DBIx-Class-0.082843/0000755000175000017500000000000014240676465013121 5ustar rabbitrabbitDBIx-Class-0.082843/lib/0000755000175000017500000000000014240676463013665 5ustar rabbitrabbitDBIx-Class-0.082843/lib/DBIx/0000755000175000017500000000000014240676463014453 5ustar rabbitrabbitDBIx-Class-0.082843/lib/DBIx/Class/0000755000175000017500000000000014240676463015520 5ustar rabbitrabbitDBIx-Class-0.082843/lib/DBIx/Class/Storage/0000755000175000017500000000000014240676463017124 5ustar rabbitrabbitDBIx-Class-0.082843/lib/DBIx/Class/Storage/DBI/0000755000175000017500000000000014240676463017522 5ustar rabbitrabbitDBIx-Class-0.082843/lib/DBIx/Class/Storage/DBI/Sybase.pm0000644000175000017500000000620714240132261021272 0ustar rabbitrabbitpackage DBIx::Class::Storage::DBI::Sybase; use strict; use warnings; use Try::Tiny; use namespace::clean; use base qw/DBIx::Class::Storage::DBI/; =head1 NAME DBIx::Class::Storage::DBI::Sybase - Base class for drivers using L =head1 DESCRIPTION This is the base class/dispatcher for Storage's designed to work with L =head1 METHODS =cut sub _rebless { my $self = shift; my $dbtype; try { $dbtype = @{$self->_get_dbh->selectrow_arrayref(qq{sp_server_info \@attribute_id=1})}[2] } catch { $self->throw_exception("Unable to establish connection to determine database type: $_") }; if ($dbtype) { $dbtype =~ s/\W/_/gi; # saner class name $dbtype = 'ASE' if $dbtype eq 'SQL_Server'; my $subclass = __PACKAGE__ . "::$dbtype"; if ($self->load_optional_class($subclass)) { bless $self, $subclass; $self->_rebless; } } } sub _init { # once the driver is determined see if we need to insert the DBD::Sybase w/ FreeTDS fixups # this is a dirty version of "instance role application", \o/ DO WANT Moo \o/ my $self = shift; if (! $self->isa('DBIx::Class::Storage::DBI::Sybase::FreeTDS') and $self->_using_freetds) { require DBIx::Class::Storage::DBI::Sybase::FreeTDS; my @isa = @{mro::get_linear_isa(ref $self)}; my $class = shift @isa; # this is our current ref my $trait_class = $class . '::FreeTDS'; mro::set_mro ($trait_class, 'c3'); no strict 'refs'; @{"${trait_class}::ISA"} = ($class, 'DBIx::Class::Storage::DBI::Sybase::FreeTDS', @isa); bless ($self, $trait_class); Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO; $self->_init(@_); } $self->next::method(@_); } sub _ping { my $self = shift; my $dbh = $self->_dbh or return 0; local $dbh->{RaiseError} = 1; local $dbh->{PrintError} = 0; ( try { $dbh->do('select 1'); 1 } ) ? 1 : 0 ; } sub _set_max_connect { my $self = shift; my $val = shift || 256; my $dsn = $self->_dbi_connect_info->[0]; return if ref($dsn) eq 'CODE'; if ($dsn !~ /maxConnect=/) { $self->_dbi_connect_info->[0] = "$dsn;maxConnect=$val"; my $connected = defined $self->_dbh; $self->disconnect; $self->ensure_connected if $connected; } } # Whether or not DBD::Sybase was compiled against FreeTDS. If false, it means # the Sybase OpenClient libraries were used. sub _using_freetds { my $self = shift; return ($self->_get_dbh->{syb_oc_version}||'') =~ /freetds/i; } # Either returns the FreeTDS version against which DBD::Sybase was compiled, # 0 if can't be determined, or undef otherwise sub _using_freetds_version { my $inf = shift->_get_dbh->{syb_oc_version}; return undef unless ($inf||'') =~ /freetds/i; return $inf =~ /v([0-9\.]+)/ ? $1 : 0; } =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. =cut 1; DBIx-Class-0.082843/lib/DBIx/Class/Storage/DBI/Replicated/0000755000175000017500000000000014240676463021576 5ustar rabbitrabbitDBIx-Class-0.082843/lib/DBIx/Class/Storage/DBI/Replicated/Types.pm0000644000175000017500000000172513271562530023235 0ustar rabbitrabbitpackage # hide from PAUSE DBIx::Class::Storage::DBI::Replicated::Types; # DBIx::Class::Storage::DBI::Replicated::Types - Types used internally by # L # Workaround for https://rt.cpan.org/Public/Bug/Display.html?id=83336 use warnings; use strict; use MooseX::Types -declare => [qw/BalancerClassNamePart Weight DBICSchema DBICStorageDBI/]; use MooseX::Types::Moose qw/ClassName Str Num/; use MooseX::Types::LoadableClass qw/LoadableClass/; class_type 'DBIx::Class::Storage::DBI'; class_type 'DBIx::Class::Schema'; subtype DBICSchema, as 'DBIx::Class::Schema'; subtype DBICStorageDBI, as 'DBIx::Class::Storage::DBI'; subtype BalancerClassNamePart, as LoadableClass; coerce BalancerClassNamePart, from Str, via { my $type = $_; $type =~ s/\A::/DBIx::Class::Storage::DBI::Replicated::Balancer::/; $type; }; subtype Weight, as Num, where { $_ >= 0 }, message { 'weight must be a decimal greater than 0' }; 1; DBIx-Class-0.082843/lib/DBIx/Class/Storage/DBI/Replicated/WithDSN.pm0000644000175000017500000000312614240132261023375 0ustar rabbitrabbitpackage DBIx::Class::Storage::DBI::Replicated::WithDSN; use Moose::Role; use Scalar::Util 'reftype'; requires qw/_query_start/; use Try::Tiny; use namespace::clean -except => 'meta'; =head1 NAME DBIx::Class::Storage::DBI::Replicated::WithDSN - A DBI Storage Role with DSN information in trace output =head1 SYNOPSIS This class is used internally by L. =head1 DESCRIPTION This role adds C info to storage debugging output. =head1 METHODS This class defines the following methods. =head2 around: _query_start Add C to debugging output. =cut around '_query_start' => sub { my ($method, $self, $sql, @bind) = @_; my $dsn = (try { $self->dsn }) || $self->_dbi_connect_info->[0]; my($op, $rest) = (($sql=~m/^(\w+)(.+)$/),'NOP', 'NO SQL'); my $storage_type = $self->can('active') ? 'REPLICANT' : 'MASTER'; my $query = do { if ((reftype($dsn)||'') ne 'CODE') { "$op [DSN_$storage_type=$dsn]$rest"; } elsif (my $id = try { $self->id }) { "$op [$storage_type=$id]$rest"; } else { "$op [$storage_type]$rest"; } }; $self->$method($query, @bind); }; =head1 ALSO SEE L =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. =cut 1; DBIx-Class-0.082843/lib/DBIx/Class/Storage/DBI/Replicated/Pool.pm0000644000175000017500000002620214240132261023026 0ustar rabbitrabbitpackage DBIx::Class::Storage::DBI::Replicated::Pool; use Moose; use DBIx::Class::Storage::DBI::Replicated::Replicant; use Scalar::Util 'reftype'; use DBI (); use MooseX::Types::Moose qw/Num Int ClassName HashRef/; use DBIx::Class::Storage::DBI::Replicated::Types 'DBICStorageDBI'; use Try::Tiny; use namespace::clean -except => 'meta'; =head1 NAME DBIx::Class::Storage::DBI::Replicated::Pool - Manage a pool of replicants =head1 SYNOPSIS This class is used internally by L. You shouldn't need to create instances of this class. =head1 DESCRIPTION In a replicated storage type, there is at least one replicant to handle the read-only traffic. The Pool class manages this replicant, or list of replicants, and gives some methods for querying information about their status. =head1 ATTRIBUTES This class defines the following attributes. =head2 maximum_lag ($num) This is a number which defines the maximum allowed lag returned by the L method. The default is 0. In general, this should return a larger number when the replicant is lagging behind its master, however the implementation of this is database specific, so don't count on this number having a fixed meaning. For example, MySQL will return a number of seconds that the replicating database is lagging. =cut has 'maximum_lag' => ( is=>'rw', isa=>Num, required=>1, lazy=>1, default=>0, ); =head2 last_validated This is an integer representing a time since the last time the replicants were validated. It's nothing fancy, just an integer provided via the perl L built-in. =cut has 'last_validated' => ( is=>'rw', isa=>Int, reader=>'last_validated', writer=>'_last_validated', lazy=>1, default=>0, ); =head2 replicant_type ($classname) Base class used to instantiate replicants that are in the pool. Unless you need to subclass L you should just leave this alone. =cut has 'replicant_type' => ( is=>'ro', isa=>ClassName, required=>1, default=>'DBIx::Class::Storage::DBI', handles=>{ 'create_replicant' => 'new', }, ); =head2 replicants A hashref of replicant, with the key being the dsn and the value returning the actual replicant storage. For example, if the $dsn element is something like: "dbi:SQLite:dbname=dbfile" You could access the specific replicant via: $schema->storage->replicants->{'dbname=dbfile'} This attributes also supports the following helper methods: =over 4 =item set_replicant($key=>$storage) Pushes a replicant onto the HashRef under $key =item get_replicant($key) Retrieves the named replicant =item has_replicants Returns true if the Pool defines replicants. =item num_replicants The number of replicants in the pool =item delete_replicant ($key) Removes the replicant under $key from the pool =back =cut has 'replicants' => ( is=>'rw', traits => ['Hash'], isa=>HashRef['Object'], default=>sub {{}}, handles => { 'set_replicant' => 'set', 'get_replicant' => 'get', 'has_replicants' => 'is_empty', 'num_replicants' => 'count', 'delete_replicant' => 'delete', 'all_replicant_storages' => 'values', }, ); around has_replicants => sub { my ($orig, $self) = @_; return !$self->$orig; }; has next_unknown_replicant_id => ( is => 'rw', traits => ['Counter'], isa => Int, default => 1, handles => { 'inc_unknown_replicant_id' => 'inc', }, ); =head2 master Reference to the master Storage. =cut has master => (is => 'rw', isa => DBICStorageDBI, weak_ref => 1); =head1 METHODS This class defines the following methods. =head2 connect_replicants ($schema, Array[$connect_info]) Given an array of $dsn or connect_info structures suitable for connected to a database, create an L object and store it in the L attribute. =cut sub connect_replicants { my $self = shift @_; my $schema = shift @_; my @newly_created = (); foreach my $connect_info (@_) { $connect_info = [ $connect_info ] if reftype $connect_info ne 'ARRAY'; my $connect_coderef = (reftype($connect_info->[0])||'') eq 'CODE' ? $connect_info->[0] : (reftype($connect_info->[0])||'') eq 'HASH' && $connect_info->[0]->{dbh_maker}; my $dsn; my $replicant = do { # yes this is evil, but it only usually happens once (for coderefs) # this will fail if the coderef does not actually DBI::connect no warnings 'redefine'; my $connect = \&DBI::connect; local *DBI::connect = sub { $dsn = $_[1]; goto $connect; }; $self->connect_replicant($schema, $connect_info); }; my $key; if (!$dsn) { if (!$connect_coderef) { $dsn = $connect_info->[0]; $dsn = $dsn->{dsn} if (reftype($dsn)||'') eq 'HASH'; } else { # all attempts to get the DSN failed $key = "UNKNOWN_" . $self->next_unknown_replicant_id; $self->inc_unknown_replicant_id; } } if ($dsn) { $replicant->dsn($dsn); ($key) = ($dsn =~ m/^dbi\:.+\:(.+)$/i); } $replicant->id($key); $self->set_replicant($key => $replicant); push @newly_created, $replicant; } return @newly_created; } =head2 connect_replicant ($schema, $connect_info) Given a schema object and a hashref of $connect_info, connect the replicant and return it. =cut sub connect_replicant { my ($self, $schema, $connect_info) = @_; my $replicant = $self->create_replicant($schema); $replicant->connect_info($connect_info); ## It is undesirable for catalyst to connect at ->conect_replicants time, as ## connections should only happen on the first request that uses the database. ## So we try to set the driver without connecting, however this doesn't always ## work, as a driver may need to connect to determine the DB version, and this ## may fail. ## ## Why this is necessary at all, is that we need to have the final storage ## class to apply the Replicant role. $self->_safely($replicant, '->_determine_driver', sub { $replicant->_determine_driver }); Moose::Meta::Class->initialize(ref $replicant); DBIx::Class::Storage::DBI::Replicated::Replicant->meta->apply($replicant); # link back to master $replicant->master($self->master); return $replicant; } =head2 _safely_ensure_connected ($replicant) The standard ensure_connected method with throw an exception should it fail to connect. For the master database this is desirable, but since replicants are allowed to fail, this behavior is not desirable. This method wraps the call to ensure_connected in an eval in order to catch any generated errors. That way a slave can go completely offline (e.g. the box itself can die) without bringing down your entire pool of databases. =cut sub _safely_ensure_connected { my ($self, $replicant, @args) = @_; return $self->_safely($replicant, '->ensure_connected', sub { $replicant->ensure_connected(@args) }); } =head2 _safely ($replicant, $name, $code) Execute C<$code> for operation C<$name> catching any exceptions and printing an error message to the C<<$replicant->debugobj>>. Returns 1 on success and undef on failure. =cut sub _safely { my ($self, $replicant, $name, $code) = @_; return try { $code->(); 1; } catch { $replicant->debugobj->print(sprintf( "Exception trying to $name for replicant %s, error is %s", $replicant->_dbi_connect_info->[0], $_) ); undef; }; } =head2 connected_replicants Returns true if there are connected replicants. Actually is overloaded to return the number of replicants. So you can do stuff like: if( my $num_connected = $storage->has_connected_replicants ) { print "I have $num_connected connected replicants"; } else { print "Sorry, no replicants."; } This method will actually test that each replicant in the L hashref is actually connected, try not to hit this 10 times a second. =cut sub connected_replicants { return scalar grep { $_->connected } shift->all_replicants ; } =head2 active_replicants This is an array of replicants that are considered to be active in the pool. This does not check to see if they are connected, but if they are not, DBIC should automatically reconnect them for us when we hit them with a query. =cut sub active_replicants { my $self = shift @_; return ( grep {$_} map { $_->active ? $_:0 } $self->all_replicants ); } =head2 all_replicants Just a simple array of all the replicant storages. No particular order to the array is given, nor should any meaning be derived. =cut sub all_replicants { my $self = shift @_; return values %{$self->replicants}; } =head2 validate_replicants This does a check to see if 1) each replicate is connected (or reconnectable), 2) that is ->is_replicating, and 3) that it is not exceeding the lag amount defined by L. Replicants that fail any of these tests are set to inactive, and thus removed from the replication pool. This tests L, since a replicant that has been previous marked as inactive can be reactivated should it start to pass the validation tests again. See L for more about checking if a replicating connection is not following a master or is lagging. Calling this method will generate queries on the replicant databases so it is not recommended that you run them very often. This method requires that your underlying storage engine supports some sort of native replication mechanism. Currently only MySQL native replication is supported. Your patches to make other replication types work are welcomed. =cut sub validate_replicants { my $self = shift @_; foreach my $replicant($self->all_replicants) { if($self->_safely_ensure_connected($replicant)) { my $is_replicating = $replicant->is_replicating; unless(defined $is_replicating) { $replicant->debugobj->print("Storage Driver ".ref($self)." Does not support the 'is_replicating' method. Assuming you are manually managing.\n"); next; } else { if($is_replicating) { my $lag_behind_master = $replicant->lag_behind_master; unless(defined $lag_behind_master) { $replicant->debugobj->print("Storage Driver ".ref($self)." Does not support the 'lag_behind_master' method. Assuming you are manually managing.\n"); next; } else { if($lag_behind_master <= $self->maximum_lag) { $replicant->active(1); } else { $replicant->active(0); } } } else { $replicant->active(0); } } } else { $replicant->active(0); } } ## Mark that we completed this validation. $self->_last_validated(time); } =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. =cut __PACKAGE__->meta->make_immutable; 1; DBIx-Class-0.082843/lib/DBIx/Class/Storage/DBI/Replicated/Balancer/0000755000175000017500000000000014240676463023305 5ustar rabbitrabbitDBIx-Class-0.082843/lib/DBIx/Class/Storage/DBI/Replicated/Balancer/Random.pm0000644000175000017500000000500313560502346025051 0ustar rabbitrabbitpackage DBIx::Class::Storage::DBI::Replicated::Balancer::Random; use Moose; with 'DBIx::Class::Storage::DBI::Replicated::Balancer'; use DBIx::Class::Storage::DBI::Replicated::Types 'Weight'; use namespace::clean -except => 'meta'; =head1 NAME DBIx::Class::Storage::DBI::Replicated::Balancer::Random - A 'random' Balancer =head1 SYNOPSIS This class is used internally by L. You shouldn't need to create instances of this class. =head1 DESCRIPTION Given a pool (L) of replicated database's (L), defines a method by which query load can be spread out across each replicant in the pool. =head1 ATTRIBUTES This class defines the following attributes. =head2 master_read_weight A number greater than 0 that specifies what weight to give the master when choosing which backend to execute a read query on. A value of 0, which is the default, does no reads from master, while a value of 1 gives it the same priority as any single replicant. For example: if you have 2 replicants, and a L of C<0.5>, the chance of reading from master will be C<20%>. You can set it to a value higher than 1, making master have higher weight than any single replicant, if for example you have a very powerful master. =cut has master_read_weight => (is => 'rw', isa => Weight, default => sub { 0 }); =head1 METHODS This class defines the following methods. =head2 next_storage Returns an active replicant at random. Please note that due to the nature of the word 'random' this means it's possible for a particular active replicant to be requested several times in a row. =cut sub next_storage { my $self = shift @_; my @replicants = $self->pool->active_replicants; if (not @replicants) { # will fall back to master anyway return; } my $master = $self->master; my $rnd = $self->_random_number(@replicants + $self->master_read_weight); return $rnd >= @replicants ? $master : $replicants[int $rnd]; } sub _random_number { rand($_[1]) } =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. =cut __PACKAGE__->meta->make_immutable; 1; DBIx-Class-0.082843/lib/DBIx/Class/Storage/DBI/Replicated/Balancer/First.pm0000644000175000017500000000272013271562530024723 0ustar rabbitrabbitpackage DBIx::Class::Storage::DBI::Replicated::Balancer::First; use Moose; with 'DBIx::Class::Storage::DBI::Replicated::Balancer'; use namespace::clean -except => 'meta'; =head1 NAME DBIx::Class::Storage::DBI::Replicated::Balancer::First - Just get the First Balancer =head1 SYNOPSIS This class is used internally by L. You shouldn't need to create instances of this class. =head1 DESCRIPTION Given a pool (L) of replicated database's (L), defines a method by which query load can be spread out across each replicant in the pool. This Balancer just gets whichever is the first replicant in the pool. =head1 ATTRIBUTES This class defines the following attributes. =head1 METHODS This class defines the following methods. =head2 next_storage Just get the first storage. Probably only good when you have one replicant. =cut sub next_storage { return (shift->pool->active_replicants)[0]; } =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. =cut __PACKAGE__->meta->make_immutable; 1; DBIx-Class-0.082843/lib/DBIx/Class/Storage/DBI/Replicated/Balancer.pm0000644000175000017500000001515313271562530023640 0ustar rabbitrabbitpackage DBIx::Class::Storage::DBI::Replicated::Balancer; use Moose::Role; requires 'next_storage'; use MooseX::Types::Moose qw/Int/; use DBIx::Class::Storage::DBI::Replicated::Pool; use DBIx::Class::Storage::DBI::Replicated::Types qw/DBICStorageDBI/; use namespace::clean -except => 'meta'; =head1 NAME DBIx::Class::Storage::DBI::Replicated::Balancer - A Software Load Balancer =head1 SYNOPSIS This role is used internally by L. =head1 DESCRIPTION Given a pool (L) of replicated database's (L), defines a method by which query load can be spread out across each replicant in the pool. =head1 ATTRIBUTES This class defines the following attributes. =head2 auto_validate_every ($seconds) If auto_validate has some sort of value, run L every $seconds. Be careful with this, because if you set it to 0 you will end up validating every query. =cut has 'auto_validate_every' => ( is=>'rw', isa=>Int, predicate=>'has_auto_validate_every', ); =head2 master The L object that is the master database all the replicants are trying to follow. The balancer needs to know it since it's the ultimate fallback. =cut has 'master' => ( is=>'ro', isa=>DBICStorageDBI, required=>1, ); =head2 pool The L object that we are trying to balance. =cut has 'pool' => ( is=>'ro', isa=>'DBIx::Class::Storage::DBI::Replicated::Pool', required=>1, ); =head2 current_replicant Replicant storages (slaves) handle all read only traffic. The assumption is that your database will become readbound well before it becomes write bound and that being able to spread your read only traffic around to multiple databases is going to help you to scale traffic. This attribute returns the next slave to handle a read request. Your L attribute has methods to help you shuffle through all the available replicants via its balancer object. =cut has 'current_replicant' => ( is=> 'rw', isa=>DBICStorageDBI, lazy_build=>1, handles=>[qw/ select select_single columns_info_for /], ); =head1 METHODS This class defines the following methods. =head2 _build_current_replicant Lazy builder for the L attribute. =cut sub _build_current_replicant { my $self = shift @_; $self->next_storage; } =head2 next_storage This method should be defined in the class which consumes this role. Given a pool object, return the next replicant that will serve queries. The default behavior is to grab the first replicant it finds but you can write your own subclasses of L to support other balance systems. This returns from the pool of active replicants. If there are no active replicants, then you should have it return the master as an ultimate fallback. =head2 around: next_storage Advice on next storage to add the autovalidation. We have this broken out so that it's easier to break out the auto validation into a role. This also returns the master in the case that none of the replicants are active or just forgot to create them :) =cut my $on_master; around 'next_storage' => sub { my ($next_storage, $self, @args) = @_; my $now = time; ## Do we need to validate the replicants? if( $self->has_auto_validate_every && ($self->auto_validate_every + $self->pool->last_validated) <= $now ) { $self->pool->validate_replicants; } ## Get a replicant, or the master if none if(my $next = $self->$next_storage(@args)) { $self->master->debugobj->print("Moved back to slave\n") if $on_master; $on_master = 0; return $next; } else { $self->master->debugobj->print("No Replicants validate, falling back to master reads.\n") unless $on_master++; return $self->master; } }; =head2 increment_storage Rolls the Storage to whatever is next in the queue, as defined by the Balancer. =cut sub increment_storage { my $self = shift @_; my $next_replicant = $self->next_storage; $self->current_replicant($next_replicant); } =head2 around: select Advice on the select attribute. Each time we use a replicant we need to change it via the storage pool algorithm. That way we are spreading the load evenly (hopefully) across existing capacity. =cut around 'select' => sub { my ($select, $self, @args) = @_; if (my $forced_pool = $args[-1]->{force_pool}) { delete $args[-1]->{force_pool}; return $self->_get_forced_pool($forced_pool)->select(@args); } elsif($self->master->{transaction_depth}) { return $self->master->select(@args); } else { $self->increment_storage; return $self->$select(@args); } }; =head2 around: select_single Advice on the select_single attribute. Each time we use a replicant we need to change it via the storage pool algorithm. That way we are spreading the load evenly (hopefully) across existing capacity. =cut around 'select_single' => sub { my ($select_single, $self, @args) = @_; if (my $forced_pool = $args[-1]->{force_pool}) { delete $args[-1]->{force_pool}; return $self->_get_forced_pool($forced_pool)->select_single(@args); } elsif($self->master->{transaction_depth}) { return $self->master->select_single(@args); } else { $self->increment_storage; return $self->$select_single(@args); } }; =head2 before: columns_info_for Advice on the current_replicant_storage attribute. Each time we use a replicant we need to change it via the storage pool algorithm. That way we are spreading the load evenly (hopefully) across existing capacity. =cut before 'columns_info_for' => sub { my $self = shift @_; $self->increment_storage; }; =head2 _get_forced_pool ($name) Given an identifier, find the most correct storage object to handle the query. =cut sub _get_forced_pool { my ($self, $forced_pool) = @_; if(blessed $forced_pool) { return $forced_pool; } elsif($forced_pool eq 'master') { return $self->master; } elsif(my $replicant = $self->pool->replicants->{$forced_pool}) { return $replicant; } else { $self->master->throw_exception("'$forced_pool' is not a named replicant."); } } =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. =cut 1; DBIx-Class-0.082843/lib/DBIx/Class/Storage/DBI/Replicated/Replicant.pm0000644000175000017500000000531413271562530024050 0ustar rabbitrabbitpackage DBIx::Class::Storage::DBI::Replicated::Replicant; use Moose::Role; requires qw/_query_start/; with 'DBIx::Class::Storage::DBI::Replicated::WithDSN'; use MooseX::Types::Moose qw/Bool Str/; use DBIx::Class::Storage::DBI::Replicated::Types 'DBICStorageDBI'; use namespace::clean -except => 'meta'; =head1 NAME DBIx::Class::Storage::DBI::Replicated::Replicant - A replicated DBI Storage Role =head1 SYNOPSIS This class is used internally by L. =head1 DESCRIPTION Replicants are DBI Storages that follow a master DBI Storage. Typically this is accomplished via an external replication system. Please see the documents for L for more details. This class exists to define methods of a DBI Storage that only make sense when it's a classic 'slave' in a pool of slave databases which replicate from a given master database. =head1 ATTRIBUTES This class defines the following attributes. =head2 active This is a boolean which allows you to programmatically activate or deactivate a replicant from the pool. This way you can do stuff like disallow a replicant when it gets too far behind the master, if it stops replicating, etc. This attribute DOES NOT reflect a replicant's internal status, i.e. if it is properly replicating from a master and has not fallen too many seconds behind a reliability threshold. For that, use L and L. Since the implementation of those functions database specific (and not all DBIC supported DBs support replication) you should refer your database-specific storage driver for more information. =cut has 'active' => ( is=>'rw', isa=>Bool, lazy=>1, required=>1, default=>1, ); has dsn => (is => 'rw', isa => Str); has id => (is => 'rw', isa => Str); =head2 master Reference to the master Storage. =cut has master => (is => 'rw', isa => DBICStorageDBI, weak_ref => 1); =head1 METHODS This class defines the following methods. =head2 debugobj Override the debugobj method to redirect this method call back to the master. =cut sub debugobj { my $self = shift; return $self->master->debugobj; } =head1 ALSO SEE L, L =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. =cut 1; DBIx-Class-0.082843/lib/DBIx/Class/Storage/DBI/Replicated/Introduction.pod0000644000175000017500000002111614240132261024743 0ustar rabbitrabbit=head1 NAME DBIx::Class::Storage::DBI::Replicated::Introduction - Minimum Need to Know =head1 SYNOPSIS This is an introductory document for L. This document is not an overview of what replication is or why you should be using it. It is not a document explaining how to setup MySQL native replication either. Copious external resources are available for both. This document presumes you have the basics down. =head1 DESCRIPTION L supports a framework for using database replication. This system is integrated completely, which means once it's setup you should be able to automatically just start using a replication cluster without additional work or changes to your code. Some caveats apply, primarily related to the proper use of transactions (you are wrapping all your database modifying statements inside a transaction, right ;) ) however in our experience properly written DBIC will work transparently with Replicated storage. Currently we have support for MySQL native replication, which is relatively easy to install and configure. We also currently support single master to one or more replicants (also called 'slaves' in some documentation). However the framework is not specifically tied to the MySQL framework and supporting other replication systems or topographies should be possible. Please bring your patches and ideas to the #dbix-class IRC channel or the mailing list. For an easy way to start playing with MySQL native replication, see: L. If you are using this with a L based application, you may also want to see more recent updates to L, which has support for replication configuration options as well. =head1 REPLICATED STORAGE By default, when you start L, your Schema (L) is assigned a storage_type, which when fully connected will reflect your underlying storage engine as defined by your chosen database driver. For example, if you connect to a MySQL database, your storage_type will be L Your storage type class will contain database specific code to help smooth over the differences between databases and let L do its thing. If you want to use replication, you will override this setting so that the replicated storage engine will 'wrap' your underlying storages and present a unified interface to the end programmer. This wrapper storage class will delegate method calls to either a master database or one or more replicated databases based on if they are read only (by default sent to the replicants) or write (reserved for the master). Additionally, the Replicated storage will monitor the health of your replicants and automatically drop them should one exceed configurable parameters. Later, it can automatically restore a replicant when its health is restored. This gives you a very robust system, since you can add or drop replicants and DBIC will automatically adjust itself accordingly. Additionally, if you need high data integrity, such as when you are executing a transaction, replicated storage will automatically delegate all database traffic to the master storage. There are several ways to enable this high integrity mode, but wrapping your statements inside a transaction is the easy and canonical option. =head1 PARTS OF REPLICATED STORAGE A replicated storage contains several parts. First, there is the replicated storage itself (L). A replicated storage takes a pool of replicants (L) and a software balancer (L). The balancer does the job of splitting up all the read traffic amongst the replicants in the Pool. Currently there are two types of balancers, a Random one which chooses a Replicant in the Pool using a naive randomizer algorithm, and a First replicant, which just uses the first one in the Pool (and obviously is only of value when you have a single replicant). =head1 REPLICATED STORAGE CONFIGURATION All the parts of replication can be altered dynamically at runtime, which makes it possibly to create a system that automatically scales under load by creating more replicants as needed, perhaps using a cloud system such as Amazon EC2. However, for common use you can setup your replicated storage to be enabled at the time you connect the databases. The following is a breakdown of how you may wish to do this. Again, if you are using L, I strongly recommend you use (or upgrade to) the latest L, which makes this job even easier. First, you need to get a C<$schema> object and set the storage_type: my $schema = MyApp::Schema->clone; $schema->storage_type([ '::DBI::Replicated' => { balancer_type => '::Random', balancer_args => { auto_validate_every => 5, master_read_weight => 1 }, pool_args => { maximum_lag =>2, }, } ]); Then, you need to connect your L. $schema->connection($dsn, $user, $pass); Let's break down the settings. The method L takes one mandatory parameter, a scalar value, and an option second value which is a Hash Reference of configuration options for that storage. In this case, we are setting the Replicated storage type using '::DBI::Replicated' as the first value. You will only use a different value if you are subclassing the replicated storage, so for now just copy that first parameter. The second parameter contains a hash reference of stuff that gets passed to the replicated storage. L is the type of software load balancer you will use to split up traffic among all your replicants. Right now we have two options, "::Random" and "::First". You can review documentation for both at: L, L. In this case we will have three replicants, so the ::Random option is the only one that makes sense. 'balancer_args' get passed to the balancer when it's instantiated. All balancers have the 'auto_validate_every' option. This is the number of seconds we allow to pass between validation checks on a load balanced replicant. So the higher the number, the more possibility that your reads to the replicant may be inconsistent with what's on the master. Setting this number too low will result in increased database loads, so choose a number with care. Our experience is that setting the number around 5 seconds results in a good performance / integrity balance. 'master_read_weight' is an option associated with the ::Random balancer. It allows you to let the master be read from. I usually leave this off (default is off). The 'pool_args' are configuration options associated with the replicant pool. This object (L) manages all the declared replicants. 'maximum_lag' is the number of seconds a replicant is allowed to lag behind the master before being temporarily removed from the pool. Keep in mind that the Balancer option 'auto_validate_every' determines how often a replicant is tested against this condition, so the true possible lag can be higher than the number you set. The default is zero. No matter how low you set the maximum_lag or the auto_validate_every settings, there is always the chance that your replicants will lag a bit behind the master for the supported replication system built into MySQL. You can ensure reliable reads by using a transaction, which will force both read and write activity to the master, however this will increase the load on your master database. After you've configured the replicated storage, you need to add the connection information for the replicants: $schema->storage->connect_replicants( [$dsn1, $user, $pass, \%opts], [$dsn2, $user, $pass, \%opts], [$dsn3, $user, $pass, \%opts], ); These replicants should be configured as slaves to the master using the instructions for MySQL native replication, or if you are just learning, you will find L an easy way to set up a replication cluster. And now your $schema object is properly configured! Enjoy! =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. DBIx-Class-0.082843/lib/DBIx/Class/Storage/DBI/AutoCast.pm0000644000175000017500000000433613271562530021601 0ustar rabbitrabbitpackage DBIx::Class::Storage::DBI::AutoCast; use strict; use warnings; use base qw/DBIx::Class::Storage::DBI/; use mro 'c3'; __PACKAGE__->mk_group_accessors('simple' => 'auto_cast' ); =head1 NAME DBIx::Class::Storage::DBI::AutoCast - Storage component for RDBMS requiring explicit placeholder typing =head1 SYNOPSIS $schema->storage->auto_cast(1); =head1 DESCRIPTION In some combinations of RDBMS and DBD drivers (e.g. FreeTDS and Sybase) statements with values bound to columns or conditions that are not strings will throw implicit type conversion errors. As long as a column L is defined and resolves to a base RDBMS native type via L<_native_data_type|DBIx::Class::Storage::DBI/_native_data_type> as defined in your Storage driver, the placeholder for this column will be converted to: CAST(? as $mapped_type) This option can also be enabled in L as: on_connect_call => ['set_auto_cast'] =cut sub _prep_for_execute { my $self = shift; my ($sql, $bind) = $self->next::method (@_); # If we're using ::NoBindVars, there are no binds by this point so this code # gets skipped. if ($self->auto_cast && @$bind) { my $new_sql; my @sql_part = split /\?/, $sql, scalar @$bind + 1; for (@$bind) { my $cast_type = $self->_native_data_type($_->[0]{sqlt_datatype}); $new_sql .= shift(@sql_part) . ($cast_type ? "CAST(? AS $cast_type)" : '?'); } $sql = $new_sql . shift @sql_part; } return ($sql, $bind); } =head2 connect_call_set_auto_cast Executes: $schema->storage->auto_cast(1); on connection. Used as: on_connect_call => ['set_auto_cast'] in L. =cut sub connect_call_set_auto_cast { my $self = shift; $self->auto_cast(1); } =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. =cut 1; DBIx-Class-0.082843/lib/DBIx/Class/Storage/DBI/ADO.pm0000644000175000017500000000453014240132261020444 0ustar rabbitrabbitpackage DBIx::Class::Storage::DBI::ADO; use warnings; use strict; use base 'DBIx::Class::Storage::DBI'; use mro 'c3'; use Sub::Name; use Try::Tiny; use DBIx::Class::_Util 'sigwarn_silencer'; use namespace::clean; =head1 NAME DBIx::Class::Storage::DBI::ADO - Support for L =head1 DESCRIPTION This class provides a mechanism for discovering and loading a sub-class for a specific ADO backend, as well as some workarounds for L. It should be transparent to the user. =cut sub _rebless { shift->_determine_connector_driver('ADO') } # cleanup some warnings from DBD::ADO # RT#65563, not fixed as of DBD::ADO v2.98 sub _dbh_get_info { my $self = shift; local $SIG{__WARN__} = sigwarn_silencer( qr{^Missing argument in sprintf at \S+/ADO/GetInfo\.pm} ); $self->next::method(@_); } # Monkeypatch out the horrible warnings during global destruction. # A patch to DBD::ADO has been submitted as well, and it was fixed # as of 2.99 # https://rt.cpan.org/Ticket/Display.html?id=65563 sub _init { unless ($DBD::ADO::__DBIC_MONKEYPATCH_CHECKED__) { require DBD::ADO; unless (try { DBD::ADO->VERSION('2.99'); 1 }) { no warnings 'redefine'; my $disconnect = *DBD::ADO::db::disconnect{CODE}; *DBD::ADO::db::disconnect = subname 'DBD::ADO::db::disconnect' => sub { local $SIG{__WARN__} = sigwarn_silencer( qr/Not a Win32::OLE object|uninitialized value/ ); $disconnect->(@_); }; } $DBD::ADO::__DBIC_MONKEYPATCH_CHECKED__ = 1; } } # Here I was just experimenting with ADO cursor types, left in as a comment in # case you want to as well. See the DBD::ADO docs. #sub _prepare_sth { # my ($self, $dbh, $sql) = @_; # # my $sth = $self->disable_sth_caching # ? $dbh->prepare($sql, { CursorType => 'adOpenStatic' }) # : $dbh->prepare_cached($sql, { CursorType => 'adOpenStatic' }, 3); # # $self->throw_exception($dbh->errstr) if !$sth; # # $sth; #} =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. =cut 1; # vim:sts=2 sw=2: DBIx-Class-0.082843/lib/DBIx/Class/Storage/DBI/ADO/0000755000175000017500000000000014240676463020125 5ustar rabbitrabbitDBIx-Class-0.082843/lib/DBIx/Class/Storage/DBI/ADO/MS_Jet.pm0000644000175000017500000001116114240132261021563 0ustar rabbitrabbitpackage DBIx::Class::Storage::DBI::ADO::MS_Jet; use strict; use warnings; use base qw/ DBIx::Class::Storage::DBI::ADO DBIx::Class::Storage::DBI::ACCESS /; use mro 'c3'; use DBIx::Class::Storage::DBI::ADO::CursorUtils '_normalize_guids'; use namespace::clean; __PACKAGE__->cursor_class('DBIx::Class::Storage::DBI::ADO::MS_Jet::Cursor'); =head1 NAME DBIx::Class::Storage::DBI::ADO::MS_Jet - Support for MS Access over ADO =head1 DESCRIPTION This driver is a subclass of L and L for connecting to MS Access via L. See the documentation for L for information on the MS Access driver for L. This driver implements workarounds for C columns, sets the L to L to normalize returned C values and provides L support for C columns. =head1 EXAMPLE DSNs # older Access versions: dbi:ADO:Microsoft.Jet.OLEDB.4.0;Data Source=C:\Users\rkitover\Documents\access_sample.accdb # newer Access versions: dbi:ADO:Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\Users\rkitover\Documents\access_sample.accdb;Persist Security Info=False' =head1 TEXT/IMAGE/MEMO COLUMNS The ADO driver does not suffer from the L the L driver has with these types of columns. You can use them safely. When you execute a C statement over this driver with a C column, it will be converted to C, while in the L driver it is converted to C. However, the caveat about L having to be twice the max size of your largest C column C<+1> still applies. L sets L to a large value by default, so it should be safe to just leave it unset. If you do pass a L in your L, it will be multiplied by two and C<1> added, just as for the L driver. =cut # set LongReadLen = LongReadLen * 2 + 1 (see docs on MEMO) sub _run_connection_actions { my $self = shift; my $long_read_len = $self->_dbh->{LongReadLen}; # This is the DBD::ADO default. if ($long_read_len != 2147483647) { $self->_dbh->{LongReadLen} = $long_read_len * 2 + 1; } return $self->next::method(@_); } # AutoCommit does not get reset properly after transactions for some reason # (probably because of my nested transaction hacks in ACCESS.pm) fix it up # here. sub _exec_txn_commit { my $self = shift; $self->next::method(@_); $self->_dbh->{AutoCommit} = $self->_dbh_autocommit if $self->{transaction_depth} == 1; } sub _exec_txn_rollback { my $self = shift; $self->next::method(@_); $self->_dbh->{AutoCommit} = $self->_dbh_autocommit if $self->{transaction_depth} == 1; } # Fix up GUIDs for ->find, for cursors see the cursor_class above. sub select_single { my $self = shift; my ($ident, $select) = @_; my @row = $self->next::method(@_); return @row unless $self->cursor_class->isa('DBIx::Class::Storage::DBI::ADO::MS_Jet::Cursor'); my $col_infos = $self->_resolve_column_info($ident); _normalize_guids($select, $col_infos, \@row, $self); return @row; } sub datetime_parser_type { 'DBIx::Class::Storage::DBI::ADO::MS_Jet::DateTime::Format' } package # hide from PAUSE DBIx::Class::Storage::DBI::ADO::MS_Jet::DateTime::Format; my $datetime_format = '%m/%d/%Y %I:%M:%S %p'; my $datetime_parser; sub parse_datetime { shift; require DateTime::Format::Strptime; $datetime_parser ||= DateTime::Format::Strptime->new( pattern => $datetime_format, on_error => 'croak', ); return $datetime_parser->parse_datetime(shift); } sub format_datetime { shift; require DateTime::Format::Strptime; $datetime_parser ||= DateTime::Format::Strptime->new( pattern => $datetime_format, on_error => 'croak', ); return $datetime_parser->format_datetime(shift); } =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. =cut 1; # vim:sts=2 sw=2: DBIx-Class-0.082843/lib/DBIx/Class/Storage/DBI/ADO/MS_Jet/0000755000175000017500000000000014240676463021246 5ustar rabbitrabbitDBIx-Class-0.082843/lib/DBIx/Class/Storage/DBI/ADO/MS_Jet/Cursor.pm0000644000175000017500000000400414240132261023036 0ustar rabbitrabbitpackage DBIx::Class::Storage::DBI::ADO::MS_Jet::Cursor; use strict; use warnings; use base 'DBIx::Class::Storage::DBI::Cursor'; use mro 'c3'; use DBIx::Class::Storage::DBI::ADO::CursorUtils '_normalize_guids'; use namespace::clean; =head1 NAME DBIx::Class::Storage::DBI::ADO::MS_Jet::Cursor - GUID Support for MS Access over ADO =head1 DESCRIPTION This class is for normalizing GUIDs retrieved from Microsoft Access over ADO. You probably don't want to be here, see L for information on the Microsoft Access driver. Unfortunately when using L, GUIDs come back wrapped in braces, the purpose of this class is to remove them. L sets L to this class by default. It is overridable via your L. You can use L safely with this class and not lose the GUID normalizing functionality, L<::Cursor::Cached|DBIx::Class::Cursor::Cached> uses the underlying class data for the inner cursor class. =cut sub next { my $self = shift; my @row = $self->next::method(@_); _normalize_guids( $self->args->[1], $self->{_colinfos} ||= $self->storage->_resolve_column_info($self->args->[0]), \@row, $self->storage ); return @row; } sub all { my $self = shift; my @rows = $self->next::method(@_); _normalize_guids( $self->args->[1], $self->{_colinfos} ||= $self->storage->_resolve_column_info($self->args->[0]), $_, $self->storage ) for @rows; return @rows; } =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. =cut 1; # vim:sts=2 sw=2: DBIx-Class-0.082843/lib/DBIx/Class/Storage/DBI/ADO/Microsoft_SQL_Server.pm0000644000175000017500000002702014240132261024455 0ustar rabbitrabbitpackage DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server; use strict; use warnings; use base qw/ DBIx::Class::Storage::DBI::ADO DBIx::Class::Storage::DBI::MSSQL /; use mro 'c3'; use DBIx::Class::Carp; use DBIx::Class::Storage::DBI::ADO::CursorUtils qw/_normalize_guids _strip_trailing_binary_nulls/; use namespace::clean; __PACKAGE__->cursor_class( 'DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server::Cursor' ); __PACKAGE__->datetime_parser_type ( 'DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server::DateTime::Format' ); __PACKAGE__->new_guid(sub { my $self = shift; my $guid = $self->_get_dbh->selectrow_array('SELECT NEWID()'); $guid =~ s/\A \{ (.+) \} \z/$1/xs; return $guid; }); =head1 NAME DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server - Support for Microsoft SQL Server via DBD::ADO =head1 SYNOPSIS This subclass supports MSSQL server connections via L. =head1 DESCRIPTION The MSSQL specific functionality is provided by L. =head1 EXAMPLE DSN dbi:ADO:provider=sqlncli10;server=EEEBOX\SQLEXPRESS =head1 CAVEATS =head2 identities C<_identity_method> is set to C<@@identity>, as C doesn't work with L. See L for caveats regarding this. =head2 truncation bug There is a bug with MSSQL ADO providers where data gets truncated based on the size of the bind sizes in the first prepare call: L The C workaround is used (see L) with the approximate maximum size of the data_type of the bound column, or 8000 (maximum VARCHAR size) if the data_type is not available. Please report problems with this driver and send patches. =head2 LongReadLen C is set to C on connection as it is necessary for some LOB types. Be aware of this if you localize this value on the C<$dbh> directly. =head2 binary data Due perhaps to the ado_size workaround we use, and/or other reasons, binary data such as C column data comes back padded with trailing C chars. The Cursor class for this driver (L) removes them, of course if your binary data is actually C padded that may be an issue to keep in mind when using this driver. =head2 uniqueidentifier columns uniqueidentifier columns come back from ADO wrapped in braces and must be submitted to the MSSQL ADO driver wrapped in braces. We take care of this transparently in this driver and the associated Cursor class (L) so that you don't have to use braces in most cases (except in literal SQL, in those cases you will have to add the braces yourself.) =head2 fractional seconds Fractional seconds with L are not currently supported, datetimes are truncated at the second. =cut sub _init { my $self = shift; # SCOPE_IDENTITY() doesn't work $self->_identity_method('@@identity'); $self->_no_scope_identity_query(1); return $self->next::method(@_); } sub _run_connection_actions { my $self = shift; # make transactions work require DBD::ADO::Const; $self->_dbh->{ado_conn}{CursorLocation} = DBD::ADO::Const->Enums->{CursorLocationEnum}{adUseClient}; # set LongReadLen = LongReadLen * 2 + 1 # this may need to be in ADO.pm, being conservative for now... my $long_read_len = $self->_dbh->{LongReadLen}; # This is the DBD::ADO default. if ($long_read_len != 2147483647) { $self->_dbh->{LongReadLen} = $long_read_len * 2 + 1; } return $self->next::method(@_); } # Fix up binary data and GUIDs for ->find, for cursors see the cursor_class # above. sub select_single { my $self = shift; my ($ident, $select) = @_; my @row = $self->next::method(@_); return @row unless $self->cursor_class->isa( 'DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server::Cursor' ); my $col_infos = $self->_resolve_column_info($ident); _normalize_guids($select, $col_infos, \@row, $self); _strip_trailing_binary_nulls($select, $col_infos, \@row, $self); return @row; } # We need to catch VARCHAR(max) before bind_attribute_by_data_type because it # could be specified by size, also if bind_attribute_by_data_type fails we want # to specify the default ado_size of 8000. # Also make sure GUID binds have braces on them or else ADO throws an "Invalid # character value for cast specification" sub _dbi_attrs_for_bind { my $self = shift; my ($ident, $bind) = @_; my $lob_max = $self->_get_dbh->{LongReadLen} || 32768; foreach my $bind (@$bind) { my $attrs = $bind->[0]; my $data_type = $attrs->{sqlt_datatype}; my $size = $attrs->{sqlt_size}; if ($size && lc($size) eq 'max') { if ($data_type =~ /^(?:varchar|character varying|nvarchar|national char varying|national character varying|varbinary)\z/i) { $attrs->{dbd_attrs} = { ado_size => $lob_max }; } else { carp_unique "bizarre data_type '$data_type' with size => 'max'"; } } if ($self->_is_guid_type($data_type) && substr($bind->[1], 0, 1) ne '{') { $bind->[1] = '{' . $bind->[1] . '}'; } } my $attrs = $self->next::method(@_); foreach my $attr (@$attrs) { $attr->{ado_size} ||= 8000 if $attr; } return $attrs; } # Can't edit all the binds in _dbi_attrs_for_bind for _insert_bulk, so we take # care of those GUIDs here. sub _insert_bulk { my $self = shift; my ($source, $cols, $data) = @_; my $columns_info = $source->columns_info($cols); my $col_idx = 0; foreach my $col (@$cols) { if ($self->_is_guid_type($columns_info->{$col}{data_type})) { foreach my $data_row (@$data) { if (substr($data_row->[$col_idx], 0, 1) ne '{') { $data_row->[$col_idx] = '{' . $data_row->[$col_idx] . '}'; } } } $col_idx++; } return $self->next::method(@_); } sub bind_attribute_by_data_type { my ($self, $data_type) = @_; $data_type = lc $data_type; my $max_size = $self->_mssql_max_data_type_representation_size_in_bytes->{$data_type}; my $res = {}; if ($max_size) { $res->{ado_size} = $max_size; } else { carp_unique "could not map data_type '$data_type' to a max size for ado_size: defaulting to 8000"; } return $res; } # FIXME This list is an abomination. We need a way to do this outside # of the scope of DBIC, as it is right now nobody will ever think to # even look here to diagnose some sort of misbehavior. sub _mssql_max_data_type_representation_size_in_bytes { my $self = shift; my $lob_max = $self->_get_dbh->{LongReadLen} || 32768; return +{ # MSSQL types char => 8000, character => 8000, varchar => 8000, 'varchar(max)' => $lob_max, 'character varying' => 8000, binary => 8000, varbinary => 8000, 'varbinary(max)' => $lob_max, nchar => 16000, 'national character' => 16000, 'national char' => 16000, nvarchar => 16000, 'nvarchar(max)' => ($lob_max*2), 'national character varying' => 16000, 'national char varying' => 16000, numeric => 100, smallint => 100, tinyint => 100, smallmoney => 100, bigint => 100, bit => 100, decimal => 100, dec => 100, integer => 100, int => 100, 'int identity' => 100, 'integer identity' => 100, money => 100, float => 100, double => 100, 'double precision' => 100, real => 100, uniqueidentifier => 100, ntext => $lob_max, text => $lob_max, image => $lob_max, date => 100, datetime => 100, datetime2 => 100, datetimeoffset => 100, smalldatetime => 100, time => 100, timestamp => 100, cursor => 100, hierarchyid => 100, rowversion => 100, sql_variant => 100, table => $lob_max, xml => $lob_max, # mysql types bool => 100, boolean => 100, 'tinyint unsigned' => 100, 'smallint unsigned' => 100, 'mediumint unsigned' => 100, 'int unsigned' => 100, 'integer unsigned' => 100, 'bigint unsigned' => 100, 'float unsigned' => 100, 'double unsigned' => 100, 'double precision unsigned' => 100, 'decimal unsigned' => 100, 'fixed' => 100, 'year' => 100, tinyblob => $lob_max, tinytext => $lob_max, blob => $lob_max, text => $lob_max, mediumblob => $lob_max, mediumtext => $lob_max, longblob => $lob_max, longtext => $lob_max, enum => 100, set => 8000, # Pg types serial => 100, bigserial => 100, int8 => 100, integer8 => 100, serial8 => 100, int4 => 100, integer4 => 100, serial4 => 100, int2 => 100, integer2 => 100, float8 => 100, float4 => 100, 'bit varying' => 8000, 'varbit' => 8000, inet => 100, cidr => 100, macaddr => 100, 'time without time zone' => 100, 'time with time zone' => 100, 'timestamp without time zone' => 100, 'timestamp with time zone' => 100, bytea => $lob_max, # DB2 types graphic => 8000, vargraphic => 8000, 'long vargraphic' => $lob_max, dbclob => $lob_max, clob => $lob_max, 'char for bit data' => 8000, 'varchar for bit data' => 8000, 'long varchar for bit data' => $lob_max, # oracle types varchar2 => 8000, binary_float => 100, binary_double => 100, raw => 8000, nclob => $lob_max, long => $lob_max, 'long raw' => $lob_max, 'timestamp with local time zone' => 100, # Sybase ASE types unitext => $lob_max, unichar => 16000, univarchar => 16000, # SQL Anywhere types 'long varbit' => $lob_max, 'long bit varying' => $lob_max, uniqueidentifierstr => 100, 'long binary' => $lob_max, 'long varchar' => $lob_max, 'long nvarchar' => $lob_max, # Firebird types 'char(x) character set unicode_fss' => 16000, 'varchar(x) character set unicode_fss' => 16000, 'blob sub_type text' => $lob_max, 'blob sub_type text character set unicode_fss' => $lob_max, # Informix types smallfloat => 100, byte => $lob_max, lvarchar => 8000, 'datetime year to fraction(5)' => 100, # FIXME add other datetime types # MS Access types autoincrement => 100, long => 100, integer4 => 100, integer2 => 100, integer1 => 100, logical => 100, logical1 => 100, yesno => 100, currency => 100, single => 100, ieeesingle => 100, ieeedouble => 100, number => 100, string => 8000, guid => 100, longchar => $lob_max, memo => $lob_max, longbinary => $lob_max, } } package # hide from PAUSE DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server::DateTime::Format; my $datetime_format = '%m/%d/%Y %I:%M:%S %p'; my $datetime_parser; sub parse_datetime { shift; require DateTime::Format::Strptime; $datetime_parser ||= DateTime::Format::Strptime->new( pattern => $datetime_format, on_error => 'croak', ); return $datetime_parser->parse_datetime(shift); } sub format_datetime { shift; require DateTime::Format::Strptime; $datetime_parser ||= DateTime::Format::Strptime->new( pattern => $datetime_format, on_error => 'croak', ); return $datetime_parser->format_datetime(shift); } =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. =cut 1; # vim:sts=2 sw=2: DBIx-Class-0.082843/lib/DBIx/Class/Storage/DBI/ADO/Microsoft_SQL_Server/0000755000175000017500000000000014240676463024137 5ustar rabbitrabbitDBIx-Class-0.082843/lib/DBIx/Class/Storage/DBI/ADO/Microsoft_SQL_Server/Cursor.pm0000644000175000017500000000525414240132261025737 0ustar rabbitrabbitpackage DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server::Cursor; use strict; use warnings; use base 'DBIx::Class::Storage::DBI::Cursor'; use mro 'c3'; use DBIx::Class::Storage::DBI::ADO::CursorUtils qw/_normalize_guids _strip_trailing_binary_nulls/; use namespace::clean; =head1 NAME DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server::Cursor - Remove trailing NULLs in binary data and normalize GUIDs for MSSQL over ADO =head1 DESCRIPTION This class is for removing trailing Cs from binary data and removing braces from GUIDs retrieved from Microsoft SQL Server over ADO. You probably don't want to be here, see L for information on the Microsoft SQL Server driver for ADO and L for the Microsoft SQL Server driver base class. Unfortunately when using L, binary data comes back padded with trailing Cs and GUIDs come back wrapped in braces, the purpose of this class is to remove the Cs and braces. L sets L to this class by default. It is overridable via your L. You can use L safely with this class and not lose the binary data normalizing functionality, L<::Cursor::Cached|DBIx::Class::Cursor::Cached> uses the underlying class data for the inner cursor class. =cut sub next { my $self = shift; my @row = $self->next::method(@_); $self->{_colinfos} ||= $self->storage->_resolve_column_info($self->args->[0]); _normalize_guids( $self->args->[1], $self->{_colinfos}, \@row, $self->storage ); _strip_trailing_binary_nulls( $self->args->[1], $self->{_colinfos}, \@row, $self->storage ); return @row; } sub all { my $self = shift; my @rows = $self->next::method(@_); $self->{_colinfos} ||= $self->storage->_resolve_column_info($self->args->[0]); for (@rows) { _normalize_guids( $self->args->[1], $self->{_colinfos}, $_, $self->storage ); _strip_trailing_binary_nulls( $self->args->[1], $self->{_colinfos}, $_, $self->storage ); } return @rows; } =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. =cut 1; # vim:sts=2 sw=2: DBIx-Class-0.082843/lib/DBIx/Class/Storage/DBI/ADO/CursorUtils.pm0000644000175000017500000000163212757225440022757 0ustar rabbitrabbitpackage # hide from PAUSE DBIx::Class::Storage::DBI::ADO::CursorUtils; use strict; use warnings; use base 'Exporter'; our @EXPORT_OK = qw/_normalize_guids _strip_trailing_binary_nulls/; sub _strip_trailing_binary_nulls { my ($select, $col_infos, $data, $storage) = @_; foreach my $select_idx (0..$#$select) { next unless defined $data->[$select_idx]; my $data_type = $col_infos->{$select->[$select_idx]}{data_type} or next; $data->[$select_idx] =~ s/\0+\z// if $storage->_is_binary_type($data_type); } } sub _normalize_guids { my ($select, $col_infos, $data, $storage) = @_; foreach my $select_idx (0..$#$select) { next unless defined $data->[$select_idx]; my $data_type = $col_infos->{$select->[$select_idx]}{data_type} or next; $data->[$select_idx] =~ s/\A \{ (.+) \} \z/$1/xs if $storage->_is_guid_type($data_type); } } 1; # vim:sts=2 sw=2: DBIx-Class-0.082843/lib/DBIx/Class/Storage/DBI/ODBC/0000755000175000017500000000000014240676463020231 5ustar rabbitrabbitDBIx-Class-0.082843/lib/DBIx/Class/Storage/DBI/ODBC/ACCESS.pm0000644000175000017500000001044613271562530021525 0ustar rabbitrabbitpackage DBIx::Class::Storage::DBI::ODBC::ACCESS; use strict; use warnings; use base qw/ DBIx::Class::Storage::DBI::ODBC DBIx::Class::Storage::DBI::ACCESS /; use mro 'c3'; __PACKAGE__->mk_group_accessors(inherited => 'disable_sth_caching_for_image_insert_or_update' ); __PACKAGE__->disable_sth_caching_for_image_insert_or_update(1); =head1 NAME DBIx::Class::Storage::DBI::ODBC::ACCESS - Support specific to MS Access over ODBC =head1 DESCRIPTION This class implements support specific to Microsoft Access over ODBC. It is a subclass of L and L, see those classes for more information. It is loaded automatically by L when it detects a MS Access back-end. This driver implements workarounds for C and C columns, and L support for C columns. =head1 EXAMPLE DSN dbi:ODBC:driver={Microsoft Access Driver (*.mdb, *.accdb)};dbq=C:\Users\rkitover\Documents\access_sample.accdb =head1 TEXT/IMAGE/MEMO COLUMNS Avoid using C columns as they will be truncated to 255 bytes. Some other drivers (like L) will automatically convert C columns to C, but the ODBC driver does not. C columns work correctly, but the statements for inserting or updating an C column will not be L, due to a bug in the Access ODBC driver. C columns work correctly as well, but you must take care to set L to C<$max_memo_size * 2 + 1>. This is done for you automatically if you pass L in your L; but if you set this attribute directly on the C<$dbh>, keep this limitation in mind. =cut # set LongReadLen = LongReadLen * 2 + 1 (see docs on MEMO) sub _run_connection_actions { my $self = shift; my $long_read_len = $self->_dbh->{LongReadLen}; # 80 is another default (just like 0) on some drivers if ($long_read_len != 0 && $long_read_len != 80) { $self->_dbh->{LongReadLen} = $long_read_len * 2 + 1; } # batch operations do not work $self->_disable_odbc_array_ops; return $self->next::method(@_); } sub insert { my $self = shift; my ($source, $to_insert) = @_; my $columns_info = $source->columns_info; my $is_image_insert = 0; for my $col (keys %$to_insert) { if ($self->_is_binary_lob_type($columns_info->{$col}{data_type})) { $is_image_insert = 1; last; } } local $self->{disable_sth_caching} = 1 if $is_image_insert && $self->disable_sth_caching_for_image_insert_or_update; return $self->next::method(@_); } sub update { my $self = shift; my ($source, $fields) = @_; my $columns_info = $source->columns_info; my $is_image_insert = 0; for my $col (keys %$fields) { if ($self->_is_binary_lob_type($columns_info->{$col}{data_type})) { $is_image_insert = 1; last; } } local $self->{disable_sth_caching} = 1 if $is_image_insert && $self->disable_sth_caching_for_image_insert_or_update; return $self->next::method(@_); } sub datetime_parser_type { 'DBIx::Class::Storage::DBI::ODBC::ACCESS::DateTime::Format' } package # hide from PAUSE DBIx::Class::Storage::DBI::ODBC::ACCESS::DateTime::Format; my $datetime_format = '%Y-%m-%d %H:%M:%S'; # %F %T, no fractional part my $datetime_parser; sub parse_datetime { shift; require DateTime::Format::Strptime; $datetime_parser ||= DateTime::Format::Strptime->new( pattern => $datetime_format, on_error => 'croak', ); return $datetime_parser->parse_datetime(shift); } sub format_datetime { shift; require DateTime::Format::Strptime; $datetime_parser ||= DateTime::Format::Strptime->new( pattern => $datetime_format, on_error => 'croak', ); return $datetime_parser->format_datetime(shift); } =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. =cut 1; # vim:sts=2 sw=2: DBIx-Class-0.082843/lib/DBIx/Class/Storage/DBI/ODBC/Microsoft_SQL_Server.pm0000644000175000017500000002225014240132261024561 0ustar rabbitrabbitpackage DBIx::Class::Storage::DBI::ODBC::Microsoft_SQL_Server; use strict; use warnings; use base qw/ DBIx::Class::Storage::DBI::ODBC DBIx::Class::Storage::DBI::MSSQL /; use mro 'c3'; use Scalar::Util 'reftype'; use Try::Tiny; use DBIx::Class::Carp; use namespace::clean; __PACKAGE__->mk_group_accessors(simple => qw/ _using_dynamic_cursors /); =head1 NAME DBIx::Class::Storage::DBI::ODBC::Microsoft_SQL_Server - Support specific to Microsoft SQL Server over ODBC =head1 DESCRIPTION This class implements support specific to Microsoft SQL Server over ODBC. It is loaded automatically by DBIx::Class::Storage::DBI::ODBC when it detects a MSSQL back-end. Most of the functionality is provided from the superclass L. =head1 USAGE NOTES =head2 Basic Linux Setup (Debian) sudo aptitude install tdsodbc libdbd-odbc-perl unixodbc In case it is not already there put the following (adjust for non-64bit arch) in C: [FreeTDS] Description = FreeTDS Driver = /usr/lib/x86_64-linux-gnu/odbc/libtdsodbc.so Setup = /usr/lib/x86_64-linux-gnu/odbc/libtdsS.so UsageCount = 1 Set your C<$dsn> in L as follows: dbi:ODBC:server=;port=1433;driver=FreeTDS;tds_version=8.0 If you use the EasySoft driver (L): dbi:ODBC:server=;port=1433;driver=Easysoft ODBC-SQL Server =head2 Basic Windows Setup Use the following C<$dsn> for the Microsoft ODBC driver: dbi:ODBC:driver={SQL Server};server=SERVER\SQL_SERVER_INSTANCE_NAME And for the Native Client: dbi:ODBC:driver={SQL Server Native Client 10.0};server=SERVER\SQL_SERVER_INSTANCE_NAME Go into Control Panel -> System and Security -> Administrative Tools -> Data Sources (ODBC) to check driver names and to set up data sources. Use System DSNs, not User DSNs if you want to use DSNs. If you set up a DSN, use the following C<$dsn> for L: dbi:ODBC:dsn=MY_DSN =head1 MULTIPLE ACTIVE STATEMENTS The following options are alternative ways to enable concurrent executing statement support. Each has its own advantages and drawbacks and works on different platforms. Read each section carefully. For more details about using MAS in MSSQL over DBD::ODBC see this excellent document provided by EasySoft: L. In order of preference, they are: =over 8 =item * L =item * L =item * L =back =head1 METHODS =head2 connect_call_use_mars Use as: on_connect_call => 'use_mars' in your connection info, or alternatively specify it directly: Your::Schema->connect ( $original_dsn . '; MARS_Connection=Yes', $user, $pass, \%attrs, ) Use to enable a feature of SQL Server 2005 and later, "Multiple Active Result Sets". See L for more information. This does not work on FreeTDS drivers at the time of this writing, and only works with the Native Client, later versions of the Windows MS ODBC driver, and the Easysoft driver. =cut sub connect_call_use_mars { my $self = shift; my $dsn = $self->_dbi_connect_info->[0]; if (ref($dsn) eq 'CODE') { $self->throw_exception('cannot change the DBI DSN on a CODE ref connect_info'); } if ($dsn !~ /MARS_Connection=/) { if ($self->_using_freetds) { $self->throw_exception('FreeTDS does not support MARS at the time of ' .'writing.'); } if (exists $self->_server_info->{normalized_dbms_version} && $self->_server_info->{normalized_dbms_version} < 9) { $self->throw_exception('SQL Server 2005 or later required to use MARS.'); } if (my ($data_source) = $dsn =~ /^dbi:ODBC:([\w-]+)\z/i) { # prefix with DSN carp_unique "Bare DSN in ODBC connect string, rewriting as 'dsn=$data_source'" ." for MARS\n"; $dsn = "dbi:ODBC:dsn=$data_source"; } $self->_dbi_connect_info->[0] = "$dsn;MARS_Connection=Yes"; $self->disconnect; $self->ensure_connected; } } sub connect_call_use_MARS { carp "'connect_call_use_MARS' has been deprecated, use " ."'connect_call_use_mars' instead."; shift->connect_call_use_mars(@_) } =head2 connect_call_use_dynamic_cursors Use as: on_connect_call => 'use_dynamic_cursors' Which will add C<< odbc_cursortype => 2 >> to your DBI connection attributes, or alternatively specify the necessary flag directly: Your::Schema->connect (@dsn, { ... odbc_cursortype => 2 }) See L for more information. If you're using FreeTDS, C must be set to at least C<8.0>. This will not work with CODE ref connect_info's. B on FreeTDS (and maybe some other drivers) this will break C, and C will work for obtaining the last insert id of an C column, instead of having to do C. This is done safely in a transaction (locking the table.) See L. A recommended L setting: on_connect_call => [['datetime_setup'], ['blob_setup', log_on_update => 0]] =head1 METHODS =cut sub _rebless { my $self = shift; my $no_bind_vars = __PACKAGE__ . '::NoBindVars'; if ($self->_using_freetds) { carp_once <<'EOF' unless $ENV{DBIC_SYBASE_FREETDS_NOWARN}; You are using FreeTDS with Sybase. We will do our best to support this configuration, but please consider this support experimental. TEXT/IMAGE columns will definitely not work. You are encouraged to recompile DBD::Sybase with the Sybase Open Client libraries instead. See perldoc DBIx::Class::Storage::DBI::Sybase::ASE for more details. To turn off this warning set the DBIC_SYBASE_FREETDS_NOWARN environment variable. EOF if (not $self->_use_typeless_placeholders) { if ($self->_use_placeholders) { $self->auto_cast(1); } else { $self->ensure_class_loaded($no_bind_vars); bless $self, $no_bind_vars; $self->_rebless; } } } elsif (not $self->_get_dbh->{syb_dynamic_supported}) { # not necessarily FreeTDS, but no placeholders nevertheless $self->ensure_class_loaded($no_bind_vars); bless $self, $no_bind_vars; $self->_rebless; } # this is highly unlikely, but we check just in case elsif (not $self->_use_typeless_placeholders) { $self->auto_cast(1); } } sub _init { my $self = shift; $self->next::method(@_); if ($self->_using_freetds && (my $ver = $self->_using_freetds_version||999) > 0.82) { carp_once( "Buggy FreeTDS version $ver detected, statement caching will not work and " . 'will be disabled.' ); $self->disable_sth_caching(1); } $self->_set_max_connect(256); # create storage for insert/(update blob) transactions, # unless this is that storage return if $self->_parent_storage; my $writer_storage = (ref $self)->new; $writer_storage->_is_writer_storage(1); # just info $writer_storage->connect_info($self->connect_info); $writer_storage->auto_cast($self->auto_cast); weaken ($writer_storage->{_parent_storage} = $self); $self->_writer_storage($writer_storage); # create a bulk storage unless connect_info is a coderef return if ref($self->_dbi_connect_info->[0]) eq 'CODE'; my $bulk_storage = (ref $self)->new; $bulk_storage->_is_bulk_storage(1); # for special ->disconnect acrobatics $bulk_storage->connect_info($self->connect_info); # this is why $bulk_storage->_dbi_connect_info->[0] .= ';bulkLogin=1'; weaken ($bulk_storage->{_parent_storage} = $self); $self->_bulk_storage($bulk_storage); } for my $method (@also_proxy_to_extra_storages) { no strict 'refs'; no warnings 'redefine'; my $replaced = __PACKAGE__->can($method); *{$method} = Sub::Name::subname $method => sub { my $self = shift; $self->_writer_storage->$replaced(@_) if $self->_writer_storage; $self->_bulk_storage->$replaced(@_) if $self->_bulk_storage; return $self->$replaced(@_); }; } sub disconnect { my $self = shift; # Even though we call $sth->finish for uses off the bulk API, there's still an # "active statement" warning on disconnect, which we throw away here. # This is due to the bug described in _insert_bulk. # Currently a noop because 'prepare' is used instead of 'prepare_cached'. local $SIG{__WARN__} = sigwarn_silencer(qr/active statement/i) if $self->_is_bulk_storage; # so that next transaction gets a dbh $self->_began_bulk_work(0) if $self->_is_bulk_storage; $self->next::method; } # This is only invoked for FreeTDS drivers by ::Storage::DBI::Sybase::FreeTDS sub _set_autocommit_stmt { my ($self, $on) = @_; return 'SET CHAINED ' . ($on ? 'OFF' : 'ON'); } # Set up session settings for Sybase databases for the connection. # # Make sure we have CHAINED mode turned on if AutoCommit is off in non-FreeTDS # DBD::Sybase (since we don't know how DBD::Sybase was compiled.) If however # we're using FreeTDS, CHAINED mode turns on an implicit transaction which we # only want when AutoCommit is off. sub _run_connection_actions { my $self = shift; if ($self->_is_bulk_storage) { # this should be cleared on every reconnect $self->_began_bulk_work(0); return; } $self->_dbh->{syb_chained_txn} = 1 unless $self->_using_freetds; $self->next::method(@_); } =head2 connect_call_blob_setup Used as: on_connect_call => [ [ 'blob_setup', log_on_update => 0 ] ] Does C<< $dbh->{syb_binary_images} = 1; >> to return C data as raw binary instead of as a hex string. Recommended. Also sets the C value for blob write operations. The default is C<1>, but C<0> is better if your database is configured for it. See L. =cut sub connect_call_blob_setup { my $self = shift; my %args = @_; my $dbh = $self->_dbh; $dbh->{syb_binary_images} = 1; $self->_blob_log_on_update($args{log_on_update}) if exists $args{log_on_update}; } sub _is_lob_column { my ($self, $source, $column) = @_; return $self->_is_lob_type($source->column_info($column)->{data_type}); } sub _prep_for_execute { my ($self, $op, $ident, $args) = @_; # ### This is commented out because all tests pass. However I am leaving it ### here as it may prove necessary (can't think through all combinations) ### BTW it doesn't currently work exactly - need better sensitivity to # currently set value # #my ($op, $ident) = @_; # # inherit these from the parent for the duration of _prep_for_execute # Don't know how to make a localizing loop with if's, otherwise I would #local $self->{_autoinc_supplied_for_op} # = $self->_parent_storage->_autoinc_supplied_for_op #if ($op eq 'insert' or $op eq 'update') and $self->_parent_storage; #local $self->{_perform_autoinc_retrieval} # = $self->_parent_storage->_perform_autoinc_retrieval #if ($op eq 'insert' or $op eq 'update') and $self->_parent_storage; my $limit; # extract and use shortcut on limit without offset if ($op eq 'select' and ! $args->[4] and $limit = $args->[3]) { $args = [ @$args ]; $args->[3] = undef; } my ($sql, $bind) = $self->next::method($op, $ident, $args); # $limit is already sanitized by now $sql = join( "\n", "SET ROWCOUNT $limit", $sql, "SET ROWCOUNT 0", ) if $limit; if (my $identity_col = $self->_perform_autoinc_retrieval) { $sql .= "\n" . $self->_fetch_identity_sql($ident, $identity_col) } return ($sql, $bind); } sub _fetch_identity_sql { my ($self, $source, $col) = @_; return sprintf ("SELECT MAX(%s) FROM %s", map { $self->sql_maker->_quote ($_) } ($col, $source->from) ); } # Stolen from SQLT, with some modifications. This is a makeshift # solution before a sane type-mapping library is available, thus # the 'our' for easy overrides. our %TYPE_MAPPING = ( number => 'numeric', money => 'money', varchar => 'varchar', varchar2 => 'varchar', timestamp => 'datetime', text => 'varchar', real => 'double precision', comment => 'text', bit => 'bit', tinyint => 'smallint', float => 'double precision', serial => 'numeric', bigserial => 'numeric', boolean => 'varchar', long => 'varchar', ); sub _native_data_type { my ($self, $type) = @_; $type = lc $type; $type =~ s/\s* identity//x; return uc($TYPE_MAPPING{$type} || $type); } sub _execute { my $self = shift; my ($rv, $sth, @bind) = $self->next::method(@_); $self->_identity( ($sth->fetchall_arrayref)->[0][0] ) if $self->_perform_autoinc_retrieval; return wantarray ? ($rv, $sth, @bind) : $rv; } sub last_insert_id { shift->_identity } # handles TEXT/IMAGE and transaction for last_insert_id sub insert { my $self = shift; my ($source, $to_insert) = @_; my $columns_info = $source->columns_info; my $identity_col = (first { $columns_info->{$_}{is_auto_increment} } keys %$columns_info ) || ''; # FIXME - this is duplication from DBI.pm. When refactored towards # the LobWriter this can be folded back where it belongs. local $self->{_autoinc_supplied_for_op} = exists $to_insert->{$identity_col} ? 1 : 0 ; local $self->{_perform_autoinc_retrieval} = ($identity_col and ! exists $to_insert->{$identity_col}) ? $identity_col : undef ; # check for empty insert # INSERT INTO foo DEFAULT VALUES -- does not work with Sybase # try to insert explicit 'DEFAULT's instead (except for identity, timestamp # and computed columns) if (not %$to_insert) { for my $col ($source->columns) { next if $col eq $identity_col; my $info = $source->column_info($col); next if ref $info->{default_value} eq 'SCALAR' || (exists $info->{data_type} && (not defined $info->{data_type})); next if $info->{data_type} && $info->{data_type} =~ /^timestamp\z/i; $to_insert->{$col} = \'DEFAULT'; } } my $blob_cols = $self->_remove_blob_cols($source, $to_insert); # do we need the horrific SELECT MAX(COL) hack? my $need_dumb_last_insert_id = ( $self->_perform_autoinc_retrieval && ($self->_identity_method||'') ne '@@IDENTITY' ); my $next = $self->next::can; # we are already in a transaction, or there are no blobs # and we don't need the PK - just (try to) do it if ($self->{transaction_depth} || (!$blob_cols && !$need_dumb_last_insert_id) ) { return $self->_insert ( $next, $source, $to_insert, $blob_cols, $identity_col ); } # otherwise use the _writer_storage to do the insert+transaction on another # connection my $guard = $self->_writer_storage->txn_scope_guard; my $updated_cols = $self->_writer_storage->_insert ( $next, $source, $to_insert, $blob_cols, $identity_col ); $self->_identity($self->_writer_storage->_identity); $guard->commit; return $updated_cols; } sub _insert { my ($self, $next, $source, $to_insert, $blob_cols, $identity_col) = @_; my $updated_cols = $self->$next ($source, $to_insert); my $final_row = { ($identity_col ? ($identity_col => $self->last_insert_id($source, $identity_col)) : ()), %$to_insert, %$updated_cols, }; $self->_insert_blobs ($source, $blob_cols, $final_row) if $blob_cols; return $updated_cols; } sub update { my $self = shift; my ($source, $fields, $where, @rest) = @_; # # When *updating* identities, ASE requires SET IDENTITY_UPDATE called # if (my $blob_cols = $self->_remove_blob_cols($source, $fields)) { # If there are any blobs in $where, Sybase will return a descriptive error # message. # XXX blobs can still be used with a LIKE query, and this should be handled. # update+blob update(s) done atomically on separate connection $self = $self->_writer_storage; my $guard = $self->txn_scope_guard; # First update the blob columns to be updated to '' (taken from $fields, where # it is originally put by _remove_blob_cols .) my %blobs_to_empty = map { ($_ => delete $fields->{$_}) } keys %$blob_cols; # We can't only update NULL blobs, because blobs cannot be in the WHERE clause. $self->next::method($source, \%blobs_to_empty, $where, @rest); # Now update the blobs before the other columns in case the update of other # columns makes the search condition invalid. my $rv = $self->_update_blobs($source, $blob_cols, $where); if (keys %$fields) { # Now set the identity update flags for the actual update local $self->{_autoinc_supplied_for_op} = grep { $_->{is_auto_increment} } values %{ $source->columns_info([ keys %$fields ]) } ; my $next = $self->next::can; my $args = \@_; return preserve_context { $self->$next(@$args); } after => sub { $guard->commit }; } else { $guard->commit; return $rv; } } else { # Set the identity update flags for the actual update local $self->{_autoinc_supplied_for_op} = grep { $_->{is_auto_increment} } values %{ $source->columns_info([ keys %$fields ]) } ; return $self->next::method(@_); } } sub _insert_bulk { my $self = shift; my ($source, $cols, $data) = @_; my $columns_info = $source->columns_info; my ($identity_col) = grep { $columns_info->{$_}{is_auto_increment} } keys %$columns_info; # FIXME - this is duplication from DBI.pm. When refactored towards # the LobWriter this can be folded back where it belongs. local $self->{_autoinc_supplied_for_op} = grep { $_ eq $identity_col } @$cols; my $use_bulk_api = $self->_bulk_storage && $self->_get_dbh->{syb_has_blk}; if (! $use_bulk_api and ref($self->_dbi_connect_info->[0]) eq 'CODE') { carp_unique( join ' ', 'Bulk API support disabled due to use of a CODEREF connect_info.', 'Reverting to regular array inserts.', ); } if (not $use_bulk_api) { my $blob_cols = $self->_remove_blob_cols_array($source, $cols, $data); # next::method uses a txn anyway, but it ends too early in case we need to # select max(col) to get the identity for inserting blobs. ($self, my $guard) = $self->{transaction_depth} == 0 ? ($self->_writer_storage, $self->_writer_storage->txn_scope_guard) : ($self, undef); $self->next::method(@_); if ($blob_cols) { if ($self->_autoinc_supplied_for_op) { $self->_insert_blobs_array ($source, $blob_cols, $cols, $data); } else { my @cols_with_identities = (@$cols, $identity_col); ## calculate identities # XXX This assumes identities always increase by 1, which may or may not # be true. my ($last_identity) = $self->_dbh->selectrow_array ( $self->_fetch_identity_sql($source, $identity_col) ); my @identities = (($last_identity - @$data + 1) .. $last_identity); my @data_with_identities = map [@$_, shift @identities], @$data; $self->_insert_blobs_array ( $source, $blob_cols, \@cols_with_identities, \@data_with_identities ); } } $guard->commit if $guard; return; } # otherwise, use the bulk API # rearrange @$data so that columns are in database order # and so we submit a full column list my %orig_order = map { $cols->[$_] => $_ } 0..$#$cols; my @source_columns = $source->columns; # bcp identity index is 1-based my ($identity_idx) = grep { $source_columns[$_] eq $identity_col } (0..$#source_columns); $identity_idx = defined $identity_idx ? $identity_idx + 1 : 0; my @new_data; for my $slice_idx (0..$#$data) { push @new_data, [map { # identity data will be 'undef' if not _autoinc_supplied_for_op() # columns with defaults will also be 'undef' exists $orig_order{$_} ? $data->[$slice_idx][$orig_order{$_}] : undef } @source_columns]; } my $proto_bind = $self->_resolve_bindattrs( $source, [map { [ { dbic_colname => $source_columns[$_], _bind_data_slice_idx => $_ } => $new_data[0][$_] ] } (0 ..$#source_columns) ], $columns_info ); ## Set a client-side conversion error handler, straight from DBD::Sybase docs. # This ignores any data conversion errors detected by the client side libs, as # they are usually harmless. my $orig_cslib_cb = DBD::Sybase::set_cslib_cb( Sub::Name::subname _insert_bulk_cslib_errhandler => sub { my ($layer, $origin, $severity, $errno, $errmsg, $osmsg, $blkmsg) = @_; return 1 if $errno == 36; carp "Layer: $layer, Origin: $origin, Severity: $severity, Error: $errno" . ($errmsg ? "\n$errmsg" : '') . ($osmsg ? "\n$osmsg" : '') . ($blkmsg ? "\n$blkmsg" : ''); return 0; }); my $exception = ''; try { my $bulk = $self->_bulk_storage; my $guard = $bulk->txn_scope_guard; ## FIXME - once this is done - address the FIXME on finish() below ## XXX get this to work instead of our own $sth ## will require SQLMaker or *Hacks changes for ordered columns # $bulk->next::method($source, \@source_columns, \@new_data, { # syb_bcp_attribs => { # identity_flag => $self->_autoinc_supplied_for_op ? 1 : 0, # identity_column => $identity_idx, # } # }); my $sql = 'INSERT INTO ' . $bulk->sql_maker->_quote($source->name) . ' (' . # colname list is ignored for BCP, but does no harm (join ', ', map $bulk->sql_maker->_quote($_), @source_columns) . ') '. ' VALUES ('. (join ', ', ('?') x @source_columns) . ')'; ## XXX there's a bug in the DBD::Sybase bulk support that makes $sth->finish for ## a prepare_cached statement ineffective. Replace with ->sth when fixed, or ## better yet the version above. Should be fixed in DBD::Sybase . my $sth = $bulk->_get_dbh->prepare($sql, # 'insert', # op { syb_bcp_attribs => { identity_flag => $self->_autoinc_supplied_for_op ? 1 : 0, identity_column => $identity_idx, } } ); { # FIXME the $sth->finish in _execute_array does a rollback for some # reason. Disable it temporarily until we fix the SQLMaker thing above no warnings 'redefine'; no strict 'refs'; local *{ref($sth).'::finish'} = sub {}; $self->_dbh_execute_for_fetch( $source, $sth, $proto_bind, \@source_columns, \@new_data ); } $guard->commit; $bulk->_query_end($sql); } catch { $exception = shift; }; DBD::Sybase::set_cslib_cb($orig_cslib_cb); if ($exception =~ /-Y option/) { my $w = 'Sybase bulk API operation failed due to character set incompatibility, ' . 'reverting to regular array inserts. Try unsetting the LANG environment variable' ; $w .= "\n$exception" if $self->debug; carp $w; $self->_bulk_storage(undef); unshift @_, $self; goto \&_insert_bulk; } elsif ($exception) { # rollback makes the bulkLogin connection unusable $self->_bulk_storage->disconnect; $self->throw_exception($exception); } } # Make sure blobs are not bound as placeholders, and return any non-empty ones # as a hash. sub _remove_blob_cols { my ($self, $source, $fields) = @_; my %blob_cols; for my $col (keys %$fields) { if ($self->_is_lob_column($source, $col)) { my $blob_val = delete $fields->{$col}; if (not defined $blob_val) { $fields->{$col} = \'NULL'; } else { $fields->{$col} = \"''"; $blob_cols{$col} = $blob_val unless $blob_val eq ''; } } } return %blob_cols ? \%blob_cols : undef; } # same for _insert_bulk sub _remove_blob_cols_array { my ($self, $source, $cols, $data) = @_; my @blob_cols; for my $i (0..$#$cols) { my $col = $cols->[$i]; if ($self->_is_lob_column($source, $col)) { for my $j (0..$#$data) { my $blob_val = delete $data->[$j][$i]; if (not defined $blob_val) { $data->[$j][$i] = \'NULL'; } else { $data->[$j][$i] = \"''"; $blob_cols[$j][$i] = $blob_val unless $blob_val eq ''; } } } } return @blob_cols ? \@blob_cols : undef; } sub _update_blobs { my ($self, $source, $blob_cols, $where) = @_; my @primary_cols = try { $source->_pri_cols_or_die } catch { $self->throw_exception("Cannot update TEXT/IMAGE column(s): $_") }; my @pks_to_update; if ( ref $where eq 'HASH' and @primary_cols == grep { defined $where->{$_} } @primary_cols ) { my %row_to_update; @row_to_update{@primary_cols} = @{$where}{@primary_cols}; @pks_to_update = \%row_to_update; } else { my $cursor = $self->select ($source, \@primary_cols, $where, {}); @pks_to_update = map { my %row; @row{@primary_cols} = @$_; \%row } $cursor->all; } for my $ident (@pks_to_update) { $self->_insert_blobs($source, $blob_cols, $ident); } } sub _insert_blobs { my ($self, $source, $blob_cols, $row) = @_; my $dbh = $self->_get_dbh; my $table = $source->name; my %row = %$row; my @primary_cols = try { $source->_pri_cols_or_die } catch { $self->throw_exception("Cannot update TEXT/IMAGE column(s): $_") }; $self->throw_exception('Cannot update TEXT/IMAGE column(s) without primary key values') if ((grep { defined $row{$_} } @primary_cols) != @primary_cols); # if we are 2-phase inserting a blob - there is nothing to retrieve anymore, # regardless of the previous state of the flag local $self->{_perform_autoinc_retrieval} if $self->_perform_autoinc_retrieval; for my $col (keys %$blob_cols) { my $blob = $blob_cols->{$col}; my %where = map { ($_, $row{$_}) } @primary_cols; my $cursor = $self->select ($source, [$col], \%where, {}); $cursor->next; my $sth = $cursor->sth; if (not $sth) { $self->throw_exception( "Could not find row in table '$table' for blob update:\n" . (Dumper \%where) ); } try { do { $sth->func('CS_GET', 1, 'ct_data_info') or die $sth->errstr; } while $sth->fetch; $sth->func('ct_prepare_send') or die $sth->errstr; my $log_on_update = $self->_blob_log_on_update; $log_on_update = 1 if not defined $log_on_update; $sth->func('CS_SET', 1, { total_txtlen => length($blob), log_on_update => $log_on_update }, 'ct_data_info') or die $sth->errstr; $sth->func($blob, length($blob), 'ct_send_data') or die $sth->errstr; $sth->func('ct_finish_send') or die $sth->errstr; } catch { if ($self->_using_freetds) { $self->throw_exception ( "TEXT/IMAGE operation failed, probably because you are using FreeTDS: $_" ); } else { $self->throw_exception($_); } } finally { $sth->finish if $sth; }; } } sub _insert_blobs_array { my ($self, $source, $blob_cols, $cols, $data) = @_; for my $i (0..$#$data) { my $datum = $data->[$i]; my %row; @row{ @$cols } = @$datum; my %blob_vals; for my $j (0..$#$cols) { if (exists $blob_cols->[$i][$j]) { $blob_vals{ $cols->[$j] } = $blob_cols->[$i][$j]; } } $self->_insert_blobs ($source, \%blob_vals, \%row); } } =head2 connect_call_datetime_setup Used as: on_connect_call => 'datetime_setup' In L to set: $dbh->syb_date_fmt('ISO_strict'); # output fmt: 2004-08-21T14:36:48.080Z $dbh->do('set dateformat mdy'); # input fmt: 08/13/1979 18:08:55.080 This works for both C and C columns, note that C columns only have minute precision. =cut sub connect_call_datetime_setup { my $self = shift; my $dbh = $self->_get_dbh; if ($dbh->can('syb_date_fmt')) { # amazingly, this works with FreeTDS $dbh->syb_date_fmt('ISO_strict'); } else { carp_once 'Your DBD::Sybase is too old to support ' .'DBIx::Class::InflateColumn::DateTime, please upgrade!'; # FIXME - in retrospect this is a rather bad US-centric choice # of format. Not changing as a bugwards compat, though in reality # the only piece that sees the results of $dt object formatting # (as opposed to parsing) is the database itself, so theoretically # changing both this SET command and the formatter definition of # ::S::D::Sybase::ASE::DateTime::Format below should be safe and # transparent $dbh->do('SET DATEFORMAT mdy'); } } sub _exec_txn_begin { my $self = shift; # bulkLogin=1 connections are always in a transaction, and can only call BEGIN # TRAN once. However, we need to make sure there's a $dbh. return if $self->_is_bulk_storage && $self->_dbh && $self->_began_bulk_work; $self->next::method(@_); $self->_began_bulk_work(1) if $self->_is_bulk_storage; } # savepoint support using ASE syntax sub _exec_svp_begin { my ($self, $name) = @_; $self->_dbh->do("SAVE TRANSACTION $name"); } # A new SAVE TRANSACTION with the same name releases the previous one. sub _exec_svp_release { 1 } sub _exec_svp_rollback { my ($self, $name) = @_; $self->_dbh->do("ROLLBACK TRANSACTION $name"); } package # hide from PAUSE DBIx::Class::Storage::DBI::Sybase::ASE::DateTime::Format; my $datetime_parse_format = '%Y-%m-%dT%H:%M:%S.%3NZ'; my $datetime_format_format = '%m/%d/%Y %H:%M:%S.%3N'; my ($datetime_parser, $datetime_formatter); sub parse_datetime { shift; require DateTime::Format::Strptime; $datetime_parser ||= DateTime::Format::Strptime->new( pattern => $datetime_parse_format, on_error => 'croak', ); return $datetime_parser->parse_datetime(shift); } sub format_datetime { shift; require DateTime::Format::Strptime; $datetime_formatter ||= DateTime::Format::Strptime->new( pattern => $datetime_format_format, on_error => 'croak', ); return $datetime_formatter->format_datetime(shift); } 1; =head1 Schema::Loader Support As of version C<0.05000>, L should work well with most versions of Sybase ASE. =head1 FreeTDS This driver supports L compiled against FreeTDS (L) to the best of our ability, however it is recommended that you recompile L against the Sybase Open Client libraries. They are a part of the Sybase ASE distribution: The Open Client FAQ is here: L. Sybase ASE for Linux (which comes with the Open Client libraries) may be downloaded here: L. To see if you're using FreeTDS run: perl -MDBI -le 'my $dbh = DBI->connect($dsn, $user, $pass); print $dbh->{syb_oc_version}' It is recommended to set C for your ASE server to C<5.0> in C. Some versions or configurations of the libraries involved will not support placeholders, in which case the storage will be reblessed to L. In some configurations, placeholders will work but will throw implicit type conversion errors for anything that's not expecting a string. In such a case, the C option from L is automatically set, which you may enable on connection with L. The type info for the Cs is taken from the L definitions in your Result classes, and are mapped to a Sybase type (if it isn't already) using a mapping based on L. In other configurations, placeholders will work just as they do with the Sybase Open Client libraries. Inserts or updates of TEXT/IMAGE columns will B work with FreeTDS. =head1 INSERTS WITH PLACEHOLDERS With placeholders enabled, inserts are done in a transaction so that there are no concurrency issues with getting the inserted identity value using C which is a session variable. =head1 TRANSACTIONS Due to limitations of the TDS protocol and L, you cannot begin a transaction while there are active cursors, nor can you use multiple active cursors within a transaction. An active cursor is, for example, a L that has been executed using C or C but has not been exhausted or L. For example, this will not work: $schema->txn_do(sub { my $rs = $schema->resultset('Book'); while (my $result = $rs->next) { $schema->resultset('MetaData')->create({ book_id => $result->id, ... }); } }); This won't either: my $first_row = $large_rs->first; $schema->txn_do(sub { ... }); Transactions done for inserts in C mode when placeholders are in use are not affected, as they are done on an extra database handle. Some workarounds: =over 4 =item * use L =item * L another L =item * load the data from your cursor with L =back =head1 MAXIMUM CONNECTIONS The TDS protocol makes separate connections to the server for active statements in the background. By default the number of such connections is limited to 25, on both the client side and the server side. This is a bit too low for a complex L application, so on connection the client side setting is set to C<256> (see L.) You can override it to whatever setting you like in the DSN. See L for information on changing the setting on the server side. =head1 DATES See L to setup date formats for L. =head1 LIMITED QUERIES Because ASE does not have a good way to limit results in SQL that works for all types of queries, the limit dialect is set to L. Fortunately, ASE and L support cursors properly, so when L is too slow you can use the L L attribute to simulate limited queries by skipping over records. =head1 TEXT/IMAGE COLUMNS L compiled with FreeTDS will B allow you to insert or update C columns. Setting C<< $dbh->{LongReadLen} >> will also not work with FreeTDS use either: $schema->storage->dbh->do("SET TEXTSIZE $bytes"); or $schema->storage->set_textsize($bytes); instead. However, the C you pass in L is used to execute the equivalent C command on connection. See L for a L setting you need to work with C columns. =head1 BULK API The experimental L Bulk API support is used for L in B context, in a transaction on a separate connection. To use this feature effectively, use a large number of rows for each L call, eg.: while (my $rows = $data_source->get_100_rows()) { $rs->populate($rows); } B the L calls in your C classes B list columns in database order for this to work. Also, you may have to unset the C environment variable before loading your app, as C is not yet supported in DBD::Sybase . When inserting IMAGE columns using this method, you'll need to use L as well. =head1 COMPUTED COLUMNS If you have columns such as: created_dtm AS getdate() represent them in your Result classes as: created_dtm => { data_type => undef, default_value => \'getdate()', is_nullable => 0, inflate_datetime => 1, } The C must exist and must be C. Then empty inserts will work on tables with such columns. =head1 TIMESTAMP COLUMNS C columns in Sybase ASE are not really timestamps, see: L. They should be defined in your Result classes as: ts => { data_type => 'timestamp', is_nullable => 0, inflate_datetime => 0, } The C< 0>> is necessary if you use L, and most people do, and still want to be able to read these values. The values will come back as hexadecimal. =head1 TODO =over =item * Transitions to AutoCommit=0 (starting a transaction) mode by exhausting any active cursors, using eager cursors. =item * Real limits and limited counts using stored procedures deployed on startup. =item * Blob update with a LIKE query on a blob, without invalidating the WHERE condition. =item * bulk_insert using prepare_cached (see comments.) =back =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. DBIx-Class-0.082843/lib/DBIx/Class/Storage/DBI/Sybase/Microsoft_SQL_Server.pm0000644000175000017500000001146013271562530025312 0ustar rabbitrabbitpackage DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server; use strict; use warnings; use base qw/ DBIx::Class::Storage::DBI::Sybase DBIx::Class::Storage::DBI::MSSQL /; use mro 'c3'; use DBIx::Class::Carp; use namespace::clean; =head1 NAME DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server - Support for Microsoft SQL Server via DBD::Sybase =head1 SYNOPSIS This subclass supports MSSQL server connections via L. =head1 DESCRIPTION This driver tries to determine whether your version of L and supporting libraries (usually FreeTDS) support using placeholders, if not the storage will be reblessed to L. The MSSQL specific functionality is provided by L. =head1 METHODS =cut __PACKAGE__->datetime_parser_type( 'DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server::DateTime::Format' ); sub _rebless { my $self = shift; my $dbh = $self->_get_dbh; return if ref $self ne __PACKAGE__; if (not $self->_use_typeless_placeholders) { carp_once <<'EOF' unless $ENV{DBIC_MSSQL_FREETDS_LOWVER_NOWARN}; Placeholders do not seem to be supported in your configuration of DBD::Sybase/FreeTDS. This means you are taking a large performance hit, as caching of prepared statements is disabled. Make sure to configure your server with "tds version" of 8.0 or 7.0 in /etc/freetds/freetds.conf . To turn off this warning, set the DBIC_MSSQL_FREETDS_LOWVER_NOWARN environment variable. EOF require DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server::NoBindVars; bless $self, 'DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server::NoBindVars'; $self->_rebless; } } sub _init { my $self = shift; $self->next::method(@_); # work around massively broken freetds versions after 0.82 # - explicitly no scope_identity # - no sth caching # # warn about the fact as well, do not provide a mechanism to shut it up if ($self->_using_freetds and (my $ver = $self->_using_freetds_version||999) > 0.82) { carp_once( "Your DBD::Sybase was compiled against buggy FreeTDS version $ver. " . 'Statement caching does not work and will be disabled.' ); $self->_identity_method('@@identity'); $self->_no_scope_identity_query(1); $self->disable_sth_caching(1); } } # invoked only if DBD::Sybase is compiled against FreeTDS sub _set_autocommit_stmt { my ($self, $on) = @_; return 'SET IMPLICIT_TRANSACTIONS ' . ($on ? 'OFF' : 'ON'); } sub _get_server_version { my $self = shift; my $product_version = $self->_get_dbh->selectrow_hashref('master.dbo.xp_msver ProductVersion'); if ((my $version = $product_version->{Character_Value}) =~ /^(\d+)\./) { return $version; } else { $self->throw_exception( "MSSQL Version Retrieval Failed, Your ProductVersion's Character_Value is missing or malformed!" ); } } =head2 connect_call_datetime_setup Used as: on_connect_call => 'datetime_setup' In L to set: $dbh->syb_date_fmt('ISO_strict'); # output fmt: 2004-08-21T14:36:48.080Z On connection for use with L This works for both C and C columns, although C columns only have minute precision. =cut sub connect_call_datetime_setup { my $self = shift; my $dbh = $self->_get_dbh; if ($dbh->can('syb_date_fmt')) { # amazingly, this works with FreeTDS $dbh->syb_date_fmt('ISO_strict'); } else{ carp_once 'Your DBD::Sybase is too old to support ' . 'DBIx::Class::InflateColumn::DateTime, please upgrade!'; } } package # hide from PAUSE DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server::DateTime::Format; my $datetime_parse_format = '%Y-%m-%dT%H:%M:%S.%3NZ'; my $datetime_format_format = '%Y-%m-%d %H:%M:%S.%3N'; # %F %T my ($datetime_parser, $datetime_formatter); sub parse_datetime { shift; require DateTime::Format::Strptime; $datetime_parser ||= DateTime::Format::Strptime->new( pattern => $datetime_parse_format, on_error => 'croak', ); return $datetime_parser->parse_datetime(shift); } sub format_datetime { shift; require DateTime::Format::Strptime; $datetime_formatter ||= DateTime::Format::Strptime->new( pattern => $datetime_format_format, on_error => 'croak', ); return $datetime_formatter->format_datetime(shift); } =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. =cut 1; DBIx-Class-0.082843/lib/DBIx/Class/Storage/DBI/Sybase/MSSQL.pm0000644000175000017500000000315613271562530022202 0ustar rabbitrabbitpackage DBIx::Class::Storage::DBI::Sybase::MSSQL; use strict; use warnings; use DBIx::Class::Carp; use namespace::clean; carp 'Setting of storage_type is redundant as connections through DBD::Sybase' .' are now properly recognized and reblessed into the appropriate subclass' .' (DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server in the' .' case of MSSQL). Please remove the explicit call to' .q/ $schema->storage_type('::DBI::Sybase::MSSQL')/ .', as this storage class has been deprecated in favor of the autodetected' .' ::DBI::Sybase::Microsoft_SQL_Server'; use base qw/DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server/; use mro 'c3'; 1; =head1 NAME DBIx::Class::Storage::DBI::Sybase::MSSQL - (DEPRECATED) Legacy storage class for MSSQL via DBD::Sybase =head1 NOTE Connections through DBD::Sybase are now correctly recognized and reblessed into the appropriate subclass (L in the case of MSSQL). Please remove the explicit storage_type setting from your schema. =head1 SYNOPSIS This subclass supports MSSQL connected via L. $schema->storage_type('::DBI::Sybase::MSSQL'); $schema->connect_info('dbi:Sybase:....', ...); =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. DBIx-Class-0.082843/lib/DBIx/Class/Storage/DBI/Sybase/FreeTDS.pm0000644000175000017500000000511314240132261022521 0ustar rabbitrabbitpackage DBIx::Class::Storage::DBI::Sybase::FreeTDS; use strict; use warnings; use base qw/DBIx::Class::Storage::DBI::Sybase/; use mro 'c3'; use Try::Tiny; use namespace::clean; =head1 NAME DBIx::Class::Storage::DBI::Sybase::FreeTDS - Base class for drivers using DBD::Sybase over FreeTDS. =head1 DESCRIPTION This is the base class for Storages designed to work with L over FreeTDS. It is a subclass of L. =head1 METHODS =cut # The subclass storage driver defines _set_autocommit_stmt # for MsSQL it is SET IMPLICIT_TRANSACTIONS ON/OFF # for proper Sybase it's SET CHAINED ON/OFF sub _set_autocommit { my $self = shift; if ($self->_dbh_autocommit) { $self->_dbh->do($self->_set_autocommit_stmt(1)); } else { $self->_dbh->do($self->_set_autocommit_stmt(0)); } } # Handle AutoCommit and SET TEXTSIZE because LongReadLen doesn't work. # sub _run_connection_actions { my $self = shift; # based on LongReadLen in connect_info $self->set_textsize; $self->_set_autocommit; $self->next::method(@_); } =head2 set_textsize When using DBD::Sybase with FreeTDS, C<< $dbh->{LongReadLen} >> is not available, use this function instead. It does: $dbh->do("SET TEXTSIZE $bytes"); Takes the number of bytes, or uses the C value from your L if omitted, lastly falls back to the C<32768> which is the L default. =cut sub set_textsize { my $self = shift; my $text_size = shift || try { $self->_dbic_cinnect_attributes->{LongReadLen} } || 32768; # the DBD::Sybase default $self->_dbh->do("SET TEXTSIZE $text_size"); } sub _exec_txn_begin { my $self = shift; if ($self->{_in_do_block}) { $self->_dbh->do('BEGIN TRAN'); } else { $self->dbh_do(sub { $_[1]->do('BEGIN TRAN') }); } } sub _exec_txn_commit { my $self = shift; my $dbh = $self->_dbh or $self->throw_exception('cannot COMMIT on a disconnected handle'); $dbh->do('COMMIT'); } sub _exec_txn_rollback { my $self = shift; my $dbh = $self->_dbh or $self->throw_exception('cannot ROLLBACK on a disconnected handle'); $dbh->do('ROLLBACK'); } =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. =cut 1; DBIx-Class-0.082843/lib/DBIx/Class/Storage/DBI/ODBC.pm0000644000175000017500000000361413271562530020563 0ustar rabbitrabbitpackage DBIx::Class::Storage::DBI::ODBC; use strict; use warnings; use base qw/DBIx::Class::Storage::DBI/; use mro 'c3'; use DBIx::Class::_Util 'modver_gt_or_eq'; use namespace::clean; sub _rebless { shift->_determine_connector_driver('ODBC') } # Whether or not we are connecting via the freetds ODBC driver sub _using_freetds { my $self = shift; my $dsn = $self->_dbi_connect_info->[0]; return 1 if ( ( (! ref $dsn) and $dsn =~ /driver=FreeTDS/i) or ( ($self->_dbh_get_info('SQL_DRIVER_NAME')||'') =~ /tdsodbc/i ) ); return 0; } # Either returns the FreeTDS version via which we are connecting, 0 if can't # be determined, or undef otherwise sub _using_freetds_version { my $self = shift; return undef unless $self->_using_freetds; return $self->_dbh_get_info('SQL_DRIVER_VER') || 0; } sub _disable_odbc_array_ops { my $self = shift; my $dbh = $self->_get_dbh; $DBD::ODBC::__DBIC_DISABLE_ARRAY_OPS_VIA__ ||= [ do { if( modver_gt_or_eq('DBD::ODBC', '1.35_01') ) { odbc_array_operations => 0; } elsif( modver_gt_or_eq('DBD::ODBC', '1.33_01') ) { odbc_disable_array_operations => 1; } }]; if (my ($k, $v) = @$DBD::ODBC::__DBIC_DISABLE_ARRAY_OPS_VIA__) { $dbh->{$k} = $v; } } =head1 NAME DBIx::Class::Storage::DBI::ODBC - Base class for ODBC drivers =head1 DESCRIPTION This class simply provides a mechanism for discovering and loading a sub-class for a specific ODBC backend. It should be transparent to the user. =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. =cut 1; # vim:sts=2 sw=2: DBIx-Class-0.082843/lib/DBIx/Class/Storage/DBI/Firebird.pm0000644000175000017500000000175713271562530021610 0ustar rabbitrabbitpackage DBIx::Class::Storage::DBI::Firebird; use strict; use warnings; # Because DBD::Firebird is more or less a copy of # DBD::Interbase, inherit all the workarounds contained # in ::Storage::DBI::InterBase as opposed to inheriting # directly from ::Storage::DBI::Firebird::Common use base qw/DBIx::Class::Storage::DBI::InterBase/; use mro 'c3'; 1; =head1 NAME DBIx::Class::Storage::DBI::Firebird - Driver for the Firebird RDBMS via L =head1 DESCRIPTION This is an empty subclass of L for use with L, see that driver for details. =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. DBIx-Class-0.082843/lib/DBIx/Class/Storage/DBI/IdentityInsert.pm0000644000175000017500000000314714240132261023022 0ustar rabbitrabbitpackage DBIx::Class::Storage::DBI::IdentityInsert; use strict; use warnings; use base 'DBIx::Class::Storage::DBI'; use mro 'c3'; =head1 NAME DBIx::Class::Storage::DBI::IdentityInsert - Storage Component for Sybase ASE and MSSQL for Identity Inserts / Updates =head1 DESCRIPTION This is a storage component for Sybase ASE (L) and Microsoft SQL Server (L) to support identity inserts, that is inserts of explicit values into C columns. This is done by wrapping C operations in a pair of table identity toggles like: SET IDENTITY_INSERT $table ON $sql SET IDENTITY_INSERT $table OFF =cut # SET IDENTITY_X only works as part of a statement scope. We can not # $dbh->do the $sql and the wrapping set()s individually. Hence the # sql mangling. The newlines are important. sub _prep_for_execute { my $self = shift; return $self->next::method(@_) unless $self->_autoinc_supplied_for_op; my ($op, $ident) = @_; my $table = $self->sql_maker->_quote($ident->name); $op = uc $op; my ($sql, $bind) = $self->next::method(@_); return (<. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. =cut 1; DBIx-Class-0.082843/lib/DBIx/Class/Storage/DBI/DB2.pm0000644000175000017500000000415213560502346020421 0ustar rabbitrabbitpackage DBIx::Class::Storage::DBI::DB2; use strict; use warnings; use base qw/DBIx::Class::Storage::DBI/; use mro 'c3'; __PACKAGE__->datetime_parser_type('DateTime::Format::DB2'); __PACKAGE__->sql_quote_char ('"'); # lazy-default kind of thing sub sql_name_sep { my $self = shift; my $v = $self->next::method(@_); if (! defined $v and ! @_) { $v = $self->next::method($self->_dbh_get_info('SQL_QUALIFIER_NAME_SEPARATOR') || '.'); } return $v; } sub sql_limit_dialect { my $self = shift; my $v = $self->next::method(@_); if (! defined $v and ! @_) { $v = $self->next::method( ($self->_server_info->{normalized_dbms_version}||0) >= 5.004 ? 'RowNumberOver' : 'FetchFirst' ); } return $v; } sub _dbh_last_insert_id { my ($self, $dbh, $source, $col) = @_; my $name_sep = $self->sql_name_sep; my $sth = $dbh->prepare_cached( # An older equivalent of 'VALUES(IDENTITY_VAL_LOCAL())', for compat # with ancient DB2 versions. Should work on modern DB2's as well: # http://publib.boulder.ibm.com/infocenter/db2luw/v8/topic/com.ibm.db2.udb.doc/admin/r0002369.htm?resultof=%22%73%79%73%64%75%6d%6d%79%31%22%20 "SELECT IDENTITY_VAL_LOCAL() FROM sysibm${name_sep}sysdummy1", {}, 3 ); $sth->execute(); my @res = $sth->fetchrow_array(); return @res ? $res[0] : undef; } =head1 NAME DBIx::Class::Storage::DBI::DB2 - IBM DB2 support for DBIx::Class =head1 DESCRIPTION This class implements autoincrements for DB2, sets the limit dialect to RowNumberOver over FetchFirst depending on the availability of support for RowNumberOver, queries the server name_sep from L and sets the L parser to L. =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. =cut 1; # vim:sts=2 sw=2: DBIx-Class-0.082843/lib/DBIx/Class/Storage/DBI/Replicated.pm0000644000175000017500000006406014240132261022121 0ustar rabbitrabbitpackage DBIx::Class::Storage::DBI::Replicated; BEGIN { use DBIx::Class; die('The following modules are required for Replication ' . DBIx::Class::Optional::Dependencies->req_missing_for ('replicated') . "\n" ) unless DBIx::Class::Optional::Dependencies->req_ok_for ('replicated'); } use Moose; use DBIx::Class::Storage::DBI; use DBIx::Class::Storage::DBI::Replicated::Pool; use DBIx::Class::Storage::DBI::Replicated::Balancer; use DBIx::Class::Storage::DBI::Replicated::Types qw/BalancerClassNamePart DBICSchema DBICStorageDBI/; use MooseX::Types::Moose qw/ClassName HashRef Object/; use Scalar::Util 'reftype'; use Hash::Merge; use List::Util (); use Context::Preserve 'preserve_context'; use Try::Tiny; use namespace::clean -except => 'meta'; =head1 NAME DBIx::Class::Storage::DBI::Replicated - BETA Replicated database support =head1 SYNOPSIS The Following example shows how to change an existing $schema to a replicated storage type, add some replicated (read-only) databases, and perform reporting tasks. You should set the 'storage_type attribute to a replicated type. You should also define your arguments, such as which balancer you want and any arguments that the Pool object should get. my $schema = Schema::Class->clone; $schema->storage_type(['::DBI::Replicated', { balancer_type => '::Random' }]); $schema->connection(...); Next, you need to add in the Replicants. Basically this is an array of arrayrefs, where each arrayref is database connect information. Think of these arguments as what you'd pass to the 'normal' $schema->connect method. $schema->storage->connect_replicants( [$dsn1, $user, $pass, \%opts], [$dsn2, $user, $pass, \%opts], [$dsn3, $user, $pass, \%opts], ); Now, just use the $schema as you normally would. Automatically all reads will be delegated to the replicants, while writes to the master. $schema->resultset('Source')->search({name=>'etc'}); You can force a given query to use a particular storage using the search attribute 'force_pool'. For example: my $rs = $schema->resultset('Source')->search(undef, {force_pool=>'master'}); Now $rs will force everything (both reads and writes) to use whatever was setup as the master storage. 'master' is hardcoded to always point to the Master, but you can also use any Replicant name. Please see: L and the replicants attribute for more. Also see transactions and L for alternative ways to force read traffic to the master. In general, you should wrap your statements in a transaction when you are reading and writing to the same tables at the same time, since your replicants will often lag a bit behind the master. If you have a multi-statement read only transaction you can force it to select a random server in the pool by: my $rs = $schema->resultset('Source')->search( undef, { force_pool => $db->storage->read_handler->next_storage } ); =head1 DESCRIPTION Warning: This class is marked BETA. This has been running a production website using MySQL native replication as its backend and we have some decent test coverage but the code hasn't yet been stressed by a variety of databases. Individual DBs may have quirks we are not aware of. Please use this in first development and pass along your experiences/bug fixes. This class implements replicated data store for DBI. Currently you can define one master and numerous slave database connections. All write-type queries (INSERT, UPDATE, DELETE and even LAST_INSERT_ID) are routed to master database, all read-type queries (SELECTs) go to the slave database. Basically, any method request that L would normally handle gets delegated to one of the two attributes: L or to L. Additionally, some methods need to be distributed to all existing storages. This way our storage class is a drop in replacement for L. Read traffic is spread across the replicants (slaves) occurring to a user selected algorithm. The default algorithm is random weighted. =head1 NOTES The consistency between master and replicants is database specific. The Pool gives you a method to validate its replicants, removing and replacing them when they fail/pass predefined criteria. Please make careful use of the ways to force a query to run against Master when needed. =head1 REQUIREMENTS Replicated Storage has additional requirements not currently part of L. See L for more details. =head1 ATTRIBUTES This class defines the following attributes. =head2 schema The underlying L object this storage is attaching =cut has 'schema' => ( is=>'rw', isa=>DBICSchema, weak_ref=>1, required=>1, ); =head2 pool_type Contains the classname which will instantiate the L object. Defaults to: L. =cut has 'pool_type' => ( is=>'rw', isa=>ClassName, default=>'DBIx::Class::Storage::DBI::Replicated::Pool', handles=>{ 'create_pool' => 'new', }, ); =head2 pool_args Contains a hashref of initialized information to pass to the Balancer object. See L for available arguments. =cut has 'pool_args' => ( is=>'rw', isa=>HashRef, lazy=>1, default=>sub { {} }, ); =head2 balancer_type The replication pool requires a balance class to provider the methods for choose how to spread the query load across each replicant in the pool. =cut has 'balancer_type' => ( is=>'rw', isa=>BalancerClassNamePart, coerce=>1, required=>1, default=> 'DBIx::Class::Storage::DBI::Replicated::Balancer::First', handles=>{ 'create_balancer' => 'new', }, ); =head2 balancer_args Contains a hashref of initialized information to pass to the Balancer object. See L for available arguments. =cut has 'balancer_args' => ( is=>'rw', isa=>HashRef, lazy=>1, required=>1, default=>sub { {} }, ); =head2 pool Is a L or derived class. This is a container class for one or more replicated databases. =cut has 'pool' => ( is=>'ro', isa=>'DBIx::Class::Storage::DBI::Replicated::Pool', lazy_build=>1, handles=>[qw/ connect_replicants replicants has_replicants /], ); =head2 balancer Is a L or derived class. This is a class that takes a pool (L) =cut has 'balancer' => ( is=>'rw', isa=>'DBIx::Class::Storage::DBI::Replicated::Balancer', lazy_build=>1, handles=>[qw/auto_validate_every/], ); =head2 master The master defines the canonical state for a pool of connected databases. All the replicants are expected to match this databases state. Thus, in a classic Master / Slaves distributed system, all the slaves are expected to replicate the Master's state as quick as possible. This is the only database in the pool of databases that is allowed to handle write traffic. =cut has 'master' => ( is=> 'ro', isa=>DBICStorageDBI, lazy_build=>1, ); =head1 ATTRIBUTES IMPLEMENTING THE DBIx::Storage::DBI INTERFACE The following methods are delegated all the methods required for the L interface. =cut my $method_dispatch = { writer => [qw/ on_connect_do on_disconnect_do on_connect_call on_disconnect_call connect_info _connect_info throw_exception sql_maker sqlt_type create_ddl_dir deployment_statements datetime_parser datetime_parser_type build_datetime_parser last_insert_id insert update delete dbh txn_begin txn_do txn_commit txn_rollback txn_scope_guard _exec_txn_rollback _exec_txn_begin _exec_txn_commit deploy with_deferred_fk_checks dbh_do _prep_for_execute is_datatype_numeric _count_select svp_rollback svp_begin svp_release relname_to_table_alias _dbh_last_insert_id _default_dbi_connect_attributes _dbi_connect_info _dbic_connect_attributes auto_savepoint _query_start _query_end _format_for_trace _dbi_attrs_for_bind bind_attribute_by_data_type transaction_depth _dbh _select_args _dbh_execute_for_fetch _sql_maker _dbh_execute_inserts_with_no_binds _select_args_to_query _gen_sql_bind _svp_generate_name _normalize_connect_info _parse_connect_do savepoints _sql_maker_opts _use_multicolumn_in _conn_pid _dbh_autocommit _native_data_type _get_dbh sql_maker_class insert_bulk _insert_bulk _execute _do_query _dbh_execute /, Class::MOP::Class->initialize('DBIx::Class::Storage::DBIHacks')->get_method_list ], reader => [qw/ select select_single columns_info_for _dbh_columns_info_for _select /], unimplemented => [qw/ _arm_global_destructor _verify_pid _seems_connected _ping get_use_dbms_capability set_use_dbms_capability get_dbms_capability set_dbms_capability _dbh_details _dbh_get_info _determine_connector_driver _extract_driver_from_connect_info _describe_connection _warn_undetermined_driver sql_limit_dialect sql_quote_char sql_name_sep _prefetch_autovalues _perform_autoinc_retrieval _autoinc_supplied_for_op _resolve_bindattrs _max_column_bytesize _is_lob_type _is_binary_lob_type _is_binary_type _is_text_lob_type _prepare_sth _bind_sth_params /,( # the capability framework # not sure if CMOP->initialize does evil things to DBIC::S::DBI, fix if a problem grep { $_ =~ /^ _ (?: use | supports | determine_supports ) _ /x and $_ ne '_use_multicolumn_in' } ( Class::MOP::Class->initialize('DBIx::Class::Storage::DBI')->get_all_method_names ) )], }; if (DBIx::Class::_ENV_::DBICTEST) { my $seen; for my $type (keys %$method_dispatch) { for (@{$method_dispatch->{$type}}) { push @{$seen->{$_}}, $type; } } if (my @dupes = grep { @{$seen->{$_}} > 1 } keys %$seen) { die(join "\n", '', 'The following methods show up multiple times in ::Storage::DBI::Replicated handlers:', (map { "$_: " . (join ', ', @{$seen->{$_}}) } sort @dupes), '', ); } if (my @cant = grep { ! DBIx::Class::Storage::DBI->can($_) } keys %$seen) { die(join "\n", '', '::Storage::DBI::Replicated specifies handling of the following *NON EXISTING* ::Storage::DBI methods:', @cant, '', ); } } for my $method (@{$method_dispatch->{unimplemented}}) { __PACKAGE__->meta->add_method($method, sub { my $self = shift; $self->throw_exception("$method() must not be called on ".(blessed $self).' objects'); }); } =head2 read_handler Defines an object that implements the read side of L. =cut has 'read_handler' => ( is=>'rw', isa=>Object, lazy_build=>1, handles=>$method_dispatch->{reader}, ); =head2 write_handler Defines an object that implements the write side of L, as well as methods that don't write or read that can be called on only one storage, methods that return a C<$dbh>, and any methods that don't make sense to run on a replicant. =cut has 'write_handler' => ( is=>'ro', isa=>Object, lazy_build=>1, handles=>$method_dispatch->{writer}, ); has _master_connect_info_opts => (is => 'rw', isa => HashRef, default => sub { {} }); =head2 around: connect_info Preserves master's C options (for merging with replicants.) Also sets any Replicated-related options from connect_info, such as C, C, C and C. =cut around connect_info => sub { my ($next, $self, $info, @extra) = @_; $self->throw_exception( 'connect_info can not be retrieved from a replicated storage - ' . 'accessor must be called on a specific pool instance' ) unless defined $info; my $merge = Hash::Merge->new('LEFT_PRECEDENT'); my %opts; for my $arg (@$info) { next unless (reftype($arg)||'') eq 'HASH'; %opts = %{ $merge->merge($arg, \%opts) }; } delete $opts{dsn}; if (@opts{qw/pool_type pool_args/}) { $self->pool_type(delete $opts{pool_type}) if $opts{pool_type}; $self->pool_args( $merge->merge((delete $opts{pool_args} || {}), $self->pool_args) ); ## Since we possibly changed the pool_args, we need to clear the current ## pool object so that next time it is used it will be rebuilt. $self->clear_pool; } if (@opts{qw/balancer_type balancer_args/}) { $self->balancer_type(delete $opts{balancer_type}) if $opts{balancer_type}; $self->balancer_args( $merge->merge((delete $opts{balancer_args} || {}), $self->balancer_args) ); $self->balancer($self->_build_balancer) if $self->balancer; } $self->_master_connect_info_opts(\%opts); return preserve_context { $self->$next($info, @extra); } after => sub { # Make sure master is blessed into the correct class and apply role to it. my $master = $self->master; $master->_determine_driver; Moose::Meta::Class->initialize(ref $master); DBIx::Class::Storage::DBI::Replicated::WithDSN->meta->apply($master); # link pool back to master $self->pool->master($master); }; }; =head1 METHODS This class defines the following methods. =head2 BUILDARGS L when instantiating its storage passed itself as the first argument. So we need to massage the arguments a bit so that all the bits get put into the correct places. =cut sub BUILDARGS { my ($class, $schema, $storage_type_args, @args) = @_; return { schema=>$schema, %$storage_type_args, @args } } =head2 _build_master Lazy builder for the L attribute. =cut sub _build_master { my $self = shift @_; my $master = DBIx::Class::Storage::DBI->new($self->schema); $master } =head2 _build_pool Lazy builder for the L attribute. =cut sub _build_pool { my $self = shift @_; $self->create_pool(%{$self->pool_args}); } =head2 _build_balancer Lazy builder for the L attribute. This takes a Pool object so that the balancer knows which pool it's balancing. =cut sub _build_balancer { my $self = shift @_; $self->create_balancer( pool=>$self->pool, master=>$self->master, %{$self->balancer_args}, ); } =head2 _build_write_handler Lazy builder for the L attribute. The default is to set this to the L. =cut sub _build_write_handler { return shift->master; } =head2 _build_read_handler Lazy builder for the L attribute. The default is to set this to the L. =cut sub _build_read_handler { return shift->balancer; } =head2 around: connect_replicants All calls to connect_replicants needs to have an existing $schema tacked onto top of the args, since L needs it, and any L options merged with the master, with replicant opts having higher priority. =cut around connect_replicants => sub { my ($next, $self, @args) = @_; for my $r (@args) { $r = [ $r ] unless reftype $r eq 'ARRAY'; $self->throw_exception('coderef replicant connect_info not supported') if ref $r->[0] && reftype $r->[0] eq 'CODE'; # any connect_info options? my $i = 0; $i++ while $i < @$r && (reftype($r->[$i])||'') ne 'HASH'; # make one if none $r->[$i] = {} unless $r->[$i]; # merge if two hashes my @hashes = @$r[$i .. $#{$r}]; $self->throw_exception('invalid connect_info options') if (grep { reftype($_) eq 'HASH' } @hashes) != @hashes; $self->throw_exception('too many hashrefs in connect_info') if @hashes > 2; my $merge = Hash::Merge->new('LEFT_PRECEDENT'); my %opts = %{ $merge->merge(reverse @hashes) }; # delete them splice @$r, $i+1, ($#{$r} - $i), (); # make sure master/replicants opts don't clash my %master_opts = %{ $self->_master_connect_info_opts }; if (exists $opts{dbh_maker}) { delete @master_opts{qw/dsn user password/}; } delete $master_opts{dbh_maker}; # merge with master %opts = %{ $merge->merge(\%opts, \%master_opts) }; # update $r->[$i] = \%opts; } $self->$next($self->schema, @args); }; =head2 all_storages Returns an array of all the connected storage backends. The first element in the returned array is the master, and the rest are each of the replicants. =cut sub all_storages { my $self = shift @_; return grep {defined $_ && blessed $_} ( $self->master, values %{ $self->replicants }, ); } =head2 execute_reliably ($coderef, ?@args) Given a coderef, saves the current state of the L, forces it to use reliable storage (e.g. sets it to the master), executes a coderef and then restores the original state. Example: my $reliably = sub { my $name = shift @_; $schema->resultset('User')->create({name=>$name}); my $user_rs = $schema->resultset('User')->find({name=>$name}); return $user_rs; }; my $user_rs = $schema->storage->execute_reliably($reliably, 'John'); Use this when you must be certain of your database state, such as when you just inserted something and need to get a resultset including it, etc. =cut sub execute_reliably { my $self = shift; my $coderef = shift; $self->throw_exception('Second argument must be a coderef') unless( ref $coderef eq 'CODE'); ## replace the current read handler for the remainder of the scope local $self->{read_handler} = $self->master; &$coderef; } =head2 set_reliable_storage Sets the current $schema to be 'reliable', that is all queries, both read and write are sent to the master =cut sub set_reliable_storage { my $self = shift @_; my $schema = $self->schema; my $write_handler = $self->schema->storage->write_handler; $schema->storage->read_handler($write_handler); } =head2 set_balanced_storage Sets the current $schema to be use the for all reads, while all writes are sent to the master only =cut sub set_balanced_storage { my $self = shift @_; my $schema = $self->schema; my $balanced_handler = $self->schema->storage->balancer; $schema->storage->read_handler($balanced_handler); } =head2 connected Check that the master and at least one of the replicants is connected. =cut sub connected { my $self = shift @_; return $self->master->connected && $self->pool->connected_replicants; } =head2 ensure_connected Make sure all the storages are connected. =cut sub ensure_connected { my $self = shift @_; foreach my $source ($self->all_storages) { $source->ensure_connected(@_); } } =head2 limit_dialect Set the limit_dialect for all existing storages =cut sub limit_dialect { my $self = shift @_; foreach my $source ($self->all_storages) { $source->limit_dialect(@_); } return $self->master->limit_dialect; } =head2 quote_char Set the quote_char for all existing storages =cut sub quote_char { my $self = shift @_; foreach my $source ($self->all_storages) { $source->quote_char(@_); } return $self->master->quote_char; } =head2 name_sep Set the name_sep for all existing storages =cut sub name_sep { my $self = shift @_; foreach my $source ($self->all_storages) { $source->name_sep(@_); } return $self->master->name_sep; } =head2 set_schema Set the schema object for all existing storages =cut sub set_schema { my $self = shift @_; foreach my $source ($self->all_storages) { $source->set_schema(@_); } } =head2 debug set a debug flag across all storages =cut sub debug { my $self = shift @_; if(@_) { foreach my $source ($self->all_storages) { $source->debug(@_); } } return $self->master->debug; } =head2 debugobj set a debug object =cut sub debugobj { my $self = shift @_; return $self->master->debugobj(@_); } =head2 debugfh set a debugfh object =cut sub debugfh { my $self = shift @_; return $self->master->debugfh(@_); } =head2 debugcb set a debug callback =cut sub debugcb { my $self = shift @_; return $self->master->debugcb(@_); } =head2 disconnect disconnect everything =cut sub disconnect { my $self = shift @_; foreach my $source ($self->all_storages) { $source->disconnect(@_); } } =head2 cursor_class set cursor class on all storages, or return master's =cut sub cursor_class { my ($self, $cursor_class) = @_; if ($cursor_class) { $_->cursor_class($cursor_class) for $self->all_storages; } $self->master->cursor_class; } =head2 cursor set cursor class on all storages, or return master's, alias for L above. =cut sub cursor { my ($self, $cursor_class) = @_; if ($cursor_class) { $_->cursor($cursor_class) for $self->all_storages; } $self->master->cursor; } =head2 unsafe sets the L option on all storages or returns master's current setting =cut sub unsafe { my $self = shift; if (@_) { $_->unsafe(@_) for $self->all_storages; } return $self->master->unsafe; } =head2 disable_sth_caching sets the L option on all storages or returns master's current setting =cut sub disable_sth_caching { my $self = shift; if (@_) { $_->disable_sth_caching(@_) for $self->all_storages; } return $self->master->disable_sth_caching; } =head2 lag_behind_master returns the highest Replicant L setting =cut sub lag_behind_master { my $self = shift; return List::Util::max( map { $_->lag_behind_master } $self->replicants ); } =head2 is_replicating returns true if all replicants return true for L =cut sub is_replicating { my $self = shift; return (grep $_->is_replicating, $self->replicants) == ($self->replicants); } =head2 connect_call_datetime_setup calls L for all storages =cut sub connect_call_datetime_setup { my $self = shift; $_->connect_call_datetime_setup for $self->all_storages; } =head2 connect_call_rebase_sqlmaker calls L for all storages =cut sub connect_call_rebase_sqlmaker { my( $self, $target_base ) = @_; $_->connect_call_rebase_sqlmaker( $target_base ) for $self->all_storages; } sub _populate_dbh { my $self = shift; $_->_populate_dbh for $self->all_storages; } sub _connect { my $self = shift; $_->_connect for $self->all_storages; } sub _rebless { my $self = shift; $_->_rebless for $self->all_storages; } sub _determine_driver { my $self = shift; $_->_determine_driver for $self->all_storages; } sub _driver_determined { my $self = shift; if (@_) { $_->_driver_determined(@_) for $self->all_storages; } return $self->master->_driver_determined; } sub _init { my $self = shift; $_->_init for $self->all_storages; } sub _run_connection_actions { my $self = shift; $_->_run_connection_actions for $self->all_storages; } sub _do_connection_actions { my $self = shift; if (@_) { $_->_do_connection_actions(@_) for $self->all_storages; } } sub connect_call_do_sql { my $self = shift; $_->connect_call_do_sql(@_) for $self->all_storages; } sub disconnect_call_do_sql { my $self = shift; $_->disconnect_call_do_sql(@_) for $self->all_storages; } # not using the normalized_version, because we want to preserve # version numbers much longer than the conventional xxx.yyyzzz my $numify_ver = sub { my $ver = shift; my @numparts = split /\D+/, $ver; my $format = '%d.' . (join '', ('%06d') x (@numparts - 1)); return sprintf $format, @numparts; }; sub _server_info { my $self = shift; if (not $self->_dbh_details->{info}) { $self->_dbh_details->{info} = ( reduce { $a->[0] < $b->[0] ? $a : $b } map [ $numify_ver->($_->{dbms_version}), $_ ], map $_->_server_info, $self->all_storages )->[1]; } return $self->next::method; } sub _get_server_version { my $self = shift; return $self->_server_info->{dbms_version}; } =head1 GOTCHAS Due to the fact that replicants can lag behind a master, you must take care to make sure you use one of the methods to force read queries to a master should you need realtime data integrity. For example, if you insert a row, and then immediately re-read it from the database (say, by doing L<< $result->discard_changes|DBIx::Class::Row/discard_changes >>) or you insert a row and then immediately build a query that expects that row to be an item, you should force the master to handle reads. Otherwise, due to the lag, there is no certainty your data will be in the expected state. For data integrity, all transactions automatically use the master storage for all read and write queries. Using a transaction is the preferred and recommended method to force the master to handle all read queries. Otherwise, you can force a single query to use the master with the 'force_pool' attribute: my $result = $resultset->search(undef, {force_pool=>'master'})->find($pk); This attribute will safely be ignored by non replicated storages, so you can use the same code for both types of systems. Lastly, you can use the L method, which works very much like a transaction. For debugging, you can turn replication on/off with the methods L and L, however this operates at a global level and is not suitable if you have a shared Schema object being used by multiple processes, such as on a web application server. You can get around this limitation by using the Schema clone method. my $new_schema = $schema->clone; $new_schema->set_reliable_storage; ## $new_schema will use only the Master storage for all reads/writes while ## the $schema object will use replicated storage. =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. =cut __PACKAGE__->meta->make_immutable; 1; DBIx-Class-0.082843/lib/DBIx/Class/Storage/DBI/mysql.pm0000644000175000017500000001443514240132261021213 0ustar rabbitrabbitpackage DBIx::Class::Storage::DBI::mysql; use strict; use warnings; use base qw/DBIx::Class::Storage::DBI/; __PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker::MySQL'); __PACKAGE__->sql_limit_dialect ('LimitXY'); __PACKAGE__->sql_quote_char ('`'); __PACKAGE__->_use_multicolumn_in (1); sub with_deferred_fk_checks { my ($self, $sub) = @_; $self->_do_query('SET FOREIGN_KEY_CHECKS = 0'); $sub->(); $self->_do_query('SET FOREIGN_KEY_CHECKS = 1'); } sub connect_call_set_strict_mode { my $self = shift; # the @@sql_mode puts back what was previously set on the session handle $self->_do_query(q|SET SQL_MODE = CONCAT('ANSI,TRADITIONAL,ONLY_FULL_GROUP_BY,', @@sql_mode)|); $self->_do_query(q|SET SQL_AUTO_IS_NULL = 0|); } sub _dbh_last_insert_id { my ($self, $dbh, $source, $col) = @_; $dbh->{mysql_insertid}; } sub _prep_for_execute { my $self = shift; #(my $op, $ident, $args) = @_; # Only update and delete need special double-subquery treatment # Insert referencing the same table (i.e. SELECT MAX(id) + 1) seems # to work just fine on MySQL return $self->next::method(@_) if ( $_[0] eq 'select' or $_[0] eq 'insert' ); # FIXME FIXME FIXME - this is a terrible, gross, incomplete, MySQL-specific # hack but it works rather well for the limited amount of actual use cases # which can not be done in any other way on MySQL. This allows us to fix # some bugs without breaking MySQL support in the process and is also # crucial for more complex things like Shadow to be usable # # This code is just a pre-analyzer, working in tandem with ::SQLMaker::MySQL, # where the possibly-set value of {_modification_target_referenced_re} is # used to demarcate which part of the final SQL to double-wrap in a subquery. # # This is covered extensively by "offline" tests, so that competing SQLMaker # implementations could benefit from the existing tests just as well. # extract the source name, construct modification indicator re my $sm = $self->sql_maker; my $target_name = $_[1]->from; if (ref $target_name) { if ( ref $target_name eq 'SCALAR' and $$target_name =~ /^ (?: \` ( [^`]+ ) \` #` | ( [\w\-]+ ) ) $/x ) { # this is just a plain-ish name, which has been literal-ed for # whatever reason $target_name = (defined $1) ? $1 : $2; } else { # this is something very complex, perhaps a custom result source or whatnot # can't deal with it undef $target_name; } } local $sm->{_modification_target_referenced_re} = qr/ (?next::method(@_); } # here may seem like an odd place to override, but this is the first # method called after we are connected *and* the driver is determined # ($self is reblessed). See code flow in ::Storage::DBI::_populate_dbh sub _run_connection_actions { my $self = shift; # default mysql_auto_reconnect to off unless explicitly set if ( $self->_dbh->{mysql_auto_reconnect} and ! exists $self->_dbic_connect_attributes->{mysql_auto_reconnect} ) { $self->_dbh->{mysql_auto_reconnect} = 0; } $self->next::method(@_); } # we need to figure out what mysql version we're running sub sql_maker { my $self = shift; # it is critical to get the version *before* calling next::method # otherwise the potential connect will obliterate the sql_maker # next::method will populate in the _sql_maker accessor my $mysql_ver = $self->_server_info->{normalized_dbms_version}; my $sm = $self->next::method(@_); # mysql 3 does not understand a bare JOIN $sm->{_default_jointype} = 'INNER' if $mysql_ver < 4; $sm; } sub sqlt_type { return 'MySQL'; } sub deployment_statements { my $self = shift; my ($schema, $type, $version, $dir, $sqltargs, @rest) = @_; $sqltargs ||= {}; if ( ! exists $sqltargs->{producer_args}{mysql_version} and my $dver = $self->_server_info->{normalized_dbms_version} ) { $sqltargs->{producer_args}{mysql_version} = $dver; } $self->next::method($schema, $type, $version, $dir, $sqltargs, @rest); } sub _exec_svp_begin { my ($self, $name) = @_; $self->_dbh->do("SAVEPOINT $name"); } sub _exec_svp_release { my ($self, $name) = @_; $self->_dbh->do("RELEASE SAVEPOINT $name"); } sub _exec_svp_rollback { my ($self, $name) = @_; $self->_dbh->do("ROLLBACK TO SAVEPOINT $name") } sub is_replicating { my $status = shift->_get_dbh->selectrow_hashref('show slave status'); return ($status->{Slave_IO_Running} eq 'Yes') && ($status->{Slave_SQL_Running} eq 'Yes'); } sub lag_behind_master { return shift->_get_dbh->selectrow_hashref('show slave status')->{Seconds_Behind_Master}; } 1; =head1 NAME DBIx::Class::Storage::DBI::mysql - Storage::DBI class implementing MySQL specifics =head1 SYNOPSIS Storage::DBI autodetects the underlying MySQL database, and re-blesses the C<$storage> object into this class. my $schema = MyApp::Schema->connect( $dsn, $user, $pass, { on_connect_call => 'set_strict_mode' } ); =head1 DESCRIPTION This class implements MySQL specific bits of L, like AutoIncrement column support and savepoints. Also it augments the SQL maker to support the MySQL-specific C join type, which you can use by specifying C<< join_type => 'straight' >> in the L It also provides a one-stop on-connect macro C which sets session variables such that MySQL behaves more predictably as far as the SQL standard is concerned. =head1 STORAGE OPTIONS =head2 set_strict_mode Enables session-wide strict options upon connecting. Equivalent to: ->connect ( ... , { on_connect_do => [ q|SET SQL_MODE = CONCAT('ANSI,TRADITIONAL,ONLY_FULL_GROUP_BY,', @@sql_mode)|, q|SET SQL_AUTO_IS_NULL = 0|, ] }); =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. DBIx-Class-0.082843/lib/DBIx/Class/Storage/DBI/InterBase.pm0000644000175000017500000001012314240132261021710 0ustar rabbitrabbitpackage DBIx::Class::Storage::DBI::InterBase; use strict; use warnings; use base qw/DBIx::Class::Storage::DBI::Firebird::Common/; use mro 'c3'; use Try::Tiny; use namespace::clean; =head1 NAME DBIx::Class::Storage::DBI::InterBase - Driver for the Firebird RDBMS via L =head1 DESCRIPTION This driver is a subclass of L for use with L, see that driver for general details. You need to use either the L option or L (see L) for your code to function correctly with this driver. Otherwise you will likely get bizarre error messages such as C. The alternative is to use the L driver, which is more suitable for long running processes such as under L. To turn on L support, see L. =cut sub _ping { my $self = shift; my $dbh = $self->_dbh or return 0; local $dbh->{RaiseError} = 1; local $dbh->{PrintError} = 0; return try { $dbh->do('select 1 from rdb$database'); 1; } catch { 0; }; } # We want dialect 3 for new features and quoting to work, DBD::InterBase uses # dialect 1 (interbase compat) by default. sub _init { my $self = shift; $self->_set_sql_dialect(3); } sub _set_sql_dialect { my $self = shift; my $val = shift || 3; my $dsn = $self->_dbi_connect_info->[0]; return if ref($dsn) eq 'CODE'; if ($dsn !~ /ib_dialect=/) { $self->_dbi_connect_info->[0] = "$dsn;ib_dialect=$val"; my $connected = defined $self->_dbh; $self->disconnect; $self->ensure_connected if $connected; } } =head2 connect_call_use_softcommit Used as: on_connect_call => 'use_softcommit' In L to set the L C option. You need either this option or C<< disable_sth_caching => 1 >> for L code to function correctly (otherwise you may get C errors.) Or use the L driver. The downside of using this option is that your process will B see UPDATEs, INSERTs and DELETEs from other processes for already open statements. =cut sub connect_call_use_softcommit { my $self = shift; $self->_dbh->{ib_softcommit} = 1; } =head2 connect_call_datetime_setup Used as: on_connect_call => 'datetime_setup' In L to set the date and timestamp formats using: $dbh->{ib_time_all} = 'ISO'; See L for more details. The C data type supports up to 4 digits after the decimal point for second precision. The full precision is used. The C data type stores the date portion only, and it B be declared with: data_type => 'date' in your Result class. Timestamp columns can be declared with either C or C. You will need the L module for inflation to work. For L, this is a noop. =cut sub connect_call_datetime_setup { my $self = shift; $self->_get_dbh->{ib_time_all} = 'ISO'; } =head1 CAVEATS =over 4 =item * with L, you will not be able to see changes made to data in other processes. If this is an issue, use L as a workaround for the C errors, this of course adversely affects performance. Alternately, use the L driver. =back =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. =cut 1; # vim:sts=2 sw=2: DBIx-Class-0.082843/lib/DBIx/Class/Storage/DBI/Oracle/0000755000175000017500000000000014240676463020727 5ustar rabbitrabbitDBIx-Class-0.082843/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm0000644000175000017500000005115114240132261022623 0ustar rabbitrabbitpackage DBIx::Class::Storage::DBI::Oracle::Generic; use strict; use warnings; use base qw/DBIx::Class::Storage::DBI/; use mro 'c3'; use DBIx::Class::Carp; use Scope::Guard (); use Context::Preserve 'preserve_context'; use Try::Tiny; use namespace::clean; __PACKAGE__->sql_limit_dialect ('RowNum'); __PACKAGE__->sql_quote_char ('"'); __PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker::Oracle'); __PACKAGE__->datetime_parser_type('DateTime::Format::Oracle'); sub __cache_queries_with_max_lob_parts { 2 } =head1 NAME DBIx::Class::Storage::DBI::Oracle::Generic - Oracle Support for DBIx::Class =head1 SYNOPSIS # In your result (table) classes use base 'DBIx::Class::Core'; __PACKAGE__->add_columns({ id => { sequence => 'mysequence', auto_nextval => 1 } }); __PACKAGE__->set_primary_key('id'); # Somewhere in your Code # add some data to a table with a hierarchical relationship $schema->resultset('Person')->create ({ firstname => 'foo', lastname => 'bar', children => [ { firstname => 'child1', lastname => 'bar', children => [ { firstname => 'grandchild', lastname => 'bar', } ], }, { firstname => 'child2', lastname => 'bar', }, ], }); # select from the hierarchical relationship my $rs = $schema->resultset('Person')->search({}, { 'start_with' => { 'firstname' => 'foo', 'lastname' => 'bar' }, 'connect_by' => { 'parentid' => { '-prior' => { -ident => 'personid' } }, 'order_siblings_by' => { -asc => 'name' }, }; ); # this will select the whole tree starting from person "foo bar", creating # following query: # SELECT # me.persionid me.firstname, me.lastname, me.parentid # FROM # person me # START WITH # firstname = 'foo' and lastname = 'bar' # CONNECT BY # parentid = prior personid # ORDER SIBLINGS BY # firstname ASC =head1 DESCRIPTION This class implements base Oracle support. The subclass L is for C<(+)> joins in Oracle versions before 9.0. =head1 METHODS =cut sub _determine_supports_insert_returning { my $self = shift; # TODO find out which version supports the RETURNING syntax # 8i has it and earlier docs are a 404 on oracle.com return 1 if $self->_server_info->{normalized_dbms_version} >= 8.001; return 0; } __PACKAGE__->_use_insert_returning_bound (1); sub deployment_statements { my $self = shift;; my ($schema, $type, $version, $dir, $sqltargs, @rest) = @_; $sqltargs ||= {}; if ( ! exists $sqltargs->{producer_args}{oracle_version} and my $dver = $self->_server_info->{dbms_version} ) { $sqltargs->{producer_args}{oracle_version} = $dver; } $self->next::method($schema, $type, $version, $dir, $sqltargs, @rest); } sub _dbh_last_insert_id { my ($self, $dbh, $source, @columns) = @_; my @ids = (); foreach my $col (@columns) { my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col)); my $id = $self->_sequence_fetch( 'CURRVAL', $seq ); push @ids, $id; } return @ids; } sub _dbh_get_autoinc_seq { my ($self, $dbh, $source, $col) = @_; my $sql_maker = $self->sql_maker; my ($ql, $qr) = map { $_ ? (quotemeta $_) : '' } $sql_maker->_quote_chars; my $source_name; if ( ref $source->name eq 'SCALAR' ) { $source_name = ${$source->name}; # the ALL_TRIGGERS match further on is case sensitive - thus uppercase # stuff unless it is already quoted $source_name = uc ($source_name) if $source_name !~ /\"/; } else { $source_name = $source->name; $source_name = uc($source_name) unless $ql; } # trigger_body is a LONG local $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024); # disable default bindtype local $sql_maker->{bindtype} = 'normal'; # look up the correct sequence automatically my ( $schema, $table ) = $source_name =~ /( (?:${ql})? \w+ (?:${qr})? ) \. ( (?:${ql})? \w+ (?:${qr})? )/x; # if no explicit schema was requested - use the default schema (which in the case of Oracle is the db user) $schema ||= \'= USER'; my ($sql, @bind) = $sql_maker->select ( 'ALL_TRIGGERS', [qw/TRIGGER_BODY TABLE_OWNER TRIGGER_NAME/], { OWNER => $schema, TABLE_NAME => $table || $source_name, TRIGGERING_EVENT => { -like => '%INSERT%' }, # this will also catch insert_or_update TRIGGER_TYPE => { -like => '%BEFORE%' }, # we care only about 'before' triggers STATUS => 'ENABLED', }, ); # to find all the triggers that mention the column in question a simple # regex grep since the trigger_body above is a LONG and hence not searchable # via -like my @triggers = ( map { my %inf; @inf{qw/body schema name/} = @$_; \%inf } ( grep { $_->[0] =~ /\:new\.${ql}${col}${qr} | \:new\.$col/xi } @{ $dbh->selectall_arrayref( $sql, {}, @bind ) } ) ); # extract all sequence names mentioned in each trigger, throw away # triggers without apparent sequences @triggers = map { my @seqs = $_->{body} =~ / ( [\.\w\"\-]+ ) \. nextval /xig; @seqs ? { %$_, sequences => \@seqs } : () ; } @triggers; my $chosen_trigger; # if only one trigger matched things are easy if (@triggers == 1) { if ( @{$triggers[0]{sequences}} == 1 ) { $chosen_trigger = $triggers[0]; } else { $self->throw_exception( sprintf ( "Unable to introspect trigger '%s' for column '%s.%s' (references multiple sequences). " . "You need to specify the correct 'sequence' explicitly in '%s's column_info.", $triggers[0]{name}, $source_name, $col, $col, ) ); } } # got more than one matching trigger - see if we can narrow it down elsif (@triggers > 1) { my @candidates = grep { $_->{body} =~ / into \s+ \:new\.$col /xi } @triggers ; if (@candidates == 1 && @{$candidates[0]{sequences}} == 1) { $chosen_trigger = $candidates[0]; } else { $self->throw_exception( sprintf ( "Unable to reliably select a BEFORE INSERT trigger for column '%s.%s' (possibilities: %s). " . "You need to specify the correct 'sequence' explicitly in '%s's column_info.", $source_name, $col, ( join ', ', map { "'$_->{name}'" } @triggers ), $col, ) ); } } if ($chosen_trigger) { my $seq_name = $chosen_trigger->{sequences}[0]; $seq_name = "$chosen_trigger->{schema}.$seq_name" unless $seq_name =~ /\./; return \$seq_name if $seq_name =~ /\"/; # may already be quoted in-trigger return $seq_name; } $self->throw_exception( sprintf ( "No suitable BEFORE INSERT triggers found for column '%s.%s'. " . "You need to specify the correct 'sequence' explicitly in '%s's column_info.", $source_name, $col, $col, )); } sub _sequence_fetch { my ( $self, $type, $seq ) = @_; # use the maker to leverage quoting settings my $sth = $self->_dbh->prepare_cached( $self->sql_maker->select('DUAL', [ ref $seq ? \"$$seq.$type" : "$seq.$type" ] ) ); $sth->execute; my ($id) = $sth->fetchrow_array; $sth->finish; return $id; } sub _ping { my $self = shift; my $dbh = $self->_dbh or return 0; local $dbh->{RaiseError} = 1; local $dbh->{PrintError} = 0; return try { $dbh->do('select 1 from dual'); 1; } catch { 0; }; } sub _dbh_execute { #my ($self, $dbh, $sql, $bind, $bind_attrs) = @_; my ($self, $sql, $bind) = @_[0,2,3]; # Turn off sth caching for multi-part LOBs. See _prep_for_execute below local $self->{disable_sth_caching} = 1 if grep { ($_->[0]{_ora_lob_autosplit_part}||0) > (__cache_queries_with_max_lob_parts - 1) } @$bind; my $next = $self->next::can; # if we are already in a txn we can't retry anything return shift->$next(@_) if $self->transaction_depth; # cheat the blockrunner we are just about to create # we do want to rerun things regardless of outer state local $self->{_in_do_block}; return DBIx::Class::Storage::BlockRunner->new( storage => $self, wrap_txn => 0, retry_handler => sub { # ORA-01003: no statement parsed (someone changed the table somehow, # invalidating your cursor.) if ( $_[0]->failed_attempt_count == 1 and $_[0]->last_exception =~ /ORA-01003/ and my $dbh = $_[0]->storage->_dbh ) { delete $dbh->{CachedKids}{$sql}; return 1; } else { return 0; } }, )->run( $next, @_ ); } sub _dbh_execute_for_fetch { #my ($self, $sth, $tuple_status, @extra) = @_; # DBD::Oracle warns loudly on partial execute_for_fetch failures local $_[1]->{PrintWarn} = 0; shift->next::method(@_); } =head2 get_autoinc_seq Returns the sequence name for an autoincrement column =cut sub get_autoinc_seq { my ($self, $source, $col) = @_; $self->dbh_do('_dbh_get_autoinc_seq', $source, $col); } =head2 datetime_parser_type This sets the proper DateTime::Format module for use with L. =head2 connect_call_datetime_setup Used as: on_connect_call => 'datetime_setup' In L to set the session nls date, and timestamp values for use with L and the necessary environment variables for L, which is used by it. Maximum allowable precision is used, unless the environment variables have already been set. These are the defaults used: $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS'; $ENV{NLS_TIMESTAMP_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF'; $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM'; To get more than second precision with L for your timestamps, use something like this: use Time::HiRes 'time'; my $ts = DateTime->from_epoch(epoch => time); =cut sub connect_call_datetime_setup { my $self = shift; my $date_format = $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS'; my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF'; my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM'; $self->_do_query( "alter session set nls_date_format = '$date_format'" ); $self->_do_query( "alter session set nls_timestamp_format = '$timestamp_format'" ); $self->_do_query( "alter session set nls_timestamp_tz_format='$timestamp_tz_format'" ); } ### Note originally by Ron "Quinn" Straight ### https://github.com/Perl5/DBIx-Class/commit/5db2758de6 # # Handle LOB types in Oracle. Under a certain size (4k?), you can get away # with the driver assuming your input is the deprecated LONG type if you # encode it as a hex string. That ain't gonna fly at larger values, where # you'll discover you have to do what this does. # # This method had to be overridden because we need to set ora_field to the # actual column, and that isn't passed to the call (provided by Storage) to # bind_attribute_by_data_type. # # According to L, the ora_field isn't always necessary, but # adding it doesn't hurt, and will save your bacon if you're modifying a # table with more than one LOB column. # sub _dbi_attrs_for_bind { my ($self, $ident, $bind) = @_; my $attrs = $self->next::method($ident, $bind); # Push the column name into all bind attrs, make sure to *NOT* write into # the existing $attrs->[$idx]{..} hashref, as it is cached by the call to # next::method above. $attrs->[$_] and keys %{ $attrs->[$_] } and $bind->[$_][0]{dbic_colname} and $attrs->[$_] = { %{$attrs->[$_]}, ora_field => $bind->[$_][0]{dbic_colname} } for 0 .. $#$attrs; $attrs; } sub bind_attribute_by_data_type { my ($self, $dt) = @_; if ($self->_is_lob_type($dt)) { # this is a hot-ish codepath, store an escape-flag in the DBD namespace, so that # things like Class::Unload work (unlikely but possible) unless ($DBD::Oracle::__DBIC_DBD_VERSION_CHECK_OK__) { # no earlier - no later if ($DBD::Oracle::VERSION eq '1.23') { $self->throw_exception( "BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later ". "version (https://rt.cpan.org/Public/Bug/Display.html?id=46016)" ); } $DBD::Oracle::__DBIC_DBD_VERSION_CHECK_OK__ = 1; } return { ora_type => $self->_is_text_lob_type($dt) ? DBD::Oracle::ORA_CLOB() : DBD::Oracle::ORA_BLOB() }; } else { return undef; } } # Handle blob columns in WHERE. # # For equality comparisons: # # We split data intended for comparing to a LOB into 2000 character chunks and # compare them using dbms_lob.substr on the LOB column. # # We turn off DBD::Oracle LOB binds for these partial LOB comparisons by passing # dbd_attrs => undef, because these are regular varchar2 comparisons and # otherwise the query will fail. # # Since the most common comparison size is likely to be under 4000 characters # (TEXT comparisons previously deployed to other RDBMSes) we disable # prepare_cached for queries with more than two part comparisons to a LOB # column. This is done in _dbh_execute (above) which was previously overridden # to gracefully recover from an Oracle error. This is to be careful to not # exhaust your application's open cursor limit. # # See: # http://itcareershift.com/blog1/2011/02/21/oracle-max-number-of-open-cursors-complete-reference-for-the-new-oracle-dba/ # on the open_cursor limit. # # For everything else: # # We assume that everything that is not a LOB comparison, will most likely be a # LIKE query or some sort of function invocation. This may prove to be a naive # assumption in the future, but for now it should cover the two most likely # things users would want to do with a BLOB or CLOB, an equality test or a LIKE # query (on a CLOB.) # # For these expressions, the bind must NOT have the attributes of a LOB bind for # DBD::Oracle, otherwise the query will fail. This is done by passing # dbd_attrs => undef. sub _prep_for_execute { my $self = shift; my ($op) = @_; return $self->next::method(@_) if $op eq 'insert'; my ($sql, $bind) = $self->next::method(@_); my $lob_bind_indices = { map { ( $bind->[$_][0]{sqlt_datatype} and $self->_is_lob_type($bind->[$_][0]{sqlt_datatype}) ) ? ( $_ => 1 ) : () } ( 0 .. $#$bind ) }; return ($sql, $bind) unless %$lob_bind_indices; my ($final_sql, @final_binds); if ($op eq 'update') { $self->throw_exception('Update with complex WHERE clauses involving BLOB columns currently not supported') if $sql =~ /\bWHERE\b .+ \bWHERE\b/xs; my $where_sql; ($final_sql, $where_sql) = $sql =~ /^ (.+?) ( \bWHERE\b .+) /xs; if (my $set_bind_count = $final_sql =~ y/?//) { delete $lob_bind_indices->{$_} for (0 .. ($set_bind_count - 1)); # bail if only the update part contains blobs return ($sql, $bind) unless %$lob_bind_indices; @final_binds = splice @$bind, 0, $set_bind_count; $lob_bind_indices = { map { $_ - $set_bind_count => $lob_bind_indices->{$_} } keys %$lob_bind_indices }; } # if we got that far - assume the where SQL is all we got # (the first part is already shoved into $final_sql) $sql = $where_sql; } elsif ($op ne 'select' and $op ne 'delete') { $self->throw_exception("Unsupported \$op: $op"); } my @sql_parts = split /\?/, $sql; my $col_equality_re = qr/ (?<=\s) ([\w."]+) (\s*=\s*) $/x; for my $b_idx (0 .. $#$bind) { my $bound = $bind->[$b_idx]; if ( $lob_bind_indices->{$b_idx} and my ($col, $eq) = $sql_parts[0] =~ $col_equality_re ) { my $data = $bound->[1]; $data = "$data" if ref $data; my @parts = unpack '(a2000)*', $data; my @sql_frag; for my $idx (0..$#parts) { push @sql_frag, sprintf ( 'UTL_RAW.CAST_TO_VARCHAR2(RAWTOHEX(DBMS_LOB.SUBSTR(%s, 2000, %d))) = ?', $col, ($idx*2000 + 1), ); } my $sql_frag = '( ' . (join ' AND ', @sql_frag) . ' )'; $sql_parts[0] =~ s/$col_equality_re/$sql_frag/; $final_sql .= shift @sql_parts; for my $idx (0..$#parts) { push @final_binds, [ { %{ $bound->[0] }, _ora_lob_autosplit_part => $idx, dbd_attrs => undef, }, $parts[$idx] ]; } } else { $final_sql .= shift(@sql_parts) . '?'; push @final_binds, $lob_bind_indices->{$b_idx} ? [ { %{ $bound->[0] }, dbd_attrs => undef, }, $bound->[1], ] : $bound ; } } if (@sql_parts > 1) { carp "There are more placeholders than binds, this should not happen!"; @sql_parts = join ('?', @sql_parts); } $final_sql .= $sql_parts[0]; return ($final_sql, \@final_binds); } # Savepoints stuff. sub _exec_svp_begin { my ($self, $name) = @_; $self->_dbh->do("SAVEPOINT $name"); } # Oracle automatically releases a savepoint when you start another one with the # same name. sub _exec_svp_release { 1 } sub _exec_svp_rollback { my ($self, $name) = @_; $self->_dbh->do("ROLLBACK TO SAVEPOINT $name") } =head2 relname_to_table_alias L uses L names as table aliases in queries. Unfortunately, Oracle doesn't support identifiers over 30 chars in length, so the L name is shortened and appended with half of an MD5 hash. See L. =cut sub relname_to_table_alias { my $self = shift; my ($relname, $join_count) = @_; my $alias = $self->next::method(@_); # we need to shorten here in addition to the shortening in SQLMaker itself, # since the final relnames are crucial for the join optimizer return $self->sql_maker->_shorten_identifier($alias); } =head2 with_deferred_fk_checks Runs a coderef between: alter session set constraints = deferred ... alter session set constraints = immediate to defer foreign key checks. Constraints must be declared C for this to work. =cut sub with_deferred_fk_checks { my ($self, $sub) = @_; my $txn_scope_guard = $self->txn_scope_guard; $self->_do_query('alter session set constraints = deferred'); my $sg = Scope::Guard->new(sub { $self->_do_query('alter session set constraints = immediate'); }); return preserve_context { $sub->() } after => sub { $txn_scope_guard->commit }; } =head1 ATTRIBUTES Following additional attributes can be used in resultsets. =head2 connect_by or connect_by_nocycle =over 4 =item Value: \%connect_by =back A hashref of conditions used to specify the relationship between parent rows and child rows of the hierarchy. connect_by => { parentid => 'prior personid' } # adds a connect by statement to the query: # SELECT # me.persionid me.firstname, me.lastname, me.parentid # FROM # person me # CONNECT BY # parentid = prior persionid connect_by_nocycle => { parentid => 'prior personid' } # adds a connect by statement to the query: # SELECT # me.persionid me.firstname, me.lastname, me.parentid # FROM # person me # CONNECT BY NOCYCLE # parentid = prior persionid =head2 start_with =over 4 =item Value: \%condition =back A hashref of conditions which specify the root row(s) of the hierarchy. It uses the same syntax as L start_with => { firstname => 'Foo', lastname => 'Bar' } # SELECT # me.persionid me.firstname, me.lastname, me.parentid # FROM # person me # START WITH # firstname = 'foo' and lastname = 'bar' # CONNECT BY # parentid = prior persionid =head2 order_siblings_by =over 4 =item Value: ($order_siblings_by | \@order_siblings_by) =back Which column(s) to order the siblings by. It uses the same syntax as L 'order_siblings_by' => 'firstname ASC' # SELECT # me.persionid me.firstname, me.lastname, me.parentid # FROM # person me # CONNECT BY # parentid = prior persionid # ORDER SIBLINGS BY # firstname ASC =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. =cut 1; # vim:sts=2 sw=2: DBIx-Class-0.082843/lib/DBIx/Class/Storage/DBI/Oracle/WhereJoins.pm0000644000175000017500000000345713271562530023343 0ustar rabbitrabbitpackage DBIx::Class::Storage::DBI::Oracle::WhereJoins; use strict; use warnings; use base qw( DBIx::Class::Storage::DBI::Oracle::Generic ); use mro 'c3'; __PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker::OracleJoins'); 1; __END__ =pod =head1 NAME DBIx::Class::Storage::DBI::Oracle::WhereJoins - Oracle joins in WHERE syntax support (instead of ANSI). =head1 PURPOSE This module is used with Oracle < 9.0 due to lack of support for standard ANSI join syntax. =head1 SYNOPSIS DBIx::Class should automagically detect Oracle and use this module with no work from you. =head1 DESCRIPTION This class implements Oracle's WhereJoin support. Instead of: SELECT x FROM y JOIN z ON y.id = z.id It will write: SELECT x FROM y, z WHERE y.id = z.id It should properly support left joins, and right joins. Full outer joins are not possible due to the fact that Oracle requires the entire query be written to union the results of a left and right join, and by the time this module is called to create the where query and table definition part of the SQL query, it's already too late. =head1 METHODS See L for implementation details. =head1 BUGS Does not support full outer joins. Probably lots more. =head1 SEE ALSO =over =item L =item L =item L =item L =back =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. DBIx-Class-0.082843/lib/DBIx/Class/Storage/DBI/SQLite.pm0000644000175000017500000003013014240132261021175 0ustar rabbitrabbitpackage DBIx::Class::Storage::DBI::SQLite; use strict; use warnings; use base qw/DBIx::Class::Storage::DBI/; use mro 'c3'; use SQL::Abstract::Util 'is_plain_value'; use DBIx::Class::_Util qw(modver_gt_or_eq sigwarn_silencer); use DBIx::Class::Carp; use Try::Tiny; use namespace::clean; __PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker::SQLite'); __PACKAGE__->sql_limit_dialect ('LimitOffset'); __PACKAGE__->sql_quote_char ('"'); __PACKAGE__->datetime_parser_type ('DateTime::Format::SQLite'); sub _determine_supports_multicolumn_in { ( shift->_server_info->{normalized_dbms_version} < '3.014' ) ? 0 : 1 } =head1 NAME DBIx::Class::Storage::DBI::SQLite - Automatic primary key class for SQLite =head1 SYNOPSIS # In your table classes use base 'DBIx::Class::Core'; __PACKAGE__->set_primary_key('id'); =head1 DESCRIPTION This class implements autoincrements for SQLite. =head2 Known Issues =over =item RT79576 NOTE - This section applies to you only if ALL of these are true: * You are or were using DBD::SQLite with a version lesser than 1.38_01 * You are or were using DBIx::Class versions between 0.08191 and 0.08209 (inclusive) or between 0.08240-TRIAL and 0.08242-TRIAL (also inclusive) * You use objects with overloaded stringification and are feeding them to DBIC CRUD methods directly An unfortunate chain of events led to DBIx::Class silently hitting the problem described in L. In order to trigger the bug condition one needs to supply B bind value that is an object with overloaded stringification (numification is not relevant, only stringification is). When this is the case the internal DBIx::Class call to C<< $sth->bind_param >> would be executed in a way that triggers the above-mentioned DBD::SQLite bug. As a result all the logs and tracers will contain the expected values, however SQLite will receive B these bind positions being set to the value of the B supplied stringifiable object. Even if you upgrade DBIx::Class (which works around the bug starting from version 0.08210) you may still have corrupted/incorrect data in your database. DBIx::Class warned about this condition for several years, hoping to give anyone affected sufficient notice of the potential issues. The warning was removed in 2015/v0.082820. =back =head1 METHODS =cut sub backup { require File::Spec; require File::Copy; require POSIX; my ($self, $dir) = @_; $dir ||= './'; ## Where is the db file? my $dsn = $self->_dbi_connect_info()->[0]; my $dbname = $1 if($dsn =~ /dbname=([^;]+)/); if(!$dbname) { $dbname = $1 if($dsn =~ /^dbi:SQLite:(.+)$/i); } $self->throw_exception("Cannot determine name of SQLite db file") if(!$dbname || !-f $dbname); # print "Found database: $dbname\n"; # my $dbfile = file($dbname); my ($vol, $dbdir, $file) = File::Spec->splitpath($dbname); # my $file = $dbfile->basename(); $file = POSIX::strftime("%Y-%m-%d-%H_%M_%S", localtime()) . $file; $file = "B$file" while(-f $file); mkdir($dir) unless -f $dir; my $backupfile = File::Spec->catfile($dir, $file); my $res = File::Copy::copy($dbname, $backupfile); $self->throw_exception("Backup failed! ($!)") if(!$res); return $backupfile; } sub _exec_svp_begin { my ($self, $name) = @_; $self->_dbh->do("SAVEPOINT $name"); } sub _exec_svp_release { my ($self, $name) = @_; $self->_dbh->do("RELEASE SAVEPOINT $name"); } sub _exec_svp_rollback { my ($self, $name) = @_; $self->_dbh->do("ROLLBACK TO SAVEPOINT $name"); # resync state for older DBD::SQLite (RT#67843) # https://github.com/DBD-SQLite/DBD-SQLite/commit/9b3cdbf if ( ! modver_gt_or_eq('DBD::SQLite', '1.33') and $self->_dbh->FETCH('AutoCommit') ) { $self->_dbh->STORE('AutoCommit', 0); $self->_dbh->STORE('BegunWork', 1); } } sub _ping { my $self = shift; # Be extremely careful what we do here. SQLite is notoriously bad at # synchronizing its internal transaction state with {AutoCommit} # https://metacpan.org/source/ADAMK/DBD-SQLite-1.37/lib/DBD/SQLite.pm#L921 # There is a function http://www.sqlite.org/c3ref/get_autocommit.html # but DBD::SQLite does not expose it (nor does it seem to properly use it) # Therefore only execute a "ping" when we have no other choice *AND* # scrutinize the thrown exceptions to make sure we are where we think we are my $dbh = $self->_dbh or return undef; return undef unless $dbh->FETCH('Active'); return undef unless $dbh->ping; my $ping_fail; # older DBD::SQLite does not properly synchronize commit state between # the libsqlite and the $dbh unless (defined $DBD::SQLite::__DBIC_TXN_SYNC_SANE__) { $DBD::SQLite::__DBIC_TXN_SYNC_SANE__ = modver_gt_or_eq('DBD::SQLite', '1.38_02'); } # fallback to travesty unless ($DBD::SQLite::__DBIC_TXN_SYNC_SANE__) { # since we do not have access to sqlite3_get_autocommit(), do a trick # to attempt to *safely* determine what state are we *actually* in. # FIXME # also using T::T here leads to bizarre leaks - will figure it out later my $really_not_in_txn = do { local $@; # older versions of DBD::SQLite do not properly detect multiline BEGIN/COMMIT # statements to adjust their {AutoCommit} state. Hence use such a statement # pair here as well, in order to escape from poking {AutoCommit} needlessly # https://rt.cpan.org/Public/Bug/Display.html?id=80087 eval { # will fail instantly if already in a txn $dbh->do("-- multiline\nBEGIN"); $dbh->do("-- multiline\nCOMMIT"); 1; } or do { ($@ =~ /transaction within a transaction/) ? 0 : undef ; }; }; # if we were unable to determine this - we may very well be dead if (not defined $really_not_in_txn) { $ping_fail = 1; } # check the AC sync-state elsif ($really_not_in_txn xor $dbh->{AutoCommit}) { carp_unique (sprintf 'Internal transaction state of handle %s (apparently %s a transaction) does not seem to ' . 'match its AutoCommit attribute setting of %s - this is an indication of a ' . 'potentially serious bug in your transaction handling logic', $dbh, $really_not_in_txn ? 'NOT in' : 'in', $dbh->{AutoCommit} ? 'TRUE' : 'FALSE', ); # it is too dangerous to execute anything else in this state # assume everything works (safer - worst case scenario next statement throws) return 1; } } # do the actual test and return on no failure ( $ping_fail ||= ! try { $dbh->do('SELECT * FROM sqlite_master LIMIT 1'); 1 } ) or return 1; # the actual RV of _ping() # ping failed (or so it seems) - need to do some cleanup # it is possible to have a proper "connection", and have "ping" return # false anyway (e.g. corrupted file). In such cases DBD::SQLite still # keeps the actual file handle open. We don't really want this to happen, # so force-close the handle via DBI itself # local $@; # so that we do not clobber the real error as set above eval { $dbh->disconnect }; # if it fails - it fails undef; # the actual RV of _ping() } sub deployment_statements { my $self = shift; my ($schema, $type, $version, $dir, $sqltargs, @rest) = @_; $sqltargs ||= {}; if ( ! exists $sqltargs->{producer_args}{sqlite_version} and my $dver = $self->_server_info->{normalized_dbms_version} ) { $sqltargs->{producer_args}{sqlite_version} = $dver; } $self->next::method($schema, $type, $version, $dir, $sqltargs, @rest); } sub bind_attribute_by_data_type { # According to http://www.sqlite.org/datatype3.html#storageclasses # all numeric types are dynamically allocated up to 8 bytes per # individual value # Thus it should be safe and non-wasteful to bind everything as # SQL_BIGINT and have SQLite deal with storage/comparisons however # it deems correct $_[1] =~ /^ (?: int(?:[1248]|eger)? | (?:tiny|small|medium|big)int ) $/ix ? DBI::SQL_BIGINT() : undef ; } # FIXME - what the flying fuck... work around RT#76395 # DBD::SQLite warns on binding >32 bit values with 32 bit IVs sub _dbh_execute { if ( ( DBIx::Class::_ENV_::IV_SIZE < 8 or DBIx::Class::_ENV_::OS_NAME eq 'MSWin32' ) and ! defined $DBD::SQLite::__DBIC_CHECK_dbd_mishandles_bound_BIGINT ) { $DBD::SQLite::__DBIC_CHECK_dbd_mishandles_bound_BIGINT = ( modver_gt_or_eq('DBD::SQLite', '1.37') ) ? 1 : 0; } local $SIG{__WARN__} = sigwarn_silencer( qr/ \Qdatatype mismatch: bind\E \s (?: param \s+ \( \d+ \) \s+ [-+]? \d+ (?: \. 0*)? \Q as integer\E | \d+ \s type \s @{[ DBI::SQL_BIGINT() ]} \s as \s [-+]? \d+ (?: \. 0*)? ) /x ) if ( ( DBIx::Class::_ENV_::IV_SIZE < 8 or DBIx::Class::_ENV_::OS_NAME eq 'MSWin32' ) and $DBD::SQLite::__DBIC_CHECK_dbd_mishandles_bound_BIGINT ); shift->next::method(@_); } # DBD::SQLite (at least up to version 1.31 has a bug where it will # non-fatally numify a string value bound as an integer, resulting # in insertions of '0' into supposed-to-be-numeric fields # Since this can result in severe data inconsistency, remove the # bind attr if such a situation is detected # # FIXME - when a DBD::SQLite version is released that eventually fixes # this situation (somehow) - no-op this override once a proper DBD # version is detected sub _dbi_attrs_for_bind { my ($self, $ident, $bind) = @_; my $bindattrs = $self->next::method($ident, $bind); if (! defined $DBD::SQLite::__DBIC_CHECK_dbd_can_bind_bigint_values) { $DBD::SQLite::__DBIC_CHECK_dbd_can_bind_bigint_values = modver_gt_or_eq('DBD::SQLite', '1.37') ? 1 : 0; } for my $i (0.. $#$bindattrs) { if ( defined $bindattrs->[$i] and defined $bind->[$i][1] and grep { $bindattrs->[$i] eq $_ } ( DBI::SQL_INTEGER(), DBI::SQL_TINYINT(), DBI::SQL_SMALLINT(), DBI::SQL_BIGINT() ) ) { if ( $bind->[$i][1] !~ /^ [\+\-]? [0-9]+ (?: \. 0* )? $/x ) { carp_unique( sprintf ( "Non-integer value supplied for column '%s' despite the integer datatype", $bind->[$i][0]{dbic_colname} || "# $i" ) ); undef $bindattrs->[$i]; } elsif ( ! $DBD::SQLite::__DBIC_CHECK_dbd_can_bind_bigint_values ) { # unsigned 32 bit ints have a range of −2,147,483,648 to 2,147,483,647 # alternatively expressed as the hexadecimal numbers below # the comparison math will come out right regardless of ivsize, since # we are operating within 31 bits # P.S. 31 because one bit is lost for the sign if ($bind->[$i][1] > 0x7fff_ffff or $bind->[$i][1] < -0x8000_0000) { carp_unique( sprintf ( "An integer value occupying more than 32 bits was supplied for column '%s' " . 'which your version of DBD::SQLite (%s) can not bind properly so DBIC ' . 'will treat it as a string instead, consider upgrading to at least ' . 'DBD::SQLite version 1.37', $bind->[$i][0]{dbic_colname} || "# $i", DBD::SQLite->VERSION, ) ); undef $bindattrs->[$i]; } else { $bindattrs->[$i] = DBI::SQL_INTEGER() } } } } return $bindattrs; } =head2 connect_call_use_foreign_keys Used as: on_connect_call => 'use_foreign_keys' In L to turn on foreign key (including cascading) support for recent versions of SQLite and L. Executes: PRAGMA foreign_keys = ON See L for more information. =cut sub connect_call_use_foreign_keys { my $self = shift; $self->_do_query( 'PRAGMA foreign_keys = ON' ); } =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. =cut 1; DBIx-Class-0.082843/lib/DBIx/Class/Storage/DBI/NoBindVars.pm0000644000175000017500000000633314240132261022051 0ustar rabbitrabbitpackage DBIx::Class::Storage::DBI::NoBindVars; use strict; use warnings; use base 'DBIx::Class::Storage::DBI'; use mro 'c3'; =head1 NAME DBIx::Class::Storage::DBI::NoBindVars - Sometime DBDs have poor to no support for bind variables =head1 DESCRIPTION This class allows queries to work when the DBD or underlying library does not support the usual C placeholders, or at least doesn't support them very well, as is the case with L =head1 METHODS =head2 connect_info We can't cache very effectively without bind variables, so force the C setting to be turned on when the connect info is set. =cut sub connect_info { my $self = shift; my $retval = $self->next::method(@_); $self->disable_sth_caching(1); $retval; } =head2 _prep_for_execute Manually subs in the values for the usual C placeholders. =cut sub _prep_for_execute { my $self = shift; my ($sql, $bind) = $self->next::method(@_); # stringify bind args, quote via $dbh, and manually insert #my ($op, $ident, $args) = @_; my $ident = $_[1]; my @sql_part = split /\?/, $sql; my $new_sql; for (@$bind) { my $data = (ref $_->[1]) ? "$_->[1]" : $_->[1]; # always stringify, array types are currently not supported my $datatype = $_->[0]{sqlt_datatype}; $data = $self->_prep_interpolated_value($datatype, $data) if $datatype; $data = $self->_get_dbh->quote($data) unless ($datatype and $self->interpolate_unquoted($datatype, $data) ); $new_sql .= shift(@sql_part) . $data; } $new_sql .= join '', @sql_part; return ($new_sql, []); } =head2 interpolate_unquoted This method is called by L for every column in order to determine if its value should be quoted or not. The arguments are the current column data type and the actual bind value. The return value is interpreted as: true - do not quote, false - do quote. You should override this in you Storage::DBI:: subclass, if your RDBMS does not like quotes around certain datatypes (e.g. Sybase and integer columns). The default method returns false, except for integer datatypes paired with values containing nothing but digits. WARNING!!! Always validate that the bind-value is valid for the current datatype. Otherwise you may very well open the door to SQL injection attacks. =cut sub interpolate_unquoted { #my ($self, $datatype, $value) = @_; return 1 if ( defined $_[2] and $_[1] and $_[2] !~ /\D/ and $_[1] =~ /int(?:eger)? | (?:tiny|small|medium|big)int/ix ); return 0; } =head2 _prep_interpolated_value Given a datatype and the value to be inserted directly into a SQL query, returns the necessary string to represent that value (by e.g. adding a '$' sign) =cut sub _prep_interpolated_value { #my ($self, $datatype, $value) = @_; return $_[2]; } =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. =cut 1; DBIx-Class-0.082843/lib/DBIx/Class/Storage/DBI/Oracle.pm0000644000175000017500000000261413560502346021260 0ustar rabbitrabbitpackage DBIx::Class::Storage::DBI::Oracle; use strict; use warnings; use base qw/DBIx::Class::Storage::DBI/; use mro 'c3'; sub _rebless { my ($self) = @_; # Default driver my $class = $self->_server_info->{normalized_dbms_version} < 9 ? 'DBIx::Class::Storage::DBI::Oracle::WhereJoins' : 'DBIx::Class::Storage::DBI::Oracle::Generic'; $self->ensure_class_loaded ($class); bless $self, $class; } 1; =head1 NAME DBIx::Class::Storage::DBI::Oracle - Base class for Oracle driver =head1 DESCRIPTION This class simply provides a mechanism for discovering and loading a sub-class for a specific version Oracle backend. It should be transparent to the user. For Oracle major versions < 9 it loads the ::Oracle::WhereJoins subclass, which unrolls the ANSI join style DBIC normally generates into entries in the WHERE clause for compatibility purposes. To force usage of this version no matter the database version, add __PACKAGE__->storage_type('::DBI::Oracle::WhereJoins'); to your Schema class. =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. DBIx-Class-0.082843/lib/DBIx/Class/Storage/DBI/SQLAnywhere/0000755000175000017500000000000014240676463021664 5ustar rabbitrabbitDBIx-Class-0.082843/lib/DBIx/Class/Storage/DBI/SQLAnywhere/Cursor.pm0000644000175000017500000000466614240132261023472 0ustar rabbitrabbitpackage DBIx::Class::Storage::DBI::SQLAnywhere::Cursor; use strict; use warnings; use base 'DBIx::Class::Storage::DBI::Cursor'; use mro 'c3'; =head1 NAME DBIx::Class::Storage::DBI::SQLAnywhere::Cursor - GUID Support for SQL Anywhere over L =head1 DESCRIPTION This class is for normalizing GUIDs retrieved from SQL Anywhere via L. You probably don't want to be here, see L for information on the SQL Anywhere driver. Unfortunately when using L, GUIDs come back in binary, the purpose of this class is to transform them to text. L sets L to this class by default. It is overridable via your L. You can use L safely with this class and not lose the GUID normalizing functionality, L<::Cursor::Cached|DBIx::Class::Cursor::Cached> uses the underlying class data for the inner cursor class. =cut my $unpack_guids = sub { my ($select, $col_infos, $data, $storage) = @_; for my $select_idx (0..$#$select) { next unless ( defined $data->[$select_idx] and length($data->[$select_idx]) == 16 ); my $selected = $select->[$select_idx]; my $data_type = $col_infos->{$select->[$select_idx]}{data_type} or next; $data->[$select_idx] = $storage->_uuid_to_str($data->[$select_idx]) if $storage->_is_guid_type($data_type); } }; sub next { my $self = shift; my @row = $self->next::method(@_); $unpack_guids->( $self->args->[1], $self->{_colinfos} ||= $self->storage->_resolve_column_info($self->args->[0]), \@row, $self->storage ); return @row; } sub all { my $self = shift; my @rows = $self->next::method(@_); $unpack_guids->( $self->args->[1], $self->{_colinfos} ||= $self->storage->_resolve_column_info($self->args->[0]), $_, $self->storage ) for @rows; return @rows; } =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. =cut 1; # vim:sts=2 sw=2: DBIx-Class-0.082843/lib/DBIx/Class/Storage/DBI/MSSQL.pm0000644000175000017500000002400214240132261020734 0ustar rabbitrabbitpackage DBIx::Class::Storage::DBI::MSSQL; use strict; use warnings; use base qw/ DBIx::Class::Storage::DBI::UniqueIdentifier DBIx::Class::Storage::DBI::IdentityInsert /; use mro 'c3'; use Try::Tiny; use namespace::clean; __PACKAGE__->mk_group_accessors(simple => qw/ _identity _identity_method _no_scope_identity_query /); __PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker::MSSQL'); __PACKAGE__->sql_quote_char([qw/[ ]/]); __PACKAGE__->datetime_parser_type ( 'DBIx::Class::Storage::DBI::MSSQL::DateTime::Format' ); __PACKAGE__->new_guid('NEWID()'); sub _prep_for_execute { my $self = shift; my ($op, $ident, $args) = @_; # cast MONEY values properly if ($op eq 'insert' || $op eq 'update') { my $fields = $args->[0]; my $colinfo = $ident->columns_info([keys %$fields]); for my $col (keys %$fields) { # $ident is a result source object with INSERT/UPDATE ops if ( $colinfo->{$col}{data_type} && $colinfo->{$col}{data_type} =~ /^money\z/i ) { my $val = $fields->{$col}; $fields->{$col} = \['CAST(? AS MONEY)', [ $col => $val ]]; } } } my ($sql, $bind) = $self->next::method (@_); # SELECT SCOPE_IDENTITY only works within a statement scope. We # must try to always use this particular idiom first, as it is the # only one that guarantees retrieving the correct id under high # concurrency. When this fails we will fall back to whatever secondary # retrieval method is specified in _identity_method, but at this # point we don't have many guarantees we will get what we expected. # http://msdn.microsoft.com/en-us/library/ms190315.aspx # http://davidhayden.com/blog/dave/archive/2006/01/17/2736.aspx if ($self->_perform_autoinc_retrieval and not $self->_no_scope_identity_query) { $sql .= "\nSELECT SCOPE_IDENTITY()"; } return ($sql, $bind); } sub _execute { my $self = shift; # always list ctx - we need the $sth my ($rv, $sth, @bind) = $self->next::method(@_); if ($self->_perform_autoinc_retrieval) { # attempt to bring back the result of SELECT SCOPE_IDENTITY() we tacked # on in _prep_for_execute above my $identity; # we didn't even try on ftds unless ($self->_no_scope_identity_query) { ($identity) = try { $sth->fetchrow_array }; $sth->finish; } # SCOPE_IDENTITY failed, but we can do something else if ( (! $identity) && $self->_identity_method) { ($identity) = $self->_dbh->selectrow_array( 'select ' . $self->_identity_method ); } $self->_identity($identity); } return wantarray ? ($rv, $sth, @bind) : $rv; } sub last_insert_id { shift->_identity } # # MSSQL is retarded wrt ordered subselects. One needs to add a TOP # to *all* subqueries, but one also *can't* use TOP 100 PERCENT # http://sqladvice.com/forums/permalink/18496/22931/ShowThread.aspx#22931 # sub _select_args_to_query { #my ($self, $ident, $select, $cond, $attrs) = @_; my $self = shift; my $attrs = $_[3]; my $sql_bind = $self->next::method (@_); # see if this is an ordered subquery if ( $$sql_bind->[0] !~ /^ \s* \( \s* SELECT \s+ TOP \s+ \d+ \s+ /xi and scalar $self->_extract_order_criteria ($attrs->{order_by}) ) { $self->throw_exception( 'An ordered subselect encountered - this is not safe! Please see "Ordered Subselects" in DBIx::Class::Storage::DBI::MSSQL' ) unless $attrs->{unsafe_subselect_ok}; $$sql_bind->[0] =~ s/^ \s* \( \s* SELECT (?=\s) / '(SELECT TOP ' . $self->sql_maker->__max_int /exi; } $sql_bind; } # savepoint syntax is the same as in Sybase ASE sub _exec_svp_begin { my ($self, $name) = @_; $self->_dbh->do("SAVE TRANSACTION $name"); } # A new SAVE TRANSACTION with the same name releases the previous one. sub _exec_svp_release { 1 } sub _exec_svp_rollback { my ($self, $name) = @_; $self->_dbh->do("ROLLBACK TRANSACTION $name"); } sub sqlt_type { 'SQLServer' } sub sql_limit_dialect { my $self = shift; my $supports_rno = 0; if (exists $self->_server_info->{normalized_dbms_version}) { $supports_rno = 1 if $self->_server_info->{normalized_dbms_version} >= 9; } else { # User is connecting via DBD::Sybase and has no permission to run # stored procedures like xp_msver, or version detection failed for some # other reason. # So, we use a query to check if RNO is implemented. try { $self->_get_dbh->selectrow_array('SELECT row_number() OVER (ORDER BY rand())'); $supports_rno = 1; }; } return $supports_rno ? 'RowNumberOver' : 'Top'; } sub _ping { my $self = shift; my $dbh = $self->_dbh or return 0; local $dbh->{RaiseError} = 1; local $dbh->{PrintError} = 0; return try { $dbh->do('select 1'); 1; } catch { 0; }; } package # hide from PAUSE DBIx::Class::Storage::DBI::MSSQL::DateTime::Format; my $datetime_format = '%Y-%m-%d %H:%M:%S.%3N'; # %F %T my $smalldatetime_format = '%Y-%m-%d %H:%M:%S'; my ($datetime_parser, $smalldatetime_parser); sub parse_datetime { shift; require DateTime::Format::Strptime; $datetime_parser ||= DateTime::Format::Strptime->new( pattern => $datetime_format, on_error => 'croak', ); return $datetime_parser->parse_datetime(shift); } sub format_datetime { shift; require DateTime::Format::Strptime; $datetime_parser ||= DateTime::Format::Strptime->new( pattern => $datetime_format, on_error => 'croak', ); return $datetime_parser->format_datetime(shift); } sub parse_smalldatetime { shift; require DateTime::Format::Strptime; $smalldatetime_parser ||= DateTime::Format::Strptime->new( pattern => $smalldatetime_format, on_error => 'croak', ); return $smalldatetime_parser->parse_datetime(shift); } sub format_smalldatetime { shift; require DateTime::Format::Strptime; $smalldatetime_parser ||= DateTime::Format::Strptime->new( pattern => $smalldatetime_format, on_error => 'croak', ); return $smalldatetime_parser->format_datetime(shift); } 1; =head1 NAME DBIx::Class::Storage::DBI::MSSQL - Base Class for Microsoft SQL Server support in DBIx::Class =head1 SYNOPSIS This is the base class for Microsoft SQL Server support, used by L and L. =head1 IMPLEMENTATION NOTES =head2 IDENTITY information Microsoft SQL Server supports three methods of retrieving the IDENTITY value for inserted row: IDENT_CURRENT, @@IDENTITY, and SCOPE_IDENTITY(). SCOPE_IDENTITY is used here because it is the safest. However, it must be called is the same execute statement, not just the same connection. So, this implementation appends a SELECT SCOPE_IDENTITY() statement onto each INSERT to accommodate that requirement. C lists =item * C/C support (via extensions to the order_by parameter) =item * A rudimentary multicolumn IN operator =item * Support of C<...FOR UPDATE> type of select statement modifiers =back =cut # to pull in CAG and the frame-boundary-markers use base 'DBIx::Class'; use DBIx::Class::Carp; use namespace::clean; __PACKAGE__->mk_group_accessors (simple => qw/quote_char name_sep limit_dialect/); sub _quoting_enabled { ( defined $_[0]->{quote_char} and length $_[0]->{quote_char} ) ? 1 : 0 } # for when I need a normalized l/r pair sub _quote_chars { # in case we are called in the old !!$sm->_quote_chars fashion return () if !wantarray and ( ! defined $_[0]->{quote_char} or ! length $_[0]->{quote_char} ); map { defined $_ ? $_ : '' } ( ref $_[0]->{quote_char} ? (@{$_[0]->{quote_char}}) : ( ($_[0]->{quote_char}) x 2 ) ) ; } # FIXME when we bring in the storage weaklink, check its schema # weaklink and channel through $schema->throw_exception sub throw_exception { DBIx::Class::Exception->throw($_[1]) } sub belch { shift; # throw away $self carp( "Warning: ", @_ ); }; sub puke { shift->throw_exception("Fatal: " . join ('', @_)); }; # constants-methods are used not only here, but also in comparison tests sub __rows_bindtype () { +{ sqlt_datatype => 'integer' } } sub __offset_bindtype () { +{ sqlt_datatype => 'integer' } } sub __total_bindtype () { +{ sqlt_datatype => 'integer' } } # the "oh noes offset/top without limit" constant # limited to 31 bits for sanity (and consistency, # since it may be handed to the like of sprintf %u) # # Also *some* builds of SQLite fail the test # some_column BETWEEN ? AND ?: 1, 4294967295 # with the proper integer bind attrs # # Implemented as a method, since ::Storage::DBI also # refers to it (i.e. for the case of software_limit or # as the value to abuse with MSSQL ordered subqueries) sub __max_int () { 0x7FFFFFFF }; # we ne longer need to check this - DBIC has ways of dealing with it # specifically ::Storage::DBI::_resolve_bindattrs() sub _assert_bindval_matches_bindtype () { 1 }; # poor man's de-qualifier sub _quote { $_[0]->next::method( ( $_[0]{_dequalify_idents} and ! ref $_[1] ) ? $_[1] =~ / ([^\.]+) $ /x : $_[1] ); } sub _where_op_NEST { carp_unique ("-nest in search conditions is deprecated, you most probably wanted:\n" .q|{..., -and => [ \%cond0, \@cond1, \'cond2', \[ 'cond3', [ col => bind ] ], etc. ], ... }| ); shift->next::method(@_); } # Handle limit-dialect selection sub select { my ($self, $table, $fields, $where, $rs_attrs, $limit, $offset) = @_; ($fields, @{$self->{select_bind}}) = $self->_recurse_fields($fields); if (defined $offset) { $self->throw_exception('A supplied offset must be a non-negative integer') if ( $offset =~ /\D/ or $offset < 0 ); } $offset ||= 0; if (defined $limit) { $self->throw_exception('A supplied limit must be a positive integer') if ( $limit =~ /\D/ or $limit <= 0 ); } elsif ($offset) { $limit = $self->__max_int; } my ($sql, @bind); if ($limit) { # this is legacy code-flow from SQLA::Limit, it is not set in stone ($sql, @bind) = $self->next::method ($table, $fields, $where); my $limiter; if( $limiter = $self->can ('emulate_limit') ) { carp_unique( 'Support for the legacy emulate_limit() mechanism inherited from ' . 'SQL::Abstract::Limit has been deprecated, and will be removed at ' . 'some future point, as it gets in the way of architectural and/or ' . 'performance advances within DBIC. If your code uses this type of ' . 'limit specification please file an RT and provide the source of ' . 'your emulate_limit() implementation, so an acceptable upgrade-path ' . 'can be devised' ); } else { my $dialect = $self->limit_dialect or $self->throw_exception( "Unable to generate SQL-limit - no limit dialect specified on $self" ); $limiter = $self->can ("_$dialect") or $self->throw_exception(__PACKAGE__ . " does not implement the requested dialect '$dialect'"); } $sql = $self->$limiter ( $sql, { %{$rs_attrs||{}}, _selector_sql => $fields }, $limit, $offset ); } else { ($sql, @bind) = $self->next::method ($table, $fields, $where, $rs_attrs); } push @{$self->{where_bind}}, @bind; # this *must* be called, otherwise extra binds will remain in the sql-maker my @all_bind = $self->_assemble_binds; $sql .= $self->_lock_select ($rs_attrs->{for}) if $rs_attrs->{for}; return wantarray ? ($sql, @all_bind) : $sql; } sub _assemble_binds { my $self = shift; return map { @{ (delete $self->{"${_}_bind"}) || [] } } (qw/pre_select select from where group having order limit/); } my $for_syntax = { update => 'FOR UPDATE', shared => 'FOR SHARE', }; sub _lock_select { my ($self, $type) = @_; my $sql; if (ref($type) eq 'SCALAR') { $sql = "FOR $$type"; } else { $sql = $for_syntax->{$type} || $self->throw_exception( "Unknown SELECT .. FOR type '$type' requested" ); } return " $sql"; } # Handle default inserts sub insert { # optimized due to hotttnesss # my ($self, $table, $data, $options) = @_; # FIXME SQLMaker will emit INSERT INTO $table ( ) VALUES ( ) # which is sadly understood only by MySQL. Change default behavior here, # until we fold the extra pieces into SQLMaker properly if (! $_[2] or (ref $_[2] eq 'HASH' and !keys %{$_[2]} ) ) { my @bind; my $sql = sprintf( 'INSERT INTO %s DEFAULT VALUES', $_[0]->_quote($_[1]) ); if ( ($_[3]||{})->{returning} ) { my $s; ($s, @bind) = $_[0]->_insert_returning ($_[3]); $sql .= $s; } return ($sql, @bind); } next::method(@_); } sub _recurse_fields { my ($self, $fields) = @_; my $ref = ref $fields; return $self->_quote($fields) unless $ref; return $$fields if $ref eq 'SCALAR'; if ($ref eq 'ARRAY') { my (@select, @bind); for my $field (@$fields) { my ($select, @new_bind) = $self->_recurse_fields($field); push @select, $select; push @bind, @new_bind; } return (join(', ', @select), @bind); } elsif ($ref eq 'HASH') { my %hash = %$fields; # shallow copy my $as = delete $hash{-as}; # if supplied my ($func, $rhs, @toomany) = %hash; # there should be only one pair if (@toomany) { $self->throw_exception( "Malformed select argument - too many keys in hash: " . join (',', keys %$fields ) ); } if (lc ($func) eq 'distinct' && ref $rhs eq 'ARRAY' && @$rhs > 1) { $self->throw_exception ( 'The select => { distinct => ... } syntax is not supported for multiple columns.' .' Instead please use { group_by => [ qw/' . (join ' ', @$rhs) . '/ ] }' .' or { select => [ qw/' . (join ' ', @$rhs) . '/ ], distinct => 1 }' ); } my ($rhs_sql, @rhs_bind) = $self->_recurse_fields($rhs); my $select = sprintf ('%s( %s )%s', $self->_sqlcase($func), $rhs_sql, $as ? sprintf (' %s %s', $self->_sqlcase('as'), $self->_quote ($as) ) : '' ); return ($select, @rhs_bind); } elsif ( $ref eq 'REF' and ref($$fields) eq 'ARRAY' ) { return @{$$fields}; } else { $self->throw_exception( $ref . qq{ unexpected in _recurse_fields()} ); } } # this used to be a part of _order_by but is broken out for clarity. # What we have been doing forever is hijacking the $order arg of # SQLAC::select to pass in arbitrary pieces of data (first the group_by, # then pretty much the entire resultset attr-hash, as more and more # things in the SQLMaker space need to have more info about the $rs they # create SQL for. The alternative would be to keep expanding the # signature of _select with more and more positional parameters, which # is just gross. # # FIXME - this will have to transition out to a subclass when the effort # of folding the SQL generating machinery into SQLMaker takes place sub _parse_rs_attrs { my ($self, $arg) = @_; my $sql = ''; if ($arg->{group_by}) { if ( my ($group_sql, @group_bind) = $self->_recurse_fields($arg->{group_by}) ) { $sql .= $self->_sqlcase(' group by ') . $group_sql; push @{$self->{group_bind}}, @group_bind; } } if (defined $arg->{having}) { my ($frag, @bind) = $self->_recurse_where($arg->{having}); push(@{$self->{having_bind}}, @bind); $sql .= $self->_sqlcase(' having ') . $frag; } if (defined $arg->{order_by}) { $sql .= $self->_order_by ($arg->{order_by}); } return $sql; } sub _order_by { my ($self, $arg) = @_; # check that we are not called in legacy mode (order_by as 4th argument) if (ref $arg eq 'HASH' and not grep { $_ =~ /^-(?:desc|asc)/i } keys %$arg ) { return $self->_parse_rs_attrs ($arg); } else { my ($sql, @bind) = $self->next::method($arg); push @{$self->{order_bind}}, @bind; return $sql; } } sub _split_order_chunk { my ($self, $chunk) = @_; # strip off sort modifiers, but always succeed, so $1 gets reset $chunk =~ s/ (?: \s+ (ASC|DESC) )? \s* $//ix; return ( $chunk, ( $1 and uc($1) eq 'DESC' ) ? 1 : 0, ); } sub _table { # optimized due to hotttnesss # my ($self, $from) = @_; if (my $ref = ref $_[1] ) { if ($ref eq 'ARRAY') { return $_[0]->_recurse_from(@{$_[1]}); } elsif ($ref eq 'HASH') { return $_[0]->_recurse_from($_[1]); } elsif ($ref eq 'REF' && ref ${$_[1]} eq 'ARRAY') { my ($sql, @bind) = @{ ${$_[1]} }; push @{$_[0]->{from_bind}}, @bind; return $sql } } return $_[0]->next::method ($_[1]); } sub _generate_join_clause { my ($self, $join_type) = @_; $join_type = $self->{_default_jointype} if ! defined $join_type; return sprintf ('%s JOIN ', $join_type ? $self->_sqlcase($join_type) : '' ); } sub _recurse_from { my $self = shift; return join (' ', $self->_gen_from_blocks(@_) ); } sub _gen_from_blocks { my ($self, $from, @joins) = @_; my @fchunks = $self->_from_chunk_to_sql($from); for (@joins) { my ($to, $on) = @$_; # check whether a join type exists my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to; my $join_type; if (ref($to_jt) eq 'HASH' and defined($to_jt->{-join_type})) { $join_type = $to_jt->{-join_type}; $join_type =~ s/^\s+ | \s+$//xg; } my @j = $self->_generate_join_clause( $join_type ); if (ref $to eq 'ARRAY') { push(@j, '(', $self->_recurse_from(@$to), ')'); } else { push(@j, $self->_from_chunk_to_sql($to)); } my ($sql, @bind) = $self->_join_condition($on); push(@j, ' ON ', $sql); push @{$self->{from_bind}}, @bind; push @fchunks, join '', @j; } return @fchunks; } sub _from_chunk_to_sql { my ($self, $fromspec) = @_; return join (' ', do { if (! ref $fromspec) { $self->_quote($fromspec); } elsif (ref $fromspec eq 'SCALAR') { $$fromspec; } elsif (ref $fromspec eq 'REF' and ref $$fromspec eq 'ARRAY') { push @{$self->{from_bind}}, @{$$fromspec}[1..$#$$fromspec]; $$fromspec->[0]; } elsif (ref $fromspec eq 'HASH') { my ($as, $table, $toomuch) = ( map { $_ => $fromspec->{$_} } ( grep { $_ !~ /^\-/ } keys %$fromspec ) ); $self->throw_exception( "Only one table/as pair expected in from-spec but an exra '$toomuch' key present" ) if defined $toomuch; ($self->_from_chunk_to_sql($table), $self->_quote($as) ); } else { $self->throw_exception('Unsupported from refkind: ' . ref $fromspec ); } }); } sub _join_condition { my ($self, $cond) = @_; # Backcompat for the old days when a plain hashref # { 't1.col1' => 't2.col2' } meant ON t1.col1 = t2.col2 if ( ref $cond eq 'HASH' and keys %$cond == 1 and (keys %$cond)[0] =~ /\./ and ! ref ( (values %$cond)[0] ) ) { carp_unique( "ResultSet {from} structures with conditions not conforming to the " . "SQL::Abstract::Classic syntax are deprecated: you either need to stop " . "abusing {from} altogether, or express the condition properly using the " . "{ -ident => ... } operator" ); $cond = { keys %$cond => { -ident => values %$cond } } } elsif ( ref $cond eq 'ARRAY' ) { # do our own ORing so that the hashref-shim above is invoked my @parts; my @binds; foreach my $c (@$cond) { my ($sql, @bind) = $self->_join_condition($c); push @binds, @bind; push @parts, $sql; } return join(' OR ', @parts), @binds; } return $self->_recurse_where($cond); } # !!! EXPERIMENTAL API !!! WILL CHANGE !!! # # This is rather odd, but vanilla SQLA* variants do not have support for # multicolumn-IN expressions # Currently has only one callsite in ResultSet, body moved into this subclass # to raise API questions like: # - how do we convey a list of idents...? # - can binds reside on lhs? # # !!! EXPERIMENTAL API !!! WILL CHANGE !!! sub _where_op_multicolumn_in { my ($self, $lhs, $rhs) = @_; if (! ref $lhs or ref $lhs eq 'ARRAY') { my (@sql, @bind); for (ref $lhs ? @$lhs : $lhs) { if (! ref $_) { push @sql, $self->_quote($_); } elsif (ref $_ eq 'SCALAR') { push @sql, $$_; } elsif (ref $_ eq 'REF' and ref $$_ eq 'ARRAY') { my ($s, @b) = @$$_; push @sql, $s; push @bind, @b; } else { $self->throw_exception("ARRAY of @{[ ref $_ ]}es unsupported for multicolumn IN lhs..."); } } $lhs = \[ join(', ', @sql), @bind]; } elsif (ref $lhs eq 'SCALAR') { $lhs = \[ $$lhs ]; } elsif (ref $lhs eq 'REF' and ref $$lhs eq 'ARRAY' ) { # noop } else { $self->throw_exception( ref($lhs) . "es unsupported for multicolumn IN lhs..."); } # is this proper...? $rhs = \[ $self->_recurse_where($rhs) ]; for ($lhs, $rhs) { $$_->[0] = "( $$_->[0] )" unless $$_->[0] =~ /^ \s* \( .* \) \s* $/xs; } \[ join( ' IN ', shift @$$lhs, shift @$$rhs ), @$$lhs, @$$rhs ]; } ### ### Code that mostly used to be in DBIC::SQLMaker::LimitDialects ### sub _LimitOffset { my ( $self, $sql, $rs_attrs, $rows, $offset ) = @_; $sql .= $self->_parse_rs_attrs( $rs_attrs ) . " LIMIT ?"; push @{$self->{limit_bind}}, [ $self->__rows_bindtype => $rows ]; if ($offset) { $sql .= " OFFSET ?"; push @{$self->{limit_bind}}, [ $self->__offset_bindtype => $offset ]; } return $sql; } sub _LimitXY { my ( $self, $sql, $rs_attrs, $rows, $offset ) = @_; $sql .= $self->_parse_rs_attrs( $rs_attrs ) . " LIMIT "; if ($offset) { $sql .= '?, '; push @{$self->{limit_bind}}, [ $self->__offset_bindtype => $offset ]; } $sql .= '?'; push @{$self->{limit_bind}}, [ $self->__rows_bindtype => $rows ]; return $sql; } sub _RowNumberOver { my ($self, $sql, $rs_attrs, $rows, $offset ) = @_; # get selectors, and scan the order_by (if any) my $sq_attrs = $self->_subqueried_limit_attrs ( $sql, $rs_attrs ); # make up an order if none exists my $requested_order = (delete $rs_attrs->{order_by}) || $self->_rno_default_order; # the order binds (if any) will need to go at the end of the entire inner select local $self->{order_bind}; my $rno_ord = $self->_order_by ($requested_order); push @{$self->{select_bind}}, @{$self->{order_bind}}; # this is the order supplement magic my $mid_sel = $sq_attrs->{selection_outer}; if (my $extra_order_sel = $sq_attrs->{order_supplement}) { for my $extra_col (sort { $extra_order_sel->{$a} cmp $extra_order_sel->{$b} } keys %$extra_order_sel ) { $sq_attrs->{selection_inner} .= sprintf (', %s AS %s', $extra_col, $extra_order_sel->{$extra_col}, ); } } # and this is order re-alias magic for my $map ($sq_attrs->{order_supplement}, $sq_attrs->{outer_renames}) { for my $col (sort { (length $b) <=> (length $a) } keys %{$map||{}} ) { my $re_col = quotemeta ($col); $rno_ord =~ s/$re_col/$map->{$col}/; } } # whatever is left of the order_by (only where is processed at this point) my $group_having = $self->_parse_rs_attrs($rs_attrs); my $qalias = $self->_quote ($rs_attrs->{alias}); my $idx_name = $self->_quote ('rno__row__index'); push @{$self->{limit_bind}}, [ $self->__offset_bindtype => $offset + 1], [ $self->__total_bindtype => $offset + $rows ]; return <{selection_outer} FROM ( SELECT $mid_sel, ROW_NUMBER() OVER( $rno_ord ) AS $idx_name FROM ( SELECT $sq_attrs->{selection_inner} $sq_attrs->{query_leftover}${group_having} ) $qalias ) $qalias WHERE $idx_name >= ? AND $idx_name <= ? EOS } # some databases are happy with OVER (), some need OVER (ORDER BY (SELECT (1)) ) sub _rno_default_order { return undef; } sub _SkipFirst { my ($self, $sql, $rs_attrs, $rows, $offset) = @_; $sql =~ s/^ \s* SELECT \s+ //ix or $self->throw_exception("Unrecognizable SELECT: $sql"); return sprintf ('SELECT %s%s%s%s', $offset ? do { push @{$self->{pre_select_bind}}, [ $self->__offset_bindtype => $offset]; 'SKIP ? ' } : '' , do { push @{$self->{pre_select_bind}}, [ $self->__rows_bindtype => $rows ]; 'FIRST ? ' }, $sql, $self->_parse_rs_attrs ($rs_attrs), ); } sub _FirstSkip { my ($self, $sql, $rs_attrs, $rows, $offset) = @_; $sql =~ s/^ \s* SELECT \s+ //ix or $self->throw_exception("Unrecognizable SELECT: $sql"); return sprintf ('SELECT %s%s%s%s', do { push @{$self->{pre_select_bind}}, [ $self->__rows_bindtype => $rows ]; 'FIRST ? ' }, $offset ? do { push @{$self->{pre_select_bind}}, [ $self->__offset_bindtype => $offset]; 'SKIP ? ' } : '' , $sql, $self->_parse_rs_attrs ($rs_attrs), ); } sub _RowNum { my ( $self, $sql, $rs_attrs, $rows, $offset ) = @_; my $sq_attrs = $self->_subqueried_limit_attrs ($sql, $rs_attrs); my $qalias = $self->_quote ($rs_attrs->{alias}); my $idx_name = $self->_quote ('rownum__index'); my $order_group_having = $self->_parse_rs_attrs($rs_attrs); # if no offset (e.g. first page) - we can skip one of the subqueries if (! $offset) { push @{$self->{limit_bind}}, [ $self->__rows_bindtype => $rows ]; return <{selection_outer} FROM ( SELECT $sq_attrs->{selection_inner} $sq_attrs->{query_leftover}${order_group_having} ) $qalias WHERE ROWNUM <= ? EOS } # # There are two ways to limit in Oracle, one vastly faster than the other # on large resultsets: https://decipherinfosys.wordpress.com/2007/08/09/paging-and-countstopkey-optimization/ # However Oracle is retarded and does not preserve stable ROWNUM() values # when called twice in the same scope. Therefore unless the resultset is # ordered by a unique set of columns, it is not safe to use the faster # method, and the slower BETWEEN query is used instead # # FIXME - this is quite expensive, and does not perform caching of any sort # as soon as some of the SQLMaker-inlining work becomes viable consider adding # some rudimentary caching support if ( $rs_attrs->{order_by} and $rs_attrs->{result_source}->storage->_order_by_is_stable( @{$rs_attrs}{qw/from order_by where/} ) ) { push @{$self->{limit_bind}}, [ $self->__total_bindtype => $offset + $rows ], [ $self->__offset_bindtype => $offset + 1 ]; return <{selection_outer} FROM ( SELECT $sq_attrs->{selection_outer}, ROWNUM AS $idx_name FROM ( SELECT $sq_attrs->{selection_inner} $sq_attrs->{query_leftover}${order_group_having} ) $qalias WHERE ROWNUM <= ? ) $qalias WHERE $idx_name >= ? EOS } else { push @{$self->{limit_bind}}, [ $self->__offset_bindtype => $offset + 1 ], [ $self->__total_bindtype => $offset + $rows ]; return <{selection_outer} FROM ( SELECT $sq_attrs->{selection_outer}, ROWNUM AS $idx_name FROM ( SELECT $sq_attrs->{selection_inner} $sq_attrs->{query_leftover}${order_group_having} ) $qalias ) $qalias WHERE $idx_name BETWEEN ? AND ? EOS } } # used by _Top and _FetchFirst below sub _prep_for_skimming_limit { my ( $self, $sql, $rs_attrs ) = @_; # get selectors my $sq_attrs = $self->_subqueried_limit_attrs ($sql, $rs_attrs); my $requested_order = delete $rs_attrs->{order_by}; $sq_attrs->{order_by_requested} = $self->_order_by ($requested_order); $sq_attrs->{grpby_having} = $self->_parse_rs_attrs ($rs_attrs); # without an offset things are easy if (! $rs_attrs->{offset}) { $sq_attrs->{order_by_inner} = $sq_attrs->{order_by_requested}; } else { $sq_attrs->{quoted_rs_alias} = $self->_quote ($rs_attrs->{alias}); # localise as we already have all the bind values we need local $self->{order_bind}; # make up an order unless supplied or sanity check what we are given my $inner_order; if ($sq_attrs->{order_by_requested}) { $self->throw_exception ( 'Unable to safely perform "skimming type" limit with supplied unstable order criteria' ) unless ($rs_attrs->{result_source}->schema->storage->_order_by_is_stable( $rs_attrs->{from}, $requested_order, $rs_attrs->{where}, )); $inner_order = $requested_order; } else { $inner_order = [ map { "$rs_attrs->{alias}.$_" } ( @{ $rs_attrs->{result_source}->_identifying_column_set || $self->throw_exception(sprintf( 'Unable to auto-construct stable order criteria for "skimming type" limit ' . "dialect based on source '%s'", $rs_attrs->{result_source}->name) ); } ) ]; } $sq_attrs->{order_by_inner} = $self->_order_by ($inner_order); my @out_chunks; for my $ch ($self->_order_by_chunks ($inner_order)) { $ch = $ch->[0] if ref $ch eq 'ARRAY'; ($ch, my $is_desc) = $self->_split_order_chunk($ch); # !NOTE! outside chunks come in reverse order ( !$is_desc ) push @out_chunks, { ($is_desc ? '-asc' : '-desc') => \$ch }; } $sq_attrs->{order_by_middle} = $self->_order_by (\@out_chunks); # this is the order supplement magic $sq_attrs->{selection_middle} = $sq_attrs->{selection_outer}; if (my $extra_order_sel = $sq_attrs->{order_supplement}) { for my $extra_col (sort { $extra_order_sel->{$a} cmp $extra_order_sel->{$b} } keys %$extra_order_sel ) { $sq_attrs->{selection_inner} .= sprintf (', %s AS %s', $extra_col, $extra_order_sel->{$extra_col}, ); $sq_attrs->{selection_middle} .= ', ' . $extra_order_sel->{$extra_col}; } # Whatever order bindvals there are, they will be realiased and # reselected, and need to show up at end of the initial inner select push @{$self->{select_bind}}, @{$self->{order_bind}}; } # and this is order re-alias magic for my $map ($sq_attrs->{order_supplement}, $sq_attrs->{outer_renames}) { for my $col (sort { (length $b) <=> (length $a) } keys %{$map||{}}) { my $re_col = quotemeta ($col); $_ =~ s/$re_col/$map->{$col}/ for ($sq_attrs->{order_by_middle}, $sq_attrs->{order_by_requested}); } } } $sq_attrs; } sub _Top { my ( $self, $sql, $rs_attrs, $rows, $offset ) = @_; my $lim = $self->_prep_for_skimming_limit($sql, $rs_attrs); $sql = sprintf ('SELECT TOP %u %s %s %s %s', $rows + ($offset||0), $offset ? $lim->{selection_inner} : $lim->{selection_original}, $lim->{query_leftover}, $lim->{grpby_having}, $lim->{order_by_inner}, ); $sql = sprintf ('SELECT TOP %u %s FROM ( %s ) %s %s', $rows, $lim->{selection_middle}, $sql, $lim->{quoted_rs_alias}, $lim->{order_by_middle}, ) if $offset; $sql = sprintf ('SELECT %s FROM ( %s ) %s %s', $lim->{selection_outer}, $sql, $lim->{quoted_rs_alias}, $lim->{order_by_requested}, ) if $offset and ( $lim->{order_by_requested} or $lim->{selection_middle} ne $lim->{selection_outer} ); return $sql; } sub _FetchFirst { my ( $self, $sql, $rs_attrs, $rows, $offset ) = @_; my $lim = $self->_prep_for_skimming_limit($sql, $rs_attrs); $sql = sprintf ('SELECT %s %s %s %s FETCH FIRST %u ROWS ONLY', $offset ? $lim->{selection_inner} : $lim->{selection_original}, $lim->{query_leftover}, $lim->{grpby_having}, $lim->{order_by_inner}, $rows + ($offset||0), ); $sql = sprintf ('SELECT %s FROM ( %s ) %s %s FETCH FIRST %u ROWS ONLY', $lim->{selection_middle}, $sql, $lim->{quoted_rs_alias}, $lim->{order_by_middle}, $rows, ) if $offset; $sql = sprintf ('SELECT %s FROM ( %s ) %s %s', $lim->{selection_outer}, $sql, $lim->{quoted_rs_alias}, $lim->{order_by_requested}, ) if $offset and ( $lim->{order_by_requested} or $lim->{selection_middle} ne $lim->{selection_outer} ); return $sql; } sub _GenericSubQ { my ($self, $sql, $rs_attrs, $rows, $offset) = @_; my $main_rsrc = $rs_attrs->{result_source}; # Explicitly require an order_by # GenSubQ is slow enough as it is, just emulating things # like in other cases is not wise - make the user work # to shoot their DBA in the foot $self->throw_exception ( 'Generic Subquery Limit does not work on resultsets without an order. Provide a stable, ' . 'main-table-based order criteria.' ) unless $rs_attrs->{order_by}; my $usable_order_colinfo = $main_rsrc->storage->_extract_colinfo_of_stable_main_source_order_by_portion( $rs_attrs ); $self->throw_exception( 'Generic Subquery Limit can not work with order criteria based on sources other than the main one' ) if ( ! keys %{$usable_order_colinfo||{}} or grep { $_->{-source_alias} ne $rs_attrs->{alias} } (values %$usable_order_colinfo) ); ### ### ### we need to know the directions after we figured out the above - reextract *again* ### this is eyebleed - trying to get it to work at first my $supplied_order = delete $rs_attrs->{order_by}; my @order_bits = do { local $self->{quote_char}; local $self->{order_bind}; map { ref $_ ? $_->[0] : $_ } $self->_order_by_chunks ($supplied_order) }; # truncate to what we'll use $#order_bits = ( (keys %$usable_order_colinfo) - 1 ); # @order_bits likely will come back quoted (due to how the prefetch # rewriter operates # Hence supplement the column_info lookup table with quoted versions if ($self->quote_char) { $usable_order_colinfo->{$self->_quote($_)} = $usable_order_colinfo->{$_} for keys %$usable_order_colinfo; } # calculate the condition my $count_tbl_alias = 'rownum__emulation'; my $main_alias = $rs_attrs->{alias}; my $main_tbl_name = $main_rsrc->name; my (@unqualified_names, @qualified_names, @is_desc, @new_order_by); for my $bit (@order_bits) { ($bit, my $is_desc) = $self->_split_order_chunk($bit); push @is_desc, $is_desc; push @unqualified_names, $usable_order_colinfo->{$bit}{-colname}; push @qualified_names, $usable_order_colinfo->{$bit}{-fq_colname}; push @new_order_by, { ($is_desc ? '-desc' : '-asc') => $usable_order_colinfo->{$bit}{-fq_colname} }; }; my (@where_cond, @skip_colpair_stack); for my $i (0 .. $#order_bits) { my $ci = $usable_order_colinfo->{$order_bits[$i]}; my ($subq_col, $main_col) = map { "$_.$ci->{-colname}" } ($count_tbl_alias, $main_alias); my $cur_cond = { $subq_col => { ($is_desc[$i] ? '>' : '<') => { -ident => $main_col } } }; push @skip_colpair_stack, [ { $main_col => { -ident => $subq_col } }, ]; # we can trust the nullability flag because # we already used it during _id_col_set resolution # if ($ci->{is_nullable}) { push @{$skip_colpair_stack[-1]}, { $main_col => undef, $subq_col=> undef }; $cur_cond = [ { ($is_desc[$i] ? $subq_col : $main_col) => { '!=', undef }, ($is_desc[$i] ? $main_col : $subq_col) => undef, }, { $subq_col => { '!=', undef }, $main_col => { '!=', undef }, -and => $cur_cond, }, ]; } push @where_cond, { '-and', => [ @skip_colpair_stack[0..$i-1], $cur_cond ] }; } # reuse the sqlmaker WHERE, this will not be returning binds my $counted_where = do { local $self->{where_bind}; $self->where(\@where_cond); }; # construct the rownum condition by hand my $rownum_cond; if ($offset) { $rownum_cond = 'BETWEEN ? AND ?'; push @{$self->{limit_bind}}, [ $self->__offset_bindtype => $offset ], [ $self->__total_bindtype => $offset + $rows - 1] ; } else { $rownum_cond = '< ?'; push @{$self->{limit_bind}}, [ $self->__rows_bindtype => $rows ] ; } # and what we will order by inside my $inner_order_sql = do { local $self->{order_bind}; my $s = $self->_order_by (\@new_order_by); $self->throw_exception('Inner gensubq order may not contain binds... something went wrong') if @{$self->{order_bind}}; $s; }; ### resume originally scheduled programming ### ### # we need to supply the order for the supplements to be properly calculated my $sq_attrs = $self->_subqueried_limit_attrs ( $sql, { %$rs_attrs, order_by => \@new_order_by } ); my $in_sel = $sq_attrs->{selection_inner}; # add the order supplement (if any) as this is what will be used for the outer WHERE $in_sel .= ", $_" for sort keys %{$sq_attrs->{order_supplement}}; my $group_having_sql = $self->_parse_rs_attrs($rs_attrs); return sprintf (" SELECT $sq_attrs->{selection_outer} FROM ( SELECT $in_sel $sq_attrs->{query_leftover}${group_having_sql} ) %s WHERE ( SELECT COUNT(*) FROM %s %s $counted_where ) $rownum_cond $inner_order_sql ", map { $self->_quote ($_) } ( $rs_attrs->{alias}, $main_tbl_name, $count_tbl_alias, )); } # !!! THIS IS ALSO HORRIFIC !!! /me ashamed # # Generates inner/outer select lists for various limit dialects # which result in one or more subqueries (e.g. RNO, Top, RowNum) # Any non-main-table columns need to have their table qualifier # turned into a column alias (otherwise names in subqueries clash # and/or lose their source table) # # Returns mangled proto-sql, inner/outer strings of SQL QUOTED selectors # with aliases (to be used in whatever select statement), and an alias # index hashref of QUOTED SEL => QUOTED ALIAS pairs (to maybe be used # for string-subst higher up). # If an order_by is supplied, the inner select needs to bring out columns # used in implicit (non-selected) orders, and the order condition itself # needs to be realiased to the proper names in the outer query. Thus we # also return a hashref (order doesn't matter) of QUOTED EXTRA-SEL => # QUOTED ALIAS pairs, which is a list of extra selectors that do *not* # exist in the original select list sub _subqueried_limit_attrs { my ($self, $proto_sql, $rs_attrs) = @_; $self->throw_exception( 'Limit dialect implementation usable only in the context of DBIC (missing $rs_attrs)' ) unless ref ($rs_attrs) eq 'HASH'; # mangle the input sql as we will be replacing the selector entirely unless ( $rs_attrs->{_selector_sql} and $proto_sql =~ s/^ \s* SELECT \s* \Q$rs_attrs->{_selector_sql}//ix ) { $self->throw_exception("Unrecognizable SELECT: $proto_sql"); } my ($re_sep, $re_alias) = map { quotemeta $_ } ( $self->{name_sep}, $rs_attrs->{alias} ); # correlate select and as, build selection index my (@sel, $in_sel_index); for my $i (0 .. $#{$rs_attrs->{select}}) { my $s = $rs_attrs->{select}[$i]; my $sql_alias = (ref $s) eq 'HASH' ? $s->{-as} : undef; # we throw away the @bind here deliberately my ($sql_sel) = $self->_recurse_fields ($s); push @sel, { arg => $s, sql => $sql_sel, unquoted_sql => do { local $self->{quote_char}; ($self->_recurse_fields ($s))[0]; # ignore binds again }, as => $sql_alias || $rs_attrs->{as}[$i] || $self->throw_exception("Select argument $i ($s) without corresponding 'as'") , }; # anything with a placeholder in it needs re-selection $in_sel_index->{$sql_sel}++ unless $sql_sel =~ / (?: ^ | \W ) \? (?: \W | $ ) /x; $in_sel_index->{$self->_quote ($sql_alias)}++ if $sql_alias; # record unqualified versions too, so we do not have # to reselect the same column twice (in qualified and # unqualified form) if (! ref $s && $sql_sel =~ / $re_sep (.+) $/x) { $in_sel_index->{$1}++; } } # re-alias and remove any name separators from aliases, # unless we are dealing with the current source alias # (which will transcend the subqueries as it is necessary # for possible further chaining) # same for anything we do not recognize my ($sel, $renamed); for my $node (@sel) { push @{$sel->{original}}, $node->{sql}; if ( ! $in_sel_index->{$node->{sql}} or $node->{as} =~ / (?{unquoted_sql} =~ / (?{as} = $self->_unqualify_colname($node->{as}); my $quoted_as = $self->_quote($node->{as}); push @{$sel->{inner}}, sprintf '%s AS %s', $node->{sql}, $quoted_as; push @{$sel->{outer}}, $quoted_as; $renamed->{$node->{sql}} = $quoted_as; } else { push @{$sel->{inner}}, $node->{sql}; push @{$sel->{outer}}, $self->_quote (ref $node->{arg} ? $node->{as} : $node->{arg}); } } # see if the order gives us anything my $extra_order_sel; for my $chunk ($self->_order_by_chunks ($rs_attrs->{order_by})) { # order with bind $chunk = $chunk->[0] if (ref $chunk) eq 'ARRAY'; ($chunk) = $self->_split_order_chunk($chunk); next if $in_sel_index->{$chunk}; $extra_order_sel->{$chunk} ||= $self->_quote ( 'ORDER__BY__' . sprintf '%03d', scalar keys %{$extra_order_sel||{}} ); } return { query_leftover => $proto_sql, (map {( "selection_$_" => join (', ', @{$sel->{$_}} ) )} keys %$sel ), outer_renames => $renamed, order_supplement => $extra_order_sel, }; } sub _unqualify_colname { my ($self, $fqcn) = @_; $fqcn =~ s/ \. /__/xg; return $fqcn; } =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. =cut 1; DBIx-Class-0.082843/lib/DBIx/Class/SQLAHacks/0000755000175000017500000000000014240676463017232 5ustar rabbitrabbitDBIx-Class-0.082843/lib/DBIx/Class/SQLAHacks/MySQL.pm0000644000175000017500000000021012757225440020522 0ustar rabbitrabbitpackage # Hide from PAUSE DBIx::Class::SQLAHacks::MySQL; use warnings; use strict; use base qw( DBIx::Class::SQLMaker::MySQL ); 1; DBIx-Class-0.082843/lib/DBIx/Class/SQLAHacks/OracleJoins.pm0000644000175000017500000000022412757225440021772 0ustar rabbitrabbitpackage # Hide from PAUSE DBIx::Class::SQLAHacks::OracleJoins; use warnings; use strict; use base qw( DBIx::Class::SQLMaker::OracleJoins ); 1; DBIx-Class-0.082843/lib/DBIx/Class/SQLAHacks/SQLite.pm0000644000175000017500000000021212757225440020720 0ustar rabbitrabbitpackage # Hide from PAUSE DBIx::Class::SQLAHacks::SQLite; use warnings; use strict; use base qw( DBIx::Class::SQLMaker::SQLite ); 1; DBIx-Class-0.082843/lib/DBIx/Class/SQLAHacks/MSSQL.pm0000644000175000017500000000021012757225440020454 0ustar rabbitrabbitpackage # Hide from PAUSE DBIx::Class::SQLAHacks::MSSQL; use warnings; use strict; use base qw( DBIx::Class::SQLMaker::MSSQL ); 1; DBIx-Class-0.082843/lib/DBIx/Class/SQLAHacks/Oracle.pm0000644000175000017500000000021212757225440020764 0ustar rabbitrabbitpackage # Hide from PAUSE DBIx::Class::SQLAHacks::Oracle; use warnings; use strict; use base qw( DBIx::Class::SQLMaker::Oracle ); 1; DBIx-Class-0.082843/lib/DBIx/Class/Manual/0000755000175000017500000000000014240676463016735 5ustar rabbitrabbitDBIx-Class-0.082843/lib/DBIx/Class/Manual/Cookbook.pod0000644000175000017500000020771614240132261021203 0ustar rabbitrabbit=head1 NAME DBIx::Class::Manual::Cookbook - Miscellaneous recipes =head1 SEARCHING =head2 Paged results When you expect a large number of results, you can ask L for a paged resultset, which will fetch only a defined number of records at a time: my $rs = $schema->resultset('Artist')->search( undef, { page => 1, # page to return (defaults to 1) rows => 10, # number of results per page }, ); return $rs->all(); # all records for page 1 return $rs->page(2); # records for page 2 You can get a L object for the resultset (suitable for use in e.g. a template) using the C method: return $rs->pager(); =head2 Complex WHERE clauses Sometimes you need to formulate a query using specific operators: my @albums = $schema->resultset('Album')->search({ artist => { 'like', '%Lamb%' }, title => { 'like', '%Fear of Fours%' }, }); This results in something like the following C clause: WHERE artist LIKE ? AND title LIKE ? And the following bind values for the placeholders: C<'%Lamb%'>, C<'%Fear of Fours%'>. Other queries might require slightly more complex logic: my @albums = $schema->resultset('Album')->search({ -or => [ -and => [ artist => { 'like', '%Smashing Pumpkins%' }, title => 'Siamese Dream', ], artist => 'Starchildren', ], }); This results in the following C clause: WHERE ( artist LIKE '%Smashing Pumpkins%' AND title = 'Siamese Dream' ) OR artist = 'Starchildren' For more information on generating complex queries, see L. =head2 Retrieve one and only one row from a resultset Sometimes you need only the first "top" row of a resultset. While this can be easily done with L<< $rs->first|DBIx::Class::ResultSet/first >>, it is suboptimal, as a full blown cursor for the resultset will be created and then immediately destroyed after fetching the first row object. L<< $rs->single|DBIx::Class::ResultSet/single >> is designed specifically for this case - it will grab the first returned result without even instantiating a cursor. Before replacing all your calls to C with C please observe the following CAVEATS: =over =item * While single() takes a search condition just like search() does, it does _not_ accept search attributes. However one can always chain a single() to a search(): my $top_cd = $cd_rs->search({}, { order_by => 'rating' })->single; =item * Since single() is the engine behind find(), it is designed to fetch a single row per database query. Thus a warning will be issued when the underlying SELECT returns more than one row. Sometimes however this usage is valid: i.e. we have an arbitrary number of cd's but only one of them is at the top of the charts at any given time. If you know what you are doing, you can silence the warning by explicitly limiting the resultset size: my $top_cd = $cd_rs->search ({}, { order_by => 'rating', rows => 1 })->single; =back =head2 Arbitrary SQL through a custom ResultSource Sometimes you have to run arbitrary SQL because your query is too complex (e.g. it contains Unions, Sub-Selects, Stored Procedures, etc.) or has to be optimized for your database in a special way, but you still want to get the results as a L. This is accomplished by defining a L for your query, almost like you would define a regular ResultSource. package My::Schema::Result::UserFriendsComplex; use strict; use warnings; use base qw/DBIx::Class::Core/; __PACKAGE__->table_class('DBIx::Class::ResultSource::View'); # For the time being this is necessary even for virtual views __PACKAGE__->table($view_name); # # ->add_columns, etc. # # do not attempt to deploy() this view __PACKAGE__->result_source_instance->is_virtual(1); __PACKAGE__->result_source_instance->view_definition(q[ SELECT u.* FROM user u INNER JOIN user_friends f ON u.id = f.user_id WHERE f.friend_user_id = ? UNION SELECT u.* FROM user u INNER JOIN user_friends f ON u.id = f.friend_user_id WHERE f.user_id = ? ]); Next, you can execute your complex query using bind parameters like this: my $friends = $schema->resultset( 'UserFriendsComplex' )->search( {}, { bind => [ 12345, 12345 ] } ); ... and you'll get back a perfect L (except, of course, that you cannot modify the rows it contains, e.g. cannot call L or L on it). Note that you cannot have bind parameters unless is_virtual is set to true. =over =item * NOTE If you're using the old deprecated C<< $rsrc_instance->name(\'( SELECT ...') >> method for custom SQL execution, you are highly encouraged to update your code to use a virtual view as above. If you do not want to change your code, and just want to suppress the deprecation warning when you call L, add this line to your source definition, so that C will exclude this "table": sub sqlt_deploy_hook { $_[1]->schema->drop_table ($_[1]) } =back =head2 Using specific columns When you only want specific columns from a table, you can use C to specify which ones you need. This is useful to avoid loading columns with large amounts of data that you aren't about to use anyway: my $rs = $schema->resultset('Artist')->search( undef, { columns => [qw/ name /] } ); # Equivalent SQL: # SELECT artist.name FROM artist This is a shortcut for C and C. =head2 Using database functions or stored procedures The combination of C to specify the source for your column value (e.g. a column name, function, or stored procedure name). You then use C to set the column name you will use to access the returned value: my $rs = $schema->resultset('Artist')->search( {}, { select => [ 'name', { LENGTH => 'name' } ], as => [qw/ name name_length /], } ); # Equivalent SQL: # SELECT name name, LENGTH( name ) # FROM artist Note that the C attribute B with the SQL syntax C< SELECT foo AS bar > (see the documentation in L). You can control the C part of the generated SQL via the C<-as> field attribute as follows: my $rs = $schema->resultset('Artist')->search( {}, { join => 'cds', distinct => 1, '+select' => [ { count => 'cds.cdid', -as => 'amount_of_cds' } ], '+as' => [qw/num_cds/], order_by => { -desc => 'amount_of_cds' }, } ); # Equivalent SQL # SELECT me.artistid, me.name, me.rank, me.charfield, COUNT( cds.cdid ) AS amount_of_cds # FROM artist me LEFT JOIN cd cds ON cds.artist = me.artistid # GROUP BY me.artistid, me.name, me.rank, me.charfield # ORDER BY amount_of_cds DESC If your alias exists as a column in your base class (i.e. it was added with L), you just access it as normal. Our C class has a C column, so we just use the C accessor: my $artist = $rs->first(); my $name = $artist->name(); If on the other hand the alias does not correspond to an existing column, you have to fetch the value using the C accessor: my $name_length = $artist->get_column('name_length'); If you don't like using C, you can always create an accessor for any of your aliases using either of these: # Define accessor manually: sub name_length { shift->get_column('name_length'); } # Or use DBIx::Class::AccessorGroup: __PACKAGE__->mk_group_accessors('column' => 'name_length'); See also L. =head2 SELECT DISTINCT with multiple columns my $rs = $schema->resultset('Artist')->search( {}, { columns => [ qw/artist_id name rank/ ], distinct => 1 } ); my $rs = $schema->resultset('Artist')->search( {}, { columns => [ qw/artist_id name rank/ ], group_by => [ qw/artist_id name rank/ ], } ); # Equivalent SQL: # SELECT me.artist_id, me.name, me.rank # FROM artist me # GROUP BY artist_id, name, rank =head2 SELECT COUNT(DISTINCT colname) my $rs = $schema->resultset('Artist')->search( {}, { columns => [ qw/name/ ], distinct => 1 } ); my $rs = $schema->resultset('Artist')->search( {}, { columns => [ qw/name/ ], group_by => [ qw/name/ ], } ); my $count = $rs->count; # Equivalent SQL: # SELECT COUNT( * ) FROM (SELECT me.name FROM artist me GROUP BY me.name) me: =head2 Grouping results L supports C as follows: my $rs = $schema->resultset('Artist')->search( {}, { join => [qw/ cds /], select => [ 'name', { count => 'cds.id' } ], as => [qw/ name cd_count /], group_by => [qw/ name /] } ); # Equivalent SQL: # SELECT name, COUNT( cd.id ) FROM artist # LEFT JOIN cd ON artist.id = cd.artist # GROUP BY name Please see L documentation if you are in any way unsure about the use of the attributes above (C< join >, C< select >, C< as > and C< group_by >). =head2 Subqueries You can write subqueries relatively easily in DBIC. my $inside_rs = $schema->resultset('Artist')->search({ name => [ 'Billy Joel', 'Brittany Spears' ], }); my $rs = $schema->resultset('CD')->search({ artist_id => { -in => $inside_rs->get_column('id')->as_query }, }); The usual operators ( '=', '!=', -in, -not_in, etc.) are supported. B: You have to explicitly use '=' when doing an equality comparison. The following will B work: my $rs = $schema->resultset('CD')->search({ artist_id => $inside_rs->get_column('id')->as_query, # does NOT work }); =head3 Support Subqueries are supported in the where clause (first hashref), and in the from, select, and +select attributes. =head3 Correlated subqueries my $cdrs = $schema->resultset('CD'); my $rs = $cdrs->search({ year => { '=' => $cdrs->search( { artist_id => { -ident => 'me.artist_id' } }, { alias => 'sub_query' } )->get_column('year')->max_rs->as_query, }, }); That creates the following SQL: SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE year = ( SELECT MAX(sub_query.year) FROM cd sub_query WHERE artist_id = me.artist_id ) =head2 Predefined searches You can define frequently used searches as methods by subclassing L: package My::DBIC::ResultSet::CD; use strict; use warnings; use base 'DBIx::Class::ResultSet'; sub search_cds_ordered { my ($self) = @_; return $self->search( {}, { order_by => 'name DESC' }, ); } 1; If you're using L, simply place the file into the C directory next to your C directory, and it will be automatically loaded. If however you are still using L, first tell DBIx::Class to create an instance of the ResultSet class for you, in your My::DBIC::Schema::CD class: # class definition as normal use base 'DBIx::Class::Core'; __PACKAGE__->table('cd'); # tell DBIC to use the custom ResultSet class __PACKAGE__->resultset_class('My::DBIC::ResultSet::CD'); Note that C must be called after C and C, or you will get errors about missing methods. Then call your new method in your code: my $ordered_cds = $schema->resultset('CD')->search_cds_ordered(); =head2 Using SQL functions on the left hand side of a comparison Using SQL functions on the left hand side of a comparison is generally not a good idea since it requires a scan of the entire table. (Unless your RDBMS supports indexes on expressions - including return values of functions - and you create an index on the return value of the function in question.) However, it can be accomplished with C when necessary by resorting to literal SQL: $rs->search( \[ 'YEAR(date_of_birth) = ?', 1979 ] ); # Equivalent SQL: # SELECT * FROM employee WHERE YEAR(date_of_birth) = ? To include the function as part of a larger search, use the '-and' keyword to collect the search conditions: $rs->search({ -and => [ name => 'Bob', \[ 'YEAR(date_of_birth) = ?', 1979 ] ]}); # Equivalent SQL: # SELECT * FROM employee WHERE name = ? AND YEAR(date_of_birth) = ? Note: the syntax for specifying the bind value's datatype and value is explained in L. See also L. =head2 Software Limits When your RDBMS does not have a working SQL limit mechanism (e.g. Sybase ASE) and L is either too slow or does not work at all, you can try the L L attribute, which skips over records to simulate limits in the Perl layer. For example: my $paged_rs = $rs->search({}, { rows => 25, page => 3, order_by => [ 'me.last_name' ], software_limit => 1, }); You can set it as a default for your schema by placing the following in your C: __PACKAGE__->default_resultset_attributes({ software_limit => 1 }); B If you are dealing with large resultsets and your L or ODBC/ADO driver does not have proper cursor support (i.e. it loads the whole resultset into memory) then this feature will be extremely slow and use huge amounts of memory at best, and may cause your process to run out of memory and cause instability on your server at worst, beware! =head1 JOINS AND PREFETCHING =head2 Using joins and prefetch You can use the C attribute to allow searching on, or sorting your results by, one or more columns in a related table. This requires that you have defined the L. For example : My::Schema::CD->has_many( artists => 'My::Schema::Artist', 'artist_id'); To return all CDs matching a particular artist name, you specify the name of the relationship ('artists'): my $rs = $schema->resultset('CD')->search( { 'artists.name' => 'Bob Marley' }, { join => 'artists', # join the artist table } ); # Equivalent SQL: # SELECT cd.* FROM cd # JOIN artist ON cd.artist = artist.id # WHERE artist.name = 'Bob Marley' In that example both the join, and the condition use the relationship name rather than the table name (see L for more details on aliasing ). If required, you can now sort on any column in the related tables by including it in your C attribute, (again using the aliased relation name rather than table name) : my $rs = $schema->resultset('CD')->search( { 'artists.name' => 'Bob Marley' }, { join => 'artists', order_by => [qw/ artists.name /] } ); # Equivalent SQL: # SELECT cd.* FROM cd # JOIN artist ON cd.artist = artist.id # WHERE artist.name = 'Bob Marley' # ORDER BY artist.name Note that the C attribute should only be used when you need to search or sort using columns in a related table. Joining related tables when you only need columns from the main table will make performance worse! Now let's say you want to display a list of CDs, each with the name of the artist. The following will work fine: while (my $cd = $rs->next) { print "CD: " . $cd->title . ", Artist: " . $cd->artist->name; } There is a problem however. We have searched both the C and C tables in our main query, but we have only returned data from the C table. To get the artist name for any of the CD objects returned, L will go back to the database: SELECT artist.* FROM artist WHERE artist.id = ? A statement like the one above will run for each and every CD returned by our main query. Five CDs, five extra queries. A hundred CDs, one hundred extra queries! Thankfully, L has a C attribute to solve this problem. This allows you to fetch results from related tables in advance: my $rs = $schema->resultset('CD')->search( { 'artists.name' => 'Bob Marley' }, { join => 'artists', order_by => [qw/ artists.name /], prefetch => 'artists' # return artist data too! } ); # Equivalent SQL (note SELECT from both "cd" and "artist"): # SELECT cd.*, artist.* FROM cd # JOIN artist ON cd.artist = artist.id # WHERE artist.name = 'Bob Marley' # ORDER BY artist.name The code to print the CD list remains the same: while (my $cd = $rs->next) { print "CD: " . $cd->title . ", Artist: " . $cd->artist->name; } L has now prefetched all matching data from the C table, so no additional SQL statements are executed. You now have a much more efficient query. Also note that C should only be used when you know you will definitely use data from a related table. Pre-fetching related tables when you only need columns from the main table will make performance worse! =head2 Multiple joins In the examples above, the C attribute was a scalar. If you pass an array reference instead, you can join to multiple tables. In this example, we want to limit the search further, using C: # Relationships defined elsewhere: # CD->belongs_to('artist' => 'Artist'); # CD->has_one('liner_notes' => 'LinerNotes', 'cd'); my $rs = $schema->resultset('CD')->search( { 'artist.name' => 'Bob Marley' 'liner_notes.notes' => { 'like', '%some text%' }, }, { join => [qw/ artist liner_notes /], order_by => [qw/ artist.name /], } ); # Equivalent SQL: # SELECT cd.*, artist.*, liner_notes.* FROM cd # JOIN artist ON cd.artist = artist.id # JOIN liner_notes ON cd.id = liner_notes.cd # WHERE artist.name = 'Bob Marley' AND liner_notes.notes LIKE '%some text%' # ORDER BY artist.name =head2 Multi-step joins Sometimes you want to join more than one relationship deep. In this example, we want to find all C objects who have Cs whose C contain a specific string: # Relationships defined elsewhere: # Artist->has_many('cds' => 'CD', 'artist'); # CD->has_one('liner_notes' => 'LinerNotes', 'cd'); my $rs = $schema->resultset('Artist')->search( { 'liner_notes.notes' => { 'like', '%some text%' }, }, { join => { 'cds' => 'liner_notes' } } ); # Equivalent SQL: # SELECT artist.* FROM artist # LEFT JOIN cd ON artist.id = cd.artist # LEFT JOIN liner_notes ON cd.id = liner_notes.cd # WHERE liner_notes.notes LIKE '%some text%' Joins can be nested to an arbitrary level. So if we decide later that we want to reduce the number of Artists returned based on who wrote the liner notes: # Relationship defined elsewhere: # LinerNotes->belongs_to('author' => 'Person'); my $rs = $schema->resultset('Artist')->search( { 'liner_notes.notes' => { 'like', '%some text%' }, 'author.name' => 'A. Writer' }, { join => { 'cds' => { 'liner_notes' => 'author' } } } ); # Equivalent SQL: # SELECT artist.* FROM artist # LEFT JOIN cd ON artist.id = cd.artist # LEFT JOIN liner_notes ON cd.id = liner_notes.cd # LEFT JOIN author ON author.id = liner_notes.author # WHERE liner_notes.notes LIKE '%some text%' # AND author.name = 'A. Writer' =head2 Multi-step and multiple joins With various combinations of array and hash references, you can join tables in any combination you desire. For example, to join Artist to CD and Concert, and join CD to LinerNotes: # Relationships defined elsewhere: # Artist->has_many('concerts' => 'Concert', 'artist'); my $rs = $schema->resultset('Artist')->search( { }, { join => [ { cds => 'liner_notes' }, 'concerts' ], } ); # Equivalent SQL: # SELECT artist.* FROM artist # LEFT JOIN cd ON artist.id = cd.artist # LEFT JOIN liner_notes ON cd.id = liner_notes.cd # LEFT JOIN concert ON artist.id = concert.artist =head2 Multi-step prefetch C can be nested more than one relationship deep using the same syntax as a multi-step join: my $rs = $schema->resultset('Tag')->search( {}, { prefetch => { cd => 'artist' } } ); # Equivalent SQL: # SELECT tag.*, cd.*, artist.* FROM tag # JOIN cd ON tag.cd = cd.id # JOIN artist ON cd.artist = artist.id Now accessing our C and C relationships does not need additional SQL statements: my $tag = $rs->first; print $tag->cd->artist->name; =head1 ROW-LEVEL OPERATIONS =head2 Retrieving a result object's Schema It is possible to get a Schema object from a result object like so: my $schema = $cd->result_source->schema; # use the schema as normal: my $artist_rs = $schema->resultset('Artist'); This can be useful when you don't want to pass around a Schema object to every method. =head2 Getting the value of the primary key for the last database insert AKA getting last_insert_id Thanks to the core component PK::Auto, this is straightforward: my $foo = $rs->create(\%blah); # do more stuff my $id = $foo->id; # foo->my_primary_key_field will also work. If you are not using autoincrementing primary keys, this will probably not work, but then you already know the value of the last primary key anyway. =head2 Stringification Employ the standard stringification technique by using the L module. To make an object stringify itself as a single column, use something like this (replace C with the column/method of your choice): use overload '""' => sub { shift->name}, fallback => 1; For more complex stringification, you can use an anonymous subroutine: use overload '""' => sub { $_[0]->name . ", " . $_[0]->address }, fallback => 1; =head3 Stringification Example Suppose we have two tables: C and C. The table specifications are: Product(id, Description, category) Category(id, Description) C is a foreign key into the Category table. If you have a Product object C<$obj> and write something like print $obj->category things will not work as expected. To obtain, for example, the category description, you should add this method to the class defining the Category table: use overload "" => sub { my $self = shift; return $self->Description; }, fallback => 1; =head2 Want to know if find_or_create found or created a row? Just use C instead, then check C: my $obj = $rs->find_or_new({ blah => 'blarg' }); unless ($obj->in_storage) { $obj->insert; # do whatever else you wanted if it was a new row } =head2 Static sub-classing DBIx::Class result classes AKA adding additional relationships/methods/etc. to a model for a specific usage of the (shared) model. B package My::App::Schema; use base 'DBIx::Class::Schema'; # load subclassed classes from My::App::Schema::Result/ResultSet __PACKAGE__->load_namespaces; # load classes from shared model load_classes({ 'My::Shared::Model::Result' => [qw/ Foo Bar /]}); 1; B package My::App::Schema::Result::Baz; use strict; use warnings; use base 'My::Shared::Model::Result::Baz'; # WARNING: Make sure you call table() again in your subclass, # otherwise DBIx::Class::ResultSourceProxy::Table will not be called # and the class name is not correctly registered as a source __PACKAGE__->table('baz'); sub additional_method { return "I'm an additional method only needed by this app"; } 1; =head2 Dynamic Sub-classing DBIx::Class proxy classes AKA multi-class object inflation from one table L classes are proxy classes, therefore some different techniques need to be employed for more than basic subclassing. In this example we have a single user table that carries a boolean bit for admin. We would like to give the admin users objects (L) the same methods as a regular user but also special admin only methods. It doesn't make sense to create two separate proxy-class files for this. We would be copying all the user methods into the Admin class. There is a cleaner way to accomplish this. Overriding the C method within the User proxy-class gives us the effect we want. This method is called by L when inflating a result from storage. So we grab the object being returned, inspect the values we are looking for, bless it if it's an admin object, and then return it. See the example below: B package My::Schema; use base qw/DBIx::Class::Schema/; __PACKAGE__->load_namespaces; 1; B package My::Schema::Result::User; use strict; use warnings; use base qw/DBIx::Class::Core/; ### Define what our admin class is, for ensure_class_loaded() my $admin_class = __PACKAGE__ . '::Admin'; __PACKAGE__->table('users'); __PACKAGE__->add_columns(qw/user_id email password firstname lastname active admin/); __PACKAGE__->set_primary_key('user_id'); sub inflate_result { my $self = shift; my $ret = $self->next::method(@_); if( $ret->admin ) {### If this is an admin, rebless for extra functions $self->ensure_class_loaded( $admin_class ); bless $ret, $admin_class; } return $ret; } sub hello { print "I am a regular user.\n"; return ; } 1; package My::Schema::Result::User::Admin; use strict; use warnings; use base qw/My::Schema::Result::User/; # This line is important __PACKAGE__->table('users'); sub hello { print "I am an admin.\n"; return; } sub do_admin_stuff { print "I am doing admin stuff\n"; return ; } 1; B test.pl use warnings; use strict; use My::Schema; my $user_data = { email => 'someguy@place.com', password => 'pass1', admin => 0 }; my $admin_data = { email => 'someadmin@adminplace.com', password => 'pass2', admin => 1 }; my $schema = My::Schema->connection('dbi:Pg:dbname=test'); $schema->resultset('User')->create( $user_data ); $schema->resultset('User')->create( $admin_data ); ### Now we search for them my $user = $schema->resultset('User')->single( $user_data ); my $admin = $schema->resultset('User')->single( $admin_data ); print ref $user, "\n"; print ref $admin, "\n"; print $user->password , "\n"; # pass1 print $admin->password , "\n";# pass2; inherited from User print $user->hello , "\n";# I am a regular user. print $admin->hello, "\n";# I am an admin. ### The statement below will NOT print print "I can do admin stuff\n" if $user->can('do_admin_stuff'); ### The statement below will print print "I can do admin stuff\n" if $admin->can('do_admin_stuff'); Alternatively you can use L that implements exactly the above functionality. =head2 Skip result object creation for faster results DBIx::Class is not built for speed, it's built for convenience and ease of use, but sometimes you just need to get the data, and skip the fancy objects. To do this simply use L. my $rs = $schema->resultset('CD'); $rs->result_class('DBIx::Class::ResultClass::HashRefInflator'); my $hash_ref = $rs->find(1); Wasn't that easy? Beware, changing the Result class using L will replace any existing class completely including any special components loaded using load_components, eg L. =head2 Get raw data for blindingly fast results If the L solution above is not fast enough for you, you can use a DBIx::Class to return values exactly as they come out of the database with none of the convenience methods wrapped round them. This is used like so: my $cursor = $rs->cursor while (my @vals = $cursor->next) { # use $val[0..n] here } You will need to map the array offsets to particular columns (you can use the L attribute of L to force ordering). =head1 RESULTSET OPERATIONS =head2 Getting Schema from a ResultSet To get the L object from a ResultSet, do the following: $rs->result_source->schema =head2 Getting Columns Of Data AKA Aggregating Data If you want to find the sum of a particular column there are several ways, the obvious one is to use search: my $rs = $schema->resultset('Items')->search( {}, { select => [ { sum => 'Cost' } ], as => [ 'total_cost' ], # remember this 'as' is for DBIx::Class::ResultSet not SQL } ); my $tc = $rs->first->get_column('total_cost'); Or, you can use the L, which gets returned when you ask the C for a column using C: my $cost = $schema->resultset('Items')->get_column('Cost'); my $tc = $cost->sum; With this you can also do: my $minvalue = $cost->min; my $maxvalue = $cost->max; Or just iterate through the values of this column only: while ( my $c = $cost->next ) { print $c; } foreach my $c ($cost->all) { print $c; } C only has a limited number of built-in functions. If you need one that it doesn't have, then you can use the C method instead: my $avg = $cost->func('AVERAGE'); This will cause the following SQL statement to be run: SELECT AVERAGE(Cost) FROM Items me Which will of course only work if your database supports this function. See L for more documentation. =head2 Creating a result set from a set of rows Sometimes you have a (set of) result objects that you want to put into a resultset without the need to hit the DB again. You can do that by using the L method: my @uploadable_groups; while (my $group = $groups->next) { if ($group->can_upload($self)) { push @uploadable_groups, $group; } } my $new_rs = $self->result_source->resultset; $new_rs->set_cache(\@uploadable_groups); return $new_rs; =head1 USING RELATIONSHIPS =head2 Create a new row in a related table my $author = $book->create_related('author', { name => 'Fred'}); =head2 Search in a related table Only searches for books named 'Titanic' by the author in $author. my $books_rs = $author->search_related('books', { name => 'Titanic' }); =head2 Delete data in a related table Deletes only the book named Titanic by the author in $author. $author->delete_related('books', { name => 'Titanic' }); =head2 Ordering a relationship result set If you always want a relation to be ordered, you can specify this when you create the relationship. To order C<< $book->pages >> by descending page_number, create the relation as follows: __PACKAGE__->has_many('pages' => 'Page', 'book', { order_by => { -desc => 'page_number'} } ); =head2 Filtering a relationship result set If you want to get a filtered result set, you can just add to $attr as follows: __PACKAGE__->has_many('pages' => 'Page', 'book', { where => { scrap => 0 } } ); =head2 Many-to-many relationship bridges This is straightforward using L: package My::User; use base 'DBIx::Class::Core'; __PACKAGE__->table('user'); __PACKAGE__->add_columns(qw/id name/); __PACKAGE__->set_primary_key('id'); __PACKAGE__->has_many('user_address' => 'My::UserAddress', 'user'); __PACKAGE__->many_to_many('addresses' => 'user_address', 'address'); package My::UserAddress; use base 'DBIx::Class::Core'; __PACKAGE__->table('user_address'); __PACKAGE__->add_columns(qw/user address/); __PACKAGE__->set_primary_key(qw/user address/); __PACKAGE__->belongs_to('user' => 'My::User'); __PACKAGE__->belongs_to('address' => 'My::Address'); package My::Address; use base 'DBIx::Class::Core'; __PACKAGE__->table('address'); __PACKAGE__->add_columns(qw/id street town area_code country/); __PACKAGE__->set_primary_key('id'); __PACKAGE__->has_many('user_address' => 'My::UserAddress', 'address'); __PACKAGE__->many_to_many('users' => 'user_address', 'user'); $rs = $user->addresses(); # get all addresses for a user $rs = $address->users(); # get all users for an address my $address = $user->add_to_addresses( # returns a My::Address instance, # NOT a My::UserAddress instance! { country => 'United Kingdom', area_code => 'XYZ', town => 'London', street => 'Sesame', } ); =head2 Relationships across DB schemas Mapping relationships across L is easy as long as the schemas themselves are all accessible via the same DBI connection. In most cases, this means that they are on the same database host as each other and your connecting database user has the proper permissions to them. To accomplish this one only needs to specify the DB schema name in the table declaration, like so... package MyApp::Schema::Result::Artist; use base qw/DBIx::Class::Core/; __PACKAGE__->table('database1.artist'); # will use "database1.artist" in FROM clause __PACKAGE__->add_columns(qw/ artist_id name /); __PACKAGE__->set_primary_key('artist_id'); __PACKAGE__->has_many('cds' => 'MyApp::Schema::Result::Cd'); 1; Whatever string you specify there will be used to build the "FROM" clause in SQL queries. The big drawback to this is you now have DB schema names hardcoded in your class files. This becomes especially troublesome if you have multiple instances of your application to support a change lifecycle (e.g. DEV, TEST, PROD) and the DB schemas are named based on the environment (e.g. database1_dev). However, one can dynamically "map" to the proper DB schema by overriding the L method in your Schema class and building a renaming facility, like so: package MyApp::Schema; use Moose; extends 'DBIx::Class::Schema'; around connection => sub { my ( $inner, $self, $dsn, $username, $pass, $attr ) = ( shift, @_ ); my $postfix = delete $attr->{schema_name_postfix}; $inner->(@_); if ( $postfix ) { $self->append_db_name($postfix); } }; sub append_db_name { my ( $self, $postfix ) = @_; my @sources_with_db = grep { $_->name =~ /^\w+\./mx } map { $self->source($_) } $self->sources; foreach my $source (@sources_with_db) { my $name = $source->name; $name =~ s{^(\w+)\.}{${1}${postfix}\.}mx; $source->name($name); } } 1; By overriding the L method and extracting a custom option from the provided \%attr hashref one can then simply iterate over all the Schema's ResultSources, renaming them as needed. To use this facility, simply add or modify the \%attr hashref that is passed to L, as follows: my $schema = MyApp::Schema->connect( $dsn, $user, $pass, { schema_name_postfix => '_dev' # ... Other options as desired ... }) Obviously, one could accomplish even more advanced mapping via a hash map or a callback routine. =head1 TRANSACTIONS =head2 Transactions with txn_do As of version 0.04001, there is improved transaction support in L and L. Here is an example of the recommended way to use it: my $genus = $schema->resultset('Genus')->find(12); my $coderef2 = sub { $genus->extinct(1); $genus->update; }; my $coderef1 = sub { $genus->add_to_species({ name => 'troglodyte' }); $genus->wings(2); $genus->update; $schema->txn_do($coderef2); # Can have a nested transaction. Only the outer will actualy commit return $genus->species; }; use Try::Tiny; my $rs; try { $rs = $schema->txn_do($coderef1); } catch { # Transaction failed die "the sky is falling!" # if ($_ =~ /Rollback failed/); # Rollback failed deal_with_failed_transaction(); }; Note: by default C will re-run the coderef one more time if an error occurs due to client disconnection (e.g. the server is bounced). You need to make sure that your coderef can be invoked multiple times without terrible side effects. Nested transactions will work as expected. That is, only the outermost transaction will actually issue a commit to the $dbh, and a rollback at any level of any transaction will cause the entire nested transaction to fail. =head2 Nested transactions and auto-savepoints If savepoints are supported by your RDBMS, it is possible to achieve true nested transactions with minimal effort. To enable auto-savepoints via nested transactions, supply the C<< auto_savepoint = 1 >> connection attribute. Here is an example of true nested transactions. In the example, we start a big task which will create several rows. Generation of data for each row is a fragile operation and might fail. If we fail creating something, depending on the type of failure, we want to abort the whole task, or only skip the failed row. my $schema = MySchema->connect("dbi:Pg:dbname=my_db"); # Start a transaction. Every database change from here on will only be # committed into the database if the try block succeeds. use Try::Tiny; my $exception; try { $schema->txn_do(sub { # SQL: BEGIN WORK; my $job = $schema->resultset('Job')->create({ name=> 'big job' }); # SQL: INSERT INTO job ( name) VALUES ( 'big job' ); for (1..10) { # Start a nested transaction, which in fact sets a savepoint. try { $schema->txn_do(sub { # SQL: SAVEPOINT savepoint_0; my $thing = $schema->resultset('Thing')->create({ job=>$job->id }); # SQL: INSERT INTO thing ( job) VALUES ( 1 ); if (rand > 0.8) { # This will generate an error, thus setting $@ $thing->update({force_fail=>'foo'}); # SQL: UPDATE thing SET force_fail = 'foo' # WHERE ( id = 42 ); } }); } catch { # SQL: ROLLBACK TO SAVEPOINT savepoint_0; # There was an error while creating a $thing. Depending on the error # we want to abort the whole transaction, or only rollback the # changes related to the creation of this $thing # Abort the whole job if ($_ =~ /horrible_problem/) { print "something horrible happened, aborting job!"; die $_; # rethrow error } # Ignore this $thing, report the error, and continue with the # next $thing print "Cannot create thing: $_"; } # There was no error, so save all changes since the last # savepoint. # SQL: RELEASE SAVEPOINT savepoint_0; } }); } catch { $exception = $_; }; if ($exception) { # There was an error while handling the $job. Rollback all changes # since the transaction started, including the already committed # ('released') savepoints. There will be neither a new $job nor any # $thing entry in the database. # SQL: ROLLBACK; print "ERROR: $exception\n"; } else { # There was no error while handling the $job. Commit all changes. # Only now other connections can see the newly created $job and # @things. # SQL: COMMIT; print "Ok\n"; } In this example it might be hard to see where the rollbacks, releases and commits are happening, but it works just the same as for plain L: If the L-block around L fails, a rollback is issued. If the L succeeds, the transaction is committed (or the savepoint released). While you can get more fine-grained control using C, C and C, it is strongly recommended to use C with coderefs. =head2 Simple Transactions with DBIx::Class::Storage::TxnScopeGuard An easy way to use transactions is with L. See L for an example. Note that unlike txn_do, TxnScopeGuard will only make sure the connection is alive when issuing the C statement. It will not (and really can not) retry if the server goes away mid-operations, unlike C. =head1 SQL =head2 Creating Schemas From An Existing Database L will connect to a database and create a L and associated sources by examining the database. The recommend way of achieving this is to use the L utility or the L helper, as described in L. Alternatively, use the L method: perl -MDBIx::Class::Schema::Loader=make_schema_at,dump_to_dir:./lib \ -e 'make_schema_at("My::Schema", \ { db_schema => 'myschema', components => ["InflateColumn::DateTime"] }, \ [ "dbi:Pg:dbname=foo", "username", "password" ])' This will create a tree of files rooted at C<./lib/My/Schema/> containing source definitions for all the tables found in the C schema in the C database. =head2 Creating DDL SQL The following functionality requires you to have L (also known as "SQL Fairy") installed. To create a set of database-specific .sql files for the above schema: my $schema = My::Schema->connect($dsn); $schema->create_ddl_dir(['MySQL', 'SQLite', 'PostgreSQL'], '0.1', './dbscriptdir/' ); By default this will create schema files in the current directory, for MySQL, SQLite and PostgreSQL, using the $VERSION from your Schema.pm. To create a new database using the schema: my $schema = My::Schema->connect($dsn); $schema->deploy({ add_drop_table => 1}); To import created .sql files using the mysql client: mysql -h "host" -D "database" -u "user" -p < My_Schema_1.0_MySQL.sql To create C conversion scripts to update a database to a newer version of your schema at a later point, first set a new C<$VERSION> in your Schema file, then: my $schema = My::Schema->connect($dsn); $schema->create_ddl_dir(['MySQL', 'SQLite', 'PostgreSQL'], '0.2', '/dbscriptdir/', '0.1' ); This will produce new database-specific .sql files for the new version of the schema, plus scripts to convert from version 0.1 to 0.2. This requires that the files for 0.1 as created above are available in the given directory to diff against. =head2 Select from dual Dummy tables are needed by some databases to allow calling functions or expressions that aren't based on table content, for examples of how this applies to various database types, see: L. Note: If you're using Oracles dual table don't B do anything other than a select, if you CRUD on your dual table you *will* break your database. Make a table class as you would for any other table package MyAppDB::Dual; use strict; use warnings; use base 'DBIx::Class::Core'; __PACKAGE__->table("Dual"); __PACKAGE__->add_columns( "dummy", { data_type => "VARCHAR2", is_nullable => 0, size => 1 }, ); Once you've loaded your table class select from it using C conditions to illustrate the different syntax you could use for doing stuff like C # get a sequence value select => [ 'A_SEQ.nextval' ], # get create table sql select => [ { 'dbms_metadata.get_ddl' => [ "'TABLE'", "'ARTIST'" ]} ], # get a random num between 0 and 100 select => [ { "trunc" => [ { "dbms_random.value" => [0,100] } ]} ], # what year is it? select => [ { 'extract' => [ \'year from sysdate' ] } ], # do some math select => [ {'round' => [{'cos' => [ \'180 * 3.14159265359/180' ]}]}], # which day of the week were you born on? select => [{'to_char' => [{'to_date' => [ "'25-DEC-1980'", "'dd-mon-yyyy'" ]}, "'day'"]}], # select 16 rows from dual select => [ "'hello'" ], as => [ 'world' ], group_by => [ 'cube( 1, 2, 3, 4 )' ], =head2 Adding Indexes And Functions To Your SQL Often you will want indexes on columns on your table to speed up searching. To do this, create a method called C in the relevant source class (refer to the advanced L if you wish to share a hook between multiple sources): package My::Schema::Result::Artist; __PACKAGE__->table('artist'); __PACKAGE__->add_columns(id => { ... }, name => { ... }) sub sqlt_deploy_hook { my ($self, $sqlt_table) = @_; $sqlt_table->add_index(name => 'idx_name', fields => ['name']); } 1; Sometimes you might want to change the index depending on the type of the database for which SQL is being generated: my ($db_type = $sqlt_table->schema->translator->producer_type) =~ s/^SQL::Translator::Producer:://; You can also add hooks to the schema level to stop certain tables being created: package My::Schema; ... sub sqlt_deploy_hook { my ($self, $sqlt_schema) = @_; $sqlt_schema->drop_table('table_name'); } You could also add views, procedures or triggers to the output using L, L or L. =head2 Schema versioning The following example shows simplistically how you might use DBIx::Class to deploy versioned schemas to your customers. The basic process is as follows: =over 4 =item 1. Create a DBIx::Class schema =item 2. Save the schema =item 3. Deploy to customers =item 4. Modify schema to change functionality =item 5. Deploy update to customers =back B This can either be done manually, or generated from an existing database as described under L B Call L as above under L. B There are several ways you could deploy your schema. These are probably beyond the scope of this recipe, but might include: =over 4 =item 1. Require customer to apply manually using their RDBMS. =item 2. Package along with your app, making database dump/schema update/tests all part of your install. =back B As your application evolves, it may be necessary to modify your schema to change functionality. Once the changes are made to your schema in DBIx::Class, export the modified schema and the conversion scripts as in L. B Add the L schema component to your Schema class. This will add a new table to your database called C which will keep track of which version is installed and warn if the user tries to run a newer schema version than the database thinks it has. Alternatively, you can send the conversion SQL scripts to your customers as above. =head2 Setting quoting for the generated SQL If the database contains column names with spaces and/or reserved words, they need to be quoted in the SQL queries. This is done using: $schema->storage->sql_maker->quote_char([ qw/[ ]/] ); $schema->storage->sql_maker->name_sep('.'); The first sets the quote characters. Either a pair of matching brackets, or a C<"> or C<'>: $schema->storage->sql_maker->quote_char('"'); Check the documentation of your database for the correct quote characters to use. C needs to be set to allow the SQL generator to put the quotes the correct place, and defaults to C<.> if not supplied. In most cases you should set these as part of the arguments passed to L: my $schema = My::Schema->connect( 'dbi:mysql:my_db', 'db_user', 'db_password', { quote_char => '"', name_sep => '.' } ) In some cases, quoting will be required for all users of a schema. To enforce this, you can also overload the C method for your schema class: sub connection { my $self = shift; my $rv = $self->next::method( @_ ); $rv->storage->sql_maker->quote_char([ qw/[ ]/ ]); $rv->storage->sql_maker->name_sep('.'); return $rv; } =head2 Working with PostgreSQL array types You can also assign values to PostgreSQL array columns by passing array references in the C<\%columns> (C<\%vals>) hashref of the L and L family of methods: $resultset->create({ numbers => [1, 2, 3] }); $result->update( { numbers => [1, 2, 3] }, { day => '2008-11-24' } ); In conditions (e.g. C<\%cond> in the L family of methods) you cannot directly use array references (since this is interpreted as a list of values to be Ced), but you can use the following syntax to force passing them as bind values: $resultset->search( { numbers => { -value => [1, 2, 3] } } ); =head2 Formatting DateTime objects in queries To ensure C conditions containing L arguments are properly formatted to be understood by your RDBMS, you must use the L formatter returned by L to format any L objects you pass to L conditions. Any L object attached to your L provides a correct L formatter, so all you have to do is: my $dtf = $schema->storage->datetime_parser; my $rs = $schema->resultset('users')->search( { signup_date => { -between => [ $dtf->format_datetime($dt_start), $dtf->format_datetime($dt_end), ], } }, ); Without doing this the query will contain the simple stringification of the C object, which almost never matches the RDBMS expectations. This kludge is necessary only for conditions passed to L and L, whereas L and L (but not L) are L-aware and will do the right thing when supplied an inflated L object. =head2 Using Unicode When using unicode character data there are two alternatives - either your database supports unicode characters (including setting the utf8 flag on the returned string), or you need to encode/decode data appropriately each time a string field is inserted into or retrieved from the database. It is better to avoid encoding/decoding data and to use your database's own unicode capabilities if at all possible. The L component handles storing selected unicode columns in a database that does not directly support unicode. If used with a database that does correctly handle unicode then strange and unexpected data corrupt B occur. The Catalyst Wiki Unicode page at L has additional information on the use of Unicode with Catalyst and DBIx::Class. The following databases do correctly handle unicode data:- =head3 MySQL MySQL supports unicode, and will correctly flag utf8 data from the database if the C is set in the connect options. my $schema = My::Schema->connection('dbi:mysql:dbname=test', $user, $pass, { mysql_enable_utf8 => 1} ); When set, a data retrieved from a textual column type (char, varchar, etc) will have the UTF-8 flag turned on if necessary. This enables character semantics on that string. You will also need to ensure that your database / table / column is configured to use UTF8. See Chapter 10 of the mysql manual for details. See L for further details. =head3 Oracle Information about Oracle support for unicode can be found in L. =head3 PostgreSQL PostgreSQL supports unicode if the character set is correctly set at database creation time. Additionally the C should be set to ensure unicode data is correctly marked. my $schema = My::Schema->connection('dbi:Pg:dbname=test', $user, $pass, { pg_enable_utf8 => 1} ); Further information can be found in L. =head3 SQLite SQLite version 3 and above natively use unicode internally. To correctly mark unicode strings taken from the database, the C flag should be set at connect time (in versions of L prior to 1.27 this attribute was named C). my $schema = My::Schema->connection('dbi:SQLite:/tmp/test.db', '', '', { sqlite_unicode => 1} ); =head1 BOOTSTRAPPING/MIGRATING =head2 Easy migration from class-based to schema-based setup You want to start using the schema-based approach to L (see L), but have an established class-based setup with lots of existing classes that you don't want to move by hand. Try this nifty script instead: use MyDB; use SQL::Translator; my $schema = MyDB->schema_instance; my $translator = SQL::Translator->new( debug => $debug || 0, trace => $trace || 0, no_comments => $no_comments || 0, show_warnings => $show_warnings || 0, add_drop_table => $add_drop_table || 0, validate => $validate || 0, parser_args => { 'DBIx::Schema' => $schema, }, producer_args => { 'prefix' => 'My::Schema', }, ); $translator->parser('SQL::Translator::Parser::DBIx::Class'); $translator->producer('SQL::Translator::Producer::DBIx::Class::File'); my $output = $translator->translate(@args) or die "Error: " . $translator->error; print $output; You could use L to search for all subclasses in the MyDB::* namespace, which is currently left as an exercise for the reader. =head1 OVERLOADING METHODS L uses the L package, which provides for redispatch of method calls, useful for things like default values and triggers. You have to use calls to C to overload methods. More information on using L with L can be found in L. =head2 Setting default values for a row It's as simple as overriding the C method. Note the use of C. sub new { my ( $class, $attrs ) = @_; $attrs->{foo} = 'bar' unless defined $attrs->{foo}; my $new = $class->next::method($attrs); return $new; } For more information about C, look in the L documentation. See also L for more ways to write your own base classes to do this. People looking for ways to do "triggers" with DBIx::Class are probably just looking for this. =head2 Changing one field whenever another changes For example, say that you have three columns, C, C, and C. You would like to make changes to C and have C be automagically set to the value of C squared. You can accomplish this by wrapping the C accessor with the C method modifier, available through either L, L or L modules): around number => sub { my ($orig, $self) = (shift, shift); if (@_) { my $value = $_[0]; $self->squared( $value * $value ); } $self->$orig(@_); }; Note that the hard work is done by the call to C<< $self->$orig >>, which redispatches your call to store_column in the superclass(es). Generally, if this is a calculation your database can easily do, try and avoid storing the calculated value, it is safer to calculate when needed, than rely on the data being in sync. =head2 Automatically creating related objects You might have a class C which has many Cs. Further, you want to create a C object every time you insert an C object. You can accomplish this by overriding C on your objects: sub insert { my ( $self, @args ) = @_; $self->next::method(@args); $self->create_related ('cds', \%initial_cd_data ); return $self; } If you want to wrap the two inserts in a transaction (for consistency, an excellent idea), you can use the awesome L: sub insert { my ( $self, @args ) = @_; my $guard = $self->result_source->schema->txn_scope_guard; $self->next::method(@args); $self->create_related ('cds', \%initial_cd_data ); $guard->commit; return $self } =head2 Wrapping/overloading a column accessor B Say you have a table "Camera" and want to associate a description with each camera. For most cameras, you'll be able to generate the description from the other columns. However, in a few special cases you may want to associate a custom description with a camera. B In your database schema, define a description field in the "Camera" table that can contain text and null values. In DBIC, we'll overload the column accessor to provide a sane default if no custom description is defined. The accessor will either return or generate the description, depending on whether the field is null or not. First, in your "Camera" schema class, define the description field as follows: __PACKAGE__->add_columns(description => { accessor => '_description' }); Next, we'll define the accessor-wrapper subroutine: sub description { my $self = shift; # If there is an update to the column, we'll let the original accessor # deal with it. return $self->_description(@_) if @_; # Fetch the column value. my $description = $self->_description; # If there's something in the description field, then just return that. return $description if defined $description && length $descripton; # Otherwise, generate a description. return $self->generate_description; } =head1 DEBUGGING AND PROFILING =head2 DBIx::Class objects with Data::Dumper L can be a very useful tool for debugging, but sometimes it can be hard to find the pertinent data in all the data it can generate. Specifically, if one naively tries to use it like so, use Data::Dumper; my $cd = $schema->resultset('CD')->find(1); print Dumper($cd); several pages worth of data from the CD object's schema and result source will be dumped to the screen. Since usually one is only interested in a few column values of the object, this is not very helpful. Luckily, it is possible to modify the data before L outputs it. Simply define a hook that L will call on the object before dumping it. For example, package My::DB::CD; sub _dumper_hook { $_[0] = bless { %{ $_[0] }, result_source => undef, }, ref($_[0]); } [...] use Data::Dumper; local $Data::Dumper::Freezer = '_dumper_hook'; my $cd = $schema->resultset('CD')->find(1); print Dumper($cd); # dumps $cd without its ResultSource If the structure of your schema is such that there is a common base class for all your table classes, simply put a method similar to C<_dumper_hook> in the base class and set C<$Data::Dumper::Freezer> to its name and L will automagically clean up your data before printing it. See L for more information. =head2 Profiling When you enable L's debugging it prints the SQL executed as well as notifications of query completion and transaction begin/commit. If you'd like to profile the SQL you can subclass the L class and write your own profiling mechanism: package My::Profiler; use strict; use base 'DBIx::Class::Storage::Statistics'; use Time::HiRes qw(time); my $start; sub query_start { my $self = shift(); my $sql = shift(); my @params = @_; $self->print("Executing $sql: ".join(', ', @params)."\n"); $start = time(); } sub query_end { my $self = shift(); my $sql = shift(); my @params = @_; my $elapsed = sprintf("%0.4f", time() - $start); $self->print("Execution took $elapsed seconds.\n"); $start = undef; } 1; You can then install that class as the debugging object: __PACKAGE__->storage->debugobj(new My::Profiler()); __PACKAGE__->storage->debug(1); A more complicated example might involve storing each execution of SQL in an array: sub query_end { my $self = shift(); my $sql = shift(); my @params = @_; my $elapsed = time() - $start; push(@{ $calls{$sql} }, { params => \@params, elapsed => $elapsed }); } You could then create average, high and low execution times for an SQL statement and dig down to see if certain parameters cause aberrant behavior. You might want to check out L as well. =head1 IMPROVING PERFORMANCE =over =item * Install L to speed up L. =item * On Perl 5.8 install L. =item * L relationships, where possible. See L. =item * Use L in void context to insert data when you don't need the resulting L objects, if possible, but see the caveats. When inserting many rows, for best results, populate a large number of rows at a time, but not so large that the table is locked for an unacceptably long time. If using L instead, use a transaction and commit every C rows; where C gives you the best performance without locking the table for too long. =item * When selecting many rows, if you don't need full-blown L objects, consider using L. =item * See also L and L in this document. =back =head1 STARTUP SPEED L programs can have a significant startup delay as the ORM loads all the relevant classes. This section examines techniques for reducing the startup delay. These tips are listed in order of decreasing effectiveness - so the first tip, if applicable, should have the greatest effect on your application. =head2 Statically Define Your Schema If you are using L to build the classes dynamically based on the database schema then there will be a significant startup delay. For production use a statically defined schema (which can be generated using L to dump the database schema once - see L and L for more details on creating static schemas from a database). =head2 Move Common Startup into a Base Class Typically L result classes start off with use base qw/DBIx::Class::Core/; __PACKAGE__->load_components(qw/InflateColumn::DateTime/); If this preamble is moved into a common base class:- package MyDBICbase; use base qw/DBIx::Class::Core/; __PACKAGE__->load_components(qw/InflateColumn::DateTime/); 1; and each result class then uses this as a base:- use base qw/MyDBICbase/; then the load_components is only performed once, which can result in a considerable startup speedup for schemas with many classes. =head2 Explicitly List Schema Result Classes The schema class will normally contain __PACKAGE__->load_classes(); to load the result classes. This will use L to find and load the appropriate modules. Explicitly defining the classes you wish to load will remove the overhead of L and the related directory operations: __PACKAGE__->load_classes(qw/ CD Artist Track /); If you are instead using the L syntax to load the appropriate classes there is not a direct alternative avoiding L. =head1 MEMORY USAGE =head2 Cached statements L normally caches all statements with L. This is normally a good idea, but if too many statements are cached, the database may use too much memory and may eventually run out and fail entirely. If you suspect this may be the case, you may want to examine DBI's L hash: # print all currently cached prepared statements print for keys %{$schema->storage->dbh->{CachedKids}}; # get a count of currently cached prepared statements my $count = scalar keys %{$schema->storage->dbh->{CachedKids}}; If it's appropriate, you can simply clear these statements, automatically deallocating them in the database: my $kids = $schema->storage->dbh->{CachedKids}; delete @{$kids}{keys %$kids} if scalar keys %$kids > 100; But what you probably want is to expire unused statements and not those that are used frequently. You can accomplish this with L or L: use Tie::Cache; use DB::Main; my $schema = DB::Main->connect($dbi_dsn, $user, $pass, { on_connect_do => sub { tie %{shift->_dbh->{CachedKids}}, 'Tie::Cache', 100 }, }); =cut =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. DBIx-Class-0.082843/lib/DBIx/Class/Manual/Joining.pod0000644000175000017500000002411013271562530021024 0ustar rabbitrabbit=head1 NAME DBIx::Class::Manual::Joining - Manual on joining tables with DBIx::Class =head1 DESCRIPTION This document should help you to use L if you are trying to convert your normal SQL queries into DBIx::Class based queries, if you use joins extensively (and also probably if you don't). =head1 WHAT ARE JOINS If you ended up here and you don't actually know what joins are yet, then you should likely try the L instead. Skip this part if you know what joins are.. But I'll explain anyway. Assuming you have created your database in a more or less sensible way, you will end up with several tables that contain C information. For example, you may have a table containing information about Cs, containing the CD title and its year of publication, and another table containing all the Cs for the CDs, one track per row. When you wish to extract information about a particular CD and all its tracks, You can either fetch the CD row, then make another query to fetch the tracks, or you can use a join. Compare: SELECT ID, Title, Year FROM CD WHERE Title = 'Funky CD'; # .. Extract the ID, which is 10 SELECT Name, Artist FROM Tracks WHERE CDID = 10; SELECT cd.ID, cd.Title, cd.Year, tracks.Name, tracks.Artist FROM CD JOIN Tracks ON CD.ID = tracks.CDID WHERE cd.Title = 'Funky CD'; So, joins are a way of extending simple select statements to include fields from other, related, tables. There are various types of joins, depending on which combination of the data you wish to retrieve, see MySQL's doc on JOINs: L. =head1 DEFINING JOINS AND RELATIONSHIPS In L each relationship between two tables needs to first be defined in the L for the table. If the relationship needs to be accessed in both directions (i.e. Fetch all tracks of a CD, and fetch the CD data for a Track), then it needs to be defined for both tables. For the CDs/Tracks example, that means writing, in C: MySchema::CD->has_many('tracks', 'MySchema::Tracks'); And in C: MySchema::Tracks->belongs_to('cd', 'MySchema::CD', 'CDID'); There are several other types of relationships, they are more comprehensively described in L. =head1 USING JOINS Once you have defined all your relationships, using them in actual joins is fairly simple. The type of relationship that you chose e.g. C, already indicates what sort of join will be performed. C produces a C for example, which will fetch all the rows on the left side, whether there are matching rows on the right (table being joined to), or not. You can force other types of joins in your relationship, see the L docs. When performing either a L or a L operation, you can specify which C to also refine your results based on, using the L attribute, like this: $schema->resultset('CD')->search( { 'Title' => 'Funky CD', 'tracks.Name' => { like => 'T%' } }, { join => 'tracks', order_by => ['tracks.id'], } ); If you don't recognise most of this syntax, you should probably go read L and L, but here's a quick break down: The first argument to search is a hashref of the WHERE attributes, in this case a restriction on the Title column in the CD table, and a restriction on the name of the track in the Tracks table, but ONLY for tracks actually related to the chosen CD(s). The second argument is a hashref of attributes to the search, the results will be returned sorted by the C of the related tracks. The special 'join' attribute specifies which C to include in the query. The distinction between C and C is important here, only the C names are valid. This slightly nonsense example will produce SQL similar to: SELECT cd.ID, cd.Title, cd.Year FROM CD cd JOIN Tracks tracks ON cd.ID = tracks.CDID WHERE cd.Title = 'Funky CD' AND tracks.Name LIKE 'T%' ORDER BY 'tracks.id'; =head1 FETCHING RELATED DATA Another common use for joining to related tables, is to fetch the data from both tables in one query, preventing extra round-trips to the database. See the example above in L. Three techniques are described here. Of the three, only the C technique will deal sanely with fetching related objects over a C relation. The others work fine for 1 to 1 type relationships. =head2 Whole related objects To fetch entire related objects, e.g. CDs and all Track data, use the 'prefetch' attribute: $schema->resultset('CD')->search( { 'Title' => 'Funky CD', }, { prefetch => 'tracks', order_by => ['tracks.id'], } ); This will produce SQL similar to the following: SELECT cd.ID, cd.Title, cd.Year, tracks.id, tracks.Name, tracks.Artist FROM CD JOIN Tracks ON CD.ID = tracks.CDID WHERE cd.Title = 'Funky CD' ORDER BY 'tracks.id'; The syntax of 'prefetch' is the same as 'join' and implies the joining, so there is no need to use both together. =head2 Subset of related fields To fetch a subset or the related fields, the '+select' and '+as' attributes can be used. For example, if the CD data is required and just the track name from the Tracks table: $schema->resultset('CD')->search( { 'Title' => 'Funky CD', }, { join => 'tracks', '+select' => ['tracks.Name'], '+as' => ['track_name'], order_by => ['tracks.id'], } ); Which will produce the query: SELECT cd.ID, cd.Title, cd.Year, tracks.Name FROM CD JOIN Tracks ON CD.ID = tracks.CDID WHERE cd.Title = 'Funky CD' ORDER BY 'tracks.id'; Note that the '+as' does not produce an SQL 'AS' keyword in the output, see the L for an explanation. This type of column restriction has a downside, the returned $result object will have no 'track_name' accessor: while(my $result = $search_rs->next) { print $result->track_name; ## ERROR } Instead C must be used: while(my $result = $search_rs->next) { print $result->get_column('track_name'); ## WORKS } =head2 Incomplete related objects In rare circumstances, you may also wish to fetch related data as incomplete objects. The usual reason to do is when the related table has a very large field you don't need for the current data output. This is better solved by storing that field in a separate table which you only join to when needed. To fetch an incomplete related object, supply the dotted notation to the '+as' attribute: $schema->resultset('CD')->search( { 'Title' => 'Funky CD', }, { join => 'tracks', '+select' => ['tracks.Name'], '+as' => ['tracks.Name'], order_by => ['tracks.id'], } ); Which will produce same query as above; SELECT cd.ID, cd.Title, cd.Year, tracks.Name FROM CD JOIN Tracks ON CD.ID = tracks.CDID WHERE cd.Title = 'Funky CD' ORDER BY 'tracks.id'; Now you can access the result using the relationship accessor: while(my $result = $search_rs->next) { print $result->tracks->name; ## WORKS } However, this will produce broken objects. If the tracks id column is not fetched, the object will not be usable for any operation other than reading its data. Use the L method as much as possible to avoid confusion in your code later. Broken means: Update will not work. Fetching other related objects will not work. Deleting the object will not work. =head1 COMPLEX JOINS AND STUFF =head2 Across multiple relations For simplicity in the example above, the C was shown as a simple text field in the C table, in reality, you'll want to have the artists in their own table as well, thus to fetch the complete set of data we'll need to join to the Artist table too. In C: MySchema::Tracks->belongs_to('artist', 'MySchema::Artist', 'ArtistID'); The search: $schema->resultset('CD')->search( { 'Title' => 'Funky CD' }, { join => { 'tracks' => 'artist' }, } ); Which is: SELECT me.ID, me.Title, me.Year FROM CD me JOIN Tracks tracks ON CD.ID = tracks.CDID JOIN Artists artist ON tracks.ArtistID = artist.ID WHERE me.Title = 'Funky CD'; To perform joins using relations of the tables you are joining to, use a hashref to indicate the join depth. This can theoretically go as deep as you like (warning: contrived examples!): join => { room => { table => 'leg' } } To join two relations at the same level, use an arrayref instead: join => { room => [ 'chair', 'table' ] } Or combine the two: join => { room => [ 'chair', { table => 'leg' } ] } =head2 Table aliases As an aside to all the discussion on joins, note that L uses the C as table aliases. This is important when you need to add grouping or ordering to your queries: $schema->resultset('CD')->search( { 'Title' => 'Funky CD' }, { join => { 'tracks' => 'artist' }, order_by => [ 'tracks.Name', 'artist.Artist' ], } ); SELECT me.ID, me.Title, me.Year FROM CD me JOIN Tracks tracks ON CD.ID = tracks.CDID JOIN Artists artist ON tracks.ArtistID = artist.ID WHERE me.Title = 'Funky CD' ORDER BY tracks.Name, artist.Artist; This is essential if any of your tables have columns with the same names. Note that the table of the resultsource the search was performed on, is always aliased to C. =head2 Joining to the same table twice There is no magic to this, just do it. The table aliases will automatically be numbered: join => [ 'room', 'room' ] The aliases are: C and C. =cut =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. DBIx-Class-0.082843/lib/DBIx/Class/Manual/Example.pod0000644000175000017500000000706113271562530021030 0ustar rabbitrabbit=head1 NAME DBIx::Class::Manual::Example - Simple CD database example =head1 DESCRIPTION This tutorial will guide you through the process of setting up and testing a very basic CD database using SQLite, with DBIx::Class::Schema as the database frontend. The database structure is based on the following rules: An artist can have many cds, and each cd belongs to just one artist. A cd can have many tracks, and each track belongs to just one cd. The database is implemented with the following: table 'artist' with columns: artistid, name table 'cd' with columns: cdid, artistid, title, year table 'track' with columns: trackid, cdid, title Each of the table's first columns is the primary key; any subsequent keys are foreign keys. =head2 Installation You'll need to install DBIx::Class via CPAN, and you'll also need to install sqlite3 (not sqlite) if it's not already intalled. =head3 The database/tables/data Your distribution already comes with a pre-filled SQLite database F. You can see it by e.g. cpanm --look DBIx::Class If for some reason the file is unreadable on your system, you can recreate it as follows: cp -a /examples/Schema dbicapp cd dbicapp rm db/example.db sqlite3 db/example.db < db/example.sql perl insertdb.pl =head3 Testing the database Enter the example Schema directory cd /examples/Schema Run the script testdb.pl, which will test that the database has successfully been filled. When this script is run, it should output the following: get_tracks_by_cd(Bad): Leave Me Alone Smooth Criminal Dirty Diana get_tracks_by_artist(Michael Jackson): Billie Jean (from the CD 'Thriller') Beat It (from the CD 'Thriller') Leave Me Alone (from the CD 'Bad') Smooth Criminal (from the CD 'Bad') Dirty Diana (from the CD 'Bad') get_cd_by_track(Stan): The Marshall Mathers LP has the track 'Stan'. get_cds_by_artist(Michael Jackson): Thriller Bad get_artist_by_track(Dirty Diana): Michael Jackson recorded the track 'Dirty Diana'. get_artist_by_cd(The Marshall Mathers LP): Eminem recorded the CD 'The Marshall Mathers LP'. =head3 Discussion about the results The data model defined in this example has an artist with multiple CDs, and a CD with multiple tracks; thus, it's simple to traverse from a track back to a CD, and from there back to an artist. This is demonstrated in the get_tracks_by_artist routine, where we easily walk from the individual track back to the title of the CD that the track came from ($track->cd->title). Note also that in the get_tracks_by_cd and get_tracks_by_artist routines, the result set is called multiple times with the 'next' iterator. In contrast, get_cd_by_track uses the 'first' result set method, since only one CD is expected to have a specific track. This example uses L to load in the appropriate L classes from the C namespace, and any required L classes from the C namespace (although we did not add, nor needed any such classes in this example). =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. =cut DBIx-Class-0.082843/lib/DBIx/Class/Manual/Component.pod0000644000175000017500000001127613271562530021402 0ustar rabbitrabbit =head1 NAME DBIx::Class::Manual::Component - Developing DBIx::Class Components =head1 WHAT IS A COMPONENT A component is a module that can be added in to your DBIx::Class classes to provide extra functionality. A good example is the PK::Auto component which automatically retrieves primary keys that the database itself creates, after the insert has happened. =head1 USING Components are loaded using the load_components() method within your DBIx::Class classes. package My::Thing; use base qw( DBIx::Class::Core ); __PACKAGE__->load_components(qw/InflateColumn::DateTime TimeStamp/); Generally you do not want to specify the full package name of a component, instead take off the DBIx::Class:: part of it and just include the rest. If you do want to load a component outside of the normal namespace you can do so by prepending the component name with a +. __PACKAGE__->load_components(qw/ +My::Component /); Once a component is loaded all of its methods, or otherwise, that it provides will be available in your class. The order in which is you load the components may be very important, depending on the component. If you are not sure, then read the docs for the components you are using and see if they mention anything about the order in which you should load them. =head1 CREATING COMPONENTS Making your own component is very easy. package DBIx::Class::MyComp; use base qw(DBIx::Class); # Create methods, accessors, load other components, etc. 1; When a component is loaded it is included in the calling class' inheritance chain using L. As well as providing custom utility methods, a component may also override methods provided by other core components, like L and others. For example, you could override the insert and delete methods. sub insert { my $self = shift; # Do stuff with $self, like set default values. return $self->next::method( @_ ); } sub delete { my $self = shift; # Do stuff with $self. return $self->next::method( @_ ); } Now, the order that a component is loaded is very important. Components that are loaded first are the first ones in the inheritance stack. So, if you override insert() but the DBIx::Class::Row component is loaded first then your insert() will never be called, since the DBIx::Class::Row insert() will be called first. If you are unsure as to why a given method is not being called try printing out the current linearized MRO. print join ', ' => mro::get_linear_isa('YourClass::Name'); =head1 EXISTING COMPONENTS =head2 Extra These components provide extra functionality beyond basic functionality that you can't live without. L - Class::DBI Compatibility layer. L - Build forms with multiple interconnected objects. L - Like FromForm but with DBIx::Class and HTML::Widget. L - Modify the position of objects in an ordered list. L - Retrieve automatically created primary keys upon insert. L - Display the amount of time it takes to run queries. L - Declare virtual columns that return random strings. L - Implicit UUID columns. L - CRUD methods. =head2 Experimental These components are under development, their interfaces may change, they may not work, etc. So, use them if you want, but be warned. L - Validate all data before submitting to your database. =head2 Core These are the components that all, or nearly all, people will use without even knowing it. These components provide most of DBIx::Class' functionality. L - Loads various components that "most people" would want. L - Lets you build groups of accessors. L - Non-recommended classdata schema component. L - Automatically create objects from column data. L - This class contains methods for handling primary keys and methods depending on them. L - Inter-table relationships. L - Provides a classdata table object and method proxies. L - Basic row methods. =head1 SEE ALSO L =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. DBIx-Class-0.082843/lib/DBIx/Class/Manual/DocMap.pod0000644000175000017500000000507014240132261020565 0ustar rabbitrabbit=head1 NAME DBIx::Class::Manual::DocMap - What documentation do we have? =head1 Manuals =over 4 =item L - User's Manual overview. =item L - Up and running with DBIC in 10 minutes. =item L - More detailed introduction to setting up and using DBIx::Class. =item L - How to use DBIx::Class if you know SQL (external, available on CPAN) =item L - Joining tables with DBIx::Class. =item L - A boatload of DBIx::Class features with links to respective documentation. =item L - What do all those terms mean? =item L - Various short recipes on how to do things. =item L - Frequently Asked Questions, gathered from IRC and the mailing list. =item L - What to do if things go wrong (diagnostics of known error messages). =back =head1 Some essential reference documentation The first two list items are the most important. =over 4 =item L - Selecting and manipulating sets. The DSL (mini-language) for query composition is only partially explained there, see L for the complete details. =item L::Result::C<$resultclass>|DBIx::Class::Manual::ResultClass> - Classes representing a single result (row) from a DB query. Such classes normally subclass L, the methods inherited from L and L are used most often. =item L - Perform operations on a single column of a ResultSet. =item L - Source/Table definition functions. =item L - Overall sources, and connection container. =item L - Simple relationship declarations. =item L - Relationship declaration details. =item L - Making objects out of your column values. =back =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. DBIx-Class-0.082843/lib/DBIx/Class/Manual/Features.pod0000644000175000017500000003255014240132261021203 0ustar rabbitrabbit=head1 NAME DBIx::Class::Manual::Features - A boatload of DBIx::Class features with links to respective documentation =head1 META =head2 Large Community There are L listed in F. That ranges from documentation help, to test help, to added features, to entire database support. =head2 Active Community Currently (June 9, 2010) 6 active branches (committed to in the last two weeks) in git. Last release (0.08122) had 14 new features, and 16 bug fixes. Of course that L.) =head2 Responsive Community =over 1 =item I needed MSSQL order-by support; the community helped me add support =item generally very welcoming of people willing to help =back =head1 General ORM These are things that are in most other ORMs, but are still reasons to use DBIC over raw SQL. =head2 Cross DB The vast majority of code should run on all databases without needing tweaking =head2 Basic CRUD =over 1 =item C - Create =item R - Retrieve =item U - Update =item D - Delete =back =head2 SQL: Create my $sth = $dbh->prepare(' INSERT INTO books (title, author_id) values (?,?) '); $sth->execute( 'A book title', $author_id ); =head2 DBIC: Create my $book = $book_rs->create({ title => 'A book title', author_id => $author_id, }); See L =over 1 =item No need to pair placeholders and values =item Automatically gets autoincremented id for you =item Transparently uses INSERT ... RETURNING for databases that support it =back =head2 SQL: Read my $sth = $dbh->prepare(' SELECT title, authors.name as author_name FROM books, authors WHERE books.author = authors.id '); while ( my $book = $sth->fetchrow_hashref ) { say "Author of $book->{title} is $book->{author_name}"; } =head2 DBIC: Read my $book = $book_rs->find($book_id); or my $book = $book_rs->search({ title => 'A book title' }, { rows => 1 })->next; or my @books = $book_rs->search({ author => $author_id })->all; or while( my $book = $books_rs->next ) { printf "Author of %s is %s\n", $book->title, $book->author->name; } See L, L, L, and L B =head2 SQL: Update my $update = $dbh->prepare(' UPDATE books SET title = ? WHERE id = ? '); $update->execute( 'New title', $book_id ); =head2 DBIC: Update $book->update({ title => 'New title' }); See L Will not update unless value changes =head2 SQL: Delete my $delete = $dbh->prepare('DELETE FROM books WHERE id = ?'); $delete->execute($book_id); =head2 DBIC: Delete $book->delete See L =head2 SQL: Search my $sth = $dbh->prepare(' SELECT title, authors.name as author_name FROM books WHERE books.name LIKE "%monte cristo%" AND books.topic = "jailbreak" '); =head2 DBIC: Search my $book = $book_rs->search({ 'me.name' => { -like => '%monte cristo%' }, 'me.topic' => 'jailbreak', })->next; =over 1 =item See L, L, and L =item (kinda) introspectible =item Prettier than SQL =back =head2 OO Overridability =over 1 =item Override new if you want to do validation =item Override delete if you want to disable deletion =item and on and on =back =head2 Convenience Methods =over 1 =item L =item L =back =head2 Non-column methods Need a method to get a user's gravatar URL? Add a C method to the Result class =head2 RELATIONSHIPS =over 1 =item L =item L =item L =item L =item L =item SET AND FORGET =back =head1 DBIx::Class Specific Features These things may be in other ORM's, but they are very specific, so doubtful =head2 ->deploy Create a database from your DBIx::Class schema. my $schema = Frew::Schema->connect( $dsn, $user, $pass ); $schema->deploy See L. See also: L =head2 Schema::Loader Create a DBIx::Class schema from your database. package Frew::Schema; use strict; use warnings; use base 'DBIx::Class::Schema::Loader'; __PACKAGE__->loader_options({ naming => 'v7', debug => $ENV{DBIC_TRACE}, }); 1; # elsewhere... my $schema = Frew::Schema->connect( $dsn, $user, $pass ); See L and L. =head2 Populate Made for inserting lots of rows very quickly into database $schema->populate([ Users => [qw( username password )], [qw( frew >=4char$ )], [qw( ... )], [qw( ... )], ); See L I use populate L to export our whole (200M~) db to SQLite =head2 Multicreate Create an object and its related objects all at once $schema->resultset('Author')->create({ name => 'Stephen King', books => [{ title => 'The Dark Tower' }], address => { street => '123 Turtle Back Lane', state => { abbreviation => 'ME' }, city => { name => 'Lowell' }, }, }); See L =over 1 =item books is a has_many =item address is a belongs_to which in turn belongs to state and city each =item for this to work right state and city must mark abbreviation and name as unique =back =head2 Extensible DBIx::Class helped pioneer fast MI in Perl 5 with Class::C3, so it is made to allow extensions to nearly every part of it. =head2 Extensibility example: DBIx::Class::Helpers =over 1 =item L =item L =item L =item L =item L =item L =item L =item L =item L =back =head2 Extensibility example: DBIx::Class::TimeStamp =over 1 =item See L =item Cross DB =item set_on_create =item set_on_update =back =head2 Extensibility example: Kioku =over 1 =item See L =item Kioku is the new hotness =item Mix RDBMS with Object DB =back =head2 Result vs ResultSet =over 1 =item Result == Row =item ResultSet == Query Plan =over 1 =item Internal Join Optimizer for all DB's (!!!) =back =item (less important but...) =item ResultSource == Queryable collection of rows (Table, View, etc) =item Storage == Database =item Schema == associates a set of ResultSources with a Storage =back =head2 ResultSet methods package MyApp::Schema::ResultSet::Book; use strict; use warnings; use base 'DBIx::Class::ResultSet'; sub good { my $self = shift; $self->search({ $self->current_source_alias . '.rating' => { '>=' => 4 } }) }; sub cheap { my $self = shift; $self->search({ $self->current_source_alias . '.price' => { '<=' => 5} }) }; # ... 1; See L =over 1 =item All searches should be ResultSet methods =item Name has obvious meaning =item L helps things to work no matter what =back =head2 ResultSet method in Action $schema->resultset('Book')->good =head2 ResultSet Chaining $schema->resultset('Book') ->good ->cheap ->recent =head2 search_related my $score = $schema->resultset('User') ->search({'me.userid' => 'frew'}) ->related_resultset('access') ->related_resultset('mgmt') ->related_resultset('orders') ->telephone ->search_related( shops => { 'shops.datecompleted' => { -between => ['2009-10-01','2009-10-08'] } })->completed ->related_resultset('rpt_score') ->search(undef, { rows => 1}) ->get_column('raw_scores') ->next; The SQL that this produces (with placeholders filled in for clarity's sake) on our system (Microsoft SQL) is: SELECT raw_scores FROM ( SELECT raw_scores, ROW_NUMBER() OVER ( ORDER BY ( SELECT (1) ) ) AS rno__row__index FROM ( SELECT rpt_score.raw_scores FROM users me JOIN access access ON access.userid = me.userid JOIN mgmt mgmt ON mgmt.mgmtid = access.mgmtid JOIN [order] orders ON orders.mgmtid = mgmt.mgmtid JOIN shop shops ON shops.orderno = orders.orderno JOIN rpt_scores rpt_score ON rpt_score.shopno = shops.shopno WHERE ( datecompleted IS NOT NULL AND ( (shops.datecompleted BETWEEN '2009-10-01' AND '2009-10-08') AND (type = '1' AND me.userid = 'frew') ) ) ) rpt_score ) rpt_score WHERE rno__row__index BETWEEN 1 AND 1 See: L, L, and L. =head2 bonus rel methods my $book = $author->create_related( books => { title => 'Another Discworld book', } ); my $book2 = $pratchett->add_to_books({ title => 'MOAR Discworld book', }); See L and L Note that it automatically fills in foreign key for you =head2 Excellent Transaction Support $schema->txn_do(sub { ... }); $schema->txn_begin; # <-- low level # ... $schema->txn_commit; See L, L, and L. =head2 InflateColumn package Frew::Schema::Result::Book; use strict; use warnings; use base 'DBIx::Class::Core'; use DateTime::Format::MySQL; # Result code here __PACKAGE__->load_components('InflateColumn'); __PACKAGE__->inflate_column( date_published => { inflate => sub { DateTime::Format::MySQL->parse_date( shift ) }, deflate => sub { shift->ymd }, }, ); See L, L, and L. =head2 InflateColumn: deflation $book->date_published(DateTime->now); $book->update; =head2 InflateColumn: inflation say $book->date_published->month_abbr; # Nov =head2 FilterColumn package Frew::Schema::Result::Book; use strict; use warnings; use base 'DBIx::Class::Core'; # Result code here __PACKAGE__->load_components('FilterColumn'); __PACKAGE__->filter_column( length => { to_storage => 'to_metric', from_storage => 'to_imperial', }, ); sub to_metric { $_[1] * .305 } sub to_imperial { $_[1] * 3.28 } See L and L =head2 ResultSetColumn my $rsc = $schema->resultset('Book')->get_column('price'); $rsc->first; $rsc->all; $rsc->min; $rsc->max; $rsc->sum; See L =head2 Aggregates my @res = $rs->search(undef, { select => [ 'price', 'genre', { max => price }, { avg => price }, ], as => [ qw(price genre max_price avg_price) ], group_by => [qw(price genre)], }); for (@res) { say $_->price . ' ' . $_->genre; say $_->get_column('max_price'); say $_->get_column('avg_price'); } See L, L, and L =over 1 =item Careful, get_column can basically mean B things =item private in which case you should use an accessor =item public for what there is no accessor for =item public for get resultset column (prev example) =back =head2 HRI $rs->search(undef, { result_class => 'DBIx::Class::ResultClass::HashRefInflator', }); See L and L. =over 1 =item Easy on memory =item Mega fast =item Great for quick debugging =item Great for performance tuning (we went from 2m to < 3s) =back =head2 Subquery Support my $inner_query = $schema->resultset('Artist') ->search({ name => [ 'Billy Joel', 'Brittany Spears' ], })->get_column('id')->as_query; my $rs = $schema->resultset('CD')->search({ artist_id => { -in => $inner_query }, }); See L =head2 Bare SQL w/ Placeholders $rs->update({ # !!! SQL INJECTION VECTOR price => \"price + $inc", # DON'T DO THIS }); Better: $rs->update({ price => \['price + ?', [inc => $inc]], }); See L =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. DBIx-Class-0.082843/lib/DBIx/Class/Manual/ResultClass.pod0000444000175000017500000001561114240676411021700 0ustar rabbitrabbit=for comment POD_DERIVED_INDEX_GENERATED The following documentation is automatically generated. Please do not edit this file, but rather the original, inline with DBIx::Class::Manual::ResultClass at lib/DBIx/Class/Manual/ResultClass.pod (on the system that originally ran this). If you do edit this file, and don't want your changes to be removed, make sure you change the first line. =cut =head1 NAME DBIx::Class::Manual::ResultClass - Representing a single result (row) from a DB query =head1 SYNOPSIS package My::Schema::Result::Track; use parent 'DBIx::Class::Core'; __PACKAGE__->table('tracks'); __PACKAGE__->add_columns({ id => { data_type => 'int', is_auto_increment => 1, }, cd_id => { data_type => 'int', }, title => { data_type => 'varchar', size => 50, }, rank => { data_type => 'int', is_nullable => 1, }, }); __PACKAGE__->set_primary_key('id'); __PACKAGE__->add_unique_constraint(u_title => ['cd_id', 'title']); =head1 DESCRIPTION In L, a user normally receives query results as instances of a certain C, depending on the main query source. Besides being the primary "toolset" for interaction with your data, a C also serves to establish source metadata, which is then used during initialization of your L instance. Because of these multiple seemingly conflicting purposes, it is hard to aggregate the documentation of various methods available on a typical C. This document serves as a general overview of C declaration best practices, and offers an index of the available methods (and the Components/Roles which provide them). =head1 INHERITED METHODS =over 4 =item L L, L, L, L, L =item L L, L, L, L, L, L, L, L, L, L, L, L, L, L =item L L, L, L, L =item L L, L, L =item L L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L =item L L, L =item L L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L =back =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. DBIx-Class-0.082843/lib/DBIx/Class/Manual/Reading.pod0000644000175000017500000001305313271562530021004 0ustar rabbitrabbit =head1 NAME DBIx::Class::Manual::Reading - How to read and write DBIx::Class POD. =head1 DESCRIPTION This doc should help users to understand how the examples and documentation found in the L distribution can be interpreted. Writers of DBIx::Class POD should also check here to make sure their additions are consistent with the rest of the documentation. =head1 METHODS Methods should be documented in the files which also contain the code for the method, or that file should be hidden from PAUSE completely, in which case the methods are documented in the file which loads it. Methods may also be documented and referred to in files representing the major objects or components on which they can be called. For example, L documents the methods actually coded in the helper relationship classes like DBIx::Class::Relationship::BelongsTo. The BelongsTo file itself is hidden from PAUSE as it has no documentation. The accessors created by relationships should be mentioned in L, the major object that they will be called on. =head2 Method documentation =over =item * Each method starts with a "head2" statement of its name. Just the plain method name, not an example of how to call it, or a link. This is to ensure easy linking to method documentation from other POD. =item * The header is followed by a two-item list. This contains a description of the arguments the method is expected to take, and an indication of what the method returns. The first item provides a list of all possible values for the arguments of the method in order, separated by C<, >, preceded by the text "Arguments: " Example (for the belongs_to relationship): =item Arguments: $accessor_name, $related_class, $fk_column|\%cond|\@cond?, \%attr? The following possible argument sigils can be shown: =over =item * $var - A scalar (string or numeric) variable. =item * \%var - A variable containing reference to a hash. =item * \@var - A variable containing a reference to an array. =item * \$var - A variable containing a reference to a scalar variable. =item * %var - A hashref variable (list of key/value pairs) - rarely used in DBIx::Class. Reading an argument as a hash variable will consume all subsequent method arguments, use with caution. =item * @var - An array variable (list of values). Reading an argument as a array variable will consume all subsequent method arguments, use with caution. =item * L<$obj|DBIx::Class> - Reference to the source class or object definition All arguments and return values should provide a link to the object's class documentation or definition, even if it's the same class as the current documentation. For example: ## Correct, if stated within DBIx::Class::ResultSet L<$resultset|/new> ## Correct, if stated outside DBIx::Class::ResultSet L<$resultset|DBIx::Class::ResultSet> =item * ? - Optional, should be placed after the argument type and name. ## Correct \%myhashref|\@myarrayref? ## Wrong \%myhashref?|\@myarrayref Applies to the entire argument. Optional arguments can be left out of method calls, unless the caller needs to pass in any of the following arguments. In which case the caller should pass C in place of the missing argument. =item * | - Alternate argument content types. At least one of these must be supplied unless the argument is also marked optional. =back The second item starts with the text "Return Value:". The remainder of the line is either the text "not defined" or a variable with a descriptive name. ## Good examples =item Return Value: not defined =item Return Value: L<$schema|DBIx::Class::Schema> =item Return Value: $classname ## Bad examples =item Return Value: The names "not defined" means the method does not deliberately return a value, and the caller should not use or rely on anything it does return. (Perl functions always return something, usually the result of the last code statement, if there is no explicit return statement.) This is different than specifying "undef", which means that it explicitly returns undef, though usually this is used an alternate return (like C<$obj | undef>). =item * The argument/return list is followed by a single paragraph describing what the method does. =item * The description paragraph is followed by another list. Each item in the list explains one of the possible argument/type combinations. This list may be omitted if the author feels that the variable names are self-explanatory enough to not require it. Use best judgement. =item * The argument/return list is followed by some examples of how to use the method, using its various types of arguments. The examples can also include ways to use the results if applicable. For instance, if the documentation is for a relationship type, the examples can include how to call the resulting relation accessor, how to use the relation name in a search and so on. If some of the examples assume default values, these should be shown with and without the actual arguments, with hints about the equivalent calls. The example should be followed by one or more paragraphs explaining what it does. Examples and explaining paragraphs can be repeated as necessary. =back =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. DBIx-Class-0.082843/lib/DBIx/Class/Manual/Troubleshooting.pod0000644000175000017500000001327314240132261022615 0ustar rabbitrabbit=head1 NAME DBIx::Class::Manual::Troubleshooting - Got a problem? Shoot it. =head2 "Can't locate storage blabla" You're trying to make a query on a non-connected schema. Make sure you got the current resultset from $schema->resultset('Artist') on a schema object you got back from connect(). =head2 Tracing SQL The C environment variable controls SQL tracing, so to see what is happening try export DBIC_TRACE=1 Alternatively use the C<< storage->debug >> class method:- $schema->storage->debug(1); To send the output somewhere else set debugfh:- $schema->storage->debugfh(IO::File->new('/tmp/trace.out', 'w')); Alternatively you can do this with the environment variable, too:- export DBIC_TRACE="1=/tmp/trace.out" =head2 Can't locate method result_source_instance For some reason the table class in question didn't load fully, so the ResultSource object for it hasn't been created. Debug this class in isolation, then try loading the full schema again. =head2 Can't get last insert ID under Postgres with serial primary keys Older L and L versions do not handle C correctly, causing code that uses auto-incrementing primary key columns to fail with a message such as: Can't get last insert id at /.../DBIx/Class/Row.pm line 95 In particular the RHEL 4 and FC3 Linux distributions both ship with combinations of L and L modules that do not work correctly. L version 1.50 and L 1.43 are known to work. =head2 Can't locate object method "source_name" via package There's likely a syntax error in the table class referred to elsewhere in this error message. In particular make sure that the package declaration is correct. For example, for a schema C< MySchema > you need to specify a fully qualified namespace: C< package MySchema::MyTable; >. =head2 syntax error at or near "" ... This can happen if you have a relation whose name is a word reserved by your database, e.g. "user": package My::Schema::User; ... __PACKAGE__->table('users'); __PACKAGE__->add_columns(qw/ id name /); __PACKAGE__->set_primary_key('id'); ... 1; package My::Schema::ACL; ... __PACKAGE__->table('acl'); __PACKAGE__->add_columns(qw/ user_id /); __PACKAGE__->belongs_to( 'user' => 'My::Schema::User', 'user_id' ); ... 1; $schema->resultset('ACL')->search( {}, { join => [qw/ user /], '+select' => [ 'user.name' ] } ); The SQL generated would resemble something like: SELECT me.user_id, user.name FROM acl me JOIN users user ON me.user_id = user.id If, as is likely, your database treats "user" as a reserved word, you'd end up with the following errors: 1) syntax error at or near "." - due to "user.name" in the SELECT clause 2) syntax error at or near "user" - due to "user" in the JOIN clause The solution is to enable quoting - see L for details. =head2 column "foo DESC" does not exist ... This can happen if you are still using the obsolete order hack, and also happen to turn on SQL-quoting. $rs->search( {}, { order_by => [ 'name DESC' ] } ); The above should be written as: $rs->search( {}, { order_by => { -desc => 'name' } } ); For more ways to express order clauses refer to L =head2 Perl Performance Issues on Red Hat Systems There is a problem with slow performance of certain DBIx::Class operations using the system perl on some Fedora and Red Hat Enterprise Linux system (as well as their derivative distributions such as Centos, White Box and Scientific Linux). Distributions affected include Fedora 5 through to Fedora 8 and RHEL5 up to and including RHEL5 Update 2. Fedora 9 (which uses perl 5.10) has never been affected - this is purely a perl 5.8.8 issue. As of September 2008 the following packages are known to be fixed and so free of this performance issue (this means all Fedora and RHEL5 systems with full current updates will not be subject to this problem):- Fedora 8 - perl-5.8.8-41.fc8 RHEL5 - perl-5.8.8-15.el5_2.1 This issue is due to perl doing an exhaustive search of blessed objects under certain circumstances. The problem shows up as performance degradation exponential to the number of L result objects in memory, so can be unnoticeable with certain data sets, but with huge performance impacts on other datasets. A pair of tests for susceptibility to the issue and performance effects of the bless/overload problem can be found in the L test suite, in the C file. Further information on this issue can be found in L, L and L =head2 Excessive Memory Allocation with TEXT/BLOB/etc. Columns and Large LongReadLen It has been observed, using L, that creating a L object which includes a column of data type TEXT/BLOB/etc. will allocate LongReadLen bytes. This allocation does not leak, but if LongReadLen is large in size, and many such result objects are created, e.g. as the output of a ResultSet query, the memory footprint of the Perl interpreter can grow very large. The solution is to use the smallest practical value for LongReadLen. =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. DBIx-Class-0.082843/lib/DBIx/Class/Manual/QuickStart.pod0000644000175000017500000001453413271562530021532 0ustar rabbitrabbit=head1 NAME DBIx::Class::Manual::QuickStart - up and running with DBIC in 10 minutes =head1 DESCRIPTION This document shows the minimum amount of code to make you a productive DBIC user. It requires you to be familiar with just the basics of database programming (what database tables, rows and columns are) and the basics of Perl object-oriented programming (calling methods on an object instance). It also helps if you already know a bit of SQL and how to connect to a database through DBI. Follow along with the example database shipping with this distribution, see directory F. This database is also used through-out the rest of the documentation. =head2 Preparation First, install DBIx::Class like you do with any other CPAN distribution. See L and L. Then open the distribution in your shell and change to the subdirectory mentioned earlier, the next command will download and unpack it: $ perl -mCPAN -e'CPAN::Shell->look("DBIx::Class")' DBIx-Class$ cd examples/Schema Inspect the database: DBIx-Class/examples/Schema$ sqlite3 db/example.db .dump You can also use a GUI database browser such as L. Have a look at the schema classes files in the subdirectory F. The C class is the entry point for loading the other classes and interacting with the database through DBIC and the C classes correspond to the tables in the database. L shows how to write all that Perl code. That is almost never necessary, though. Instead use L (part of the distribution L) to automatically create schema classes files from an existing database. The chapter L below shows an example invocation. =head2 Connecting to the database A L object represents the database. use MyApp::Schema qw(); my $schema = MyApp::Schema->connect('dbi:SQLite:db/example.db'); The first four arguments are the same as for L. =head2 Working with data Almost all actions go through a L object. =head3 Adding data Via intermediate result objects: my $artist_ma = $schema->resultset('Artist')->create({ name => 'Massive Attack', }); my $cd_mezz = $artist_ma->create_related(cds => { title => 'Mezzanine', }); for ('Angel', 'Teardrop') { $cd_mezz->create_related(tracks => { title => $_ }); } Via relation accessors: $schema->resultset('Artist')->create({ name => 'Metallica', cds => [ { title => q{Kill 'Em All}, tracks => [ { title => 'Jump in the Fire' }, { title => 'Whiplash' }, ], }, { title => 'ReLoad', tracks => [ { title => 'The Memory Remains' }, { title => 'The Unforgiven II' }, { title => 'Fuel' }, ], }, ], }); Columns that are not named are filled with default values. The value C acts as a C in the database. See the chapter L below to find out where the non-obvious source name strings such as C and accessors such as C and C come from. Set the environment variable C to see the generated queries. =head3 Retrieving data Set up a condition. my $artists_starting_with_m = $schema->resultset('Artist')->search( { name => { like => 'M%' } } ); Iterate over result objects of class C. L objects represent a row and automatically get accessors for their column names. for my $artist ($artists_starting_with_m->all) { say $artist->name; } =head3 Changing data Change the release year of all CDs titled I. $schema->resultset('Cd')->search( { title => 'ReLoad', } )->update_all( { year => 1997, } ); =head3 Removing data Removes all tracks titled I regardless of which CD the belong to. $schema->resultset('Track')->search( { title => 'Fuel', } )->delete_all; =head2 Introspecting the schema classes This is useful for getting a feel for the naming of things in a REPL or during explorative programming. From the root to the details: $schema->sources; # returns qw(Cd Track Artist) $schema->source('Cd')->columns; # returns qw(cdid artist title year) $schema->source('Cd')->relationships; # returns qw(artist tracks) From a detail to the root: $some_result->result_source; # returns appropriate source $some_resultset->result_source; $some_resultsource->schema; # returns appropriate schema =head2 Resetting the database # delete database file DBIx-Class/examples/Schema$ rm -f db/example.db # create database and set up tables from definition DBIx-Class/examples/Schema$ sqlite3 db/example.db < db/example.sql # fill them with data DBIx-Class/examples/Schema$ perl ./insertdb.pl # delete the schema classes files DBIx-Class/examples/Schema$ rm -rf MyApp # recreate schema classes files from database file DBIx-Class/examples/Schema$ dbicdump \ -o dump_directory=. MyApp::Schema dbi:SQLite:db/example.db =head2 Where to go next If you want to exercise what you learned with a more complicated schema, load L into your database. If you want to transfer your existing SQL knowledge, read L. Continue with L and L. =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. DBIx-Class-0.082843/lib/DBIx/Class/Manual/FAQ.pod0000644000175000017500000006006614240132261020037 0ustar rabbitrabbit=head1 NAME DBIx::Class::Manual::FAQ - Frequently Asked Questions (in theory) =head1 DESCRIPTION This document is intended as an anti-map of the documentation. If you know what you want to do, but not how to do it in L, then look here. It does B contain much code or examples, it just gives explanations and pointers to the correct pieces of documentation to read. =head1 FAQs How Do I: =head2 Getting started =over 4 =item .. create a database to use? First, choose a database. For testing/experimenting, we recommend L, which is a self-contained small database (i.e. all you need to do is to install L from CPAN, and it works). Next, spend some time defining which data you need to store, and how it relates to the other data you have. For some help on normalisation, go to L. Now, decide whether you want to have the database itself be the definitive source of information about the data layout, or your DBIx::Class schema. If it's the former, look up the documentation for your database, eg. L, on how to create tables, and start creating them. For a nice universal interface to your database, you can try L. If you decided on the latter choice, read the FAQ on setting up your classes manually, and the one on creating tables from your schema. =item .. use DBIx::Class with L? Install L from CPAN. See its documentation, or below, for further details. =item .. set up my DBIx::Class classes automatically from my database? Install L from CPAN, and read its documentation. =item .. set up my DBIx::Class classes manually? Look at the L and come back here if you get lost. =item .. create my database tables from my DBIx::Class schema? Create your classes manually, as above. Write a script that calls L. See there for details, or the L. =item .. store/retrieve Unicode data in my database? Make sure you database supports Unicode and set the connect attributes appropriately - see L =item .. connect to my database? Once you have created all the appropriate table/source classes, and an overall L class, you can start using them in an application. To do this, you need to create a central Schema object, which is used to access all the data in the various tables. See L for details. The actual connection does not happen until you actually request data, so don't be alarmed if the error from incorrect connection details happens a lot later. =item .. use DBIx::Class across multiple databases? If your database server allows you to run queries across multiple databases at once, then so can DBIx::Class. All you need to do is make sure you write the database name as part of the L call. Eg: __PACKAGE__->table('mydb.mytablename'); And load all the Result classes for both / all databases by calling L. =item .. use DBIx::Class across PostgreSQL/DB2/Oracle schemas? Add the name of the schema to the table name, when invoking L, and make sure the user you are about to connect as has permissions to read/write all the schemas/tables as necessary. =back =head2 Relationships =over 4 =item .. tell DBIx::Class about relationships between my tables? There are a variety of relationship types that come pre-defined for you to use. These are all listed in L. If you need a non-standard type, or more information, look in L. =item .. define a one-to-many relationship? This is called a C relationship on the one side, and a C relationship on the many side. Currently these need to be set up individually on each side. See L for details. =item .. define a relationship where this table contains another table's primary key? (foreign key) Create a C relationship for the field containing the foreign key. See L. =item .. define a foreign key relationship where the key field may contain NULL? Just create a C relationship, as above. If the column is NULL then the inflation to the foreign object will not happen. This has a side effect of not always fetching all the relevant data, if you use a nullable foreign-key relationship in a JOIN, then you probably want to set the C to C. =item .. define a relationship where the key consists of more than one column? Instead of supplying a single column name, all relationship types also allow you to supply a hashref containing the condition across which the tables are to be joined. The condition may contain as many fields as you like. See L. =item .. define a relationship bridge across an intermediate table? (many-to-many) The term 'relationship' is used loosely with many_to_many as it is not considered a relationship in the fullest sense. For more info, read the documentation on L. =item .. stop DBIx::Class from attempting to cascade deletes on my has_many and might_have relationships? By default, DBIx::Class cascades deletes and updates across C and C relationships. You can disable this behaviour on a per-relationship basis by supplying C<< cascade_delete => 0 >> in the relationship attributes. The cascaded operations are performed after the requested delete or update, so if your database has a constraint on the relationship, it will have deleted/updated the related records or raised an exception before DBIx::Class gets to perform the cascaded operation. See L. =item .. use a relationship? Use its name. An accessor is created using the name. See examples in L. =back =head2 Searching =over 4 =item .. search for data? Create a C<$schema> object, as mentioned above in L. Find the L that you want to search in, by calling C<< $schema->resultset('MySource') >> and call C on it. See L. =item .. search using database functions? Supplying something like: ->search({'mydatefield' => 'now()'}) to search, will probably not do what you expect. It will quote the text "now()", instead of trying to call the function. To provide literal, unquoted text you need to pass in a scalar reference, like so: ->search({'mydatefield' => \'now()'}) =item .. sort the results of my search? Supply a list of columns you want to sort by to the C attribute. See L. =item .. sort my results based on fields I've aliased using C? You didn't alias anything, since L B with the produced SQL. See L for details. =item .. group the results of my search? Supply a list of columns you want to group on, to the C attribute, see L. =item .. group my results based on fields I've aliased using C? You don't. See the explanation on ordering by an alias above. =item .. filter the results of my search? The first argument to C is a hashref of accessor names and values to filter them by, for example: ->search({'created_time' => { '>=', '2006-06-01 00:00:00' } }) Note that to use a function here you need to make it a scalar reference: ->search({'created_time' => { '>=', \'yesterday()' } }) =item .. search in several tables simultaneously? To search in two related tables, you first need to set up appropriate relationships between their respective classes. When searching you then supply the name of the relationship to the C attribute in your search, for example when searching in the Books table for all the books by the author "Fred Bloggs": ->search({'authors.name' => 'Fred Bloggs'}, { join => 'authors' }) The type of join created in your SQL depends on the type of relationship between the two tables, see L for the join used by each relationship. =item .. create joins with conditions other than column equality? Currently, L can only create join conditions using equality, so you're probably better off creating a C in your database, and using that as your source. A C is a stored SQL query, which can be accessed similarly to a table, see your database documentation for details. =item .. search with an SQL function on the left hand side? To use an SQL function on the left hand side of a comparison you currently need to resort to literal SQL: ->search( \[ 'YEAR(date_of_birth) = ?', 1979 ] ); =item .. find more help on constructing searches? Behind the scenes, DBIx::Class uses L to help construct its SQL searches. So if you fail to find help in the L, try looking in the L documentation. =item .. make searches in Oracle (10gR2 and newer) case-insensitive? To make Oracle behave like most RDBMS use on_connect_do to issue alter session statements on database connection establishment: ->on_connect_do("ALTER SESSION SET NLS_COMP = 'LINGUISTIC'"); ->on_connect_do("ALTER SESSION SET NLS_SORT = '_CI'"); e.g. ->on_connect_do("ALTER SESSION SET NLS_SORT = 'BINARY_CI'"); ->on_connect_do("ALTER SESSION SET NLS_SORT = 'GERMAN_CI'"); =item .. format a DateTime object for searching? L and L do not take L into account, and so your L object will not be correctly deflated into a format your RDBMS expects. The L method on your storage object can be used to return the object that would normally do this, so it's easy to do it manually: my $dtf = $schema->storage->datetime_parser; my $rs = $schema->resultset('users')->search( { signup_date => { -between => [ $dtf->format_datetime($dt_start), $dtf->format_datetime($dt_end), ], } }, ); With in a Result Class method, you can get this from the L|DBIx::Class::Row/result_source>. my $dtf = $self->result_source->storage->datetime_parser; This kludge is necessary only for conditions passed to L and L, whereas L and L (but not L) are L-aware and will do the right thing when supplied an inflated L object. =back =head2 Fetching data =over 4 =item .. fetch as much data as possible in as few select calls as possible? See the prefetch examples in the L. =item .. fetch a whole column of data instead of a row? Call C on a L. This returns a L. See its documentation and the L for details. =item .. fetch a formatted column? In your table schema class, create a "private" column accessor with: __PACKAGE__->add_columns(my_column => { accessor => '_hidden_my_column' }); Then, in the same class, implement a subroutine called "my_column" that fetches the real value and does the formatting you want. See the L for more details. =item .. fetch a single (or topmost) row? Use the L and L attributes to order your data and pick off a single row. See also L. A less readable way is to ask a regular search to return 1 row, using L: ->search->(undef, { order_by => "id DESC" })->slice(0) which (if supported by the database) will use LIMIT/OFFSET to hint to the database that we really only need one row. This can result in a significant speed improvement. The method using L mentioned in the cookbook can do the same if you pass a C attribute to the search. =item .. refresh a row from storage? Use L. $result->discard_changes Discarding changes and refreshing from storage are two sides of the same coin. When you want to discard your local changes, just re-fetch the row from storage. When you want to get a new, fresh copy of the row, just re-fetch the row from storage. L does just that by re-fetching the row from storage using the row's primary key. =item .. fetch my data a "page" at a time? Pass the C and C attributes to your search, eg: ->search({}, { rows => 10, page => 1}); =item .. get a count of all rows even when paging? Call C on the paged resultset, it will return a L with an API/behavior identical to that of L. Calling C on the pager will return the correct total. C on the resultset will only return the total number in the page. =back =head2 Inserting and updating data =over 4 =item .. insert a row with an auto incrementing primary key? This happens automatically. After L a result object, the primary key value created by your database can be fetched by calling C (or the access of your primary key column) on the object. =item .. insert a row with a primary key that uses a sequence? You need to create a trigger in your database that updates your primary key field from the sequence. To help PK::Auto find the next key value, you can tell it the name of the sequence in the C supplied with C. ->add_columns({ id => { sequence => 'mysequence', auto_nextval => 1 } }); =item .. insert many rows of data efficiently? The C method in L provides efficient bulk inserts. L provides an alternative way to do this. =item .. update a collection of rows at the same time? Create a resultset using a C, to filter the rows of data you would like to update, then call C on the resultset to change all the rows at once. =item .. use database functions when updating rows? =item .. update a column using data from another column? To stop the column name from being quoted, you'll need to tell DBIC that the right hand side is an SQL identifier (it will be quoted properly if you have quoting enabled): ->update({ somecolumn => { -ident => 'othercolumn' } }) This method will not retrieve the new value and put it in your Row object. To fetch the new value, use the C method on the Row. # will return the scalar reference: $result->somecolumn() # issue a select using the PK to re-fetch the row data: $result->discard_changes(); # Now returns the correct new value: $result->somecolumn() To update and refresh at once, chain your calls: $result->update({ 'somecolumn' => { -ident => 'othercolumn' } })->discard_changes; =item .. store JSON/YAML in a column and have it deflate/inflate automatically? You can use L to accomplish YAML/JSON storage transparently. If you want to use JSON, then in your table schema class, do the following: use JSON; __PACKAGE__->add_columns(qw/ ... my_column ../) __PACKAGE__->inflate_column('my_column', { inflate => sub { jsonToObj(shift) }, deflate => sub { objToJson(shift) }, }); For YAML, in your table schema class, do the following: use YAML; __PACKAGE__->add_columns(qw/ ... my_column ../) __PACKAGE__->inflate_column('my_column', { inflate => sub { YAML::Load(shift) }, deflate => sub { YAML::Dump(shift) }, }); This technique is an easy way to store supplemental unstructured data in a table. Be careful not to overuse this capability, however. If you find yourself depending more and more on some data within the inflated column, then it may be time to factor that data out. =back =head2 Custom methods in Result classes You can add custom methods that do arbitrary things, even to unrelated tables. For example, to provide a C<< $book->foo() >> method which searches the cd table, you'd could add this to Book.pm: sub foo { my ($self, $col_data) = @_; return $self->result_source->schema->resultset('cd')->search($col_data); } And invoke that on any Book Result object like so: my $rs = $book->foo({ title => 'Down to Earth' }); When two tables ARE related, L provides many methods to find or create data in related tables for you. But if you want to write your own methods, you can. For example, to provide a C<< $book->foo() >> method to manually implement what create_related() from L does, you could add this to Book.pm: sub foo { my ($self, $rel_name, $col_data) = @_; return $self->related_resultset($rel_name)->create($col_data); } Invoked like this: my $author = $book->foo('author', { name => 'Fred' }); =head2 Misc =over 4 =item How do I store my own (non-db) data in my DBIx::Class objects? You can add your own data accessors to your Result classes. One method is to use the built in mk_group_accessors (via L) package App::Schema::Result::MyTable; use parent 'DBIx::Class::Core'; __PACKAGE__->table('foo'); #etc __PACKAGE__->mk_group_accessors('simple' => qw/non_column_data/); # must use simple group And another method is to use L with your L package. package App::Schema::Result::MyTable; use Moose; # import Moose use Moose::Util::TypeConstraint; # import Moose accessor type constraints extends 'DBIx::Class::Core'; # Moose changes the way we define our parent (base) package has 'non_column_data' => ( is => 'rw', isa => 'Str' ); # define a simple attribute __PACKAGE__->table('foo'); # etc With either of these methods the resulting use of the accessor would be my $result; # assume that somewhere in here $result will get assigned to a MyTable row $result->non_column_data('some string'); # would set the non_column_data accessor # some other stuff happens here $result->update(); # would not inline the non_column_data accessor into the update =item How do I use DBIx::Class objects in my TT templates? Like normal objects, mostly. However you need to watch out for TT calling methods in list context. When calling relationship accessors you will not get resultsets, but a list of all the related objects. Use the L method, or the relationship accessor methods ending with "_rs" to work around this issue. See also L. =item See the SQL statements my code is producing? Set the shell environment variable C to a true value. For more info see L for details of how to turn on debugging in the environment, pass your own filehandle to save debug to, or create your own callback. =item Why didn't my search run any SQL? L runs the actual SQL statement as late as possible, thus if you create a resultset using C in scalar context, no query is executed. You can create further resultset refinements by calling search again or relationship accessors. The SQL query is only run when you ask the resultset for an actual result object. =item How do I deal with tables that lack a primary key? If your table lacks a primary key, DBIx::Class can't work out which row it should operate on, for example to delete or update. However, a UNIQUE constraint on one or more columns allows DBIx::Class to uniquely identify the row, so you can tell L these columns act as a primary key, even if they don't from the database's point of view: $resultset->set_primary_key(@column); =item How do I make my program start faster? Look at the tips in L =item How do I reduce the overhead of database queries? You can reduce the overhead of object creation within L using the tips in L and L =item How do I override a run time method (e.g. a relationship accessor)? If you need access to the original accessor, then you must "wrap around" the original method. You can do that either with L or L. The code example works for both modules: package Your::Schema::Group; use Class::Method::Modifiers; # ... declare columns ... __PACKAGE__->has_many('group_servers', 'Your::Schema::GroupServer', 'group_id'); __PACKAGE__->many_to_many('servers', 'group_servers', 'server'); # if the server group is a "super group", then return all servers # otherwise return only servers that belongs to the given group around 'servers' => sub { my $orig = shift; my $self = shift; return $self->$orig(@_) unless $self->is_super_group; return $self->result_source->schema->resultset('Server')->all; }; If you just want to override the original method, and don't care about the data from the original accessor, then you have two options. Either use L that does most of the work for you, or do it the "dirty way". L way: package Your::Schema::Group; use Method::Signatures::Simple; # ... declare columns ... __PACKAGE__->has_many('group_servers', 'Your::Schema::GroupServer', 'group_id'); __PACKAGE__->many_to_many('servers', 'group_servers', 'server'); # The method keyword automatically injects the annoying my $self = shift; for you. method servers { return $self->result_source->schema->resultset('Server')->search({ ... }); } The dirty way: package Your::Schema::Group; use Sub::Name; # ... declare columns ... __PACKAGE__->has_many('group_servers', 'Your::Schema::GroupServer', 'group_id'); __PACKAGE__->many_to_many('servers', 'group_servers', 'server'); *servers = subname servers => sub { my $self = shift; return $self->result_source->schema->resultset('Server')->search({ ... }); }; =back =head2 Notes for CDBI users =over 4 =item Is there a way to make an object auto-stringify itself as a particular column or group of columns (a-la cdbi Stringfy column group, or stringify_self method) ? See L =back =head2 Troubleshooting =over 4 =item Help, I can't connect to postgresql! If you get an error such as: DBI connect('dbname=dbic','user',...) failed: could not connect to server: No such file or directory Is the server running locally and accepting connections on Unix domain socket "/var/run/postgresql/.s.PGSQL.5432"? Likely you have/had two copies of postgresql installed simultaneously, the second one will use a default port of 5433, while L is compiled with a default port of 5432. You can change the port setting in C. =item I've lost or forgotten my mysql password Stop mysqld and restart it with the --skip-grant-tables option. Issue the following statements in the mysql client. UPDATE mysql.user SET Password=PASSWORD('MyNewPass') WHERE User='root'; FLUSH PRIVILEGES; Restart mysql. Taken from: L. =back =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. DBIx-Class-0.082843/lib/DBIx/Class/Manual/Intro.pod0000644000175000017500000004113214240132261020514 0ustar rabbitrabbit=head1 NAME DBIx::Class::Manual::Intro - Introduction to DBIx::Class =head1 INTRODUCTION You're bored with SQL, and want a native Perl interface for your database? Or you've been doing this for a while with L, and think there's a better way? You've come to the right place. =head1 THE DBIx::Class WAY Here are a few simple tips that will help you get your bearings with DBIx::Class. =head2 Tables become Result classes DBIx::Class needs to know what your Table structure looks like. You do that by defining Result classes. Result classes are defined by calling methods proxied to L. Each Result class defines one Table, which defines the Columns it has, along with any Relationships it has to other tables. (And oh, so much more besides) The important thing to understand: A Result class == Table (most of the time, but just bear with my simplification) =head2 It's all about the ResultSet So, we've got some ResultSources defined. Now, we want to actually use those definitions to help us translate the queries we need into handy perl objects! Let's say we defined a ResultSource for an "album" table with three columns: "albumid", "artist", and "title". Any time we want to query this table, we'll be creating a L from its ResultSource. For example, the results of: SELECT albumid, artist, title FROM album; Would be retrieved by creating a ResultSet object from the album table's ResultSource, likely by using the "search" method. DBIx::Class doesn't limit you to creating only simple ResultSets -- if you wanted to do something like: SELECT title FROM album GROUP BY title; You could easily achieve it. The important thing to understand: Any time you would reach for a SQL query in DBI, you are creating a DBIx::Class::ResultSet. =head2 Search is like "prepare" DBIx::Class tends to wait until it absolutely must fetch information from the database. If you are returning a ResultSet, the query won't execute until you use a method that wants to access the data. (Such as "next", or "first") The important thing to understand: Setting up a ResultSet does not execute the query; retrieving the data does. =head2 Search results are returned as Rows Rows of the search from the database are blessed into L objects. =head1 SETTING UP DBIx::Class Let's look at how you can set and use your first native L tree. First we'll see how you can set up your classes yourself. If you want them to be auto-discovered, just skip to the L, which shows you how to use L. =head2 Setting it up manually First, you should create your base schema class, which inherits from L: package My::Schema; use base qw/DBIx::Class::Schema/; In this class you load your result_source ("table", "model") classes, which we will define later, using the load_namespaces() method: # load My::Schema::Result::* and their resultset classes __PACKAGE__->load_namespaces(); By default this loads all the Result (Row) classes in the My::Schema::Result:: namespace, and also any resultset classes in the My::Schema::ResultSet:: namespace (if missing, the resultsets are defaulted to be DBIx::Class::ResultSet objects). You can change the result and resultset namespaces by using options to the L call. It is also possible to do the same things manually by calling C for the Row classes and defining in those classes any required resultset classes. Next, create each of the classes you want to load as specified above: package My::Schema::Result::Album; use base qw/DBIx::Class::Core/; Load any additional components you may need with the load_components() method, and provide component configuration if required. For example, if you want automatic row ordering: __PACKAGE__->load_components(qw/ Ordered /); __PACKAGE__->position_column('rank'); Ordered will refer to a field called 'position' unless otherwise directed. Here you are defining the ordering field to be named 'rank'. (NOTE: Insert errors may occur if you use the Ordered component, but have not defined a position column or have a 'position' field in your row.) Set the table for your class: __PACKAGE__->table('album'); Add columns to your class: __PACKAGE__->add_columns(qw/ albumid artist title rank /); Each column can also be set up with its own accessor, data_type and other pieces of information that it may be useful to have -- just pass C a hash: __PACKAGE__->add_columns(albumid => { accessor => 'album', data_type => 'integer', size => 16, is_nullable => 0, is_auto_increment => 1, }, artist => { data_type => 'integer', size => 16, is_nullable => 0, }, title => { data_type => 'varchar', size => 256, is_nullable => 0, }, rank => { data_type => 'integer', size => 16, is_nullable => 0, default_value => 0, } ); DBIx::Class doesn't directly use most of this data yet, but various related modules such as L make use of it. Also it allows you to create your database tables from your Schema, instead of the other way around. See L for details. See L for more details of the possible column attributes. Accessors are created for each column automatically, so My::Schema::Result::Album will have albumid() (or album(), when using the accessor), artist() and title() methods. Define a primary key for your class: __PACKAGE__->set_primary_key('albumid'); If you have a multi-column primary key, just pass a list instead: __PACKAGE__->set_primary_key( qw/ albumid artistid / ); Define this class' relationships with other classes using either C to describe a column which contains an ID of another Table, or C to make a predefined accessor for fetching objects that contain this Table's foreign key: # in My::Schema::Result::Artist __PACKAGE__->has_many('albums', 'My::Schema::Result::Album', 'artist'); See L for more information about the various types of available relationships and how you can design your own. =head2 Using DBIx::Class::Schema::Loader This module (L) is an external module, and not part of the L distribution. It inspects your database, and automatically creates classes for all the tables in your schema. The simplest way to use it is via the L script from the L distribution. For example: $ dbicdump -o dump_directory=./lib \ -o components='["InflateColumn::DateTime"]' \ MyApp::Schema dbi:mysql:mydb user pass If you have a mixed-case database, use the C option, e.g.: $ dbicdump -o dump_directory=./lib -o preserve_case=1 \ -o components='["InflateColumn::DateTime"]' \ MyApp::Schema dbi:mysql:mydb user pass If you are using L, then you can use the helper that comes with L: $ script/myapp_create.pl model MyModel DBIC::Schema MyApp::Schema \ create=static moniker_map='{ foo => "FOO" }' dbi:SQLite:./myapp.db \ on_connect_do='PRAGMA foreign_keys=ON' quote_char='"' See L for more information on this helper. See the L and L documentation for more information on the many loader options. =head2 Connecting To connect to your Schema, you need to provide the connection details or a database handle. =head3 Via connection details The arguments are the same as for L: my $schema = My::Schema->connect('dbi:SQLite:/home/me/myapp/my.db'); You can create as many different schema instances as you need. So if you have a second database you want to access: my $other_schema = My::Schema->connect( $dsn, $user, $password, $attrs ); Note that L does not cache connections for you. If you use multiple connections, you need to do this manually. To execute some SQL statements on every connect you can add them as an option in a special fifth argument to connect: my $another_schema = My::Schema->connect( $dsn, $user, $password, $attrs, { on_connect_do => \@on_connect_sql_statments } ); See L for more information about this and other special C-time options. =head3 Via a database handle The supplied coderef is expected to return a single connected database handle (e.g. a L C<$dbh>) my $schema = My::Schema->connect ( sub { Some::DBH::Factory->connect }, \%extra_attrs, ); =head2 Basic usage Once you've defined the basic classes, either manually or using L, you can start interacting with your database. To access your database using your $schema object, you can fetch a L representing each of your tables by calling the C method. The simplest way to get a record is by primary key: my $album = $schema->resultset('Album')->find(14); This will run a C
and C. See also: L =head2 ResultSet This is an object representing a set of conditions to filter data. It can either be an entire table, or the results of a query. The actual data is not held in the ResultSet, it is only a description of how to fetch the data. See also: L =head2 Result Result objects contain your actual data. They are returned from ResultSet objects. These are sometimes (incorrectly) called row objects, including older versions of the DBIC documentation. See also: L =head2 Row See Result. =head2 Object See Result. =head2 Record See Result. =head2 prefetch Similar to a join, except the related result objects are fetched and cached for future use, instead of used directly from the ResultSet. This allows you to jump to different relationships within a Result without worrying about generating a ton of extra SELECT statements. =head1 SQL TERMS =head2 CRUD Create, Read, Update, Delete. A general concept of something that can do all four operations (INSERT, SELECT, UPDATE, DELETE), usually at a row-level. =head2 Join This is an SQL keyword, it is used to link multiple tables in one SQL statement. This enables us to fetch data from more than one table at once, or filter data based on content in another table, without having to issue multiple SQL queries. =head2 Normalisation A normalised database is a sane database. Each table contains only data belonging to one concept, related tables refer to the key field or fields of each other. Some links to webpages about normalisation can be found in L. =head2 Related data In SQL, related data actually refers to data that are normalised into the same table. (Yes. DBIC does mis-use this term.) =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. DBIx-Class-0.082843/lib/DBIx/Class/PK/0000755000175000017500000000000014240676463016032 5ustar rabbitrabbitDBIx-Class-0.082843/lib/DBIx/Class/PK/Auto.pm0000644000175000017500000000232013271562530017265 0ustar rabbitrabbitpackage DBIx::Class::PK::Auto; #use base qw/DBIx::Class::PK/; use base qw/DBIx::Class/; use strict; use warnings; 1; __END__ =head1 NAME DBIx::Class::PK::Auto - Automatic primary key class =head1 SYNOPSIS use base 'DBIx::Class::Core'; __PACKAGE__->set_primary_key('id'); =head1 DESCRIPTION This class overrides the insert method to get automatically incremented primary keys. PK::Auto is now part of Core. See L for details of component interactions. =head1 LOGIC C does this by letting the database assign the primary key field and fetching the assigned value afterwards. =head1 METHODS =head2 insert The code that was handled here is now in Row for efficiency. =head2 sequence The code that was handled here is now in ResultSource, and is being proxied to Row as well. =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. DBIx-Class-0.082843/lib/DBIx/Class/PK/Auto/0000755000175000017500000000000014240676463016742 5ustar rabbitrabbitDBIx-Class-0.082843/lib/DBIx/Class/PK/Auto/Pg.pm0000644000175000017500000000135413271562530017641 0ustar rabbitrabbitpackage # hide package from pause DBIx::Class::PK::Auto::Pg; use strict; use warnings; use base qw/DBIx::Class/; __PACKAGE__->load_components(qw/PK::Auto/); 1; __END__ =head1 NAME DBIx::Class::PK::Auto::Pg - (DEPRECATED) Automatic primary key class for Pg =head1 SYNOPSIS Just load PK::Auto instead; auto-inc is now handled by Storage. =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. DBIx-Class-0.082843/lib/DBIx/Class/PK/Auto/MSSQL.pm0000644000175000017500000000136513271562530020174 0ustar rabbitrabbitpackage # hide package from pause DBIx::Class::PK::Auto::MSSQL; use strict; use warnings; use base qw/DBIx::Class/; __PACKAGE__->load_components(qw/PK::Auto/); 1; __END__ =head1 NAME DBIx::Class::PK::Auto::MSSQL - (DEPRECATED) Automatic primary key class for MSSQL =head1 SYNOPSIS Just load PK::Auto instead; auto-inc is now handled by Storage. =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. DBIx-Class-0.082843/lib/DBIx/Class/PK/Auto/DB2.pm0000644000175000017500000000135713271562530017645 0ustar rabbitrabbitpackage # hide package from pause DBIx::Class::PK::Auto::DB2; use strict; use warnings; use base qw/DBIx::Class/; __PACKAGE__->load_components(qw/PK::Auto/); 1; __END__ =head1 NAME DBIx::Class::PK::Auto::DB2 - (DEPRECATED) Automatic primary key class for DB2 =head1 SYNOPSIS Just load PK::Auto instead; auto-inc is now handled by Storage. =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. DBIx-Class-0.082843/lib/DBIx/Class/PK/Auto/SQLite.pm0000644000175000017500000000137013271562530020432 0ustar rabbitrabbitpackage # hide package from pause DBIx::Class::PK::Auto::SQLite; use strict; use warnings; use base qw/DBIx::Class/; __PACKAGE__->load_components(qw/PK::Auto/); 1; __END__ =head1 NAME DBIx::Class::PK::Auto::SQLite - (DEPRECATED) Automatic primary key class for SQLite =head1 SYNOPSIS Just load PK::Auto instead; auto-inc is now handled by Storage. =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. DBIx-Class-0.082843/lib/DBIx/Class/PK/Auto/Oracle.pm0000644000175000017500000000137013271562530020476 0ustar rabbitrabbitpackage # hide package from pause DBIx::Class::PK::Auto::Oracle; use strict; use warnings; use base qw/DBIx::Class/; __PACKAGE__->load_components(qw/PK::Auto/); 1; __END__ =head1 NAME DBIx::Class::PK::Auto::Oracle - (DEPRECATED) Automatic primary key class for Oracle =head1 SYNOPSIS Just load PK::Auto instead; auto-inc is now handled by Storage. =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. DBIx-Class-0.082843/lib/DBIx/Class/PK/Auto/MySQL.pm0000644000175000017500000000136513271562530020242 0ustar rabbitrabbitpackage # hide package from pause DBIx::Class::PK::Auto::MySQL; use strict; use warnings; use base qw/DBIx::Class/; __PACKAGE__->load_components(qw/PK::Auto/); 1; __END__ =head1 NAME DBIx::Class::PK::Auto::MySQL - (DEPRECATED) Automatic primary key class for MySQL =head1 SYNOPSIS Just load PK::Auto instead; auto-inc is now handled by Storage. =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. DBIx-Class-0.082843/lib/DBIx/Class/ResultSource/0000755000175000017500000000000014240676463020157 5ustar rabbitrabbitDBIx-Class-0.082843/lib/DBIx/Class/ResultSource/View.pod0000444000175000017500000001526114240676410021570 0ustar rabbitrabbit=for comment POD_DERIVED_INDEX_GENERATED The following documentation is automatically generated. Please do not edit this file, but rather the original, inline with DBIx::Class::ResultSource::View at lib/DBIx/Class/ResultSource/View.pm (on the system that originally ran this). If you do edit this file, and don't want your changes to be removed, make sure you change the first line. =cut =head1 NAME DBIx::Class::ResultSource::View - ResultSource object representing a view =head1 SYNOPSIS package MyApp::Schema::Result::Year2000CDs; use base qw/DBIx::Class::Core/; __PACKAGE__->table_class('DBIx::Class::ResultSource::View'); __PACKAGE__->table('year2000cds'); __PACKAGE__->result_source_instance->is_virtual(1); __PACKAGE__->result_source_instance->view_definition( "SELECT cdid, artist, title FROM cd WHERE year ='2000'" ); __PACKAGE__->add_columns( 'cdid' => { data_type => 'integer', is_auto_increment => 1, }, 'artist' => { data_type => 'integer', }, 'title' => { data_type => 'varchar', size => 100, }, ); =head1 DESCRIPTION View object that inherits from L This class extends ResultSource to add basic view support. A view has a L, which contains a SQL query. The query can only have parameters if L is set to true. It may contain JOINs, sub selects and any other SQL your database supports. View definition SQL is deployed to your database on L unless you set L to true. Deploying the view does B translate it between different database syntaxes, so be careful what you write in your view SQL. Virtual views (L true), are assumed to not exist in your database as a real view. The L in this case replaces the view name in a FROM clause in a subselect. =head1 EXAMPLES Having created the MyApp::Schema::Year2000CDs schema as shown in the SYNOPSIS above, you can then: $2000_cds = $schema->resultset('Year2000CDs') ->search() ->all(); $count = $schema->resultset('Year2000CDs') ->search() ->count(); If you modified the schema to include a placeholder __PACKAGE__->result_source_instance->view_definition( "SELECT cdid, artist, title FROM cd WHERE year = ?" ); and ensuring you have is_virtual set to true: __PACKAGE__->result_source_instance->is_virtual(1); You could now say: $2001_cds = $schema->resultset('Year2000CDs') ->search({}, { bind => [2001] }) ->all(); $count = $schema->resultset('Year2000CDs') ->search({}, { bind => [2001] }) ->count(); =head1 SQL EXAMPLES =over 4 =item is_virtual set to false $schema->resultset('Year2000CDs')->all(); SELECT cdid, artist, title FROM year2000cds me =item is_virtual set to true $schema->resultset('Year2000CDs')->all(); SELECT cdid, artist, title FROM (SELECT cdid, artist, title FROM cd WHERE year ='2000') me =back =head1 METHODS =head2 is_virtual __PACKAGE__->result_source_instance->is_virtual(1); Set to true for a virtual view, false or unset for a real database-based view. =head2 view_definition __PACKAGE__->result_source_instance->view_definition( "SELECT cdid, artist, title FROM cd WHERE year ='2000'" ); An SQL query for your view. Will not be translated across database syntaxes. =head2 deploy_depends_on __PACKAGE__->result_source_instance->deploy_depends_on( ["MyApp::Schema::Result::Year","MyApp::Schema::Result::CD"] ); Specify the views (and only the views) that this view depends on. Pass this an array reference of fully qualified result classes. =head1 OVERRIDDEN METHODS =head2 from Returns the FROM entry for the table (i.e. the view name) or the SQL as a subselect if this is a virtual view. =head1 OTHER METHODS =head2 new The constructor. =head1 INHERITED METHODS =over 4 =item L L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L =back =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. DBIx-Class-0.082843/lib/DBIx/Class/ResultSource/Table.pod0000444000175000017500000000663714240676410021714 0ustar rabbitrabbit=for comment POD_DERIVED_INDEX_GENERATED The following documentation is automatically generated. Please do not edit this file, but rather the original, inline with DBIx::Class::ResultSource::Table at lib/DBIx/Class/ResultSource/Table.pm (on the system that originally ran this). If you do edit this file, and don't want your changes to be removed, make sure you change the first line. =cut =head1 NAME DBIx::Class::ResultSource::Table - Table object =head1 SYNOPSIS =head1 DESCRIPTION Table object that inherits from L. =head1 METHODS =head2 from Returns the FROM entry for the table (i.e. the table name) =head1 INHERITED METHODS =over 4 =item L L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L =back =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. DBIx-Class-0.082843/lib/DBIx/Class/ResultSource/RowParser/0000755000175000017500000000000014240676463022103 5ustar rabbitrabbitDBIx-Class-0.082843/lib/DBIx/Class/ResultSource/RowParser/Util.pm0000644000175000017500000002504014240132261023336 0ustar rabbitrabbitpackage # hide from the pauses DBIx::Class::ResultSource::RowParser::Util; use strict; use warnings; use DBIx::Class::_Util 'perlstring'; use constant HAS_DOR => ( $] < 5.010 ? 0 : 1 ); use base 'Exporter'; our @EXPORT_OK = qw( assemble_simple_parser assemble_collapsing_parser ); # working title - we are hoping to extract this eventually... our $null_branch_class = 'DBIx::ResultParser::RelatedNullBranch'; sub __wrap_in_strictured_scope { " { use strict; use warnings; use warnings FATAL => 'uninitialized';\n$_[0]\n }" } sub assemble_simple_parser { #my ($args) = @_; # the non-collapsing assembler is easy # FIXME SUBOPTIMAL there could be a yet faster way to do things here, but # need to try an actual implementation and benchmark it: # # First setup the nested data structure you want for each row # Then call bind_col() to alias the row fields into the right place in # the data structure, then to fetch the data do: # push @rows, dclone($row_data_struct) while ($sth->fetchrow); # my $parser_src = sprintf('$_ = %s for @{$_[0]}', __visit_infmap_simple($_[0]) ); # change the quoted placeholders to unquoted alias-references $parser_src =~ s/ \' \xFF__VALPOS__(\d+)__\xFF \' /"\$_->[$1]"/gex; __wrap_in_strictured_scope($parser_src); } # the simple non-collapsing nested structure recursor sub __visit_infmap_simple { my $args = shift; my $my_cols = {}; my $rel_cols; for (keys %{$args->{val_index}}) { if ($_ =~ /^ ([^\.]+) \. (.+) /x) { $rel_cols->{$1}{$2} = $args->{val_index}{$_}; } else { $my_cols->{$_} = $args->{val_index}{$_}; } } my @relperl; for my $rel (sort keys %$rel_cols) { my $rel_struct = __visit_infmap_simple({ %$args, val_index => $rel_cols->{$rel}, }); if (keys %$my_cols) { my $branch_null_checks = join ' && ', map { "( ! defined '\xFF__VALPOS__${_}__\xFF' )" } sort { $a <=> $b } values %{$rel_cols->{$rel}} ; if ($args->{prune_null_branches}) { $rel_struct = sprintf ( '( (%s) ? undef : %s )', $branch_null_checks, $rel_struct, ); } else { $rel_struct = sprintf ( '( (%s) ? bless( (%s), %s ) : %s )', $branch_null_checks, $rel_struct, perlstring($null_branch_class), $rel_struct, ); } } push @relperl, sprintf '( %s => %s )', perlstring($rel), $rel_struct, ; } my $me_struct; $me_struct = __result_struct_to_source($my_cols) if keys %$my_cols; if ($args->{hri_style}) { $me_struct =~ s/^ \s* \{ | \} \s* $//gx if $me_struct; return sprintf '{ %s }', join (', ', $me_struct||(), @relperl); } else { return sprintf '[%s]', join (',', $me_struct || 'undef', @relperl ? sprintf ('{ %s }', join (',', @relperl)) : (), ); } } sub assemble_collapsing_parser { my $args = shift; # it may get unset further down my $no_rowid_container = $args->{prune_null_branches}; my ($top_node_key, $top_node_key_assembler); if (scalar @{$args->{collapse_map}{-identifying_columns}}) { $top_node_key = join ('', map { "{'\xFF__IDVALPOS__${_}__\xFF'}" } @{$args->{collapse_map}{-identifying_columns}} ); } elsif( my @variants = @{$args->{collapse_map}{-identifying_columns_variants}} ) { my @path_parts = map { sprintf "( ( defined '\xFF__VALPOS__%d__\xFF' ) && (join qq(\xFF), '', %s, '') )", $_->[0], # checking just first is enough - one ID defined, all defined ( join ', ', map { "'\xFF__VALPOS__${_}__\xFF'" } @$_ ), } @variants; my $virtual_column_idx = (scalar keys %{$args->{val_index}} ) + 1; $top_node_key = "{'\xFF__IDVALPOS__${virtual_column_idx}__\xFF'}"; $top_node_key_assembler = sprintf "'\xFF__IDVALPOS__%d__\xFF' = (%s);", $virtual_column_idx, "\n" . join( "\n or\n", @path_parts, qq{"\0\$rows_pos\0"} ) ; $args->{collapse_map} = { %{$args->{collapse_map}}, -custom_node_key => $top_node_key, }; $no_rowid_container = 0; } else { die('Unexpected collapse map contents'); } my ($data_assemblers, $stats) = __visit_infmap_collapse ($args); my @idcol_args = $no_rowid_container ? ('', '') : ( ', %cur_row_ids', # only declare the variable if we'll use it join ("\n", map { my $quoted_null_val = qq( "\0NULL\xFF\${rows_pos}\xFF${_}\0" ); qq(\$cur_row_ids{$_} = ) . ( # in case we prune - we will never hit these undefs $args->{prune_null_branches} ? qq( \$cur_row_data->[$_]; ) : HAS_DOR ? qq( \$cur_row_data->[$_] // $quoted_null_val; ) : qq( defined(\$cur_row_data->[$_]) ? \$cur_row_data->[$_] : $quoted_null_val; ) ) } sort { $a <=> $b } keys %{ $stats->{idcols_seen} } ), ); my $parser_src = sprintf (<<'EOS', @idcol_args, $top_node_key_assembler||'', $top_node_key, join( "\n", @{$data_assemblers||[]} ) ); ### BEGIN LITERAL STRING EVAL my $rows_pos = 0; my ($result_pos, @collapse_idx, $cur_row_data %1$s); # this loop is a bit arcane - the rationale is that the passed in # $_[0] will either have only one row (->next) or will have all # rows already pulled in (->all and/or unordered). Given that the # result can be rather large - we reuse the same already allocated # array, since the collapsed prefetch is smaller by definition. # At the end we cut the leftovers away and move on. while ($cur_row_data = ( ( $rows_pos >= 0 and $_[0][$rows_pos++] ) or ( $_[1] and $rows_pos = -1 and $_[1]->() ) ) ) { # this code exists only when we are using a cur_row_ids # furthermore the undef checks may or may not be there # depending on whether we prune or not # # due to left joins some of the ids may be NULL/undef, and # won't play well when used as hash lookups # we also need to differentiate NULLs on per-row/per-col basis # (otherwise folding of optional 1:1s will be greatly confused %2$s # in the case of an underdefined root - calculate the virtual id (otherwise no code at all) %3$s # if we were supplied a coderef - we are collapsing lazily (the set # is ordered properly) # as long as we have a result already and the next result is new we # return the pre-read data and bail $_[1] and $result_pos and ! $collapse_idx[0]%4$s and (unshift @{$_[2]}, $cur_row_data) and last; # the rel assemblers %5$s } $#{$_[0]} = $result_pos - 1; # truncate the passed in array to where we filled it with results ### END LITERAL STRING EVAL EOS # !!! note - different var than the one above # change the quoted placeholders to unquoted alias-references $parser_src =~ s/ \' \xFF__VALPOS__(\d+)__\xFF \' /"\$cur_row_data->[$1]"/gex; $parser_src =~ s/ \' \xFF__IDVALPOS__(\d+)__\xFF \' / $no_rowid_container ? "\$cur_row_data->[$1]" : "\$cur_row_ids{$1}" /gex; __wrap_in_strictured_scope($parser_src); } # the collapsing nested structure recursor sub __visit_infmap_collapse { my $args = {%{ shift() }}; my $cur_node_idx = ${ $args->{-node_idx_counter} ||= \do { my $x = 0} }++; my ($my_cols, $rel_cols) = {}; for ( keys %{$args->{val_index}} ) { if ($_ =~ /^ ([^\.]+) \. (.+) /x) { $rel_cols->{$1}{$2} = $args->{val_index}{$_}; } else { $my_cols->{$_} = $args->{val_index}{$_}; } } if ($args->{hri_style}) { delete $my_cols->{$_} for grep { $rel_cols->{$_} } keys %$my_cols; } my $me_struct; $me_struct = __result_struct_to_source($my_cols) if keys %$my_cols; $me_struct = sprintf( '[ %s ]', $me_struct||'' ) unless $args->{hri_style}; my $node_key = $args->{collapse_map}->{-custom_node_key} || join ('', map { "{'\xFF__IDVALPOS__${_}__\xFF'}" } @{$args->{collapse_map}->{-identifying_columns}} ); my $node_idx_slot = sprintf '$collapse_idx[%d]%s', $cur_node_idx, $node_key; my @src; if ($cur_node_idx == 0) { push @src, sprintf( '%s %s $_[0][$result_pos++] = %s;', $node_idx_slot, (HAS_DOR ? '//=' : '||='), $me_struct || '{}', ); } else { my $parent_attach_slot = sprintf( '$collapse_idx[%d]%s%s{%s}', @{$args}{qw/-parent_node_idx -parent_node_key/}, $args->{hri_style} ? '' : '[1]', perlstring($args->{-node_rel_name}), ); if ($args->{collapse_map}->{-is_single}) { push @src, sprintf ( '%s %s %s%s;', $parent_attach_slot, (HAS_DOR ? '//=' : '||='), $node_idx_slot, $me_struct ? " = $me_struct" : '', ); } else { push @src, sprintf('(! %s) and push @{%s}, %s%s;', $node_idx_slot, $parent_attach_slot, $node_idx_slot, $me_struct ? " = $me_struct" : '', ); } } my $known_present_ids = { map { $_ => 1 } @{$args->{collapse_map}{-identifying_columns}} }; my ($stats, $rel_src); for my $rel (sort keys %$rel_cols) { my $relinfo = $args->{collapse_map}{$rel}; ($rel_src, $stats->{$rel}) = __visit_infmap_collapse({ %$args, val_index => $rel_cols->{$rel}, collapse_map => $relinfo, -parent_node_idx => $cur_node_idx, -parent_node_key => $node_key, -node_rel_name => $rel, }); my $rel_src_pos = $#src + 1; push @src, @$rel_src; if ( $relinfo->{-is_optional} and scalar( my ($first_distinct_child_idcol) = grep { ! $known_present_ids->{$_} } @{$relinfo->{-identifying_columns}} ) ) { if ($args->{prune_null_branches}) { # start of wrap of the entire chain in a conditional splice @src, $rel_src_pos, 0, sprintf "( ! defined %s )\n ? %s%s{%s} = %s\n : do {", "'\xFF__VALPOS__${first_distinct_child_idcol}__\xFF'", $node_idx_slot, $args->{hri_style} ? '' : '[1]', perlstring($rel), ($args->{hri_style} && $relinfo->{-is_single}) ? 'undef' : '[]' ; # end of wrap push @src, '};' } else { splice @src, $rel_src_pos + 1, 0, sprintf ( '(defined %s) or bless (%s[1]{%s}, %s);', "'\xFF__VALPOS__${first_distinct_child_idcol}__\xFF'", $node_idx_slot, perlstring($rel), perlstring($null_branch_class), ); } } } return ( \@src, { idcols_seen => { ( map { %{ $_->{idcols_seen} } } values %$stats ), ( map { $_ => 1 } @{$args->{collapse_map}->{-identifying_columns}} ), } } ); } sub __result_struct_to_source { sprintf( '{ %s }', join (', ', map { sprintf "%s => '\xFF__VALPOS__%d__\xFF'", perlstring($_), $_[0]{$_} } sort keys %{$_[0]} )); } 1; DBIx-Class-0.082843/lib/DBIx/Class/ResultSource/View.pm0000644000175000017500000001115514240132261021411 0ustar rabbitrabbitpackage DBIx::Class::ResultSource::View; use strict; use warnings; use DBIx::Class::ResultSet; use base qw/DBIx::Class/; __PACKAGE__->load_components(qw/ResultSource/); __PACKAGE__->mk_group_accessors( 'simple' => qw(is_virtual view_definition deploy_depends_on) ); =head1 NAME DBIx::Class::ResultSource::View - ResultSource object representing a view =head1 SYNOPSIS package MyApp::Schema::Result::Year2000CDs; use base qw/DBIx::Class::Core/; __PACKAGE__->table_class('DBIx::Class::ResultSource::View'); __PACKAGE__->table('year2000cds'); __PACKAGE__->result_source_instance->is_virtual(1); __PACKAGE__->result_source_instance->view_definition( "SELECT cdid, artist, title FROM cd WHERE year ='2000'" ); __PACKAGE__->add_columns( 'cdid' => { data_type => 'integer', is_auto_increment => 1, }, 'artist' => { data_type => 'integer', }, 'title' => { data_type => 'varchar', size => 100, }, ); =head1 DESCRIPTION View object that inherits from L This class extends ResultSource to add basic view support. A view has a L, which contains a SQL query. The query can only have parameters if L is set to true. It may contain JOINs, sub selects and any other SQL your database supports. View definition SQL is deployed to your database on L unless you set L to true. Deploying the view does B translate it between different database syntaxes, so be careful what you write in your view SQL. Virtual views (L true), are assumed to not exist in your database as a real view. The L in this case replaces the view name in a FROM clause in a subselect. =head1 EXAMPLES Having created the MyApp::Schema::Year2000CDs schema as shown in the SYNOPSIS above, you can then: $2000_cds = $schema->resultset('Year2000CDs') ->search() ->all(); $count = $schema->resultset('Year2000CDs') ->search() ->count(); If you modified the schema to include a placeholder __PACKAGE__->result_source_instance->view_definition( "SELECT cdid, artist, title FROM cd WHERE year = ?" ); and ensuring you have is_virtual set to true: __PACKAGE__->result_source_instance->is_virtual(1); You could now say: $2001_cds = $schema->resultset('Year2000CDs') ->search({}, { bind => [2001] }) ->all(); $count = $schema->resultset('Year2000CDs') ->search({}, { bind => [2001] }) ->count(); =head1 SQL EXAMPLES =over =item is_virtual set to false $schema->resultset('Year2000CDs')->all(); SELECT cdid, artist, title FROM year2000cds me =item is_virtual set to true $schema->resultset('Year2000CDs')->all(); SELECT cdid, artist, title FROM (SELECT cdid, artist, title FROM cd WHERE year ='2000') me =back =head1 METHODS =head2 is_virtual __PACKAGE__->result_source_instance->is_virtual(1); Set to true for a virtual view, false or unset for a real database-based view. =head2 view_definition __PACKAGE__->result_source_instance->view_definition( "SELECT cdid, artist, title FROM cd WHERE year ='2000'" ); An SQL query for your view. Will not be translated across database syntaxes. =head2 deploy_depends_on __PACKAGE__->result_source_instance->deploy_depends_on( ["MyApp::Schema::Result::Year","MyApp::Schema::Result::CD"] ); Specify the views (and only the views) that this view depends on. Pass this an array reference of fully qualified result classes. =head1 OVERRIDDEN METHODS =head2 from Returns the FROM entry for the table (i.e. the view name) or the SQL as a subselect if this is a virtual view. =cut sub from { my $self = shift; return \"(${\$self->view_definition})" if $self->is_virtual; return $self->name; } =head1 OTHER METHODS =head2 new The constructor. =cut sub new { my ( $self, @args ) = @_; my $new = $self->next::method(@args); $new->{deploy_depends_on} = { map { $_ => 1 } @{ $new->{deploy_depends_on} || [] } } unless ref $new->{deploy_depends_on} eq 'HASH'; return $new; } =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. =cut 1; DBIx-Class-0.082843/lib/DBIx/Class/ResultSource/Table.pm0000644000175000017500000000154414240132261021527 0ustar rabbitrabbitpackage DBIx::Class::ResultSource::Table; use strict; use warnings; use DBIx::Class::ResultSet; use base qw/DBIx::Class/; __PACKAGE__->load_components(qw/ResultSource/); =head1 NAME DBIx::Class::ResultSource::Table - Table object =head1 SYNOPSIS =head1 DESCRIPTION Table object that inherits from L. =head1 METHODS =head2 from Returns the FROM entry for the table (i.e. the table name) =cut sub from { shift->name; } =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. =cut 1; DBIx-Class-0.082843/lib/DBIx/Class/ResultSource/RowParser.pm0000644000175000017500000003672614240132261022436 0ustar rabbitrabbitpackage # hide from the pauses DBIx::Class::ResultSource::RowParser; use strict; use warnings; use base 'DBIx::Class'; use Try::Tiny; use DBIx::Class::ResultSource::RowParser::Util qw( assemble_simple_parser assemble_collapsing_parser ); use namespace::clean; # Accepts one or more relationships for the current source and returns an # array of column names for each of those relationships. Column names are # prefixed relative to the current source, in accordance with where they appear # in the supplied relationships. sub _resolve_prefetch { my ($self, $pre, $alias, $alias_map, $order, $pref_path) = @_; $pref_path ||= []; if (not defined $pre or not length $pre) { return (); } elsif( ref $pre eq 'ARRAY' ) { return map { $self->_resolve_prefetch( $_, $alias, $alias_map, $order, [ @$pref_path ] ) } @$pre; } elsif( ref $pre eq 'HASH' ) { my @ret = map { $self->_resolve_prefetch($_, $alias, $alias_map, $order, [ @$pref_path ] ), $self->related_source($_)->_resolve_prefetch( $pre->{$_}, "${alias}.$_", $alias_map, $order, [ @$pref_path, $_] ) } keys %$pre; return @ret; } elsif( ref $pre ) { $self->throw_exception( "don't know how to resolve prefetch reftype ".ref($pre)); } else { my $p = $alias_map; $p = $p->{$_} for (@$pref_path, $pre); $self->throw_exception ( "Unable to resolve prefetch '$pre' - join alias map does not contain an entry for path: " . join (' -> ', @$pref_path, $pre) ) if (ref $p->{-join_aliases} ne 'ARRAY' or not @{$p->{-join_aliases}} ); my $as = shift @{$p->{-join_aliases}}; my $rel_info = $self->relationship_info( $pre ); $self->throw_exception( $self->source_name . " has no such relationship '$pre'" ) unless $rel_info; my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : ''); return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] } $self->related_source($pre)->columns; } } # Takes an arrayref of {as} dbic column aliases and the collapse and select # attributes from the same $rs (the selector requirement is a temporary # workaround... I hope), and returns a coderef capable of: # my $me_pref_clps = $coderef->([$rs->cursor->next/all]) # Where the $me_pref_clps arrayref is the future argument to inflate_result() # # For an example of this coderef in action (and to see its guts) look at # t/resultset/rowparser_internals.t # # This is a huge performance win, as we call the same code for every row # returned from the db, thus avoiding repeated method lookups when traversing # relationships # # Also since the coderef is completely stateless (the returned structure is # always fresh on every new invocation) this is a very good opportunity for # memoization if further speed improvements are needed # # The way we construct this coderef is somewhat fugly, although the result is # really worth it. The final coderef does not perform any kind of recursion - # the entire nested structure constructor is rolled out into a single scope. # # In any case - the output of this thing is meticulously micro-tested, so # any sort of adjustment/rewrite should be relatively easy (fsvo relatively) # sub _mk_row_parser { # $args and $attrs are separated to delineate what is core collapser stuff and # what is dbic $rs specific my ($self, $args, $attrs) = @_; die "HRI without pruning makes zero sense" if ( $args->{hri_style} && ! $args->{prune_null_branches} ); my %common = ( hri_style => $args->{hri_style}, prune_null_branches => $args->{prune_null_branches}, val_index => { map { $args->{inflate_map}[$_] => $_ } ( 0 .. $#{$args->{inflate_map}} ) }, ); my $check_null_columns; my $src = (! $args->{collapse} ) ? assemble_simple_parser(\%common) : do { my $collapse_map = $self->_resolve_collapse ({ # FIXME # only consider real columns (not functions) during collapse resolution # this check shouldn't really be here, as fucktards are not supposed to # alias random crap to existing column names anyway, but still - just in # case # FIXME !!!! - this does not yet deal with unbalanced selectors correctly # (it is now trivial as the attrs specify where things go out of sync # needs MOAR tests) as => { map { ref $attrs->{select}[$common{val_index}{$_}] ? () : ( $_ => $common{val_index}{$_} ) } keys %{$common{val_index}} }, premultiplied => $args->{premultiplied}, }); $check_null_columns = $collapse_map->{-identifying_columns} if @{$collapse_map->{-identifying_columns}}; assemble_collapsing_parser({ %common, collapse_map => $collapse_map, }); }; utf8::upgrade($src) if DBIx::Class::_ENV_::STRESSTEST_UTF8_UPGRADE_GENERATED_COLLAPSER_SOURCE; return ( $args->{eval} ? ( eval "sub $src" || die $@ ) : $src, $check_null_columns, ); } # Takes an arrayref selection list and generates a collapse-map representing # row-object fold-points. Every relationship is assigned a set of unique, # non-nullable columns (which may *not even be* from the same resultset) # and the collapser will use this information to correctly distinguish # data of individual to-be-row-objects. See t/resultset/rowparser_internals.t # for extensive RV examples sub _resolve_collapse { my ($self, $args, $common_args) = @_; # for comprehensible error messages put ourselves at the head of the relationship chain $args->{_rel_chain} ||= [ $self->source_name ]; # record top-level fully-qualified column index, signify toplevelness unless ($common_args->{_as_fq_idx}) { $common_args->{_as_fq_idx} = { %{$args->{as}} }; $args->{_is_top_level} = 1; }; my ($my_cols, $rel_cols); for (keys %{$args->{as}}) { if ($_ =~ /^ ([^\.]+) \. (.+) /x) { $rel_cols->{$1}{$2} = 1; } else { $my_cols->{$_} = {}; # important for ||='s below } } my $relinfo; # run through relationships, collect metadata for my $rel (keys %$rel_cols) { my $inf = $self->relationship_info ($rel); $relinfo->{$rel} = { is_single => ( $inf->{attrs}{accessor} && $inf->{attrs}{accessor} ne 'multi' ), is_inner => ( ( $inf->{attrs}{join_type} || '' ) !~ /^left/i), rsrc => $self->related_source($rel), }; # FIME - need to use _resolve_cond here instead my $cond = $inf->{cond}; if ( ref $cond eq 'HASH' and keys %$cond and ! grep { $_ !~ /^foreign\./ } (keys %$cond) and ! grep { $_ !~ /^self\./ } (values %$cond) ) { for my $f (keys %$cond) { my $s = $cond->{$f}; $_ =~ s/^ (?: foreign | self ) \.//x for ($f, $s); $relinfo->{$rel}{fk_map}{$s} = $f; } } } # inject non-left fk-bridges from *INNER-JOINED* children (if any) for my $rel (grep { $relinfo->{$_}{is_inner} } keys %$relinfo) { my $ri = $relinfo->{$rel}; for (keys %{$ri->{fk_map}} ) { # need to know source from *our* pov, hence $rel.col $my_cols->{$_} ||= { via_fk => "$rel.$ri->{fk_map}{$_}" } if defined $rel_cols->{$rel}{$ri->{fk_map}{$_}} # in fact selected } } # if the parent is already defined *AND* we have an inner reverse relationship # (i.e. do not exist without it) , assume all of its related FKs are selected # (even if they in fact are NOT in the select list). Keep a record of what we # assumed, and if any such phantom-column becomes part of our own collapser, # throw everything assumed-from-parent away and replace with the collapser of # the parent (whatever it may be) my $assumed_from_parent; if ( ! $args->{_parent_info}{underdefined} and ! $args->{_parent_info}{rev_rel_is_optional} ) { for my $col ( values %{$args->{_parent_info}{rel_condition} || {}} ) { next if exists $my_cols->{$col}; $my_cols->{$col} = { via_collapse => $args->{_parent_info}{collapse_on_idcols} }; $assumed_from_parent->{columns}{$col}++; } } # get colinfo for everything if ($my_cols) { my $ci = $self->columns_info; $my_cols->{$_}{colinfo} = $ci->{$_} for keys %$my_cols; } my $collapse_map; # first try to reuse the parent's collapser (i.e. reuse collapser over 1:1) # (makes for a leaner coderef later) unless ($collapse_map->{-identifying_columns}) { $collapse_map->{-identifying_columns} = $args->{_parent_info}{collapse_on_idcols} if $args->{_parent_info}{collapser_reusable}; } # Still don't know how to collapse - try to resolve based on our columns (plus already inserted FK bridges) if ( ! $collapse_map->{-identifying_columns} and $my_cols and my $idset = $self->_identifying_column_set ({map { $_ => $my_cols->{$_}{colinfo} } keys %$my_cols}) ) { # see if the resulting collapser relies on any implied columns, # and fix stuff up if this is the case my @reduced_set = grep { ! $assumed_from_parent->{columns}{$_} } @$idset; $collapse_map->{-identifying_columns} = [ __unique_numlist( @{ $args->{_parent_info}{collapse_on_idcols}||[] }, (map { my $fqc = join ('.', @{$args->{_rel_chain}}[1 .. $#{$args->{_rel_chain}}], ( $my_cols->{$_}{via_fk} || $_ ), ); $common_args->{_as_fq_idx}->{$fqc}; } @reduced_set ), )]; } # Stil don't know how to collapse - keep descending down 1:1 chains - if # a related non-LEFT 1:1 is resolvable - its condition will collapse us # too unless ($collapse_map->{-identifying_columns}) { my @candidates; for my $rel (keys %$relinfo) { next unless ($relinfo->{$rel}{is_single} && $relinfo->{$rel}{is_inner}); if ( my $rel_collapse = $relinfo->{$rel}{rsrc}->_resolve_collapse ({ as => $rel_cols->{$rel}, _rel_chain => [ @{$args->{_rel_chain}}, $rel ], _parent_info => { underdefined => 1 }, }, $common_args)) { push @candidates, $rel_collapse->{-identifying_columns}; } } # get the set with least amount of columns # FIXME - maybe need to implement a data type order as well (i.e. prefer several ints # to a single varchar) if (@candidates) { ($collapse_map->{-identifying_columns}) = sort { scalar @$a <=> scalar @$b } (@candidates); } } # Stil don't know how to collapse, and we are the root node. Last ditch # effort in case we are *NOT* premultiplied. # Run through *each multi* all the way down, left or not, and all # *left* singles (a single may become a multi underneath) . When everything # gets back see if all the rels link to us definitively. If this is the # case we are good - either one of them will define us, or if all are NULLs # we know we are "unique" due to the "non-premultiplied" check if ( ! $collapse_map->{-identifying_columns} and ! $args->{premultiplied} and $args->{_is_top_level} ) { my (@collapse_sets, $uncollapsible_chain); for my $rel (keys %$relinfo) { # we already looked at these higher up next if ($relinfo->{$rel}{is_single} && $relinfo->{$rel}{is_inner}); if (my $clps = $relinfo->{$rel}{rsrc}->_resolve_collapse ({ as => $rel_cols->{$rel}, _rel_chain => [ @{$args->{_rel_chain}}, $rel ], _parent_info => { underdefined => 1 }, }, $common_args) ) { # for singles use the idcols wholesale (either there or not) if ($relinfo->{$rel}{is_single}) { push @collapse_sets, $clps->{-identifying_columns}; } elsif (! $relinfo->{$rel}{fk_map}) { $uncollapsible_chain = 1; last; } else { my $defined_cols_parent_side; for my $fq_col ( grep { /^$rel\.[^\.]+$/ } keys %{$args->{as}} ) { my ($col) = $fq_col =~ /([^\.]+)$/; $defined_cols_parent_side->{$_} = $args->{as}{$fq_col} for grep { $relinfo->{$rel}{fk_map}{$_} eq $col } keys %{$relinfo->{$rel}{fk_map}} ; } if (my $set = $self->_identifying_column_set([ keys %$defined_cols_parent_side ]) ) { push @collapse_sets, [ sort map { $defined_cols_parent_side->{$_} } @$set ]; } else { $uncollapsible_chain = 1; last; } } } else { $uncollapsible_chain = 1; last; } } unless ($uncollapsible_chain) { # if we got here - we are good to go, but the construction is tricky # since our children will want to include our collapse criteria - we # don't give them anything (safe, since they are all collapsible on their own) # in addition we record the individual collapse possibilities # of all left children node collapsers, and merge them in the rowparser # coderef later $collapse_map->{-identifying_columns} = []; $collapse_map->{-identifying_columns_variants} = [ sort { (scalar @$a) <=> (scalar @$b) or ( # Poor man's max() ( sort { $b <=> $a } @$a )[0] <=> ( sort { $b <=> $a } @$b )[0] ) } @collapse_sets ]; } } # stop descending into children if we were called by a parent for first-pass # and don't despair if nothing was found (there may be other parallel branches # to dive into) if ($args->{_parent_info}{underdefined}) { return $collapse_map->{-identifying_columns} ? $collapse_map : undef } # nothing down the chain resolved - can't calculate a collapse-map elsif (! $collapse_map->{-identifying_columns}) { $self->throw_exception ( sprintf "Unable to calculate a definitive collapse column set for %s%s: fetch more unique non-nullable columns", $self->source_name, @{$args->{_rel_chain}} > 1 ? sprintf (' (last member of the %s chain)', join ' -> ', @{$args->{_rel_chain}} ) : '' , ); } # If we got that far - we are collapsable - GREAT! Now go down all children # a second time, and fill in the rest $collapse_map->{-identifying_columns} = [ __unique_numlist( @{ $args->{_parent_info}{collapse_on_idcols}||[] }, @{ $collapse_map->{-identifying_columns} }, )]; my @id_sets; for my $rel (sort keys %$relinfo) { $collapse_map->{$rel} = $relinfo->{$rel}{rsrc}->_resolve_collapse ({ as => { map { $_ => 1 } ( keys %{$rel_cols->{$rel}} ) }, _rel_chain => [ @{$args->{_rel_chain}}, $rel], _parent_info => { # shallow copy collapse_on_idcols => [ @{$collapse_map->{-identifying_columns}} ], rel_condition => $relinfo->{$rel}{fk_map}, is_optional => ! $relinfo->{$rel}{is_inner}, # if there is at least one *inner* reverse relationship which is HASH-based (equality only) # we can safely assume that the child can not exist without us rev_rel_is_optional => ( grep { ref $_->{cond} eq 'HASH' and ($_->{attrs}{join_type}||'') !~ /^left/i } values %{ $self->reverse_relationship_info($rel) }, ) ? 0 : 1, # if this is a 1:1 our own collapser can be used as a collapse-map # (regardless of left or not) collapser_reusable => ( $relinfo->{$rel}{is_single} && $relinfo->{$rel}{is_inner} && @{$collapse_map->{-identifying_columns}} ) ? 1 : 0, }, }, $common_args ); $collapse_map->{$rel}{-is_single} = 1 if $relinfo->{$rel}{is_single}; $collapse_map->{$rel}{-is_optional} ||= 1 unless $relinfo->{$rel}{is_inner}; } return $collapse_map; } # adding a dep on MoreUtils *just* for this is retarded sub __unique_numlist { sort { $a <=> $b } keys %{ {map { $_ => 1 } @_ }} } 1; DBIx-Class-0.082843/lib/DBIx/Class/ResultSourceProxy/0000755000175000017500000000000014240676463021221 5ustar rabbitrabbitDBIx-Class-0.082843/lib/DBIx/Class/ResultSourceProxy/Table.pm0000644000175000017500000000655114240132261022574 0ustar rabbitrabbitpackage DBIx::Class::ResultSourceProxy::Table; use strict; use warnings; use base qw/DBIx::Class::ResultSourceProxy/; use DBIx::Class::ResultSource::Table; use Scalar::Util 'blessed'; use namespace::clean; __PACKAGE__->mk_classdata(table_class => 'DBIx::Class::ResultSource::Table'); __PACKAGE__->mk_classdata('table_alias'); # FIXME: Doesn't actually do # anything yet! sub _init_result_source_instance { my $class = shift; $class->mk_classdata('result_source_instance') unless $class->can('result_source_instance'); my $table = $class->result_source_instance; my $class_has_table_instance = ($table and $table->result_class eq $class); return $table if $class_has_table_instance; my $table_class = $class->table_class; $class->ensure_class_loaded($table_class); if( $table ) { $table = $table_class->new({ %$table, result_class => $class, source_name => undef, schema => undef }); } else { $table = $table_class->new({ name => undef, result_class => $class, source_name => undef, }); } $class->result_source_instance($table); return $table; } =head1 NAME DBIx::Class::ResultSourceProxy::Table - provides a classdata table object and method proxies =head1 SYNOPSIS __PACKAGE__->table('cd'); __PACKAGE__->add_columns(qw/cdid artist title year/); __PACKAGE__->set_primary_key('cdid'); =head1 METHODS =head2 add_columns __PACKAGE__->add_columns(qw/cdid artist title year/); Adds columns to the current class and creates accessors for them. =cut =head2 table __PACKAGE__->table('tbl_name'); Gets or sets the table name. =cut sub table { my ($class, $table) = @_; return $class->result_source_instance->name unless $table; unless (blessed $table && $table->isa($class->table_class)) { my $table_class = $class->table_class; $class->ensure_class_loaded($table_class); $table = $table_class->new({ $class->can('result_source_instance') ? %{$class->result_source_instance||{}} : () , name => $table, result_class => $class, }); } $class->mk_classdata('result_source_instance') unless $class->can('result_source_instance'); $class->result_source_instance($table); return $class->result_source_instance->name; } =head2 table_class __PACKAGE__->table_class('DBIx::Class::ResultSource::Table'); Gets or sets the table class used for construction and validation. =head2 has_column if ($obj->has_column($col)) { ... } Returns 1 if the class has a column of this name, 0 otherwise. =head2 column_info my $info = $obj->column_info($col); Returns the column metadata hashref for a column. For a description of the various types of column data in this hashref, see L =head2 columns my @column_names = $obj->columns; =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. =cut 1; DBIx-Class-0.082843/lib/DBIx/Class/ResultSourceProxy/Table.pod0000444000175000017500000000671714240676410022755 0ustar rabbitrabbit=for comment POD_DERIVED_INDEX_GENERATED The following documentation is automatically generated. Please do not edit this file, but rather the original, inline with DBIx::Class::ResultSourceProxy::Table at lib/DBIx/Class/ResultSourceProxy/Table.pm (on the system that originally ran this). If you do edit this file, and don't want your changes to be removed, make sure you change the first line. =cut =head1 NAME DBIx::Class::ResultSourceProxy::Table - provides a classdata table object and method proxies =head1 SYNOPSIS __PACKAGE__->table('cd'); __PACKAGE__->add_columns(qw/cdid artist title year/); __PACKAGE__->set_primary_key('cdid'); =head1 METHODS =head2 add_columns __PACKAGE__->add_columns(qw/cdid artist title year/); Adds columns to the current class and creates accessors for them. =head2 table __PACKAGE__->table('tbl_name'); Gets or sets the table name. =head2 table_class __PACKAGE__->table_class('DBIx::Class::ResultSource::Table'); Gets or sets the table class used for construction and validation. =head2 has_column if ($obj->has_column($col)) { ... } Returns 1 if the class has a column of this name, 0 otherwise. =head2 column_info my $info = $obj->column_info($col); Returns the column metadata hashref for a column. For a description of the various types of column data in this hashref, see L =head2 columns my @column_names = $obj->columns; =head1 INHERITED METHODS =over 4 =item L L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L =back =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. DBIx-Class-0.082843/lib/DBIx/Class/Schema.pm0000644000175000017500000012462414240132261017246 0ustar rabbitrabbitpackage DBIx::Class::Schema; use strict; use warnings; use base 'DBIx::Class'; use DBIx::Class::Carp; use Try::Tiny; use Scalar::Util qw/weaken blessed/; use DBIx::Class::_Util qw(refcount quote_sub is_exception scope_guard); use Devel::GlobalDestruction; use namespace::clean; __PACKAGE__->mk_classdata('class_mappings' => {}); __PACKAGE__->mk_classdata('source_registrations' => {}); __PACKAGE__->mk_classdata('storage_type' => '::DBI'); __PACKAGE__->mk_classdata('storage'); __PACKAGE__->mk_classdata('exception_action'); __PACKAGE__->mk_classdata('stacktrace' => $ENV{DBIC_TRACE} || 0); __PACKAGE__->mk_classdata('default_resultset_attributes' => {}); =head1 NAME DBIx::Class::Schema - composable schemas =head1 SYNOPSIS package Library::Schema; use base qw/DBIx::Class::Schema/; # load all Result classes in Library/Schema/Result/ __PACKAGE__->load_namespaces(); package Library::Schema::Result::CD; use base qw/DBIx::Class::Core/; __PACKAGE__->load_components(qw/InflateColumn::DateTime/); # for example __PACKAGE__->table('cd'); # Elsewhere in your code: my $schema1 = Library::Schema->connect( $dsn, $user, $password, { AutoCommit => 1 }, ); my $schema2 = Library::Schema->connect($coderef_returning_dbh); # fetch objects using Library::Schema::Result::DVD my $resultset = $schema1->resultset('DVD')->search( ... ); my @dvd_objects = $schema2->resultset('DVD')->search( ... ); =head1 DESCRIPTION Creates database classes based on a schema. This is the recommended way to use L and allows you to use more than one concurrent connection with your classes. NB: If you're used to L it's worth reading the L carefully, as DBIx::Class does things a little differently. Note in particular which module inherits off which. =head1 SETUP METHODS =head2 load_namespaces =over 4 =item Arguments: %options? =back package MyApp::Schema; __PACKAGE__->load_namespaces(); __PACKAGE__->load_namespaces( result_namespace => 'Res', resultset_namespace => 'RSet', default_resultset_class => '+MyApp::Othernamespace::RSet', ); With no arguments, this method uses L to load all of the Result and ResultSet classes under the namespace of the schema from which it is called. For example, C will by default find and load Result classes named C and ResultSet classes named C. ResultSet classes are associated with Result class of the same name. For example, C will get the ResultSet class C if it is present. Both Result and ResultSet namespaces are configurable via the C and C options. Another option, C specifies a custom default ResultSet class for Result classes with no corresponding ResultSet. All of the namespace and classname options are by default relative to the schema classname. To specify a fully-qualified name, prefix it with a literal C<+>. For example, C<+Other::NameSpace::Result>. =head3 Warnings You will be warned if ResultSet classes are discovered for which there are no matching Result classes like this: load_namespaces found ResultSet class $classname with no corresponding Result class If a ResultSource instance is found to already have a ResultSet class set using L to some other class, you will be warned like this: We found ResultSet class '$rs_class' for '$result_class', but it seems that you had already set '$result_class' to use '$rs_set' instead =head3 Examples # load My::Schema::Result::CD, My::Schema::Result::Artist, # My::Schema::ResultSet::CD, etc... My::Schema->load_namespaces; # Override everything to use ugly names. # In this example, if there is a My::Schema::Res::Foo, but no matching # My::Schema::RSets::Foo, then Foo will have its # resultset_class set to My::Schema::RSetBase My::Schema->load_namespaces( result_namespace => 'Res', resultset_namespace => 'RSets', default_resultset_class => 'RSetBase', ); # Put things in other namespaces My::Schema->load_namespaces( result_namespace => '+Some::Place::Results', resultset_namespace => '+Another::Place::RSets', ); To search multiple namespaces for either Result or ResultSet classes, use an arrayref of namespaces for that option. In the case that the same result (or resultset) class exists in multiple namespaces, later entries in the list of namespaces will override earlier ones. My::Schema->load_namespaces( # My::Schema::Results_C::Foo takes precedence over My::Schema::Results_B::Foo : result_namespace => [ 'Results_A', 'Results_B', 'Results_C' ], resultset_namespace => [ '+Some::Place::RSets', 'RSets' ], ); =cut # Pre-pends our classname to the given relative classname or # class namespace, unless there is a '+' prefix, which will # be stripped. sub _expand_relative_name { my ($class, $name) = @_; $name =~ s/^\+// or $name = "${class}::${name}"; return $name; } # Finds all modules in the supplied namespace, or if omitted in the # namespace of $class. Untaints all findings as they can be assumed # to be safe sub _findallmod { require Module::Find; return map { $_ =~ /(.+)/ } # untaint result Module::Find::findallmod( $_[1] || ref $_[0] || $_[0] ) ; } # returns a hash of $shortname => $fullname for every package # found in the given namespaces ($shortname is with the $fullname's # namespace stripped off) sub _map_namespaces { my ($me, $namespaces) = @_; my %res; for my $ns (@$namespaces) { $res{ substr($_, length "${ns}::") } = $_ for $me->_findallmod($ns); } \%res; } # returns the result_source_instance for the passed class/object, # or dies with an informative message (used by load_namespaces) sub _ns_get_rsrc_instance { my $me = shift; my $rs_class = ref ($_[0]) || $_[0]; return try { $rs_class->result_source_instance } catch { $me->throw_exception ( "Attempt to load_namespaces() class $rs_class failed - are you sure this is a real Result Class?: $_" ); }; } sub load_namespaces { my ($class, %args) = @_; my $result_namespace = delete $args{result_namespace} || 'Result'; my $resultset_namespace = delete $args{resultset_namespace} || 'ResultSet'; my $default_resultset_class = delete $args{default_resultset_class}; $default_resultset_class = $class->_expand_relative_name($default_resultset_class) if $default_resultset_class; $class->throw_exception('load_namespaces: unknown option(s): ' . join(q{,}, map { qq{'$_'} } keys %args)) if scalar keys %args; for my $arg ($result_namespace, $resultset_namespace) { $arg = [ $arg ] if ( $arg and ! ref $arg ); $class->throw_exception('load_namespaces: namespace arguments must be ' . 'a simple string or an arrayref') if ref($arg) ne 'ARRAY'; $_ = $class->_expand_relative_name($_) for (@$arg); } my $results_by_source_name = $class->_map_namespaces($result_namespace); my $resultsets_by_source_name = $class->_map_namespaces($resultset_namespace); my @to_register; { no warnings qw/redefine/; local *Class::C3::reinitialize = sub { } if DBIx::Class::_ENV_::OLD_MRO; use warnings qw/redefine/; # ensure classes are loaded and attached in inheritance order for my $result_class (values %$results_by_source_name) { $class->ensure_class_loaded($result_class); } my %inh_idx; my @source_names_by_subclass_last = sort { ($inh_idx{$a} ||= scalar @{mro::get_linear_isa( $results_by_source_name->{$a} )} ) <=> ($inh_idx{$b} ||= scalar @{mro::get_linear_isa( $results_by_source_name->{$b} )} ) } keys(%$results_by_source_name); foreach my $source_name (@source_names_by_subclass_last) { my $result_class = $results_by_source_name->{$source_name}; my $preset_resultset_class = $class->_ns_get_rsrc_instance ($result_class)->resultset_class; my $found_resultset_class = delete $resultsets_by_source_name->{$source_name}; if($preset_resultset_class && $preset_resultset_class ne 'DBIx::Class::ResultSet') { if($found_resultset_class && $found_resultset_class ne $preset_resultset_class) { carp "We found ResultSet class '$found_resultset_class' matching '$results_by_source_name->{$source_name}', but it seems " . "that you had already set the '$results_by_source_name->{$source_name}' resultet to '$preset_resultset_class' instead"; } } # elsif - there may be *no* default_resultset_class, in which case we fallback to # DBIx::Class::Resultset and there is nothing to check elsif($found_resultset_class ||= $default_resultset_class) { $class->ensure_class_loaded($found_resultset_class); if(!$found_resultset_class->isa("DBIx::Class::ResultSet")) { carp "load_namespaces found ResultSet class '$found_resultset_class' that does not subclass DBIx::Class::ResultSet"; } $class->_ns_get_rsrc_instance ($result_class)->resultset_class($found_resultset_class); } my $source_name = $class->_ns_get_rsrc_instance ($result_class)->source_name || $source_name; push(@to_register, [ $source_name, $result_class ]); } } foreach (sort keys %$resultsets_by_source_name) { carp "load_namespaces found ResultSet class '$resultsets_by_source_name->{$_}' " .'with no corresponding Result class'; } Class::C3->reinitialize if DBIx::Class::_ENV_::OLD_MRO; $class->register_class(@$_) for (@to_register); return; } =head2 load_classes =over 4 =item Arguments: @classes?, { $namespace => [ @classes ] }+ =back L is an alternative method to L, both of which serve similar purposes, each with different advantages and disadvantages. In the general case you should use L, unless you need to be able to specify that only specific classes are loaded at runtime. With no arguments, this method uses L to find all classes under the schema's namespace. Otherwise, this method loads the classes you specify (using L), and registers them (using L). It is possible to comment out classes with a leading C<#>, but note that perl will think it's a mistake (trying to use a comment in a qw list), so you'll need to add C before your load_classes call. If any classes found do not appear to be Result class files, you will get the following warning: Failed to load $comp_class. Can't find source_name method. Is $comp_class really a full DBIC result class? Fix it, move it elsewhere, or make your load_classes call more specific. Example: My::Schema->load_classes(); # loads My::Schema::CD, My::Schema::Artist, # etc. (anything under the My::Schema namespace) # loads My::Schema::CD, My::Schema::Artist, Other::Namespace::Producer but # not Other::Namespace::LinerNotes nor My::Schema::Track My::Schema->load_classes(qw/ CD Artist #Track /, { Other::Namespace => [qw/ Producer #LinerNotes /], }); =cut sub load_classes { my ($class, @params) = @_; my %comps_for; if (@params) { foreach my $param (@params) { if (ref $param eq 'ARRAY') { # filter out commented entries my @modules = grep { $_ !~ /^#/ } @$param; push (@{$comps_for{$class}}, @modules); } elsif (ref $param eq 'HASH') { # more than one namespace possible for my $comp ( keys %$param ) { # filter out commented entries my @modules = grep { $_ !~ /^#/ } @{$param->{$comp}}; push (@{$comps_for{$comp}}, @modules); } } else { # filter out commented entries push (@{$comps_for{$class}}, $param) if $param !~ /^#/; } } } else { my @comp = map { substr $_, length "${class}::" } $class->_findallmod($class); $comps_for{$class} = \@comp; } my @to_register; { no warnings qw/redefine/; local *Class::C3::reinitialize = sub { } if DBIx::Class::_ENV_::OLD_MRO; use warnings qw/redefine/; foreach my $prefix (keys %comps_for) { foreach my $comp (@{$comps_for{$prefix}||[]}) { my $comp_class = "${prefix}::${comp}"; $class->ensure_class_loaded($comp_class); my $snsub = $comp_class->can('source_name'); if(! $snsub ) { carp "Failed to load $comp_class. Can't find source_name method. Is $comp_class really a full DBIC result class? Fix it, move it elsewhere, or make your load_classes call more specific."; next; } $comp = $snsub->($comp_class) || $comp; push(@to_register, [ $comp, $comp_class ]); } } } Class::C3->reinitialize if DBIx::Class::_ENV_::OLD_MRO; foreach my $to (@to_register) { $class->register_class(@$to); } } =head2 storage_type =over 4 =item Arguments: $storage_type|{$storage_type, \%args} =item Return Value: $storage_type|{$storage_type, \%args} =item Default value: DBIx::Class::Storage::DBI =back Set the storage class that will be instantiated when L is called. If the classname starts with C<::>, the prefix C is assumed by L. You want to use this to set subclasses of L in cases where the appropriate subclass is not autodetected. If your storage type requires instantiation arguments, those are defined as a second argument in the form of a hashref and the entire value needs to be wrapped into an arrayref or a hashref. We support both types of refs here in order to play nice with your Config::[class] or your choice. See L for an example of this. =head2 exception_action =over 4 =item Arguments: $code_reference =item Return Value: $code_reference =item Default value: None =back When L is invoked and L is set to a code reference, this reference will be called instead of L, with the exception message passed as the only argument. Your custom throw code B rethrow the exception, as L is an integral part of DBIC's internal execution control flow. Example: package My::Schema; use base qw/DBIx::Class::Schema/; use My::ExceptionClass; __PACKAGE__->exception_action(sub { My::ExceptionClass->throw(@_) }); __PACKAGE__->load_classes; # or: my $schema_obj = My::Schema->connect( .... ); $schema_obj->exception_action(sub { My::ExceptionClass->throw(@_) }); =head2 stacktrace =over 4 =item Arguments: boolean =back Whether L should include stack trace information. Defaults to false normally, but defaults to true if C<$ENV{DBIC_TRACE}> is true. =head2 sqlt_deploy_hook =over =item Arguments: $sqlt_schema =back An optional sub which you can declare in your own Schema class that will get passed the L object when you deploy the schema via L or L. For an example of what you can do with this, see L. Note that sqlt_deploy_hook is called by L, which in turn is called before L. Therefore the hook can be used only to manipulate the L object before it is turned into SQL fed to the database. If you want to execute post-deploy statements which can not be generated by L, the currently suggested method is to overload L and use L. =head1 METHODS =head2 connect =over 4 =item Arguments: @connectinfo =item Return Value: $new_schema =back Creates and returns a new Schema object. The connection info set on it is used to create a new instance of the storage backend and set it on the Schema object. See L for DBI-specific syntax on the C<@connectinfo> argument, or L in general. Note that C expects an arrayref of arguments, but C does not. C wraps its arguments in an arrayref before passing them to C. =head3 Overloading C is a convenience method. It is equivalent to calling $schema->clone->connection(@connectinfo). To write your own overloaded version, overload L instead. =cut sub connect { shift->clone->connection(@_) } =head2 resultset =over 4 =item Arguments: L<$source_name|DBIx::Class::ResultSource/source_name> =item Return Value: L<$resultset|DBIx::Class::ResultSet> =back my $rs = $schema->resultset('DVD'); Returns the L object for the registered source name. =cut sub resultset { my ($self, $source_name) = @_; $self->throw_exception('resultset() expects a source name') unless defined $source_name; return $self->source($source_name)->resultset; } =head2 sources =over 4 =item Return Value: L<@source_names|DBIx::Class::ResultSource/source_name> =back my @source_names = $schema->sources; Lists names of all the sources registered on this Schema object. =cut sub sources { keys %{shift->source_registrations} } =head2 source =over 4 =item Arguments: L<$source_name|DBIx::Class::ResultSource/source_name> =item Return Value: L<$result_source|DBIx::Class::ResultSource> =back my $source = $schema->source('Book'); Returns the L object for the registered source name. =cut sub source { my $self = shift; $self->throw_exception("source() expects a source name") unless @_; my $source_name = shift; my $sreg = $self->source_registrations; return $sreg->{$source_name} if exists $sreg->{$source_name}; # if we got here, they probably passed a full class name my $mapped = $self->class_mappings->{$source_name}; $self->throw_exception("Can't find source for ${source_name}") unless $mapped && exists $sreg->{$mapped}; return $sreg->{$mapped}; } =head2 class =over 4 =item Arguments: L<$source_name|DBIx::Class::ResultSource/source_name> =item Return Value: $classname =back my $class = $schema->class('CD'); Retrieves the Result class name for the given source name. =cut sub class { return shift->source(shift)->result_class; } =head2 txn_do =over 4 =item Arguments: C<$coderef>, @coderef_args? =item Return Value: The return value of $coderef =back Executes C<$coderef> with (optional) arguments C<@coderef_args> atomically, returning its result (if any). Equivalent to calling $schema->storage->txn_do. See L for more information. This interface is preferred over using the individual methods L, L, and L below. WARNING: If you are connected with C<< AutoCommit => 0 >> the transaction is considered nested, and you will still need to call L to write your changes when appropriate. You will also want to connect with C<< auto_savepoint => 1 >> to get partial rollback to work, if the storage driver for your database supports it. Connecting with C<< AutoCommit => 1 >> is recommended. =cut sub txn_do { my $self = shift; $self->storage or $self->throw_exception ('txn_do called on $schema without storage'); $self->storage->txn_do(@_); } =head2 txn_scope_guard Runs C on the schema's storage. See L. =cut sub txn_scope_guard { my $self = shift; $self->storage or $self->throw_exception ('txn_scope_guard called on $schema without storage'); $self->storage->txn_scope_guard(@_); } =head2 txn_begin Begins a transaction (does nothing if AutoCommit is off). Equivalent to calling $schema->storage->txn_begin. See L for more information. =cut sub txn_begin { my $self = shift; $self->storage or $self->throw_exception ('txn_begin called on $schema without storage'); $self->storage->txn_begin; } =head2 txn_commit Commits the current transaction. Equivalent to calling $schema->storage->txn_commit. See L for more information. =cut sub txn_commit { my $self = shift; $self->storage or $self->throw_exception ('txn_commit called on $schema without storage'); $self->storage->txn_commit; } =head2 txn_rollback Rolls back the current transaction. Equivalent to calling $schema->storage->txn_rollback. See L for more information. =cut sub txn_rollback { my $self = shift; $self->storage or $self->throw_exception ('txn_rollback called on $schema without storage'); $self->storage->txn_rollback; } =head2 storage my $storage = $schema->storage; Returns the L object for this Schema. Grab this if you want to turn on SQL statement debugging at runtime, or set the quote character. For the default storage, the documentation can be found in L. =head2 populate =over 4 =item Arguments: L<$source_name|DBIx::Class::ResultSource/source_name>, [ \@column_list, \@row_values+ ] | [ \%col_data+ ] =item Return Value: L<\@result_objects|DBIx::Class::Manual::ResultClass> (scalar context) | L<@result_objects|DBIx::Class::Manual::ResultClass> (list context) =back A convenience shortcut to L. Equivalent to: $schema->resultset($source_name)->populate([...]); =over 4 =item NOTE The context of this method call has an important effect on what is submitted to storage. In void context data is fed directly to fastpath insertion routines provided by the underlying storage (most often L), bypassing the L and L calls on the L class, including any augmentation of these methods provided by components. For example if you are using something like L to create primary keys for you, you will find that your PKs are empty. In this case you will have to explicitly force scalar or list context in order to create those values. =back =cut sub populate { my ($self, $name, $data) = @_; my $rs = $self->resultset($name) or $self->throw_exception("'$name' is not a resultset"); return $rs->populate($data); } =head2 connection =over 4 =item Arguments: @args =item Return Value: $new_schema =back Similar to L except sets the storage object and connection data in-place on the Schema class. You should probably be calling L to get a proper Schema object instead. =head3 Overloading Overload C to change the behaviour of C. =cut sub connection { my ($self, @info) = @_; return $self if !@info && $self->storage; my ($storage_class, $args) = ref $self->storage_type ? $self->_normalize_storage_type($self->storage_type) : $self->storage_type ; $storage_class =~ s/^::/DBIx::Class::Storage::/; try { $self->ensure_class_loaded ($storage_class); } catch { $self->throw_exception( "Unable to load storage class ${storage_class}: $_" ); }; my $storage = $storage_class->new( $self => $args||{} ); $storage->connect_info(\@info); $self->storage($storage); return $self; } sub _normalize_storage_type { my ($self, $storage_type) = @_; if(ref $storage_type eq 'ARRAY') { return @$storage_type; } elsif(ref $storage_type eq 'HASH') { return %$storage_type; } else { $self->throw_exception('Unsupported REFTYPE given: '. ref $storage_type); } } =head2 compose_namespace =over 4 =item Arguments: $target_namespace, $additional_base_class? =item Return Value: $new_schema =back For each L in the schema, this method creates a class in the target namespace (e.g. $target_namespace::CD, $target_namespace::Artist) that inherits from the corresponding classes attached to the current schema. It also attaches a corresponding L object to the new $schema object. If C<$additional_base_class> is given, the new composed classes will inherit from first the corresponding class from the current schema then the base class. For example, for a schema with My::Schema::CD and My::Schema::Artist classes, $schema->compose_namespace('My::DB', 'Base::Class'); print join (', ', @My::DB::CD::ISA) . "\n"; print join (', ', @My::DB::Artist::ISA) ."\n"; will produce the output My::Schema::CD, Base::Class My::Schema::Artist, Base::Class =cut # this might be oversimplified # sub compose_namespace { # my ($self, $target, $base) = @_; # my $schema = $self->clone; # foreach my $source_name ($schema->sources) { # my $source = $schema->source($source_name); # my $target_class = "${target}::${source_name}"; # $self->inject_base( # $target_class => $source->result_class, ($base ? $base : ()) # ); # $source->result_class($target_class); # $target_class->result_source_instance($source) # if $target_class->can('result_source_instance'); # $schema->register_source($source_name, $source); # } # return $schema; # } sub compose_namespace { my ($self, $target, $base) = @_; my $schema = $self->clone; $schema->source_registrations({}); # the original class-mappings must remain - otherwise # reverse_relationship_info will not work #$schema->class_mappings({}); { no warnings qw/redefine/; local *Class::C3::reinitialize = sub { } if DBIx::Class::_ENV_::OLD_MRO; use warnings qw/redefine/; foreach my $source_name ($self->sources) { my $orig_source = $self->source($source_name); my $target_class = "${target}::${source_name}"; $self->inject_base($target_class, $orig_source->result_class, ($base || ()) ); # register_source examines result_class, and then returns us a clone my $new_source = $schema->register_source($source_name, bless { %$orig_source, result_class => $target_class }, ref $orig_source, ); if ($target_class->can('result_source_instance')) { # give the class a schema-less source copy $target_class->result_source_instance( bless { %$new_source, schema => ref $new_source->{schema} || $new_source->{schema} }, ref $new_source, ); } } quote_sub "${target}::${_}" => "shift->schema->$_(\@_)" for qw(class source resultset); } Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO; return $schema; } sub setup_connection_class { my ($class, $target, @info) = @_; $class->inject_base($target => 'DBIx::Class::DB'); #$target->load_components('DB'); $target->connection(@info); } =head2 svp_begin Creates a new savepoint (does nothing outside a transaction). Equivalent to calling $schema->storage->svp_begin. See L for more information. =cut sub svp_begin { my ($self, $name) = @_; $self->storage or $self->throw_exception ('svp_begin called on $schema without storage'); $self->storage->svp_begin($name); } =head2 svp_release Releases a savepoint (does nothing outside a transaction). Equivalent to calling $schema->storage->svp_release. See L for more information. =cut sub svp_release { my ($self, $name) = @_; $self->storage or $self->throw_exception ('svp_release called on $schema without storage'); $self->storage->svp_release($name); } =head2 svp_rollback Rollback to a savepoint (does nothing outside a transaction). Equivalent to calling $schema->storage->svp_rollback. See L for more information. =cut sub svp_rollback { my ($self, $name) = @_; $self->storage or $self->throw_exception ('svp_rollback called on $schema without storage'); $self->storage->svp_rollback($name); } =head2 clone =over 4 =item Arguments: %attrs? =item Return Value: $new_schema =back Clones the schema and its associated result_source objects and returns the copy. The resulting copy will have the same attributes as the source schema, except for those attributes explicitly overridden by the provided C<%attrs>. =cut sub clone { my $self = shift; my $clone = { (ref $self ? %$self : ()), (@_ == 1 && ref $_[0] eq 'HASH' ? %{ $_[0] } : @_), }; bless $clone, (ref $self || $self); $clone->$_(undef) for qw/class_mappings source_registrations storage/; $clone->_copy_state_from($self); return $clone; } # Needed in Schema::Loader - if you refactor, please make a compatibility shim # -- Caelum sub _copy_state_from { my ($self, $from) = @_; $self->class_mappings({ %{$from->class_mappings} }); $self->source_registrations({ %{$from->source_registrations} }); foreach my $source_name ($from->sources) { my $source = $from->source($source_name); my $new = $source->new($source); # we use extra here as we want to leave the class_mappings as they are # but overwrite the source_registrations entry with the new source $self->register_extra_source($source_name => $new); } if ($from->storage) { $self->storage($from->storage); $self->storage->set_schema($self); } } =head2 throw_exception =over 4 =item Arguments: $message =back Throws an exception. Obeys the exemption rules of L to report errors from outer-user's perspective. See L for details on overriding this method's behavior. If L is turned on, C's default behavior will provide a detailed stack trace. =cut sub throw_exception { my ($self, @args) = @_; if (my $act = $self->exception_action) { my $guard_disarmed; my $guard = scope_guard { return if $guard_disarmed; local $SIG{__WARN__}; Carp::cluck(" !!! DBIx::Class INTERNAL PANIC !!! The exception_action() handler installed on '$self' aborted the stacktrace below via a longjmp (either via Return::Multilevel or plain goto, or Scope::Upper or something equally nefarious). There currently is nothing safe DBIx::Class can do, aside from displaying this error. A future version ( 0.082900, when available ) will reduce the cases in which the handler is invoked, but this is neither a complete solution, nor can it do anything for other software that might be affected by a similar problem. !!! FIX YOUR ERROR HANDLING !!! This guard was activated beginning" ); }; eval { # if it throws - good, we'll go down to the do{} below # if it doesn't - do different things depending on RV truthiness if( $act->(@args) ) { $args[0] = ( "Invocation of the exception_action handler installed on $self did *not*" .' result in an exception. DBIx::Class is unable to function without a reliable' .' exception mechanism, ensure that exception_action does not hide exceptions' ." (original error: $args[0])" ); } else { carp_unique ( "The exception_action handler installed on $self returned false instead" .' of throwing an exception. This behavior has been deprecated, adjust your' .' handler to always rethrow the supplied error' ); } $guard_disarmed = 1; } or do { # We call this to get the necessary warnings emitted and disregard the RV # as it's definitely an exception if we got as far as this do{} block is_exception($@); $guard_disarmed = 1; $args[0] = $@; }; } DBIx::Class::Exception->throw($args[0], $self->stacktrace); } =head2 deploy =over 4 =item Arguments: \%sqlt_args, $dir =back Attempts to deploy the schema to the current storage using L. See L for a list of values for C<\%sqlt_args>. The most common value for this would be C<< { add_drop_table => 1 } >> to have the SQL produced include a C statement for each table created. For quoting purposes supply C. Additionally, the DBIx::Class parser accepts a C parameter as a hash ref or an array ref, containing a list of source to deploy. If present, then only the sources listed will get deployed. Furthermore, you can use the C parser parameter to prevent the parser from creating an index for each FK. =cut sub deploy { my ($self, $sqltargs, $dir) = @_; $self->throw_exception("Can't deploy without storage") unless $self->storage; $self->storage->deploy($self, undef, $sqltargs, $dir); } =head2 deployment_statements =over 4 =item Arguments: See L =item Return Value: $listofstatements =back A convenient shortcut to C<< $self->storage->deployment_statements($self, @args) >>. Returns the statements used by L and L. =cut sub deployment_statements { my $self = shift; $self->throw_exception("Can't generate deployment statements without a storage") if not $self->storage; $self->storage->deployment_statements($self, @_); } =head2 create_ddl_dir =over 4 =item Arguments: See L =back A convenient shortcut to C<< $self->storage->create_ddl_dir($self, @args) >>. Creates an SQL file based on the Schema, for each of the specified database types, in the given directory. =cut sub create_ddl_dir { my $self = shift; $self->throw_exception("Can't create_ddl_dir without storage") unless $self->storage; $self->storage->create_ddl_dir($self, @_); } =head2 ddl_filename =over 4 =item Arguments: $database-type, $version, $directory, $preversion =item Return Value: $normalised_filename =back my $filename = $table->ddl_filename($type, $version, $dir, $preversion) This method is called by C to compose a file name out of the supplied directory, database type and version number. The default file name format is: C<$dir$schema-$version-$type.sql>. You may override this method in your schema if you wish to use a different format. WARNING Prior to DBIx::Class version 0.08100 this method had a different signature: my $filename = $table->ddl_filename($type, $dir, $version, $preversion) In recent versions variables $dir and $version were reversed in order to bring the signature in line with other Schema/Storage methods. If you really need to maintain backward compatibility, you can do the following in any overriding methods: ($dir, $version) = ($version, $dir) if ($DBIx::Class::VERSION < 0.08100); =cut sub ddl_filename { my ($self, $type, $version, $dir, $preversion) = @_; require File::Spec; $version = "$preversion-$version" if $preversion; my $class = blessed($self) || $self; $class =~ s/::/-/g; return File::Spec->catfile($dir, "$class-$version-$type.sql"); } =head2 thaw Provided as the recommended way of thawing schema objects. You can call C directly if you wish, but the thawed objects will not have a reference to any schema, so are rather useless. =cut sub thaw { my ($self, $obj) = @_; local $DBIx::Class::ResultSourceHandle::thaw_schema = $self; return Storable::thaw($obj); } =head2 freeze This doesn't actually do anything beyond calling L, it is just provided here for symmetry. =cut sub freeze { return Storable::nfreeze($_[1]); } =head2 dclone =over 4 =item Arguments: $object =item Return Value: dcloned $object =back Recommended way of dcloning L and L objects so their references to the schema object (which itself is B cloned) are properly maintained. =cut sub dclone { my ($self, $obj) = @_; local $DBIx::Class::ResultSourceHandle::thaw_schema = $self; return Storable::dclone($obj); } =head2 schema_version Returns the current schema class' $VERSION in a normalised way. =cut sub schema_version { my ($self) = @_; my $class = ref($self)||$self; # does -not- use $schema->VERSION # since that varies in results depending on if version.pm is installed, and if # so the perl or XS versions. If you want this to change, bug the version.pm # author to make vpp and vxs behave the same. my $version; { no strict 'refs'; $version = ${"${class}::VERSION"}; } return $version; } =head2 register_class =over 4 =item Arguments: $source_name, $component_class =back This method is called by L and L to install the found classes into your Schema. You should be using those instead of this one. You will only need this method if you have your Result classes in files which are not named after the packages (or all in the same file). You may also need it to register classes at runtime. Registers a class which isa DBIx::Class::ResultSourceProxy. Equivalent to calling: $schema->register_source($source_name, $component_class->result_source_instance); =cut sub register_class { my ($self, $source_name, $to_register) = @_; $self->register_source($source_name => $to_register->result_source_instance); } =head2 register_source =over 4 =item Arguments: $source_name, L<$result_source|DBIx::Class::ResultSource> =back This method is called by L. Registers the L in the schema with the given source name. =cut sub register_source { shift->_register_source(@_) } =head2 unregister_source =over 4 =item Arguments: $source_name =back Removes the L from the schema for the given source name. =cut sub unregister_source { shift->_unregister_source(@_) } =head2 register_extra_source =over 4 =item Arguments: $source_name, L<$result_source|DBIx::Class::ResultSource> =back As L but should be used if the result class already has a source and you want to register an extra one. =cut sub register_extra_source { shift->_register_source(@_, { extra => 1 }) } sub _register_source { my ($self, $source_name, $source, $params) = @_; $source = $source->new({ %$source, source_name => $source_name }); $source->schema($self); weaken $source->{schema} if ref($self); my %reg = %{$self->source_registrations}; $reg{$source_name} = $source; $self->source_registrations(\%reg); return $source if $params->{extra}; my $rs_class = $source->result_class; if ($rs_class and my $rsrc = try { $rs_class->result_source_instance } ) { my %map = %{$self->class_mappings}; if ( exists $map{$rs_class} and $map{$rs_class} ne $source_name and $rsrc ne $_[2] # orig_source ) { carp "$rs_class already had a registered source which was replaced by this call. " . 'Perhaps you wanted register_extra_source(), though it is more likely you did ' . 'something wrong.' ; } $map{$rs_class} = $source_name; $self->class_mappings(\%map); } return $source; } my $global_phase_destroy; sub DESTROY { ### NO detected_reinvoked_destructor check ### This code very much relies on being called multuple times return if $global_phase_destroy ||= in_global_destruction; my $self = shift; my $srcs = $self->source_registrations; for my $source_name (keys %$srcs) { # find first source that is not about to be GCed (someone other than $self # holds a reference to it) and reattach to it, weakening our own link # # during global destruction (if we have not yet bailed out) this should throw # which will serve as a signal to not try doing anything else # however beware - on older perls the exception seems randomly untrappable # due to some weird race condition during thread joining :((( if (length ref $srcs->{$source_name} and refcount($srcs->{$source_name}) > 1) { local $@; eval { $srcs->{$source_name}->schema($self); weaken $srcs->{$source_name}; 1; } or do { $global_phase_destroy = 1; }; last; } } } sub _unregister_source { my ($self, $source_name) = @_; my %reg = %{$self->source_registrations}; my $source = delete $reg{$source_name}; $self->source_registrations(\%reg); if ($source->result_class) { my %map = %{$self->class_mappings}; delete $map{$source->result_class}; $self->class_mappings(\%map); } } =head2 compose_connection (DEPRECATED) =over 4 =item Arguments: $target_namespace, @db_info =item Return Value: $new_schema =back DEPRECATED. You probably wanted compose_namespace. Actually, you probably just wanted to call connect. =begin hidden (hidden due to deprecation) Calls L to the target namespace, calls L with @db_info on the new schema, then injects the L component and a resultset_instance classdata entry on all the new classes, in order to support $target_namespaces::$class->search(...) method calls. This is primarily useful when you have a specific need for class method access to a connection. In normal usage it is preferred to call L and use the resulting schema object to operate on L objects with L for more information. =end hidden =cut sub compose_connection { my ($self, $target, @info) = @_; carp_once "compose_connection deprecated as of 0.08000" unless $INC{"DBIx/Class/CDBICompat.pm"}; my $base = 'DBIx::Class::ResultSetProxy'; try { eval "require ${base};" } catch { $self->throw_exception ("No arguments to load_classes and couldn't load ${base} ($_)") }; if ($self eq $target) { # Pathological case, largely caused by the docs on early C::M::DBIC::Plain foreach my $source_name ($self->sources) { my $source = $self->source($source_name); my $class = $source->result_class; $self->inject_base($class, $base); $class->mk_classdata(resultset_instance => $source->resultset); $class->mk_classdata(class_resolver => $self); } $self->connection(@info); return $self; } my $schema = $self->compose_namespace($target, $base); quote_sub "${target}::schema", '$s', { '$s' => \$schema }; $schema->connection(@info); foreach my $source_name ($schema->sources) { my $source = $schema->source($source_name); my $class = $source->result_class; #warn "$source_name $class $source ".$source->storage; $class->mk_classdata(result_source_instance => $source); $class->mk_classdata(resultset_instance => $source->resultset); $class->mk_classdata(class_resolver => $schema); } return $schema; } =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. =cut 1; DBIx-Class-0.082843/lib/DBIx/Class/SQLMaker.pm0000644000175000017500000001454714240132261017467 0ustar rabbitrabbitpackage DBIx::Class::SQLMaker; use strict; use warnings; use base qw( DBIx::Class::SQLMaker::ClassicExtensions SQL::Abstract::Classic ); # NOTE THE LACK OF mro SPECIFICATION # This is deliberate to ensure things will continue to work # with ( usually ) untagged custom darkpan subclasses 1; __END__ =head1 NAME DBIx::Class::SQLMaker - An SQL::Abstract::Classic-like SQL maker class =head1 DESCRIPTION This module serves as a mere "nexus class" providing L-like functionality to L itself, and to a number of database-engine-specific subclasses. This indirection is explicitly maintained in order to allow swapping out the core of SQL generation within DBIC on per-C<$schema> basis without major architectural changes. It is guaranteed by design and tests that this fast-switching will continue being maintained indefinitely. =head2 Implementation switching See L =head1 ROADMAP Some maintainer musings on the current state of SQL generation within DBIC as of October 2019 =head2 Folding of most (or all) of L into DBIC. The rise of complex prefetch use, and the general streamlining of result parsing within DBIC ended up pushing the actual SQL generation to the forefront of many casual performance profiles. While the idea behind the SQLAC-like API is sound, the actual implementation is terribly inefficient (once again bumping into the ridiculously high overhead of perl function calls). Given that SQLAC has a B distinct life on its own, and will hopefully continue to be used within an order of magnitude more projects compared to DBIC, it is prudent to B disturb the current call chains within SQLAC itself. Instead in the future an effort will be undertaken to seek a more thorough decoupling of DBIC SQL generation from reliance on SQLAC, possibly to a point where B<< in the future DBIC may no longer depend on L >> at all. B library itself will continue being maintained> although it is not likely to gain many extra features, notably it will B add further dialect support, at least not within the preexisting C namespace. Such streamlining work (if undertaken) will take into consideration the following constraints: =over =item Main API compatibility The object returned by C<< $schema->storage->sqlmaker >> needs to be able to satisfy most of the basic tests found in the current-at-the-time SQLAC dist. While things like L or L or even worse L will definitely remain unsupported, the rest of the tests should pass (within reason). =item Ability to replace SQL::Abstract::Classic with a derivative module During the initial work on L, which later was slated to occupy the preexisting namespace of L, the test suite of DBIC turned out to be an invaluable asset to iron out hard-to-reason-about corner cases. In addition the test suite is much more vast and intricate than the tests of SQLAC itself. This state of affairs is way too valuable to sacrifice in order to gain faster SQL generation. Thus the L functionality introduced in DBIC v0.082850 along with extra CI configurations will continue to ensure that DBIC can be used with an off-the-CPAN SQLAC and derivatives, and that it continues to flawlessly run its entire test suite. While this will undoubtedly complicate the future implementation of a better performing SQL generator, it will preserve both the usability of the test suite for external projects and will keep L from regressions in the future. =back Aside from these constraints it is becoming more and more practical to simply stop using SQLAC in day-to-day production deployments of DBIC. The flexibility of the internals is simply not worth the performance cost. =head2 Relationship to L and what formerly was known as L When initial work on DQ was taking place, the tools in L<::Storage::DBIHacks |https://github.com/Perl5/DBIx-Class/blob/master/lib/DBIx/Class/Storage/DBIHacks.pm> were only beginning to take shape, and it wasn't clear how important they will become further down the road. In fact the I was considered an ugly stop-gap, and even a couple of highly entertaining talks were given to that effect. As the use-cases of DBIC were progressing, and evidence for the importance of supporting arbitrary SQL was mounting, it became clearer that DBIC itself would not really benefit in any significant way from tigher integration with DQ, but on the contrary is likely to lose L while the corners of the brand new DQ/SQLA codebase are sanded off. The current stance on DBIC/SQLA integration is that it would mainly benefit SQLA by having access to the very extensive "early adopter" test suite, in the same manner as early DBIC benefitted tremendously from usurping the Class::DBI test suite. As far as the DBIC user-base - there are no immediate large-scale upsides to deep SQLA integration, neither in terms of API nor in performance. As such it is unlikely that DBIC will switch back to using L in its core any time soon, if ever. Accordingly the DBIC development effort will in the foreseable future ignore the existence of the new-guts SQLA, and will continue optimizing the preexisting SQLAC-based solution, potentially "organically growing" its own compatible implementation. Also, as described higher up, the ability to plug a separate SQLAC-compatible class providing the necessary surface API will remain possible, and will be protected at all costs in order to continue providing SQLA and friends access to the test cases of DBIC. =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. DBIx-Class-0.082843/lib/DBIx/Class/Cursor.pm0000644000175000017500000000370213271562530017325 0ustar rabbitrabbitpackage DBIx::Class::Cursor; use strict; use warnings; use base qw/DBIx::Class/; =head1 NAME DBIx::Class::Cursor - Abstract object representing a query cursor on a resultset. =head1 SYNOPSIS my $cursor = $schema->resultset('CD')->cursor(); # raw values off the database handle in resultset columns/select order my @next_cd_column_values = $cursor->next; # list of all raw values as arrayrefs my @all_cds_column_values = $cursor->all; =head1 DESCRIPTION A Cursor represents a query cursor on a L object. It allows for traversing the result set with L, retrieving all results with L and resetting the cursor with L. Usually, you would use the cursor methods built into L to traverse it. See L, L and L for more information. =head1 METHODS =head2 new Virtual method. Returns a new L object. =cut sub new { die "Virtual method!"; } =head2 next Virtual method. Advances the cursor to the next row. Returns an array of column values (the result of L method). =cut sub next { die "Virtual method!"; } =head2 reset Virtual method. Resets the cursor to the beginning. =cut sub reset { die "Virtual method!"; } =head2 all Virtual method. Returns all rows in the L. =cut sub all { my ($self) = @_; $self->reset; my @all; while (my @row = $self->next) { push(@all, \@row); } $self->reset; return @all; } =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. =cut 1; DBIx-Class-0.082843/lib/DBIx/Class/Optional/0000755000175000017500000000000014240676463017305 5ustar rabbitrabbitDBIx-Class-0.082843/lib/DBIx/Class/Optional/Dependencies.pm0000644000175000017500000005074214240132261022220 0ustar rabbitrabbitpackage DBIx::Class::Optional::Dependencies; use warnings; use strict; use Carp (); # NO EXTERNAL NON-5.8.1 CORE DEPENDENCIES EVER (e.g. C::A::G) # This module is to be loaded by Makefile.PM on a pristine system # POD is generated automatically by calling _gen_pod from the # Makefile.PL in $AUTHOR mode # NOTE: the rationale for 2 JSON::Any versions is that # we need the newer only to work around JSON::XS, which # itself is an optional dep my $min_json_any = { 'JSON::Any' => '1.23', }; my $test_and_dist_json_any = { 'JSON::Any' => '1.31', }; my $moose_basic = { 'Moose' => '0.98', 'MooseX::Types' => '0.21', 'MooseX::Types::LoadableClass' => '0.011', }; my $replicated = { 'Clone' => 0, %$moose_basic, }; my $admin_basic = { %$moose_basic, %$min_json_any, 'MooseX::Types::Path::Class' => '0.05', 'MooseX::Types::JSON' => '0.02', }; my $admin_script = { %$moose_basic, %$admin_basic, 'Getopt::Long::Descriptive' => '0.081', 'Text::CSV' => '1.16', }; my $datetime_basic = { 'DateTime' => '0.55', 'DateTime::Format::Strptime' => '1.2', }; my $id_shortener = { 'Math::BigInt' => '1.80', 'Math::Base36' => '0.07', }; my $rdbms_sqlite = { 'DBD::SQLite' => '0', }; my $rdbms_pg = { 'DBD::Pg' => '0', }; my $rdbms_mssql_odbc = { 'DBD::ODBC' => '0', }; my $rdbms_mssql_sybase = { 'DBD::Sybase' => '0', }; my $rdbms_mssql_ado = { 'DBD::ADO' => '0', }; my $rdbms_msaccess_odbc = { 'DBD::ODBC' => '0', }; my $rdbms_msaccess_ado = { 'DBD::ADO' => '0', }; my $rdbms_mysql = { 'DBD::mysql' => '0', }; my $rdbms_oracle = { 'DBD::Oracle' => '0', %$id_shortener, }; my $rdbms_ase = { 'DBD::Sybase' => '0', }; my $rdbms_db2 = { 'DBD::DB2' => '0', }; my $rdbms_db2_400 = { 'DBD::ODBC' => '0', }; my $rdbms_informix = { 'DBD::Informix' => '0', }; my $rdbms_sqlanywhere = { 'DBD::SQLAnywhere' => '0', }; my $rdbms_sqlanywhere_odbc = { 'DBD::ODBC' => '0', }; my $rdbms_firebird = { 'DBD::Firebird' => '0', }; my $rdbms_firebird_interbase = { 'DBD::InterBase' => '0', }; my $rdbms_firebird_odbc = { 'DBD::ODBC' => '0', }; my $reqs = { replicated => { req => $replicated, pod => { title => 'Storage::Replicated', desc => 'Modules required for L', }, }, test_replicated => { req => { %$replicated, 'Test::Moose' => '0', }, }, admin => { req => { %$admin_basic, }, pod => { title => 'DBIx::Class::Admin', desc => 'Modules required for the DBIx::Class administrative library', }, }, admin_script => { req => { %$admin_script, }, pod => { title => 'dbicadmin', desc => 'Modules required for the CLI DBIx::Class interface dbicadmin', }, }, deploy => { req => { 'SQL::Translator' => '0.11018', }, pod => { title => 'Storage::DBI::deploy()', desc => 'Modules required for L and L', }, }, id_shortener => { req => $id_shortener, }, test_component_accessor => { req => { 'Class::Unload' => '0.07', }, }, test_pod => { req => { 'Test::Pod' => '1.42', }, }, test_podcoverage => { req => { 'Test::Pod::Coverage' => '1.08', 'Pod::Coverage' => '0.20', }, }, test_whitespace => { req => { 'Test::EOL' => '1.0', 'Test::NoTabs' => '0.9', }, }, test_strictures => { req => { 'Test::Strict' => '0.20', }, }, test_prettydebug => { req => $min_json_any, }, test_admin_script => { req => { %$admin_script, %$test_and_dist_json_any, 'JSON' => 0, 'JSON::PP' => 0, 'Cpanel::JSON::XS' => 0, 'JSON::XS' => 0, $^O eq 'MSWin32' # for t/admin/10script.t ? ('Win32::ShellQuote' => 0) # DWIW does not compile (./configure even) on win32 : ('JSON::DWIW' => 0 ) , } }, test_leaks_heavy => { req => { 'Class::MethodCache' => '0.02', 'PadWalker' => '1.06', }, }, test_dt => { req => $datetime_basic, }, test_dt_sqlite => { req => { %$datetime_basic, # t/36datetime.t # t/60core.t 'DateTime::Format::SQLite' => '0', }, }, test_dt_mysql => { req => { %$datetime_basic, # t/inflate/datetime_mysql.t # (doesn't need Mysql itself) 'DateTime::Format::MySQL' => '0', }, }, test_dt_pg => { req => { %$datetime_basic, # t/inflate/datetime_pg.t # (doesn't need PG itself) 'DateTime::Format::Pg' => '0.16004', }, }, test_cdbicompat => { req => { 'Class::DBI::Plugin::DeepAbstractSearch' => '0', %$datetime_basic, 'Time::Piece::MySQL' => '0', 'Date::Simple' => '3.03', }, }, # this is just for completeness as SQLite # is a core dep of DBIC for testing rdbms_sqlite => { req => { %$rdbms_sqlite, }, pod => { title => 'SQLite support', desc => 'Modules required to connect to SQLite', }, }, rdbms_pg => { req => { # when changing this list make sure to adjust xt/optional_deps.t %$rdbms_pg, }, pod => { title => 'PostgreSQL support', desc => 'Modules required to connect to PostgreSQL', }, }, rdbms_mssql_odbc => { req => { %$rdbms_mssql_odbc, }, pod => { title => 'MSSQL support via DBD::ODBC', desc => 'Modules required to connect to MSSQL via DBD::ODBC', }, }, rdbms_mssql_sybase => { req => { %$rdbms_mssql_sybase, }, pod => { title => 'MSSQL support via DBD::Sybase', desc => 'Modules required to connect to MSSQL via DBD::Sybase', }, }, rdbms_mssql_ado => { req => { %$rdbms_mssql_ado, }, pod => { title => 'MSSQL support via DBD::ADO (Windows only)', desc => 'Modules required to connect to MSSQL via DBD::ADO. This particular DBD is available on Windows only', }, }, rdbms_msaccess_odbc => { req => { %$rdbms_msaccess_odbc, }, pod => { title => 'MS Access support via DBD::ODBC', desc => 'Modules required to connect to MS Access via DBD::ODBC', }, }, rdbms_msaccess_ado => { req => { %$rdbms_msaccess_ado, }, pod => { title => 'MS Access support via DBD::ADO (Windows only)', desc => 'Modules required to connect to MS Access via DBD::ADO. This particular DBD is available on Windows only', }, }, rdbms_mysql => { req => { %$rdbms_mysql, }, pod => { title => 'MySQL support', desc => 'Modules required to connect to MySQL', }, }, rdbms_oracle => { req => { %$rdbms_oracle, }, pod => { title => 'Oracle support', desc => 'Modules required to connect to Oracle', }, }, rdbms_ase => { req => { %$rdbms_ase, }, pod => { title => 'Sybase ASE support', desc => 'Modules required to connect to Sybase ASE', }, }, rdbms_db2 => { req => { %$rdbms_db2, }, pod => { title => 'DB2 support', desc => 'Modules required to connect to DB2', }, }, rdbms_db2_400 => { req => { %$rdbms_db2_400, }, pod => { title => 'DB2 on AS/400 support', desc => 'Modules required to connect to DB2 on AS/400', }, }, rdbms_informix => { req => { %$rdbms_informix, }, pod => { title => 'Informix support', desc => 'Modules required to connect to Informix', }, }, rdbms_sqlanywhere => { req => { %$rdbms_sqlanywhere, }, pod => { title => 'SQLAnywhere support', desc => 'Modules required to connect to SQLAnywhere', }, }, rdbms_sqlanywhere_odbc => { req => { %$rdbms_sqlanywhere_odbc, }, pod => { title => 'SQLAnywhere support via DBD::ODBC', desc => 'Modules required to connect to SQLAnywhere via DBD::ODBC', }, }, rdbms_firebird => { req => { %$rdbms_firebird, }, pod => { title => 'Firebird support', desc => 'Modules required to connect to Firebird', }, }, rdbms_firebird_interbase => { req => { %$rdbms_firebird_interbase, }, pod => { title => 'Firebird support via DBD::InterBase', desc => 'Modules required to connect to Firebird via DBD::InterBase', }, }, rdbms_firebird_odbc => { req => { %$rdbms_firebird_odbc, }, pod => { title => 'Firebird support via DBD::ODBC', desc => 'Modules required to connect to Firebird via DBD::ODBC', }, }, # the order does matter because the rdbms support group might require # a different version that the test group test_rdbms_pg => { req => { $ENV{DBICTEST_PG_DSN} ? ( # when changing this list make sure to adjust xt/optional_deps.t %$rdbms_pg, 'DBD::Pg' => '2.009002', ) : () }, }, test_rdbms_mssql_odbc => { req => { $ENV{DBICTEST_MSSQL_ODBC_DSN} ? ( %$rdbms_mssql_odbc, ) : () }, }, test_rdbms_mssql_ado => { req => { $ENV{DBICTEST_MSSQL_ADO_DSN} ? ( %$rdbms_mssql_ado, ) : () }, }, test_rdbms_mssql_sybase => { req => { $ENV{DBICTEST_MSSQL_DSN} ? ( %$rdbms_mssql_sybase, ) : () }, }, test_rdbms_msaccess_odbc => { req => { $ENV{DBICTEST_MSACCESS_ODBC_DSN} ? ( %$rdbms_msaccess_odbc, %$datetime_basic, 'Data::GUID' => '0', ) : () }, }, test_rdbms_msaccess_ado => { req => { $ENV{DBICTEST_MSACCESS_ADO_DSN} ? ( %$rdbms_msaccess_ado, %$datetime_basic, 'Data::GUID' => 0, ) : () }, }, test_rdbms_mysql => { req => { $ENV{DBICTEST_MYSQL_DSN} ? ( %$rdbms_mysql, ) : () }, }, test_rdbms_oracle => { req => { $ENV{DBICTEST_ORA_DSN} ? ( %$rdbms_oracle, 'DateTime::Format::Oracle' => '0', 'DBD::Oracle' => '1.24', ) : () }, }, test_rdbms_ase => { req => { $ENV{DBICTEST_SYBASE_DSN} ? ( %$rdbms_ase, ) : () }, }, test_rdbms_db2 => { req => { $ENV{DBICTEST_DB2_DSN} ? ( %$rdbms_db2, ) : () }, }, test_rdbms_db2_400 => { req => { $ENV{DBICTEST_DB2_400_DSN} ? ( %$rdbms_db2_400, ) : () }, }, test_rdbms_informix => { req => { $ENV{DBICTEST_INFORMIX_DSN} ? ( %$rdbms_informix, ) : () }, }, test_rdbms_sqlanywhere => { req => { $ENV{DBICTEST_SQLANYWHERE_DSN} ? ( %$rdbms_sqlanywhere, ) : () }, }, test_rdbms_sqlanywhere_odbc => { req => { $ENV{DBICTEST_SQLANYWHERE_ODBC_DSN} ? ( %$rdbms_sqlanywhere_odbc, ) : () }, }, test_rdbms_firebird => { req => { $ENV{DBICTEST_FIREBIRD_DSN} ? ( %$rdbms_firebird, ) : () }, }, test_rdbms_firebird_interbase => { req => { $ENV{DBICTEST_FIREBIRD_INTERBASE_DSN} ? ( %$rdbms_firebird_interbase, ) : () }, }, test_rdbms_firebird_odbc => { req => { $ENV{DBICTEST_FIREBIRD_ODBC_DSN} ? ( %$rdbms_firebird_odbc, ) : () }, }, test_memcached => { req => { $ENV{DBICTEST_MEMCACHED} ? ( 'Cache::Memcached' => 0, ) : () }, }, dist_dir => { req => { %$admin_script, %$test_and_dist_json_any, 'ExtUtils::MakeMaker' => '6.64', 'Pod::Inherit' => '0.91', }, }, dist_upload => { req => { 'CPAN::Uploader' => '0.103001', }, }, }; our %req_availability_cache; sub req_list_for { my ($class, $group) = @_; Carp::croak "req_list_for() expects a requirement group name" unless $group; my $deps = $reqs->{$group}{req} or Carp::croak "Requirement group '$group' does not exist"; return { %$deps }; } sub die_unless_req_ok_for { my ($class, $group) = @_; Carp::croak "die_unless_req_ok_for() expects a requirement group name" unless $group; $class->_check_deps($group)->{status} or die sprintf( "Required modules missing, unable to continue: %s\n", $class->_check_deps($group)->{missing} ); } sub req_ok_for { my ($class, $group) = @_; Carp::croak "req_ok_for() expects a requirement group name" unless $group; return $class->_check_deps($group)->{status}; } sub req_missing_for { my ($class, $group) = @_; Carp::croak "req_missing_for() expects a requirement group name" unless $group; return $class->_check_deps($group)->{missing}; } sub req_errorlist_for { my ($class, $group) = @_; Carp::croak "req_errorlist_for() expects a requirement group name" unless $group; return $class->_check_deps($group)->{errorlist}; } sub _check_deps { my ($class, $group) = @_; return $req_availability_cache{$group} ||= do { my $deps = $class->req_list_for ($group); my %errors; for my $mod (keys %$deps) { my $req_line = "require $mod;"; if (my $ver = $deps->{$mod}) { $req_line .= "$mod->VERSION($ver);"; } eval $req_line; $errors{$mod} = $@ if $@; } my $res; if (keys %errors) { my $missing = join (', ', map { $deps->{$_} ? "$_ >= $deps->{$_}" : $_ } (sort keys %errors) ); $missing .= " (see $class for details)" if $reqs->{$group}{pod}; $res = { status => 0, errorlist => \%errors, missing => $missing, }; } else { $res = { status => 1, errorlist => {}, missing => '', }; } $res; }; } sub req_group_list { return { map { $_ => { %{ $reqs->{$_}{req} || {} } } } (keys %$reqs) }; } # This is to be called by the author only (automatically in Makefile.PL) sub _gen_pod { my ($class, $distver, $pod_dir) = @_; die "No POD root dir supplied" unless $pod_dir; $distver ||= eval { require DBIx::Class; DBIx::Class->VERSION; } || die "\n\n---------------------------------------------------------------------\n" . 'Unable to load core DBIx::Class module to determine current version, '. 'possibly due to missing dependencies. Author-mode autodocumentation ' . "halted\n\n" . $@ . "\n\n---------------------------------------------------------------------\n" ; # do not ask for a recent version, use 1.x API calls # this *may* execute on a smoker with old perl or whatnot require File::Path; (my $modfn = __PACKAGE__ . '.pm') =~ s|::|/|g; (my $podfn = "$pod_dir/$modfn") =~ s/\.pm$/\.pod/; (my $dir = $podfn) =~ s|/[^/]+$||; File::Path::mkpath([$dir]); my $sqltver = $class->req_list_for ('deploy')->{'SQL::Translator'} or die "Hrmm? No sqlt dep?"; my @chunks = ( <<"EOC", ######################################################################### ##################### A U T O G E N E R A T E D ######################## ######################################################################### # # The contents of this POD file are auto-generated. Any changes you make # will be lost. If you need to change the generated text edit _gen_pod() # at the end of $modfn # EOC '=head1 NAME', "$class - Optional module dependency specifications (for module authors)", '=head1 SYNOPSIS', <<"EOS", Somewhere in your build-file (e.g. L's Makefile.PL): ... configure_requires 'DBIx::Class' => '$distver'; require $class; my \$deploy_deps = $class->req_list_for('deploy'); for (keys %\$deploy_deps) { requires \$_ => \$deploy_deps->{\$_}; } ... Note that there are some caveats regarding C, more info can be found at L EOS '=head1 DESCRIPTION', <<'EOD', Some of the less-frequently used features of L have external module dependencies on their own. In order not to burden the average user with modules he will never use, these optional dependencies are not included in the base Makefile.PL. Instead an exception with a descriptive message is thrown when a specific feature is missing one or several modules required for its operation. This module is the central holding place for the current list of such dependencies, for DBIx::Class core authors, and DBIx::Class extension authors alike. EOD '=head1 CURRENT REQUIREMENT GROUPS', <<'EOD', Dependencies are organized in C and each group can list one or more required modules, with an optional minimum version (or 0 for any version). The group name can be used in the EOD ); for my $group (sort keys %$reqs) { my $p = $reqs->{$group}{pod} or next; my $modlist = $reqs->{$group}{req} or next; next unless keys %$modlist; push @chunks, ( "=head2 $p->{title}", "$p->{desc}", '=over', ( map { "=item * $_" . ($modlist->{$_} ? " >= $modlist->{$_}" : '') } (sort keys %$modlist) ), '=back', "Requirement group: B<$group>", ); } push @chunks, ( '=head1 METHODS', '=head2 req_group_list', '=over', '=item Arguments: none', '=item Return Value: \%list_of_requirement_groups', '=back', <<'EOD', This method should be used by DBIx::Class packagers, to get a hashref of all dependencies keyed by dependency group. Each key (group name) can be supplied to one of the group-specific methods below. EOD '=head2 req_list_for', '=over', '=item Arguments: $group_name', '=item Return Value: \%list_of_module_version_pairs', '=back', <<'EOD', This method should be used by DBIx::Class extension authors, to determine the version of modules a specific feature requires in the B version of DBIx::Class. See the L for a real-world example. EOD '=head2 req_ok_for', '=over', '=item Arguments: $group_name', '=item Return Value: 1|0', '=back', <<'EOD', Returns true or false depending on whether all modules required by C<$group_name> are present on the system and loadable. EOD '=head2 req_missing_for', '=over', '=item Arguments: $group_name', '=item Return Value: $error_message_string', '=back', <<"EOD", Returns a single line string suitable for inclusion in larger error messages. This method would normally be used by DBIx::Class core-module author, to indicate to the user that he needs to install specific modules before he will be able to use a specific feature. For example if some of the requirements for C are not available, the returned string could look like: SQL::Translator >= $sqltver (see $class for details) The author is expected to prepend the necessary text to this message before returning the actual error seen by the user. EOD '=head2 die_unless_req_ok_for', '=over', '=item Arguments: $group_name', '=back', <<'EOD', Checks if L passes for the supplied C<$group_name>, and in case of failure throws an exception including the information from L. EOD '=head2 req_errorlist_for', '=over', '=item Arguments: $group_name', '=item Return Value: \%list_of_loaderrors_per_module', '=back', <<'EOD', Returns a hashref containing the actual errors that occurred while attempting to load each module in the requirement group. EOD '=head1 FURTHER QUESTIONS?', 'Check the list of L.', '=head1 COPYRIGHT AND LICENSE', <<'EOL', This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. EOL ); open (my $fh, '>', $podfn) or Carp::croak "Unable to write to $podfn: $!"; print $fh join ("\n\n", @chunks); print $fh "\n"; close ($fh); } 1; DBIx-Class-0.082843/lib/DBIx/Class/Optional/Dependencies.pod0000444000175000017500000002035014240676410022365 0ustar rabbitrabbit######################################################################### ##################### A U T O G E N E R A T E D ######################## ######################################################################### # # The contents of this POD file are auto-generated. Any changes you make # will be lost. If you need to change the generated text edit _gen_pod() # at the end of DBIx/Class/Optional/Dependencies.pm # =head1 NAME DBIx::Class::Optional::Dependencies - Optional module dependency specifications (for module authors) =head1 SYNOPSIS Somewhere in your build-file (e.g. L's Makefile.PL): ... configure_requires 'DBIx::Class' => '0.082843'; require DBIx::Class::Optional::Dependencies; my $deploy_deps = DBIx::Class::Optional::Dependencies->req_list_for('deploy'); for (keys %$deploy_deps) { requires $_ => $deploy_deps->{$_}; } ... Note that there are some caveats regarding C, more info can be found at L =head1 DESCRIPTION Some of the less-frequently used features of L have external module dependencies on their own. In order not to burden the average user with modules he will never use, these optional dependencies are not included in the base Makefile.PL. Instead an exception with a descriptive message is thrown when a specific feature is missing one or several modules required for its operation. This module is the central holding place for the current list of such dependencies, for DBIx::Class core authors, and DBIx::Class extension authors alike. =head1 CURRENT REQUIREMENT GROUPS Dependencies are organized in C and each group can list one or more required modules, with an optional minimum version (or 0 for any version). The group name can be used in the =head2 DBIx::Class::Admin Modules required for the DBIx::Class administrative library =over =item * JSON::Any >= 1.23 =item * Moose >= 0.98 =item * MooseX::Types >= 0.21 =item * MooseX::Types::JSON >= 0.02 =item * MooseX::Types::LoadableClass >= 0.011 =item * MooseX::Types::Path::Class >= 0.05 =back Requirement group: B =head2 dbicadmin Modules required for the CLI DBIx::Class interface dbicadmin =over =item * Getopt::Long::Descriptive >= 0.081 =item * JSON::Any >= 1.23 =item * Moose >= 0.98 =item * MooseX::Types >= 0.21 =item * MooseX::Types::JSON >= 0.02 =item * MooseX::Types::LoadableClass >= 0.011 =item * MooseX::Types::Path::Class >= 0.05 =item * Text::CSV >= 1.16 =back Requirement group: B =head2 Storage::DBI::deploy() Modules required for L and L =over =item * SQL::Translator >= 0.11018 =back Requirement group: B =head2 Sybase ASE support Modules required to connect to Sybase ASE =over =item * DBD::Sybase =back Requirement group: B =head2 DB2 support Modules required to connect to DB2 =over =item * DBD::DB2 =back Requirement group: B =head2 DB2 on AS/400 support Modules required to connect to DB2 on AS/400 =over =item * DBD::ODBC =back Requirement group: B =head2 Firebird support Modules required to connect to Firebird =over =item * DBD::Firebird =back Requirement group: B =head2 Firebird support via DBD::InterBase Modules required to connect to Firebird via DBD::InterBase =over =item * DBD::InterBase =back Requirement group: B =head2 Firebird support via DBD::ODBC Modules required to connect to Firebird via DBD::ODBC =over =item * DBD::ODBC =back Requirement group: B =head2 Informix support Modules required to connect to Informix =over =item * DBD::Informix =back Requirement group: B =head2 MS Access support via DBD::ADO (Windows only) Modules required to connect to MS Access via DBD::ADO. This particular DBD is available on Windows only =over =item * DBD::ADO =back Requirement group: B =head2 MS Access support via DBD::ODBC Modules required to connect to MS Access via DBD::ODBC =over =item * DBD::ODBC =back Requirement group: B =head2 MSSQL support via DBD::ADO (Windows only) Modules required to connect to MSSQL via DBD::ADO. This particular DBD is available on Windows only =over =item * DBD::ADO =back Requirement group: B =head2 MSSQL support via DBD::ODBC Modules required to connect to MSSQL via DBD::ODBC =over =item * DBD::ODBC =back Requirement group: B =head2 MSSQL support via DBD::Sybase Modules required to connect to MSSQL via DBD::Sybase =over =item * DBD::Sybase =back Requirement group: B =head2 MySQL support Modules required to connect to MySQL =over =item * DBD::mysql =back Requirement group: B =head2 Oracle support Modules required to connect to Oracle =over =item * DBD::Oracle =item * Math::Base36 >= 0.07 =item * Math::BigInt >= 1.80 =back Requirement group: B =head2 PostgreSQL support Modules required to connect to PostgreSQL =over =item * DBD::Pg =back Requirement group: B =head2 SQLAnywhere support Modules required to connect to SQLAnywhere =over =item * DBD::SQLAnywhere =back Requirement group: B =head2 SQLAnywhere support via DBD::ODBC Modules required to connect to SQLAnywhere via DBD::ODBC =over =item * DBD::ODBC =back Requirement group: B =head2 SQLite support Modules required to connect to SQLite =over =item * DBD::SQLite =back Requirement group: B =head2 Storage::Replicated Modules required for L =over =item * Clone =item * Moose >= 0.98 =item * MooseX::Types >= 0.21 =item * MooseX::Types::LoadableClass >= 0.011 =back Requirement group: B =head1 METHODS =head2 req_group_list =over =item Arguments: none =item Return Value: \%list_of_requirement_groups =back This method should be used by DBIx::Class packagers, to get a hashref of all dependencies keyed by dependency group. Each key (group name) can be supplied to one of the group-specific methods below. =head2 req_list_for =over =item Arguments: $group_name =item Return Value: \%list_of_module_version_pairs =back This method should be used by DBIx::Class extension authors, to determine the version of modules a specific feature requires in the B version of DBIx::Class. See the L for a real-world example. =head2 req_ok_for =over =item Arguments: $group_name =item Return Value: 1|0 =back Returns true or false depending on whether all modules required by C<$group_name> are present on the system and loadable. =head2 req_missing_for =over =item Arguments: $group_name =item Return Value: $error_message_string =back Returns a single line string suitable for inclusion in larger error messages. This method would normally be used by DBIx::Class core-module author, to indicate to the user that he needs to install specific modules before he will be able to use a specific feature. For example if some of the requirements for C are not available, the returned string could look like: SQL::Translator >= 0.11018 (see DBIx::Class::Optional::Dependencies for details) The author is expected to prepend the necessary text to this message before returning the actual error seen by the user. =head2 die_unless_req_ok_for =over =item Arguments: $group_name =back Checks if L passes for the supplied C<$group_name>, and in case of failure throws an exception including the information from L. =head2 req_errorlist_for =over =item Arguments: $group_name =item Return Value: \%list_of_loaderrors_per_module =back Returns a hashref containing the actual errors that occurred while attempting to load each module in the requirement group. =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. DBIx-Class-0.082843/lib/DBIx/Class/Relationship/0000755000175000017500000000000014240676463020161 5ustar rabbitrabbitDBIx-Class-0.082843/lib/DBIx/Class/Relationship/HasOne.pm0000644000175000017500000000634714240132261021665 0ustar rabbitrabbitpackage # hide from PAUSE DBIx::Class::Relationship::HasOne; use strict; use warnings; use DBIx::Class::Carp; use Try::Tiny; use namespace::clean; our %_pod_inherit_config = ( class_map => { 'DBIx::Class::Relationship::HasOne' => 'DBIx::Class::Relationship' } ); sub might_have { shift->_has_one('LEFT' => @_); } sub has_one { shift->_has_one(undef() => @_); } sub _has_one { my ($class, $join_type, $rel, $f_class, $cond, $attrs) = @_; unless (ref $cond) { my $pri = $class->result_source_instance->_single_pri_col_or_die; my ($f_key,$guess,$f_rsrc); if (defined $cond && length $cond) { $f_key = $cond; $guess = "caller specified foreign key '$f_key'"; } else { # at this point we need to load the foreigner, expensive or not $class->ensure_class_loaded($f_class); $f_rsrc = try { my $r = $f_class->result_source_instance; die "There got to be some columns by now... (exception caught and rewritten by catch below)" unless $r->columns; $r; } catch { $class->throw_exception( "Foreign class '$f_class' does not seem to be a Result class " . "(or it simply did not load entirely due to a circular relation chain)" ); }; if ($f_rsrc->has_column($rel)) { $f_key = $rel; $guess = "using given relationship name '$rel' as foreign key column name"; } else { $f_key = $f_rsrc->_single_pri_col_or_die; $guess = "using primary key of foreign class for foreign key"; } } # FIXME - this check needs to be moved to schema-composition time... # # only perform checks if the far side was not preloaded above *AND* # # appears to have been loaded by something else (has a rsrc_instance) # if (! $f_rsrc and $f_rsrc = try { $f_class->result_source_instance }) { # $class->throw_exception( # "No such column '$f_key' on foreign class ${f_class} ($guess)" # ) if !$f_rsrc->has_column($f_key); # } $cond = { "foreign.${f_key}" => "self.${pri}" }; } $class->_validate_has_one_condition($cond); my $default_cascade = ref $cond eq 'CODE' ? 0 : 1; $class->add_relationship($rel, $f_class, $cond, { accessor => 'single', cascade_update => $default_cascade, cascade_delete => $default_cascade, is_depends_on => 0, ($join_type ? ('join_type' => $join_type) : ()), %{$attrs || {}} }); 1; } sub _validate_has_one_condition { my ($class, $cond ) = @_; return if $ENV{DBIC_DONT_VALIDATE_RELS}; return unless 'HASH' eq ref $cond; foreach my $foreign_id ( keys %$cond ) { my $self_id = $cond->{$foreign_id}; # we can ignore a bad $self_id because add_relationship handles this # exception return unless $self_id =~ /^self\.(.*)$/; my $key = $1; $class->throw_exception("Defining rel on ${class} that includes '$key' but no such column defined here yet") unless $class->has_column($key); my $column_info = $class->column_info($key); if ( $column_info->{is_nullable} ) { carp(qq'"might_have/has_one" must not be on columns with is_nullable set to true ($class/$key). This might indicate an incorrect use of those relationship helpers instead of belongs_to.'); } } } 1; DBIx-Class-0.082843/lib/DBIx/Class/Relationship/ProxyMethods.pm0000644000175000017500000000255614240132261023153 0ustar rabbitrabbitpackage # hide from PAUSE DBIx::Class::Relationship::ProxyMethods; use strict; use warnings; use base 'DBIx::Class'; use DBIx::Class::_Util 'quote_sub'; use namespace::clean; our %_pod_inherit_config = ( class_map => { 'DBIx::Class::Relationship::ProxyMethods' => 'DBIx::Class::Relationship' } ); sub register_relationship { my ($class, $rel, $info) = @_; if (my $proxy_args = $info->{attrs}{proxy}) { $class->proxy_to_related($rel, $proxy_args); } $class->next::method($rel, $info); } sub proxy_to_related { my ($class, $rel, $proxy_args) = @_; my %proxy_map = $class->_build_proxy_map_from($proxy_args); quote_sub "${class}::$_", sprintf( <<'EOC', $rel, $proxy_map{$_} ) my $self = shift; my $relobj = $self->%1$s; if (@_ && !defined $relobj) { $relobj = $self->create_related( %1$s => { %2$s => $_[0] } ); @_ = (); } $relobj ? $relobj->%2$s(@_) : undef; EOC for keys %proxy_map } sub _build_proxy_map_from { my ( $class, $proxy_arg ) = @_; my $ref = ref $proxy_arg; if ($ref eq 'HASH') { return %$proxy_arg; } elsif ($ref eq 'ARRAY') { return map { (ref $_ eq 'HASH') ? (%$_) : ($_ => $_) } @$proxy_arg; } elsif ($ref) { $class->throw_exception("Unable to process the 'proxy' argument $proxy_arg"); } else { return ( $proxy_arg => $proxy_arg ); } } 1; DBIx-Class-0.082843/lib/DBIx/Class/Relationship/Accessor.pm0000644000175000017500000000724014240132261022243 0ustar rabbitrabbitpackage # hide from PAUSE DBIx::Class::Relationship::Accessor; use strict; use warnings; use DBIx::Class::Carp; use DBIx::Class::_Util qw(quote_sub perlstring); use namespace::clean; our %_pod_inherit_config = ( class_map => { 'DBIx::Class::Relationship::Accessor' => 'DBIx::Class::Relationship' } ); sub register_relationship { my ($class, $rel, $info) = @_; if (my $acc_type = $info->{attrs}{accessor}) { $class->add_relationship_accessor($rel => $acc_type); } $class->next::method($rel => $info); } sub add_relationship_accessor { my ($class, $rel, $acc_type) = @_; if ($acc_type eq 'single') { quote_sub "${class}::${rel}" => sprintf(<<'EOC', perlstring $rel); my $self = shift; if (@_) { $self->set_from_related( %1$s => @_ ); return $self->{_relationship_data}{%1$s} = $_[0]; } elsif (exists $self->{_relationship_data}{%1$s}) { return $self->{_relationship_data}{%1$s}; } else { my $relcond = $self->result_source->_resolve_relationship_condition( rel_name => %1$s, foreign_alias => %1$s, self_alias => 'me', self_result_object => $self, ); return undef if ( $relcond->{join_free_condition} and $relcond->{join_free_condition} ne DBIx::Class::_Util::UNRESOLVABLE_CONDITION and scalar grep { not defined $_ } values %%{ $relcond->{join_free_condition} || {} } and $self->result_source->relationship_info(%1$s)->{attrs}{undef_on_null_fk} ); my $val = $self->search_related( %1$s )->single; return $val unless $val; # $val instead of undef so that null-objects can go through return $self->{_relationship_data}{%1$s} = $val; } EOC } elsif ($acc_type eq 'filter') { $class->throw_exception("No such column '$rel' to filter") unless $class->has_column($rel); my $f_class = $class->relationship_info($rel)->{class}; $class->inflate_column($rel, { inflate => sub { my ($val, $self) = @_; return $self->find_or_new_related($rel, {}, {}); }, deflate => sub { my ($val, $self) = @_; $self->throw_exception("'$val' isn't a $f_class") unless $val->isa($f_class); # MASSIVE FIXME - this code assumes we pointed at the PK, but the belongs_to # helper does not check any of this # fixup the code a bit to make things saner, but ideally 'filter' needs to # be deprecated ASAP and removed shortly after # Not doing so before 0.08250 however, too many things in motion already my ($pk_col, @rest) = $val->result_source->_pri_cols_or_die; $self->throw_exception( "Relationship '$rel' of type 'filter' can not work with a multicolumn primary key on source '$f_class'" ) if @rest; my $pk_val = $val->get_column($pk_col); carp_unique ( "Unable to deflate 'filter'-type relationship '$rel' (related object " . "primary key not retrieved), assuming undef instead" ) if ( ! defined $pk_val and $val->in_storage ); return $pk_val; }, }); } elsif ($acc_type eq 'multi') { quote_sub "${class}::${rel}_rs", "shift->search_related_rs( $rel => \@_ )"; quote_sub "${class}::add_to_${rel}", "shift->create_related( $rel => \@_ )"; quote_sub "${class}::${rel}", sprintf( <<'EOC', perlstring $rel ); DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = DBIx::Class::_Util::fail_on_internal_wantarray; shift->search_related( %s => @_ ) EOC } else { $class->throw_exception("No such relationship accessor type '$acc_type'"); } } 1; DBIx-Class-0.082843/lib/DBIx/Class/Relationship/ManyToMany.pm0000644000175000017500000001142214240132261022532 0ustar rabbitrabbitpackage # hide from PAUSE DBIx::Class::Relationship::ManyToMany; use strict; use warnings; use DBIx::Class::Carp; use Sub::Name 'subname'; use Scalar::Util 'blessed'; use DBIx::Class::_Util 'fail_on_internal_wantarray'; use namespace::clean; our %_pod_inherit_config = ( class_map => { 'DBIx::Class::Relationship::ManyToMany' => 'DBIx::Class::Relationship' } ); sub many_to_many { my ($class, $meth, $rel, $f_rel, $rel_attrs) = @_; $class->throw_exception( "missing relation in many-to-many" ) unless $rel; $class->throw_exception( "missing foreign relation in many-to-many" ) unless $f_rel; { no strict 'refs'; no warnings 'redefine'; my $add_meth = "add_to_${meth}"; my $remove_meth = "remove_from_${meth}"; my $set_meth = "set_${meth}"; my $rs_meth = "${meth}_rs"; for ($add_meth, $remove_meth, $set_meth, $rs_meth) { if ( $class->can ($_) ) { carp (<<"EOW") unless $ENV{DBIC_OVERWRITE_HELPER_METHODS_OK}; *************************************************************************** The many-to-many relationship '$meth' is trying to create a utility method called $_. This will completely overwrite one such already existing method on class $class. You almost certainly want to rename your method or the many-to-many relationship, as the functionality of the original method will not be accessible anymore. To disable this warning set to a true value the environment variable DBIC_OVERWRITE_HELPER_METHODS_OK *************************************************************************** EOW } } $rel_attrs->{alias} ||= $f_rel; my $rs_meth_name = join '::', $class, $rs_meth; *$rs_meth_name = subname $rs_meth_name, sub { my $self = shift; my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {}; my $rs = $self->search_related($rel)->search_related( $f_rel, @_ > 0 ? @_ : undef, { %{$rel_attrs||{}}, %$attrs } ); return $rs; }; my $meth_name = join '::', $class, $meth; *$meth_name = subname $meth_name, sub { DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = fail_on_internal_wantarray; my $self = shift; my $rs = $self->$rs_meth( @_ ); return (wantarray ? $rs->all : $rs); }; my $add_meth_name = join '::', $class, $add_meth; *$add_meth_name = subname $add_meth_name, sub { my $self = shift; @_ > 0 or $self->throw_exception( "${add_meth} needs an object or hashref" ); my $source = $self->result_source; my $schema = $source->schema; my $rel_source_name = $source->relationship_info($rel)->{source}; my $rel_source = $schema->resultset($rel_source_name)->result_source; my $f_rel_source_name = $rel_source->relationship_info($f_rel)->{source}; my $f_rel_rs = $schema->resultset($f_rel_source_name)->search({}, $rel_attrs||{}); my $obj; if (ref $_[0]) { if (ref $_[0] eq 'HASH') { $obj = $f_rel_rs->find_or_create($_[0]); } else { $obj = $_[0]; } } else { $obj = $f_rel_rs->find_or_create({@_}); } my $link_vals = @_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {}; my $link = $self->search_related($rel)->new_result($link_vals); $link->set_from_related($f_rel, $obj); $link->insert(); return $obj; }; my $set_meth_name = join '::', $class, $set_meth; *$set_meth_name = subname $set_meth_name, sub { my $self = shift; @_ > 0 or $self->throw_exception( "{$set_meth} needs a list of objects or hashrefs" ); my @to_set = (ref($_[0]) eq 'ARRAY' ? @{ $_[0] } : @_); # if there is a where clause in the attributes, ensure we only delete # rows that are within the where restriction if ($rel_attrs && $rel_attrs->{where}) { $self->search_related( $rel, $rel_attrs->{where},{join => $f_rel})->delete; } else { $self->search_related( $rel, {} )->delete; } # add in the set rel objects $self->$add_meth($_, ref($_[1]) ? $_[1] : {}) for (@to_set); }; my $remove_meth_name = join '::', $class, $remove_meth; *$remove_meth_name = subname $remove_meth_name, sub { my ($self, $obj) = @_; $self->throw_exception("${remove_meth} needs an object") unless blessed ($obj); my $rel_source = $self->search_related($rel)->result_source; my $cond = $rel_source->relationship_info($f_rel)->{cond}; my ($link_cond, $crosstable) = $rel_source->_resolve_condition( $cond, $obj, $f_rel, $f_rel ); $self->throw_exception( "Relationship '$rel' does not resolve to a join-free condition, " ."unable to use with the ManyToMany helper '$f_rel'" ) if $crosstable; $self->search_related($rel, $link_cond)->delete; }; } } 1; DBIx-Class-0.082843/lib/DBIx/Class/Relationship/HasMany.pm0000644000175000017500000000270714240132261022044 0ustar rabbitrabbitpackage # hide from PAUSE DBIx::Class::Relationship::HasMany; use strict; use warnings; use Try::Tiny; use namespace::clean; our %_pod_inherit_config = ( class_map => { 'DBIx::Class::Relationship::HasMany' => 'DBIx::Class::Relationship' } ); sub has_many { my ($class, $rel, $f_class, $cond, $attrs) = @_; unless (ref $cond) { my $pri = $class->result_source_instance->_single_pri_col_or_die; my ($f_key,$guess); if (defined $cond && length $cond) { $f_key = $cond; $guess = "caller specified foreign key '$f_key'"; } else { $class =~ /([^\:]+)$/; # match is safe - $class can't be '' $f_key = lc $1; # go ahead and guess; best we can do $guess = "using our class name '$class' as foreign key source"; } # FIXME - this check needs to be moved to schema-composition time... # # only perform checks if the far side appears already loaded # if (my $f_rsrc = try { $f_class->result_source_instance } ) { # $class->throw_exception( # "No such column '$f_key' on foreign class ${f_class} ($guess)" # ) if !$f_rsrc->has_column($f_key); # } $cond = { "foreign.${f_key}" => "self.${pri}" }; } my $default_cascade = ref $cond eq 'CODE' ? 0 : 1; $class->add_relationship($rel, $f_class, $cond, { accessor => 'multi', join_type => 'LEFT', cascade_delete => $default_cascade, cascade_copy => $default_cascade, is_depends_on => 0, %{$attrs||{}} }); } 1; DBIx-Class-0.082843/lib/DBIx/Class/Relationship/CascadeActions.pm0000644000175000017500000000402714240132261023345 0ustar rabbitrabbitpackage # hide from PAUSE DBIx::Class::Relationship::CascadeActions; use strict; use warnings; use DBIx::Class::Carp; use namespace::clean; our %_pod_inherit_config = ( class_map => { 'DBIx::Class::Relationship::CascadeActions' => 'DBIx::Class::Relationship' } ); sub delete { my ($self, @rest) = @_; return $self->next::method(@rest) unless ref $self; # I'm just ignoring this for class deletes because hell, the db should # be handling this anyway. Assuming we have joins we probably actually # *could* do them, but I'd rather not. my $source = $self->result_source; my %rels = map { $_ => $source->relationship_info($_) } $source->relationships; my @cascade = grep { $rels{$_}{attrs}{cascade_delete} } keys %rels; if (@cascade) { my $guard = $source->schema->txn_scope_guard; my $ret = $self->next::method(@rest); foreach my $rel (@cascade) { if( my $rel_rs = eval{ $self->search_related($rel) } ) { $rel_rs->delete_all; } else { carp "Skipping cascade delete on relationship '$rel' - related resultsource '$rels{$rel}{class}' is not registered with this schema"; next; } } $guard->commit; return $ret; } $self->next::method(@rest); } sub update { my ($self, @rest) = @_; return $self->next::method(@rest) unless ref $self; # Because update cascades on a class *really* don't make sense! my $source = $self->result_source; my %rels = map { $_ => $source->relationship_info($_) } $source->relationships; my @cascade = grep { $rels{$_}{attrs}{cascade_update} } keys %rels; if (@cascade) { my $guard = $source->schema->txn_scope_guard; my $ret = $self->next::method(@rest); foreach my $rel (@cascade) { next if ( $rels{$rel}{attrs}{accessor} && $rels{$rel}{attrs}{accessor} eq 'single' && !exists($self->{_relationship_data}{$rel}) ); $_->update for grep defined, $self->$rel; } $guard->commit; return $ret; } $self->next::method(@rest); } 1; DBIx-Class-0.082843/lib/DBIx/Class/Relationship/Base.pm0000644000175000017500000007357014240132261021364 0ustar rabbitrabbitpackage DBIx::Class::Relationship::Base; use strict; use warnings; use base qw/DBIx::Class/; use Scalar::Util qw/weaken blessed/; use Try::Tiny; use DBIx::Class::_Util 'UNRESOLVABLE_CONDITION'; use namespace::clean; =head1 NAME DBIx::Class::Relationship::Base - Inter-table relationships =head1 SYNOPSIS __PACKAGE__->add_relationship( spiders => 'My::DB::Result::Creatures', sub { my $args = shift; return { "$args->{foreign_alias}.id" => { -ident => "$args->{self_alias}.id" }, "$args->{foreign_alias}.type" => 'arachnid' }; }, ); =head1 DESCRIPTION This class provides methods to describe the relationships between the tables in your database model. These are the "bare bones" relationships methods, for predefined ones, look in L. =head1 METHODS =head2 add_relationship =over 4 =item Arguments: $rel_name, $foreign_class, $condition, $attrs =back __PACKAGE__->add_relationship('rel_name', 'Foreign::Class', $condition, $attrs); Create a custom relationship between one result source and another source, indicated by its class name. =head3 condition The condition argument describes the C clause of the C expression used to connect the two sources when creating SQL queries. =head4 Simple equality To create simple equality joins, supply a hashref containing the remote table column name as the key(s) prefixed by C<'foreign.'>, and the corresponding local table column name as the value(s) prefixed by C<'self.'>. Both C and C are pseudo aliases and must be entered literally. They will be replaced with the actual correct table alias when the SQL is produced. For example given: My::Schema::Author->has_many( books => 'My::Schema::Book', { 'foreign.author_id' => 'self.id' } ); A query like: $author_rs->search_related('books')->next will result in the following C clause: ... FROM author me LEFT JOIN book books ON books.author_id = me.id ... This describes a relationship between the C table and the C table where the C table has a column C containing the ID value of the C. Similarly: My::Schema::Book->has_many( editions => 'My::Schema::Edition', { 'foreign.publisher_id' => 'self.publisher_id', 'foreign.type_id' => 'self.type_id', } ); ... $book_rs->search_related('editions')->next will result in the C clause: ... FROM book me LEFT JOIN edition editions ON editions.publisher_id = me.publisher_id AND editions.type_id = me.type_id ... This describes the relationship from C to C, where the C table refers to a publisher and a type (e.g. "paperback"): =head4 Multiple groups of simple equality conditions As is the default in L, the key-value pairs will be Ced in the resulting C clause. An C can be achieved with an arrayref. For example a condition like: My::Schema::Item->has_many( related_item_links => My::Schema::Item::Links, [ { 'foreign.left_itemid' => 'self.id' }, { 'foreign.right_itemid' => 'self.id' }, ], ); will translate to the following C clause: ... FROM item me JOIN item_relations related_item_links ON related_item_links.left_itemid = me.id OR related_item_links.right_itemid = me.id ... This describes the relationship from C to C, where C is a many-to-many linking table, linking items back to themselves in a peer fashion (without a "parent-child" designation) =head4 Custom join conditions NOTE: The custom join condition specification mechanism is capable of generating JOIN clauses of virtually unlimited complexity. This may limit your ability to traverse some of the more involved relationship chains the way you expect, *and* may bring your RDBMS to its knees. Exercise care when declaring relationships as described here. To specify joins which describe more than a simple equality of column values, the custom join condition coderef syntax can be used. For example: My::Schema::Artist->has_many( cds_80s => 'My::Schema::CD', sub { my $args = shift; return { "$args->{foreign_alias}.artist" => { -ident => "$args->{self_alias}.artistid" }, "$args->{foreign_alias}.year" => { '>', "1979", '<', "1990" }, }; } ); ... $artist_rs->search_related('cds_80s')->next; will result in the C clause: ... FROM artist me LEFT JOIN cd cds_80s ON cds_80s.artist = me.artistid AND cds_80s.year < ? AND cds_80s.year > ? with the bind values: '1990', '1979' C<< $args->{foreign_alias} >> and C<< $args->{self_alias} >> are supplied the same values that would be otherwise substituted for C and C in the simple hashref syntax case. The coderef is expected to return a valid L query-structure, just like what one would supply as the first argument to L. The return value will be passed directly to L and the resulting SQL will be used verbatim as the C clause of the C statement associated with this relationship. While every coderef-based condition must return a valid C clause, it may elect to additionally return a simplified B join-free condition consisting of a hashref with B. This boils down to two scenarios: =over =item * When relationship resolution is invoked after C<< $result->$rel_name >>, as opposed to C<< $rs->related_resultset($rel_name) >>, the C<$result> object is passed to the coderef as C<< $args->{self_result_object} >>. =item * Alternatively when the user-space invokes resolution via C<< $result->set_from_related( $rel_name => $foreign_values_or_object ) >>, the corresponding data is passed to the coderef as C<< $args->{foreign_values} >>, B in the form of a hashref. If a foreign result object is supplied (which is valid usage of L), its values will be extracted into hashref form by calling L. =back Note that the above scenarios are mutually exclusive, that is you will be supplied none or only one of C and C. In other words if you define your condition coderef as: sub { my $args = shift; return ( { "$args->{foreign_alias}.artist" => { -ident => "$args->{self_alias}.artistid" }, "$args->{foreign_alias}.year" => { '>', "1979", '<', "1990" }, }, ! $args->{self_result_object} ? () : { "$args->{foreign_alias}.artist" => $args->{self_result_object}->artistid, "$args->{foreign_alias}.year" => { '>', "1979", '<', "1990" }, }, ! $args->{foreign_values} ? () : { "$args->{self_alias}.artistid" => $args->{foreign_values}{artist}, } ); } Then this code: my $artist = $schema->resultset("Artist")->find({ id => 4 }); $artist->cds_80s->all; Can skip a C altogether and instead produce: SELECT cds_80s.cdid, cds_80s.artist, cds_80s.title, cds_80s.year, cds_80s.genreid, cds_80s.single_track FROM cd cds_80s WHERE cds_80s.artist = ? AND cds_80s.year < ? AND cds_80s.year > ? With the bind values: '4', '1990', '1979' While this code: my $cd = $schema->resultset("CD")->search({ artist => 1 }, { rows => 1 })->single; my $artist = $schema->resultset("Artist")->new({}); $artist->set_from_related('cds_80s'); Will properly set the C<< $artist->artistid >> field of this new object to C<1> Note that in order to be able to use L (and by extension L<< $result->create_related|DBIx::Class::Relationship::Base/create_related >>), the returned join free condition B contain only plain values/deflatable objects. For instance the C constraint in the above example prevents the relationship from being used to create related objects using C<< $artst->create_related( cds_80s => { title => 'blah' } ) >> (an exception will be thrown). In order to allow the user to go truly crazy when generating a custom C clause, the C<$args> hashref passed to the subroutine contains some extra metadata. Currently the supplied coderef is executed as: $relationship_info->{cond}->({ self_resultsource => The resultsource instance on which rel_name is registered rel_name => The relationship name (does *NOT* always match foreign_alias) self_alias => The alias of the invoking resultset foreign_alias => The alias of the to-be-joined resultset (does *NOT* always match rel_name) # only one of these (or none at all) will ever be supplied to aid in the # construction of a join-free condition self_result_object => The invocant *object* itself in case of a call like $result_object->$rel_name( ... ) foreign_values => A *hashref* of related data: may be passed in directly or derived via ->get_columns() from a related object in case of $result_object->set_from_related( $rel_name, $foreign_result_object ) # deprecated inconsistent names, will be forever available for legacy code self_rowobj => Old deprecated slot for self_result_object foreign_relname => Old deprecated slot for rel_name }); =head3 attributes The L may be used as relationship attributes. In particular, the 'where' attribute is useful for filtering relationships: __PACKAGE__->has_many( 'valid_users', 'MyApp::Schema::User', { 'foreign.user_id' => 'self.user_id' }, { where => { valid => 1 } } ); The following attributes are also valid: =over 4 =item join_type Explicitly specifies the type of join to use in the relationship. Any SQL join type is valid, e.g. C or C. It will be placed in the SQL command immediately before C. =item proxy =E $column | \@columns | \%column The 'proxy' attribute can be used to retrieve values, and to perform updates if the relationship has 'cascade_update' set. The 'might_have' and 'has_one' relationships have this set by default; if you want a proxy to update across a 'belongs_to' relationship, you must set the attribute yourself. =over 4 =item \@columns An arrayref containing a list of accessors in the foreign class to create in the main class. If, for example, you do the following: MyApp::Schema::CD->might_have(liner_notes => 'MyApp::Schema::LinerNotes', undef, { proxy => [ qw/notes/ ], }); Then, assuming MyApp::Schema::LinerNotes has an accessor named notes, you can do: my $cd = MyApp::Schema::CD->find(1); $cd->notes('Notes go here'); # set notes -- LinerNotes object is # created if it doesn't exist For a 'belongs_to relationship, note the 'cascade_update': MyApp::Schema::Track->belongs_to( cd => 'MyApp::Schema::CD', 'cd, { proxy => ['title'], cascade_update => 1 } ); $track->title('New Title'); $track->update; # updates title in CD =item \%column A hashref where each key is the accessor you want installed in the main class, and its value is the name of the original in the foreign class. MyApp::Schema::Track->belongs_to( cd => 'MyApp::Schema::CD', 'cd', { proxy => { cd_title => 'title' }, }); This will create an accessor named C on the C<$track> result object. =back NOTE: you can pass a nested struct too, for example: MyApp::Schema::Track->belongs_to( cd => 'MyApp::Schema::CD', 'cd', { proxy => [ 'year', { cd_title => 'title' } ], }); =item accessor Specifies the type of accessor that should be created for the relationship. Valid values are C (for when there is only a single related object), C (when there can be many), and C (for when there is a single related object, but you also want the relationship accessor to double as a column accessor). For C accessors, an add_to_* method is also created, which calls C for the relationship. =item is_foreign_key_constraint If you are using L to create SQL for you and you find that it is creating constraints where it shouldn't, or not creating them where it should, set this attribute to a true or false value to override the detection of when to create constraints. =item cascade_copy If C is true on a C relationship for an object, then when you copy the object all the related objects will be copied too. To turn this behaviour off, pass C<< cascade_copy => 0 >> in the C<$attr> hashref. The behaviour defaults to C<< cascade_copy => 1 >> for C relationships. =item cascade_delete By default, DBIx::Class cascades deletes across C, C and C relationships. You can disable this behaviour on a per-relationship basis by supplying C<< cascade_delete => 0 >> in the relationship attributes. The cascaded operations are performed after the requested delete, so if your database has a constraint on the relationship, it will have deleted/updated the related records or raised an exception before DBIx::Class gets to perform the cascaded operation. =item cascade_update By default, DBIx::Class cascades updates across C and C relationships. You can disable this behaviour on a per-relationship basis by supplying C<< cascade_update => 0 >> in the relationship attributes. The C relationship does not update across relationships by default, so if you have a 'proxy' attribute on a belongs_to and want to use 'update' on it, you must set C<< cascade_update => 1 >>. This is not a RDMS style cascade update - it purely means that when an object has update called on it, all the related objects also have update called. It will not change foreign keys automatically - you must arrange to do this yourself. =item on_delete / on_update If you are using L to create SQL for you, you can use these attributes to explicitly set the desired C or C constraint type. If not supplied the SQLT parser will attempt to infer the constraint type by interrogating the attributes of the B relationship. For any 'multi' relationship with C<< cascade_delete => 1 >>, the corresponding belongs_to relationship will be created with an C constraint. For any relationship bearing C<< cascade_copy => 1 >> the resulting belongs_to constraint will be C. If you wish to disable this autodetection, and just use the RDBMS' default constraint type, pass C<< on_delete => undef >> or C<< on_delete => '' >>, and the same for C respectively. =item is_deferrable Tells L that the foreign key constraint it creates should be deferrable. In other words, the user may request that the constraint be ignored until the end of the transaction. Currently, only the PostgreSQL producer actually supports this. =item add_fk_index Tells L to add an index for this constraint. Can also be specified globally in the args to L or L. Default is on, set to 0 to disable. =back =head2 register_relationship =over 4 =item Arguments: $rel_name, $rel_info =back Registers a relationship on the class. This is called internally by DBIx::Class::ResultSourceProxy to set up Accessors and Proxies. =cut sub register_relationship { } =head2 related_resultset =over 4 =item Arguments: $rel_name =item Return Value: L<$related_resultset|DBIx::Class::ResultSet> =back $rs = $cd->related_resultset('artist'); Returns a L for the relationship named $rel_name. =head2 $relationship_accessor =over 4 =item Arguments: none =item Return Value: L<$result|DBIx::Class::Manual::ResultClass> | L<$related_resultset|DBIx::Class::ResultSet> | undef =back # These pairs do the same thing $result = $cd->related_resultset('artist')->single; # has_one relationship $result = $cd->artist; $rs = $cd->related_resultset('tracks'); # has_many relationship $rs = $cd->tracks; This is the recommended way to traverse through relationships, based on the L name given in the relationship definition. This will return either a L or a L, depending on if the relationship is C (returns only one row) or C (returns many rows). The method may also return C if the relationship doesn't exist for this instance (like in the case of C relationships). =cut sub related_resultset { my $self = shift; $self->throw_exception("Can't call *_related as class methods") unless ref $self; my $rel = shift; return $self->{related_resultsets}{$rel} if defined $self->{related_resultsets}{$rel}; return $self->{related_resultsets}{$rel} = do { my $rsrc = $self->result_source; my $rel_info = $rsrc->relationship_info($rel) or $self->throw_exception( "No such relationship '$rel'" ); my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {}); $attrs = { %{$rel_info->{attrs} || {}}, %$attrs }; $self->throw_exception( "Invalid query: @_" ) if (@_ > 1 && (@_ % 2 == 1)); my $query = ((@_ > 1) ? {@_} : shift); # condition resolution may fail if an incomplete master-object prefetch # is encountered - that is ok during prefetch construction (not yet in_storage) my ($cond, $is_crosstable) = try { $rsrc->_resolve_condition( $rel_info->{cond}, $rel, $self, $rel ) } catch { $self->throw_exception ($_) if $self->in_storage; UNRESOLVABLE_CONDITION; # RV, no return() }; # keep in mind that the following if() block is part of a do{} - no return()s!!! if ($is_crosstable and ref $rel_info->{cond} eq 'CODE') { # A WHOREIFFIC hack to reinvoke the entire condition resolution # with the correct alias. Another way of doing this involves a # lot of state passing around, and the @_ positions are already # mapped out, making this crap a less icky option. # # The point of this exercise is to retain the spirit of the original # $obj->search_related($rel) where the resulting rset will have the # root alias as 'me', instead of $rel (as opposed to invoking # $rs->search_related) # make the fake 'me' rel local $rsrc->{_relationships}{me} = { %{ $rsrc->{_relationships}{$rel} }, _original_name => $rel, }; my $obj_table_alias = lc($rsrc->source_name) . '__row'; $obj_table_alias =~ s/\W+/_/g; $rsrc->resultset->search( $self->ident_condition($obj_table_alias), { alias => $obj_table_alias }, )->search_related('me', $query, $attrs) } else { # FIXME - this conditional doesn't seem correct - got to figure out # at some point what it does. Also the entire UNRESOLVABLE_CONDITION # business seems shady - we could simply not query *at all* if ($cond eq UNRESOLVABLE_CONDITION) { my $reverse = $rsrc->reverse_relationship_info($rel); foreach my $rev_rel (keys %$reverse) { if ($reverse->{$rev_rel}{attrs}{accessor} && $reverse->{$rev_rel}{attrs}{accessor} eq 'multi') { weaken($attrs->{related_objects}{$rev_rel}[0] = $self); } else { weaken($attrs->{related_objects}{$rev_rel} = $self); } } } elsif (ref $cond eq 'ARRAY') { $cond = [ map { if (ref $_ eq 'HASH') { my $hash; foreach my $key (keys %$_) { my $newkey = $key !~ /\./ ? "me.$key" : $key; $hash->{$newkey} = $_->{$key}; } $hash; } else { $_; } } @$cond ]; } elsif (ref $cond eq 'HASH') { foreach my $key (grep { ! /\./ } keys %$cond) { $cond->{"me.$key"} = delete $cond->{$key}; } } $query = ($query ? { '-and' => [ $cond, $query ] } : $cond); $rsrc->related_source($rel)->resultset->search( $query, $attrs ); } }; } =head2 search_related =over 4 =item Arguments: $rel_name, $cond?, L<\%attrs?|DBIx::Class::ResultSet/ATTRIBUTES> =item Return Value: L<$resultset|DBIx::Class::ResultSet> (scalar context) | L<@result_objs|DBIx::Class::Manual::ResultClass> (list context) =back Run a search on a related resultset. The search will be restricted to the results represented by the L it was called upon. See L for more information. =cut sub search_related { return shift->related_resultset(shift)->search(@_); } =head2 search_related_rs This method works exactly the same as search_related, except that it guarantees a resultset, even in list context. =cut sub search_related_rs { return shift->related_resultset(shift)->search_rs(@_); } =head2 count_related =over 4 =item Arguments: $rel_name, $cond?, L<\%attrs?|DBIx::Class::ResultSet/ATTRIBUTES> =item Return Value: $count =back Returns the count of all the rows in the related resultset, restricted by the current result or where conditions. =cut sub count_related { shift->search_related(@_)->count; } =head2 new_related =over 4 =item Arguments: $rel_name, \%col_data =item Return Value: L<$result|DBIx::Class::Manual::ResultClass> =back Create a new result object of the related foreign class. It will magically set any foreign key columns of the new object to the related primary key columns of the source object for you. The newly created result will not be saved into your storage until you call L on it. =cut sub new_related { my ($self, $rel, $data) = @_; return $self->search_related($rel)->new_result( $self->result_source->_resolve_relationship_condition ( infer_values_based_on => $data, rel_name => $rel, self_result_object => $self, foreign_alias => $rel, self_alias => 'me', )->{inferred_values} ); } =head2 create_related =over 4 =item Arguments: $rel_name, \%col_data =item Return Value: L<$result|DBIx::Class::Manual::ResultClass> =back my $result = $obj->create_related($rel_name, \%col_data); Creates a new result object, similarly to new_related, and also inserts the result's data into your storage medium. See the distinction between C and C in L for details. =cut sub create_related { my $self = shift; my $rel = shift; my $obj = $self->new_related($rel, @_)->insert; delete $self->{related_resultsets}->{$rel}; return $obj; } =head2 find_related =over 4 =item Arguments: $rel_name, \%col_data | @pk_values, { key => $unique_constraint, L<%attrs|DBIx::Class::ResultSet/ATTRIBUTES> }? =item Return Value: L<$result|DBIx::Class::Manual::ResultClass> | undef =back my $result = $obj->find_related($rel_name, \%col_data); Attempt to find a related object using its primary key or unique constraints. See L for details. =cut sub find_related { #my ($self, $rel, @args) = @_; return shift->search_related(shift)->find(@_); } =head2 find_or_new_related =over 4 =item Arguments: $rel_name, \%col_data, { key => $unique_constraint, L<%attrs|DBIx::Class::ResultSet/ATTRIBUTES> }? =item Return Value: L<$result|DBIx::Class::Manual::ResultClass> =back Find a result object of a related class. See L for details. =cut sub find_or_new_related { my $self = shift; my $obj = $self->find_related(@_); return defined $obj ? $obj : $self->new_related(@_); } =head2 find_or_create_related =over 4 =item Arguments: $rel_name, \%col_data, { key => $unique_constraint, L<%attrs|DBIx::Class::ResultSet/ATTRIBUTES> }? =item Return Value: L<$result|DBIx::Class::Manual::ResultClass> =back Find or create a result object of a related class. See L for details. =cut sub find_or_create_related { my $self = shift; my $obj = $self->find_related(@_); return (defined($obj) ? $obj : $self->create_related(@_)); } =head2 update_or_create_related =over 4 =item Arguments: $rel_name, \%col_data, { key => $unique_constraint, L<%attrs|DBIx::Class::ResultSet/ATTRIBUTES> }? =item Return Value: L<$result|DBIx::Class::Manual::ResultClass> =back Update or create a result object of a related class. See L for details. =cut sub update_or_create_related { #my ($self, $rel, @args) = @_; shift->related_resultset(shift)->update_or_create(@_); } =head2 set_from_related =over 4 =item Arguments: $rel_name, L<$result|DBIx::Class::Manual::ResultClass> =item Return Value: not defined =back $book->set_from_related('author', $author_obj); $book->author($author_obj); ## same thing Set column values on the current object, using related values from the given related object. This is used to associate previously separate objects, for example, to set the correct author for a book, find the Author object, then call set_from_related on the book. This is called internally when you pass existing objects as values to L, or pass an object to a belongs_to accessor. The columns are only set in the local copy of the object, call L to update them in the storage. =cut sub set_from_related { my ($self, $rel, $f_obj) = @_; $self->set_columns( $self->result_source->_resolve_relationship_condition ( infer_values_based_on => {}, rel_name => $rel, foreign_values => $f_obj, foreign_alias => $rel, self_alias => 'me', )->{inferred_values} ); return 1; } =head2 update_from_related =over 4 =item Arguments: $rel_name, L<$result|DBIx::Class::Manual::ResultClass> =item Return Value: not defined =back $book->update_from_related('author', $author_obj); The same as L, but the changes are immediately updated in storage. =cut sub update_from_related { my $self = shift; $self->set_from_related(@_); $self->update; } =head2 delete_related =over 4 =item Arguments: $rel_name, $cond?, L<\%attrs?|DBIx::Class::ResultSet/ATTRIBUTES> =item Return Value: $underlying_storage_rv =back Delete any related row, subject to the given conditions. Internally, this calls: $self->search_related(@_)->delete And returns the result of that. =cut sub delete_related { my $self = shift; my $obj = $self->search_related(@_)->delete; delete $self->{related_resultsets}->{$_[0]}; return $obj; } =head2 add_to_$rel B, C and 'multi' type relationships.> =head3 has_many / multi =over 4 =item Arguments: \%col_data =item Return Value: L<$result|DBIx::Class::Manual::ResultClass> =back Creates/inserts a new result object. Internally, this calls: $self->create_related($rel, @_) And returns the result of that. =head3 many_to_many =over 4 =item Arguments: (\%col_data | L<$result|DBIx::Class::Manual::ResultClass>), \%link_col_data? =item Return Value: L<$result|DBIx::Class::Manual::ResultClass> =back my $role = $schema->resultset('Role')->find(1); $actor->add_to_roles($role); # creates a My::DBIC::Schema::ActorRoles linking table result object $actor->add_to_roles({ name => 'lead' }, { salary => 15_000_000 }); # creates a new My::DBIC::Schema::Role result object and the linking table # object with an extra column in the link Adds a linking table object. If the first argument is a hash reference, the related object is created first with the column values in the hash. If an object reference is given, just the linking table object is created. In either case, any additional column values for the linking table object can be specified in C<\%link_col_data>. See L for additional details. =head2 set_$rel B relationships.> =over 4 =item Arguments: (\@hashrefs_of_col_data | L<\@result_objs|DBIx::Class::Manual::ResultClass>), $link_vals? =item Return Value: not defined =back my $actor = $schema->resultset('Actor')->find(1); my @roles = $schema->resultset('Role')->search({ role => { '-in' => ['Fred', 'Barney'] } } ); $actor->set_roles(\@roles); # Replaces all of $actor's previous roles with the two named $actor->set_roles(\@roles, { salary => 15_000_000 }); # Sets a column in the link table for all roles Replace all the related objects with the given reference to a list of objects. This does a C B to remove the association between the current object and all related objects, then calls C repeatedly to link all the new objects. Note that this means that this method will B delete any objects in the table on the right side of the relation, merely that it will delete the link between them. Due to a mistake in the original implementation of this method, it will also accept a list of objects or hash references. This is B and will be removed in a future version. =head2 remove_from_$rel B relationships.> =over 4 =item Arguments: L<$result|DBIx::Class::Manual::ResultClass> =item Return Value: not defined =back my $role = $schema->resultset('Role')->find(1); $actor->remove_from_roles($role); # removes $role's My::DBIC::Schema::ActorRoles linking table result object Removes the link between the current object and the related object. Note that the related object itself won't be deleted unless you call ->delete() on it. This method just removes the link between the two objects. =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. =cut 1; DBIx-Class-0.082843/lib/DBIx/Class/Relationship/Helpers.pm0000644000175000017500000000041612756537025022122 0ustar rabbitrabbitpackage # hide from PAUSE DBIx::Class::Relationship::Helpers; use strict; use warnings; use base qw/DBIx::Class/; __PACKAGE__->load_components(qw/ Relationship::HasMany Relationship::HasOne Relationship::BelongsTo Relationship::ManyToMany /); 1; DBIx-Class-0.082843/lib/DBIx/Class/Relationship/BelongsTo.pm0000644000175000017500000000504414240132261022375 0ustar rabbitrabbitpackage # hide from PAUSE DBIx::Class::Relationship::BelongsTo; # Documentation for these methods can be found in # DBIx::Class::Relationship use strict; use warnings; use Try::Tiny; use namespace::clean; our %_pod_inherit_config = ( class_map => { 'DBIx::Class::Relationship::BelongsTo' => 'DBIx::Class::Relationship' } ); sub belongs_to { my ($class, $rel, $f_class, $cond, $attrs) = @_; # assume a foreign key constraint unless defined otherwise $attrs->{is_foreign_key_constraint} = 1 if not exists $attrs->{is_foreign_key_constraint}; $attrs->{undef_on_null_fk} = 1 if not exists $attrs->{undef_on_null_fk}; # no join condition or just a column name if (!ref $cond) { my ($f_key, $guess); if (defined $cond and length $cond) { $f_key = $cond; $guess = "caller specified foreign key '$f_key'"; } else { $f_key = $rel; $guess = "using given relationship name '$rel' as foreign key column name"; } $class->throw_exception( "No such column '$f_key' declared yet on ${class} ($guess)" ) unless $class->has_column($f_key); $class->ensure_class_loaded($f_class); my $f_rsrc = try { $f_class->result_source_instance; } catch { $class->throw_exception( "Foreign class '$f_class' does not seem to be a Result class " . "(or it simply did not load entirely due to a circular relation chain)" ); }; my $pri = $f_rsrc->_single_pri_col_or_die; $cond = { "foreign.${pri}" => "self.${f_key}" }; } # explicit join condition else { if (ref $cond eq 'HASH') { # ARRAY is also valid my $cond_rel; # FIXME This loop is ridiculously incomplete and dangerous # staving off changes until implmentation of the swindon consensus for (keys %$cond) { if (m/\./) { # Explicit join condition $cond_rel = $cond; last; } $cond_rel->{"foreign.$_"} = "self.".$cond->{$_}; } $cond = $cond_rel; } } my $acc_type = ( ref $cond eq 'HASH' and keys %$cond == 1 and (keys %$cond)[0] =~ /^foreign\./ and $class->has_column($rel) ) ? 'filter' : 'single'; my $fk_columns = ($acc_type eq 'single' and ref $cond eq 'HASH') ? { map { $_ =~ /^self\.(.+)/ ? ( $1 => 1 ) : () } (values %$cond ) } : undef ; $class->add_relationship($rel, $f_class, $cond, { is_depends_on => 1, accessor => $acc_type, $fk_columns ? ( fk_columns => $fk_columns ) : (), %{$attrs || {}} } ); return 1; } 1; DBIx-Class-0.082843/lib/DBIx/Class/Exception.pm0000644000175000017500000000446014240132261017777 0ustar rabbitrabbitpackage DBIx::Class::Exception; use strict; use warnings; # load Carp early to prevent tickling of the ::Internal stash being # interpreted as "Carp is already loaded" by some braindead loader use Carp (); $Carp::Internal{ (__PACKAGE__) }++; use DBIx::Class::Carp (); use overload '""' => sub { shift->{msg} }, fallback => 1; =head1 NAME DBIx::Class::Exception - Exception objects for DBIx::Class =head1 DESCRIPTION Exception objects of this class are used internally by the default error handling of L and derivatives. These objects stringify to the contained error message, and use overload fallback to give natural boolean/numeric values. =head1 METHODS =head2 throw =over 4 =item Arguments: $exception_scalar, $stacktrace =back This is meant for internal use by L's C code, and shouldn't be used directly elsewhere. Expects a scalar exception message. The optional boolean C<$stacktrace> causes it to output a full trace similar to L. DBIx::Class::Exception->throw('Foo'); try { ... } catch { DBIx::Class::Exception->throw(shift) } =cut sub throw { my ($class, $msg, $stacktrace) = @_; # Don't re-encapsulate exception objects of any kind die $msg if ref($msg); # all exceptions include a caller $msg =~ s/\n$//; if(!$stacktrace) { # skip all frames that match the original caller, or any of # the dbic-wide classdata patterns my ($ln, $calling) = DBIx::Class::Carp::__find_caller( '^' . caller() . '$', 'DBIx::Class', ); $msg = "${calling}${msg} ${ln}\n"; } else { $msg = Carp::longmess($msg); } my $self = { msg => $msg }; bless $self => $class; die $self; } =head2 rethrow This method provides some syntactic sugar in order to re-throw exceptions. =cut sub rethrow { die shift; } =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. =cut 1; DBIx-Class-0.082843/lib/DBIx/Class/Schema/0000755000175000017500000000000014240676463016720 5ustar rabbitrabbitDBIx-Class-0.082843/lib/DBIx/Class/Schema/Versioned.pm0000644000175000017500000005244114240132261021201 0ustar rabbitrabbitpackage # Hide from PAUSE DBIx::Class::Version::Table; use base 'DBIx::Class::Core'; use strict; use warnings; __PACKAGE__->table('dbix_class_schema_versions'); __PACKAGE__->add_columns ( 'version' => { 'data_type' => 'VARCHAR', 'is_auto_increment' => 0, 'default_value' => undef, 'is_foreign_key' => 0, 'name' => 'version', 'is_nullable' => 0, 'size' => '10' }, 'installed' => { 'data_type' => 'VARCHAR', 'is_auto_increment' => 0, 'default_value' => undef, 'is_foreign_key' => 0, 'name' => 'installed', 'is_nullable' => 0, 'size' => '20' }, ); __PACKAGE__->set_primary_key('version'); package # Hide from PAUSE DBIx::Class::Version::TableCompat; use base 'DBIx::Class::Core'; __PACKAGE__->table('SchemaVersions'); __PACKAGE__->add_columns ( 'Version' => { 'data_type' => 'VARCHAR', }, 'Installed' => { 'data_type' => 'VARCHAR', }, ); __PACKAGE__->set_primary_key('Version'); package # Hide from PAUSE DBIx::Class::Version; use base 'DBIx::Class::Schema'; use strict; use warnings; __PACKAGE__->register_class('Table', 'DBIx::Class::Version::Table'); package # Hide from PAUSE DBIx::Class::VersionCompat; use base 'DBIx::Class::Schema'; use strict; use warnings; __PACKAGE__->register_class('TableCompat', 'DBIx::Class::Version::TableCompat'); # --------------------------------------------------------------------------- =head1 NAME DBIx::Class::Schema::Versioned - DBIx::Class::Schema plugin for Schema upgrades =head1 SYNOPSIS package MyApp::Schema; use base qw/DBIx::Class::Schema/; our $VERSION = 0.001; # load MyApp::Schema::CD, MyApp::Schema::Book, MyApp::Schema::DVD __PACKAGE__->load_classes(qw/CD Book DVD/); __PACKAGE__->load_components(qw/Schema::Versioned/); __PACKAGE__->upgrade_directory('/path/to/upgrades/'); =head1 DESCRIPTION This module provides methods to apply DDL changes to your database using SQL diff files. Normally these diff files would be created using L. A table called I is created and maintained by the module. This is used to determine which version your database is currently at. Similarly the $VERSION in your DBIC schema class is used to determine the current DBIC schema version. The upgrade is initiated manually by calling C on your schema object, this will attempt to upgrade the database from its current version to the current schema version using a diff from your I. If a suitable diff is not found then no upgrade is possible. =head1 SEE ALSO L is a much more powerful alternative to this module. Examples of things it can do that this module cannot do include =over =item * Downgrades in addition to upgrades =item * Multiple sql files per upgrade/downgrade/install =item * Perl scripts allowed for upgrade/downgrade/install =item * Just one set of files needed for upgrade, unlike this module where one might need to generate C =back =head1 GETTING STARTED Firstly you need to setup your schema class as per the L, make sure you have specified an upgrade_directory and an initial $VERSION. Then you'll need two scripts, one to create DDL files and diffs and another to perform upgrades. Your creation script might look like a bit like this: use strict; use Pod::Usage; use Getopt::Long; use MyApp::Schema; my ( $preversion, $help ); GetOptions( 'p|preversion:s' => \$preversion, ) or die pod2usage; my $schema = MyApp::Schema->connect( $dsn, $user, $password, ); my $sql_dir = './sql'; my $version = $schema->schema_version(); $schema->create_ddl_dir( 'MySQL', $version, $sql_dir, $preversion ); Then your upgrade script might look like so: use strict; use MyApp::Schema; my $schema = MyApp::Schema->connect( $dsn, $user, $password, ); if (!$schema->get_db_version()) { # schema is unversioned $schema->deploy(); } else { $schema->upgrade(); } The script above assumes that if the database is unversioned then it is empty and we can safely deploy the DDL to it. However things are not always so simple. if you want to initialise a pre-existing database where the DDL is not the same as the DDL for your current schema version then you will need a diff which converts the database's DDL to the current DDL. The best way to do this is to get a dump of the database schema (without data) and save that in your SQL directory as version 0.000 (the filename must be as with L) then create a diff using your create DDL script given above from version 0.000 to the current version. Then hand check and if necessary edit the resulting diff to ensure that it will apply. Once you have done all that you can do this: if (!$schema->get_db_version()) { # schema is unversioned $schema->install("0.000"); } # this will now apply the 0.000 to current version diff $schema->upgrade(); In the case of an unversioned database the above code will create the dbix_class_schema_versions table and write version 0.000 to it, then upgrade will then apply the diff we talked about creating in the previous paragraph and then you're good to go. =cut package DBIx::Class::Schema::Versioned; use strict; use warnings; use base 'DBIx::Class::Schema'; use DBIx::Class::Carp; use Time::HiRes qw/gettimeofday/; use Try::Tiny; use Scalar::Util 'weaken'; use namespace::clean; __PACKAGE__->mk_classdata('_filedata'); __PACKAGE__->mk_classdata('upgrade_directory'); __PACKAGE__->mk_classdata('backup_directory'); __PACKAGE__->mk_classdata('do_backup'); __PACKAGE__->mk_classdata('do_diff_on_init'); =head1 METHODS =head2 upgrade_directory Use this to set the directory your upgrade files are stored in. =head2 backup_directory Use this to set the directory you want your backups stored in (note that backups are disabled by default). =cut =head2 install =over 4 =item Arguments: $db_version =back Call this to initialise a previously unversioned database. The table 'dbix_class_schema_versions' will be created which will be used to store the database version. Takes one argument which should be the version that the database is currently at. Defaults to the return value of L. See L for more details. =cut sub install { my ($self, $new_version) = @_; # must be called on a fresh database if ($self->get_db_version()) { $self->throw_exception("A versioned schema has already been deployed, try upgrade instead.\n"); } # default to current version if none passed $new_version ||= $self->schema_version(); if ($new_version) { # create versions table and version row $self->{vschema}->deploy; $self->_set_db_version({ version => $new_version }); } } =head2 deploy Same as L but also calls C. =cut sub deploy { my $self = shift; $self->next::method(@_); $self->install(); } =head2 create_upgrade_path =over 4 =item Arguments: { upgrade_file => $file } =back Virtual method that should be overridden to create an upgrade file. This is useful in the case of upgrading across multiple versions to concatenate several files to create one upgrade file. You'll probably want the db_version retrieved via $self->get_db_version and the schema_version which is retrieved via $self->schema_version =cut sub create_upgrade_path { ## override this method } =head2 ordered_schema_versions =over 4 =item Return Value: a list of version numbers, ordered from lowest to highest =back Virtual method that should be overridden to return an ordered list of schema versions. This is then used to produce a set of steps to upgrade through to achieve the required schema version. You may want the db_version retrieved via $self->get_db_version and the schema_version which is retrieved via $self->schema_version =cut sub ordered_schema_versions { ## override this method } =head2 upgrade Call this to attempt to upgrade your database from the version it is at to the version this DBIC schema is at. If they are the same it does nothing. It will call L to retrieve an ordered list of schema versions (if ordered_schema_versions returns nothing then it is assumed you can do the upgrade as a single step). It then iterates through the list of versions between the current db version and the schema version applying one update at a time until all relevant updates are applied. The individual update steps are performed by using L, which will apply the update and also update the dbix_class_schema_versions table. =cut sub upgrade { my ($self) = @_; my $db_version = $self->get_db_version(); # db unversioned unless ($db_version) { carp 'Upgrade not possible as database is unversioned. Please call install first.'; return; } # db and schema at same version. do nothing if ( $db_version eq $self->schema_version ) { carp 'Upgrade not necessary'; return; } my @version_list = $self->ordered_schema_versions; # if nothing returned then we preload with min/max @version_list = ( $db_version, $self->schema_version ) unless ( scalar(@version_list) ); # catch the case of someone returning an arrayref @version_list = @{ $version_list[0] } if ( ref( $version_list[0] ) eq 'ARRAY' ); # remove all versions in list above the required version while ( scalar(@version_list) && ( $version_list[-1] ne $self->schema_version ) ) { pop @version_list; } # remove all versions in list below the current version while ( scalar(@version_list) && ( $version_list[0] ne $db_version ) ) { shift @version_list; } # check we have an appropriate list of versions if ( scalar(@version_list) < 2 ) { die; } # do sets of upgrade while ( scalar(@version_list) >= 2 ) { $self->upgrade_single_step( $version_list[0], $version_list[1] ); shift @version_list; } } =head2 upgrade_single_step =over 4 =item Arguments: db_version - the version currently within the db =item Arguments: target_version - the version to upgrade to =back Call this to attempt to upgrade your database from the I to the I. If they are the same it does nothing. It requires an SQL diff file to exist in your I, normally you will have created this using L. If successful the dbix_class_schema_versions table is updated with the I. This method may be called repeatedly by the upgrade method to upgrade through a series of updates. =cut sub upgrade_single_step { my ($self, $db_version, $target_version) = @_; # db and schema at same version. do nothing if ($db_version eq $target_version) { carp 'Upgrade not necessary'; return; } # strangely the first time this is called can # differ to subsequent times. so we call it # here to be sure. # XXX - just fix it $self->storage->sqlt_type; my $upgrade_file = $self->ddl_filename( $self->storage->sqlt_type, $target_version, $self->upgrade_directory, $db_version, ); $self->create_upgrade_path({ upgrade_file => $upgrade_file }); unless (-f $upgrade_file) { carp "Upgrade not possible, no upgrade file found ($upgrade_file), please create one"; return; } carp "DB version ($db_version) is lower than the schema version (".$self->schema_version."). Attempting upgrade.\n"; # backup if necessary then apply upgrade $self->_filedata($self->_read_sql_file($upgrade_file)); $self->backup() if($self->do_backup); $self->txn_do(sub { $self->do_upgrade() }); # set row in dbix_class_schema_versions table $self->_set_db_version({version => $target_version}); } =head2 do_upgrade This is an overwritable method used to run your upgrade. The freeform method allows you to run your upgrade any way you please, you can call C any number of times to run the actual SQL commands, and in between you can sandwich your data upgrading. For example, first run all the B commands, then migrate your data from old to new tables/formats, then issue the DROP commands when you are finished. Will run the whole file as it is by default. =cut sub do_upgrade { my ($self) = @_; # just run all the commands (including inserts) in order $self->run_upgrade(qr/.*?/); } =head2 run_upgrade $self->run_upgrade(qr/create/i); Runs a set of SQL statements matching a passed in regular expression. The idea is that this method can be called any number of times from your C method, running whichever commands you specify via the regex in the parameter. Probably won't work unless called from the overridable do_upgrade method. =cut sub run_upgrade { my ($self, $stm) = @_; return unless ($self->_filedata); my @statements = grep { $_ =~ $stm } @{$self->_filedata}; $self->_filedata([ grep { $_ !~ /$stm/i } @{$self->_filedata} ]); for (@statements) { $self->storage->debugobj->query_start($_) if $self->storage->debug; $self->apply_statement($_); $self->storage->debugobj->query_end($_) if $self->storage->debug; } return 1; } =head2 apply_statement Takes an SQL statement and runs it. Override this if you want to handle errors differently. =cut sub apply_statement { my ($self, $statement) = @_; $self->storage->dbh->do($_) or carp "SQL was: $_"; } =head2 get_db_version Returns the version that your database is currently at. This is determined by the values in the dbix_class_schema_versions table that C and C write to. =cut sub get_db_version { my ($self, $rs) = @_; my $vtable = $self->{vschema}->resultset('Table'); my $version = try { $vtable->search({}, { order_by => { -desc => 'installed' }, rows => 1 } ) ->get_column ('version') ->next; }; return $version || 0; } =head2 schema_version Returns the current schema class' $VERSION =cut =head2 backup This is an overwritable method which is called just before the upgrade, to allow you to make a backup of the database. Per default this method attempts to call C<< $self->storage->backup >>, to run the standard backup on each database type. This method should return the name of the backup file, if appropriate.. This method is disabled by default. Set $schema->do_backup(1) to enable it. =cut sub backup { my ($self) = @_; ## Make each ::DBI::Foo do this $self->storage->backup($self->backup_directory()); } =head2 connection Overloaded method. This checks the DBIC schema version against the DB version and warns if they are not the same or if the DB is unversioned. It also provides compatibility between the old versions table (SchemaVersions) and the new one (dbix_class_schema_versions). To avoid the checks on connect, set the environment var DBIC_NO_VERSION_CHECK or alternatively you can set the ignore_version attr in the forth argument like so: my $schema = MyApp::Schema->connect( $dsn, $user, $password, { ignore_version => 1 }, ); =cut sub connection { my $self = shift; $self->next::method(@_); $self->_on_connect(); return $self; } sub _on_connect { my ($self) = @_; weaken (my $w_storage = $self->storage ); $self->{vschema} = DBIx::Class::Version->connect( sub { $w_storage->dbh }, # proxy some flags from the main storage { map { $_ => $w_storage->$_ } qw( unsafe ) }, ); my $conn_attrs = $w_storage->_dbic_connect_attributes || {}; my $vtable = $self->{vschema}->resultset('Table'); # useful when connecting from scripts etc return if ($conn_attrs->{ignore_version} || ($ENV{DBIC_NO_VERSION_CHECK} && !exists $conn_attrs->{ignore_version})); # check for legacy versions table and move to new if exists unless ($self->_source_exists($vtable)) { my $vtable_compat = DBIx::Class::VersionCompat->connect(sub { $w_storage->dbh })->resultset('TableCompat'); if ($self->_source_exists($vtable_compat)) { $self->{vschema}->deploy; map { $vtable->new_result({ installed => $_->Installed, version => $_->Version })->insert } $vtable_compat->all; $self->storage->_get_dbh->do("DROP TABLE " . $vtable_compat->result_source->from); } } my $pversion = $self->get_db_version(); if($pversion eq $self->schema_version) { #carp "This version is already installed"; return 1; } if(!$pversion) { carp "Your DB is currently unversioned. Please call upgrade on your schema to sync the DB."; return 1; } carp "Versions out of sync. This is " . $self->schema_version . ", your database contains version $pversion, please call upgrade on your Schema."; } # is this just a waste of time? if not then merge with DBI.pm sub _create_db_to_schema_diff { my $self = shift; my %driver_to_db_map = ( 'mysql' => 'MySQL' ); my $db = $driver_to_db_map{$self->storage->dbh->{Driver}->{Name}}; unless ($db) { print "Sorry, this is an unsupported DB\n"; return; } unless (DBIx::Class::Optional::Dependencies->req_ok_for ('deploy')) { $self->throw_exception("Unable to proceed without " . DBIx::Class::Optional::Dependencies->req_missing_for ('deploy') ); } my $db_tr = SQL::Translator->new({ add_drop_table => 1, parser => 'DBI', parser_args => { dbh => $self->storage->dbh } }); $db_tr->producer($db); my $dbic_tr = SQL::Translator->new; $dbic_tr->parser('SQL::Translator::Parser::DBIx::Class'); $dbic_tr->data($self); $dbic_tr->producer($db); $db_tr->schema->name('db_schema'); $dbic_tr->schema->name('dbic_schema'); # is this really necessary? foreach my $tr ($db_tr, $dbic_tr) { my $data = $tr->data; $tr->parser->($tr, $$data); } my $diff = SQL::Translator::Diff::schema_diff($db_tr->schema, $db, $dbic_tr->schema, $db, { ignore_constraint_names => 1, ignore_index_names => 1, caseopt => 1 }); my $filename = $self->ddl_filename( $db, $self->schema_version, $self->upgrade_directory, 'PRE', ); my $file; if(!open($file, ">$filename")) { $self->throw_exception("Can't open $filename for writing ($!)"); next; } print $file $diff; close($file); carp "WARNING: There may be differences between your DB and your DBIC schema. Please review and if necessary run the SQL in $filename to sync your DB."; } sub _set_db_version { my $self = shift; my ($params) = @_; $params ||= {}; my $version = $params->{version} ? $params->{version} : $self->schema_version; my $vtable = $self->{vschema}->resultset('Table'); ############################################################################## # !!! NOTE !!! ############################################################################## # # The travesty below replaces the old nice timestamp format of %Y-%m-%d %H:%M:%S # This is necessary since there are legitimate cases when upgrades can happen # back to back within the same second. This breaks things since we relay on the # ability to sort by the 'installed' value. The logical choice of an autoinc # is not possible, as it will break multiple legacy installations. Also it is # not possible to format the string sanely, as the column is a varchar(20). # The 'v' character is added to the front of the string, so that any version # formatted by this new function will sort _after_ any existing 200... strings. my @tm = gettimeofday(); my @dt = gmtime ($tm[0]); my $o = $vtable->new_result({ version => $version, installed => sprintf("v%04d%02d%02d_%02d%02d%02d.%03.0f", $dt[5] + 1900, $dt[4] + 1, $dt[3], $dt[2], $dt[1], $dt[0], int($tm[1] / 1000), # convert to millisecs ), })->insert; } sub _read_sql_file { my $self = shift; my $file = shift || return; open my $fh, '<', $file or carp("Can't open upgrade file, $file ($!)"); my @data = split /\n/, join '', <$fh>; close $fh; @data = split /;/, join '', grep { $_ && !/^--/ && !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/mi } @data; return \@data; } sub _source_exists { my ($self, $rs) = @_; return try { $rs->search(\'1=0')->cursor->next; 1; } catch { 0; }; } =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. =cut 1; DBIx-Class-0.082843/lib/DBIx/Class/SQLAHacks.pm0000644000175000017500000000017012757225440017562 0ustar rabbitrabbitpackage # Hide from PAUSE DBIx::Class::SQLAHacks; use warnings; use strict; use base qw/DBIx::Class::SQLMaker/; 1; DBIx-Class-0.082843/lib/DBIx/Class/StartupCheck.pm0000644000175000017500000000275714240132261020450 0ustar rabbitrabbitpackage DBIx::Class::StartupCheck; use strict; use warnings; 1; __END__ =head1 NAME DBIx::Class::StartupCheck - Run environment checks on startup =head1 SYNOPSIS use DBIx::Class::StartupCheck; =head1 DESCRIPTION This module used to check for, and if necessary issue a warning for, a particular bug found on Red Hat and Fedora systems using their system perl build. As of September 2008 there are fixed versions of perl for all current Red Hat and Fedora distributions, but the old check still triggers, incorrectly flagging those versions of perl to be buggy. A more comprehensive check has been moved into the test suite in C and further information about the bug has been put in L. Other checks may be added from time to time. Any checks herein can be disabled by setting an appropriate environment variable. If your system suffers from a particular bug, you will get a warning message on startup sent to STDERR, explaining what to do about it and how to suppress the message. If you don't see any messages, you have nothing to worry about. =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. DBIx-Class-0.082843/lib/DBIx/Class/Row.pm0000644000175000017500000013131514240132261016610 0ustar rabbitrabbitpackage DBIx::Class::Row; use strict; use warnings; use base qw/DBIx::Class/; use Scalar::Util 'blessed'; use Try::Tiny; use DBIx::Class::Carp; use SQL::Abstract::Util 'is_literal_value'; ### ### Internal method ### Do not use ### BEGIN { *MULTICREATE_DEBUG = $ENV{DBIC_MULTICREATE_DEBUG} ? sub () { 1 } : sub () { 0 }; } use namespace::clean; __PACKAGE__->mk_group_accessors ( simple => [ in_storage => '_in_storage' ] ); =head1 NAME DBIx::Class::Row - Basic row methods =head1 SYNOPSIS =head1 DESCRIPTION This class is responsible for defining and doing basic operations on rows derived from L objects. Result objects are returned from Ls using the L, L, L and L methods, as well as invocations of 'single' ( L, L or L) relationship accessors of L objects. =head1 NOTE All "Row objects" derived from a Schema-attached L object (such as a typical C<< L-> L >> call) are actually Result instances, based on your application's L. L implements most of the row-based communication with the underlying storage, but a Result class B. Usually, Result classes inherit from L, which in turn combines the methods from several classes, one of them being L. Therefore, while many of the methods available to a L-derived Result class are described in the following documentation, it does not detail all of the methods available to Result objects. Refer to L for more info. =head1 METHODS =head2 new my $result = My::Class->new(\%attrs); my $result = $schema->resultset('MySource')->new(\%colsandvalues); =over =item Arguments: \%attrs or \%colsandvalues =item Return Value: L<$result|DBIx::Class::Manual::ResultClass> =back While you can create a new result object by calling C directly on this class, you are better off calling it on a L object. When calling it directly, you will not get a complete, usable row object until you pass or set the C attribute, to a L instance that is attached to a L with a valid connection. C<$attrs> is a hashref of column name, value data. It can also contain some other attributes such as the C. Passing an object, or an arrayref of objects as a value will call L for you. When passed a hashref or an arrayref of hashrefs as the value, these will be turned into objects via new_related, and treated as if you had passed objects. For a more involved explanation, see L. Please note that if a value is not passed to new, no value will be sent in the SQL INSERT call, and the column will therefore assume whatever default value was specified in your database. While DBIC will retrieve the value of autoincrement columns, it will never make an explicit database trip to retrieve default values assigned by the RDBMS. You can explicitly request that all values be fetched back from the database by calling L, or you can supply an explicit C to columns with NULL as the default, and save yourself a SELECT. CAVEAT: The behavior described above will backfire if you use a foreign key column with a database-defined default. If you call the relationship accessor on an object that doesn't have a set value for the FK column, DBIC will throw an exception, as it has no way of knowing the PK of the related object (if there is one). =cut ## It needs to store the new objects somewhere, and call insert on that list later when insert is called on this object. We may need an accessor for these so the user can retrieve them, if just doing ->new(). ## This only works because DBIC doesn't yet care to check whether the new_related objects have been passed all their mandatory columns ## When doing the later insert, we need to make sure the PKs are set. ## using _relationship_data in new and funky ways.. ## check Relationship::CascadeActions and Relationship::Accessor for compat ## tests! sub __new_related_find_or_new_helper { my ($self, $rel_name, $values) = @_; my $rsrc = $self->result_source; # create a mock-object so all new/set_column component overrides will run: my $rel_rs = $rsrc->related_source($rel_name)->resultset; my $new_rel_obj = $rel_rs->new_result($values); my $proc_data = { $new_rel_obj->get_columns }; if ($self->__their_pk_needs_us($rel_name)) { MULTICREATE_DEBUG and print STDERR "MC $self constructing $rel_name via new_result\n"; return $new_rel_obj; } elsif ($rsrc->_pk_depends_on($rel_name, $proc_data )) { if (! keys %$proc_data) { # there is nothing to search for - blind create MULTICREATE_DEBUG and print STDERR "MC $self constructing default-insert $rel_name\n"; } else { MULTICREATE_DEBUG and print STDERR "MC $self constructing $rel_name via find_or_new\n"; # this is not *really* find or new, as we don't want to double-new the # data (thus potentially double encoding or whatever) my $exists = $rel_rs->find ($proc_data); return $exists if $exists; } return $new_rel_obj; } else { my $us = $rsrc->source_name; $self->throw_exception ( "Unable to determine relationship '$rel_name' direction from '$us', " . "possibly due to a missing reverse-relationship on '$rel_name' to '$us'." ); } } sub __their_pk_needs_us { # this should maybe be in resultsource. my ($self, $rel_name) = @_; my $rsrc = $self->result_source; my $reverse = $rsrc->reverse_relationship_info($rel_name); my $rel_source = $rsrc->related_source($rel_name); my $us = { $self->get_columns }; foreach my $key (keys %$reverse) { # if their primary key depends on us, then we have to # just create a result and we'll fill it out afterwards return 1 if $rel_source->_pk_depends_on($key, $us); } return 0; } sub new { my ($class, $attrs) = @_; $class = ref $class if ref $class; my $new = bless { _column_data => {}, _in_storage => 0 }, $class; if ($attrs) { $new->throw_exception("attrs must be a hashref") unless ref($attrs) eq 'HASH'; my $rsrc = delete $attrs->{-result_source}; if ( my $h = delete $attrs->{-source_handle} ) { $rsrc ||= $h->resolve; } $new->result_source($rsrc) if $rsrc; if (my $col_from_rel = delete $attrs->{-cols_from_relations}) { @{$new->{_ignore_at_insert}={}}{@$col_from_rel} = (); } my ($related,$inflated); foreach my $key (keys %$attrs) { if (ref $attrs->{$key} and ! is_literal_value($attrs->{$key}) ) { ## Can we extract this lot to use with update(_or .. ) ? $new->throw_exception("Can't do multi-create without result source") unless $rsrc; my $info = $rsrc->relationship_info($key); my $acc_type = $info->{attrs}{accessor} || ''; if ($acc_type eq 'single') { my $rel_obj = delete $attrs->{$key}; if(!blessed $rel_obj) { $rel_obj = $new->__new_related_find_or_new_helper($key, $rel_obj); } if ($rel_obj->in_storage) { $new->{_rel_in_storage}{$key} = 1; $new->set_from_related($key, $rel_obj); } else { MULTICREATE_DEBUG and print STDERR "MC $new uninserted $key $rel_obj\n"; } $related->{$key} = $rel_obj; next; } elsif ($acc_type eq 'multi' && ref $attrs->{$key} eq 'ARRAY' ) { my $others = delete $attrs->{$key}; my $total = @$others; my @objects; foreach my $idx (0 .. $#$others) { my $rel_obj = $others->[$idx]; if(!blessed $rel_obj) { $rel_obj = $new->__new_related_find_or_new_helper($key, $rel_obj); } if ($rel_obj->in_storage) { $rel_obj->throw_exception ('A multi relationship can not be pre-existing when doing multicreate. Something went wrong'); } else { MULTICREATE_DEBUG and print STDERR "MC $new uninserted $key $rel_obj (${\($idx+1)} of $total)\n"; } push(@objects, $rel_obj); } $related->{$key} = \@objects; next; } elsif ($acc_type eq 'filter') { ## 'filter' should disappear and get merged in with 'single' above! my $rel_obj = delete $attrs->{$key}; if(!blessed $rel_obj) { $rel_obj = $new->__new_related_find_or_new_helper($key, $rel_obj); } if ($rel_obj->in_storage) { $new->{_rel_in_storage}{$key} = 1; } else { MULTICREATE_DEBUG and print STDERR "MC $new uninserted $key $rel_obj\n"; } $inflated->{$key} = $rel_obj; next; } elsif ( $rsrc->has_column($key) and $rsrc->column_info($key)->{_inflate_info} ) { $inflated->{$key} = $attrs->{$key}; next; } } $new->store_column($key => $attrs->{$key}); } $new->{_relationship_data} = $related if $related; $new->{_inflated_column} = $inflated if $inflated; } return $new; } =head2 $column_accessor # Each pair does the same thing # (un-inflated, regular column) my $val = $result->get_column('first_name'); my $val = $result->first_name; $result->set_column('first_name' => $val); $result->first_name($val); # (inflated column via DBIx::Class::InflateColumn::DateTime) my $val = $result->get_inflated_column('last_modified'); my $val = $result->last_modified; $result->set_inflated_column('last_modified' => $val); $result->last_modified($val); =over =item Arguments: $value? =item Return Value: $value =back A column accessor method is created for each column, which is used for getting/setting the value for that column. The actual method name is based on the L name given during the L L. Like L, this will not store the data in the database until L or L is called on the row. =head2 insert $result->insert; =over =item Arguments: none =item Return Value: L<$result|DBIx::Class::Manual::ResultClass> =back Inserts an object previously created by L into the database if it isn't already in there. Returns the object itself. To insert an entirely new row into the database, use L. To fetch an uninserted result object, call L on a resultset. This will also insert any uninserted, related objects held inside this one, see L for more details. =cut sub insert { my ($self) = @_; return $self if $self->in_storage; my $rsrc = $self->result_source; $self->throw_exception("No result_source set on this object; can't insert") unless $rsrc; my $storage = $rsrc->storage; my $rollback_guard; # Check if we stored uninserted relobjs here in new() my %related_stuff = (%{$self->{_relationship_data} || {}}, %{$self->{_inflated_column} || {}}); # insert what needs to be inserted before us my %pre_insert; for my $rel_name (keys %related_stuff) { my $rel_obj = $related_stuff{$rel_name}; if (! $self->{_rel_in_storage}{$rel_name}) { next unless (blessed $rel_obj && $rel_obj->isa('DBIx::Class::Row')); next unless $rsrc->_pk_depends_on( $rel_name, { $rel_obj->get_columns } ); # The guard will save us if we blow out of this scope via die $rollback_guard ||= $storage->txn_scope_guard; MULTICREATE_DEBUG and print STDERR "MC $self pre-reconstructing $rel_name $rel_obj\n"; my $them = { %{$rel_obj->{_relationship_data} || {} }, $rel_obj->get_columns }; my $existing; # if there are no keys - nothing to search for if (keys %$them and $existing = $self->result_source ->related_source($rel_name) ->resultset ->find($them) ) { %{$rel_obj} = %{$existing}; } else { $rel_obj->insert; } $self->{_rel_in_storage}{$rel_name} = 1; } $self->set_from_related($rel_name, $rel_obj); delete $related_stuff{$rel_name}; } # start a transaction here if not started yet and there is more stuff # to insert after us if (keys %related_stuff) { $rollback_guard ||= $storage->txn_scope_guard } MULTICREATE_DEBUG and do { no warnings 'uninitialized'; print STDERR "MC $self inserting (".join(', ', $self->get_columns).")\n"; }; # perform the insert - the storage will return everything it is asked to # (autoinc primary columns and any retrieve_on_insert columns) my %current_rowdata = $self->get_columns; my $returned_cols = $storage->insert( $rsrc, { %current_rowdata }, # what to insert, copy because the storage *will* change it ); for (keys %$returned_cols) { $self->store_column($_, $returned_cols->{$_}) # this ensures we fire store_column only once # (some asshats like overriding it) if ( (!exists $current_rowdata{$_}) or (defined $current_rowdata{$_} xor defined $returned_cols->{$_}) or (defined $current_rowdata{$_} and $current_rowdata{$_} ne $returned_cols->{$_}) ); } delete $self->{_column_data_in_storage}; $self->in_storage(1); $self->{_dirty_columns} = {}; $self->{related_resultsets} = {}; foreach my $rel_name (keys %related_stuff) { next unless $rsrc->has_relationship ($rel_name); my @cands = ref $related_stuff{$rel_name} eq 'ARRAY' ? @{$related_stuff{$rel_name}} : $related_stuff{$rel_name} ; if (@cands && blessed $cands[0] && $cands[0]->isa('DBIx::Class::Row') ) { my $reverse = $rsrc->reverse_relationship_info($rel_name); foreach my $obj (@cands) { $obj->set_from_related($_, $self) for keys %$reverse; if ($self->__their_pk_needs_us($rel_name)) { if (exists $self->{_ignore_at_insert}{$rel_name}) { MULTICREATE_DEBUG and print STDERR "MC $self skipping post-insert on $rel_name\n"; } else { MULTICREATE_DEBUG and print STDERR "MC $self inserting $rel_name $obj\n"; $obj->insert; } } else { MULTICREATE_DEBUG and print STDERR "MC $self post-inserting $obj\n"; $obj->insert(); } } } } delete $self->{_ignore_at_insert}; $rollback_guard->commit if $rollback_guard; return $self; } =head2 in_storage $result->in_storage; # Get value $result->in_storage(1); # Set value =over =item Arguments: none or 1|0 =item Return Value: 1|0 =back Indicates whether the object exists as a row in the database or not. This is set to true when L, L or L are invoked. Creating a result object using L, or calling L on one, sets it to false. =head2 update $result->update(\%columns?) =over =item Arguments: none or a hashref =item Return Value: L<$result|DBIx::Class::Manual::ResultClass> =back Throws an exception if the result object is not yet in the database, according to L. Returns the object itself. This method issues an SQL UPDATE query to commit any changes to the object to the database if required (see L). It throws an exception if a proper WHERE clause uniquely identifying the database row can not be constructed (see L for more details). Also takes an optional hashref of C<< column_name => value >> pairs to update on the object first. Be aware that the hashref will be passed to C, which might edit it in place, so don't rely on it being the same after a call to C. If you need to preserve the hashref, it is sufficient to pass a shallow copy to C, e.g. ( { %{ $href } } ) If the values passed or any of the column values set on the object contain scalar references, e.g.: $result->last_modified(\'NOW()')->update(); # OR $result->update({ last_modified => \'NOW()' }); The update will pass the values verbatim into SQL. (See L docs). The values in your Result object will NOT change as a result of the update call, if you want the object to be updated with the actual values from the database, call L after the update. $result->update()->discard_changes(); To determine before calling this method, which column values have changed and will be updated, call L. To check if any columns will be updated, call L. To force a column to be updated, call L before this method. =cut sub update { my ($self, $upd) = @_; $self->set_inflated_columns($upd) if $upd; my %to_update = $self->get_dirty_columns or return $self; $self->throw_exception( "Not in database" ) unless $self->in_storage; my $rows = $self->result_source->storage->update( $self->result_source, \%to_update, $self->_storage_ident_condition ); if ($rows == 0) { $self->throw_exception( "Can't update ${self}: row not found" ); } elsif ($rows > 1) { $self->throw_exception("Can't update ${self}: updated more than one row"); } $self->{_dirty_columns} = {}; $self->{related_resultsets} = {}; delete $self->{_column_data_in_storage}; return $self; } =head2 delete $result->delete =over =item Arguments: none =item Return Value: L<$result|DBIx::Class::Manual::ResultClass> =back Throws an exception if the object is not in the database according to L. Also throws an exception if a proper WHERE clause uniquely identifying the database row can not be constructed (see L for more details). The object is still perfectly usable, but L will now return 0 and the object must be reinserted using L before it can be used to L the row again. If you delete an object in a class with a C relationship, an attempt is made to delete all the related objects as well. To turn this behaviour off, pass C<< cascade_delete => 0 >> in the C<$attr> hashref of the relationship, see L. Any database-level cascade or restrict will take precedence over a DBIx-Class-based cascading delete, since DBIx-Class B and only then attempts to delete any remaining related rows. If you delete an object within a txn_do() (see L) and the transaction subsequently fails, the result object will remain marked as not being in storage. If you know for a fact that the object is still in storage (i.e. by inspecting the cause of the transaction's failure), you can use C<< $obj->in_storage(1) >> to restore consistency between the object and the database. This would allow a subsequent C<< $obj->delete >> to work as expected. See also L. =cut sub delete { my $self = shift; if (ref $self) { $self->throw_exception( "Not in database" ) unless $self->in_storage; $self->result_source->storage->delete( $self->result_source, $self->_storage_ident_condition ); delete $self->{_column_data_in_storage}; $self->in_storage(0); } else { my $rsrc = try { $self->result_source_instance } or $self->throw_exception("Can't do class delete without a ResultSource instance"); my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? { %{pop(@_)} } : {}; my $query = ref $_[0] eq 'HASH' ? $_[0] : {@_}; $rsrc->resultset->search(@_)->delete; } return $self; } =head2 get_column my $val = $result->get_column($col); =over =item Arguments: $columnname =item Return Value: The value of the column =back Throws an exception if the column name given doesn't exist according to L. Returns a raw column value from the result object, if it has already been fetched from the database or set by an accessor. If an L has been set, it will be deflated and returned. Note that if you used the C or the C, L are present, they reset the original selection, and start the selection "clean". The L, L, L, L, L attributes are merged into the existing ones from the original resultset. The L and L attributes, and any search conditions, are merged with an SQL C to the existing condition from the original resultset. All other attributes are overridden by any new ones supplied in the search attributes. =head2 Multiple queries Since a resultset just defines a query, you can do all sorts of things with it with the same object. # Don't hit the DB yet. my $cd_rs = $schema->resultset('CD')->search({ title => 'something', year => 2009, }); # Each of these hits the DB individually. my $count = $cd_rs->count; my $most_recent = $cd_rs->get_column('date_released')->max(); my @records = $cd_rs->all; And it's not just limited to SELECT statements. $cd_rs->delete(); This is even cooler: $cd_rs->create({ artist => 'Fred' }); Which is the same as: $schema->resultset('CD')->create({ title => 'something', year => 2009, artist => 'Fred' }); See: L, L, L, L, L. =head2 Custom ResultSet classes To add methods to your resultsets, you can subclass L, similar to: package MyApp::Schema::ResultSet::User; use strict; use warnings; use base 'DBIx::Class::ResultSet'; sub active { my $self = shift; $self->search({ $self->current_source_alias . '.active' => 1 }); } sub unverified { my $self = shift; $self->search({ $self->current_source_alias . '.verified' => 0 }); } sub created_n_days_ago { my ($self, $days_ago) = @_; $self->search({ $self->current_source_alias . '.create_date' => { '<=', $self->result_source->schema->storage->datetime_parser->format_datetime( DateTime->now( time_zone => 'UTC' )->subtract( days => $days_ago ) )} }); } sub users_to_warn { shift->active->unverified->created_n_days_ago(7) } 1; See L on how DBIC can discover and automatically attach L-specific L classes. =head3 ResultSet subclassing with Moose and similar constructor-providers Using L or L in your ResultSet classes is usually overkill, but you may find it useful if your ResultSets contain a lot of business logic (e.g. C, C, etc) or if you just prefer to organize your code via roles. In order to write custom ResultSet classes with L you need to use the following template. The L is necessary due to the unusual signature of the L C<< ->new($source, \%args) >>. use Moo; extends 'DBIx::Class::ResultSet'; sub BUILDARGS { $_[2] || {} } # ::RS::new() expects my ($class, $rsrc, $args) = @_ ...your code... 1; If you want to build your custom ResultSet classes with L, you need a similar, though a little more elaborate template in order to interface the inlining of the L-provided L, with the DBIC one. package MyApp::Schema::ResultSet::User; use Moose; use MooseX::NonMoose; extends 'DBIx::Class::ResultSet'; sub BUILDARGS { $_[2] || {} } # ::RS::new() expects my ($class, $rsrc, $args) = @_ ...your code... __PACKAGE__->meta->make_immutable; 1; The L is necessary so that the L constructor does not entirely overwrite the DBIC one (in contrast L does this automatically). Alternatively, you can skip L and get by with just L instead by doing: __PACKAGE__->meta->make_immutable(inline_constructor => 0); =head1 METHODS =head2 new =over 4 =item Arguments: L<$source|DBIx::Class::ResultSource>, L<\%attrs?|/ATTRIBUTES> =item Return Value: L<$resultset|/search> =back The resultset constructor. Takes a source object (usually a L) and an attribute hash (see L below). Does not perform any queries -- these are executed as needed by the other methods. Generally you never construct a resultset manually. Instead you get one from e.g. a C<< $schema->L('$source_name') >> or C<< $another_resultset->L(...) >> (the later called in scalar context): my $rs = $schema->resultset('CD')->search({ title => '100th Window' }); =over =item WARNING If called on an object, proxies to L instead, so my $cd = $schema->resultset('CD')->new({ title => 'Spoon' }); will return a CD object, not a ResultSet, and is equivalent to: my $cd = $schema->resultset('CD')->new_result({ title => 'Spoon' }); Please also keep in mind that many internals call L directly, so overloading this method with the idea of intercepting new result object creation B. See also warning pertaining to L. =back =cut sub new { my $class = shift; if (ref $class) { DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; return $class->new_result(@_); } my ($source, $attrs) = @_; $source = $source->resolve if $source->isa('DBIx::Class::ResultSourceHandle'); $attrs = { %{$attrs||{}} }; delete @{$attrs}{qw(_last_sqlmaker_alias_map _simple_passthrough_construction)}; if ($attrs->{page}) { $attrs->{rows} ||= 10; } $attrs->{alias} ||= 'me'; my $self = bless { result_source => $source, cond => $attrs->{where}, pager => undef, attrs => $attrs, }, $class; # if there is a dark selector, this means we are already in a # chain and the cleanup/sanification was taken care of by # _search_rs already $self->_normalize_selection($attrs) unless $attrs->{_dark_selector}; $self->result_class( $attrs->{result_class} || $source->result_class ); $self; } =head2 search =over 4 =item Arguments: L<$cond|DBIx::Class::SQLMaker> | undef, L<\%attrs?|/ATTRIBUTES> =item Return Value: $resultset (scalar context) | L<@result_objs|DBIx::Class::Manual::ResultClass> (list context) =back my @cds = $cd_rs->search({ year => 2001 }); # "... WHERE year = 2001" my $new_rs = $cd_rs->search({ year => 2005 }); my $new_rs = $cd_rs->search([ { year => 2005 }, { year => 2004 } ]); # year = 2005 OR year = 2004 In list context, C<< ->all() >> is called implicitly on the resultset, thus returning a list of L objects instead. To avoid that, use L. If you need to pass in additional attributes but no additional condition, call it as C. # "SELECT name, artistid FROM $artist_table" my @all_artists = $schema->resultset('Artist')->search(undef, { columns => [qw/name artistid/], }); For a list of attributes that can be passed to C, see L. For more examples of using this function, see L. For a complete documentation for the first argument, see L and its extension L. For more help on using joins with search, see L. =head3 CAVEAT Note that L does not process/deflate any of the values passed in the L-compatible search condition structure. This is unlike other condition-bound methods L, L and L. The user must ensure manually that any value passed to this method will stringify to something the RDBMS knows how to deal with. A notable example is the handling of L objects, for more info see: L. =cut sub search { my $self = shift; my $rs = $self->search_rs( @_ ); if (wantarray) { DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = fail_on_internal_wantarray; return $rs->all; } elsif (defined wantarray) { return $rs; } else { # we can be called by a relationship helper, which in # turn may be called in void context due to some braindead # overload or whatever else the user decided to be clever # at this particular day. Thus limit the exception to # external code calls only $self->throw_exception ('->search is *not* a mutator, calling it in void context makes no sense') if (caller)[0] !~ /^\QDBIx::Class::/; return (); } } =head2 search_rs =over 4 =item Arguments: L<$cond|DBIx::Class::SQLMaker>, L<\%attrs?|/ATTRIBUTES> =item Return Value: L<$resultset|/search> =back This method does the same exact thing as search() except it will always return a resultset, even in list context. =cut sub search_rs { my $self = shift; my $rsrc = $self->result_source; my ($call_cond, $call_attrs); # Special-case handling for (undef, undef) or (undef) # Note that (foo => undef) is valid deprecated syntax @_ = () if not scalar grep { defined $_ } @_; # just a cond if (@_ == 1) { $call_cond = shift; } # fish out attrs in the ($condref, $attr) case elsif (@_ == 2 and ( ! defined $_[0] or (ref $_[0]) ne '') ) { ($call_cond, $call_attrs) = @_; } elsif (@_ % 2) { $self->throw_exception('Odd number of arguments to search') } # legacy search elsif (@_) { carp_unique 'search( %condition ) is deprecated, use search( \%condition ) instead' unless $rsrc->result_class->isa('DBIx::Class::CDBICompat'); for my $i (0 .. $#_) { next if $i % 2; $self->throw_exception ('All keys in condition key/value pairs must be plain scalars') if (! defined $_[$i] or ref $_[$i] ne ''); } $call_cond = { @_ }; } # see if we can keep the cache (no $rs changes) my $cache; my %safe = (alias => 1, cache => 1); if ( ! grep { !$safe{$_} } keys %$call_attrs and ( ! defined $call_cond or ref $call_cond eq 'HASH' && ! keys %$call_cond or ref $call_cond eq 'ARRAY' && ! @$call_cond )) { $cache = $self->get_cache; } my $old_attrs = { %{$self->{attrs}} }; my ($old_having, $old_where) = delete @{$old_attrs}{qw(having where)}; my $new_attrs = { %$old_attrs }; # take care of call attrs (only if anything is changing) if ($call_attrs and keys %$call_attrs) { # copy for _normalize_selection $call_attrs = { %$call_attrs }; my @selector_attrs = qw/select as columns cols +select +as +columns include_columns/; # reset the current selector list if new selectors are supplied delete @{$old_attrs}{(@selector_attrs, '_dark_selector')} if grep { exists $call_attrs->{$_} } qw(columns cols select as); # Normalize the new selector list (operates on the passed-in attr structure) # Need to do it on every chain instead of only once on _resolved_attrs, in # order to allow detection of empty vs partial 'as' $call_attrs->{_dark_selector} = $old_attrs->{_dark_selector} if $old_attrs->{_dark_selector}; $self->_normalize_selection ($call_attrs); # start with blind overwriting merge, exclude selector attrs $new_attrs = { %{$old_attrs}, %{$call_attrs} }; delete @{$new_attrs}{@selector_attrs}; for (@selector_attrs) { $new_attrs->{$_} = $self->_merge_attr($old_attrs->{$_}, $call_attrs->{$_}) if ( exists $old_attrs->{$_} or exists $call_attrs->{$_} ); } # older deprecated name, use only if {columns} is not there if (my $c = delete $new_attrs->{cols}) { carp_unique( "Resultset attribute 'cols' is deprecated, use 'columns' instead" ); if ($new_attrs->{columns}) { carp "Resultset specifies both the 'columns' and the legacy 'cols' attributes - ignoring 'cols'"; } else { $new_attrs->{columns} = $c; } } # join/prefetch use their own crazy merging heuristics foreach my $key (qw/join prefetch/) { $new_attrs->{$key} = $self->_merge_joinpref_attr($old_attrs->{$key}, $call_attrs->{$key}) if exists $call_attrs->{$key}; } # stack binds together $new_attrs->{bind} = [ @{ $old_attrs->{bind} || [] }, @{ $call_attrs->{bind} || [] } ]; } for ($old_where, $call_cond) { if (defined $_) { $new_attrs->{where} = $self->_stack_cond ( $_, $new_attrs->{where} ); } } if (defined $old_having) { $new_attrs->{having} = $self->_stack_cond ( $old_having, $new_attrs->{having} ) } my $rs = (ref $self)->new($rsrc, $new_attrs); $rs->set_cache($cache) if ($cache); return $rs; } my $dark_sel_dumper; sub _normalize_selection { my ($self, $attrs) = @_; # legacy syntax if ( exists $attrs->{include_columns} ) { carp_unique( "Resultset attribute 'include_columns' is deprecated, use '+columns' instead" ); $attrs->{'+columns'} = $self->_merge_attr( $attrs->{'+columns'}, delete $attrs->{include_columns} ); } # columns are always placed first, however # Keep the X vs +X separation until _resolved_attrs time - this allows to # delay the decision on whether to use a default select list ($rsrc->columns) # allowing stuff like the remove_columns helper to work # # select/as +select/+as pairs need special handling - the amount of select/as # elements in each pair does *not* have to be equal (think multicolumn # selectors like distinct(foo, bar) ). If the selector is bare (no 'as' # supplied at all) - try to infer the alias, either from the -as parameter # of the selector spec, or use the parameter whole if it looks like a column # name (ugly legacy heuristic). If all fails - leave the selector bare (which # is ok as well), but make sure no more additions to the 'as' chain take place for my $pref ('', '+') { my ($sel, $as) = map { my $key = "${pref}${_}"; my $val = [ ref $attrs->{$key} eq 'ARRAY' ? @{$attrs->{$key}} : $attrs->{$key} || () ]; delete $attrs->{$key}; $val; } qw/select as/; if (! @$as and ! @$sel ) { next; } elsif (@$as and ! @$sel) { $self->throw_exception( "Unable to handle ${pref}as specification (@$as) without a corresponding ${pref}select" ); } elsif( ! @$as ) { # no as part supplied at all - try to deduce (unless explicit end of named selection is declared) # if any @$as has been supplied we assume the user knows what (s)he is doing # and blindly keep stacking up pieces unless ($attrs->{_dark_selector}) { SELECTOR: for (@$sel) { if ( ref $_ eq 'HASH' and exists $_->{-as} ) { push @$as, $_->{-as}; } # assume any plain no-space, no-parenthesis string to be a column spec # FIXME - this is retarded but is necessary to support shit like 'count(foo)' elsif ( ! ref $_ and $_ =~ /^ [^\s\(\)]+ $/x) { push @$as, $_; } # if all else fails - raise a flag that no more aliasing will be allowed else { $attrs->{_dark_selector} = { plus_stage => $pref, string => ($dark_sel_dumper ||= do { require Data::Dumper::Concise; Data::Dumper::Concise::DumperObject()->Indent(0); })->Values([$_])->Dump , }; last SELECTOR; } } } } elsif (@$as < @$sel) { $self->throw_exception( "Unable to handle an ${pref}as specification (@$as) with less elements than the corresponding ${pref}select" ); } elsif ($pref and $attrs->{_dark_selector}) { $self->throw_exception( "Unable to process named '+select', resultset contains an unnamed selector $attrs->{_dark_selector}{string}" ); } # merge result $attrs->{"${pref}select"} = $self->_merge_attr($attrs->{"${pref}select"}, $sel); $attrs->{"${pref}as"} = $self->_merge_attr($attrs->{"${pref}as"}, $as); } } sub _stack_cond { my ($self, $left, $right) = @_; ( (ref $_ eq 'ARRAY' and !@$_) or (ref $_ eq 'HASH' and ! keys %$_) ) and $_ = undef for ($left, $right); # either one of the two undef if ( (defined $left) xor (defined $right) ) { return defined $left ? $left : $right; } # both undef elsif ( ! defined $left ) { return undef } else { return $self->result_source->schema->storage->_collapse_cond({ -and => [$left, $right] }); } } =head2 search_literal B: C is provided for Class::DBI compatibility and should only be used in that context. C is a convenience method. It is equivalent to calling C<< $schema->search(\[]) >>, but if you want to ensure columns are bound correctly, use L. See L and L for searching techniques that do not require C. =over 4 =item Arguments: $sql_fragment, @standalone_bind_values =item Return Value: L<$resultset|/search> (scalar context) | L<@result_objs|DBIx::Class::Manual::ResultClass> (list context) =back my @cds = $cd_rs->search_literal('year = ? AND title = ?', qw/2001 Reload/); my $newrs = $artist_rs->search_literal('name = ?', 'Metallica'); Pass a literal chunk of SQL to be added to the conditional part of the resultset query. Example of how to use C instead of C my @cds = $cd_rs->search_literal('cdid = ? AND (artist = ? OR artist = ?)', (2, 1, 2)); my @cds = $cd_rs->search(\[ 'cdid = ? AND (artist = ? OR artist = ?)', [ 'cdid', 2 ], [ 'artist', 1 ], [ 'artist', 2 ] ]); =cut sub search_literal { my ($self, $sql, @bind) = @_; my $attr; if ( @bind && ref($bind[-1]) eq 'HASH' ) { $attr = pop @bind; } return $self->search(\[ $sql, map [ {} => $_ ], @bind ], ($attr || () )); } =head2 find =over 4 =item Arguments: \%columns_values | @pk_values, { key => $unique_constraint, L<%attrs|/ATTRIBUTES> }? =item Return Value: L<$result|DBIx::Class::Manual::ResultClass> | undef =back Finds and returns a single row based on supplied criteria. Takes either a hashref with the same format as L (including inference of foreign keys from related objects), or a list of primary key values in the same order as the L declaration on the L. In either case an attempt is made to combine conditions already existing on the resultset with the condition passed to this method. To aid with preparing the correct query for the storage you may supply the C attribute, which is the name of a L (the unique constraint corresponding to the L is always named C). If the C attribute has been supplied, and DBIC is unable to construct a query that satisfies the named unique constraint fully ( non-NULL values for each column member of the constraint) an exception is thrown. If no C is specified, the search is carried over all unique constraints which are fully defined by the available condition. If no such constraint is found, C currently defaults to a simple C<< search->(\%column_values) >> which may or may not do what you expect. Note that this fallback behavior may be deprecated in further versions. If you need to search with arbitrary conditions - use L. If the query resulting from this fallback produces more than one row, a warning to the effect is issued, though only the first row is constructed and returned as C<$result_object>. In addition to C, L recognizes and applies standard L in the same way as L does. Note that if you have extra concerns about the correctness of the resulting query you need to specify the C attribute and supply the entire condition as an argument to find (since it is not always possible to perform the combination of the resultset condition with the supplied one, especially if the resultset condition contains literal sql). For example, to find a row by its primary key: my $cd = $schema->resultset('CD')->find(5); You can also find a row by a specific unique constraint: my $cd = $schema->resultset('CD')->find( { artist => 'Massive Attack', title => 'Mezzanine', }, { key => 'cd_artist_title' } ); See also L and L. =cut sub find { my $self = shift; my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {}); my $rsrc = $self->result_source; my $constraint_name; if (exists $attrs->{key}) { $constraint_name = defined $attrs->{key} ? $attrs->{key} : $self->throw_exception("An undefined 'key' resultset attribute makes no sense") ; } # Parse out the condition from input my $call_cond; if (ref $_[0] eq 'HASH') { $call_cond = { %{$_[0]} }; } else { # if only values are supplied we need to default to 'primary' $constraint_name = 'primary' unless defined $constraint_name; my @c_cols = $rsrc->unique_constraint_columns($constraint_name); $self->throw_exception( "No constraint columns, maybe a malformed '$constraint_name' constraint?" ) unless @c_cols; $self->throw_exception ( 'find() expects either a column/value hashref, or a list of values ' . "corresponding to the columns of the specified unique constraint '$constraint_name'" ) unless @c_cols == @_; @{$call_cond}{@c_cols} = @_; } # process relationship data if any for my $key (keys %$call_cond) { if ( length ref($call_cond->{$key}) and my $relinfo = $rsrc->relationship_info($key) and # implicitly skip has_many's (likely MC) (ref (my $val = delete $call_cond->{$key}) ne 'ARRAY' ) ) { my ($rel_cond, $crosstable) = $rsrc->_resolve_condition( $relinfo->{cond}, $val, $key, $key ); $self->throw_exception("Complex condition via relationship '$key' is unsupported in find()") if $crosstable or ref($rel_cond) ne 'HASH'; # supplement condition # relationship conditions take precedence (?) @{$call_cond}{keys %$rel_cond} = values %$rel_cond; } } my $alias = exists $attrs->{alias} ? $attrs->{alias} : $self->{attrs}{alias}; my $final_cond; if (defined $constraint_name) { $final_cond = $self->_qualify_cond_columns ( $self->result_source->_minimal_valueset_satisfying_constraint( constraint_name => $constraint_name, values => ($self->_merge_with_rscond($call_cond))[0], carp_on_nulls => 1, ), $alias, ); } elsif ($self->{attrs}{accessor} and $self->{attrs}{accessor} eq 'single') { # This means that we got here after a merger of relationship conditions # in ::Relationship::Base::search_related (the row method), and furthermore # the relationship is of the 'single' type. This means that the condition # provided by the relationship (already attached to $self) is sufficient, # as there can be only one row in the database that would satisfy the # relationship } else { my (@unique_queries, %seen_column_combinations, $ci, @fc_exceptions); # no key was specified - fall down to heuristics mode: # run through all unique queries registered on the resultset, and # 'OR' all qualifying queries together # # always start from 'primary' if it exists at all for my $c_name ( sort { $a eq 'primary' ? -1 : $b eq 'primary' ? 1 : $a cmp $b } $rsrc->unique_constraint_names) { next if $seen_column_combinations{ join "\x00", sort $rsrc->unique_constraint_columns($c_name) }++; try { push @unique_queries, $self->_qualify_cond_columns( $self->result_source->_minimal_valueset_satisfying_constraint( constraint_name => $c_name, values => ($self->_merge_with_rscond($call_cond))[0], columns_info => ($ci ||= $self->result_source->columns_info), ), $alias ); } catch { push @fc_exceptions, $_ if $_ =~ /\bFilterColumn\b/; }; } $final_cond = @unique_queries ? \@unique_queries : @fc_exceptions ? $self->throw_exception(join "; ", map { $_ =~ /(.*) at .+ line \d+$/s } @fc_exceptions ) : $self->_non_unique_find_fallback ($call_cond, $attrs) ; } # Run the query, passing the result_class since it should propagate for find my $rs = $self->search ($final_cond, {result_class => $self->result_class, %$attrs}); if ($rs->_resolved_attrs->{collapse}) { my $row = $rs->next; carp "Query returned more than one row" if $rs->next; return $row; } else { return $rs->single; } } # This is a stop-gap method as agreed during the discussion on find() cleanup: # http://lists.scsys.co.uk/pipermail/dbix-class/2010-October/009535.html # # It is invoked when find() is called in legacy-mode with insufficiently-unique # condition. It is provided for overrides until a saner way forward is devised # # *NOTE* This is not a public method, and it's *GUARANTEED* to disappear down # the road. Please adjust your tests accordingly to catch this situation early # DBIx::Class::ResultSet->can('_non_unique_find_fallback') is reasonable # # The method will not be removed without an adequately complete replacement # for strict-mode enforcement sub _non_unique_find_fallback { my ($self, $cond, $attrs) = @_; return $self->_qualify_cond_columns( $cond, exists $attrs->{alias} ? $attrs->{alias} : $self->{attrs}{alias} ); } sub _qualify_cond_columns { my ($self, $cond, $alias) = @_; my %aliased = %$cond; for (keys %aliased) { $aliased{"$alias.$_"} = delete $aliased{$_} if $_ !~ /\./; } return \%aliased; } sub _build_unique_cond { carp_unique sprintf '_build_unique_cond is a private method, and moreover is about to go ' . 'away. Please contact the development team at %s if you believe you ' . 'have a genuine use for this method, in order to discuss alternatives.', DBIx::Class::_ENV_::HELP_URL, ; my ($self, $constraint_name, $cond, $croak_on_null) = @_; $self->result_source->_minimal_valueset_satisfying_constraint( constraint_name => $constraint_name, values => $cond, carp_on_nulls => !$croak_on_null ); } =head2 search_related =over 4 =item Arguments: $rel_name, $cond?, L<\%attrs?|/ATTRIBUTES> =item Return Value: L<$resultset|/search> (scalar context) | L<@result_objs|DBIx::Class::Manual::ResultClass> (list context) =back $new_rs = $cd_rs->search_related('artist', { name => 'Emo-R-Us', }); Searches the specified relationship, optionally specifying a condition and attributes for matching records. See L for more information. In list context, C<< ->all() >> is called implicitly on the resultset, thus returning a list of result objects instead. To avoid that, use L. See also L. =cut sub search_related { return shift->related_resultset(shift)->search(@_); } =head2 search_related_rs This method works exactly the same as search_related, except that it guarantees a resultset, even in list context. =cut sub search_related_rs { return shift->related_resultset(shift)->search_rs(@_); } =head2 cursor =over 4 =item Arguments: none =item Return Value: L<$cursor|DBIx::Class::Cursor> =back Returns a storage-driven cursor to the given resultset. See L for more information. =cut sub cursor { my $self = shift; return $self->{cursor} ||= do { my $attrs = $self->_resolved_attrs; $self->result_source->storage->select( $attrs->{from}, $attrs->{select}, $attrs->{where}, $attrs ); }; } =head2 single =over 4 =item Arguments: L<$cond?|DBIx::Class::SQLMaker> =item Return Value: L<$result|DBIx::Class::Manual::ResultClass> | undef =back my $cd = $schema->resultset('CD')->single({ year => 2001 }); Inflates the first result without creating a cursor if the resultset has any records in it; if not returns C. Used by L as a lean version of L. While this method can take an optional search condition (just like L) being a fast-code-path it does not recognize search attributes. If you need to add extra joins or similar, call L and then chain-call L on the L returned. =over =item B As of 0.08100, this method enforces the assumption that the preceding query returns only one row. If more than one row is returned, you will receive a warning: Query returned more than one row In this case, you should be using L or L instead, or if you really know what you are doing, use the L attribute to explicitly limit the size of the resultset. This method will also throw an exception if it is called on a resultset prefetching has_many, as such a prefetch implies fetching multiple rows from the database in order to assemble the resulting object. =back =cut sub single { my ($self, $where) = @_; if(@_ > 2) { $self->throw_exception('single() only takes search conditions, no attributes. You want ->search( $cond, $attrs )->single()'); } my $attrs = { %{$self->_resolved_attrs} }; $self->throw_exception( 'single() can not be used on resultsets collapsing a has_many. Use find( \%cond ) or next() instead' ) if $attrs->{collapse}; if ($where) { if (defined $attrs->{where}) { $attrs->{where} = { '-and' => [ map { ref $_ eq 'ARRAY' ? [ -or => $_ ] : $_ } $where, delete $attrs->{where} ] }; } else { $attrs->{where} = $where; } } my $data = [ $self->result_source->storage->select_single( $attrs->{from}, $attrs->{select}, $attrs->{where}, $attrs )]; return undef unless @$data; $self->{_stashed_rows} = [ $data ]; $self->_construct_results->[0]; } =head2 get_column =over 4 =item Arguments: L<$cond?|DBIx::Class::SQLMaker> =item Return Value: L<$resultsetcolumn|DBIx::Class::ResultSetColumn> =back my $max_length = $rs->get_column('length')->max; Returns a L instance for a column of the ResultSet. =cut sub get_column { my ($self, $column) = @_; my $new = DBIx::Class::ResultSetColumn->new($self, $column); return $new; } =head2 search_like =over 4 =item Arguments: L<$cond|DBIx::Class::SQLMaker>, L<\%attrs?|/ATTRIBUTES> =item Return Value: L<$resultset|/search> (scalar context) | L<@result_objs|DBIx::Class::Manual::ResultClass> (list context) =back # WHERE title LIKE '%blue%' $cd_rs = $rs->search_like({ title => '%blue%'}); Performs a search, but uses C instead of C<=> as the condition. Note that this is simply a convenience method retained for ex Class::DBI users. You most likely want to use L with specific operators. For more information, see L. This method is deprecated and will be removed in 0.09. Use L instead. An example conversion is: ->search_like({ foo => 'bar' }); # Becomes ->search({ foo => { like => 'bar' } }); =cut sub search_like { my $class = shift; carp_unique ( 'search_like() is deprecated and will be removed in DBIC version 0.09.' .' Instead use ->search({ x => { -like => "y%" } })' .' (note the outer pair of {}s - they are important!)' ); my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {}); my $query = ref $_[0] eq 'HASH' ? { %{shift()} }: {@_}; $query->{$_} = { 'like' => $query->{$_} } for keys %$query; return $class->search($query, { %$attrs }); } =head2 slice =over 4 =item Arguments: $first, $last =item Return Value: L<$resultset|/search> (scalar context) | L<@result_objs|DBIx::Class::Manual::ResultClass> (list context) =back Returns a resultset or object list representing a subset of elements from the resultset slice is called on. Indexes are from 0, i.e., to get the first three records, call: my ($one, $two, $three) = $rs->slice(0, 2); =cut sub slice { my ($self, $min, $max) = @_; my $attrs = {}; # = { %{ $self->{attrs} || {} } }; $attrs->{offset} = $self->{attrs}{offset} || 0; $attrs->{offset} += $min; $attrs->{rows} = ($max ? ($max - $min + 1) : 1); return $self->search(undef, $attrs); } =head2 next =over 4 =item Arguments: none =item Return Value: L<$result|DBIx::Class::Manual::ResultClass> | undef =back Returns the next element in the resultset (C is there is none). Can be used to efficiently iterate over records in the resultset: my $rs = $schema->resultset('CD')->search; while (my $cd = $rs->next) { print $cd->title; } Note that you need to store the resultset object, and call C on it. Calling C<< resultset('Table')->next >> repeatedly will always return the first record from the resultset. =cut sub next { my ($self) = @_; if (my $cache = $self->get_cache) { $self->{all_cache_position} ||= 0; return $cache->[$self->{all_cache_position}++]; } if ($self->{attrs}{cache}) { delete $self->{pager}; $self->{all_cache_position} = 1; return ($self->all)[0]; } return shift(@{$self->{_stashed_results}}) if @{ $self->{_stashed_results}||[] }; $self->{_stashed_results} = $self->_construct_results or return undef; return shift @{$self->{_stashed_results}}; } # Constructs as many results as it can in one pass while respecting # cursor laziness. Several modes of operation: # # * Always builds everything present in @{$self->{_stashed_rows}} # * If called with $fetch_all true - pulls everything off the cursor and # builds all result structures (or objects) in one pass # * If $self->_resolved_attrs->{collapse} is true, checks the order_by # and if the resultset is ordered properly by the left side: # * Fetches stuff off the cursor until the "master object" changes, # and saves the last extra row (if any) in @{$self->{_stashed_rows}} # OR # * Just fetches, and collapses/constructs everything as if $fetch_all # was requested (there is no other way to collapse except for an # eager cursor) # * If no collapse is requested - just get the next row, construct and # return sub _construct_results { my ($self, $fetch_all) = @_; my $rsrc = $self->result_source; my $attrs = $self->_resolved_attrs; if ( ! $fetch_all and ! $attrs->{order_by} and $attrs->{collapse} and my @pcols = $rsrc->primary_columns ) { # default order for collapsing unless the user asked for something $attrs->{order_by} = [ map { join '.', $attrs->{alias}, $_} @pcols ]; $attrs->{_ordered_for_collapse} = 1; $attrs->{_order_is_artificial} = 1; } # this will be used as both initial raw-row collector AND as a RV of # _construct_results. Not regrowing the array twice matters a lot... # a surprising amount actually my $rows = delete $self->{_stashed_rows}; my $cursor; # we may not need one at all my $did_fetch_all = $fetch_all; if ($fetch_all) { # FIXME SUBOPTIMAL - we can do better, cursor->next/all (well diff. methods) should return a ref $rows = [ ($rows ? @$rows : ()), $self->cursor->all ]; } elsif( $attrs->{collapse} ) { # a cursor will need to be closed over in case of collapse $cursor = $self->cursor; $attrs->{_ordered_for_collapse} = ( ( $attrs->{order_by} and $rsrc->schema ->storage ->_extract_colinfo_of_stable_main_source_order_by_portion($attrs) ) ? 1 : 0 ) unless defined $attrs->{_ordered_for_collapse}; if (! $attrs->{_ordered_for_collapse}) { $did_fetch_all = 1; # instead of looping over ->next, use ->all in stealth mode # *without* calling a ->reset afterwards # FIXME ENCAPSULATION - encapsulation breach, cursor method additions pending if (! $cursor->{_done}) { $rows = [ ($rows ? @$rows : ()), $cursor->all ]; $cursor->{_done} = 1; } } } if (! $did_fetch_all and ! @{$rows||[]} ) { # FIXME SUBOPTIMAL - we can do better, cursor->next/all (well diff. methods) should return a ref $cursor ||= $self->cursor; if (scalar (my @r = $cursor->next) ) { $rows = [ \@r ]; } } return undef unless @{$rows||[]}; # sanity check - people are too clever for their own good if ($attrs->{collapse} and my $aliastypes = $attrs->{_last_sqlmaker_alias_map} ) { my $multiplied_selectors; for my $sel_alias ( grep { $_ ne $attrs->{alias} } keys %{ $aliastypes->{selecting} } ) { if ( $aliastypes->{multiplying}{$sel_alias} or $aliastypes->{premultiplied}{$sel_alias} ) { $multiplied_selectors->{$_} = 1 for values %{$aliastypes->{selecting}{$sel_alias}{-seen_columns}} } } for my $i (0 .. $#{$attrs->{as}} ) { my $sel = $attrs->{select}[$i]; if (ref $sel eq 'SCALAR') { $sel = $$sel; } elsif( ref $sel eq 'REF' and ref $$sel eq 'ARRAY' ) { $sel = $$sel->[0]; } $self->throw_exception( 'Result collapse not possible - selection from a has_many source redirected to the main object' ) if ($multiplied_selectors->{$sel} and $attrs->{as}[$i] !~ /\./); } } # hotspot - skip the setter my $res_class = $self->_result_class; my $inflator_cref = $self->{_result_inflator}{cref} ||= do { $res_class->can ('inflate_result') or $self->throw_exception("Inflator $res_class does not provide an inflate_result() method"); }; my $infmap = $attrs->{as}; $self->{_result_inflator}{is_core_row} = ( ( $inflator_cref == ( \&DBIx::Class::Row::inflate_result || die "No ::Row::inflate_result() - can't happen" ) ) ? 1 : 0 ) unless defined $self->{_result_inflator}{is_core_row}; $self->{_result_inflator}{is_hri} = ( ( ! $self->{_result_inflator}{is_core_row} and $inflator_cref == ( require DBIx::Class::ResultClass::HashRefInflator && DBIx::Class::ResultClass::HashRefInflator->can('inflate_result') ) ) ? 1 : 0 ) unless defined $self->{_result_inflator}{is_hri}; if ($attrs->{_simple_passthrough_construction}) { # construct a much simpler array->hash folder for the one-table HRI cases right here if ($self->{_result_inflator}{is_hri}) { for my $r (@$rows) { $r = { map { $infmap->[$_] => $r->[$_] } 0..$#$infmap }; } } # FIXME SUBOPTIMAL this is a very very very hot spot # while rather optimal we can *still* do much better, by # building a smarter Row::inflate_result(), and # switch to feeding it data via a much leaner interface # # crude unscientific benchmarking indicated the shortcut eval is not worth it for # this particular resultset size elsif ( $self->{_result_inflator}{is_core_row} and @$rows < 60 ) { for my $r (@$rows) { $r = $inflator_cref->($res_class, $rsrc, { map { $infmap->[$_] => $r->[$_] } (0..$#$infmap) } ); } } else { eval sprintf ( ( $self->{_result_inflator}{is_core_row} ? '$_ = $inflator_cref->($res_class, $rsrc, { %s }) for @$rows' # a custom inflator may be a multiplier/reductor - put it in direct list ctx : '@$rows = map { $inflator_cref->($res_class, $rsrc, { %s } ) } @$rows' ), ( join (', ', map { "\$infmap->[$_] => \$_->[$_]" } 0..$#$infmap ) ) ) . '; 1' or die; } } else { my $parser_type = $self->{_result_inflator}{is_hri} ? 'hri' : $self->{_result_inflator}{is_core_row} ? 'classic_pruning' : 'classic_nonpruning' ; # $args and $attrs to _mk_row_parser are separated to delineate what is # core collapser stuff and what is dbic $rs specific @{$self->{_row_parser}{$parser_type}}{qw(cref nullcheck)} = $rsrc->_mk_row_parser({ eval => 1, inflate_map => $infmap, collapse => $attrs->{collapse}, premultiplied => $attrs->{_main_source_premultiplied}, hri_style => $self->{_result_inflator}{is_hri}, prune_null_branches => $self->{_result_inflator}{is_hri} || $self->{_result_inflator}{is_core_row}, }, $attrs) unless $self->{_row_parser}{$parser_type}{cref}; # column_info metadata historically hasn't been too reliable. # We need to start fixing this somehow (the collapse resolver # can't work without it). Add an explicit check for the *main* # result, hopefully this will gradually weed out such errors # # FIXME - this is a temporary kludge that reduces performance # It is however necessary for the time being my ($unrolled_non_null_cols_to_check, $err); if (my $check_non_null_cols = $self->{_row_parser}{$parser_type}{nullcheck} ) { $err = 'Collapse aborted due to invalid ResultSource metadata - the following ' . 'selections are declared non-nullable but NULLs were retrieved: ' ; my @violating_idx; COL: for my $i (@$check_non_null_cols) { ! defined $_->[$i] and push @violating_idx, $i and next COL for @$rows; } $self->throw_exception( $err . join (', ', map { "'$infmap->[$_]'" } @violating_idx ) ) if @violating_idx; $unrolled_non_null_cols_to_check = join (',', @$check_non_null_cols); utf8::upgrade($unrolled_non_null_cols_to_check) if DBIx::Class::_ENV_::STRESSTEST_UTF8_UPGRADE_GENERATED_COLLAPSER_SOURCE; } my $next_cref = ($did_fetch_all or ! $attrs->{collapse}) ? undef : defined $unrolled_non_null_cols_to_check ? eval sprintf <<'EOS', $unrolled_non_null_cols_to_check sub { # FIXME SUBOPTIMAL - we can do better, cursor->next/all (well diff. methods) should return a ref my @r = $cursor->next or return; if (my @violating_idx = grep { ! defined $r[$_] } (%s) ) { $self->throw_exception( $err . join (', ', map { "'$infmap->[$_]'" } @violating_idx ) ) } \@r } EOS : sub { # FIXME SUBOPTIMAL - we can do better, cursor->next/all (well diff. methods) should return a ref my @r = $cursor->next or return; \@r } ; $self->{_row_parser}{$parser_type}{cref}->( $rows, $next_cref ? ( $next_cref, $self->{_stashed_rows} = [] ) : (), ); # simple in-place substitution, does not regrow $rows if ($self->{_result_inflator}{is_core_row}) { $_ = $inflator_cref->($res_class, $rsrc, @$_) for @$rows } # Special-case multi-object HRI - there is no $inflator_cref pass at all elsif ( ! $self->{_result_inflator}{is_hri} ) { # the inflator may be a multiplier/reductor - put it in list ctx @$rows = map { $inflator_cref->($res_class, $rsrc, @$_) } @$rows; } } # The @$rows check seems odd at first - why wouldn't we want to warn # regardless? The issue is things like find() etc, where the user # *knows* only one result will come back. In these cases the ->all # is not a pessimization, but rather something we actually want carp_unique( 'Unable to properly collapse has_many results in iterator mode due ' . 'to order criteria - performed an eager cursor slurp underneath. ' . 'Consider using ->all() instead' ) if ( ! $fetch_all and @$rows > 1 ); return $rows; } =head2 result_source =over 4 =item Arguments: L<$result_source?|DBIx::Class::ResultSource> =item Return Value: L<$result_source|DBIx::Class::ResultSource> =back An accessor for the primary ResultSource object from which this ResultSet is derived. =head2 result_class =over 4 =item Arguments: $result_class? =item Return Value: $result_class =back An accessor for the class to use when creating result objects. Defaults to C<< result_source->result_class >> - which in most cases is the name of the L<"table"|DBIx::Class::Manual::Glossary/"ResultSource"> class. Note that changing the result_class will also remove any components that were originally loaded in the source class via L. Any overloaded methods in the original source class will not run. =cut sub result_class { my ($self, $result_class) = @_; if ($result_class) { # don't fire this for an object $self->ensure_class_loaded($result_class) unless ref($result_class); if ($self->get_cache) { carp_unique('Changing the result_class of a ResultSet instance with cached results is a noop - the cache contents will not be altered'); } # FIXME ENCAPSULATION - encapsulation breach, cursor method additions pending elsif ($self->{cursor} && $self->{cursor}{_pos}) { $self->throw_exception('Changing the result_class of a ResultSet instance with an active cursor is not supported'); } $self->_result_class($result_class); delete $self->{_result_inflator}; } $self->_result_class; } =head2 count =over 4 =item Arguments: L<$cond|DBIx::Class::SQLMaker>, L<\%attrs?|/ATTRIBUTES> =item Return Value: $count =back Performs an SQL C with the same query as the resultset was built with to find the number of elements. Passing arguments is equivalent to C<< $rs->search ($cond, \%attrs)->count >> =cut sub count { my $self = shift; return $self->search(@_)->count if @_ and defined $_[0]; return scalar @{ $self->get_cache } if $self->get_cache; my $attrs = { %{ $self->_resolved_attrs } }; # this is a little optimization - it is faster to do the limit # adjustments in software, instead of a subquery my ($rows, $offset) = delete @{$attrs}{qw/rows offset/}; my $crs; if ($self->_has_resolved_attr (qw/collapse group_by/)) { $crs = $self->_count_subq_rs ($attrs); } else { $crs = $self->_count_rs ($attrs); } my $count = $crs->next; $count -= $offset if $offset; $count = $rows if $rows and $rows < $count; $count = 0 if ($count < 0); return $count; } =head2 count_rs =over 4 =item Arguments: L<$cond|DBIx::Class::SQLMaker>, L<\%attrs?|/ATTRIBUTES> =item Return Value: L<$count_rs|DBIx::Class::ResultSetColumn> =back Same as L but returns a L object. This can be very handy for subqueries: ->search( { amount => $some_rs->count_rs->as_query } ) As with regular resultsets the SQL query will be executed only after the resultset is accessed via L or L. That would return the same single value obtainable via L. =cut sub count_rs { my $self = shift; return $self->search(@_)->count_rs if @_; # this may look like a lack of abstraction (count() does about the same) # but in fact an _rs *must* use a subquery for the limits, as the # software based limiting can not be ported if this $rs is to be used # in a subquery itself (i.e. ->as_query) if ($self->_has_resolved_attr (qw/collapse group_by offset rows/)) { return $self->_count_subq_rs($self->{_attrs}); } else { return $self->_count_rs($self->{_attrs}); } } # # returns a ResultSetColumn object tied to the count query # sub _count_rs { my ($self, $attrs) = @_; my $rsrc = $self->result_source; my $tmp_attrs = { %$attrs }; # take off any limits, record_filter is cdbi, and no point of ordering nor locking a count delete @{$tmp_attrs}{qw/rows offset order_by record_filter for/}; # overwrite the selector (supplied by the storage) $rsrc->resultset_class->new($rsrc, { %$tmp_attrs, select => $rsrc->storage->_count_select ($rsrc, $attrs), as => 'count', })->get_column ('count'); } # # same as above but uses a subquery # sub _count_subq_rs { my ($self, $attrs) = @_; my $rsrc = $self->result_source; my $sub_attrs = { %$attrs }; # extra selectors do not go in the subquery and there is no point of ordering it, nor locking it delete @{$sub_attrs}{qw/collapse columns as select order_by for/}; # if we multi-prefetch we group_by something unique, as this is what we would # get out of the rs via ->next/->all. We *DO WANT* to clobber old group_by regardless if ( $attrs->{collapse} ) { $sub_attrs->{group_by} = [ map { "$attrs->{alias}.$_" } @{ $rsrc->_identifying_column_set || $self->throw_exception( 'Unable to construct a unique group_by criteria properly collapsing the ' . 'has_many prefetch before count()' ); } ] } # Calculate subquery selector if (my $g = $sub_attrs->{group_by}) { my $sql_maker = $rsrc->storage->sql_maker; # necessary as the group_by may refer to aliased functions my $sel_index; for my $sel (@{$attrs->{select}}) { $sel_index->{$sel->{-as}} = $sel if (ref $sel eq 'HASH' and $sel->{-as}); } # anything from the original select mentioned on the group-by needs to make it to the inner selector # also look for named aggregates referred in the having clause # having often contains scalarrefs - thus parse it out entirely my @parts = @$g; if ($attrs->{having}) { local $sql_maker->{having_bind}; local $sql_maker->{quote_char} = $sql_maker->{quote_char}; local $sql_maker->{name_sep} = $sql_maker->{name_sep}; unless (defined $sql_maker->{quote_char} and length $sql_maker->{quote_char}) { $sql_maker->{quote_char} = [ "\x00", "\xFF" ]; # if we don't unset it we screw up retarded but unfortunately working # 'MAX(foo.bar)' => { '>', 3 } $sql_maker->{name_sep} = ''; } my ($lquote, $rquote, $sep) = map { quotemeta $_ } ($sql_maker->_quote_chars, $sql_maker->name_sep); my $having_sql = $sql_maker->_parse_rs_attrs ({ having => $attrs->{having} }); my %seen_having; # search for both a proper quoted qualified string, for a naive unquoted scalarref # and if all fails for an utterly naive quoted scalar-with-function while ($having_sql =~ / $rquote $sep $lquote (.+?) $rquote | [\s,] \w+ \. (\w+) [\s,] | [\s,] $lquote (.+?) $rquote [\s,] /gx) { my $part = $1 || $2 || $3; # one of them matched if we got here unless ($seen_having{$part}++) { push @parts, $part; } } } for (@parts) { my $colpiece = $sel_index->{$_} || $_; # unqualify join-based group_by's. Arcane but possible query # also horrible horrible hack to alias a column (not a func.) if ($colpiece =~ /\./ && $colpiece !~ /^$attrs->{alias}\./) { my $as = $colpiece; $as =~ s/\./__/; $colpiece = \ sprintf ('%s AS %s', map { $sql_maker->_quote ($_) } ($colpiece, $as) ); } push @{$sub_attrs->{select}}, $colpiece; } } else { my @pcols = map { "$attrs->{alias}.$_" } ($rsrc->primary_columns); $sub_attrs->{select} = @pcols ? \@pcols : [ 1 ]; } return $rsrc->resultset_class ->new ($rsrc, $sub_attrs) ->as_subselect_rs ->search ({}, { columns => { count => $rsrc->storage->_count_select ($rsrc, $attrs) } }) ->get_column ('count'); } =head2 count_literal B: C is provided for Class::DBI compatibility and should only be used in that context. See L for further info. =over 4 =item Arguments: $sql_fragment, @standalone_bind_values =item Return Value: $count =back Counts the results in a literal query. Equivalent to calling L with the passed arguments, then L. =cut sub count_literal { shift->search_literal(@_)->count; } =head2 all =over 4 =item Arguments: none =item Return Value: L<@result_objs|DBIx::Class::Manual::ResultClass> =back Returns all elements in the resultset. =cut sub all { my $self = shift; if(@_) { $self->throw_exception("all() doesn't take any arguments, you probably wanted ->search(...)->all()"); } delete @{$self}{qw/_stashed_rows _stashed_results/}; if (my $c = $self->get_cache) { return @$c; } $self->cursor->reset; my $objs = $self->_construct_results('fetch_all') || []; $self->set_cache($objs) if $self->{attrs}{cache}; return @$objs; } =head2 reset =over 4 =item Arguments: none =item Return Value: $self =back Resets the resultset's cursor, so you can iterate through the elements again. Implicitly resets the storage cursor, so a subsequent L will trigger another query. =cut sub reset { my ($self) = @_; delete @{$self}{qw/_stashed_rows _stashed_results/}; $self->{all_cache_position} = 0; $self->cursor->reset; return $self; } =head2 first =over 4 =item Arguments: none =item Return Value: L<$result|DBIx::Class::Manual::ResultClass> | undef =back L the resultset (causing a fresh query to storage) and returns an object for the first result (or C if the resultset is empty). =cut sub first { return $_[0]->reset->next; } # _rs_update_delete # # Determines whether and what type of subquery is required for the $rs operation. # If grouping is necessary either supplies its own, or verifies the current one # After all is done delegates to the proper storage method. sub _rs_update_delete { my ($self, $op, $values) = @_; my $rsrc = $self->result_source; my $storage = $rsrc->schema->storage; my $attrs = { %{$self->_resolved_attrs} }; my $join_classifications; my ($existing_group_by) = delete @{$attrs}{qw(group_by _grouped_by_distinct)}; # do we need a subquery for any reason? my $needs_subq = ( defined $existing_group_by or # if {from} is unparseable wrap a subq ref($attrs->{from}) ne 'ARRAY' or # limits call for a subq $self->_has_resolved_attr(qw/rows offset/) ); # simplify the joinmap, so we can further decide if a subq is necessary if (!$needs_subq and @{$attrs->{from}} > 1) { ($attrs->{from}, $join_classifications) = $storage->_prune_unused_joins ($attrs); # any non-pruneable non-local restricting joins imply subq $needs_subq = grep { $_ ne $attrs->{alias} } keys %{ $join_classifications->{restricting} || {} }; } # check if the head is composite (by now all joins are thrown out unless $needs_subq) $needs_subq ||= ( (ref $attrs->{from}[0]) ne 'HASH' or ref $attrs->{from}[0]{ $attrs->{from}[0]{-alias} } ); my ($cond, $guard); # do we need anything like a subquery? if (! $needs_subq) { # Most databases do not allow aliasing of tables in UPDATE/DELETE. Thus # a condition containing 'me' or other table prefixes will not work # at all. Tell SQLMaker to dequalify idents via a gross hack. $cond = do { my $sqla = $rsrc->storage->sql_maker; local $sqla->{_dequalify_idents} = 1; \[ $sqla->_recurse_where($self->{cond}) ]; }; } else { # we got this far - means it is time to wrap a subquery my $idcols = $rsrc->_identifying_column_set || $self->throw_exception( sprintf( "Unable to perform complex resultset %s() without an identifying set of columns on source '%s'", $op, $rsrc->source_name, ) ); # make a new $rs selecting only the PKs (that's all we really need for the subq) delete $attrs->{$_} for qw/select as collapse/; $attrs->{columns} = [ map { "$attrs->{alias}.$_" } @$idcols ]; # this will be consumed by the pruner waaaaay down the stack $attrs->{_force_prune_multiplying_joins} = 1; my $subrs = (ref $self)->new($rsrc, $attrs); if (@$idcols == 1) { $cond = { $idcols->[0] => { -in => $subrs->as_query } }; } elsif ($storage->_use_multicolumn_in) { # no syntax for calling this properly yet # !!! EXPERIMENTAL API !!! WILL CHANGE !!! $cond = $storage->sql_maker->_where_op_multicolumn_in ( $idcols, # how do I convey a list of idents...? can binds reside on lhs? $subrs->as_query ), } else { # if all else fails - get all primary keys and operate over a ORed set # wrap in a transaction for consistency # this is where the group_by/multiplication starts to matter if ( $existing_group_by or # we do not need to check pre-multipliers, since if the premulti is there, its # parent (who is multi) will be there too keys %{ $join_classifications->{multiplying} || {} } ) { # make sure if there is a supplied group_by it matches the columns compiled above # perfectly. Anything else can not be sanely executed on most databases so croak # right then and there if ($existing_group_by) { my @current_group_by = map { $_ =~ /\./ ? $_ : "$attrs->{alias}.$_" } @$existing_group_by ; if ( join ("\x00", sort @current_group_by) ne join ("\x00", sort @{$attrs->{columns}} ) ) { $self->throw_exception ( "You have just attempted a $op operation on a resultset which does group_by" . ' on columns other than the primary keys, while DBIC internally needs to retrieve' . ' the primary keys in a subselect. All sane RDBMS engines do not support this' . ' kind of queries. Please retry the operation with a modified group_by or' . ' without using one at all.' ); } } $subrs = $subrs->search({}, { group_by => $attrs->{columns} }); } $guard = $storage->txn_scope_guard; for my $row ($subrs->cursor->all) { push @$cond, { map { $idcols->[$_] => $row->[$_] } (0 .. $#$idcols) }; } } } my $res = $cond ? $storage->$op ( $rsrc, $op eq 'update' ? $values : (), $cond, ) : '0E0'; $guard->commit if $guard; return $res; } =head2 update =over 4 =item Arguments: \%values =item Return Value: $underlying_storage_rv =back Sets the specified columns in the resultset to the supplied values in a single query. Note that this will not run any accessor/set_column/update triggers, nor will it update any result object instances derived from this resultset (this includes the contents of the L if any). See L if you need to execute any on-update triggers or cascades defined either by you or a L. The return value is a pass through of what the underlying storage backend returned, and may vary. See L for the most common case. =head3 CAVEAT Note that L does not process/deflate any of the values passed in. This is unlike the corresponding L. The user must ensure manually that any value passed to this method will stringify to something the RDBMS knows how to deal with. A notable example is the handling of L objects, for more info see: L. =cut sub update { my ($self, $values) = @_; $self->throw_exception('Values for update must be a hash') unless ref $values eq 'HASH'; return $self->_rs_update_delete ('update', $values); } =head2 update_all =over 4 =item Arguments: \%values =item Return Value: 1 =back Fetches all objects and updates them one at a time via L. Note that C will run DBIC defined triggers, while L will not. =cut sub update_all { my ($self, $values) = @_; $self->throw_exception('Values for update_all must be a hash') unless ref $values eq 'HASH'; my $guard = $self->result_source->schema->txn_scope_guard; $_->update({%$values}) for $self->all; # shallow copy - update will mangle it $guard->commit; return 1; } =head2 delete =over 4 =item Arguments: none =item Return Value: $underlying_storage_rv =back Deletes the rows matching this resultset in a single query. Note that this will not run any delete triggers, nor will it alter the L status of any result object instances derived from this resultset (this includes the contents of the L if any). See L if you need to execute any on-delete triggers or cascades defined either by you or a L. The return value is a pass through of what the underlying storage backend returned, and may vary. See L for the most common case. =cut sub delete { my $self = shift; $self->throw_exception('delete does not accept any arguments') if @_; return $self->_rs_update_delete ('delete'); } =head2 delete_all =over 4 =item Arguments: none =item Return Value: 1 =back Fetches all objects and deletes them one at a time via L. Note that C will run DBIC defined triggers, while L will not. =cut sub delete_all { my $self = shift; $self->throw_exception('delete_all does not accept any arguments') if @_; my $guard = $self->result_source->schema->txn_scope_guard; $_->delete for $self->all; $guard->commit; return 1; } =head2 populate =over 4 =item Arguments: [ \@column_list, \@row_values+ ] | [ \%col_data+ ] =item Return Value: L<\@result_objects|DBIx::Class::Manual::ResultClass> (scalar context) | L<@result_objects|DBIx::Class::Manual::ResultClass> (list context) =back Accepts either an arrayref of hashrefs or alternatively an arrayref of arrayrefs. =over =item NOTE The context of this method call has an important effect on what is submitted to storage. In void context data is fed directly to fastpath insertion routines provided by the underlying storage (most often L), bypassing the L and L calls on the L class, including any augmentation of these methods provided by components. For example if you are using something like L to create primary keys for you, you will find that your PKs are empty. In this case you will have to explicitly force scalar or list context in order to create those values. =back In non-void (scalar or list) context, this method is simply a wrapper for L. Depending on list or scalar context either a list of L objects or an arrayref containing these objects is returned. When supplying data in "arrayref of arrayrefs" invocation style, the first element should be a list of column names and each subsequent element should be a data value in the earlier specified column order. For example: $schema->resultset("Artist")->populate([ [ qw( artistid name ) ], [ 100, 'A Formally Unknown Singer' ], [ 101, 'A singer that jumped the shark two albums ago' ], [ 102, 'An actually cool singer' ], ]); For the arrayref of hashrefs style each hashref should be a structure suitable for passing to L. Multi-create is also permitted with this syntax. $schema->resultset("Artist")->populate([ { artistid => 4, name => 'Manufactured Crap', cds => [ { title => 'My First CD', year => 2006 }, { title => 'Yet More Tweeny-Pop crap', year => 2007 }, ], }, { artistid => 5, name => 'Angsty-Whiny Girl', cds => [ { title => 'My parents sold me to a record company', year => 2005 }, { title => 'Why Am I So Ugly?', year => 2006 }, { title => 'I Got Surgery and am now Popular', year => 2007 } ], }, ]); If you attempt a void-context multi-create as in the example above (each Artist also has the related list of CDs), and B supply the necessary autoinc foreign key information, this method will proxy to the less efficient L, and then throw the Result objects away. In this case there are obviously no benefits to using this method over L. =cut sub populate { my $self = shift; # this is naive and just a quick check # the types will need to be checked more thoroughly when the # multi-source populate gets added my $data = ( ref $_[0] eq 'ARRAY' and ( @{$_[0]} or return ) and ( ref $_[0][0] eq 'HASH' or ref $_[0][0] eq 'ARRAY' ) and $_[0] ) or $self->throw_exception('Populate expects an arrayref of hashrefs or arrayref of arrayrefs'); # FIXME - no cref handling # At this point assume either hashes or arrays if(defined wantarray) { my (@results, $guard); if (ref $data->[0] eq 'ARRAY') { # column names only, nothing to do return if @$data == 1; $guard = $self->result_source->schema->storage->txn_scope_guard if @$data > 2; @results = map { my $vals = $_; $self->new_result({ map { $data->[0][$_] => $vals->[$_] } 0..$#{$data->[0]} })->insert } @{$data}[1 .. $#$data] ; } else { $guard = $self->result_source->schema->storage->txn_scope_guard if @$data > 1; @results = map { $self->new_result($_)->insert } @$data; } $guard->commit if $guard; return wantarray ? @results : \@results; } # we have to deal with *possibly incomplete* related data # this means we have to walk the data structure twice # whether we want this or not # jnap, I hate you ;) my $rsrc = $self->result_source; my $rel_info = { map { $_ => $rsrc->relationship_info($_) } $rsrc->relationships }; my ($colinfo, $colnames, $slices_with_rels); my $data_start = 0; DATA_SLICE: for my $i (0 .. $#$data) { my $current_slice_seen_rel_infos; ### Determine/Supplement collists ### BEWARE - This is a hot piece of code, a lot of weird idioms were used if( ref $data->[$i] eq 'ARRAY' ) { # positional(!) explicit column list if ($i == 0) { # column names only, nothing to do return if @$data == 1; $colinfo->{$data->[0][$_]} = { pos => $_, name => $data->[0][$_] } and push @$colnames, $data->[0][$_] for 0 .. $#{$data->[0]}; $data_start = 1; next DATA_SLICE; } else { for (values %$colinfo) { if ($_->{is_rel} ||= ( $rel_info->{$_->{name}} and ( ref $data->[$i][$_->{pos}] eq 'ARRAY' or ref $data->[$i][$_->{pos}] eq 'HASH' or ( defined blessed $data->[$i][$_->{pos}] and $data->[$i][$_->{pos}]->isa('DBIx::Class::Row') ) ) and 1 )) { # moar sanity check... sigh for ( ref $data->[$i][$_->{pos}] eq 'ARRAY' ? @{$data->[$i][$_->{pos}]} : $data->[$i][$_->{pos}] ) { if ( defined blessed $_ and $_->isa('DBIx::Class::Row' ) ) { carp_unique("Fast-path populate() with supplied related objects is not possible - falling back to regular create()"); return my $throwaway = $self->populate(@_); } } push @$current_slice_seen_rel_infos, $rel_info->{$_->{name}}; } } } if ($current_slice_seen_rel_infos) { push @$slices_with_rels, { map { $colnames->[$_] => $data->[$i][$_] } 0 .. $#$colnames }; # this is needed further down to decide whether or not to fallback to create() $colinfo->{$colnames->[$_]}{seen_null} ||= ! defined $data->[$i][$_] for 0 .. $#$colnames; } } elsif( ref $data->[$i] eq 'HASH' ) { for ( sort keys %{$data->[$i]} ) { $colinfo->{$_} ||= do { $self->throw_exception("Column '$_' must be present in supplied explicit column list") if $data_start; # it will be 0 on AoH, 1 on AoA push @$colnames, $_; # RV { pos => $#$colnames, name => $_ } }; if ($colinfo->{$_}{is_rel} ||= ( $rel_info->{$_} and ( ref $data->[$i]{$_} eq 'ARRAY' or ref $data->[$i]{$_} eq 'HASH' or ( defined blessed $data->[$i]{$_} and $data->[$i]{$_}->isa('DBIx::Class::Row') ) ) and 1 )) { # moar sanity check... sigh for ( ref $data->[$i]{$_} eq 'ARRAY' ? @{$data->[$i]{$_}} : $data->[$i]{$_} ) { if ( defined blessed $_ and $_->isa('DBIx::Class::Row' ) ) { carp_unique("Fast-path populate() with supplied related objects is not possible - falling back to regular create()"); return my $throwaway = $self->populate(@_); } } push @$current_slice_seen_rel_infos, $rel_info->{$_}; } } if ($current_slice_seen_rel_infos) { push @$slices_with_rels, $data->[$i]; # this is needed further down to decide whether or not to fallback to create() $colinfo->{$_}{seen_null} ||= ! defined $data->[$i]{$_} for keys %{$data->[$i]}; } } else { $self->throw_exception('Unexpected populate() data structure member type: ' . ref $data->[$i] ); } if ( grep { $_->{attrs}{is_depends_on} } @{ $current_slice_seen_rel_infos || [] } ) { carp_unique("Fast-path populate() of belongs_to relationship data is not possible - falling back to regular create()"); return my $throwaway = $self->populate(@_); } } if( $slices_with_rels ) { # need to exclude the rel "columns" $colnames = [ grep { ! $colinfo->{$_}{is_rel} } @$colnames ]; # extra sanity check - ensure the main source is in fact identifiable # the localizing of nullability is insane, but oh well... the use-case is legit my $ci = $rsrc->columns_info($colnames); $ci->{$_} = { %{$ci->{$_}}, is_nullable => 0 } for grep { ! $colinfo->{$_}{seen_null} } keys %$ci; unless( $rsrc->_identifying_column_set($ci) ) { carp_unique("Fast-path populate() of non-uniquely identifiable rows with related data is not possible - falling back to regular create()"); return my $throwaway = $self->populate(@_); } } ### inherit the data locked in the conditions of the resultset my ($rs_data) = $self->_merge_with_rscond({}); delete @{$rs_data}{@$colnames}; # passed-in stuff takes precedence # if anything left - decompose rs_data my $rs_data_vals; if (keys %$rs_data) { push @$rs_data_vals, $rs_data->{$_} for sort keys %$rs_data; } ### start work my $guard; $guard = $rsrc->schema->storage->txn_scope_guard if $slices_with_rels; ### main source data # FIXME - need to switch entirely to a coderef-based thing, # so that large sets aren't copied several times... I think $rsrc->storage->_insert_bulk( $rsrc, [ @$colnames, sort keys %$rs_data ], [ map { ref $data->[$_] eq 'ARRAY' ? ( $slices_with_rels ? [ @{$data->[$_]}[0..$#$colnames], @{$rs_data_vals||[]} ] # the collist changed : $rs_data_vals ? [ @{$data->[$_]}, @$rs_data_vals ] : $data->[$_] ) : [ @{$data->[$_]}{@$colnames}, @{$rs_data_vals||[]} ] } $data_start .. $#$data ], ); ### do the children relationships if ( $slices_with_rels ) { my @rels = grep { $colinfo->{$_}{is_rel} } keys %$colinfo or die 'wtf... please report a bug with DBIC_TRACE=1 output (stacktrace)'; for my $sl (@$slices_with_rels) { my ($main_proto, $main_proto_rs); for my $rel (@rels) { next unless defined $sl->{$rel}; $main_proto ||= { %$rs_data, (map { $_ => $sl->{$_} } @$colnames), }; unless (defined $colinfo->{$rel}{rs}) { $colinfo->{$rel}{rs} = $rsrc->related_source($rel)->resultset; $colinfo->{$rel}{fk_map} = { reverse %{ $rsrc->_resolve_relationship_condition( rel_name => $rel, self_alias => "\xFE", # irrelevant foreign_alias => "\xFF", # irrelevant )->{identity_map} || {} } }; } $colinfo->{$rel}{rs}->search({ map # only so that we inherit them values properly, no actual search { $_ => { '=' => ( $main_proto_rs ||= $rsrc->resultset->search($main_proto) ) ->get_column( $colinfo->{$rel}{fk_map}{$_} ) ->as_query } } keys %{$colinfo->{$rel}{fk_map}} })->populate( ref $sl->{$rel} eq 'ARRAY' ? $sl->{$rel} : [ $sl->{$rel} ] ); 1; } } } $guard->commit if $guard; } =head2 pager =over 4 =item Arguments: none =item Return Value: L<$pager|DBIx::Class::ResultSet::Pager> =back Returns a L object tied to the current resultset. Requires the C attribute to have been previously set on the resultset object, usually via a call to L. To get the full count of entries for a paged resultset, call L on the pager object. =cut sub pager { my ($self) = @_; return $self->{pager} if $self->{pager}; my $attrs = $self->{attrs}; if (!defined $attrs->{page}) { $self->throw_exception("Can't create pager for non-paged rs, you need to call page(\$num) first"); } elsif ($attrs->{page} <= 0) { $self->throw_exception('Invalid page number (page-numbers are 1-based)'); } $attrs->{rows} ||= 10; # throw away the paging flags and re-run the count (possibly # with a subselect) to get the real total count my $count_attrs = { %$attrs }; delete @{$count_attrs}{qw/rows offset page pager/}; my $total_rs = (ref $self)->new($self->result_source, $count_attrs); require DBIx::Class::ResultSet::Pager; return $self->{pager} = DBIx::Class::ResultSet::Pager->new( sub { $total_rs->count }, #lazy-get the total $attrs->{rows}, $self->{attrs}{page}, ); } =head2 page =over 4 =item Arguments: $page_number =item Return Value: L<$resultset|/search> =back Returns a resultset for the $page_number page of the resultset on which page is called, where each page contains a number of rows equal to the 'rows' attribute set on the resultset (10 by default). =cut sub page { my ($self, $page) = @_; return (ref $self)->new($self->result_source, { %{$self->{attrs}}, page => $page }); } =head2 new_result =over 4 =item Arguments: \%col_data =item Return Value: L<$result|DBIx::Class::Manual::ResultClass> =back Creates a new result object in the resultset's result class and returns it. The row is not inserted into the database at this point, call L to do that. Calling L will tell you whether the result object has been inserted or not. Passes the hashref of input on to L. =cut sub new_result { my ($self, $values) = @_; $self->throw_exception( "new_result takes only one argument - a hashref of values" ) if @_ > 2; $self->throw_exception( "Result object instantiation requires a hashref as argument" ) unless (ref $values eq 'HASH'); my ($merged_cond, $cols_from_relations) = $self->_merge_with_rscond($values); my $new = $self->result_class->new({ %$merged_cond, ( @$cols_from_relations ? (-cols_from_relations => $cols_from_relations) : () ), -result_source => $self->result_source, # DO NOT REMOVE THIS, REQUIRED }); if ( reftype($new) eq 'HASH' and ! keys %$new and blessed($new) ) { carp_unique (sprintf ( "%s->new returned a blessed empty hashref - a strong indicator something is wrong with its inheritance chain", $self->result_class, )); } $new; } # _merge_with_rscond # # Takes a simple hash of K/V data and returns its copy merged with the # condition already present on the resultset. Additionally returns an # arrayref of value/condition names, which were inferred from related # objects (this is needed for in-memory related objects) sub _merge_with_rscond { my ($self, $data) = @_; my ($implied_data, @cols_from_relations); my $alias = $self->{attrs}{alias}; if (! defined $self->{cond}) { # just massage $data below } elsif ($self->{cond} eq UNRESOLVABLE_CONDITION) { $implied_data = $self->{attrs}{related_objects}; # nothing might have been inserted yet @cols_from_relations = keys %{ $implied_data || {} }; } else { my $eqs = $self->result_source->schema->storage->_extract_fixed_condition_columns($self->{cond}, 'consider_nulls'); $implied_data = { map { ( ($eqs->{$_}||'') eq UNRESOLVABLE_CONDITION ) ? () : ( $_ => $eqs->{$_} ) } keys %$eqs }; } return ( { map { %{ $self->_remove_alias($_, $alias) } } # precedence must be given to passed values over values inherited from # the cond, so the order here is important. ( $implied_data||(), $data) }, \@cols_from_relations ); } # _has_resolved_attr # # determines if the resultset defines at least one # of the attributes supplied # # used to determine if a subquery is necessary # # supports some virtual attributes: # -join # This will scan for any joins being present on the resultset. # It is not a mere key-search but a deep inspection of {from} # sub _has_resolved_attr { my ($self, @attr_names) = @_; my $attrs = $self->_resolved_attrs; my %extra_checks; for my $n (@attr_names) { if (grep { $n eq $_ } (qw/-join/) ) { $extra_checks{$n}++; next; } my $attr = $attrs->{$n}; next if not defined $attr; if (ref $attr eq 'HASH') { return 1 if keys %$attr; } elsif (ref $attr eq 'ARRAY') { return 1 if @$attr; } else { return 1 if $attr; } } # a resolved join is expressed as a multi-level from return 1 if ( $extra_checks{-join} and ref $attrs->{from} eq 'ARRAY' and @{$attrs->{from}} > 1 ); return 0; } # _remove_alias # # Remove the specified alias from the specified query hash. A copy is made so # the original query is not modified. sub _remove_alias { my ($self, $query, $alias) = @_; my %orig = %{ $query || {} }; my %unaliased; foreach my $key (keys %orig) { if ($key !~ /\./) { $unaliased{$key} = $orig{$key}; next; } $unaliased{$1} = $orig{$key} if $key =~ m/^(?:\Q$alias\E\.)?([^.]+)$/; } return \%unaliased; } =head2 as_query =over 4 =item Arguments: none =item Return Value: \[ $sql, L<@bind_values|/DBIC BIND VALUES> ] =back Returns the SQL query and bind vars associated with the invocant. This is generally used as the RHS for a subquery. =cut sub as_query { my $self = shift; my $attrs = { %{ $self->_resolved_attrs } }; my $aq = $self->result_source->storage->_select_args_to_query ( $attrs->{from}, $attrs->{select}, $attrs->{where}, $attrs ); $aq; } =head2 find_or_new =over 4 =item Arguments: \%col_data, { key => $unique_constraint, L<%attrs|/ATTRIBUTES> }? =item Return Value: L<$result|DBIx::Class::Manual::ResultClass> =back my $artist = $schema->resultset('Artist')->find_or_new( { artist => 'fred' }, { key => 'artists' }); $cd->cd_to_producer->find_or_new({ producer => $producer }, { key => 'primary' }); Find an existing record from this resultset using L. if none exists, instantiate a new result object and return it. The object will not be saved into your storage until you call L on it. You most likely want this method when looking for existing rows using a unique constraint that is not the primary key, or looking for related rows. If you want objects to be saved immediately, use L instead. B: Make sure to read the documentation of L and understand the significance of the C attribute, as its lack may skew your search, and subsequently result in spurious new objects. B: Take care when using C with a table having columns with default values that you intend to be automatically supplied by the database (e.g. an auto_increment primary key column). In normal usage, the value of such columns should NOT be included at all in the call to C, even when set to C. =cut sub find_or_new { my $self = shift; my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {}); my $hash = ref $_[0] eq 'HASH' ? shift : {@_}; if (keys %$hash and my $row = $self->find($hash, $attrs) ) { return $row; } return $self->new_result($hash); } =head2 create =over 4 =item Arguments: \%col_data =item Return Value: L<$result|DBIx::Class::Manual::ResultClass> =back Attempt to create a single new row or a row with multiple related rows in the table represented by the resultset (and related tables). This will not check for duplicate rows before inserting, use L to do that. To create one row for this resultset, pass a hashref of key/value pairs representing the columns of the table and the values you wish to store. If the appropriate relationships are set up, foreign key fields can also be passed an object representing the foreign row, and the value will be set to its primary key. To create related objects, pass a hashref of related-object column values B. If the relationship is of type C (L) - pass an arrayref of hashrefs. The process will correctly identify columns holding foreign keys, and will transparently populate them from the keys of the corresponding relation. This can be applied recursively, and will work correctly for a structure with an arbitrary depth and width, as long as the relationships actually exists and the correct column data has been supplied. Instead of hashrefs of plain related data (key/value pairs), you may also pass new or inserted objects. New objects (not inserted yet, see L), will be inserted into their appropriate tables. Effectively a shortcut for C<< ->new_result(\%col_data)->insert >>. Example of creating a new row. $person_rs->create({ name=>"Some Person", email=>"somebody@someplace.com" }); Example of creating a new row and also creating rows in a related C or C resultset. Note Arrayref. $artist_rs->create( { artistid => 4, name => 'Manufactured Crap', cds => [ { title => 'My First CD', year => 2006 }, { title => 'Yet More Tweeny-Pop crap', year => 2007 }, ], }, ); Example of creating a new row and also creating a row in a related C resultset. Note Hashref. $cd_rs->create({ title=>"Music for Silly Walks", year=>2000, artist => { name=>"Silly Musician", } }); =over =item WARNING When subclassing ResultSet never attempt to override this method. Since it is a simple shortcut for C<< $self->new_result($attrs)->insert >>, a lot of the internals simply never call it, so your override will be bypassed more often than not. Override either L or L depending on how early in the L process you need to intervene. See also warning pertaining to L. =back =cut sub create { #my ($self, $col_data) = @_; DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; return shift->new_result(shift)->insert; } =head2 find_or_create =over 4 =item Arguments: \%col_data, { key => $unique_constraint, L<%attrs|/ATTRIBUTES> }? =item Return Value: L<$result|DBIx::Class::Manual::ResultClass> =back $cd->cd_to_producer->find_or_create({ producer => $producer }, { key => 'primary' }); Tries to find a record based on its primary key or unique constraints; if none is found, creates one and returns that instead. my $cd = $schema->resultset('CD')->find_or_create({ cdid => 5, artist => 'Massive Attack', title => 'Mezzanine', year => 2005, }); Also takes an optional C attribute, to search by a specific key or unique constraint. For example: my $cd = $schema->resultset('CD')->find_or_create( { artist => 'Massive Attack', title => 'Mezzanine', }, { key => 'cd_artist_title' } ); B: Make sure to read the documentation of L and understand the significance of the C attribute, as its lack may skew your search, and subsequently result in spurious row creation. B: Because find_or_create() reads from the database and then possibly inserts based on the result, this method is subject to a race condition. Another process could create a record in the table after the find has completed and before the create has started. To avoid this problem, use find_or_create() inside a transaction. B: Take care when using C with a table having columns with default values that you intend to be automatically supplied by the database (e.g. an auto_increment primary key column). In normal usage, the value of such columns should NOT be included at all in the call to C, even when set to C. See also L and L. For information on how to declare unique constraints, see L. If you need to know if an existing row was found or a new one created use L and L instead. Don't forget to call L to save the newly created row to the database! my $cd = $schema->resultset('CD')->find_or_new({ cdid => 5, artist => 'Massive Attack', title => 'Mezzanine', year => 2005, }); if( !$cd->in_storage ) { # do some stuff $cd->insert; } =cut sub find_or_create { my $self = shift; my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {}); my $hash = ref $_[0] eq 'HASH' ? shift : {@_}; if (keys %$hash and my $row = $self->find($hash, $attrs) ) { return $row; } return $self->new_result($hash)->insert; } =head2 update_or_create =over 4 =item Arguments: \%col_data, { key => $unique_constraint, L<%attrs|/ATTRIBUTES> }? =item Return Value: L<$result|DBIx::Class::Manual::ResultClass> =back $resultset->update_or_create({ col => $val, ... }); Like L, but if a row is found it is immediately updated via C<< $found_row->update (\%col_data) >>. Takes an optional C attribute to search on a specific unique constraint. For example: # In your application my $cd = $schema->resultset('CD')->update_or_create( { artist => 'Massive Attack', title => 'Mezzanine', year => 1998, }, { key => 'cd_artist_title' } ); $cd->cd_to_producer->update_or_create({ producer => $producer, name => 'harry', }, { key => 'primary', }); B: Make sure to read the documentation of L and understand the significance of the C attribute, as its lack may skew your search, and subsequently result in spurious row creation. B: Take care when using C with a table having columns with default values that you intend to be automatically supplied by the database (e.g. an auto_increment primary key column). In normal usage, the value of such columns should NOT be included at all in the call to C, even when set to C. See also L and L. For information on how to declare unique constraints, see L. If you need to know if an existing row was updated or a new one created use L and L instead. Don't forget to call L to save the newly created row to the database! =cut sub update_or_create { my $self = shift; my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {}); my $cond = ref $_[0] eq 'HASH' ? shift : {@_}; my $row = $self->find($cond, $attrs); if (defined $row) { $row->update($cond); return $row; } return $self->new_result($cond)->insert; } =head2 update_or_new =over 4 =item Arguments: \%col_data, { key => $unique_constraint, L<%attrs|/ATTRIBUTES> }? =item Return Value: L<$result|DBIx::Class::Manual::ResultClass> =back $resultset->update_or_new({ col => $val, ... }); Like L but if a row is found it is immediately updated via C<< $found_row->update (\%col_data) >>. For example: # In your application my $cd = $schema->resultset('CD')->update_or_new( { artist => 'Massive Attack', title => 'Mezzanine', year => 1998, }, { key => 'cd_artist_title' } ); if ($cd->in_storage) { # the cd was updated } else { # the cd is not yet in the database, let's insert it $cd->insert; } B: Make sure to read the documentation of L and understand the significance of the C attribute, as its lack may skew your search, and subsequently result in spurious new objects. B: Take care when using C with a table having columns with default values that you intend to be automatically supplied by the database (e.g. an auto_increment primary key column). In normal usage, the value of such columns should NOT be included at all in the call to C, even when set to C. See also L, L and L. =cut sub update_or_new { my $self = shift; my $attrs = ( @_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {} ); my $cond = ref $_[0] eq 'HASH' ? shift : {@_}; my $row = $self->find( $cond, $attrs ); if ( defined $row ) { $row->update($cond); return $row; } return $self->new_result($cond); } =head2 get_cache =over 4 =item Arguments: none =item Return Value: L<\@result_objs|DBIx::Class::Manual::ResultClass> | undef =back Gets the contents of the cache for the resultset, if the cache is set. The cache is populated either by using the L attribute to L or by calling L. =cut sub get_cache { shift->{all_cache}; } =head2 set_cache =over 4 =item Arguments: L<\@result_objs|DBIx::Class::Manual::ResultClass> =item Return Value: L<\@result_objs|DBIx::Class::Manual::ResultClass> =back Sets the contents of the cache for the resultset. Expects an arrayref of objects of the same class as those produced by the resultset. Note that if the cache is set, the resultset will return the cached objects rather than re-querying the database even if the cache attr is not set. The contents of the cache can also be populated by using the L attribute to L. =cut sub set_cache { my ( $self, $data ) = @_; $self->throw_exception("set_cache requires an arrayref") if defined($data) && (ref $data ne 'ARRAY'); $self->{all_cache} = $data; } =head2 clear_cache =over 4 =item Arguments: none =item Return Value: undef =back Clears the cache for the resultset. =cut sub clear_cache { shift->set_cache(undef); } =head2 is_paged =over 4 =item Arguments: none =item Return Value: true, if the resultset has been paginated =back =cut sub is_paged { my ($self) = @_; return !!$self->{attrs}{page}; } =head2 is_ordered =over 4 =item Arguments: none =item Return Value: true, if the resultset has been ordered with C. =back =cut sub is_ordered { my ($self) = @_; return scalar $self->result_source->storage->_extract_order_criteria($self->{attrs}{order_by}); } =head2 related_resultset =over 4 =item Arguments: $rel_name =item Return Value: L<$resultset|/search> =back Returns a related resultset for the supplied relationship name. $artist_rs = $schema->resultset('CD')->related_resultset('Artist'); =cut sub related_resultset { my ($self, $rel) = @_; return $self->{related_resultsets}{$rel} if defined $self->{related_resultsets}{$rel}; return $self->{related_resultsets}{$rel} = do { my $rsrc = $self->result_source; my $rel_info = $rsrc->relationship_info($rel); $self->throw_exception( "search_related: result source '" . $rsrc->source_name . "' has no such relationship $rel") unless $rel_info; my $attrs = $self->_chain_relationship($rel); my $join_count = $attrs->{seen_join}{$rel}; my $alias = $self->result_source->storage ->relname_to_table_alias($rel, $join_count); # since this is search_related, and we already slid the select window inwards # (the select/as attrs were deleted in the beginning), we need to flip all # left joins to inner, so we get the expected results # read the comment on top of the actual function to see what this does $attrs->{from} = $rsrc->schema->storage->_inner_join_to_node ($attrs->{from}, $alias); #XXX - temp fix for result_class bug. There likely is a more elegant fix -groditi delete @{$attrs}{qw(result_class alias)}; my $rel_source = $rsrc->related_source($rel); my $new = do { # The reason we do this now instead of passing the alias to the # search_rs below is that if you wrap/overload resultset on the # source you need to know what alias it's -going- to have for things # to work sanely (e.g. RestrictWithObject wants to be able to add # extra query restrictions, and these may need to be $alias.) my $rel_attrs = $rel_source->resultset_attributes; local $rel_attrs->{alias} = $alias; $rel_source->resultset ->search_rs( undef, { %$attrs, where => $attrs->{where}, }); }; if (my $cache = $self->get_cache) { my @related_cache = map { $_->related_resultset($rel)->get_cache || () } @$cache ; $new->set_cache([ map @$_, @related_cache ]) if @related_cache == @$cache; } $new; }; } =head2 current_source_alias =over 4 =item Arguments: none =item Return Value: $source_alias =back Returns the current table alias for the result source this resultset is built on, that will be used in the SQL query. Usually it is C. Currently the source alias that refers to the result set returned by a L/L family method depends on how you got to the resultset: it's C by default, but eg. L aliases it to the related result source name (and keeps C referring to the original result set). The long term goal is to make L always alias the current resultset as C (and make this method unnecessary). Thus it's currently necessary to use this method in predefined queries (see L) when referring to the source alias of the current result set: # in a result set class sub modified_by { my ($self, $user) = @_; my $me = $self->current_source_alias; return $self->search({ "$me.modified" => $user->id, }); } The alias of L can be altered by the L. =cut sub current_source_alias { return (shift->{attrs} || {})->{alias} || 'me'; } =head2 as_subselect_rs =over 4 =item Arguments: none =item Return Value: L<$resultset|/search> =back Act as a barrier to SQL symbols. The resultset provided will be made into a "virtual view" by including it as a subquery within the from clause. From this point on, any joined tables are inaccessible to ->search on the resultset (as if it were simply where-filtered without joins). For example: my $rs = $schema->resultset('Bar')->search({'x.name' => 'abc'},{ join => 'x' }); # 'x' now pollutes the query namespace # So the following works as expected my $ok_rs = $rs->search({'x.other' => 1}); # But this doesn't: instead of finding a 'Bar' related to two x rows (abc and # def) we look for one row with contradictory terms and join in another table # (aliased 'x_2') which we never use my $broken_rs = $rs->search({'x.name' => 'def'}); my $rs2 = $rs->as_subselect_rs; # doesn't work - 'x' is no longer accessible in $rs2, having been sealed away my $not_joined_rs = $rs2->search({'x.other' => 1}); # works as expected: finds a 'table' row related to two x rows (abc and def) my $correctly_joined_rs = $rs2->search({'x.name' => 'def'}); Another example of when one might use this would be to select a subset of columns in a group by clause: my $rs = $schema->resultset('Bar')->search(undef, { group_by => [qw{ id foo_id baz_id }], })->as_subselect_rs->search(undef, { columns => [qw{ id foo_id }] }); In the above example normally columns would have to be equal to the group by, but because we isolated the group by into a subselect the above works. =cut sub as_subselect_rs { my $self = shift; my $attrs = $self->_resolved_attrs; my $fresh_rs = (ref $self)->new ( $self->result_source, {}, ); # these pieces will be locked in the subquery delete $fresh_rs->{cond}; delete @{$fresh_rs->{attrs}}{qw/where bind/}; return $fresh_rs->search( {}, { from => [{ $attrs->{alias} => $self->as_query, -alias => $attrs->{alias}, -rsrc => $self->result_source, }], alias => $attrs->{alias}, }); } # This code is called by search_related, and makes sure there # is clear separation between the joins before, during, and # after the relationship. This information is needed later # in order to properly resolve prefetch aliases (any alias # with a relation_chain_depth less than the depth of the # current prefetch is not considered) # # The increments happen twice per join. An even number means a # relationship specified via a search_related, whereas an odd # number indicates a join/prefetch added via attributes # # Also this code will wrap the current resultset (the one we # chain to) in a subselect IFF it contains limiting attributes sub _chain_relationship { my ($self, $rel) = @_; my $source = $self->result_source; my $attrs = { %{$self->{attrs}||{}} }; # we need to take the prefetch the attrs into account before we # ->_resolve_join as otherwise they get lost - captainL my $join = $self->_merge_joinpref_attr( $attrs->{join}, $attrs->{prefetch} ); delete @{$attrs}{qw/join prefetch collapse group_by distinct _grouped_by_distinct select as columns +select +as +columns/}; my $seen = { %{ (delete $attrs->{seen_join}) || {} } }; my $from; my @force_subq_attrs = qw/offset rows group_by having/; if ( ($attrs->{from} && ref $attrs->{from} ne 'ARRAY') || $self->_has_resolved_attr (@force_subq_attrs) ) { # Nuke the prefetch (if any) before the new $rs attrs # are resolved (prefetch is useless - we are wrapping # a subquery anyway). my $rs_copy = $self->search; $rs_copy->{attrs}{join} = $self->_merge_joinpref_attr ( $rs_copy->{attrs}{join}, delete $rs_copy->{attrs}{prefetch}, ); $from = [{ -rsrc => $source, -alias => $attrs->{alias}, $attrs->{alias} => $rs_copy->as_query, }]; delete @{$attrs}{@force_subq_attrs, qw/where bind/}; $seen->{-relation_chain_depth} = 0; } elsif ($attrs->{from}) { #shallow copy suffices $from = [ @{$attrs->{from}} ]; } else { $from = [{ -rsrc => $source, -alias => $attrs->{alias}, $attrs->{alias} => $source->from, }]; } my $jpath = ($seen->{-relation_chain_depth}) ? $from->[-1][0]{-join_path} : []; my @requested_joins = $source->_resolve_join( $join, $attrs->{alias}, $seen, $jpath, ); push @$from, @requested_joins; $seen->{-relation_chain_depth}++; # if $self already had a join/prefetch specified on it, the requested # $rel might very well be already included. What we do in this case # is effectively a no-op (except that we bump up the chain_depth on # the join in question so we could tell it *is* the search_related) my $already_joined; # we consider the last one thus reverse for my $j (reverse @requested_joins) { my ($last_j) = keys %{$j->[0]{-join_path}[-1]}; if ($rel eq $last_j) { $j->[0]{-relation_chain_depth}++; $already_joined++; last; } } unless ($already_joined) { push @$from, $source->_resolve_join( $rel, $attrs->{alias}, $seen, $jpath, ); } $seen->{-relation_chain_depth}++; return {%$attrs, from => $from, seen_join => $seen}; } sub _resolved_attrs { my $self = shift; return $self->{_attrs} if $self->{_attrs}; my $attrs = { %{ $self->{attrs} || {} } }; my $source = $attrs->{result_source} = $self->result_source; my $alias = $attrs->{alias}; $self->throw_exception("Specifying distinct => 1 in conjunction with collapse => 1 is unsupported") if $attrs->{collapse} and $attrs->{distinct}; # default selection list $attrs->{columns} = [ $source->columns ] unless grep { exists $attrs->{$_} } qw/columns cols select as/; # merge selectors together for (qw/columns select as/) { $attrs->{$_} = $self->_merge_attr($attrs->{$_}, delete $attrs->{"+$_"}) if $attrs->{$_} or $attrs->{"+$_"}; } # disassemble columns my (@sel, @as); if (my $cols = delete $attrs->{columns}) { for my $c (ref $cols eq 'ARRAY' ? @$cols : $cols) { if (ref $c eq 'HASH') { for my $as (sort keys %$c) { push @sel, $c->{$as}; push @as, $as; } } else { push @sel, $c; push @as, $c; } } } # when trying to weed off duplicates later do not go past this point - # everything added from here on is unbalanced "anyone's guess" stuff my $dedup_stop_idx = $#as; push @as, @{ ref $attrs->{as} eq 'ARRAY' ? $attrs->{as} : [ $attrs->{as} ] } if $attrs->{as}; push @sel, @{ ref $attrs->{select} eq 'ARRAY' ? $attrs->{select} : [ $attrs->{select} ] } if $attrs->{select}; # assume all unqualified selectors to apply to the current alias (legacy stuff) $_ = (ref $_ or $_ =~ /\./) ? $_ : "$alias.$_" for @sel; # disqualify all $alias.col as-bits (inflate-map mandated) $_ = ($_ =~ /^\Q$alias.\E(.+)$/) ? $1 : $_ for @as; # de-duplicate the result (remove *identical* select/as pairs) # and also die on duplicate {as} pointing to different {select}s # not using a c-style for as the condition is prone to shrinkage my $seen; my $i = 0; while ($i <= $dedup_stop_idx) { if ($seen->{"$sel[$i] \x00\x00 $as[$i]"}++) { splice @sel, $i, 1; splice @as, $i, 1; $dedup_stop_idx--; } elsif ($seen->{$as[$i]}++) { $self->throw_exception( "inflate_result() alias '$as[$i]' specified twice with different SQL-side {select}-ors" ); } else { $i++; } } $attrs->{select} = \@sel; $attrs->{as} = \@as; $attrs->{from} ||= [{ -rsrc => $source, -alias => $self->{attrs}{alias}, $self->{attrs}{alias} => $source->from, }]; if ( $attrs->{join} || $attrs->{prefetch} ) { $self->throw_exception ('join/prefetch can not be used with a custom {from}') if ref $attrs->{from} ne 'ARRAY'; my $join = (delete $attrs->{join}) || {}; if ( defined $attrs->{prefetch} ) { $join = $self->_merge_joinpref_attr( $join, $attrs->{prefetch} ); } $attrs->{from} = # have to copy here to avoid corrupting the original [ @{ $attrs->{from} }, $source->_resolve_join( $join, $alias, { %{ $attrs->{seen_join} || {} } }, ( $attrs->{seen_join} && keys %{$attrs->{seen_join}}) ? $attrs->{from}[-1][0]{-join_path} : [] , ) ]; } for my $attr (qw(order_by group_by)) { if ( defined $attrs->{$attr} ) { $attrs->{$attr} = ( ref( $attrs->{$attr} ) eq 'ARRAY' ? [ @{ $attrs->{$attr} } ] : [ $attrs->{$attr} || () ] ); delete $attrs->{$attr} unless @{$attrs->{$attr}}; } } # generate selections based on the prefetch helper my ($prefetch, @prefetch_select, @prefetch_as); $prefetch = $self->_merge_joinpref_attr( {}, delete $attrs->{prefetch} ) if defined $attrs->{prefetch}; if ($prefetch) { $self->throw_exception("Unable to prefetch, resultset contains an unnamed selector $attrs->{_dark_selector}{string}") if $attrs->{_dark_selector}; $self->throw_exception("Specifying prefetch in conjunction with an explicit collapse => 0 is unsupported") if defined $attrs->{collapse} and ! $attrs->{collapse}; $attrs->{collapse} = 1; # this is a separate structure (we don't look in {from} directly) # as the resolver needs to shift things off the lists to work # properly (identical-prefetches on different branches) my $join_map = {}; if (ref $attrs->{from} eq 'ARRAY') { my $start_depth = $attrs->{seen_join}{-relation_chain_depth} || 0; for my $j ( @{$attrs->{from}}[1 .. $#{$attrs->{from}} ] ) { next unless $j->[0]{-alias}; next unless $j->[0]{-join_path}; next if ($j->[0]{-relation_chain_depth} || 0) < $start_depth; my @jpath = map { keys %$_ } @{$j->[0]{-join_path}}; my $p = $join_map; $p = $p->{$_} ||= {} for @jpath[ ($start_depth/2) .. $#jpath]; #only even depths are actual jpath boundaries push @{$p->{-join_aliases} }, $j->[0]{-alias}; } } my @prefetch = $source->_resolve_prefetch( $prefetch, $alias, $join_map ); # save these for after distinct resolution @prefetch_select = map { $_->[0] } @prefetch; @prefetch_as = map { $_->[1] } @prefetch; } # run through the resulting joinstructure (starting from our current slot) # and unset collapse if proven unnecessary # # also while we are at it find out if the current root source has # been premultiplied by previous related_source chaining # # this allows to predict whether a root object with all other relation # data set to NULL is in fact unique if ($attrs->{collapse}) { if (ref $attrs->{from} eq 'ARRAY') { if (@{$attrs->{from}} == 1) { # no joins - no collapse $attrs->{collapse} = 0; } else { # find where our table-spec starts my @fromlist = @{$attrs->{from}}; while (@fromlist) { my $t = shift @fromlist; my $is_multi; # me vs join from-spec distinction - a ref means non-root if (ref $t eq 'ARRAY') { $t = $t->[0]; $is_multi ||= ! $t->{-is_single}; } last if ($t->{-alias} && $t->{-alias} eq $alias); $attrs->{_main_source_premultiplied} ||= $is_multi; } # no non-singles remaining, nor any premultiplication - nothing to collapse if ( ! $attrs->{_main_source_premultiplied} and ! grep { ! $_->[0]{-is_single} } @fromlist ) { $attrs->{collapse} = 0; } } } else { # if we can not analyze the from - err on the side of safety $attrs->{_main_source_premultiplied} = 1; } } # generate the distinct induced group_by before injecting the prefetched select/as parts if (delete $attrs->{distinct}) { if ($attrs->{group_by}) { carp_unique ("Useless use of distinct on a grouped resultset ('distinct' is ignored when a 'group_by' is present)"); } else { $attrs->{_grouped_by_distinct} = 1; # distinct affects only the main selection part, not what prefetch may add below ($attrs->{group_by}, my $new_order) = $source->storage->_group_over_selection($attrs); # FIXME possibly ignore a rewritten order_by (may turn out to be an issue) # The thinking is: if we are collapsing the subquerying prefetch engine will # rip stuff apart for us anyway, and we do not want to have a potentially # function-converted external order_by # ( there is an explicit if ( collapse && _grouped_by_distinct ) check in DBIHacks ) $attrs->{order_by} = $new_order unless $attrs->{collapse}; } } # inject prefetch-bound selection (if any) push @{$attrs->{select}}, @prefetch_select; push @{$attrs->{as}}, @prefetch_as; $attrs->{_simple_passthrough_construction} = !( $attrs->{collapse} or grep { $_ =~ /\./ } @{$attrs->{as}} ); # if both page and offset are specified, produce a combined offset # even though it doesn't make much sense, this is what pre 081xx has # been doing if (my $page = delete $attrs->{page}) { $attrs->{offset} = ($attrs->{rows} * ($page - 1)) + ($attrs->{offset} || 0) ; } return $self->{_attrs} = $attrs; } sub _rollout_attr { my ($self, $attr) = @_; if (ref $attr eq 'HASH') { return $self->_rollout_hash($attr); } elsif (ref $attr eq 'ARRAY') { return $self->_rollout_array($attr); } else { return [$attr]; } } sub _rollout_array { my ($self, $attr) = @_; my @rolled_array; foreach my $element (@{$attr}) { if (ref $element eq 'HASH') { push( @rolled_array, @{ $self->_rollout_hash( $element ) } ); } elsif (ref $element eq 'ARRAY') { # XXX - should probably recurse here push( @rolled_array, @{$self->_rollout_array($element)} ); } else { push( @rolled_array, $element ); } } return \@rolled_array; } sub _rollout_hash { my ($self, $attr) = @_; my @rolled_array; foreach my $key (keys %{$attr}) { push( @rolled_array, { $key => $attr->{$key} } ); } return \@rolled_array; } sub _calculate_score { my ($self, $a, $b) = @_; if (defined $a xor defined $b) { return 0; } elsif (not defined $a) { return 1; } if (ref $b eq 'HASH') { my ($b_key) = keys %{$b}; $b_key = '' if ! defined $b_key; if (ref $a eq 'HASH') { my ($a_key) = keys %{$a}; $a_key = '' if ! defined $a_key; if ($a_key eq $b_key) { return (1 + $self->_calculate_score( $a->{$a_key}, $b->{$b_key} )); } else { return 0; } } else { return ($a eq $b_key) ? 1 : 0; } } else { if (ref $a eq 'HASH') { my ($a_key) = keys %{$a}; return ($b eq $a_key) ? 1 : 0; } else { return ($b eq $a) ? 1 : 0; } } } sub _merge_joinpref_attr { my ($self, $orig, $import) = @_; return $import unless defined($orig); return $orig unless defined($import); $orig = $self->_rollout_attr($orig); $import = $self->_rollout_attr($import); my $seen_keys; foreach my $import_element ( @{$import} ) { # find best candidate from $orig to merge $b_element into my $best_candidate = { position => undef, score => 0 }; my $position = 0; foreach my $orig_element ( @{$orig} ) { my $score = $self->_calculate_score( $orig_element, $import_element ); if ($score > $best_candidate->{score}) { $best_candidate->{position} = $position; $best_candidate->{score} = $score; } $position++; } my ($import_key) = ( ref $import_element eq 'HASH' ) ? keys %{$import_element} : ($import_element); $import_key = '' if not defined $import_key; if ($best_candidate->{score} == 0 || exists $seen_keys->{$import_key}) { push( @{$orig}, $import_element ); } else { my $orig_best = $orig->[$best_candidate->{position}]; # merge orig_best and b_element together and replace original with merged if (ref $orig_best ne 'HASH') { $orig->[$best_candidate->{position}] = $import_element; } elsif (ref $import_element eq 'HASH') { my ($key) = keys %{$orig_best}; $orig->[$best_candidate->{position}] = { $key => $self->_merge_joinpref_attr($orig_best->{$key}, $import_element->{$key}) }; } } $seen_keys->{$import_key} = 1; # don't merge the same key twice } return @$orig ? $orig : (); } { my $hm; sub _merge_attr { $hm ||= do { my $hm = Hash::Merge->new; $hm->specify_behavior({ SCALAR => { SCALAR => sub { my ($defl, $defr) = map { defined $_ } (@_[0,1]); if ($defl xor $defr) { return [ $defl ? $_[0] : $_[1] ]; } elsif (! $defl) { return []; } elsif (__HM_DEDUP and $_[0] eq $_[1]) { return [ $_[0] ]; } else { return [$_[0], $_[1]]; } }, ARRAY => sub { return $_[1] if !defined $_[0]; return $_[1] if __HM_DEDUP and grep { $_ eq $_[0] } @{$_[1]}; return [$_[0], @{$_[1]}] }, HASH => sub { return [] if !defined $_[0] and !keys %{$_[1]}; return [ $_[1] ] if !defined $_[0]; return [ $_[0] ] if !keys %{$_[1]}; return [$_[0], $_[1]] }, }, ARRAY => { SCALAR => sub { return $_[0] if !defined $_[1]; return $_[0] if __HM_DEDUP and grep { $_ eq $_[1] } @{$_[0]}; return [@{$_[0]}, $_[1]] }, ARRAY => sub { my @ret = @{$_[0]} or return $_[1]; return [ @ret, @{$_[1]} ] unless __HM_DEDUP; my %idx = map { $_ => 1 } @ret; push @ret, grep { ! defined $idx{$_} } (@{$_[1]}); \@ret; }, HASH => sub { return [ $_[1] ] if ! @{$_[0]}; return $_[0] if !keys %{$_[1]}; return $_[0] if __HM_DEDUP and grep { $_ eq $_[1] } @{$_[0]}; return [ @{$_[0]}, $_[1] ]; }, }, HASH => { SCALAR => sub { return [] if !keys %{$_[0]} and !defined $_[1]; return [ $_[0] ] if !defined $_[1]; return [ $_[1] ] if !keys %{$_[0]}; return [$_[0], $_[1]] }, ARRAY => sub { return [] if !keys %{$_[0]} and !@{$_[1]}; return [ $_[0] ] if !@{$_[1]}; return $_[1] if !keys %{$_[0]}; return $_[1] if __HM_DEDUP and grep { $_ eq $_[0] } @{$_[1]}; return [ $_[0], @{$_[1]} ]; }, HASH => sub { return [] if !keys %{$_[0]} and !keys %{$_[1]}; return [ $_[0] ] if !keys %{$_[1]}; return [ $_[1] ] if !keys %{$_[0]}; return [ $_[0] ] if $_[0] eq $_[1]; return [ $_[0], $_[1] ]; }, } } => 'DBIC_RS_ATTR_MERGER'); $hm; }; return $hm->merge ($_[1], $_[2]); } } sub STORABLE_freeze { my ($self, $cloning) = @_; my $to_serialize = { %$self }; # A cursor in progress can't be serialized (and would make little sense anyway) # the parser can be regenerated (and can't be serialized) delete @{$to_serialize}{qw/cursor _row_parser _result_inflator/}; # nor is it sensical to store a not-yet-fired-count pager if ($to_serialize->{pager} and ref $to_serialize->{pager}{total_entries} eq 'CODE') { delete $to_serialize->{pager}; } Storable::nfreeze($to_serialize); } # need this hook for symmetry sub STORABLE_thaw { my ($self, $cloning, $serialized) = @_; %$self = %{ Storable::thaw($serialized) }; $self; } =head2 throw_exception See L for details. =cut sub throw_exception { my $self=shift; if (ref $self and my $rsrc = $self->result_source) { $rsrc->throw_exception(@_) } else { DBIx::Class::Exception->throw(@_); } } 1; __END__ # XXX: FIXME: Attributes docs need clearing up =head1 ATTRIBUTES Attributes are used to refine a ResultSet in various ways when searching for data. They can be passed to any method which takes an C<\%attrs> argument. See L, L, L, L. Default attributes can be set on the result class using L. (Please read the CAVEATS on that feature before using it!) These are in no particular order: =head2 order_by =over 4 =item Value: ( $order_by | \@order_by | \%order_by ) =back Which column(s) to order the results by. [The full list of suitable values is documented in L; the following is a summary of common options.] If a single column name, or an arrayref of names is supplied, the argument is passed through directly to SQL. The hashref syntax allows for connection-agnostic specification of ordering direction: For descending order: order_by => { -desc => [qw/col1 col2 col3/] } For explicit ascending order: order_by => { -asc => 'col' } The old scalarref syntax (i.e. order_by => \'year DESC') is still supported, although you are strongly encouraged to use the hashref syntax as outlined above. =head2 columns =over 4 =item Value: \@columns | \%columns | $column =back Shortcut to request a particular set of columns to be retrieved. Each column spec may be a string (a table column name), or a hash (in which case the key is the C value, and the value is used as the C from that, then auto-populates C from C and L. columns => [ 'some_column', { dbic_slot => 'another_column' } ] is the same as select => [qw(some_column another_column)], as => [qw(some_column dbic_slot)] If you want to individually retrieve related columns (in essence perform manual L) you have to make sure to specify the correct inflation slot chain such that it matches existing relationships: my $rs = $schema->resultset('Artist')->search({}, { # required to tell DBIC to collapse has_many relationships collapse => 1, join => { cds => 'tracks' }, '+columns' => { 'cds.cdid' => 'cds.cdid', 'cds.tracks.title' => 'tracks.title', }, }); Like elsewhere, literal SQL or literal values can be included by using a scalar reference or a literal bind value, and these values will be available in the result with C (see also L/Literal SQL and value type operators>): # equivalent SQL: SELECT 1, 'a string', IF(my_column,?,?) ... # bind values: $true_value, $false_value columns => [ { foo => \1, bar => \q{'a string'}, baz => \[ 'IF(my_column,?,?)', $true_value, $false_value ], } ] =head2 +columns B You B explicitly quote C<'+columns'> when using this attribute. Not doing so causes Perl to incorrectly interpret C<+columns> as a bareword with a unary plus operator before it, which is the same as simply C. =over 4 =item Value: \@extra_columns =back Indicates additional columns to be selected from storage. Works the same as L but adds columns to the current selection. (You may also use the C attribute, as in earlier versions of DBIC, but this is deprecated) $schema->resultset('CD')->search(undef, { '+columns' => ['artist.name'], join => ['artist'] }); would return all CDs and include a 'name' column to the information passed to object inflation. Note that the 'artist' is the name of the column (or relationship) accessor, and 'name' is the name of the column accessor in the related table. =head2 select =over 4 =item Value: \@select_columns =back Indicates which columns should be selected from the storage. You can use column names, or in the case of RDBMS back ends, function or stored procedure names: $rs = $schema->resultset('Employee')->search(undef, { select => [ 'name', { count => 'employeeid' }, { max => { length => 'name' }, -as => 'longest_name' } ] }); # Equivalent SQL SELECT name, COUNT( employeeid ), MAX( LENGTH( name ) ) AS longest_name FROM employee B You will almost always need a corresponding L attribute when you use L, to instruct DBIx::Class how to store the result of the column. Also note that the L attribute has B with the SQL-side C identifier aliasing. You B alias a function (so you can use it e.g. in an C clause), however this is done via the C<-as> B. =over 4 =item Value: \@extra_select_columns =back Indicates additional columns to be selected from storage. Works the same as L but adds columns to the current selection, instead of specifying a new explicit list. =head2 as =over 4 =item Value: \@inflation_names =back Indicates DBIC-side names for object inflation. That is L indicates the slot name in which the column value will be stored within the L object. The value will then be accessible via this identifier by the C method (or via the object accessor B) as shown below. The L attribute has B with the SQL-side identifier aliasing C. See L for details. $rs = $schema->resultset('Employee')->search(undef, { select => [ 'name', { count => 'employeeid' }, { max => { length => 'name' }, -as => 'longest_name' } ], as => [qw/ name employee_count max_name_length /], }); If the object against which the search is performed already has an accessor matching a column name specified in C, the value can be retrieved using the accessor as normal: my $name = $employee->name(); If on the other hand an accessor does not exist in the object, you need to use C instead: my $employee_count = $employee->get_column('employee_count'); You can create your own accessors if required - see L for details. =head2 +as B You B explicitly quote C<'+as'> when using this attribute. Not doing so causes Perl to incorrectly interpret C<+as> as a bareword with a unary plus operator before it, which is the same as simply C. =over 4 =item Value: \@extra_inflation_names =back Indicates additional inflation names for selectors added via L. See L. =head2 join =over 4 =item Value: ($rel_name | \@rel_names | \%rel_names) =back Contains a list of relationships that should be joined for this query. For example: # Get CDs by Nine Inch Nails my $rs = $schema->resultset('CD')->search( { 'artist.name' => 'Nine Inch Nails' }, { join => 'artist' } ); Can also contain a hash reference to refer to the other relation's relations. For example: package MyApp::Schema::Track; use base qw/DBIx::Class/; __PACKAGE__->table('track'); __PACKAGE__->add_columns(qw/trackid cd position title/); __PACKAGE__->set_primary_key('trackid'); __PACKAGE__->belongs_to(cd => 'MyApp::Schema::CD'); 1; # In your application my $rs = $schema->resultset('Artist')->search( { 'track.title' => 'Teardrop' }, { join => { cd => 'track' }, order_by => 'artist.name', } ); You need to use the relationship (not the table) name in conditions, because they are aliased as such. The current table is aliased as "me", so you need to use me.column_name in order to avoid ambiguity. For example: # Get CDs from 1984 with a 'Foo' track my $rs = $schema->resultset('CD')->search( { 'me.year' => 1984, 'tracks.name' => 'Foo' }, { join => 'tracks' } ); If the same join is supplied twice, it will be aliased to _2 (and similarly for a third time). For e.g. my $rs = $schema->resultset('Artist')->search({ 'cds.title' => 'Down to Earth', 'cds_2.title' => 'Popular', }, { join => [ qw/cds cds/ ], }); will return a set of all artists that have both a cd with title 'Down to Earth' and a cd with title 'Popular'. If you want to fetch related objects from other tables as well, see L below. NOTE: An internal join-chain pruner will discard certain joins while constructing the actual SQL query, as long as the joins in question do not affect the retrieved result. This for example includes 1:1 left joins that are not part of the restriction specification (WHERE/HAVING) nor are a part of the query selection. For more help on using joins with search, see L. =head2 collapse =over 4 =item Value: (0 | 1) =back When set to a true value, indicates that any rows fetched from joined has_many relationships are to be aggregated into the corresponding "parent" object. For example, the resultset: my $rs = $schema->resultset('CD')->search({}, { '+columns' => [ qw/ tracks.title tracks.position / ], join => 'tracks', collapse => 1, }); While executing the following query: SELECT me.*, tracks.title, tracks.position FROM cd me LEFT JOIN track tracks ON tracks.cdid = me.cdid Will return only as many objects as there are rows in the CD source, even though the result of the query may span many rows. Each of these CD objects will in turn have multiple "Track" objects hidden behind the has_many generated accessor C. Without C<< collapse => 1 >>, the return values of this resultset would be as many CD objects as there are tracks (a "Cartesian product"), with each CD object containing exactly one of all fetched Track data. When a collapse is requested on a non-ordered resultset, an order by some unique part of the main source (the left-most table) is inserted automatically. This is done so that the resultset is allowed to be "lazy" - calling L<< $rs->next|/next >> will fetch only as many rows as it needs to build the next object with all of its related data. If an L is already declared, and orders the resultset in a way that makes collapsing as described above impossible (e.g. C<< ORDER BY has_many_rel.column >> or C), DBIC will automatically switch to "eager" mode and slurp the entire resultset before constructing the first object returned by L. Setting this attribute on a resultset that does not join any has_many relations is a no-op. For a more in-depth discussion, see L. =head2 prefetch =over 4 =item Value: ($rel_name | \@rel_names | \%rel_names) =back This attribute is a shorthand for specifying a L spec, adding all columns from the joined related sources as L and setting L to a true value. It can be thought of as a rough B of the L attribute. For example, the following two queries are equivalent: my $rs = $schema->resultset('Artist')->search({}, { prefetch => { cds => ['genre', 'tracks' ] }, }); and my $rs = $schema->resultset('Artist')->search({}, { join => { cds => ['genre', 'tracks' ] }, collapse => 1, '+columns' => [ (map { +{ "cds.$_" => "cds.$_" } } $schema->source('Artist')->related_source('cds')->columns ), (map { +{ "cds.genre.$_" => "genre.$_" } } $schema->source('Artist')->related_source('cds')->related_source('genre')->columns ), (map { +{ "cds.tracks.$_" => "tracks.$_" } } $schema->source('Artist')->related_source('cds')->related_source('tracks')->columns ), ], }); Both producing the following SQL: SELECT me.artistid, me.name, me.rank, me.charfield, cds.cdid, cds.artist, cds.title, cds.year, cds.genreid, cds.single_track, genre.genreid, genre.name, tracks.trackid, tracks.cd, tracks.position, tracks.title, tracks.last_updated_on, tracks.last_updated_at FROM artist me LEFT JOIN cd cds ON cds.artist = me.artistid LEFT JOIN genre genre ON genre.genreid = cds.genreid LEFT JOIN track tracks ON tracks.cd = cds.cdid ORDER BY me.artistid While L implies a L, it is ok to mix the two together, as the arguments are properly merged and generally do the right thing. For example, you may want to do the following: my $artists_and_cds_without_genre = $schema->resultset('Artist')->search( { 'genre.genreid' => undef }, { join => { cds => 'genre' }, prefetch => 'cds', } ); Which generates the following SQL: SELECT me.artistid, me.name, me.rank, me.charfield, cds.cdid, cds.artist, cds.title, cds.year, cds.genreid, cds.single_track FROM artist me LEFT JOIN cd cds ON cds.artist = me.artistid LEFT JOIN genre genre ON genre.genreid = cds.genreid WHERE genre.genreid IS NULL ORDER BY me.artistid For a more in-depth discussion, see L. =head2 alias =over 4 =item Value: $source_alias =back Sets the source alias for the query. Normally, this defaults to C, but nested search queries (sub-SELECTs) might need specific aliases set to reference inner queries. For example: my $q = $rs ->related_resultset('CDs') ->related_resultset('Tracks') ->search({ 'track.id' => { -ident => 'none_search.id' }, }) ->as_query; my $ids = $self->search({ -not_exists => $q, }, { alias => 'none_search', group_by => 'none_search.id', })->get_column('id')->as_query; $self->search({ id => { -in => $ids } }) This attribute is directly tied to L. =head2 page =over 4 =item Value: $page =back Makes the resultset paged and specifies the page to retrieve. Effectively identical to creating a non-pages resultset and then calling ->page($page) on it. If L attribute is not specified it defaults to 10 rows per page. When you have a paged resultset, L will only return the number of rows in the page. To get the total, use the L and call C on it. =head2 rows =over 4 =item Value: $rows =back Specifies the maximum number of rows for direct retrieval or the number of rows per page if the page attribute or method is used. =head2 offset =over 4 =item Value: $offset =back Specifies the (zero-based) row number for the first row to be returned, or the of the first row of the first page if paging is used. =head2 software_limit =over 4 =item Value: (0 | 1) =back When combined with L and/or L the generated SQL will not include any limit dialect stanzas. Instead the entire result will be selected as if no limits were specified, and DBIC will perform the limit locally, by artificially advancing and finishing the resulting L. This is the recommended way of performing resultset limiting when no sane RDBMS implementation is available (e.g. L using the L hack) =head2 group_by =over 4 =item Value: \@columns =back A arrayref of columns to group by. Can include columns of joined tables. group_by => [qw/ column1 column2 ... /] =head2 having =over 4 =item Value: $condition =back The HAVING operator specifies a B condition applied to the set after the grouping calculations have been done. In other words it is a constraint just like L (and accepting the same L) applied to the data as it exists after GROUP BY has taken place. Specifying L without L is a logical mistake, and a fatal error on most RDBMS engines. E.g. having => { 'count_employee' => { '>=', 100 } } or with an in-place function in which case literal SQL is required: having => \[ 'count(employee) >= ?', 100 ] =head2 distinct =over 4 =item Value: (0 | 1) =back Set to 1 to automatically generate a L clause based on the selection (including intelligent handling of L contents). Note that the group criteria calculation takes place over the B selection. This includes any L, L or L additions in subsequent L calls, and standalone columns selected via L (L). A notable exception are the extra selections specified via L - such selections are explicitly excluded from group criteria calculations. If the final ResultSet also explicitly defines a L attribute, this setting is ignored and an appropriate warning is issued. =head2 where =over 4 Adds to the WHERE clause. # only return rows WHERE deleted IS NULL for all searches __PACKAGE__->resultset_attributes({ where => { deleted => undef } }); Can be overridden by passing C<< { where => undef } >> as an attribute to a resultset. For more complicated where clauses see L. =back =head2 cache Set to 1 to cache search results. This prevents extra SQL queries if you revisit rows in your ResultSet: my $resultset = $schema->resultset('Artist')->search( undef, { cache => 1 } ); while( my $artist = $resultset->next ) { ... do stuff ... } $rs->first; # without cache, this would issue a query By default, searches are not cached. For more examples of using these attributes, see L. =head2 for =over 4 =item Value: ( 'update' | 'shared' | \$scalar ) =back Set to 'update' for a SELECT ... FOR UPDATE or 'shared' for a SELECT ... FOR SHARED. If \$scalar is passed, this is taken directly and embedded in the query. =head1 PREFETCHING DBIx::Class supports arbitrary related data prefetching from multiple related sources. Any combination of relationship types and column sets are supported. If L is requested, there is an additional requirement of selecting enough data to make every individual object uniquely identifiable. Here are some more involved examples, based on the following relationship map: # Assuming: My::Schema::CD->belongs_to( artist => 'My::Schema::Artist' ); My::Schema::CD->might_have( liner_note => 'My::Schema::LinerNotes' ); My::Schema::CD->has_many( tracks => 'My::Schema::Track' ); My::Schema::Artist->belongs_to( record_label => 'My::Schema::RecordLabel' ); My::Schema::Track->has_many( guests => 'My::Schema::Guest' ); my $rs = $schema->resultset('Tag')->search( undef, { prefetch => { cd => 'artist' } } ); The initial search results in SQL like the following: SELECT tag.*, cd.*, artist.* FROM tag JOIN cd ON tag.cd = cd.cdid JOIN artist ON cd.artist = artist.artistid L has no need to go back to the database when we access the C or C relationships, which saves us two SQL statements in this case. Simple prefetches will be joined automatically, so there is no need for a C attribute in the above search. The L attribute can be used with any of the relationship types and multiple prefetches can be specified together. Below is a more complex example that prefetches a CD's artist, its liner notes (if present), the cover image, the tracks on that CD, and the guests on those tracks. my $rs = $schema->resultset('CD')->search( undef, { prefetch => [ { artist => 'record_label'}, # belongs_to => belongs_to 'liner_note', # might_have 'cover_image', # has_one { tracks => 'guests' }, # has_many => has_many ] } ); This will produce SQL like the following: SELECT cd.*, artist.*, record_label.*, liner_note.*, cover_image.*, tracks.*, guests.* FROM cd me JOIN artist artist ON artist.artistid = me.artistid JOIN record_label record_label ON record_label.labelid = artist.labelid LEFT JOIN track tracks ON tracks.cdid = me.cdid LEFT JOIN guest guests ON guests.trackid = track.trackid LEFT JOIN liner_notes liner_note ON liner_note.cdid = me.cdid JOIN cd_artwork cover_image ON cover_image.cdid = me.cdid ORDER BY tracks.cd Now the C, C, C, C, C, and C of the CD will all be available through the relationship accessors without the need for additional queries to the database. =head3 CAVEATS Prefetch does a lot of deep magic. As such, it may not behave exactly as you might expect. =over 4 =item * Prefetch uses the L to populate the prefetched relationships. This may or may not be what you want. =item * If you specify a condition on a prefetched relationship, ONLY those rows that match the prefetched condition will be fetched into that relationship. This means that adding prefetch to a search() B what is returned by traversing a relationship. So, if you have C<< Artist->has_many(CDs) >> and you do my $artist_rs = $schema->resultset('Artist')->search({ 'cds.year' => 2008, }, { join => 'cds', }); my $count = $artist_rs->first->cds->count; my $artist_rs_prefetch = $artist_rs->search( {}, { prefetch => 'cds' } ); my $prefetch_count = $artist_rs_prefetch->first->cds->count; cmp_ok( $count, '==', $prefetch_count, "Counts should be the same" ); That cmp_ok() may or may not pass depending on the datasets involved. In other words the C condition would apply to the entire dataset, just like it would in regular SQL. If you want to add a condition only to the "right side" of a C - consider declaring and using a L =back =head1 DBIC BIND VALUES Because DBIC may need more information to bind values than just the column name and value itself, it uses a special format for both passing and receiving bind values. Each bind value should be composed of an arrayref of C<< [ \%args => $val ] >>. The format of C<< \%args >> is currently: =over 4 =item dbd_attrs If present (in any form), this is what is being passed directly to bind_param. Note that different DBD's expect different bind args. (e.g. DBD::SQLite takes a single numerical type, while DBD::Pg takes a hashref if bind options.) If this is specified, all other bind options described below are ignored. =item sqlt_datatype If present, this is used to infer the actual bind attribute by passing to C<< $resolved_storage->bind_attribute_by_data_type() >>. Defaults to the "data_type" from the L. Note that the data type is somewhat freeform (hence the sqlt_ prefix); currently drivers are expected to "Do the Right Thing" when given a common datatype name. (Not ideal, but that's what we got at this point.) =item sqlt_size Currently used to correctly allocate buffers for bind_param_inout(). Defaults to "size" from the L, or to a sensible value based on the "data_type". =item dbic_colname Used to fill in missing sqlt_datatype and sqlt_size attributes (if they are explicitly specified they are never overridden). Also used by some weird DBDs, where the column name should be available at bind_param time (e.g. Oracle). =back For backwards compatibility and convenience, the following shortcuts are supported: [ $name => $val ] === [ { dbic_colname => $name }, $val ] [ \$dt => $val ] === [ { sqlt_datatype => $dt }, $val ] [ undef, $val ] === [ {}, $val ] $val === [ {}, $val ] =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. =cut DBIx-Class-0.082843/lib/DBIx/Class/FilterColumn.pm0000644000175000017500000001742114240132261020445 0ustar rabbitrabbitpackage DBIx::Class::FilterColumn; use strict; use warnings; use base 'DBIx::Class::Row'; use SQL::Abstract::Util 'is_literal_value'; use namespace::clean; sub filter_column { my ($self, $col, $attrs) = @_; my $colinfo = $self->column_info($col); $self->throw_exception("FilterColumn can not be used on a column with a declared InflateColumn inflator") if defined $colinfo->{_inflate_info} and $self->isa('DBIx::Class::InflateColumn'); $self->throw_exception("No such column $col to filter") unless $self->has_column($col); $self->throw_exception('filter_column expects a hashref of filter specifications') unless ref $attrs eq 'HASH'; $self->throw_exception('An invocation of filter_column() must specify either a filter_from_storage or filter_to_storage') unless $attrs->{filter_from_storage} || $attrs->{filter_to_storage}; $colinfo->{_filter_info} = $attrs; my $acc = $colinfo->{accessor}; $self->mk_group_accessors(filtered_column => [ (defined $acc ? $acc : $col), $col]); return 1; } sub _column_from_storage { my ($self, $col, $value) = @_; return $value if is_literal_value($value); my $info = $self->result_source->column_info($col) or $self->throw_exception("No column info for $col"); return $value unless exists $info->{_filter_info}; my $filter = $info->{_filter_info}{filter_from_storage}; return defined $filter ? $self->$filter($value) : $value; } sub _column_to_storage { my ($self, $col, $value) = @_; return $value if is_literal_value($value); my $info = $self->result_source->column_info($col) or $self->throw_exception("No column info for $col"); return $value unless exists $info->{_filter_info}; my $unfilter = $info->{_filter_info}{filter_to_storage}; return defined $unfilter ? $self->$unfilter($value) : $value; } sub get_filtered_column { my ($self, $col) = @_; $self->throw_exception("$col is not a filtered column") unless exists $self->result_source->column_info($col)->{_filter_info}; return $self->{_filtered_column}{$col} if exists $self->{_filtered_column}{$col}; my $val = $self->get_column($col); return $self->{_filtered_column}{$col} = $self->_column_from_storage( $col, $val ); } sub get_column { my ($self, $col) = @_; ! exists $self->{_column_data}{$col} and exists $self->{_filtered_column}{$col} and $self->{_column_data}{$col} = $self->_column_to_storage ( $col, $self->{_filtered_column}{$col} ); return $self->next::method ($col); } # sadly a separate codepath in Row.pm ( used by insert() ) sub get_columns { my $self = shift; $self->{_column_data}{$_} = $self->_column_to_storage ( $_, $self->{_filtered_column}{$_} ) for grep { ! exists $self->{_column_data}{$_} } keys %{$self->{_filtered_column}||{}} ; $self->next::method (@_); } # and *another* separate codepath, argh! sub get_dirty_columns { my $self = shift; $self->{_dirty_columns}{$_} and ! exists $self->{_column_data}{$_} and $self->{_column_data}{$_} = $self->_column_to_storage ( $_, $self->{_filtered_column}{$_} ) for keys %{$self->{_filtered_column}||{}}; $self->next::method(@_); } sub store_column { my ($self, $col) = (shift, @_); # blow cache delete $self->{_filtered_column}{$col}; $self->next::method(@_); } sub has_column_loaded { my ($self, $col) = @_; return 1 if exists $self->{_filtered_column}{$col}; return $self->next::method($col); } sub set_filtered_column { my ($self, $col, $filtered) = @_; # unlike IC, FC does not need to deal with the 'filter' abomination # thus we can short-curcuit filtering entirely and never call set_column # in case this is already a dirty change OR the row never touched storage if ( ! $self->in_storage or $self->is_column_changed($col) ) { $self->make_column_dirty($col); delete $self->{_column_data}{$col}; } else { $self->set_column($col, $self->_column_to_storage($col, $filtered)); }; return $self->{_filtered_column}{$col} = $filtered; } sub update { my ($self, $data, @rest) = @_; my $colinfos = $self->result_source->columns_info; foreach my $col (keys %{$data||{}}) { if ( exists $colinfos->{$col}{_filter_info} ) { $self->set_filtered_column($col, delete $data->{$col}); # FIXME update() reaches directly into the object-hash # and we may *not* have a filtered value there - thus # the void-ctx filter-trigger $self->get_column($col) unless exists $self->{_column_data}{$col}; } } return $self->next::method($data, @rest); } sub new { my ($class, $data, @rest) = @_; my $rsrc = $data->{-result_source} or $class->throw_exception('Sourceless rows are not supported with DBIx::Class::FilterColumn'); my $obj = $class->next::method($data, @rest); my $colinfos = $rsrc->columns_info; foreach my $col (keys %{$data||{}}) { if (exists $colinfos->{$col}{_filter_info} ) { $obj->set_filtered_column($col, $data->{$col}); } } return $obj; } 1; __END__ =head1 NAME DBIx::Class::FilterColumn - Automatically convert column data =head1 SYNOPSIS In your Schema or DB class add "FilterColumn" to the top of the component list. __PACKAGE__->load_components(qw( FilterColumn ... )); Set up filters for the columns you want to convert. __PACKAGE__->filter_column( money => { filter_to_storage => 'to_pennies', filter_from_storage => 'from_pennies', }); sub to_pennies { $_[1] * 100 } sub from_pennies { $_[1] / 100 } 1; =head1 DESCRIPTION This component is meant to be a more powerful, but less DWIM-y, L. One of the major issues with said component is that it B works with references. Generally speaking anything that can be done with L can be done with this component. =head1 METHODS =head2 filter_column __PACKAGE__->filter_column( colname => { filter_from_storage => 'method'|\&coderef, filter_to_storage => 'method'|\&coderef, }) This is the method that you need to call to set up a filtered column. It takes exactly two arguments; the first being the column name the second being a hash reference with C and C set to either a method name or a code reference. In either case the filter is invoked as: $result->$filter_specification ($value_to_filter) with C<$filter_specification> being chosen depending on whether the C<$value_to_filter> is being retrieved from or written to permanent storage. If a specific directional filter is not specified, the original value will be passed to/from storage unfiltered. =head2 get_filtered_column $obj->get_filtered_column('colname') Returns the filtered value of the column =head2 set_filtered_column $obj->set_filtered_column(colname => 'new_value') Sets the filtered value of the column =head1 EXAMPLE OF USE Some databases have restrictions on values that can be passed to boolean columns, and problems can be caused by passing value that perl considers to be false (such as C). One solution to this is to ensure that the boolean values are set to something that the database can handle - such as numeric zero and one, using code like this:- __PACKAGE__->filter_column( my_boolean_column => { filter_to_storage => sub { $_[1] ? 1 : 0 }, } ); In this case the C is not required, as just passing the database value through to perl does the right thing. =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. DBIx-Class-0.082843/lib/DBIx/Class/Relationship.pm0000644000175000017500000005304713271562530020520 0ustar rabbitrabbitpackage DBIx::Class::Relationship; use strict; use warnings; use base qw/DBIx::Class/; __PACKAGE__->load_own_components(qw/ Helpers Accessor CascadeActions ProxyMethods Base /); 1; __END__ =head1 NAME DBIx::Class::Relationship - Inter-table relationships =head1 SYNOPSIS ## Creating relationships MyApp::Schema::Actor->has_many('actorroles' => 'MyApp::Schema::ActorRole', 'actor'); MyApp::Schema::Role->has_many('actorroles' => 'MyApp::Schema::ActorRole', 'role'); MyApp::Schema::ActorRole->belongs_to('role' => 'MyApp::Schema::Role'); MyApp::Schema::ActorRole->belongs_to('actor' => 'MyApp::Schema::Actor'); MyApp::Schema::Role->many_to_many('actors' => 'actorroles', 'actor'); MyApp::Schema::Actor->many_to_many('roles' => 'actorroles', 'role'); ## Using relationships $schema->resultset('Actor')->find({ id => 1})->roles(); $schema->resultset('Role')->find({ id => 1 })->actorroles->search_related('actor', { Name => 'Fred' }); $schema->resultset('Actor')->add_to_roles({ Name => 'Sherlock Holmes'}); See L for more. =head1 DESCRIPTION The word I has a specific meaning in DBIx::Class, see the definition in the L. This class provides methods to set up relationships between the tables in your database model. Relationships are the most useful and powerful technique that L provides. To create efficient database queries, create relationships between any and all tables that have something in common, for example if you have a table Authors: ID | Name | Age ------------------ 1 | Fred | 30 2 | Joe | 32 and a table Books: ID | Author | Name -------------------- 1 | 1 | Rulers of the universe 2 | 1 | Rulers of the galaxy Then without relationships, the method of getting all books by Fred goes like this: my $fred = $schema->resultset('Author')->find({ Name => 'Fred' }); my $fredsbooks = $schema->resultset('Book')->search({ Author => $fred->ID }); With a has_many relationship called "books" on Author (see below for details), we can do this instead: my $fredsbooks = $schema->resultset('Author')->find({ Name => 'Fred' })->books; Each relationship sets up an accessor method on the L objects that represent the items of your table. From L objects, the relationships can be searched using the "search_related" method. In list context, each returns a list of Result objects for the related class, in scalar context, a new ResultSet representing the joined tables is returned. Thus, the calls can be chained to produce complex queries. Since the database is not actually queried until you attempt to retrieve the data for an actual item, no time is wasted producing them. my $cheapfredbooks = $schema->resultset('Author')->find({ Name => 'Fred', })->books->search_related('prices', { Price => { '<=' => '5.00' }, }); will produce a query something like: SELECT * FROM Author me LEFT JOIN Books books ON books.author = me.id LEFT JOIN Prices prices ON prices.book = books.id WHERE prices.Price <= 5.00 all without needing multiple fetches. Only the helper methods for setting up standard relationship types are documented here. For the basic, lower-level methods, and a description of all the useful *_related methods that you get for free, see L. =head1 METHODS All helper methods are called similar to the following template: __PACKAGE__->$method_name('rel_name', 'Foreign::Class', \%cond|\@cond|\&cond?, \%attrs?); Both C and C are optional. Pass C for C if you want to use the default value for it, but still want to set C. See L for full documentation on definition of the C argument. See L for documentation on the attributes that are allowed in the C argument. =head2 belongs_to =over 4 =item Arguments: $accessor_name, $related_class, $our_fk_column|\%cond|\@cond|\$cond?, \%attrs? =back Creates a relationship where the calling class stores the foreign class's primary key in one (or more) of the calling class columns. This relationship defaults to using C<$accessor_name> as the column name in this class to resolve the join against the primary key from C<$related_class>, unless C<$our_fk_column> specifies the foreign key column in this class or C specifies a reference to a join condition. =over =item accessor_name This argument is the name of the method you can call on a L object to retrieve the instance of the foreign class matching this relationship. This is often called the C. Use this accessor_name in L or L to join to the foreign table indicated by this relationship. =item related_class This is the class name of the table referenced by the foreign key in this class. =item our_fk_column The column name on this class that contains the foreign key. OR =item cond A hashref, arrayref or coderef specifying a custom join expression. For more info see L. =back # in a Book class (where Author has many Books) My::DBIC::Schema::Book->belongs_to( author => 'My::DBIC::Schema::Author', 'author_id' ); # OR (same result) My::DBIC::Schema::Book->belongs_to( author => 'My::DBIC::Schema::Author', { 'foreign.author_id' => 'self.author_id' } ); # OR (similar result but uglier accessor name) My::DBIC::Schema::Book->belongs_to( author_id => 'My::DBIC::Schema::Author' ); # Usage my $author_obj = $book->author; # get author object $book->author( $new_author_obj ); # set author object $book->author_id(); # get the plain id # To retrieve the plain id if you used the ugly version: $book->get_column('author_id'); If some of the foreign key columns are L you probably want to set the L attribute to C explicitly so that SQL expressing this relation is composed with a C (as opposed to C which is default for L relationships). This ensures that relationship traversal works consistently in all situations. (i.e. resultsets involving L or L). The modified declaration is shown below: # in a Book class (where Author has_many Books) __PACKAGE__->belongs_to( author => 'My::DBIC::Schema::Author', 'author', { join_type => 'left' } ); Cascading deletes are off by default on a C relationship. To turn them on, pass C<< cascade_delete => 1 >> in the $attr hashref. By default, DBIC will return undef and avoid querying the database if a C accessor is called when any part of the foreign key IS NULL. To disable this behavior, pass C<< undef_on_null_fk => 0 >> in the C<\%attrs> hashref. NOTE: If you are used to L relationships, this is the equivalent of C. See L for documentation on relationship methods and valid relationship attributes. Also see L for a L which can be assigned to relationships as well. =head2 has_many =over 4 =item Arguments: $accessor_name, $related_class, $their_fk_column|\%cond|\@cond|\&cond?, L<\%attrs?|DBIx::Class::ResultSet/ATTRIBUTES> =back Creates a one-to-many relationship where the foreign class refers to this class's primary key. This relationship refers to zero or more records in the foreign table (e.g. a C). This relationship defaults to using the end of this classes namespace as the foreign key in C<$related_class> to resolve the join, unless C<$their_fk_column> specifies the foreign key column in C<$related_class> or C specifies a reference to a join condition. =over =item accessor_name This argument is the name of the method you can call on a L object to retrieve a resultset of the related class restricted to the ones related to the result object. In list context it returns the result objects. This is often called the C. Use this accessor_name in L or L to join to the foreign table indicated by this relationship. =item related_class This is the class name of the table which contains a foreign key column containing PK values of this class. =item their_fk_column The column name on the related class that contains the foreign key. OR =item cond A hashref, arrayref or coderef specifying a custom join expression. For more info see L. =back # in an Author class (where Author has_many Books) # assuming related class is storing our PK in "author_id" My::DBIC::Schema::Author->has_many( books => 'My::DBIC::Schema::Book', 'author_id' ); # OR (same result) My::DBIC::Schema::Author->has_many( books => 'My::DBIC::Schema::Book', { 'foreign.author_id' => 'self.id' }, ); # OR (similar result, assuming related_class is storing our PK, in "author") # (the "author" is guessed at from "Author" in the class namespace) My::DBIC::Schema::Author->has_many( books => 'My::DBIC::Schema::Book', ); # Usage # resultset of Books belonging to author my $booklist = $author->books; # resultset of Books belonging to author, restricted by author name my $booklist = $author->books({ name => { LIKE => '%macaroni%' }, { prefetch => [qw/book/], }); # array of Book objects belonging to author my @book_objs = $author->books; # force resultset even in list context my $books_rs = $author->books; ( $books_rs ) = $obj->books_rs; # create a new book for this author, the relation fields are auto-filled $author->create_related('books', \%col_data); # alternative method for the above $author->add_to_books(\%col_data); Three methods are created when you create a has_many relationship. The first method is the expected accessor method, C<$accessor_name()>. The second is almost exactly the same as the accessor method but "_rs" is added to the end of the method name, eg C<$accessor_name_rs()>. This method works just like the normal accessor, except that it always returns a resultset, even in list context. The third method, named C<< add_to_$rel_name >>, will also be added to your Row items; this allows you to insert new related items, using the same mechanism as in L. If you delete an object in a class with a C relationship, all the related objects will be deleted as well. To turn this behaviour off, pass C<< cascade_delete => 0 >> in the C<$attr> hashref. The cascaded operations are performed after the requested delete or update, so if your database has a constraint on the relationship, it will have deleted/updated the related records or raised an exception before DBIx::Class gets to perform the cascaded operation. If you copy an object in a class with a C relationship, all the related objects will be copied as well. To turn this behaviour off, pass C<< cascade_copy => 0 >> in the C<$attr> hashref. The behaviour defaults to C<< cascade_copy => 1 >>. See L for documentation on relationship methods and valid relationship attributes. Also see L for a L which can be assigned to relationships as well. =head2 might_have =over 4 =item Arguments: $accessor_name, $related_class, $their_fk_column|\%cond|\@cond|\&cond?, L<\%attrs?|DBIx::Class::ResultSet/ATTRIBUTES> =back Creates an optional one-to-one relationship with a class. This relationship defaults to using C<$accessor_name> as the foreign key in C<$related_class> to resolve the join, unless C<$their_fk_column> specifies the foreign key column in C<$related_class> or C specifies a reference to a join condition. =over =item accessor_name This argument is the name of the method you can call on a L object to retrieve the instance of the foreign class matching this relationship. This is often called the C. Use this accessor_name in L or L to join to the foreign table indicated by this relationship. =item related_class This is the class name of the table which contains a foreign key column containing PK values of this class. =item their_fk_column The column name on the related class that contains the foreign key. OR =item cond A hashref, arrayref or coderef specifying a custom join expression. For more info see L. =back # Author may have an entry in the pseudonym table My::DBIC::Schema::Author->might_have( pseudonym => 'My::DBIC::Schema::Pseudonym', 'author_id', ); # OR (same result, assuming the related_class stores our PK) My::DBIC::Schema::Author->might_have( pseudonym => 'My::DBIC::Schema::Pseudonym', ); # OR (same result) My::DBIC::Schema::Author->might_have( pseudonym => 'My::DBIC::Schema::Pseudonym', { 'foreign.author_id' => 'self.id' }, ); # Usage my $pname = $author->pseudonym; # to get the Pseudonym object If you update or delete an object in a class with a C relationship, the related object will be updated or deleted as well. To turn off this behavior, add C<< cascade_delete => 0 >> to the C<$attr> hashref. The cascaded operations are performed after the requested delete or update, so if your database has a constraint on the relationship, it will have deleted/updated the related records or raised an exception before DBIx::Class gets to perform the cascaded operation. See L for documentation on relationship methods and valid relationship attributes. Also see L for a L which can be assigned to relationships as well. Note that if you supply a condition on which to join, and the column in the current table allows nulls (i.e., has the C attribute set to a true value), than C will warn about this because it's naughty and you shouldn't do that. The warning will look something like: "might_have/has_one" must not be on columns with is_nullable set to true (MySchema::SomeClass/key) If you must be naughty, you can suppress the warning by setting C environment variable to a true value. Otherwise, you probably just meant to use C. =head2 has_one =over 4 =item Arguments: $accessor_name, $related_class, $their_fk_column|\%cond|\@cond|\&cond?, L<\%attrs?|DBIx::Class::ResultSet/ATTRIBUTES> =back Creates a one-to-one relationship with a class. This relationship defaults to using C<$accessor_name> as the foreign key in C<$related_class> to resolve the join, unless C<$their_fk_column> specifies the foreign key column in C<$related_class> or C specifies a reference to a join condition. =over =item accessor_name This argument is the name of the method you can call on a L object to retrieve the instance of the foreign class matching this relationship. This is often called the C. Use this accessor_name in L or L to join to the foreign table indicated by this relationship. =item related_class This is the class name of the table which contains a foreign key column containing PK values of this class. =item their_fk_column The column name on the related class that contains the foreign key. OR =item cond A hashref, arrayref or coderef specifying a custom join expression. For more info see L. =back # Every book has exactly one ISBN My::DBIC::Schema::Book->has_one( isbn => 'My::DBIC::Schema::ISBN', 'book_id', ); # OR (same result, assuming related_class stores our PK) My::DBIC::Schema::Book->has_one( isbn => 'My::DBIC::Schema::ISBN', ); # OR (same result) My::DBIC::Schema::Book->has_one( isbn => 'My::DBIC::Schema::ISBN', { 'foreign.book_id' => 'self.id' }, ); # Usage my $isbn_obj = $book->isbn; # to get the ISBN object Creates a one-to-one relationship with another class. This is just like C, except the implication is that the other object is always present. The only difference between C and C is that C uses an (ordinary) inner join, whereas C defaults to a left join. The has_one relationship should be used when a row in the table must have exactly one related row in another table. If the related row might not exist in the foreign table, use the L relationship. In the above example, each Book in the database is associated with exactly one ISBN object. See L for documentation on relationship methods and valid relationship attributes. Also see L for a L which can be assigned to relationships as well. Note that if you supply a condition on which to join, if the column in the current table allows nulls (i.e., has the C attribute set to a true value), than warnings might apply just as with L. =head2 many_to_many =over 4 =item Arguments: $accessor_name, $link_rel_name, $foreign_rel_name, L<\%attrs?|DBIx::Class::ResultSet/ATTRIBUTES> =back C is a I which has a specific meaning in DBIx::Class, see the definition in the L. C is not strictly a relationship in its own right. Instead, it is a bridge between two resultsets which provide the same kind of convenience accessors as true relationships provide. Although the accessor will return a resultset or collection of objects just like has_many does, you cannot call C and similar methods which operate on true relationships. =over =item accessor_name This argument is the name of the method you can call on a L object to retrieve the rows matching this relationship. On a many_to_many, unlike other relationships, this cannot be used in L to join tables. Use the relations bridged across instead. =item link_rel_name This is the accessor_name from the has_many relationship we are bridging from. =item foreign_rel_name This is the accessor_name of the belongs_to relationship in the link table that we are bridging across (which gives us the table we are bridging to). =back To create a many_to_many relationship from Actor to Role: My::DBIC::Schema::Actor->has_many( actor_roles => 'My::DBIC::Schema::ActorRoles', 'actor' ); My::DBIC::Schema::ActorRoles->belongs_to( role => 'My::DBIC::Schema::Role' ); My::DBIC::Schema::ActorRoles->belongs_to( actor => 'My::DBIC::Schema::Actor' ); My::DBIC::Schema::Actor->many_to_many( roles => 'actor_roles', 'role' ); And, for the reverse relationship, from Role to Actor: My::DBIC::Schema::Role->has_many( actor_roles => 'My::DBIC::Schema::ActorRoles', 'role' ); My::DBIC::Schema::Role->many_to_many( actors => 'actor_roles', 'actor' ); To add a role for your actor, and fill in the year of the role in the actor_roles table: $actor->add_to_roles($role, { year => 1995 }); In the above example, ActorRoles is the link table class, and Role is the foreign class. The C<$link_rel_name> parameter is the name of the accessor for the has_many relationship from this table to the link table, and the C<$foreign_rel_name> parameter is the accessor for the belongs_to relationship from the link table to the foreign table. To use many_to_many, existing relationships from the original table to the link table, and from the link table to the end table must already exist, these relation names are then used in the many_to_many call. In the above example, the Actor class will have 3 many_to_many accessor methods set: C, C, C, and similarly named accessors will be created for the Role class for the C many_to_many relationship. See L for documentation on relationship methods and valid relationship attributes. Also see L for a L which can be assigned to relationships as well. =head1 FURTHER QUESTIONS? Check the list of L. =head1 COPYRIGHT AND LICENSE This module is free software L by the L. You can redistribute it and/or modify it under the same terms as the L. DBIx-Class-0.082843/lib/DBIx/Class/ResultSource.pm0000644000175000017500000020452014240132261020477 0ustar rabbitrabbitpackage DBIx::Class::ResultSource; use strict; use warnings; use base qw/DBIx::Class::ResultSource::RowParser DBIx::Class/; use DBIx::Class::ResultSet; use DBIx::Class::ResultSourceHandle; use DBIx::Class::Carp; use DBIx::Class::_Util 'UNRESOLVABLE_CONDITION'; use SQL::Abstract::Util 'is_literal_value'; use Devel::GlobalDestruction; use Try::Tiny; use Scalar::Util qw/blessed weaken isweak/; use namespace::clean; __PACKAGE__->mk_group_accessors(simple => qw/ source_name name source_info _ordered_columns _columns _primaries _unique_constraints _relationships resultset_attributes column_info_from_storage /); __PACKAGE__->mk_group_accessors(component_class => qw/ resultset_class result_class /); __PACKAGE__->mk_classdata( sqlt_deploy_callback => 'default_sqlt_deploy_hook' ); =head1 NAME DBIx::Class::ResultSource - Result source object =head1 SYNOPSIS # Create a table based result source, in a result class. package MyApp::Schema::Result::Artist; use base qw/DBIx::Class::Core/; __PACKAGE__->table('artist'); __PACKAGE__->add_columns(qw/ artistid name /); __PACKAGE__->set_primary_key('artistid'); __PACKAGE__->has_many(cds => 'MyApp::Schema::Result::CD'); 1; # Create a query (view) based result source, in a result class package MyApp::Schema::Result::Year2000CDs; use base qw/DBIx::Class::Core/; __PACKAGE__->load_components('InflateColumn::DateTime'); __PACKAGE__->table_class('DBIx::Class::ResultSource::View'); __PACKAGE__->table('year2000cds'); __PACKAGE__->result_source_instance->is_virtual(1); __PACKAGE__->result_source_instance->view_definition( "SELECT cdid, artist, title FROM cd WHERE year ='2000'" ); =head1 DESCRIPTION A ResultSource is an object that represents a source of data for querying. This class is a base class for various specialised types of result sources, for example L. Table is the default result source type, so one is created for you when defining a result class as described in the synopsis above. More specifically, the L base class pulls in the L component, which defines the L method. When called, C
creates and stores an instance of L. Luckily, to use tables as result sources, you don't need to remember any of this. Result sources representing select queries, or views, can also be created, see L for full details. =head2 Finding result source objects As mentioned above, a result source instance is created and stored for you when you define a L. You can retrieve the result source at runtime in the following ways: =over =item From a Schema object: $schema->source($source_name); =item From a Result object: $result->result_source; =item From a ResultSet object: $rs->result_source; =back =head1 METHODS =head2 new $class->new(); $class->new({attribute_name => value}); Creates a new ResultSource object. Not normally called directly by end users. =cut sub new { my ($class, $attrs) = @_; $class = ref $class if ref $class; my $new = bless { %{$attrs || {}} }, $class; $new->{resultset_class} ||= 'DBIx::Class::ResultSet'; $new->{resultset_attributes} = { %{$new->{resultset_attributes} || {}} }; $new->{_ordered_columns} = [ @{$new->{_ordered_columns}||[]}]; $new->{_columns} = { %{$new->{_columns}||{}} }; $new->{_relationships} = { %{$new->{_relationships}||{}} }; $new->{name} ||= "!!NAME NOT SET!!"; $new->{_columns_info_loaded} ||= 0; return $new; } =pod =head2 add_columns =over =item Arguments: @columns =item Return Value: L<$result_source|/new> =back $source->add_columns(qw/col1 col2 col3/); $source->add_columns('col1' => \%col1_info, 'col2' => \%col2_info, ...); $source->add_columns( 'col1' => { data_type => 'integer', is_nullable => 1, ... }, 'col2' => { data_type => 'text', is_auto_increment => 1, ... }, ); Adds columns to the result source. If supplied colname => hashref pairs, uses the hashref as the L for that column. Repeated calls of this method will add more columns, not replace them. The column names given will be created as accessor methods on your L objects. You can change the name of the accessor by supplying an L in the column_info hash. If a column name beginning with a plus sign ('+col1') is provided, the attributes provided will be merged with any existing attributes for the column, with the new attributes taking precedence in the case that an attribute already exists. Using this without a hashref (C<< $source->add_columns(qw/+col1 +col2/) >>) is legal, but useless -- it does the same thing it would do without the plus. The contents of the column_info are not set in stone. The following keys are currently recognised/used by DBIx::Class: =over 4 =item accessor { accessor => '_name' } # example use, replace standard accessor with one of your own: sub name { my ($self, $value) = @_; die "Name cannot contain digits!" if($value =~ /\d/); $self->_name($value); return $self->_name(); } Use this to set the name of the accessor method for this column. If unset, the name of the column will be used. =item data_type { data_type => 'integer' } This contains the column type. It is automatically filled if you use the L producer, or the L module. Currently there is no standard set of values for the data_type. Use whatever your database supports. =item size { size => 20 } The length of your column, if it is a column type that can have a size restriction. This is currently only used to create tables from your schema, see L. { size => [ 9, 6 ] } For decimal or float values you can specify an ArrayRef in order to control precision, assuming your database's L supports it. =item is_nullable { is_nullable => 1 } Set this to a true value for a column that is allowed to contain NULL values, default is false. This is currently only used to create tables from your schema, see L. =item is_auto_increment { is_auto_increment => 1 } Set this to a true value for a column whose value is somehow automatically set, defaults to false. This is used to determine which columns to empty when cloning objects using L. It is also used by L. =item is_numeric { is_numeric => 1 } Set this to a true or false value (not C) to explicitly specify if this column contains numeric data. This controls how set_column decides whether to consider a column dirty after an update: if C is true a numeric comparison C<< != >> will take place instead of the usual C If not specified the storage class will attempt to figure this out on first access to the column, based on the column C. The result will be cached in this attribute. =item is_foreign_key { is_foreign_key => 1 } Set this to a true value for a column that contains a key from a foreign table, defaults to false. This is currently only used to create tables from your schema, see L. =item default_value { default_value => \'now()' } Set this to the default value which will be inserted into a column by the database. Can contain either a value or a function (use a reference to a scalar e.g. C<\'now()'> if you want a function). This is currently only used to create tables from your schema, see L. See the note on L for more information about possible issues related to db-side default values. =item sequence { sequence => 'my_table_seq' } Set this on a primary key column to the name of the sequence used to generate a new key value. If not specified, L will attempt to retrieve the name of the sequence from the database automatically. =item retrieve_on_insert { retrieve_on_insert => 1 } For every column where this is set to true, DBIC will retrieve the RDBMS-side value upon a new row insertion (normally only the autoincrement PK is retrieved on insert). C is used automatically if supported by the underlying storage, otherwise an extra SELECT statement is executed to retrieve the missing data. =item auto_nextval { auto_nextval => 1 } Set this to a true value for a column whose value is retrieved automatically from a sequence or function (if supported by your Storage driver.) For a sequence, if you do not use a trigger to get the nextval, you have to set the L value as well. Also set this for MSSQL columns with the 'uniqueidentifier' L whose values you want to automatically generate using C, unless they are a primary key in which case this will be done anyway. =item extra This is used by L and L to add extra non-generic data to the column. For example: C<< extra => { unsigned => 1} >> is used by the MySQL producer to set an integer column to unsigned. For more details, see L. =back =head2 add_column =over =item Arguments: $colname, \%columninfo? =item Return Value: 1/0 (true/false) =back $source->add_column('col' => \%info); Add a single column and optional column info. Uses the same column info keys as L. =cut sub add_columns { my ($self, @cols) = @_; $self->_ordered_columns(\@cols) unless $self->_ordered_columns; my @added; my $columns = $self->_columns; while (my $col = shift @cols) { my $column_info = {}; if ($col =~ s/^\+//) { $column_info = $self->column_info($col); } # If next entry is { ... } use that for the column info, if not # use an empty hashref if (ref $cols[0]) { my $new_info = shift(@cols); %$column_info = (%$column_info, %$new_info); } push(@added, $col) unless exists $columns->{$col}; $columns->{$col} = $column_info; } push @{ $self->_ordered_columns }, @added; return $self; } sub add_column { shift->add_columns(@_); } # DO NOT CHANGE THIS TO GLOB =head2 has_column =over =item Arguments: $colname =item Return Value: 1/0 (true/false) =back if ($source->has_column($colname)) { ... } Returns true if the source has a column of this name, false otherwise. =cut sub has_column { my ($self, $column) = @_; return exists $self->_columns->{$column}; } =head2 column_info =over =item Arguments: $colname =item Return Value: Hashref of info =back my $info = $source->column_info($col); Returns the column metadata hashref for a column, as originally passed to L. See L above for information on the contents of the hashref. =cut sub column_info { my ($self, $column) = @_; $self->throw_exception("No such column $column") unless exists $self->_columns->{$column}; if ( ! $self->_columns->{$column}{data_type} and ! $self->{_columns_info_loaded} and $self->column_info_from_storage and my $stor = try { $self->storage } ) { $self->{_columns_info_loaded}++; # try for the case of storage without table try { my $info = $stor->columns_info_for( $self->from ); my $lc_info = { map { (lc $_) => $info->{$_} } ( keys %$info ) }; foreach my $col ( keys %{$self->_columns} ) { $self->_columns->{$col} = { %{ $self->_columns->{$col} }, %{ $info->{$col} || $lc_info->{lc $col} || {} } }; } }; } return $self->_columns->{$column}; } =head2 columns =over =item Arguments: none =item Return Value: Ordered list of column names =back my @column_names = $source->columns; Returns all column names in the order they were declared to L. =cut sub columns { my $self = shift; $self->throw_exception( "columns() is a read-only accessor, did you mean add_columns()?" ) if @_; return @{$self->{_ordered_columns}||[]}; } =head2 columns_info =over =item Arguments: \@colnames ? =item Return Value: Hashref of column name/info pairs =back my $columns_info = $source->columns_info; Like L but returns information for the requested columns. If the optional column-list arrayref is omitted it returns info on all columns currently defined on the ResultSource via L. =cut sub columns_info { my ($self, $columns) = @_; my $colinfo = $self->_columns; if ( grep { ! $_->{data_type} } values %$colinfo and ! $self->{_columns_info_loaded} and $self->column_info_from_storage and my $stor = try { $self->storage } ) { $self->{_columns_info_loaded}++; # try for the case of storage without table try { my $info = $stor->columns_info_for( $self->from ); my $lc_info = { map { (lc $_) => $info->{$_} } ( keys %$info ) }; foreach my $col ( keys %$colinfo ) { $colinfo->{$col} = { %{ $colinfo->{$col} }, %{ $info->{$col} || $lc_info->{lc $col} || {} } }; } }; } my %ret; if ($columns) { for (@$columns) { if (my $inf = $colinfo->{$_}) { $ret{$_} = $inf; } else { $self->throw_exception( sprintf ( "No such column '%s' on source '%s'", $_, $self->source_name || $self->name || 'Unknown source...?', )); } } } else { %ret = %$colinfo; } return \%ret; } =head2 remove_columns =over =item Arguments: @colnames =item Return Value: not defined =back $source->remove_columns(qw/col1 col2 col3/); Removes the given list of columns by name, from the result source. B: Removing a column that is also used in the sources primary key, or in one of the sources unique constraints, B result in a broken result source. =head2 remove_column =over =item Arguments: $colname =item Return Value: not defined =back $source->remove_column('col'); Remove a single column by name from the result source, similar to L. B: Removing a column that is also used in the sources primary key, or in one of the sources unique constraints, B result in a broken result source. =cut sub remove_columns { my ($self, @to_remove) = @_; my $columns = $self->_columns or return; my %to_remove; for (@to_remove) { delete $columns->{$_}; ++$to_remove{$_}; } $self->_ordered_columns([ grep { not $to_remove{$_} } @{$self->_ordered_columns} ]); } sub remove_column { shift->remove_columns(@_); } # DO NOT CHANGE THIS TO GLOB =head2 set_primary_key =over 4 =item Arguments: @cols =item Return Value: not defined =back Defines one or more columns as primary key for this source. Must be called after L. Additionally, defines a L named C. Note: you normally do want to define a primary key on your sources B. See L for more info. =cut sub set_primary_key { my ($self, @cols) = @_; my $colinfo = $self->columns_info(\@cols); for my $col (@cols) { carp_unique(sprintf ( "Primary key of source '%s' includes the column '%s' which has its " . "'is_nullable' attribute set to true. This is a mistake and will cause " . 'various Result-object operations to fail', $self->source_name || $self->name || 'Unknown source...?', $col, )) if $colinfo->{$col}{is_nullable}; } $self->_primaries(\@cols); $self->add_unique_constraint(primary => \@cols); } =head2 primary_columns =over 4 =item Arguments: none =item Return Value: Ordered list of primary column names =back Read-only accessor which returns the list of primary keys, supplied by L. =cut sub primary_columns { return @{shift->_primaries||[]}; } # a helper method that will automatically die with a descriptive message if # no pk is defined on the source in question. For internal use to save # on if @pks... boilerplate sub _pri_cols_or_die { my $self = shift; my @pcols = $self->primary_columns or $self->throw_exception (sprintf( "Operation requires a primary key to be declared on '%s' via set_primary_key", # source_name is set only after schema-registration $self->source_name || $self->result_class || $self->name || 'Unknown source...?', )); return @pcols; } # same as above but mandating single-column PK (used by relationship condition # inference) sub _single_pri_col_or_die { my $self = shift; my ($pri, @too_many) = $self->_pri_cols_or_die; $self->throw_exception( sprintf( "Operation requires a single-column primary key declared on '%s'", $self->source_name || $self->result_class || $self->name || 'Unknown source...?', )) if @too_many; return $pri; } =head2 sequence Manually define the correct sequence for your table, to avoid the overhead associated with looking up the sequence automatically. The supplied sequence will be applied to the L of each L =over 4 =item Arguments: $sequence_name =item Return Value: not defined =back =cut sub sequence { my ($self,$seq) = @_; my @pks = $self->primary_columns or return; $_->{sequence} = $seq for values %{ $self->columns_info (\@pks) }; } =head2 add_unique_constraint =over 4 =item Arguments: $name?, \@colnames =item Return Value: not defined =back Declare a unique constraint on this source. Call once for each unique constraint. # For UNIQUE (column1, column2) __PACKAGE__->add_unique_constraint( constraint_name => [ qw/column1 column2/ ], ); Alternatively, you can specify only the columns: __PACKAGE__->add_unique_constraint([ qw/column1 column2/ ]); This will result in a unique constraint named C, where C
is replaced with the table name. Unique constraints are used, for example, when you pass the constraint name as the C attribute to L. Then only columns in the constraint are searched. Throws an error if any of the given column names do not yet exist on the result source. =cut sub add_unique_constraint { my $self = shift; if (@_ > 2) { $self->throw_exception( 'add_unique_constraint() does not accept multiple constraints, use ' . 'add_unique_constraints() instead' ); } my $cols = pop @_; if (ref $cols ne 'ARRAY') { $self->throw_exception ( 'Expecting an arrayref of constraint columns, got ' . ($cols||'NOTHING') ); } my $name = shift @_; $name ||= $self->name_unique_constraint($cols); foreach my $col (@$cols) { $self->throw_exception("No such column $col on table " . $self->name) unless $self->has_column($col); } my %unique_constraints = $self->unique_constraints; $unique_constraints{$name} = $cols; $self->_unique_constraints(\%unique_constraints); } =head2 add_unique_constraints =over 4 =item Arguments: @constraints =item Return Value: not defined =back Declare multiple unique constraints on this source. __PACKAGE__->add_unique_constraints( constraint_name1 => [ qw/column1 column2/ ], constraint_name2 => [ qw/column2 column3/ ], ); Alternatively, you can specify only the columns: __PACKAGE__->add_unique_constraints( [ qw/column1 column2/ ], [ qw/column3 column4/ ] ); This will result in unique constraints named C and C, where C
is replaced with the table name. Throws an error if any of the given column names do not yet exist on the result source. See also L. =cut sub add_unique_constraints { my $self = shift; my @constraints = @_; if ( !(@constraints % 2) && grep { ref $_ ne 'ARRAY' } @constraints ) { # with constraint name while (my ($name, $constraint) = splice @constraints, 0, 2) { $self->add_unique_constraint($name => $constraint); } } else { # no constraint name foreach my $constraint (@constraints) { $self->add_unique_constraint($constraint); } } } =head2 name_unique_constraint =over 4 =item Arguments: \@colnames =item Return Value: Constraint name =back $source->table('mytable'); $source->name_unique_constraint(['col1', 'col2']); # returns 'mytable_col1_col2' Return a name for a unique constraint containing the specified columns. The name is created by joining the table name and each column name, using an underscore character. For example, a constraint on a table named C containing the columns C and C would result in a constraint name of C<cd_artist_title>. This is used by L</add_unique_constraint> if you do not specify the optional constraint name. =cut sub name_unique_constraint { my ($self, $cols) = @_; my $name = $self->name; $name = $$name if (ref $name eq 'SCALAR'); $name =~ s/ ^ [^\.]+ \. //x; # strip possible schema qualifier return join '_', $name, @$cols; } =head2 unique_constraints =over 4 =item Arguments: none =item Return Value: Hash of unique constraint data =back $source->unique_constraints(); Read-only accessor which returns a hash of unique constraints on this source. The hash is keyed by constraint name, and contains an arrayref of column names as values. =cut sub unique_constraints { return %{shift->_unique_constraints||{}}; } =head2 unique_constraint_names =over 4 =item Arguments: none =item Return Value: Unique constraint names =back $source->unique_constraint_names(); Returns the list of unique constraint names defined on this source. =cut sub unique_constraint_names { my ($self) = @_; my %unique_constraints = $self->unique_constraints; return keys %unique_constraints; } =head2 unique_constraint_columns =over 4 =item Arguments: $constraintname =item Return Value: List of constraint columns =back $source->unique_constraint_columns('myconstraint'); Returns the list of columns that make up the specified unique constraint. =cut sub unique_constraint_columns { my ($self, $constraint_name) = @_; my %unique_constraints = $self->unique_constraints; $self->throw_exception( "Unknown unique constraint $constraint_name on '" . $self->name . "'" ) unless exists $unique_constraints{$constraint_name}; return @{ $unique_constraints{$constraint_name} }; } =head2 sqlt_deploy_callback =over =item Arguments: $callback_name | \&callback_code =item Return Value: $callback_name | \&callback_code =back __PACKAGE__->sqlt_deploy_callback('mycallbackmethod'); or __PACKAGE__->sqlt_deploy_callback(sub { my ($source_instance, $sqlt_table) = @_; ... } ); An accessor to set a callback to be called during deployment of the schema via L<DBIx::Class::Schema/create_ddl_dir> or L<DBIx::Class::Schema/deploy>. The callback can be set as either a code reference or the name of a method in the current result class. Defaults to L</default_sqlt_deploy_hook>. Your callback will be passed the $source object representing the ResultSource instance being deployed, and the L<SQL::Translator::Schema::Table> object being created from it. The callback can be used to manipulate the table object or add your own customised indexes. If you need to manipulate a non-table object, use the L<DBIx::Class::Schema/sqlt_deploy_hook>. See L<DBIx::Class::Manual::Cookbook/Adding Indexes And Functions To Your SQL> for examples. This sqlt deployment callback can only be used to manipulate SQL::Translator objects as they get turned into SQL. To execute post-deploy statements which SQL::Translator does not currently handle, override L<DBIx::Class::Schema/deploy> in your Schema class and call L<dbh_do|DBIx::Class::Storage::DBI/dbh_do>. =head2 default_sqlt_deploy_hook This is the default deploy hook implementation which checks if your current Result class has a C<sqlt_deploy_hook> method, and if present invokes it B<on the Result class directly>. This is to preserve the semantics of C<sqlt_deploy_hook> which was originally designed to expect the Result class name and the L<$sqlt_table instance|SQL::Translator::Schema::Table> of the table being deployed. =cut sub default_sqlt_deploy_hook { my $self = shift; my $class = $self->result_class; if ($class and $class->can('sqlt_deploy_hook')) { $class->sqlt_deploy_hook(@_); } } sub _invoke_sqlt_deploy_hook { my $self = shift; if ( my $hook = $self->sqlt_deploy_callback) { $self->$hook(@_); } } =head2 result_class =over 4 =item Arguments: $classname =item Return Value: $classname =back use My::Schema::ResultClass::Inflator; ... use My::Schema::Artist; ... __PACKAGE__->result_class('My::Schema::ResultClass::Inflator'); Set the default result class for this source. You can use this to create and use your own result inflator. See L<DBIx::Class::ResultSet/result_class> for more details. Please note that setting this to something like L<DBIx::Class::ResultClass::HashRefInflator> will make every result unblessed and make life more difficult. Inflators like those are better suited to temporary usage via L<DBIx::Class::ResultSet/result_class>. =head2 resultset =over 4 =item Arguments: none =item Return Value: L<$resultset|DBIx::Class::ResultSet> =back Returns a resultset for the given source. This will initially be created on demand by calling $self->resultset_class->new($self, $self->resultset_attributes) but is cached from then on unless resultset_class changes. =head2 resultset_class =over 4 =item Arguments: $classname =item Return Value: $classname =back package My::Schema::ResultSet::Artist; use base 'DBIx::Class::ResultSet'; ... # In the result class __PACKAGE__->resultset_class('My::Schema::ResultSet::Artist'); # Or in code $source->resultset_class('My::Schema::ResultSet::Artist'); Set the class of the resultset. This is useful if you want to create your own resultset methods. Create your own class derived from L<DBIx::Class::ResultSet>, and set it here. If called with no arguments, this method returns the name of the existing resultset class, if one exists. =head2 resultset_attributes =over 4 =item Arguments: L<\%attrs|DBIx::Class::ResultSet/ATTRIBUTES> =item Return Value: L<\%attrs|DBIx::Class::ResultSet/ATTRIBUTES> =back # In the result class __PACKAGE__->resultset_attributes({ order_by => [ 'id' ] }); # Or in code $source->resultset_attributes({ order_by => [ 'id' ] }); Store a collection of resultset attributes, that will be set on every L<DBIx::Class::ResultSet> produced from this result source. B<CAVEAT>: C<resultset_attributes> comes with its own set of issues and bugs! While C<resultset_attributes> isn't deprecated per se, its usage is not recommended! Since relationships use attributes to link tables together, the "default" attributes you set may cause unpredictable and undesired behavior. Furthermore, the defaults cannot be turned off, so you are stuck with them. In most cases, what you should actually be using are project-specific methods: package My::Schema::ResultSet::Artist; use base 'DBIx::Class::ResultSet'; ... # BAD IDEA! #__PACKAGE__->resultset_attributes({ prefetch => 'tracks' }); # GOOD IDEA! sub with_tracks { shift->search({}, { prefetch => 'tracks' }) } # in your code $schema->resultset('Artist')->with_tracks->... This gives you the flexibility of not using it when you don't need it. For more complex situations, another solution would be to use a virtual view via L<DBIx::Class::ResultSource::View>. =cut sub resultset { my $self = shift; $self->throw_exception( 'resultset does not take any arguments. If you want another resultset, '. 'call it on the schema instead.' ) if scalar @_; $self->resultset_class->new( $self, { try { %{$self->schema->default_resultset_attributes} }, %{$self->{resultset_attributes}}, }, ); } =head2 name =over 4 =item Arguments: none =item Result value: $name =back Returns the name of the result source, which will typically be the table name. This may be a scalar reference if the result source has a non-standard name. =head2 source_name =over 4 =item Arguments: $source_name =item Result value: $source_name =back Set an alternate name for the result source when it is loaded into a schema. This is useful if you want to refer to a result source by a name other than its class name. package ArchivedBooks; use base qw/DBIx::Class/; __PACKAGE__->table('books_archive'); __PACKAGE__->source_name('Books'); # from your schema... $schema->resultset('Books')->find(1); =head2 from =over 4 =item Arguments: none =item Return Value: FROM clause =back my $from_clause = $source->from(); Returns an expression of the source to be supplied to storage to specify retrieval from this source. In the case of a database, the required FROM clause contents. =cut sub from { die 'Virtual method!' } =head2 source_info Stores a hashref of per-source metadata. No specific key names have yet been standardized, the examples below are purely hypothetical and don't actually accomplish anything on their own: __PACKAGE__->source_info({ "_tablespace" => 'fast_disk_array_3', "_engine" => 'InnoDB', }); =head2 schema =over 4 =item Arguments: L<$schema?|DBIx::Class::Schema> =item Return Value: L<$schema|DBIx::Class::Schema> =back my $schema = $source->schema(); Sets and/or returns the L<DBIx::Class::Schema> object to which this result source instance has been attached to. =cut sub schema { if (@_ > 1) { $_[0]->{schema} = $_[1]; } else { $_[0]->{schema} || do { my $name = $_[0]->{source_name} || '_unnamed_'; my $err = 'Unable to perform storage-dependent operations with a detached result source ' . "(source '$name' is not associated with a schema)."; $err .= ' You need to use $schema->thaw() or manually set' . ' $DBIx::Class::ResultSourceHandle::thaw_schema while thawing.' if $_[0]->{_detached_thaw}; DBIx::Class::Exception->throw($err); }; } } =head2 storage =over 4 =item Arguments: none =item Return Value: L<$storage|DBIx::Class::Storage> =back $source->storage->debug(1); Returns the L<storage handle|DBIx::Class::Storage> for the current schema. =cut sub storage { shift->schema->storage; } =head2 add_relationship =over 4 =item Arguments: $rel_name, $related_source_name, \%cond, \%attrs? =item Return Value: 1/true if it succeeded =back $source->add_relationship('rel_name', 'related_source', $cond, $attrs); L<DBIx::Class::Relationship> describes a series of methods which create pre-defined useful types of relationships. Look there first before using this method directly. The relationship name can be arbitrary, but must be unique for each relationship attached to this result source. 'related_source' should be the name with which the related result source was registered with the current schema. For example: $schema->source('Book')->add_relationship('reviews', 'Review', { 'foreign.book_id' => 'self.id', }); The condition C<$cond> needs to be an L<SQL::Abstract::Classic>-style representation of the join between the tables. For example, if you're creating a relation from Author to Book, { 'foreign.author_id' => 'self.id' } will result in the JOIN clause author me JOIN book foreign ON foreign.author_id = me.id You can specify as many foreign => self mappings as necessary. Valid attributes are as follows: =over 4 =item join_type Explicitly specifies the type of join to use in the relationship. Any SQL join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in the SQL command immediately before C<JOIN>. =item proxy An arrayref containing a list of accessors in the foreign class to proxy in the main class. If, for example, you do the following: CD->might_have(liner_notes => 'LinerNotes', undef, { proxy => [ qw/notes/ ], }); Then, assuming LinerNotes has an accessor named notes, you can do: my $cd = CD->find(1); # set notes -- LinerNotes object is created if it doesn't exist $cd->notes('Notes go here'); =item accessor Specifies the type of accessor that should be created for the relationship. Valid values are C<single> (for when there is only a single related object), C<multi> (when there can be many), and C<filter> (for when there is a single related object, but you also want the relationship accessor to double as a column accessor). For C<multi> accessors, an add_to_* method is also created, which calls C<create_related> for the relationship. =back Throws an exception if the condition is improperly supplied, or cannot be resolved. =cut sub add_relationship { my ($self, $rel, $f_source_name, $cond, $attrs) = @_; $self->throw_exception("Can't create relationship without join condition") unless $cond; $attrs ||= {}; # Check foreign and self are right in cond if ( (ref $cond ||'') eq 'HASH') { $_ =~ /^foreign\./ or $self->throw_exception("Malformed relationship condition key '$_': must be prefixed with 'foreign.'") for keys %$cond; $_ =~ /^self\./ or $self->throw_exception("Malformed relationship condition value '$_': must be prefixed with 'self.'") for values %$cond; } my %rels = %{ $self->_relationships }; $rels{$rel} = { class => $f_source_name, source => $f_source_name, cond => $cond, attrs => $attrs }; $self->_relationships(\%rels); return $self; # XXX disabled. doesn't work properly currently. skip in tests. my $f_source = $self->schema->source($f_source_name); unless ($f_source) { $self->ensure_class_loaded($f_source_name); $f_source = $f_source_name->result_source; #my $s_class = ref($self->schema); #$f_source_name =~ m/^${s_class}::(.*)$/; #$self->schema->register_class(($1 || $f_source_name), $f_source_name); #$f_source = $self->schema->source($f_source_name); } return unless $f_source; # Can't test rel without f_source try { $self->_resolve_join($rel, 'me', {}, []) } catch { # If the resolve failed, back out and re-throw the error delete $rels{$rel}; $self->_relationships(\%rels); $self->throw_exception("Error creating relationship $rel: $_"); }; 1; } =head2 relationships =over 4 =item Arguments: none =item Return Value: L<@rel_names|DBIx::Class::Relationship> =back my @rel_names = $source->relationships(); Returns all relationship names for this source. =cut sub relationships { return keys %{shift->_relationships}; } =head2 relationship_info =over 4 =item Arguments: L<$rel_name|DBIx::Class::Relationship> =item Return Value: L<\%rel_data|DBIx::Class::Relationship::Base/add_relationship> =back Returns a hash of relationship information for the specified relationship name. The keys/values are as specified for L<DBIx::Class::Relationship::Base/add_relationship>. =cut sub relationship_info { #my ($self, $rel) = @_; return shift->_relationships->{+shift}; } =head2 has_relationship =over 4 =item Arguments: L<$rel_name|DBIx::Class::Relationship> =item Return Value: 1/0 (true/false) =back Returns true if the source has a relationship of this name, false otherwise. =cut sub has_relationship { #my ($self, $rel) = @_; return exists shift->_relationships->{+shift}; } =head2 reverse_relationship_info =over 4 =item Arguments: L<$rel_name|DBIx::Class::Relationship> =item Return Value: L<\%rel_data|DBIx::Class::Relationship::Base/add_relationship> =back Looks through all the relationships on the source this relationship points to, looking for one whose condition is the reverse of the condition on this relationship. A common use of this is to find the name of the C<belongs_to> relation opposing a C<has_many> relation. For definition of these look in L<DBIx::Class::Relationship>. The returned hashref is keyed by the name of the opposing relationship, and contains its data in the same manner as L</relationship_info>. =cut sub reverse_relationship_info { my ($self, $rel) = @_; my $rel_info = $self->relationship_info($rel) or $self->throw_exception("No such relationship '$rel'"); my $ret = {}; return $ret unless ((ref $rel_info->{cond}) eq 'HASH'); my $stripped_cond = $self->__strip_relcond ($rel_info->{cond}); my $registered_source_name = $self->source_name; # this may be a partial schema or something else equally esoteric my $other_rsrc = $self->related_source($rel); # Get all the relationships for that source that related to this source # whose foreign column set are our self columns on $rel and whose self # columns are our foreign columns on $rel foreach my $other_rel ($other_rsrc->relationships) { # only consider stuff that points back to us # "us" here is tricky - if we are in a schema registration, we want # to use the source_names, otherwise we will use the actual classes # the schema may be partial my $roundtrip_rsrc = try { $other_rsrc->related_source($other_rel) } or next; if ($registered_source_name) { next if $registered_source_name ne ($roundtrip_rsrc->source_name || '') } else { next if $self->result_class ne $roundtrip_rsrc->result_class; } my $other_rel_info = $other_rsrc->relationship_info($other_rel); # this can happen when we have a self-referential class next if $other_rel_info eq $rel_info; next unless ref $other_rel_info->{cond} eq 'HASH'; my $other_stripped_cond = $self->__strip_relcond($other_rel_info->{cond}); $ret->{$other_rel} = $other_rel_info if ( $self->_compare_relationship_keys ( [ keys %$stripped_cond ], [ values %$other_stripped_cond ] ) and $self->_compare_relationship_keys ( [ values %$stripped_cond ], [ keys %$other_stripped_cond ] ) ); } return $ret; } # all this does is removes the foreign/self prefix from a condition sub __strip_relcond { +{ map { map { /^ (?:foreign|self) \. (\w+) $/x } ($_, $_[1]{$_}) } keys %{$_[1]} } } sub compare_relationship_keys { carp 'compare_relationship_keys is a private method, stop calling it'; my $self = shift; $self->_compare_relationship_keys (@_); } # Returns true if both sets of keynames are the same, false otherwise. sub _compare_relationship_keys { # my ($self, $keys1, $keys2) = @_; return join ("\x00", sort @{$_[1]}) eq join ("\x00", sort @{$_[2]}) ; } # optionally takes either an arrayref of column names, or a hashref of already # retrieved colinfos # returns an arrayref of column names of the shortest unique constraint # (matching some of the input if any), giving preference to the PK sub _identifying_column_set { my ($self, $cols) = @_; my %unique = $self->unique_constraints; my $colinfos = ref $cols eq 'HASH' ? $cols : $self->columns_info($cols||()); # always prefer the PK first, and then shortest constraints first USET: for my $set (delete $unique{primary}, sort { @$a <=> @$b } (values %unique) ) { next unless $set && @$set; for (@$set) { next USET unless ($colinfos->{$_} && !$colinfos->{$_}{is_nullable} ); } # copy so we can mangle it at will return [ @$set ]; } return undef; } sub _minimal_valueset_satisfying_constraint { my $self = shift; my $args = { ref $_[0] eq 'HASH' ? %{ $_[0] } : @_ }; $args->{columns_info} ||= $self->columns_info; my $vals = $self->storage->_extract_fixed_condition_columns( $args->{values}, ($args->{carp_on_nulls} ? 'consider_nulls' : undef ), ); my $cols; for my $col ($self->unique_constraint_columns($args->{constraint_name}) ) { if( ! exists $vals->{$col} or ( $vals->{$col}||'' ) eq UNRESOLVABLE_CONDITION ) { $cols->{missing}{$col} = undef; } elsif( ! defined $vals->{$col} ) { $cols->{$args->{carp_on_nulls} ? 'undefined' : 'missing'}{$col} = undef; } else { # we need to inject back the '=' as _extract_fixed_condition_columns # will strip it from literals and values alike, resulting in an invalid # condition in the end $cols->{present}{$col} = { '=' => $vals->{$col} }; } $cols->{fc}{$col} = 1 if ( ( ! $cols->{missing} or ! exists $cols->{missing}{$col} ) and keys %{ $args->{columns_info}{$col}{_filter_info} || {} } ); } $self->throw_exception( sprintf ( "Unable to satisfy requested constraint '%s', missing values for column(s): %s", $args->{constraint_name}, join (', ', map { "'$_'" } sort keys %{$cols->{missing}} ), ) ) if $cols->{missing}; $self->throw_exception( sprintf ( "Unable to satisfy requested constraint '%s', FilterColumn values not usable for column(s): %s", $args->{constraint_name}, join (', ', map { "'$_'" } sort keys %{$cols->{fc}}), )) if $cols->{fc}; if ( $cols->{undefined} and !$ENV{DBIC_NULLABLE_KEY_NOWARN} ) { carp_unique ( sprintf ( "NULL/undef values supplied for requested unique constraint '%s' (NULL " . 'values in column(s): %s). This is almost certainly not what you wanted, ' . 'though you can set DBIC_NULLABLE_KEY_NOWARN to disable this warning.', $args->{constraint_name}, join (', ', map { "'$_'" } sort keys %{$cols->{undefined}}), )); } return { map { %{ $cols->{$_}||{} } } qw(present undefined) }; } # Returns the {from} structure used to express JOIN conditions sub _resolve_join { my ($self, $join, $alias, $seen, $jpath, $parent_force_left) = @_; # we need a supplied one, because we do in-place modifications, no returns $self->throw_exception ('You must supply a seen hashref as the 3rd argument to _resolve_join') unless ref $seen eq 'HASH'; $self->throw_exception ('You must supply a joinpath arrayref as the 4th argument to _resolve_join') unless ref $jpath eq 'ARRAY'; $jpath = [@$jpath]; # copy if (not defined $join or not length $join) { return (); } elsif (ref $join eq 'ARRAY') { return map { $self->_resolve_join($_, $alias, $seen, $jpath, $parent_force_left); } @$join; } elsif (ref $join eq 'HASH') { my @ret; for my $rel (keys %$join) { my $rel_info = $self->relationship_info($rel) or $self->throw_exception("No such relationship '$rel' on " . $self->source_name); my $force_left = $parent_force_left; $force_left ||= lc($rel_info->{attrs}{join_type}||'') eq 'left'; # the actual seen value will be incremented by the recursion my $as = $self->storage->relname_to_table_alias( $rel, ($seen->{$rel} && $seen->{$rel} + 1) ); push @ret, ( $self->_resolve_join($rel, $alias, $seen, [@$jpath], $force_left), $self->related_source($rel)->_resolve_join( $join->{$rel}, $as, $seen, [@$jpath, { $rel => $as }], $force_left ) ); } return @ret; } elsif (ref $join) { $self->throw_exception("No idea how to resolve join reftype ".ref $join); } else { my $count = ++$seen->{$join}; my $as = $self->storage->relname_to_table_alias( $join, ($count > 1 && $count) ); my $rel_info = $self->relationship_info($join) or $self->throw_exception("No such relationship $join on " . $self->source_name); my $rel_src = $self->related_source($join); return [ { $as => $rel_src->from, -rsrc => $rel_src, -join_type => $parent_force_left ? 'left' : $rel_info->{attrs}{join_type} , -join_path => [@$jpath, { $join => $as } ], -is_single => !!( (! $rel_info->{attrs}{accessor}) or grep { $rel_info->{attrs}{accessor} eq $_ } (qw/single filter/) ), -alias => $as, -relation_chain_depth => ( $seen->{-relation_chain_depth} || 0 ) + 1, }, scalar $self->_resolve_condition($rel_info->{cond}, $as, $alias, $join) ]; } } sub pk_depends_on { carp 'pk_depends_on is a private method, stop calling it'; my $self = shift; $self->_pk_depends_on (@_); } # Determines whether a relation is dependent on an object from this source # having already been inserted. Takes the name of the relationship and a # hashref of columns of the related object. sub _pk_depends_on { my ($self, $rel_name, $rel_data) = @_; my $relinfo = $self->relationship_info($rel_name); # don't assume things if the relationship direction is specified return $relinfo->{attrs}{is_foreign_key_constraint} if exists ($relinfo->{attrs}{is_foreign_key_constraint}); my $cond = $relinfo->{cond}; return 0 unless ref($cond) eq 'HASH'; # map { foreign.foo => 'self.bar' } to { bar => 'foo' } my $keyhash = { map { my $x = $_; $x =~ s/.*\.//; $x; } reverse %$cond }; # assume anything that references our PK probably is dependent on us # rather than vice versa, unless the far side is (a) defined or (b) # auto-increment my $rel_source = $self->related_source($rel_name); foreach my $p ($self->primary_columns) { if (exists $keyhash->{$p}) { unless (defined($rel_data->{$keyhash->{$p}}) || $rel_source->column_info($keyhash->{$p}) ->{is_auto_increment}) { return 0; } } } return 1; } sub resolve_condition { carp 'resolve_condition is a private method, stop calling it'; shift->_resolve_condition (@_); } sub _resolve_condition { # carp_unique sprintf # '_resolve_condition is a private method, and moreover is about to go ' # . 'away. Please contact the development team at %s if you believe you ' # . 'have a genuine use for this method, in order to discuss alternatives.', # DBIx::Class::_ENV_::HELP_URL, # ; ####################### ### API Design? What's that...? (a backwards compatible shim, kill me now) my ($self, $cond, @res_args, $rel_name); # we *SIMPLY DON'T KNOW YET* which arg is which, yay ($self, $cond, $res_args[0], $res_args[1], $rel_name) = @_; # assume that an undef is an object-like unset (set_from_related(undef)) my @is_objlike = map { ! defined $_ or length ref $_ } (@res_args); # turn objlike into proper objects for saner code further down for (0,1) { next unless $is_objlike[$_]; if ( defined blessed $res_args[$_] ) { # but wait - there is more!!! WHAT THE FUCK?!?!?!?! if ($res_args[$_]->isa('DBIx::Class::ResultSet')) { carp('Passing a resultset for relationship resolution makes no sense - invoking __gremlins__'); $is_objlike[$_] = 0; $res_args[$_] = '__gremlins__'; } } else { $res_args[$_] ||= {}; # hate everywhere - have to pass in as a plain hash # pretending to be an object at least for now $self->throw_exception("Unsupported object-like structure encountered: $res_args[$_]") unless ref $res_args[$_] eq 'HASH'; } } my $args = { condition => $cond, # where-is-waldo block guesses relname, then further down we override it if available ( $is_objlike[1] ? ( rel_name => $res_args[0], self_alias => $res_args[0], foreign_alias => 'me', self_result_object => $res_args[1] ) : $is_objlike[0] ? ( rel_name => $res_args[1], self_alias => 'me', foreign_alias => $res_args[1], foreign_values => $res_args[0] ) : ( rel_name => $res_args[0], self_alias => $res_args[1], foreign_alias => $res_args[0] ) ), ( $rel_name ? ( rel_name => $rel_name ) : () ), }; ####################### # now it's fucking easy isn't it?! my $rc = $self->_resolve_relationship_condition( $args ); my @res = ( ( $rc->{join_free_condition} || $rc->{condition} ), ! $rc->{join_free_condition}, ); # _resolve_relationship_condition always returns qualified cols even in the # case of join_free_condition, but nothing downstream expects this if ($rc->{join_free_condition} and ref $res[0] eq 'HASH') { $res[0] = { map { ($_ =~ /\.(.+)/) => $res[0]{$_} } keys %{$res[0]} }; } # and more legacy return wantarray ? @res : $res[0]; } # Keep this indefinitely. There is evidence of both CPAN and # darkpan using it, and there isn't much harm in an extra var # anyway. our $UNRESOLVABLE_CONDITION = UNRESOLVABLE_CONDITION; # YES I KNOW THIS IS EVIL # it is there to save darkpan from themselves, since internally # we are moving to a constant Internals::SvREADONLY($UNRESOLVABLE_CONDITION => 1); # Resolves the passed condition to a concrete query fragment and extra # metadata # ## self-explanatory API, modeled on the custom cond coderef: # rel_name => (scalar) # foreign_alias => (scalar) # foreign_values => (either not supplied, or a hashref, or a foreign ResultObject (to be ->get_columns()ed), or plain undef ) # self_alias => (scalar) # self_result_object => (either not supplied or a result object) # require_join_free_condition => (boolean, throws on failure to construct a JF-cond) # infer_values_based_on => (either not supplied or a hashref, implies require_join_free_condition) # condition => (sqla cond struct, optional, defeaults to from $self->rel_info(rel_name)->{cond}) # ## returns a hash # condition => (a valid *likely fully qualified* sqla cond structure) # identity_map => (a hashref of foreign-to-self *unqualified* column equality names) # join_free_condition => (a valid *fully qualified* sqla cond structure, maybe unset) # inferred_values => (in case of an available join_free condition, this is a hashref of # *unqualified* column/value *EQUALITY* pairs, representing an amalgamation # of the JF-cond parse and infer_values_based_on # always either complete or unset) # sub _resolve_relationship_condition { my $self = shift; my $args = { ref $_[0] eq 'HASH' ? %{ $_[0] } : @_ }; for ( qw( rel_name self_alias foreign_alias ) ) { $self->throw_exception("Mandatory argument '$_' to _resolve_relationship_condition() is not a plain string") if !defined $args->{$_} or length ref $args->{$_}; } $self->throw_exception("Arguments 'self_alias' and 'foreign_alias' may not be identical") if $args->{self_alias} eq $args->{foreign_alias}; # TEMP my $exception_rel_id = "relationship '$args->{rel_name}' on source '@{[ $self->source_name ]}'"; my $rel_info = $self->relationship_info($args->{rel_name}) # TEMP # or $self->throw_exception( "No such $exception_rel_id" ); or carp_unique("Requesting resolution on non-existent relationship '$args->{rel_name}' on source '@{[ $self->source_name ]}': fix your code *soon*, as it will break with the next major version"); # TEMP $exception_rel_id = "relationship '$rel_info->{_original_name}' on source '@{[ $self->source_name ]}'" if $rel_info and exists $rel_info->{_original_name}; $self->throw_exception("No practical way to resolve $exception_rel_id between two data structures") if exists $args->{self_result_object} and exists $args->{foreign_values}; $self->throw_exception( "Argument to infer_values_based_on must be a hash" ) if exists $args->{infer_values_based_on} and ref $args->{infer_values_based_on} ne 'HASH'; $args->{require_join_free_condition} ||= !!$args->{infer_values_based_on}; $args->{condition} ||= $rel_info->{cond}; $self->throw_exception( "Argument 'self_result_object' must be an object inheriting from DBIx::Class::Row" ) if ( exists $args->{self_result_object} and ( ! defined blessed $args->{self_result_object} or ! $args->{self_result_object}->isa('DBIx::Class::Row') ) ) ; #TEMP my $rel_rsrc;# = $self->related_source($args->{rel_name}); if (exists $args->{foreign_values}) { # TEMP $rel_rsrc ||= $self->related_source($args->{rel_name}); if (defined blessed $args->{foreign_values}) { $self->throw_exception( "Objects supplied as 'foreign_values' ($args->{foreign_values}) must inherit from DBIx::Class::Row" ) unless $args->{foreign_values}->isa('DBIx::Class::Row'); carp_unique( "Objects supplied as 'foreign_values' ($args->{foreign_values}) " . "usually should inherit from the related ResultClass ('@{[ $rel_rsrc->result_class ]}'), " . "perhaps you've made a mistake invoking the condition resolver?" ) unless $args->{foreign_values}->isa($rel_rsrc->result_class); $args->{foreign_values} = { $args->{foreign_values}->get_columns }; } elsif (! defined $args->{foreign_values} or ref $args->{foreign_values} eq 'HASH') { my $ri = { map { $_ => 1 } $rel_rsrc->relationships }; my $ci = $rel_rsrc->columns_info; ! exists $ci->{$_} and ! exists $ri->{$_} and $self->throw_exception( "Key '$_' supplied as 'foreign_values' is not a column on related source '@{[ $rel_rsrc->source_name ]}'" ) for keys %{ $args->{foreign_values} ||= {} }; } else { $self->throw_exception( "Argument 'foreign_values' must be either an object inheriting from '@{[ $rel_rsrc->result_class ]}', " . "or a hash reference, or undef" ); } } my $ret; if (ref $args->{condition} eq 'CODE') { my $cref_args = { rel_name => $args->{rel_name}, self_resultsource => $self, self_alias => $args->{self_alias}, foreign_alias => $args->{foreign_alias}, ( map { (exists $args->{$_}) ? ( $_ => $args->{$_} ) : () } qw( self_result_object foreign_values ) ), }; # legacy - never remove these!!! $cref_args->{foreign_relname} = $cref_args->{rel_name}; $cref_args->{self_rowobj} = $cref_args->{self_result_object} if exists $cref_args->{self_result_object}; ($ret->{condition}, $ret->{join_free_condition}, my @extra) = $args->{condition}->($cref_args); # sanity check $self->throw_exception("A custom condition coderef can return at most 2 conditions, but $exception_rel_id returned extra values: @extra") if @extra; if (my $jfc = $ret->{join_free_condition}) { $self->throw_exception ( "The join-free condition returned for $exception_rel_id must be a hash reference" ) unless ref $jfc eq 'HASH'; # TEMP $rel_rsrc ||= $self->related_source($args->{rel_name}); my ($joinfree_alias, $joinfree_source); if (defined $args->{self_result_object}) { $joinfree_alias = $args->{foreign_alias}; $joinfree_source = $rel_rsrc; } elsif (defined $args->{foreign_values}) { $joinfree_alias = $args->{self_alias}; $joinfree_source = $self; } # FIXME sanity check until things stabilize, remove at some point $self->throw_exception ( "A join-free condition returned for $exception_rel_id without a result object to chain from" ) unless $joinfree_alias; my $fq_col_list = { map { ( "$joinfree_alias.$_" => 1 ) } $joinfree_source->columns }; exists $fq_col_list->{$_} or $self->throw_exception ( "The join-free condition returned for $exception_rel_id may only " . 'contain keys that are fully qualified column names of the corresponding source ' . "(it returned '$_')" ) for keys %$jfc; ( length ref $_ and defined blessed($_) and $_->isa('DBIx::Class::Row') and $self->throw_exception ( "The join-free condition returned for $exception_rel_id may not " . 'contain result objects as values - perhaps instead of invoking ' . '->$something you meant to return ->get_column($something)' ) ) for values %$jfc; } } elsif (ref $args->{condition} eq 'HASH') { # the condition is static - use parallel arrays # for a "pivot" depending on which side of the # rel did we get as an object my (@f_cols, @l_cols); for my $fc (keys %{$args->{condition}}) { my $lc = $args->{condition}{$fc}; # FIXME STRICTMODE should probably check these are valid columns $fc =~ s/^foreign\.// || $self->throw_exception("Invalid rel cond key '$fc'"); $lc =~ s/^self\.// || $self->throw_exception("Invalid rel cond val '$lc'"); push @f_cols, $fc; push @l_cols, $lc; } # construct the crosstable condition and the identity map for (0..$#f_cols) { $ret->{condition}{"$args->{foreign_alias}.$f_cols[$_]"} = { -ident => "$args->{self_alias}.$l_cols[$_]" }; $ret->{identity_map}{$l_cols[$_]} = $f_cols[$_]; }; if ($args->{foreign_values}) { $ret->{join_free_condition}{"$args->{self_alias}.$l_cols[$_]"} = $args->{foreign_values}{$f_cols[$_]} for 0..$#f_cols; } elsif (defined $args->{self_result_object}) { for my $i (0..$#l_cols) { if ( $args->{self_result_object}->has_column_loaded($l_cols[$i]) ) { $ret->{join_free_condition}{"$args->{foreign_alias}.$f_cols[$i]"} = $args->{self_result_object}->get_column($l_cols[$i]); } else { $self->throw_exception(sprintf "Unable to resolve relationship '%s' from object '%s': column '%s' not " . 'loaded from storage (or not passed to new() prior to insert()). You ' . 'probably need to call ->discard_changes to get the server-side defaults ' . 'from the database.', $args->{rel_name}, $args->{self_result_object}, $l_cols[$i], ) if $args->{self_result_object}->in_storage; # FIXME - temporarly force-override delete $args->{require_join_free_condition}; $ret->{join_free_condition} = UNRESOLVABLE_CONDITION; last; } } } } elsif (ref $args->{condition} eq 'ARRAY') { if (@{$args->{condition}} == 0) { $ret = { condition => UNRESOLVABLE_CONDITION, join_free_condition => UNRESOLVABLE_CONDITION, }; } elsif (@{$args->{condition}} == 1) { $ret = $self->_resolve_relationship_condition({ %$args, condition => $args->{condition}[0], }); } else { # we are discarding inferred values here... likely incorrect... # then again - the entire thing is an OR, so we *can't* use them anyway for my $subcond ( map { $self->_resolve_relationship_condition({ %$args, condition => $_ }) } @{$args->{condition}} ) { $self->throw_exception('Either all or none of the OR-condition members must resolve to a join-free condition') if ( $ret and ( $ret->{join_free_condition} xor $subcond->{join_free_condition} ) ); $subcond->{$_} and push @{$ret->{$_}}, $subcond->{$_} for (qw(condition join_free_condition)); } } } else { $self->throw_exception ("Can't handle condition $args->{condition} for $exception_rel_id yet :("); } $self->throw_exception(ucfirst "$exception_rel_id does not resolve to a join-free condition fragment") if ( $args->{require_join_free_condition} and ( ! $ret->{join_free_condition} or $ret->{join_free_condition} eq UNRESOLVABLE_CONDITION ) ); my $storage = $self->schema->storage; # we got something back - sanity check and infer values if we can my @nonvalues; if ( my $jfc = $ret->{join_free_condition} and $ret->{join_free_condition} ne UNRESOLVABLE_CONDITION ) { my $jfc_eqs = $storage->_extract_fixed_condition_columns($jfc, 'consider_nulls'); if (keys %$jfc_eqs) { for (keys %$jfc) { # $jfc is fully qualified by definition my ($col) = $_ =~ /\.(.+)/; if (exists $jfc_eqs->{$_} and ($jfc_eqs->{$_}||'') ne UNRESOLVABLE_CONDITION) { $ret->{inferred_values}{$col} = $jfc_eqs->{$_}; } elsif ( !$args->{infer_values_based_on} or ! exists $args->{infer_values_based_on}{$col} ) { push @nonvalues, $col; } } # all or nothing delete $ret->{inferred_values} if @nonvalues; } } # did the user explicitly ask if ($args->{infer_values_based_on}) { $self->throw_exception(sprintf ( "Unable to complete value inferrence - custom $exception_rel_id returns conditions instead of values for column(s): %s", map { "'$_'" } @nonvalues )) if @nonvalues; $ret->{inferred_values} ||= {}; $ret->{inferred_values}{$_} = $args->{infer_values_based_on}{$_} for keys %{$args->{infer_values_based_on}}; } # add the identities based on the main condition # (may already be there, since easy to calculate on the fly in the HASH case) if ( ! $ret->{identity_map} ) { my $col_eqs = $storage->_extract_fixed_condition_columns($ret->{condition}); my $colinfos; for my $lhs (keys %$col_eqs) { next if $col_eqs->{$lhs} eq UNRESOLVABLE_CONDITION; # TEMP $rel_rsrc ||= $self->related_source($args->{rel_name}); # there is no way to know who is right and who is left in a cref # therefore a full blown resolution call, and figure out the # direction a bit further below $colinfos ||= $storage->_resolve_column_info([ { -alias => $args->{self_alias}, -rsrc => $self }, { -alias => $args->{foreign_alias}, -rsrc => $rel_rsrc }, ]); next unless $colinfos->{$lhs}; # someone is engaging in witchcraft if ( my $rhs_ref = is_literal_value( $col_eqs->{$lhs} ) ) { if ( $colinfos->{$rhs_ref->[0]} and $colinfos->{$lhs}{-source_alias} ne $colinfos->{$rhs_ref->[0]}{-source_alias} ) { ( $colinfos->{$lhs}{-source_alias} eq $args->{self_alias} ) ? ( $ret->{identity_map}{$colinfos->{$lhs}{-colname}} = $colinfos->{$rhs_ref->[0]}{-colname} ) : ( $ret->{identity_map}{$colinfos->{$rhs_ref->[0]}{-colname}} = $colinfos->{$lhs}{-colname} ) ; } } elsif ( $col_eqs->{$lhs} =~ /^ ( \Q$args->{self_alias}\E \. .+ ) /x and ($colinfos->{$1}||{})->{-result_source} == $rel_rsrc ) { my ($lcol, $rcol) = map { $colinfos->{$_}{-colname} } ( $lhs, $1 ) ; carp_unique( "The $exception_rel_id specifies equality of column '$lcol' and the " . "*VALUE* '$rcol' (you did not use the { -ident => ... } operator)" ); } } } # FIXME - temporary, to fool the idiotic check in SQLMaker::_join_condition $ret->{condition} = { -and => [ $ret->{condition} ] } unless $ret->{condition} eq UNRESOLVABLE_CONDITION; $ret; } =head2 related_source =over 4 =item Arguments: $rel_name =item Return Value: $source =back Returns the result source object for the given relationship. =cut sub related_source { my ($self, $rel) = @_; if( !$self->has_relationship( $rel ) ) { $self->throw_exception("No such relationship '$rel' on " . $self->source_name); } # if we are not registered with a schema - just use the prototype # however if we do have a schema - ask for the source by name (and # throw in the process if all fails) if (my $schema = try { $self->schema }) { $schema->source($self->relationship_info($rel)->{source}); } else { my $class = $self->relationship_info($rel)->{class}; $self->ensure_class_loaded($class); $class->result_source_instance; } } =head2 related_class =over 4 =item Arguments: $rel_name =item Return Value: $classname =back Returns the class name for objects in the given relationship. =cut sub related_class { my ($self, $rel) = @_; if( !$self->has_relationship( $rel ) ) { $self->throw_exception("No such relationship '$rel' on " . $self->source_name); } return $self->schema->class($self->relationship_info($rel)->{source}); } =head2 handle =over 4 =item Arguments: none =item Return Value: L<$source_handle|DBIx::Class::ResultSourceHandle> =back Obtain a new L<result source handle instance|DBIx::Class::ResultSourceHandle> for this source. Used as a serializable pointer to this resultsource, as it is not easy (nor advisable) to serialize CODErefs which may very well be present in e.g. relationship definitions. =cut sub handle { return DBIx::Class::ResultSourceHandle->new({ source_moniker => $_[0]->source_name, # so that a detached thaw can be re-frozen $_[0]->{_detached_thaw} ? ( _detached_source => $_[0] ) : ( schema => $_[0]->schema ) , }); } my $global_phase_destroy; sub DESTROY { ### NO detected_reinvoked_destructor check ### This code very much relies on being called multuple times return if $global_phase_destroy ||= in_global_destruction; ###### # !!! ACHTUNG !!!! ###### # # Under no circumstances shall $_[0] be stored anywhere else (like copied to # a lexical variable, or shifted, or anything else). Doing so will mess up # the refcount of this particular result source, and will allow the $schema # we are trying to save to reattach back to the source we are destroying. # The relevant code checking refcounts is in ::Schema::DESTROY() # if we are not a schema instance holder - we don't matter return if( ! ref $_[0]->{schema} or isweak $_[0]->{schema} ); # weaken our schema hold forcing the schema to find somewhere else to live # during global destruction (if we have not yet bailed out) this will throw # which will serve as a signal to not try doing anything else # however beware - on older perls the exception seems randomly untrappable # due to some weird race condition during thread joining :((( local $@; eval { weaken $_[0]->{schema}; # if schema is still there reintroduce ourselves with strong refs back to us if ($_[0]->{schema}) { my $srcregs = $_[0]->{schema}->source_registrations; for (keys %$srcregs) { next unless $srcregs->{$_}; $srcregs->{$_} = $_[0] if $srcregs->{$_} == $_[0]; } } 1; } or do { $global_phase_destroy = 1; }; return; } sub STORABLE_freeze { Storable::nfreeze($_[0]->handle) } sub STORABLE_thaw { my ($self, $cloning, $ice) = @_; %$self = %{ (Storable::thaw($ice))->resolve }; } =head2 throw_exception See L<DBIx::Class::Schema/"throw_exception">. =cut sub throw_exception { my $self = shift; $self->{schema} ? $self->{schema}->throw_exception(@_) : DBIx::Class::Exception->throw(@_) ; } =head2 column_info_from_storage =over =item Arguments: 1/0 (default: 0) =item Return Value: 1/0 =back __PACKAGE__->column_info_from_storage(1); Enables the on-demand automatic loading of the above column metadata from storage as necessary. This is *deprecated*, and should not be used. It will be removed before 1.0. =head1 FURTHER QUESTIONS? Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>. =head1 COPYRIGHT AND LICENSE This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE> by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can redistribute it and/or modify it under the same terms as the L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>. =cut 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/lib/DBIx/Class/ResultSetColumn.pm�����������������������������������������������0000644�0001750�0001750�00000025175�14240132261�021157� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBIx::Class::ResultSetColumn; use strict; use warnings; use base 'DBIx::Class'; use DBIx::Class::Carp; use DBIx::Class::_Util 'fail_on_internal_wantarray'; use namespace::clean; =head1 NAME DBIx::Class::ResultSetColumn - helpful methods for messing with a single column of the resultset =head1 SYNOPSIS $rs = $schema->resultset('CD')->search({ artist => 'Tool' }); $rs_column = $rs->get_column('year'); $max_year = $rs_column->max; #returns latest year =head1 DESCRIPTION A convenience class used to perform operations on a specific column of a resultset. =cut =head1 METHODS =head2 new my $obj = DBIx::Class::ResultSetColumn->new($rs, $column); Creates a new resultset column object from the resultset and column passed as params. Used internally by L<DBIx::Class::ResultSet/get_column>. =cut sub new { my ($class, $rs, $column) = @_; $class = ref $class if ref $class; $rs->throw_exception('column must be supplied') unless $column; my $orig_attrs = $rs->_resolved_attrs; my $alias = $rs->current_source_alias; my $rsrc = $rs->result_source; # If $column can be found in the 'as' list of the parent resultset, use the # corresponding element of its 'select' list (to keep any custom column # definition set up with 'select' or '+select' attrs), otherwise use $column # (to create a new column definition on-the-fly). my $as_list = $orig_attrs->{as} || []; my $select_list = $orig_attrs->{select} || []; my ($as_index) = grep { ($as_list->[$_] || "") eq $column } 0..$#$as_list; my $select = defined $as_index ? $select_list->[$as_index] : $column; my $colmap; for ($rsrc->columns, $column) { if ($_ =~ /^ \Q$alias\E \. ([^\.]+) $ /x) { $colmap->{$_} = $1; } elsif ($_ !~ /\./) { $colmap->{"$alias.$_"} = $_; $colmap->{$_} = $_; } } my $new_parent_rs; # analyze the order_by, and see if it is done over a function/nonexistentcolumn # if this is the case we will need to wrap a subquery since the result of RSC # *must* be a single column select if ( scalar grep { ! exists $colmap->{$_->[0]} } ( $rsrc->schema->storage->_extract_order_criteria ($orig_attrs->{order_by} ) ) ) { # nuke the prefetch before collapsing to sql my $subq_rs = $rs->search_rs; $subq_rs->{attrs}{join} = $subq_rs->_merge_joinpref_attr( $subq_rs->{attrs}{join}, delete $subq_rs->{attrs}{prefetch} ); $new_parent_rs = $subq_rs->as_subselect_rs; } $new_parent_rs ||= $rs->search_rs; my $new_attrs = $new_parent_rs->{attrs} ||= {}; # prefetch causes additional columns to be fetched, but we can not just make a new # rs via the _resolved_attrs trick - we need to retain the separation between # +select/+as and select/as. At the same time we want to preserve any joins that the # prefetch would otherwise generate. $new_attrs->{join} = $rs->_merge_joinpref_attr( $new_attrs->{join}, delete $new_attrs->{prefetch} ); # {collapse} would mean a has_many join was injected, which in turn means # we need to group *IF WE CAN* (only if the column in question is unique) if (!$orig_attrs->{group_by} && $orig_attrs->{collapse}) { if ($colmap->{$select} and $rsrc->_identifying_column_set([$colmap->{$select}])) { $new_attrs->{group_by} = [ $select ]; delete @{$new_attrs}{qw(distinct _grouped_by_distinct)}; # it is ignored when group_by is present } else { carp ( "Attempting to retrieve non-unique column '$column' on a resultset containing " . 'one-to-many joins will return duplicate results.' ); } } return bless { _select => $select, _as => $column, _parent_resultset => $new_parent_rs }, $class; } =head2 as_query =over 4 =item Arguments: none =item Return Value: \[ $sql, L<@bind_values|DBIx::Class::ResultSet/DBIC BIND VALUES> ] =back Returns the SQL query and bind vars associated with the invocant. This is generally used as the RHS for a subquery. =cut sub as_query { return shift->_resultset->as_query(@_) } =head2 next =over 4 =item Arguments: none =item Return Value: $value =back Returns the next value of the column in the resultset (or C<undef> if there is none). Much like L<DBIx::Class::ResultSet/next> but just returning the one value. =cut sub next { my $self = shift; # using cursor so we don't inflate anything my ($row) = $self->_resultset->cursor->next; return $row; } =head2 all =over 4 =item Arguments: none =item Return Value: @values =back Returns all values of the column in the resultset (or C<undef> if there are none). Much like L<DBIx::Class::ResultSet/all> but returns values rather than result objects. =cut sub all { my $self = shift; # using cursor so we don't inflate anything return map { $_->[0] } $self->_resultset->cursor->all; } =head2 reset =over 4 =item Arguments: none =item Return Value: $self =back Resets the underlying resultset's cursor, so you can iterate through the elements of the column again. Much like L<DBIx::Class::ResultSet/reset>. =cut sub reset { my $self = shift; $self->_resultset->cursor->reset; return $self; } =head2 first =over 4 =item Arguments: none =item Return Value: $value =back Resets the underlying resultset and returns the next value of the column in the resultset (or C<undef> if there is none). Much like L<DBIx::Class::ResultSet/first> but just returning the one value. =cut sub first { my $self = shift; # using cursor so we don't inflate anything $self->_resultset->cursor->reset; my ($row) = $self->_resultset->cursor->next; return $row; } =head2 single =over 4 =item Arguments: none =item Return Value: $value =back Much like L<DBIx::Class::ResultSet/single> fetches one and only one column value using the cursor directly. If additional rows are present a warning is issued before discarding the cursor. =cut sub single { my $self = shift; my $attrs = $self->_resultset->_resolved_attrs; my ($row) = $self->_resultset->result_source->storage->select_single( $attrs->{from}, $attrs->{select}, $attrs->{where}, $attrs ); return $row; } =head2 min =over 4 =item Arguments: none =item Return Value: $lowest_value =back my $first_year = $year_col->min(); Wrapper for ->func. Returns the lowest value of the column in the resultset (or C<undef> if there are none). =cut sub min { return shift->func('MIN'); } =head2 min_rs =over 4 =item Arguments: none =item Return Value: L<$resultset|DBIx::Class::ResultSet> =back my $rs = $year_col->min_rs(); Wrapper for ->func_rs for function MIN(). =cut sub min_rs { return shift->func_rs('MIN') } =head2 max =over 4 =item Arguments: none =item Return Value: $highest_value =back my $last_year = $year_col->max(); Wrapper for ->func. Returns the highest value of the column in the resultset (or C<undef> if there are none). =cut sub max { return shift->func('MAX'); } =head2 max_rs =over 4 =item Arguments: none =item Return Value: L<$resultset|DBIx::Class::ResultSet> =back my $rs = $year_col->max_rs(); Wrapper for ->func_rs for function MAX(). =cut sub max_rs { return shift->func_rs('MAX') } =head2 sum =over 4 =item Arguments: none =item Return Value: $sum_of_values =back my $total = $prices_col->sum(); Wrapper for ->func. Returns the sum of all the values in the column of the resultset. Use on varchar-like columns at your own risk. =cut sub sum { return shift->func('SUM'); } =head2 sum_rs =over 4 =item Arguments: none =item Return Value: L<$resultset|DBIx::Class::ResultSet> =back my $rs = $year_col->sum_rs(); Wrapper for ->func_rs for function SUM(). =cut sub sum_rs { return shift->func_rs('SUM') } =head2 func =over 4 =item Arguments: $function =item Return Value: $function_return_value =back $rs = $schema->resultset("CD")->search({}); $length = $rs->get_column('title')->func('LENGTH'); Runs a query using the function on the column and returns the value. Produces the following SQL: SELECT LENGTH( title ) FROM cd me =cut sub func { my ($self,$function) = @_; my $cursor = $self->func_rs($function)->cursor; if( wantarray ) { DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = fail_on_internal_wantarray; return map { $_->[ 0 ] } $cursor->all; } return ( $cursor->next )[ 0 ]; } =head2 func_rs =over 4 =item Arguments: $function =item Return Value: L<$resultset|DBIx::Class::ResultSet> =back Creates the resultset that C<func()> uses to run its query. =cut sub func_rs { my ($self,$function) = @_; my $rs = $self->{_parent_resultset}; my $select = $self->{_select}; # wrap a grouped rs if ($rs->_resolved_attrs->{group_by}) { $select = $self->{_as}; $rs = $rs->as_subselect_rs; } $rs->search( undef, { columns => { $self->{_as} => { $function => $select } } } ); } =head2 throw_exception See L<DBIx::Class::Schema/throw_exception> for details. =cut sub throw_exception { my $self = shift; if (ref $self && $self->{_parent_resultset}) { $self->{_parent_resultset}->throw_exception(@_); } else { DBIx::Class::Exception->throw(@_); } } # _resultset # # Arguments: none # # Return Value: $resultset # # $year_col->_resultset->next # # Returns the underlying resultset. Creates it from the parent resultset if # necessary. # sub _resultset { my $self = shift; return $self->{_resultset} ||= do { my $select = $self->{_select}; if ($self->{_parent_resultset}{attrs}{distinct}) { my $alias = $self->{_parent_resultset}->current_source_alias; my $rsrc = $self->{_parent_resultset}->result_source; my %cols = map { $_ => 1, "$alias.$_" => 1 } $rsrc->columns; unless( $cols{$select} ) { carp_unique( 'Use of distinct => 1 while selecting anything other than a column ' . 'declared on the primary ResultSource is deprecated (you selected ' . "'$self->{_as}') - please supply an explicit group_by instead" ); # collapse the selector to a literal so that it survives the distinct parse # if it turns out to be an aggregate - at least the user will get a proper exception # instead of silent drop of the group_by altogether $select = \[ $rsrc->storage->sql_maker->_recurse_fields($select) ]; } } $self->{_parent_resultset}->search(undef, { columns => { $self->{_as} => $select } }); }; } =head1 FURTHER QUESTIONS? Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>. =head1 COPYRIGHT AND LICENSE This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE> by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can redistribute it and/or modify it under the same terms as the L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>. =cut 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/lib/DBIx/Class/PK.pm������������������������������������������������������������0000644�0001750�0001750�00000006466�14240132261�016363� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBIx::Class::PK; use strict; use warnings; use base qw/DBIx::Class::Row/; =head1 NAME DBIx::Class::PK - Primary Key class =head1 SYNOPSIS =head1 DESCRIPTION This class contains methods for handling primary keys and methods depending on them. =head1 METHODS =cut =head2 id Returns the primary key(s) for a row. Can't be called as a class method. =cut sub id { my ($self) = @_; $self->throw_exception( "Can't call id() as a class method" ) unless ref $self; my @id_vals = $self->_ident_values; return (wantarray ? @id_vals : $id_vals[0]); } sub _ident_values { my ($self, $use_storage_state) = @_; my (@ids, @missing); for ($self->result_source->_pri_cols_or_die) { push @ids, ($use_storage_state and exists $self->{_column_data_in_storage}{$_}) ? $self->{_column_data_in_storage}{$_} : $self->get_column($_) ; push @missing, $_ if (! defined $ids[-1] and ! $self->has_column_loaded ($_) ); } if (@missing && $self->in_storage) { $self->throw_exception ( 'Unable to uniquely identify result object with missing PK columns: ' . join (', ', @missing ) ); } return @ids; } =head2 ID Returns a unique id string identifying a result object by primary key. Used by L<DBIx::Class::CDBICompat::LiveObjectIndex> and L<DBIx::Class::ObjectCache>. =over =item WARNING The default C<_create_ID> method used by this function orders the returned values by the alphabetical order of the primary column names, B<unlike> the L</id> method, which follows the same order in which columns were fed to L<DBIx::Class::ResultSource/set_primary_key>. =back =cut sub ID { my ($self) = @_; $self->throw_exception( "Can't call ID() as a class method" ) unless ref $self; return undef unless $self->in_storage; return $self->_create_ID(%{$self->ident_condition}); } sub _create_ID { my ($self, %vals) = @_; return undef if grep { !defined } values %vals; return join '|', ref $self || $self, $self->result_source->name, map { $_ . '=' . $vals{$_} } sort keys %vals; } =head2 ident_condition my $cond = $result_source->ident_condition(); my $cond = $result_source->ident_condition('alias'); Produces a condition hash to locate a row based on the primary key(s). =cut sub ident_condition { shift->_mk_ident_cond(@_); } sub _storage_ident_condition { shift->_mk_ident_cond(shift, 1); } sub _mk_ident_cond { my ($self, $alias, $use_storage_state) = @_; my @pks = $self->result_source->_pri_cols_or_die; my @vals = $self->_ident_values($use_storage_state); my (%cond, @undef); my $prefix = defined $alias ? $alias.'.' : ''; for my $col (@pks) { if (! defined ($cond{$prefix.$col} = shift @vals) ) { push @undef, $col; } } if (@undef && $self->in_storage) { $self->throw_exception ( 'Unable to construct result object identity condition due to NULL PK columns: ' . join (', ', @undef) ); } return \%cond; } =head1 FURTHER QUESTIONS? Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>. =head1 COPYRIGHT AND LICENSE This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE> by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can redistribute it and/or modify it under the same terms as the L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>. =cut 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/lib/DBIx/Class/Carp.pm����������������������������������������������������������0000644�0001750�0001750�00000011750�14240132261�016726� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from pause DBIx::Class::Carp; use strict; use warnings; # load Carp early to prevent tickling of the ::Internal stash being # interpreted as "Carp is already loaded" by some braindead loader use Carp (); $Carp::Internal{ (__PACKAGE__) }++; sub __find_caller { my ($skip_pattern, $class) = @_; my $skip_class_data = $class->_skip_namespace_frames if ($class and $class->can('_skip_namespace_frames')); $skip_pattern = qr/$skip_pattern|$skip_class_data/ if $skip_class_data; my $fr_num = 1; # skip us and the calling carp* my (@f, $origin); while (@f = caller($fr_num++)) { next if ( $f[3] eq '(eval)' or $f[3] =~ /::__ANON__$/ ); $origin ||= ( $f[3] =~ /^ (.+) :: ([^\:]+) $/x and ! $Carp::Internal{$1} and ############################# # Need a way to parameterize this for Carp::Skip $1 !~ /^(?: DBIx::Class::Storage::BlockRunner | Context::Preserve | Try::Tiny | Class::Accessor::Grouped | Class::C3::Componentised | Module::Runtime )$/x and $2 !~ /^(?: throw_exception | carp | carp_unique | carp_once | dbh_do | txn_do | with_deferred_fk_checks)$/x ############################# ) ? $f[3] : undef; if ( $f[0]->can('_skip_namespace_frames') and my $extra_skip = $f[0]->_skip_namespace_frames ) { $skip_pattern = qr/$skip_pattern|$extra_skip/; } last if $f[0] !~ $skip_pattern; } my $site = @f # if empty - nothing matched - full stack ? "at $f[1] line $f[2]" : Carp::longmess() ; $origin ||= '{UNKNOWN}'; return ( $site, $origin =~ /::/ ? "$origin(): " : "$origin: ", # cargo-cult from Carp::Clan ); }; my $warn = sub { my ($ln, @warn) = @_; @warn = "Warning: something's wrong" unless @warn; # back-compat with Carp::Clan - a warning ending with \n does # not include caller info warn ( @warn, $warn[-1] =~ /\n$/ ? '' : " $ln\n" ); }; sub import { my (undef, $skip_pattern) = @_; my $into = caller; $skip_pattern = $skip_pattern ? qr/ ^ $into $ | $skip_pattern /x : qr/ ^ $into $ /x ; no strict 'refs'; *{"${into}::carp"} = sub { $warn->( __find_caller($skip_pattern, $into), @_ ); }; my $fired = {}; *{"${into}::carp_once"} = sub { return if $fired->{$_[0]}; $fired->{$_[0]} = 1; $warn->( __find_caller($skip_pattern, $into), @_, ); }; my $seen; *{"${into}::carp_unique"} = sub { my ($ln, $calling) = __find_caller($skip_pattern, $into); my $msg = join ('', $calling, @_); # unique carping with a hidden caller makes no sense $msg =~ s/\n+$//; return if $seen->{$ln}{$msg}; $seen->{$ln}{$msg} = 1; $warn->( $ln, $msg, ); }; } sub unimport { die (__PACKAGE__ . " does not implement unimport yet\n"); } 1; __END__ =head1 NAME DBIx::Class::Carp - Provides advanced Carp::Clan-like warning functions for DBIx::Class internals =head1 DESCRIPTION Documentation is lacking on purpose - this an experiment not yet fit for mass consumption. If you use this do not count on any kind of stability, in fact don't even count on this module's continuing existence (it has been noindexed for a reason). In addition to the classic interface: use DBIx::Class::Carp '^DBIx::Class' this module also supports a class-data based way to specify the exclusion regex. A message is only carped from a callsite that matches neither the closed over string, nor the value of L</_skip_namespace_frames> as declared on any callframe already skipped due to the same mechanism. This is to ensure that intermediate callsites can declare their own additional skip-namespaces. =head1 CLASS ATTRIBUTES =head2 _skip_namespace_frames A classdata attribute holding the stringified regex matching callsites that should be skipped by the carp methods below. An empty string C<q{}> is treated like no setting/C<undef> (the distinction is necessary due to semantics of the class data accessors provided by L<Class::Accessor::Grouped>) =head1 EXPORTED FUNCTIONS This module export the following 3 functions. Only warning related C<carp*> is being handled here, for C<croak>-ing you must use L<DBIx::Class::Schema/throw_exception> or L<DBIx::Class::Exception>. =head2 carp Carps message with the file/line of the first callsite not matching L</_skip_namespace_frames> nor the closed-over arguments to C<use DBIx::Class::Carp>. =head2 carp_unique Like L</carp> but warns once for every distinct callsite (subject to the same ruleset as L</carp>). =head2 carp_once Like L</carp> but warns only once for the life of the perl interpreter (regardless of callsite). =head1 FURTHER QUESTIONS? Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>. =head1 COPYRIGHT AND LICENSE This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE> by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can redistribute it and/or modify it under the same terms as the L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>. =cut ������������������������DBIx-Class-0.082843/lib/DBIx/Class/PK.pod�����������������������������������������������������������0000444�0001750�0001750�00000005723�14240676411�016534� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������=for comment POD_DERIVED_INDEX_GENERATED The following documentation is automatically generated. Please do not edit this file, but rather the original, inline with DBIx::Class::PK at lib/DBIx/Class/PK.pm (on the system that originally ran this). If you do edit this file, and don't want your changes to be removed, make sure you change the first line. =cut =head1 NAME DBIx::Class::PK - Primary Key class =head1 SYNOPSIS =head1 DESCRIPTION This class contains methods for handling primary keys and methods depending on them. =head1 METHODS =head2 id Returns the primary key(s) for a row. Can't be called as a class method. =head2 ID Returns a unique id string identifying a result object by primary key. Used by L<DBIx::Class::CDBICompat::LiveObjectIndex> and L<DBIx::Class::ObjectCache>. =over 4 =item WARNING The default C<_create_ID> method used by this function orders the returned values by the alphabetical order of the primary column names, B<unlike> the L</id> method, which follows the same order in which columns were fed to L<DBIx::Class::ResultSource/set_primary_key>. =back =head2 ident_condition my $cond = $result_source->ident_condition(); my $cond = $result_source->ident_condition('alias'); Produces a condition hash to locate a row based on the primary key(s). =head1 INHERITED METHODS =over 4 =item L<DBIx::Class::Row> L<copy|DBIx::Class::Row/copy>, L<delete|DBIx::Class::Row/delete>, L<discard_changes|DBIx::Class::Row/discard_changes>, L<get_column|DBIx::Class::Row/get_column>, L<get_columns|DBIx::Class::Row/get_columns>, L<get_dirty_columns|DBIx::Class::Row/get_dirty_columns>, L<get_from_storage|DBIx::Class::Row/get_from_storage>, L<get_inflated_columns|DBIx::Class::Row/get_inflated_columns>, L<has_column_loaded|DBIx::Class::Row/has_column_loaded>, L<in_storage|DBIx::Class::Row/in_storage>, L<inflate_result|DBIx::Class::Row/inflate_result>, L<insert|DBIx::Class::Row/insert>, L<insert_or_update|DBIx::Class::Row/insert_or_update>, L<is_changed|DBIx::Class::Row/is_changed>, L<is_column_changed|DBIx::Class::Row/is_column_changed>, L<make_column_dirty|DBIx::Class::Row/make_column_dirty>, L<new|DBIx::Class::Row/new>, L<register_column|DBIx::Class::Row/register_column>, L<result_source|DBIx::Class::Row/result_source>, L<set_column|DBIx::Class::Row/set_column>, L<set_columns|DBIx::Class::Row/set_columns>, L<set_inflated_columns|DBIx::Class::Row/set_inflated_columns>, L<store_column|DBIx::Class::Row/store_column>, L<throw_exception|DBIx::Class::Row/throw_exception>, L<update|DBIx::Class::Row/update>, L<update_or_insert|DBIx::Class::Row/update_or_insert> =back =head1 FURTHER QUESTIONS? Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>. =head1 COPYRIGHT AND LICENSE This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE> by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can redistribute it and/or modify it under the same terms as the L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>. ���������������������������������������������DBIx-Class-0.082843/lib/DBIx/Class/Storage.pm�������������������������������������������������������0000644�0001750�0001750�00000037031�14240132261�017445� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBIx::Class::Storage; use strict; use warnings; use base qw/DBIx::Class/; use mro 'c3'; { package # Hide from PAUSE DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION; use base 'DBIx::Class::Exception'; } use DBIx::Class::Carp; use DBIx::Class::Storage::BlockRunner; use Scalar::Util qw/blessed weaken/; use DBIx::Class::Storage::TxnScopeGuard; use Try::Tiny; use namespace::clean; __PACKAGE__->mk_group_accessors(simple => qw/debug schema transaction_depth auto_savepoint savepoints/); __PACKAGE__->mk_group_accessors(component_class => 'cursor_class'); __PACKAGE__->cursor_class('DBIx::Class::Cursor'); sub cursor { shift->cursor_class(@_); } =head1 NAME DBIx::Class::Storage - Generic Storage Handler =head1 DESCRIPTION A base implementation of common Storage methods. For specific information about L<DBI>-based storage, see L<DBIx::Class::Storage::DBI>. =head1 METHODS =head2 new Arguments: $schema Instantiates the Storage object. =cut sub new { my ($self, $schema) = @_; $self = ref $self if ref $self; my $new = bless( { transaction_depth => 0, savepoints => [], }, $self); $new->set_schema($schema); $new->debug(1) if $ENV{DBIX_CLASS_STORAGE_DBI_DEBUG} || $ENV{DBIC_TRACE}; $new; } =head2 set_schema Used to reset the schema class or object which owns this storage object, such as during L<DBIx::Class::Schema/clone>. =cut sub set_schema { my ($self, $schema) = @_; $self->schema($schema); weaken $self->{schema} if ref $self->{schema}; } =head2 connected Returns true if we have an open storage connection, false if it is not (yet) open. =cut sub connected { die "Virtual method!" } =head2 disconnect Closes any open storage connection unconditionally. =cut sub disconnect { die "Virtual method!" } =head2 ensure_connected Initiate a connection to the storage if one isn't already open. =cut sub ensure_connected { die "Virtual method!" } =head2 throw_exception Throws an exception - croaks. =cut sub throw_exception { my $self = shift; if (ref $self and $self->schema) { $self->schema->throw_exception(@_); } else { DBIx::Class::Exception->throw(@_); } } =head2 txn_do =over 4 =item Arguments: C<$coderef>, @coderef_args? =item Return Value: The return value of $coderef =back Executes C<$coderef> with (optional) arguments C<@coderef_args> atomically, returning its result (if any). If an exception is caught, a rollback is issued and the exception is rethrown. If the rollback fails, (i.e. throws an exception) an exception is thrown that includes a "Rollback failed" message. For example, my $author_rs = $schema->resultset('Author')->find(1); my @titles = qw/Night Day It/; my $coderef = sub { # If any one of these fails, the entire transaction fails $author_rs->create_related('books', { title => $_ }) foreach (@titles); return $author->books; }; my $rs; try { $rs = $schema->txn_do($coderef); } catch { my $error = shift; # Transaction failed die "something terrible has happened!" if ($error =~ /Rollback failed/); # Rollback failed deal_with_failed_transaction(); }; In a nested transaction (calling txn_do() from within a txn_do() coderef) only the outermost transaction will issue a L</txn_commit>, and txn_do() can be called in void, scalar and list context and it will behave as expected. Please note that all of the code in your coderef, including non-DBIx::Class code, is part of a transaction. This transaction may fail out halfway, or it may get partially double-executed (in the case that our DB connection failed halfway through the transaction, in which case we reconnect and restart the txn). Therefore it is best that any side-effects in your coderef are idempotent (that is, can be re-executed multiple times and get the same result), and that you check up on your side-effects in the case of transaction failure. =cut sub txn_do { my $self = shift; DBIx::Class::Storage::BlockRunner->new( storage => $self, wrap_txn => 1, retry_handler => sub { $_[0]->failed_attempt_count == 1 and ! $_[0]->storage->connected }, )->run(@_); } =head2 txn_begin Starts a transaction. See the preferred L</txn_do> method, which allows for an entire code block to be executed transactionally. =cut sub txn_begin { my $self = shift; if($self->transaction_depth == 0) { $self->debugobj->txn_begin() if $self->debug; $self->_exec_txn_begin; } elsif ($self->auto_savepoint) { $self->svp_begin; } $self->{transaction_depth}++; } =head2 txn_commit Issues a commit of the current transaction. It does I<not> perform an actual storage commit unless there's a DBIx::Class transaction currently in effect (i.e. you called L</txn_begin>). =cut sub txn_commit { my $self = shift; if ($self->transaction_depth == 1) { $self->debugobj->txn_commit() if $self->debug; $self->_exec_txn_commit; $self->{transaction_depth}--; $self->savepoints([]); } elsif($self->transaction_depth > 1) { $self->{transaction_depth}--; $self->svp_release if $self->auto_savepoint; } else { $self->throw_exception( 'Refusing to commit without a started transaction' ); } } =head2 txn_rollback Issues a rollback of the current transaction. A nested rollback will throw a L<DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION> exception, which allows the rollback to propagate to the outermost transaction. =cut sub txn_rollback { my $self = shift; if ($self->transaction_depth == 1) { $self->debugobj->txn_rollback() if $self->debug; $self->_exec_txn_rollback; $self->{transaction_depth}--; $self->savepoints([]); } elsif ($self->transaction_depth > 1) { $self->{transaction_depth}--; if ($self->auto_savepoint) { $self->svp_rollback; $self->svp_release; } else { DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->throw( "A txn_rollback in nested transaction is ineffective! (depth $self->{transaction_depth})" ); } } else { $self->throw_exception( 'Refusing to roll back without a started transaction' ); } } =head2 svp_begin Arguments: $savepoint_name? Created a new savepoint using the name provided as argument. If no name is provided, a random name will be used. =cut sub svp_begin { my ($self, $name) = @_; $self->throw_exception ("You can't use savepoints outside a transaction") unless $self->transaction_depth; my $exec = $self->can('_exec_svp_begin') or $self->throw_exception ("Your Storage implementation doesn't support savepoints"); $name = $self->_svp_generate_name unless defined $name; push @{ $self->{savepoints} }, $name; $self->debugobj->svp_begin($name) if $self->debug; $exec->($self, $name); } sub _svp_generate_name { my ($self) = @_; return 'savepoint_'.scalar(@{ $self->{'savepoints'} }); } =head2 svp_release Arguments: $savepoint_name? Release the savepoint provided as argument. If none is provided, release the savepoint created most recently. This will implicitly release all savepoints created after the one explicitly released as well. =cut sub svp_release { my ($self, $name) = @_; $self->throw_exception ("You can't use savepoints outside a transaction") unless $self->transaction_depth; my $exec = $self->can('_exec_svp_release') or $self->throw_exception ("Your Storage implementation doesn't support savepoints"); if (defined $name) { my @stack = @{ $self->savepoints }; my $svp = ''; while( $svp ne $name ) { $self->throw_exception ("Savepoint '$name' does not exist") unless @stack; $svp = pop @stack; } $self->savepoints(\@stack); # put back what's left } else { $name = pop @{ $self->savepoints } or $self->throw_exception('No savepoints to release');; } $self->debugobj->svp_release($name) if $self->debug; $exec->($self, $name); } =head2 svp_rollback Arguments: $savepoint_name? Rollback to the savepoint provided as argument. If none is provided, rollback to the savepoint created most recently. This will implicitly release all savepoints created after the savepoint we rollback to. =cut sub svp_rollback { my ($self, $name) = @_; $self->throw_exception ("You can't use savepoints outside a transaction") unless $self->transaction_depth; my $exec = $self->can('_exec_svp_rollback') or $self->throw_exception ("Your Storage implementation doesn't support savepoints"); if (defined $name) { my @stack = @{ $self->savepoints }; my $svp; # a rollback doesn't remove the named savepoint, # only everything after it while (@stack and $stack[-1] ne $name) { pop @stack }; $self->throw_exception ("Savepoint '$name' does not exist") unless @stack; $self->savepoints(\@stack); # put back what's left } else { $name = $self->savepoints->[-1] or $self->throw_exception('No savepoints to rollback');; } $self->debugobj->svp_rollback($name) if $self->debug; $exec->($self, $name); } =head2 txn_scope_guard An alternative way of transaction handling based on L<DBIx::Class::Storage::TxnScopeGuard>: my $txn_guard = $storage->txn_scope_guard; $result->col1("val1"); $result->update; $txn_guard->commit; If an exception occurs, or the guard object otherwise leaves the scope before C<< $txn_guard->commit >> is called, the transaction will be rolled back by an explicit L</txn_rollback> call. In essence this is akin to using a L</txn_begin>/L</txn_commit> pair, without having to worry about calling L</txn_rollback> at the right places. Note that since there is no defined code closure, there will be no retries and other magic upon database disconnection. If you need such functionality see L</txn_do>. =cut sub txn_scope_guard { return DBIx::Class::Storage::TxnScopeGuard->new($_[0]); } =head2 sql_maker Returns a C<sql_maker> object - normally an object of class C<DBIx::Class::SQLMaker>. =cut sub sql_maker { die "Virtual method!" } =head2 debug Causes trace information to be emitted on the L</debugobj> object. (or C<STDERR> if L</debugobj> has not specifically been set). This is the equivalent to setting L</DBIC_TRACE> in your shell environment. =head2 debugfh An opportunistic proxy to L<< ->debugobj->debugfh(@_) |DBIx::Class::Storage::Statistics/debugfh >> If the currently set L</debugobj> does not have a L</debugfh> method, caling this is a no-op. =cut sub debugfh { my $self = shift; if ($self->debugobj->can('debugfh')) { return $self->debugobj->debugfh(@_); } } =head2 debugobj Sets or retrieves the object used for metric collection. Defaults to an instance of L<DBIx::Class::Storage::Statistics> that is compatible with the original method of using a coderef as a callback. See the aforementioned Statistics class for more information. =cut sub debugobj { my $self = shift; if (@_) { return $self->{debugobj} = $_[0]; } $self->{debugobj} ||= do { if (my $profile = $ENV{DBIC_TRACE_PROFILE}) { require DBIx::Class::Storage::Debug::PrettyTrace; my @pp_args; if ($profile =~ /^\.?\//) { require Config::Any; my $cfg = try { Config::Any->load_files({ files => [$profile], use_ext => 1 }); } catch { # sanitize the error message a bit $_ =~ s/at \s+ .+ Storage\.pm \s line \s \d+ $//x; $self->throw_exception("Failure processing \$ENV{DBIC_TRACE_PROFILE}: $_"); }; @pp_args = values %{$cfg->[0]}; } else { @pp_args = { profile => $profile }; } # FIXME - FRAGILE # Hash::Merge is a sorry piece of shit and tramples all over $@ # *without* throwing an exception # This is a rather serious problem in the debug codepath # Insulate the condition here with a try{} until a review of # DBIx::Class::Storage::Debug::PrettyTrace takes place # we do rethrow the error unconditionally, the only reason # to try{} is to preserve the precise state of $@ (down # to the scalar (if there is one) address level) # # Yes I am aware this is fragile and TxnScopeGuard needs # a better fix. This is another yak to shave... :( try { DBIx::Class::Storage::Debug::PrettyTrace->new(@pp_args); } catch { $self->throw_exception($_); } } else { require DBIx::Class::Storage::Statistics; DBIx::Class::Storage::Statistics->new } }; } =head2 debugcb Sets a callback to be executed each time a statement is run; takes a sub reference. Callback is executed as $sub->($op, $info) where $op is SELECT/INSERT/UPDATE/DELETE and $info is what would normally be printed. See L</debugobj> for a better way. =cut sub debugcb { my $self = shift; if ($self->debugobj->can('callback')) { return $self->debugobj->callback(@_); } } =head2 cursor_class The cursor class for this Storage object. =cut =head2 deploy Deploy the tables to storage (CREATE TABLE and friends in a SQL-based Storage class). This would normally be called through L<DBIx::Class::Schema/deploy>. =cut sub deploy { die "Virtual method!" } =head2 connect_info The arguments of C<connect_info> are always a single array reference, and are Storage-handler specific. This is normally accessed via L<DBIx::Class::Schema/connection>, which encapsulates its argument list in an arrayref before calling C<connect_info> here. =cut sub connect_info { die "Virtual method!" } =head2 select Handle a select statement. =cut sub select { die "Virtual method!" } =head2 insert Handle an insert statement. =cut sub insert { die "Virtual method!" } =head2 update Handle an update statement. =cut sub update { die "Virtual method!" } =head2 delete Handle a delete statement. =cut sub delete { die "Virtual method!" } =head2 select_single Performs a select, fetch and return of data - handles a single row only. =cut sub select_single { die "Virtual method!" } =head2 columns_info_for Returns metadata for the given source's columns. This is *deprecated*, and will be removed before 1.0. You should be specifying the metadata yourself if you need it. =cut sub columns_info_for { die "Virtual method!" } =head1 ENVIRONMENT VARIABLES =head2 DBIC_TRACE If C<DBIC_TRACE> is set then trace information is produced (as when the L</debug> method is set). If the value is of the form C<1=/path/name> then the trace output is written to the file C</path/name>. This environment variable is checked when the storage object is first created (when you call connect on your schema). So, run-time changes to this environment variable will not take effect unless you also re-connect on your schema. =head2 DBIC_TRACE_PROFILE If C<DBIC_TRACE_PROFILE> is set, L<DBIx::Class::Storage::Debug::PrettyTrace> will be used to format the output from C<DBIC_TRACE>. The value it is set to is the C<profile> that it will be used. If the value is a filename the file is read with L<Config::Any> and the results are used as the configuration for tracing. See L<SQL::Abstract::Tree/new> for what that structure should look like. =head2 DBIX_CLASS_STORAGE_DBI_DEBUG Old name for DBIC_TRACE =head1 SEE ALSO L<DBIx::Class::Storage::DBI> - reference storage implementation using DBI and a subclass of SQL::Abstract::Classic ( or similar ) =head1 FURTHER QUESTIONS? Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>. =head1 COPYRIGHT AND LICENSE This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE> by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can redistribute it and/or modify it under the same terms as the L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>. =cut 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/lib/DBIx/Class/Manual.pod�������������������������������������������������������0000644�0001750�0001750�00000003365�13271562530�017440� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������=head1 NAME DBIx::Class::Manual - Index of the Manual =head1 DESCRIPTION This is the L<DBIx::Class> users manual. DBIx::Class is a SQL->OOP mapper. This means that it can represent your SQL tables as perl classes, and give you convenient accessors and methods for retrieving and updating information from your SQL database. =head1 SECTIONS =head2 L<DBIx::Class::Manual::FAQ> Short answers and doc pointers to questions. =head2 L<DBIx::Class::Manual::Glossary> Explanations of terms used in this documentation. =head2 L<DBIx::Class::Manual::Intro> Beginner guide to using DBIx::Class. =head2 L<DBIx::Class::Manual::Example> An example of slightly more complex usage. =head2 L<DBIx::Class::Manual::Joining> How to translate known SQL JOINs into DBIx-Class-ish. =head2 L<DBIx::Class::Manual::Cookbook> Convenient recipes for DBIC usage. =head2 L<DBIx::Class::Manual::Reading> How to read (and write) the reference documentation. =head2 L<DBIx::Class::Manual::DocMap> Lists of modules by task to help you find the correct document. =head2 L<DBIx::Class::Manual::Troubleshooting> Got trouble? Let us shoot it for you. If you're using the CDBI Compat layer, we suggest reading the L<Class::DBI> documentation. It should behave the same way. =head2 L<DBIx::Class::Manual::Component> Existing components, and documentation and example on how to develop new ones. =head1 FURTHER QUESTIONS? Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>. =head1 COPYRIGHT AND LICENSE This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE> by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can redistribute it and/or modify it under the same terms as the L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>. ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/lib/DBIx/Class/Ordered.pm�������������������������������������������������������0000644�0001750�0001750�00000064270�14240132261�017432� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBIx::Class::Ordered; use strict; use warnings; use base qw( DBIx::Class ); =head1 NAME DBIx::Class::Ordered - Modify the position of objects in an ordered list. =head1 SYNOPSIS Create a table for your ordered data. CREATE TABLE items ( item_id INTEGER PRIMARY KEY AUTOINCREMENT, name TEXT NOT NULL, position INTEGER NOT NULL ); Optionally, add one or more columns to specify groupings, allowing you to maintain independent ordered lists within one table: CREATE TABLE items ( item_id INTEGER PRIMARY KEY AUTOINCREMENT, name TEXT NOT NULL, position INTEGER NOT NULL, group_id INTEGER NOT NULL ); Or even CREATE TABLE items ( item_id INTEGER PRIMARY KEY AUTOINCREMENT, name TEXT NOT NULL, position INTEGER NOT NULL, group_id INTEGER NOT NULL, other_group_id INTEGER NOT NULL ); In your Schema or DB class add "Ordered" to the top of the component list. __PACKAGE__->load_components(qw( Ordered ... )); Specify the column that stores the position number for each row. package My::Item; __PACKAGE__->position_column('position'); If you are using one grouping column, specify it as follows: __PACKAGE__->grouping_column('group_id'); Or if you have multiple grouping columns: __PACKAGE__->grouping_column(['group_id', 'other_group_id']); That's it, now you can change the position of your objects. #!/use/bin/perl use My::Item; my $item = My::Item->create({ name=>'Matt S. Trout' }); # If using grouping_column: my $item = My::Item->create({ name=>'Matt S. Trout', group_id=>1 }); my $rs = $item->siblings(); my @siblings = $item->siblings(); my $sibling; $sibling = $item->first_sibling(); $sibling = $item->last_sibling(); $sibling = $item->previous_sibling(); $sibling = $item->next_sibling(); $item->move_previous(); $item->move_next(); $item->move_first(); $item->move_last(); $item->move_to( $position ); $item->move_to_group( 'groupname' ); $item->move_to_group( 'groupname', $position ); $item->move_to_group( {group_id=>'groupname', 'other_group_id=>'othergroupname'} ); $item->move_to_group( {group_id=>'groupname', 'other_group_id=>'othergroupname'}, $position ); =head1 DESCRIPTION This module provides a simple interface for modifying the ordered position of DBIx::Class objects. =head1 AUTO UPDATE All of the move_* methods automatically update the rows involved in the query. This is not configurable and is due to the fact that if you move a record it always causes other records in the list to be updated. =head1 METHODS =head2 position_column __PACKAGE__->position_column('position'); Sets and retrieves the name of the column that stores the positional value of each record. Defaults to "position". =cut __PACKAGE__->mk_classdata( 'position_column' => 'position' ); =head2 grouping_column __PACKAGE__->grouping_column('group_id'); This method specifies a column to limit all queries in this module by. This effectively allows you to have multiple ordered lists within the same table. =cut __PACKAGE__->mk_classdata( 'grouping_column' ); =head2 null_position_value __PACKAGE__->null_position_value(undef); This method specifies a value of L</position_column> which B<would never be assigned to a row> during normal operation. When a row is moved, its position is set to this value temporarily, so that any unique constraints can not be violated. This value defaults to 0, which should work for all cases except when your positions do indeed start from 0. =cut __PACKAGE__->mk_classdata( 'null_position_value' => 0 ); =head2 siblings my $rs = $item->siblings(); my @siblings = $item->siblings(); Returns an B<ordered> resultset of all other objects in the same group excluding the one you called it on. The ordering is a backwards-compatibility artifact - if you need a resultset with no ordering applied use C<_siblings> =cut sub siblings { my $self = shift; return $self->_siblings->search ({}, { order_by => $self->position_column } ); } =head2 previous_siblings my $prev_rs = $item->previous_siblings(); my @prev_siblings = $item->previous_siblings(); Returns a resultset of all objects in the same group positioned before the object on which this method was called. =cut sub previous_siblings { my $self = shift; my $position_column = $self->position_column; my $position = $self->get_column ($position_column); return ( defined $position ? $self->_siblings->search ({ $position_column => { '<', $position } }) : $self->_siblings ); } =head2 next_siblings my $next_rs = $item->next_siblings(); my @next_siblings = $item->next_siblings(); Returns a resultset of all objects in the same group positioned after the object on which this method was called. =cut sub next_siblings { my $self = shift; my $position_column = $self->position_column; my $position = $self->get_column ($position_column); return ( defined $position ? $self->_siblings->search ({ $position_column => { '>', $position } }) : $self->_siblings ); } =head2 previous_sibling my $sibling = $item->previous_sibling(); Returns the sibling that resides one position back. Returns 0 if the current object is the first one. =cut sub previous_sibling { my $self = shift; my $position_column = $self->position_column; my $psib = $self->previous_siblings->search( {}, { rows => 1, order_by => { '-desc' => $position_column } }, )->single; return defined $psib ? $psib : 0; } =head2 first_sibling my $sibling = $item->first_sibling(); Returns the first sibling object, or 0 if the first sibling is this sibling. =cut sub first_sibling { my $self = shift; my $position_column = $self->position_column; my $fsib = $self->previous_siblings->search( {}, { rows => 1, order_by => { '-asc' => $position_column } }, )->single; return defined $fsib ? $fsib : 0; } =head2 next_sibling my $sibling = $item->next_sibling(); Returns the sibling that resides one position forward. Returns 0 if the current object is the last one. =cut sub next_sibling { my $self = shift; my $position_column = $self->position_column; my $nsib = $self->next_siblings->search( {}, { rows => 1, order_by => { '-asc' => $position_column } }, )->single; return defined $nsib ? $nsib : 0; } =head2 last_sibling my $sibling = $item->last_sibling(); Returns the last sibling, or 0 if the last sibling is this sibling. =cut sub last_sibling { my $self = shift; my $position_column = $self->position_column; my $lsib = $self->next_siblings->search( {}, { rows => 1, order_by => { '-desc' => $position_column } }, )->single; return defined $lsib ? $lsib : 0; } # an optimized method to get the last sibling position value without inflating a result object sub _last_sibling_posval { my $self = shift; my $position_column = $self->position_column; my $cursor = $self->next_siblings->search( {}, { rows => 1, order_by => { '-desc' => $position_column }, select => $position_column }, )->cursor; my ($pos) = $cursor->next; return $pos; } =head2 move_previous $item->move_previous(); Swaps position with the sibling in the position previous in the list. Returns 1 on success, and 0 if the object is already the first one. =cut sub move_previous { my $self = shift; return $self->move_to ($self->_position - 1); } =head2 move_next $item->move_next(); Swaps position with the sibling in the next position in the list. Returns 1 on success, and 0 if the object is already the last in the list. =cut sub move_next { my $self = shift; return 0 unless defined $self->_last_sibling_posval; # quick way to check for no more siblings return $self->move_to ($self->_position + 1); } =head2 move_first $item->move_first(); Moves the object to the first position in the list. Returns 1 on success, and 0 if the object is already the first. =cut sub move_first { return shift->move_to( 1 ); } =head2 move_last $item->move_last(); Moves the object to the last position in the list. Returns 1 on success, and 0 if the object is already the last one. =cut sub move_last { my $self = shift; my $last_posval = $self->_last_sibling_posval; return 0 unless defined $last_posval; return $self->move_to( $self->_position_from_value ($last_posval) ); } =head2 move_to $item->move_to( $position ); Moves the object to the specified position. Returns 1 on success, and 0 if the object is already at the specified position. =cut sub move_to { my( $self, $to_position ) = @_; return 0 if ( $to_position < 1 ); my $position_column = $self->position_column; my $is_txn; if ($is_txn = $self->result_source->schema->storage->transaction_depth) { # Reload position state from storage # The thinking here is that if we are in a transaction, it is # *more likely* the object went out of sync due to resultset # level shenanigans. Instead of always reloading (slow) - go # ahead and hand-hold only in the case of higher layers # requesting the safety of a txn $self->store_column( $position_column, ( $self->result_source ->resultset ->search($self->_storage_ident_condition, { rows => 1, columns => $position_column }) ->cursor ->next )[0] || $self->throw_exception( sprintf "Unable to locate object '%s' in storage - object went ouf of sync...?", $self->ID ), ); delete $self->{_dirty_columns}{$position_column}; } elsif ($self->is_column_changed ($position_column) ) { # something changed our position, we need to know where we # used to be - use the stashed value $self->store_column($position_column, delete $self->{_column_data_in_storage}{$position_column}); delete $self->{_dirty_columns}{$position_column}; } my $from_position = $self->_position; if ( $from_position == $to_position ) { # FIXME this will not work for non-numeric order return 0; } my $guard = $is_txn ? undef : $self->result_source->schema->txn_scope_guard; my ($direction, @between); if ( $from_position < $to_position ) { $direction = -1; @between = map { $self->_position_value ($_) } ( $from_position + 1, $to_position ); } else { $direction = 1; @between = map { $self->_position_value ($_) } ( $to_position, $from_position - 1 ); } my $new_pos_val = $self->_position_value ($to_position); # record this before the shift # we need to null-position the moved row if the position column is part of a constraint if (grep { $_ eq $position_column } ( map { @$_ } (values %{{ $self->result_source->unique_constraints }} ) ) ) { $self->_ordered_internal_update({ $position_column => $self->null_position_value }); } $self->_shift_siblings ($direction, @between); $self->_ordered_internal_update({ $position_column => $new_pos_val }); $guard->commit if $guard; return 1; } =head2 move_to_group $item->move_to_group( $group, $position ); Moves the object to the specified position of the specified group, or to the end of the group if $position is undef. 1 is returned on success, and 0 is returned if the object is already at the specified position of the specified group. $group may be specified as a single scalar if only one grouping column is in use, or as a hashref of column => value pairs if multiple grouping columns are in use. =cut sub move_to_group { my( $self, $to_group, $to_position ) = @_; # if we're given a single value, turn it into a hashref unless (ref $to_group eq 'HASH') { my @gcols = $self->_grouping_columns; $self->throw_exception ('Single group supplied for a multi-column group identifier') if @gcols > 1; $to_group = {$gcols[0] => $to_group}; } my $position_column = $self->position_column; return 0 if ( defined($to_position) and $to_position < 1 ); # check if someone changed the _grouping_columns - this will # prevent _is_in_group working, so we need to restore the # original stashed values for ($self->_grouping_columns) { if ($self->is_column_changed ($_)) { $self->store_column($_, delete $self->{_column_data_in_storage}{$_}); delete $self->{_dirty_columns}{$_}; } } if ($self->_is_in_group ($to_group) ) { my $ret; if (defined $to_position) { $ret = $self->move_to ($to_position); } return $ret||0; } my $guard = $self->result_source->schema->txn_scope_guard; # Move to end of current group to adjust siblings $self->move_last; $self->set_inflated_columns({ %$to_group, $position_column => undef }); my $new_group_last_posval = $self->_last_sibling_posval; my $new_group_last_position = $self->_position_from_value ( $new_group_last_posval ); if ( not defined($to_position) or $to_position > $new_group_last_position) { $self->set_column( $position_column => $new_group_last_position ? $self->_next_position_value ( $new_group_last_posval ) : $self->_initial_position_value ); } else { my $bumped_pos_val = $self->_position_value ($to_position); my @between = map { $self->_position_value ($_) } ($to_position, $new_group_last_position); $self->_shift_siblings (1, @between); #shift right $self->set_column( $position_column => $bumped_pos_val ); } $self->_ordered_internal_update; $guard->commit; return 1; } =head2 insert Overrides the DBIC insert() method by providing a default position number. The default will be the number of rows in the table +1, thus positioning the new record at the last position. =cut sub insert { my $self = shift; my $position_column = $self->position_column; unless ($self->get_column($position_column)) { my $lsib_posval = $self->_last_sibling_posval; $self->set_column( $position_column => (defined $lsib_posval ? $self->_next_position_value ( $lsib_posval ) : $self->_initial_position_value ) ); } return $self->next::method( @_ ); } =head2 update Overrides the DBIC update() method by checking for a change to the position and/or group columns. Movement within a group or to another group is handled by repositioning the appropriate siblings. Position defaults to the end of a new group if it has been changed to undef. =cut sub update { my $self = shift; # this is set by _ordered_internal_update() return $self->next::method(@_) if $self->result_source->schema->{_ORDERED_INTERNAL_UPDATE}; my $upd = shift; $self->set_inflated_columns($upd) if $upd; my $position_column = $self->position_column; my @group_columns = $self->_grouping_columns; # see if the order is already changed my $changed_ordering_cols = { map { $_ => $self->get_column($_) } grep { $self->is_column_changed($_) } ($position_column, @group_columns) }; # nothing changed - short circuit if (! keys %$changed_ordering_cols) { return $self->next::method( undef, @_ ); } elsif (grep { exists $changed_ordering_cols->{$_} } @group_columns ) { $self->move_to_group( # since the columns are already re-set the _grouping_clause is correct # move_to_group() knows how to get the original storage values { $self->_grouping_clause }, # The FIXME bit contradicts the documentation: POD states that # when changing groups without supplying explicit positions in # move_to_group(), we push the item to the end of the group. # However when I was rewriting this, the position from the old # group was clearly passed to the new one # Probably needs to go away (by ribasushi) (exists $changed_ordering_cols->{$position_column} ? $changed_ordering_cols->{$position_column} # means there was a position change supplied with the update too : $self->_position # FIXME! (replace with undef) ), ); } else { $self->move_to($changed_ordering_cols->{$position_column}); } return $self; } =head2 delete Overrides the DBIC delete() method by first moving the object to the last position, then deleting it, thus ensuring the integrity of the positions. =cut sub delete { my $self = shift; my $guard = $self->result_source->schema->txn_scope_guard; $self->move_last; $self->next::method( @_ ); $guard->commit; return $self; } # add the current position/group to the things we track old values for sub _track_storage_value { my ($self, $col) = @_; return ( $self->next::method($col) || grep { $_ eq $col } ($self->position_column, $self->_grouping_columns) ); } =head1 METHODS FOR EXTENDING ORDERED You would want to override the methods below if you use sparse (non-linear) or non-numeric position values. This can be useful if you are working with preexisting non-normalised position data, or if you need to work with materialized path columns. =head2 _position_from_value my $num_pos = $item->_position_from_value ( $pos_value ) Returns the B<absolute numeric position> of an object with a B<position value> set to C<$pos_value>. By default simply returns C<$pos_value>. =cut sub _position_from_value { my ($self, $val) = @_; return 0 unless defined $val; # #the right way to do this # return $self -> _group_rs # -> search({ $self->position_column => { '<=', $val } }) # -> count return $val; } =head2 _position_value my $pos_value = $item->_position_value ( $pos ) Returns the B<value> of L</position_column> of the object at numeric position C<$pos>. By default simply returns C<$pos>. =cut sub _position_value { my ($self, $pos) = @_; # #the right way to do this (not optimized) # my $position_column = $self->position_column; # return $self -> _group_rs # -> search({}, { order_by => $position_column }) # -> slice ( $pos - 1) # -> single # -> get_column ($position_column); return $pos; } =head2 _initial_position_value __PACKAGE__->_initial_position_value(0); This method specifies a B<value> of L</position_column> which is assigned to the first inserted element of a group, if no value was supplied at insertion time. All subsequent values are derived from this one by L</_next_position_value> below. Defaults to 1. =cut __PACKAGE__->mk_classdata( '_initial_position_value' => 1 ); =head2 _next_position_value my $new_value = $item->_next_position_value ( $position_value ) Returns a position B<value> that would be considered C<next> with regards to C<$position_value>. Can be pretty much anything, given that C<< $position_value < $new_value >> where C<< < >> is the SQL comparison operator (usually works fine on strings). The default method expects C<$position_value> to be numeric, and returns C<$position_value + 1> =cut sub _next_position_value { return $_[1] + 1; } =head2 _shift_siblings $item->_shift_siblings ($direction, @between) Shifts all siblings with B<positions values> in the range @between (inclusive) by one position as specified by $direction (left if < 0, right if > 0). By default simply increments/decrements each L</position_column> value by 1, doing so in a way as to not violate any existing constraints. Note that if you override this method and have unique constraints including the L</position_column> the shift is not a trivial task. Refer to the implementation source of the default method for more information. =cut sub _shift_siblings { my ($self, $direction, @between) = @_; return 0 unless $direction; my $position_column = $self->position_column; my ($op, $ord); if ($direction < 0) { $op = '-'; $ord = 'asc'; } else { $op = '+'; $ord = 'desc'; } my $shift_rs = $self->_group_rs-> search ({ $position_column => { -between => \@between } }); # some databases (sqlite, pg, perhaps others) are dumb and can not do a # blanket increment/decrement without violating a unique constraint. # So what we do here is check if the position column is part of a unique # constraint, and do a one-by-one update if this is the case. my $rsrc = $self->result_source; # set in case there are more cascades combined with $rs->update => $rs_update_all overrides local $rsrc->schema->{_ORDERED_INTERNAL_UPDATE} = 1; my @pcols = $rsrc->primary_columns; if ( grep { $_ eq $position_column } ( map { @$_ } (values %{{ $rsrc->unique_constraints }} ) ) ) { my $clean_rs = $rsrc->resultset; for ( $shift_rs->search ( {}, { order_by => { "-$ord", $position_column }, select => [$position_column, @pcols] } )->cursor->all ) { my $pos = shift @$_; $clean_rs->find(@$_)->update ({ $position_column => $pos + ( ($op eq '+') ? 1 : -1 ) }); } } else { $shift_rs->update ({ $position_column => \ "$position_column $op 1" } ); } } # This method returns a resultset containing all members of the row # group (including the row itself). sub _group_rs { my $self = shift; return $self->result_source->resultset->search({$self->_grouping_clause()}); } # Returns an unordered resultset of all objects in the same group # excluding the object you called this method on. sub _siblings { my $self = shift; my $position_column = $self->position_column; my $pos; return defined ($pos = $self->get_column($position_column)) ? $self->_group_rs->search( { $position_column => { '!=' => $pos } }, ) : $self->_group_rs ; } # Returns the B<absolute numeric position> of the current object, with the # first object being at position 1, its sibling at position 2 and so on. sub _position { my $self = shift; return $self->_position_from_value ($self->get_column ($self->position_column) ); } # This method returns one or more name=>value pairs for limiting a search # by the grouping column(s). If the grouping column is not defined then # this will return an empty list. sub _grouping_clause { my( $self ) = @_; return map { $_ => $self->get_column($_) } $self->_grouping_columns(); } # Returns a list of the column names used for grouping, regardless of whether # they were specified as an arrayref or a single string, and returns () # if there is no grouping. sub _grouping_columns { my( $self ) = @_; my $col = $self->grouping_column(); if (ref $col eq 'ARRAY') { return @$col; } elsif ($col) { return ( $col ); } else { return (); } } # Returns true if the object is in the group represented by hashref $other sub _is_in_group { my ($self, $other) = @_; my $current = {$self->_grouping_clause}; no warnings qw/uninitialized/; return 0 if ( join ("\x00", sort keys %$current) ne join ("\x00", sort keys %$other) ); for my $key (keys %$current) { return 0 if $current->{$key} ne $other->{$key}; } return 1; } # This is a short-circuited method, that is used internally by this # module to update positioning values in isolation (i.e. without # triggering any of the positioning integrity code). # # Some day you might get confronted by datasets that have ambiguous # positioning data (e.g. duplicate position values within the same group, # in a table without unique constraints). When manually fixing such data # keep in mind that you can not invoke L<DBIx::Class::Row/update> like # you normally would, as it will get confused by the wrong data before # having a chance to update the ill-defined row. If you really know what # you are doing use this method which bypasses any hooks introduced by # this module. sub _ordered_internal_update { my $self = shift; local $self->result_source->schema->{_ORDERED_INTERNAL_UPDATE} = 1; return $self->update (@_); } 1; __END__ =head1 CAVEATS =head2 Resultset Methods Note that all Insert/Create/Delete overrides are happening on L<DBIx::Class::Row> methods only. If you use the L<DBIx::Class::ResultSet> versions of L<update|DBIx::Class::ResultSet/update> or L<delete|DBIx::Class::ResultSet/delete>, all logic present in this module will be bypassed entirely (possibly resulting in a broken order-tree). Instead always use the L<update_all|DBIx::Class::ResultSet/update_all> and L<delete_all|DBIx::Class::ResultSet/delete_all> methods, which will invoke the corresponding L<row|DBIx::Class::Row> method on every member of the given resultset. =head2 Race Condition on Insert If a position is not specified for an insert, a position will be chosen based either on L</_initial_position_value> or L</_next_position_value>, depending if there are already some items in the current group. The space of time between the necessary selects and insert introduces a race condition. Having unique constraints on your position/group columns, and using transactions (see L<DBIx::Class::Storage/txn_do>) will prevent such race conditions going undetected. =head2 Multiple Moves If you have multiple same-group result objects already loaded from storage, you need to be careful when executing C<move_*> operations on them: without a L</position_column> reload the L</_position_value> of the "siblings" will be out of sync with the underlying storage. Starting from version C<0.082800> DBIC will implicitly perform such reloads when the C<move_*> happens as a part of a transaction (a good example of such situation is C<< $ordered_resultset->delete_all >>). If it is not possible for you to wrap the entire call-chain in a transaction, you will need to call L<DBIx::Class::Row/discard_changes> to get an object up-to-date before proceeding, otherwise undefined behavior will result. =head2 Default Values Using a database defined default_value on one of your group columns could result in the position not being assigned correctly. =head1 FURTHER QUESTIONS? Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>. =head1 COPYRIGHT AND LICENSE This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE> by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can redistribute it and/or modify it under the same terms as the L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>. ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/lib/DBIx/Class/ResultSourceProxy.pm���������������������������������������������0000644�0001750�0001750�00000003610�14240132261�021536� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBIx::Class::ResultSourceProxy; use strict; use warnings; use base 'DBIx::Class'; use Scalar::Util 'blessed'; use DBIx::Class::_Util 'quote_sub'; use namespace::clean; __PACKAGE__->mk_group_accessors('inherited_ro_instance' => 'source_name'); sub get_inherited_ro_instance { shift->get_inherited(@_) } sub set_inherited_ro_instance { my $self = shift; $self->throw_exception ("Cannot set @{[shift]} on an instance") if blessed $self; $self->set_inherited(@_); } sub add_columns { my ($class, @cols) = @_; my $source = $class->result_source_instance; $source->add_columns(@cols); foreach my $c (grep { !ref } @cols) { # If this is an augment definition get the real colname. $c =~ s/^\+//; $class->register_column($c => $source->column_info($c)); } } sub add_column { shift->add_columns(@_) } sub add_relationship { my ($class, $rel, @rest) = @_; my $source = $class->result_source_instance; $source->add_relationship($rel => @rest); $class->register_relationship($rel => $source->relationship_info($rel)); } # legacy resultset_class accessor, seems to be used by cdbi only sub iterator_class { shift->result_source_instance->resultset_class(@_) } for my $method_to_proxy (qw/ source_info result_class resultset_class resultset_attributes columns has_column remove_column remove_columns column_info columns_info column_info_from_storage set_primary_key primary_columns sequence add_unique_constraint add_unique_constraints unique_constraints unique_constraint_names unique_constraint_columns relationships relationship_info has_relationship /) { quote_sub __PACKAGE__."::$method_to_proxy", sprintf( <<'EOC', $method_to_proxy ); DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call; shift->result_source_instance->%s (@_); EOC } 1; ������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/lib/DBIx/Class.pm���������������������������������������������������������������0000644�0001750�0001750�00000026001�14240676342�016051� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBIx::Class; use strict; use warnings; our $VERSION; # Always remember to do all digits for the version even if they're 0 # i.e. first release of 0.XX *must* be 0.XX000. This avoids fBSD ports # brain damage and presumably various other packaging systems too # $VERSION declaration must stay up here, ahead of any other package # declarations, as to not confuse various modules attempting to determine # this ones version, whether that be s.c.o. or Module::Metadata, etc $VERSION = '0.082843'; { package DBIx::Class::_ENV_; require constant; constant->import( DEVREL => ( ($DBIx::Class::VERSION =~ /_/) ? 1 : 0 ) ); } $VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases use DBIx::Class::_Util; use mro 'c3'; use DBIx::Class::Optional::Dependencies; use base qw/DBIx::Class::Componentised DBIx::Class::AccessorGroup/; use DBIx::Class::StartupCheck; use DBIx::Class::Exception; __PACKAGE__->mk_group_accessors(inherited => '_skip_namespace_frames'); __PACKAGE__->_skip_namespace_frames('^DBIx::Class|^SQL::Abstract|^Try::Tiny|^Class::Accessor::Grouped|^Context::Preserve'); # FIXME - this is not really necessary, and is in # fact going to slow things down a bit # However it is the right thing to do in order to get # various install bases to highlight their brokenness # Remove at some unknown point in the future sub DESTROY { &DBIx::Class::_Util::detected_reinvoked_destructor } sub mk_classdata { shift->mk_classaccessor(@_); } sub mk_classaccessor { my $self = shift; $self->mk_group_accessors('inherited', $_[0]); $self->set_inherited(@_) if @_ > 1; } sub component_base_class { 'DBIx::Class' } sub MODIFY_CODE_ATTRIBUTES { my ($class,$code,@attrs) = @_; $class->mk_classdata('__attr_cache' => {}) unless $class->can('__attr_cache'); $class->__attr_cache->{$code} = [@attrs]; return (); } sub _attr_cache { my $self = shift; my $cache = $self->can('__attr_cache') ? $self->__attr_cache : {}; return { %$cache, %{ $self->maybe::next::method || {} }, }; } # *DO NOT* change this URL nor the identically named =head1 below # it is linked throughout the ecosystem sub DBIx::Class::_ENV_::HELP_URL () { 'http://p3rl.org/DBIx::Class#GETTING_HELP/SUPPORT' } 1; __END__ # This is the only file where an explicit =encoding is needed, # as the distbuild-time injected author list is utf8 encoded # Without this pod2text output is less than ideal # # A bit regarding selection/compatiblity: # Before 5.8.7 UTF-8 was == utf8, both behaving like the (lax) utf8 we know today # Then https://www.nntp.perl.org/group/perl.unicode/2004/12/msg2705.html happened # Encode way way before 5.8.0 supported UTF-8: https://metacpan.org/source/DANKOGAI/Encode-1.00/lib/Encode/Supported.pod#L44 # so it is safe for the oldest toolchains. # Additionally we inject all the utf8 programattically and test its well-formedness # so all is well # =encoding UTF-8 =head1 NAME DBIx::Class - Extensible and flexible object <-> relational mapper. =head1 WHERE TO START READING See L<DBIx::Class::Manual::DocMap> for an overview of the exhaustive documentation. To get the most out of DBIx::Class with the least confusion it is strongly recommended to read (at the very least) the L<Manuals|DBIx::Class::Manual::DocMap/Manuals> in the order presented there. =cut =head1 GETTING HELP/SUPPORT Due to the sheer size of its problem domain, DBIx::Class is a relatively complex framework. After you start using DBIx::Class questions will inevitably arise. If you are stuck with a problem or have doubts about a particular approach do not hesitate to contact us via any of the following options (the list is sorted by "fastest response time"): =over =item * RT Bug Tracker: L<https://rt.cpan.org/Public/Dist/Display.html?Name=DBIx-Class> =item * Email: L<mailto:bug-DBIx-Class@rt.cpan.org> =item * Twitter: L<https://twitter.com/intent/tweet?text=%40ribasushi%20%23DBIC> =back =head1 SYNOPSIS For the very impatient: L<DBIx::Class::Manual::QuickStart> This code in the next step can be generated automatically from an existing database, see L<dbicdump> from the distribution C<DBIx-Class-Schema-Loader>. =head2 Schema classes preparation Create a schema class called F<MyApp/Schema.pm>: package MyApp::Schema; use base qw/DBIx::Class::Schema/; __PACKAGE__->load_namespaces(); 1; Create a result class to represent artists, who have many CDs, in F<MyApp/Schema/Result/Artist.pm>: See L<DBIx::Class::ResultSource> for docs on defining result classes. package MyApp::Schema::Result::Artist; use base qw/DBIx::Class::Core/; __PACKAGE__->table('artist'); __PACKAGE__->add_columns(qw/ artistid name /); __PACKAGE__->set_primary_key('artistid'); __PACKAGE__->has_many(cds => 'MyApp::Schema::Result::CD', 'artistid'); 1; A result class to represent a CD, which belongs to an artist, in F<MyApp/Schema/Result/CD.pm>: package MyApp::Schema::Result::CD; use base qw/DBIx::Class::Core/; __PACKAGE__->load_components(qw/InflateColumn::DateTime/); __PACKAGE__->table('cd'); __PACKAGE__->add_columns(qw/ cdid artistid title year /); __PACKAGE__->set_primary_key('cdid'); __PACKAGE__->belongs_to(artist => 'MyApp::Schema::Result::Artist', 'artistid'); 1; =head2 API usage Then you can use these classes in your application's code: # Connect to your database. use MyApp::Schema; my $schema = MyApp::Schema->connect($dbi_dsn, $user, $pass, \%dbi_params); # Query for all artists and put them in an array, # or retrieve them as a result set object. # $schema->resultset returns a DBIx::Class::ResultSet my @all_artists = $schema->resultset('Artist')->all; my $all_artists_rs = $schema->resultset('Artist'); # Output all artists names # $artist here is a DBIx::Class::Row, which has accessors # for all its columns. Rows are also subclasses of your Result class. foreach $artist (@all_artists) { print $artist->name, "\n"; } # Create a result set to search for artists. # This does not query the DB. my $johns_rs = $schema->resultset('Artist')->search( # Build your WHERE using an SQL::Abstract::Classic-compatible structure: { name => { like => 'John%' } } ); # Execute a joined query to get the cds. my @all_john_cds = $johns_rs->search_related('cds')->all; # Fetch the next available row. my $first_john = $johns_rs->next; # Specify ORDER BY on the query. my $first_john_cds_by_title_rs = $first_john->cds( undef, { order_by => 'title' } ); # Create a result set that will fetch the artist data # at the same time as it fetches CDs, using only one query. my $millennium_cds_rs = $schema->resultset('CD')->search( { year => 2000 }, { prefetch => 'artist' } ); my $cd = $millennium_cds_rs->next; # SELECT ... FROM cds JOIN artists ... my $cd_artist_name = $cd->artist->name; # Already has the data so no 2nd query # new() makes a Result object but doesn't insert it into the DB. # create() is the same as new() then insert(). my $new_cd = $schema->resultset('CD')->new({ title => 'Spoon' }); $new_cd->artist($cd->artist); $new_cd->insert; # Auto-increment primary key filled in after INSERT $new_cd->title('Fork'); $schema->txn_do(sub { $new_cd->update }); # Runs the update in a transaction # change the year of all the millennium CDs at once $millennium_cds_rs->update({ year => 2002 }); =head1 DESCRIPTION This is an SQL to OO mapper with an object API inspired by L<Class::DBI> (with a compatibility layer as a springboard for porting) and a resultset API that allows abstract encapsulation of database operations. It aims to make representing queries in your code as perl-ish as possible while still providing access to as many of the capabilities of the database as possible, including retrieving related records from multiple tables in a single query, C<JOIN>, C<LEFT JOIN>, C<COUNT>, C<DISTINCT>, C<GROUP BY>, C<ORDER BY> and C<HAVING> support. DBIx::Class can handle multi-column primary and foreign keys, complex queries and database-level paging, and does its best to only query the database in order to return something you've directly asked for. If a resultset is used as an iterator it only fetches rows off the statement handle as requested in order to minimise memory usage. It has auto-increment support for SQLite, MySQL, PostgreSQL, Oracle, SQL Server and DB2 and is known to be used in production on at least the first four, and is fork- and thread-safe out of the box (although L<your DBD may not be|DBI/Threads and Thread Safety>). This project is still under rapid development, so large new features may be marked B<experimental> - such APIs are still usable but may have edge bugs. Failing test cases are I<always> welcome and point releases are put out rapidly as bugs are found and fixed. We do our best to maintain full backwards compatibility for published APIs, since DBIx::Class is used in production in many organisations, and even backwards incompatible changes to non-published APIs will be fixed if they're reported and doing so doesn't cost the codebase anything. The test suite is quite substantial, and several developer releases are generally made to CPAN before the branch for the next release is merged back to trunk for a major release. =head1 HOW TO CONTRIBUTE Contributions are always welcome, in all usable forms (we especially welcome documentation improvements). The delivery methods include git- or unified-diff formatted patches, GitHub pull requests, or plain bug reports either via RT or the Mailing list. Do not hesitate to L<get in touch|/GETTING HELP/SUPPORT> with any further questions you may have. =for comment FIXME: Getty, frew and jnap need to get off their asses and finish the contrib section so we can link it here ;) This project is maintained in a git repository. The code and related tools are accessible at the following locations: =over =item * Current git repository: L<https://github.com/Perl5/DBIx-Class> =item * Travis-CI log: L<https://travis-ci.com/github/Perl5/DBIx-Class/branches> =back =head1 AUTHORS Even though a large portion of the source I<appears> to be written by just a handful of people, this library continues to remain a collaborative effort - perhaps one of the most successful such projects on L<CPAN|http://cpan.org>. It is important to remember that ideas do not always result in a direct code contribution, but deserve acknowledgement just the same. Time and time again the seemingly most insignificant questions and suggestions have been shown to catalyze monumental improvements in consistency, accuracy and performance. =for comment this line is replaced with the author list at dist-building time The canonical source of authors and their details is the F<AUTHORS> file at the root of this distribution (or repository). The canonical source of per-line authorship is the L<git repository|/HOW TO CONTRIBUTE> history itself. =head1 COPYRIGHT AND LICENSE Copyright (c) 2005 by mst, castaway, ribasushi, and other DBIx::Class L</AUTHORS> as listed above and in F<AUTHORS>. This library is free software and may be distributed under the same terms as perl5 itself. See F<LICENSE> for the complete licensing terms. �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/lib/DBIx/Class.pod��������������������������������������������������������������0000444�0001750�0001750�00000043413�14240676412�016221� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������=encoding UTF-8 =head1 NAME DBIx::Class - Extensible and flexible object <-> relational mapper. =head1 WHERE TO START READING See L<DBIx::Class::Manual::DocMap> for an overview of the exhaustive documentation. To get the most out of DBIx::Class with the least confusion it is strongly recommended to read (at the very least) the L<Manuals|DBIx::Class::Manual::DocMap/Manuals> in the order presented there. =cut =head1 GETTING HELP/SUPPORT Due to the sheer size of its problem domain, DBIx::Class is a relatively complex framework. After you start using DBIx::Class questions will inevitably arise. If you are stuck with a problem or have doubts about a particular approach do not hesitate to contact us via any of the following options (the list is sorted by "fastest response time"): =over =item * RT Bug Tracker: L<https://rt.cpan.org/Public/Dist/Display.html?Name=DBIx-Class> =item * Email: L<mailto:bug-DBIx-Class@rt.cpan.org> =item * Twitter: L<https://twitter.com/intent/tweet?text=%40ribasushi%20%23DBIC> =back =head1 SYNOPSIS For the very impatient: L<DBIx::Class::Manual::QuickStart> This code in the next step can be generated automatically from an existing database, see L<dbicdump> from the distribution C<DBIx-Class-Schema-Loader>. =head2 Schema classes preparation Create a schema class called F<MyApp/Schema.pm>: package MyApp::Schema; use base qw/DBIx::Class::Schema/; __PACKAGE__->load_namespaces(); 1; Create a result class to represent artists, who have many CDs, in F<MyApp/Schema/Result/Artist.pm>: See L<DBIx::Class::ResultSource> for docs on defining result classes. package MyApp::Schema::Result::Artist; use base qw/DBIx::Class::Core/; __PACKAGE__->table('artist'); __PACKAGE__->add_columns(qw/ artistid name /); __PACKAGE__->set_primary_key('artistid'); __PACKAGE__->has_many(cds => 'MyApp::Schema::Result::CD', 'artistid'); 1; A result class to represent a CD, which belongs to an artist, in F<MyApp/Schema/Result/CD.pm>: package MyApp::Schema::Result::CD; use base qw/DBIx::Class::Core/; __PACKAGE__->load_components(qw/InflateColumn::DateTime/); __PACKAGE__->table('cd'); __PACKAGE__->add_columns(qw/ cdid artistid title year /); __PACKAGE__->set_primary_key('cdid'); __PACKAGE__->belongs_to(artist => 'MyApp::Schema::Result::Artist', 'artistid'); 1; =head2 API usage Then you can use these classes in your application's code: # Connect to your database. use MyApp::Schema; my $schema = MyApp::Schema->connect($dbi_dsn, $user, $pass, \%dbi_params); # Query for all artists and put them in an array, # or retrieve them as a result set object. # $schema->resultset returns a DBIx::Class::ResultSet my @all_artists = $schema->resultset('Artist')->all; my $all_artists_rs = $schema->resultset('Artist'); # Output all artists names # $artist here is a DBIx::Class::Row, which has accessors # for all its columns. Rows are also subclasses of your Result class. foreach $artist (@all_artists) { print $artist->name, "\n"; } # Create a result set to search for artists. # This does not query the DB. my $johns_rs = $schema->resultset('Artist')->search( # Build your WHERE using an SQL::Abstract::Classic-compatible structure: { name => { like => 'John%' } } ); # Execute a joined query to get the cds. my @all_john_cds = $johns_rs->search_related('cds')->all; # Fetch the next available row. my $first_john = $johns_rs->next; # Specify ORDER BY on the query. my $first_john_cds_by_title_rs = $first_john->cds( undef, { order_by => 'title' } ); # Create a result set that will fetch the artist data # at the same time as it fetches CDs, using only one query. my $millennium_cds_rs = $schema->resultset('CD')->search( { year => 2000 }, { prefetch => 'artist' } ); my $cd = $millennium_cds_rs->next; # SELECT ... FROM cds JOIN artists ... my $cd_artist_name = $cd->artist->name; # Already has the data so no 2nd query # new() makes a Result object but doesn't insert it into the DB. # create() is the same as new() then insert(). my $new_cd = $schema->resultset('CD')->new({ title => 'Spoon' }); $new_cd->artist($cd->artist); $new_cd->insert; # Auto-increment primary key filled in after INSERT $new_cd->title('Fork'); $schema->txn_do(sub { $new_cd->update }); # Runs the update in a transaction # change the year of all the millennium CDs at once $millennium_cds_rs->update({ year => 2002 }); =head1 DESCRIPTION This is an SQL to OO mapper with an object API inspired by L<Class::DBI> (with a compatibility layer as a springboard for porting) and a resultset API that allows abstract encapsulation of database operations. It aims to make representing queries in your code as perl-ish as possible while still providing access to as many of the capabilities of the database as possible, including retrieving related records from multiple tables in a single query, C<JOIN>, C<LEFT JOIN>, C<COUNT>, C<DISTINCT>, C<GROUP BY>, C<ORDER BY> and C<HAVING> support. DBIx::Class can handle multi-column primary and foreign keys, complex queries and database-level paging, and does its best to only query the database in order to return something you've directly asked for. If a resultset is used as an iterator it only fetches rows off the statement handle as requested in order to minimise memory usage. It has auto-increment support for SQLite, MySQL, PostgreSQL, Oracle, SQL Server and DB2 and is known to be used in production on at least the first four, and is fork- and thread-safe out of the box (although L<your DBD may not be|DBI/Threads and Thread Safety>). This project is still under rapid development, so large new features may be marked B<experimental> - such APIs are still usable but may have edge bugs. Failing test cases are I<always> welcome and point releases are put out rapidly as bugs are found and fixed. We do our best to maintain full backwards compatibility for published APIs, since DBIx::Class is used in production in many organisations, and even backwards incompatible changes to non-published APIs will be fixed if they're reported and doing so doesn't cost the codebase anything. The test suite is quite substantial, and several developer releases are generally made to CPAN before the branch for the next release is merged back to trunk for a major release. =head1 HOW TO CONTRIBUTE Contributions are always welcome, in all usable forms (we especially welcome documentation improvements). The delivery methods include git- or unified-diff formatted patches, GitHub pull requests, or plain bug reports either via RT or the Mailing list. Do not hesitate to L<get in touch|/GETTING HELP/SUPPORT> with any further questions you may have. =for comment FIXME: Getty, frew and jnap need to get off their asses and finish the contrib section so we can link it here ;) This project is maintained in a git repository. The code and related tools are accessible at the following locations: =over =item * Current git repository: L<https://github.com/Perl5/DBIx-Class> =item * Travis-CI log: L<https://travis-ci.com/github/Perl5/DBIx-Class/branches> =back =head1 AUTHORS Even though a large portion of the source I<appears> to be written by just a handful of people, this library continues to remain a collaborative effort - perhaps one of the most successful such projects on L<CPAN|http://cpan.org>. It is important to remember that ideas do not always result in a direct code contribution, but deserve acknowledgement just the same. Time and time again the seemingly most insignificant questions and suggestions have been shown to catalyze monumental improvements in consistency, accuracy and performance. List of the awesome contributors who made DBIC v0.082843 possible =encoding utf8 =over B<abraxxa>: Alexander Hartmaier <abraxxa@cpan.org> B<acca>: Alexander Kuznetsov <acca@cpan.org> B<acme>: Leon Brocard <acme@astray.com> B<aherzog>: Adam Herzog <adam@herzogdesigns.com> Alexander Keusch <cpan@keusch.at> B<alexrj>: Alessandro Ranellucci <aar@cpan.org> B<alnewkirk>: Al Newkirk <github@alnewkirk.com> B<Altreus>: Alastair McGowan-Douglas <alastair.mcgowan@opusvl.com> B<amiri>: Amiri Barksdale <amiribarksdale@gmail.com> B<amoore>: Andrew Moore <amoore@cpan.org> Andrew Mehta <Andrew@unitedgames.co.uk> B<andrewalker>: Andre Walker <andre@andrewalker.net> B<andyg>: Andy Grundman <andy@hybridized.org> B<ank>: Andres Kievsky <ank@ank.com.ar> B<arc>: Aaron Crane <arc@cpan.org> B<arcanez>: Justin Hunter <justin.d.hunter@gmail.com> B<ash>: Ash Berlin <ash@cpan.org> B<bert>: Norbert Csongrádi <bert@cpan.org> B<bfwg>: Colin Newell <colin.newell@gmail.com> B<blblack>: Brandon L. Black <blblack@gmail.com> B<bluefeet>: Aran Deltac <bluefeet@cpan.org> B<boghead>: Bryan Beeley <cpan@beeley.org> B<bphillips>: Brian Phillips <bphillips@cpan.org> B<brd>: Brad Davis <brd@FreeBSD.org> Brian Kirkbride <brian.kirkbride@deeperbydesign.com> B<bricas>: Brian Cassidy <bricas@cpan.org> B<brunov>: Bruno Vecchi <vecchi.b@gmail.com> B<caelum>: Rafael Kitover <rkitover@cpan.org> B<caldrin>: Maik Hentsche <maik.hentsche@amd.com> B<castaway>: Jess Robinson <castaway@desert-island.me.uk> B<chorny>: Alexandr Ciornii <alexchorny@gmail.com> B<cj>: C.J. Adams-Collier <cjcollier@cpan.org> B<claco>: Christopher H. Laco <claco@cpan.org> B<clkao>: CL Kao <clkao@clkao.org> Ctrl-O L<http://ctrlo.com/|http://ctrlo.com/> B<da5id>: David Jack Olrik <david@olrik.dk> B<dams>: Damien Krotkine <dams@cpan.org> B<dandv>: Dan Dascalescu <ddascalescu+github@gmail.com> B<dariusj>: Darius Jokilehto <dariusjokilehto@yahoo.co.uk> B<davewood>: David Schmidt <mail@davidschmidt.at> B<daxim>: Lars Dɪᴇᴄᴋᴏᴡ 迪拉斯 <daxim@cpan.org> B<dduncan>: Darren Duncan <darren@darrenduncan.net> B<debolaz>: Anders Nor Berle <berle@cpan.org> B<dew>: Dan Thomas <dan@godders.org> B<dim0xff>: Dmitry Latin <dim0xff@gmail.com> B<dkubb>: Dan Kubb <dan.kubb-cpan@onautopilot.com> B<dnm>: Justin Wheeler <jwheeler@datademons.com> B<dpetrov>: Dimitar Petrov <mitakaa@gmail.com> B<Dr^ZigMan>: Robert Stone <drzigman@drzigman.com> B<dsteinbrunner>: David Steinbrunner <dsteinbrunner@pobox.com> B<duncan_dmg>: Duncan Garland <Duncan.Garland@motortrak.com> B<dwc>: Daniel Westermann-Clark <danieltwc@cpan.org> B<dyfrgi>: Michael Leuchtenburg <michael@slashhome.org> B<edenc>: Eden Cardim <edencardim@gmail.com> Eligo L<http://eligo.co.uk/|http://eligo.co.uk/> B<ether>: Karen Etheridge <ether@cpan.org> B<evdb>: Edmund von der Burg <evdb@ecclestoad.co.uk> B<faxm0dem>: Fabien Wernli <cpan@faxm0dem.org> B<felliott>: Fitz Elliott <fitz.elliott@gmail.com> B<fgabolde>: Fabrice Gabolde <fgabolde@weborama.com> B<freetime>: Bill Moseley <moseley@hank.org> B<frew>: Arthur Axel "fREW" Schmidt <frioux@gmail.com> B<gbjk>: Gareth Kirwan <gbjk@thermeon.com> B<geotheve>: Georgina Thevenet <geotheve@gmail.com> B<Getty>: Torsten Raudssus <torsten@raudss.us> B<goraxe>: Gordon Irving <goraxe@cpan.org> B<gphat>: Cory G Watson <gphat@cpan.org> Grant Street Group L<http://www.grantstreet.com/|http://www.grantstreet.com/> B<gregoa>: Gregor Herrmann <gregoa@debian.org> B<groditi>: Guillermo Roditi <groditi@cpan.org> B<gshank>: Gerda Shank <gshank@cpan.org> B<guacamole>: Fred Steinberg <fred.steinberg@gmail.com> B<Haarg>: Graham Knop <haarg@haarg.org> B<hobbs>: Andrew Rodland <andrew@cleverdomain.org> Ian Wells <ijw@cack.org.uk> B<idn>: Ian Norton <i.norton@shadowcat.co.uk> B<ilmari>: Dagfinn Ilmari Mannsåker <ilmari@ilmari.org> B<ingy>: Ingy döt Net <ingy@ingy.net> B<initself>: Mike Baas <mike@initselftech.com> B<ironcamel>: Naveed Massjouni <naveedm9@gmail.com> B<jasonmay>: Jason May <jason.a.may@gmail.com> B<jawnsy>: Jonathan Yu <jawnsy@cpan.org> B<jegade>: Jens Gassmann <jens.gassmann@atomix.de> B<jeneric>: Eric A. Miller <emiller@cpan.org> B<jesper>: Jesper Krogh <jesper@krogh.cc> Jesse Sheidlower <jester@panix.com> B<jgoulah>: John Goulah <jgoulah@cpan.org> B<jguenther>: Justin Guenther <jguenther@cpan.org> B<jhannah>: Jay Hannah <jay@jays.net> B<jmac>: Jason McIntosh <jmac@appleseed-sc.com> B<jmmills>: Jason M. Mills <jmmills@cpan.org> B<jnapiorkowski>: John Napiorkowski <jjn1056@yahoo.com> Joe Carlson <jwcarlson@lbl.gov> B<jon>: Jon Schutz <jjschutz@cpan.org> Jordan Metzmeier <jmetzmeier@magazines.com> B<jshirley>: J. Shirley <jshirley@gmail.com> B<kaare>: Kaare Rasmussen B<kd>: Kieren Diment <diment@gmail.com> B<kentnl>: Kent Fredric <kentnl@cpan.org> B<kkane>: Kevin L. Kane <kevin.kane@gmail.com> B<konobi>: Scott McWhirter <konobi@cpan.org> B<lejeunerenard>: Sean Zellmer <sean@lejeunerenard.com> B<leont>: Leon Timmermans <fawaka@gmail.com> B<littlesavage>: Alexey Illarionov <littlesavage@orionet.ru> B<lukes>: Luke Saunders <luke.saunders@gmail.com> B<marcus>: Marcus Ramberg <mramberg@cpan.org> B<mateu>: Mateu X. Hunter <hunter@missoula.org> Matt LeBlanc <antirice@gmail.com> Matt Sickler <imMute@msk4.com> B<mattlaw>: Matt Lawrence B<mattp>: Matt Phillips <mattp@cpan.org> B<mdk>: Mark Keating <m.keating@shadowcat.co.uk> B<melo>: Pedro Melo <melo@simplicidade.org> B<metaperl>: Terrence Brannon <metaperl@gmail.com> B<michaelr>: Michael Reddick <michael.reddick@gmail.com> B<milki>: Jonathan Chu <milki@rescomp.berkeley.edu> B<minty>: Murray Walker <perl@minty.org> B<mithaldu>: Christian Walde <walde.christian@gmail.com> B<mjemmeson>: Michael Jemmeson <michael.jemmeson@gmail.com> B<mna>: Maya B<mo>: Moritz Onken <onken@netcubed.de> B<moltar>: Roman Filippov <romanf@cpan.org> B<moritz>: Moritz Lenz <moritz@faui2k3.org> B<mrf>: Mike Francis <ungrim97@gmail.com> B<mst>: Matt S. Trout <mst@shadowcat.co.uk> B<mstratman>: Mark A. Stratman <stratman@gmail.com> B<ned>: Neil de Carteret <n3dst4@gmail.com> B<nigel>: Nigel Metheringham <nigelm@cpan.org> B<ningu>: David Kamholz <dkamholz@cpan.org> B<Nniuq>: Ron "Quinn" Straight" <quinnfazigu@gmail.org> B<norbi>: Norbert Buchmuller <norbi@nix.hu> B<nothingmuch>: Yuval Kogman <nothingmuch@woobling.org> B<nuba>: Nuba Princigalli <nuba@cpan.org> B<Numa>: Dan Sully <daniel@cpan.org> B<oalders>: Olaf Alders <olaf@wundersolutions.com> Olly Betts <olly@survex.com> B<osfameron>: Hakim Cassimally <osfameron@cpan.org> B<ovid>: Curtis "Ovid" Poe <ovid@cpan.org> B<oyse>: Øystein Torget <oystein.torget@dnv.com> B<paulm>: Paul Makepeace <paulm+pause@paulm.com> B<penguin>: K J Cheetham <jamie@shadowcatsystems.co.uk> B<perigrin>: Chris Prather <chris@prather.org> Peter Siklósi <einon@einon.hu> Peter Valdemar Mørch <peter@morch.com> B<peter>: Peter Collingbourne <peter@pcc.me.uk> B<phaylon>: Robert Sedlacek <phaylon@dunkelheit.at> B<plu>: Johannes Plunien <plu@cpan.org> B<pmooney>: Paul Mooney <paul.mooney@net-a-porter.com> B<Possum>: Daniel LeWarne <possum@cpan.org> B<pplu>: Jose Luis Martinez <jlmartinez@capside.com> B<quicksilver>: Jules Bean <jules@jellybean.co.uk> B<racke>: Stefan Hornburg <racke@linuxia.de> B<rafl>: Florian Ragwitz <rafl@debian.org> B<rainboxx>: Matthias Dietrich <perl@rb.ly> B<rbo>: Robert Bohne <rbo@cpan.org> B<rbuels>: Robert Buels <rmb32@cornell.edu> B<rdj>: Ryan D Johnson <ryan@innerfence.com> B<Relequestual>: Ben Hutton <relequestual@gmail.com> B<renormalist>: Steffen Schwigon <schwigon@cpan.org> B<ribasushi>: Peter Rabbitson <ribasushi@leporine.io> B<rjbs>: Ricardo Signes <rjbs@cpan.org> Robert Krimen <rkrimen@cpan.org> Robert Olson <bob@rdolson.org> B<robkinyon>: Rob Kinyon <rkinyon@cpan.org> Roman Ardern-Corris <spam_in@3legs.com> B<ruoso>: Daniel Ruoso <daniel@ruoso.com> B<Sadrak>: Felix Antonius Wilhelm Ostmann <sadrak@cpan.org> B<sc_>: Just Another Perl Hacker B<schwern>: Michael G Schwern <mschwern@cpan.org> Scott R. Godin <webdragon.net@gmail.com> B<scotty>: Scotty Allen <scotty@scottyallen.com> B<semifor>: Marc Mims <marc@questright.com> Simon Elliott <cpan@browsing.co.uk> B<SineSwiper>: Brendan Byrd <perl@resonatorsoft.org> B<skaufman>: Samuel Kaufman <sam@socialflow.com> B<solomon>: Jared Johnson <jaredj@nmgi.com> B<spb>: Stephen Bennett <stephen@freenode.net> Squeeks <squeek@cpan.org> B<srezic>: Slaven Rezic <slaven@rezic.de> B<sszabo>: Stephan Szabo <sszabo@bigpanda.com> Stephen Peters <steve@stephenpeters.me> B<stonecolddevin>: Devin Austin <dhoss@cpan.org> B<talexb>: Alex Beamish <talexb@gmail.com> B<tamias>: Ronald J Kimball <rjk@tamias.net> B<TBSliver>: Tom Bloor <t.bloor@shadowcat.co.uk> B<teejay>: Aaron Trevena <teejay@cpan.org> B<theorbtwo>: James Mastros <james@mastros.biz> Thomas Kratz <tomk@cpan.org> B<timbunce>: Tim Bunce <tim.bunce@pobox.com> B<tinita>: Tina Mueller <cpan2@tinita.de> Todd Lipcon Tom Hukins <tom@eborcom.com> B<tommy>: Tommy Butler <tbutler.cpan.org@internetalias.net> B<tonvoon>: Ton Voon <ton.voon@opsview.com> B<triode>: Pete Gamache <gamache@cpan.org> B<typester>: Daisuke Murase <typester@cpan.org> B<uree>: Oriol Soriano <oriol.soriano@capside.com> B<uwe>: Uwe Voelker <uwe@uwevoelker.de> B<vanstyn>: Henry Van Styn <vanstyn@cpan.org> B<victori>: Victor Igumnov <victori@cpan.org> B<wdh>: Will Hawes <wdhawes@gmail.com> B<wesm>: Wes Malone <wes@mitsi.com> B<willert>: Sebastian Willert <willert@cpan.org> B<wintermute>: Toby Corkindale <tjc@cpan.org> B<wreis>: Wallace Reis <wreis@cpan.org> x86-64 <x86mail@gmail.com> B<xenoterracide>: Caleb Cushing <xenoterracide@gmail.com> B<xmikew>: Mike Wisener <xmikew@32ths.com> B<yrlnry>: Mark Jason Dominus <mjd@plover.com> B<zamolxes>: Bogdan Lucaciu <bogdan@wiz.ro> B<Zefram>: Andrew Main <zefram@fysh.org> =back The canonical source of authors and their details is the F<AUTHORS> file at the root of this distribution (or repository). The canonical source of per-line authorship is the L<git repository|/HOW TO CONTRIBUTE> history itself. =head1 COPYRIGHT AND LICENSE Copyright (c) 2005 by mst, castaway, ribasushi, and other DBIx::Class L</AUTHORS> as listed above and in F<AUTHORS>. This library is free software and may be distributed under the same terms as perl5 itself. See F<LICENSE> for the complete licensing terms. �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/lib/SQL/������������������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�014324� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/lib/SQL/Translator/�������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�016455� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/lib/SQL/Translator/Producer/����������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�020240� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/lib/SQL/Translator/Producer/DBIx/�����������������������������������������������0000755�0001750�0001750�00000000000�14240676463�021026� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/lib/SQL/Translator/Producer/DBIx/Class/�����������������������������������������0000755�0001750�0001750�00000000000�14240676463�022073� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/lib/SQL/Translator/Producer/DBIx/Class/File.pm����������������������������������0000644�0001750�0001750�00000011726�14240132261�023276� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package SQL::Translator::Producer::DBIx::Class::File; =head1 NAME SQL::Translator::Producer::DBIx::Class::File - DBIx::Class file producer =head1 SYNOPSIS use SQL::Translator; my $t = SQL::Translator->new( parser => '...', producer => 'DBIx::Class::File' ); print $translator->translate( $file ); =head1 DESCRIPTION Creates a DBIx::Class::Schema for use with DBIx::Class =head1 FURTHER QUESTIONS? Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>. =head1 COPYRIGHT AND LICENSE This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE> by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can redistribute it and/or modify it under the same terms as the L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>. =cut use strict; our ($VERSION, $DEBUG, $WARN); $VERSION = '0.1'; $DEBUG = 0 unless defined $DEBUG; use SQL::Translator::Schema::Constants; use SQL::Translator::Utils qw(header_comment); use Data::Dumper (); ## Skip all column type translation, as we want to use whatever the parser got. ## Translate parsers -> PK::Auto::Foo, however my %parser2PK = ( MySQL => 'PK::Auto::MySQL', PostgreSQL => 'PK::Auto::Pg', DB2 => 'PK::Auto::DB2', Oracle => 'PK::Auto::Oracle', ); sub produce { my ($translator) = @_; $DEBUG = $translator->debug; $WARN = $translator->show_warnings; my $no_comments = $translator->no_comments; my $add_drop_table = $translator->add_drop_table; my $schema = $translator->schema; my $output = ''; # Steal the XML producers "prefix" arg for our namespace? my $dbixschema = $translator->producer_args()->{prefix} || $schema->name || 'My::Schema'; my $pkclass = $parser2PK{$translator->parser_type} || ''; my %tt_vars = (); $tt_vars{dbixschema} = $dbixschema; $tt_vars{pkclass} = $pkclass; my $schemaoutput .= << "DATA"; package ${dbixschema}; use base 'DBIx::Class::Schema'; use strict; use warnings; DATA my %tableoutput = (); my %tableextras = (); foreach my $table ($schema->get_tables) { my $tname = $table->name; my $output .= qq{ package ${dbixschema}::${tname}; use base 'DBIx::Class'; use strict; use warnings; __PACKAGE__->load_components(qw/${pkclass} Core/); __PACKAGE__->table('${tname}'); }; my @fields = map { { $_->name => { name => $_->name, is_auto_increment => $_->is_auto_increment, is_foreign_key => $_->is_foreign_key, is_nullable => $_->is_nullable, default_value => $_->default_value, data_type => $_->data_type, size => $_->size, } } } ($table->get_fields); $output .= "\n__PACKAGE__->add_columns("; foreach my $f (@fields) { local $Data::Dumper::Terse = 1; $output .= "\n '" . (keys %$f)[0] . "' => " ; my $colinfo = Data::Dumper->Dump([values %$f], [''] # keys %$f] ); chomp($colinfo); $output .= $colinfo . ","; } $output .= "\n);\n"; my $pk = $table->primary_key; if($pk) { my @pk = map { $_->name } ($pk->fields); $output .= "__PACKAGE__->set_primary_key("; $output .= "'" . join("', '", @pk) . "');\n"; } foreach my $cont ($table->get_constraints) { # print Data::Dumper::Dumper($cont->type); if($cont->type =~ /foreign key/i) { # $output .= "\n__PACKAGE__->belongs_to('" . # $cont->fields->[0]->name . "', '" . # "${dbixschema}::" . $cont->reference_table . "');\n"; $tableextras{$table->name} .= "\n__PACKAGE__->belongs_to('" . $cont->fields->[0]->name . "', '" . "${dbixschema}::" . $cont->reference_table . "');\n"; my $other = "\n__PACKAGE__->has_many('" . "get_" . $table->name. "', '" . "${dbixschema}::" . $table->name. "', '" . $cont->fields->[0]->name . "');"; $tableextras{$cont->reference_table} .= $other; } } $tableoutput{$table->name} .= $output; } foreach my $to (keys %tableoutput) { $output .= $tableoutput{$to}; $schemaoutput .= "\n__PACKAGE__->register_class('${to}', '${dbixschema}::${to}');\n"; } foreach my $te (keys %tableextras) { $output .= "\npackage ${dbixschema}::$te;\n"; $output .= $tableextras{$te} . "\n"; # $tableoutput{$te} .= $tableextras{$te} . "\n"; } # print "$output\n"; return "${output}\n\n${schemaoutput}\n1;\n"; } ������������������������������������������DBIx-Class-0.082843/lib/SQL/Translator/Parser/������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�017711� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/lib/SQL/Translator/Parser/DBIx/�������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�020477� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/lib/SQL/Translator/Parser/DBIx/Class.pm�����������������������������������������0000644�0001750�0001750�00000045135�14240132261�022071� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package SQL::Translator::Parser::DBIx::Class; # AUTHOR: Jess Robinson # Some mistakes the fault of Matt S Trout # Others the fault of Ash Berlin use strict; use warnings; our ($DEBUG, $VERSION, @EXPORT_OK); $VERSION = '1.10'; $DEBUG = 0 unless defined $DEBUG; use Exporter; use SQL::Translator::Utils qw(debug normalize_name); use DBIx::Class::Carp qw/^SQL::Translator|^DBIx::Class|^Try::Tiny/; use DBIx::Class::Exception; use Scalar::Util 'blessed'; use Try::Tiny; use namespace::clean; use base qw(Exporter); @EXPORT_OK = qw(parse); # ------------------------------------------------------------------- # parse($tr, $data) # # setting parser_args => { add_fk_index => 0 } will prevent # the auto-generation of an index for each FK. # # Note that $data, in the case of this parser, is not useful. # We're working with DBIx::Class Schemas, not data streams. # ------------------------------------------------------------------- sub parse { my ($tr, $data) = @_; my $args = $tr->parser_args; my $dbicschema = $data || $args->{dbic_schema}; for (qw(DBIx::Class::Schema DBIx::Schema package)) { if (defined (my $s = delete $args->{$_} )) { carp_unique("Supplying a schema via ... parser_args => { '$_' => \$schema } is deprecated. Please use parser_args => { dbic_schema => \$schema } instead"); # move it from the deprecated to the proper $args slot unless ($dbicschema) { $args->{dbic_schema} = $dbicschema = $s; } } } DBIx::Class::Exception->throw('No DBIx::Class::Schema') unless ($dbicschema); if (!ref $dbicschema) { eval "require $dbicschema" or DBIx::Class::Exception->throw("Can't load $dbicschema: $@"); } if ( ref $args->{dbic_schema} and $args->{dbic_schema}->storage ) { # we have a storage-holding $schema instance in $args # we need to dissociate it from that $storage # otherwise SQLT insanity may ensue due to how some # serializing producers treat $args (crazy crazy shit) local $args->{dbic_schema}{storage}; $args->{dbic_schema} = $args->{dbic_schema}->clone; } my $schema = $tr->schema; my $table_no = 0; $schema->name( ref($dbicschema) . " v" . ($dbicschema->schema_version || '1.x')) unless ($schema->name); my @monikers = sort $dbicschema->sources; if (my $limit_sources = $args->{'sources'}) { my $ref = ref $limit_sources || ''; $dbicschema->throw_exception ("'sources' parameter must be an array or hash ref") unless( $ref eq 'ARRAY' || ref eq 'HASH' ); # limit monikers to those specified in my $sources; if ($ref eq 'ARRAY') { $sources->{$_} = 1 for (@$limit_sources); } else { $sources = $limit_sources; } @monikers = grep { $sources->{$_} } @monikers; } my(%table_monikers, %view_monikers); for my $moniker (@monikers){ my $source = $dbicschema->source($moniker); if ( $source->isa('DBIx::Class::ResultSource::Table') ) { $table_monikers{$moniker}++; } elsif( $source->isa('DBIx::Class::ResultSource::View') ){ next if $source->is_virtual; $view_monikers{$moniker}++; } } my %tables; foreach my $moniker (sort keys %table_monikers) { my $source = $dbicschema->source($moniker); my $table_name = $source->name; # FIXME - this isn't the right way to do it, but sqlt does not # support quoting properly to be signaled about this $table_name = $$table_name if ref $table_name eq 'SCALAR'; # It's possible to have multiple DBIC sources using the same table next if $tables{$table_name}; $tables{$table_name}{source} = $source; my $table = $tables{$table_name}{object} = SQL::Translator::Schema::Table->new( name => $table_name, type => 'TABLE', ); foreach my $col ($source->columns) { # assuming column_info in dbic is the same as DBI (?) # data_type is a number, column_type is text? my %colinfo = ( name => $col, size => 0, is_auto_increment => 0, is_foreign_key => 0, is_nullable => 0, %{$source->column_info($col)} ); if ($colinfo{is_nullable}) { $colinfo{default} = '' unless exists $colinfo{default}; } my $f = $table->add_field(%colinfo) || $dbicschema->throw_exception ($table->error); } my @primary = $source->primary_columns; $table->primary_key(@primary) if @primary; my %unique_constraints = $source->unique_constraints; foreach my $uniq (sort keys %unique_constraints) { if (!$source->_compare_relationship_keys($unique_constraints{$uniq}, \@primary)) { $table->add_constraint( type => 'unique', name => $uniq, fields => $unique_constraints{$uniq} ); } } my @rels = $source->relationships(); my %created_FK_rels; # global add_fk_index set in parser_args my $add_fk_index = (exists $args->{add_fk_index} && ! $args->{add_fk_index}) ? 0 : 1; REL: foreach my $rel (sort @rels) { my $rel_info = $source->relationship_info($rel); # Ignore any rel cond that isn't a straight hash next unless ref $rel_info->{cond} eq 'HASH'; my $relsource = try { $source->related_source($rel) }; unless ($relsource) { carp "Ignoring relationship '$rel' on '$moniker' - related resultsource '$rel_info->{class}' is not registered with this schema\n"; next; }; # related sources might be excluded via a {sources} filter or might be views next unless exists $table_monikers{$relsource->source_name}; my $rel_table = $relsource->name; # FIXME - this isn't the right way to do it, but sqlt does not # support quoting properly to be signaled about this $rel_table = $$rel_table if ref $rel_table eq 'SCALAR'; # Force the order of @cond to match the order of ->add_columns my $idx; my %other_columns_idx = map {'foreign.'.$_ => ++$idx } $relsource->columns; for ( keys %{$rel_info->{cond}} ) { unless (exists $other_columns_idx{$_}) { carp "Ignoring relationship '$rel' on '$moniker' - related resultsource '@{[ $relsource->source_name ]}' does not contain one of the specified columns: '$_'\n"; next REL; } } my @cond = sort { $other_columns_idx{$a} <=> $other_columns_idx{$b} } keys(%{$rel_info->{cond}}); # Get the key information, mapping off the foreign/self markers my @refkeys = map {/^\w+\.(\w+)$/} @cond; my @keys = map {$rel_info->{cond}->{$_} =~ /^\w+\.(\w+)$/} @cond; # determine if this relationship is a self.fk => foreign.pk (i.e. belongs_to) my $fk_constraint; #first it can be specified explicitly if ( exists $rel_info->{attrs}{is_foreign_key_constraint} ) { $fk_constraint = $rel_info->{attrs}{is_foreign_key_constraint}; } # it can not be multi elsif ( $rel_info->{attrs}{accessor} && $rel_info->{attrs}{accessor} eq 'multi' ) { $fk_constraint = 0; } # if indeed single, check if all self.columns are our primary keys. # this is supposed to indicate a has_one/might_have... # where's the introspection!!?? :) else { $fk_constraint = not $source->_compare_relationship_keys(\@keys, \@primary); } my ($otherrelname, $otherrelationship) = %{ $source->reverse_relationship_info($rel) }; my $cascade; for my $c (qw/delete update/) { if (exists $rel_info->{attrs}{"on_$c"}) { if ($fk_constraint) { $cascade->{$c} = $rel_info->{attrs}{"on_$c"}; } elsif ( $rel_info->{attrs}{"on_$c"} ) { carp "SQLT attribute 'on_$c' was supplied for relationship '$moniker/$rel', which does not appear to be a foreign constraint. " . "If you are sure that SQLT must generate a constraint for this relationship, add 'is_foreign_key_constraint => 1' to the attributes.\n"; } } elsif (defined $otherrelationship and $otherrelationship->{attrs}{$c eq 'update' ? 'cascade_copy' : 'cascade_delete'}) { $cascade->{$c} = 'CASCADE'; } } if($rel_table) { # Constraints are added only if applicable next unless $fk_constraint; # Make sure we don't create the same foreign key constraint twice my $key_test = join("\x00", sort @keys); next if $created_FK_rels{$rel_table}->{$key_test}; if (scalar(@keys)) { $created_FK_rels{$rel_table}->{$key_test} = 1; my $is_deferrable = $rel_info->{attrs}{is_deferrable}; # calculate dependencies: do not consider deferrable constraints and # self-references for dependency calculations if (! $is_deferrable and $rel_table ne $table_name) { $tables{$table_name}{foreign_table_deps}{$rel_table}++; } # trim schema before generating constraint/index names (my $table_abbrev = $table_name) =~ s/ ^ [^\.]+ \. //x; $table->add_constraint( type => 'foreign_key', name => join('_', $table_abbrev, 'fk', @keys), fields => \@keys, reference_fields => \@refkeys, reference_table => $rel_table, on_delete => uc ($cascade->{delete} || ''), on_update => uc ($cascade->{update} || ''), (defined $is_deferrable ? ( deferrable => $is_deferrable ) : ()), ); # global parser_args add_fk_index param can be overridden on the rel def my $add_fk_index_rel = (exists $rel_info->{attrs}{add_fk_index}) ? $rel_info->{attrs}{add_fk_index} : $add_fk_index; # Check that we do not create an index identical to the PK index # (some RDBMS croak on this, and it generally doesn't make much sense) # NOTE: we do not sort the key columns because the order of # columns is important for indexes and two indexes with the # same cols but different order are allowed and sometimes # needed next if join("\x00", @keys) eq join("\x00", @primary); if ($add_fk_index_rel) { (my $idx_name = $table_name) =~ s/ ^ [^\.]+ \. //x; my $index = $table->add_index( name => join('_', $table_abbrev, 'idx', @keys), fields => \@keys, type => 'NORMAL', ); } } } } } # attach the tables to the schema in dependency order my $dependencies = { map { $_ => _resolve_deps ($_, \%tables) } (keys %tables) }; for my $table (sort { keys %{$dependencies->{$a} || {} } <=> keys %{ $dependencies->{$b} || {} } || $a cmp $b } (keys %tables) ) { $schema->add_table ($tables{$table}{object}); $tables{$table}{source} -> _invoke_sqlt_deploy_hook( $tables{$table}{object} ); # the hook might have already removed the table if ($schema->get_table($table) && $table =~ /^ \s* \( \s* SELECT \s+/ix) { carp <<'EOW'; Custom SQL through ->name(\'( SELECT ...') is DEPRECATED, for more details see "Arbitrary SQL through a custom ResultSource" in DBIx::Class::Manual::Cookbook or http://search.cpan.org/dist/DBIx-Class/lib/DBIx/Class/Manual/Cookbook.pod EOW # remove the table as there is no way someone might want to # actually deploy this $schema->drop_table ($table); } } my %views; my @views = map { $dbicschema->source($_) } keys %view_monikers; my $view_dependencies = { map { $_ => _resolve_deps( $dbicschema->source($_), \%view_monikers ) } ( keys %view_monikers ) }; my @view_sources = sort { keys %{ $view_dependencies->{ $a->source_name } || {} } <=> keys %{ $view_dependencies->{ $b->source_name } || {} } || $a->source_name cmp $b->source_name } map { $dbicschema->source($_) } keys %view_monikers; foreach my $source (@view_sources) { my $view_name = $source->name; # FIXME - this isn't the right way to do it, but sqlt does not # support quoting properly to be signaled about this $view_name = $$view_name if ref $view_name eq 'SCALAR'; # Skip custom query sources next if ref $view_name; # Its possible to have multiple DBIC source using same table next if $views{$view_name}++; $dbicschema->throw_exception ("view $view_name is missing a view_definition") unless $source->view_definition; my $view = $schema->add_view ( name => $view_name, fields => [ $source->columns ], $source->view_definition ? ( 'sql' => $source->view_definition ) : () ) || $dbicschema->throw_exception ($schema->error); $source->_invoke_sqlt_deploy_hook($view); } if ($dbicschema->can('sqlt_deploy_hook')) { $dbicschema->sqlt_deploy_hook($schema); } return 1; } # # Quick and dirty dependency graph calculator # sub _resolve_deps { my ( $question, $answers, $seen ) = @_; my $ret = {}; $seen ||= {}; my @deps; # copy and bump all deps by one (so we can reconstruct the chain) my %seen = map { $_ => $seen->{$_} + 1 } ( keys %$seen ); if ( blessed($question) && $question->isa('DBIx::Class::ResultSource::View') ) { $seen{ $question->result_class } = 1; @deps = keys %{ $question->{deploy_depends_on} }; } else { $seen{$question} = 1; @deps = keys %{ $answers->{$question}{foreign_table_deps} }; } for my $dep (@deps) { if ( $seen->{$dep} ) { return {}; } my $next_dep; if ( blessed($question) && $question->isa('DBIx::Class::ResultSource::View') ) { no warnings 'uninitialized'; my ($next_dep_source_name) = grep { $question->schema->source($_)->result_class eq $dep && !( $question->schema->source($_) ->isa('DBIx::Class::ResultSource::Table') ) } @{ [ $question->schema->sources ] }; return {} unless $next_dep_source_name; $next_dep = $question->schema->source($next_dep_source_name); } else { $next_dep = $dep; } my $subdeps = _resolve_deps( $next_dep, $answers, \%seen ); $ret->{$_} += $subdeps->{$_} for ( keys %$subdeps ); ++$ret->{$dep}; } return $ret; } 1; =head1 NAME SQL::Translator::Parser::DBIx::Class - Create a SQL::Translator schema from a DBIx::Class::Schema instance =head1 SYNOPSIS ## Via DBIx::Class use MyApp::Schema; my $schema = MyApp::Schema->connect("dbi:SQLite:something.db"); $schema->create_ddl_dir(); ## or $schema->deploy(); ## Standalone use MyApp::Schema; use SQL::Translator; my $schema = MyApp::Schema->connect; my $trans = SQL::Translator->new ( parser => 'SQL::Translator::Parser::DBIx::Class', parser_args => { dbic_schema => $schema, add_fk_index => 0, sources => [qw/ Artist CD /], }, producer => 'SQLite', ) or die SQL::Translator->error; my $out = $trans->translate() or die $trans->error; =head1 DESCRIPTION This class requires L<SQL::Translator> installed to work. C<SQL::Translator::Parser::DBIx::Class> reads a DBIx::Class schema, interrogates the columns, and stuffs it all in an $sqlt_schema object. Its primary use is in deploying database layouts described as a set of L<DBIx::Class> classes, to a database. To do this, see L<DBIx::Class::Schema/deploy>. This can also be achieved by having DBIx::Class export the schema as a set of SQL files ready for import into your database, or passed to other machines that need to have your application installed but don't have SQL::Translator installed. To do this see L<DBIx::Class::Schema/create_ddl_dir>. =head1 PARSER OPTIONS =head2 dbic_schema The DBIx::Class schema (either an instance or a class name) to be parsed. This argument is in fact optional - instead one can supply it later at translation time as an argument to L<SQL::Translator/translate>. In other words both of the following invocations are valid and will produce conceptually identical output: my $yaml = SQL::Translator->new( parser => 'SQL::Translator::Parser::DBIx::Class', parser_args => { dbic_schema => $schema, }, producer => 'SQL::Translator::Producer::YAML', )->translate; my $yaml = SQL::Translator->new( parser => 'SQL::Translator::Parser::DBIx::Class', producer => 'SQL::Translator::Producer::YAML', )->translate(data => $schema); =head2 add_fk_index Create an index for each foreign key. Enabled by default, as having indexed foreign key columns is normally the sensible thing to do. =head2 sources =over 4 =item Arguments: \@class_names =back Limit the amount of parsed sources by supplying an explicit list of source names. =head1 SEE ALSO L<SQL::Translator>, L<DBIx::Class::Schema> =head1 FURTHER QUESTIONS? Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>. =head1 COPYRIGHT AND LICENSE This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE> by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can redistribute it and/or modify it under the same terms as the L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>. �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/������������������������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676464�013363� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/��������������������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�014130� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/�����������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�015471� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/RunMode.pm�������������������������������������������������������0000644�0001750�0001750�00000017205�14240132261�017364� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::RunMode; use strict; use warnings; BEGIN { if ($INC{'DBIx/Class.pm'}) { my ($fr, @frame) = 1; while (@frame = caller($fr++)) { last if $frame[1] !~ m|^t/lib/DBICTest|; } die __PACKAGE__ . " must be loaded before DBIx::Class (or modules using DBIx::Class) at $frame[1] line $frame[2]\n"; } if ( $ENV{DBICTEST_VERSION_WARNS_INDISCRIMINATELY} ) { my $ov = UNIVERSAL->can("VERSION"); require Carp; no warnings 'redefine'; *UNIVERSAL::VERSION = sub { Carp::carp( 'Argument "blah bleh bloh" isn\'t numeric in subroutine entry' ); &$ov; }; } # our own test suite doesn't need to see this delete $ENV{DBICDEVREL_SWAPOUT_SQLAC_WITH}; } use Path::Class qw/file dir/; use Fcntl ':DEFAULT'; use File::Spec (); use File::Temp (); use DBICTest::Util 'local_umask'; _check_author_makefile() unless $ENV{DBICTEST_NO_MAKEFILE_VERIFICATION}; # PathTools has a bug where on MSWin32 it will often return / as a tmpdir. # This is *really* stupid and the result of having our lockfiles all over # the place is also rather obnoxious. So we use our own heuristics instead # https://rt.cpan.org/Ticket/Display.html?id=76663 my $tmpdir; sub tmpdir { dir ($tmpdir ||= do { # works but not always my $dir = dir(File::Spec->tmpdir); my $reason_dir_unusable; my @parts = File::Spec->splitdir($dir); if (@parts == 2 and $parts[1] =~ /^ [ \\ \/ ]? $/x ) { $reason_dir_unusable = 'File::Spec->tmpdir returned a root directory instead of a designated ' . 'tempdir (possibly https://rt.cpan.org/Ticket/Display.html?id=76663)'; } else { # make sure we can actually create and sysopen a file in this dir local $@; my $u = local_umask(0); # match the umask we use in DBICTest(::Schema) my $tempfile = '<NONCREATABLE>'; eval { $tempfile = File::Temp->new( TEMPLATE => '_dbictest_writability_test_XXXXXX', DIR => "$dir", UNLINK => 1, ); close $tempfile or die "closing $tempfile failed: $!\n"; sysopen (my $tempfh2, "$tempfile", O_RDWR) or die "reopening $tempfile failed: $!\n"; print $tempfh2 'deadbeef' x 1024 or die "printing to $tempfile failed: $!\n"; close $tempfh2 or die "closing $tempfile failed: $!\n"; 1; } or do { chomp( my $err = $@ ); my @x_tests = map { (defined $_) ? ( $_ ? 1 : 0 ) : 'U' } map {(-e, -d, -f, -r, -w, -x, -o)} ("$dir", "$tempfile"); $reason_dir_unusable = sprintf <<"EOE", "$tempfile"||'', $err, scalar $>, scalar $), umask(), (stat($dir))[4,5,2], @x_tests; File::Spec->tmpdir returned a directory which appears to be non-writeable: Error encountered while testing '%s': %s Process EUID/EGID: %s / %s Effective umask: %o TmpDir UID/GID: %s / %s TmpDir StatMode: %o TmpDir X-tests: -e:%s -d:%s -f:%s -r:%s -w:%s -x:%s -o:%s TmpFile X-tests: -e:%s -d:%s -f:%s -r:%s -w:%s -x:%s -o:%s EOE }; } if ($reason_dir_unusable) { # Replace with our local project tmpdir. This will make multiple runs # from different runs conflict with each other, but is much better than # polluting the root dir with random crap or failing outright my $local_dir = _find_co_root()->subdir('t')->subdir('var'); $local_dir->mkpath; warn "\n\nUsing '$local_dir' as test scratch-dir instead of '$dir': $reason_dir_unusable\n"; $dir = $local_dir; } $dir->stringify; }); } # Die if the author did not update his makefile # # This is pretty heavy handed, so the check is pretty solid: # # 1) Assume that this particular module is loaded from -I <$root>/t/lib # 2) Make sure <$root>/Makefile.PL exists # 3) Make sure we can stat() <$root>/Makefile.PL # # If all of the above is satisfied # # *) die if <$root>/inc does not exist # *) die if no stat() results for <$root>/Makefile (covers no Makefile) # *) die if Makefile.PL mtime > Makefile mtime # sub _check_author_makefile { my $root = _find_co_root() or return; my $optdeps = file('lib/DBIx/Class/Optional/Dependencies.pm'); # not using file->stat as it invokes File::stat which in turn breaks stat(_) my ($mf_pl_mtime, $mf_mtime, $optdeps_mtime) = ( map { (stat ($root->file ($_)) )[9] || undef } # stat returns () on nonexistent files (qw|Makefile.PL Makefile|, $optdeps) ); return unless $mf_pl_mtime; # something went wrong during co_root detection ? my @fail_reasons; if(not -d $root->subdir ('inc')) { push @fail_reasons, "Missing ./inc directory"; } if(not $mf_mtime) { push @fail_reasons, "Missing ./Makefile"; } else { if($mf_mtime < $mf_pl_mtime) { push @fail_reasons, "./Makefile.PL is newer than ./Makefile"; } if($mf_mtime < $optdeps_mtime) { push @fail_reasons, "./$optdeps is newer than ./Makefile"; } } if (@fail_reasons) { print STDERR <<'EOE'; !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ======================== FATAL ERROR =========================== !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! We have a number of reasons to believe that this is a development checkout and that you, the user, did not run `perl Makefile.PL` before using this code. You absolutely _must_ perform this step, to ensure you have all required dependencies present. Not doing so often results in a lot of wasted time for other contributors trying to assist you with spurious "its broken!" problems. By default DBICs Makefile.PL turns all optional dependencies into *HARD REQUIREMENTS*, in order to make sure that the entire test suite is executed, and no tests are skipped due to missing modules. If you for some reason need to disable this behavior - supply the --skip_author_deps option when running perl Makefile.PL If you are seeing this message unexpectedly (i.e. you are in fact attempting a regular installation be it through CPAN or manually), please report the situation to either the mailing list or to the irc channel as described in http://search.cpan.org/dist/DBIx-Class/lib/DBIx/Class.pm#GETTING_HELP/SUPPORT The DBIC team Reasons you received this message: EOE foreach my $r (@fail_reasons) { print STDERR " * $r\n"; } print STDERR "\n\n\n"; require Time::HiRes; Time::HiRes::sleep(0.005); print STDOUT "\nBail out!\n"; exit 1; } } # Mimic $Module::Install::AUTHOR sub is_author { my $root = _find_co_root() or return undef; return ( ( not -d $root->subdir ('inc') ) or ( -e $root->subdir ('inc')->subdir ($^O eq 'VMS' ? '_author' : '.author') ) ); } sub is_smoker { return ( ($ENV{TRAVIS}||'') eq 'true' and ($ENV{TRAVIS_REPO_SLUG}||'') eq 'Perl5/DBIx-Class' ) || ( $ENV{AUTOMATED_TESTING} && ! $ENV{PERL5_CPANM_IS_RUNNING} && ! $ENV{RELEASE_TESTING} ) ; } sub is_ci { return ( ($ENV{TRAVIS}||'') eq 'true' and ($ENV{TRAVIS_REPO_SLUG}||'') =~ m|\w+/DBIx-Class$| ) } sub is_plain { return (! __PACKAGE__->is_smoker && ! __PACKAGE__->is_author && ! $ENV{RELEASE_TESTING} ) } # Try to determine the root of a checkout/untar if possible # or return undef sub _find_co_root { my @mod_parts = split /::/, (__PACKAGE__ . '.pm'); my $rel_path = join ('/', @mod_parts); # %INC stores paths with / regardless of OS return undef unless ($INC{$rel_path}); # a bit convoluted, but what we do here essentially is: # - get the file name of this particular module # - do 'cd ..' as many times as necessary to get to t/lib/../.. my $root = dir ($INC{$rel_path}); for (1 .. @mod_parts + 2) { $root = $root->parent; } return (-f $root->file ('Makefile.PL') ) ? $root : undef ; } 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/ForeignComponent/������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�020745� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/ForeignComponent/TestComp.pm�������������������������������������0000644�0001750�0001750�00000000241�13555517102�023026� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# belongs to t/05components.t package # hide from PAUSE DBICTest::ForeignComponent::TestComp; use warnings; use strict; sub foreign_test_method { 1 } 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/����������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�016671� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/Year1999CDs.pm��������������������������������������������0000644�0001750�0001750�00000001727�13555517102�021054� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::Year1999CDs; ## Used in 104view.t use warnings; use strict; use base qw/DBICTest::BaseResult/; __PACKAGE__->table_class('DBIx::Class::ResultSource::View'); __PACKAGE__->table('year1999cds'); __PACKAGE__->result_source_instance->is_virtual(1); __PACKAGE__->result_source_instance->view_definition( "SELECT cdid, artist, title, single_track FROM cd WHERE year ='1999'" ); __PACKAGE__->add_columns( 'cdid' => { data_type => 'integer', is_auto_increment => 1, }, 'artist' => { data_type => 'integer', }, 'title' => { data_type => 'varchar', size => 100, }, 'single_track' => { data_type => 'integer', is_nullable => 1, is_foreign_key => 1, }, ); __PACKAGE__->set_primary_key('cdid'); __PACKAGE__->add_unique_constraint([ qw/artist title/ ]); __PACKAGE__->belongs_to( artist => 'DBICTest::Schema::Artist' ); __PACKAGE__->has_many( tracks => 'DBICTest::Schema::Track', 'cd' ); 1; �����������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/PunctuatedColumnName.pm�����������������������������������0000644�0001750�0001750�00000001163�13555517102�023313� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::PunctuatedColumnName; use warnings; use strict; use base qw/DBICTest::BaseResult/; __PACKAGE__->table('punctuated_column_name'); __PACKAGE__->add_columns( 'id' => { data_type => 'integer', is_auto_increment => 1, }, q{foo ' bar} => { data_type => 'integer', is_nullable => 1, accessor => 'foo_bar', }, q{bar/baz} => { data_type => 'integer', is_nullable => 1, accessor => 'bar_baz', }, q{baz;quux} => { data_type => 'integer', is_nullable => 1, accessor => 'bar_quux', }, ); __PACKAGE__->set_primary_key('id'); 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/Dummy.pm��������������������������������������������������0000644�0001750�0001750�00000000734�13555517102�020316� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::Dummy; use strict; use warnings; use base qw/DBICTest::BaseResult/; __PACKAGE__->table('dummy'); __PACKAGE__->add_columns( 'id' => { data_type => 'integer', is_auto_increment => 1 }, 'gittery' => { data_type => 'varchar', size => 100, is_nullable => 1, }, ); __PACKAGE__->set_primary_key('id'); # part of a test, do not remove __PACKAGE__->sequence('bogus'); 1; ������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/Collection.pm���������������������������������������������0000644�0001750�0001750�00000001730�13555517102�021313� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::Collection; use warnings; use strict; use base qw/DBICTest::BaseResult/; __PACKAGE__->table('collection'); __PACKAGE__->add_columns( 'collectionid' => { data_type => 'integer', is_auto_increment => 1, }, 'name' => { data_type => 'varchar', size => 100, }, ); __PACKAGE__->set_primary_key('collectionid'); __PACKAGE__->has_many( collection_object => "DBICTest::Schema::CollectionObject", { "foreign.collection" => "self.collectionid" } ); __PACKAGE__->many_to_many( objects => collection_object => "object" ); __PACKAGE__->many_to_many( pointy_objects => collection_object => "object", { where => { "object.type" => "pointy" } } ); __PACKAGE__->many_to_many( round_objects => collection_object => "object", { where => { "object.type" => "round" } } ); 1; ����������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/ArtistSubclass.pm�����������������������������������������0000644�0001750�0001750�00000000255�14240132261�022156� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::ArtistSubclass; use warnings; use strict; use base 'DBICTest::Schema::Artist'; __PACKAGE__->table(__PACKAGE__->table); 1;���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/Artwork_to_Artist.pm��������������������������������������0000644�0001750�0001750�00000003315�14240132261�022671� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::Artwork_to_Artist; use warnings; use strict; use base 'DBICTest::BaseResult'; use DBICTest::Util 'check_customcond_args'; __PACKAGE__->table('artwork_to_artist'); __PACKAGE__->add_columns( 'artwork_cd_id' => { data_type => 'integer', is_foreign_key => 1, }, 'artist_id' => { data_type => 'integer', is_foreign_key => 1, }, ); __PACKAGE__->set_primary_key(qw/artwork_cd_id artist_id/); __PACKAGE__->belongs_to('artwork', 'DBICTest::Schema::Artwork', 'artwork_cd_id'); __PACKAGE__->belongs_to('artist', 'DBICTest::Schema::Artist', 'artist_id'); __PACKAGE__->belongs_to('artist_test_m2m', 'DBICTest::Schema::Artist', sub { # This is for test purposes only. A regular user does not # need to sanity check the passed-in arguments, this is what # the tests are for :) my $args = &check_customcond_args; return ( { "$args->{foreign_alias}.artistid" => { -ident => "$args->{self_alias}.artist_id" }, "$args->{foreign_alias}.rank" => { '<' => 10 }, }, $args->{self_result_object} && { "$args->{foreign_alias}.artistid" => $args->{self_result_object}->artist_id, "$args->{foreign_alias}.rank" => { '<' => 10 }, } ); } ); __PACKAGE__->belongs_to('artist_test_m2m_noopt', 'DBICTest::Schema::Artist', sub { # This is for test purposes only. A regular user does not # need to sanity check the passed-in arguments, this is what # the tests are for :) my $args = &check_customcond_args; return ( { "$args->{foreign_alias}.artistid" => { -ident => "$args->{self_alias}.artist_id" }, "$args->{foreign_alias}.rank" => { '<' => 10 }, } ); } ); 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/Encoded.pm������������������������������������������������0000644�0001750�0001750�00000001502�13555517102�020556� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::Encoded; use strict; use warnings; use base qw/DBICTest::BaseResult/; __PACKAGE__->table('encoded'); __PACKAGE__->add_columns( 'id' => { data_type => 'integer', is_auto_increment => 1 }, 'encoded' => { data_type => 'varchar', size => 100, is_nullable => 1, }, ); __PACKAGE__->set_primary_key('id'); __PACKAGE__->has_many (keyholders => 'DBICTest::Schema::Employee', 'encoded'); sub set_column { my ($self, $col, $value) = @_; if( $col eq 'encoded' ){ $value = reverse split '', $value; } $self->next::method($col, $value); } sub new { my($self, $attr, @rest) = @_; $attr->{encoded} = reverse split '', $attr->{encoded} if defined $attr->{encoded}; return $self->next::method($attr, @rest); } 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/Money.pm��������������������������������������������������0000644�0001750�0001750�00000000556�13555517102�020314� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::Money; use warnings; use strict; use base qw/DBICTest::BaseResult/; __PACKAGE__->table('money_test'); __PACKAGE__->add_columns( 'id' => { data_type => 'integer', is_auto_increment => 1, }, 'amount' => { data_type => 'money', is_nullable => 1, }, ); __PACKAGE__->set_primary_key('id'); 1; ��������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/Image.pm��������������������������������������������������0000644�0001750�0001750�00000001102�13555517102�020233� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::Image; use warnings; use strict; use base qw/DBICTest::BaseResult/; __PACKAGE__->table('images'); __PACKAGE__->add_columns( 'id' => { data_type => 'integer', is_auto_increment => 1, }, 'artwork_id' => { data_type => 'integer', is_foreign_key => 1, }, 'name' => { data_type => 'varchar', size => 100, }, 'data' => { data_type => 'blob', is_nullable => 1, }, ); __PACKAGE__->set_primary_key('id'); __PACKAGE__->belongs_to('artwork', 'DBICTest::Schema::Artwork', 'artwork_id'); 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/Year2000CDs.pm��������������������������������������������0000644�0001750�0001750�00000001061�14240132261�021000� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::Year2000CDs; use warnings; use strict; use base qw/DBICTest::Schema::CD/; __PACKAGE__->table_class('DBIx::Class::ResultSource::View'); __PACKAGE__->table('year2000cds'); # need to operate on the instance for things to work __PACKAGE__->result_source_instance->view_definition( sprintf ( 'SELECT %s FROM cd WHERE year = "2000"', join (', ', __PACKAGE__->columns), )); __PACKAGE__->belongs_to( artist => 'DBICTest::Schema::Artist' ); __PACKAGE__->has_many( tracks => 'DBICTest::Schema::Track', 'cd' ); 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/TreeLike.pm�����������������������������������������������0000644�0001750�0001750�00000001640�13555517102�020724� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::TreeLike; use warnings; use strict; use base qw/DBICTest::BaseResult/; __PACKAGE__->table('treelike'); __PACKAGE__->add_columns( 'id' => { data_type => 'integer', is_auto_increment => 1 }, 'parent' => { data_type => 'integer' , is_nullable=>1}, 'name' => { data_type => 'varchar', size => 100, }, ); __PACKAGE__->set_primary_key(qw/id/); __PACKAGE__->belongs_to('parent', 'TreeLike', { 'foreign.id' => 'self.parent' }); __PACKAGE__->has_many('children', 'TreeLike', { 'foreign.parent' => 'self.id' }); ## since this is a self referential table we need to do a post deploy hook and get ## some data in while constraints are off sub sqlt_deploy_hook { my ($self, $sqlt_table) = @_; ## We don't seem to need this anymore, but keeping it for the moment ## $sqlt_table->add_index(name => 'idx_name', fields => ['name']); } 1; ������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/FourKeys_to_TwoKeys.pm������������������������������������0000644�0001750�0001750�00000001773�13555517102�023165� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::FourKeys_to_TwoKeys; use warnings; use strict; use base qw/DBICTest::BaseResult/; __PACKAGE__->table('fourkeys_to_twokeys'); __PACKAGE__->add_columns( 'f_foo' => { data_type => 'integer' }, 'f_bar' => { data_type => 'integer' }, 'f_hello' => { data_type => 'integer' }, 'f_goodbye' => { data_type => 'integer' }, 't_artist' => { data_type => 'integer' }, 't_cd' => { data_type => 'integer' }, 'autopilot' => { data_type => 'character' }, 'pilot_sequence' => { data_type => 'integer', is_nullable => 1 }, ); __PACKAGE__->set_primary_key( qw/f_foo f_bar f_hello f_goodbye t_artist t_cd/ ); __PACKAGE__->belongs_to('fourkeys', 'DBICTest::Schema::FourKeys', { 'foreign.foo' => 'self.f_foo', 'foreign.bar' => 'self.f_bar', 'foreign.hello' => 'self.f_hello', 'foreign.goodbye' => 'self.f_goodbye', }); __PACKAGE__->belongs_to('twokeys', 'DBICTest::Schema::TwoKeys', { 'foreign.artist' => 'self.t_artist', 'foreign.cd' => 'self.t_cd', }); 1; �����DBIx-Class-0.082843/t/lib/DBICTest/Schema/EventTZPg.pm����������������������������������������������0000644�0001750�0001750�00000001532�14240132261�021035� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBICTest::Schema::EventTZPg; use strict; use warnings; use base qw/DBICTest::BaseResult/; __PACKAGE__->load_components(qw/InflateColumn::DateTime/); __PACKAGE__->table('event'); __PACKAGE__->add_columns( id => { data_type => 'integer', is_auto_increment => 1 }, starts_at => { data_type => 'datetime', timezone => "America/Chicago", locale => 'de_DE' }, created_on => { data_type => 'timestamp with time zone', timezone => "America/Chicago" }, ts_without_tz => { data_type => 'timestamp without time zone' }, ); __PACKAGE__->set_primary_key('id'); sub _datetime_parser { require DateTime::Format::Pg; DateTime::Format::Pg->new(); } # this is for a reentrancy test, the duplication from above is intentional __PACKAGE__->add_columns( ts_without_tz => { data_type => 'timestamp without time zone', inflate_datetime => 1 }, ); 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/BindType.pm�����������������������������������������������0000644�0001750�0001750�00000001073�13555517102�020736� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::BindType; use warnings; use strict; use base qw/DBICTest::BaseResult/; __PACKAGE__->table('bindtype_test'); __PACKAGE__->add_columns( 'id' => { data_type => 'integer', is_auto_increment => 1, }, 'bytea' => { data_type => 'bytea', is_nullable => 1, }, 'blob' => { data_type => 'blob', is_nullable => 1, }, 'clob' => { data_type => 'clob', is_nullable => 1, }, 'a_memo' => { data_type => 'memo', is_nullable => 1, }, ); __PACKAGE__->set_primary_key('id'); 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/Serialized.pm���������������������������������������������0000644�0001750�0001750�00000000514�13555517102�021312� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::Serialized; use warnings; use strict; use base qw/DBICTest::BaseResult/; __PACKAGE__->table('serialized'); __PACKAGE__->add_columns( 'id' => { data_type => 'integer', is_auto_increment => 1 }, 'serialized' => { data_type => 'text' }, ); __PACKAGE__->set_primary_key('id'); 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/CustomSql.pm����������������������������������������������0000644�0001750�0001750�00000000640�14240132261�021140� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::CustomSql; use warnings; use strict; use base qw/DBICTest::Schema::Artist/; __PACKAGE__->table('dummy'); __PACKAGE__->result_source_instance->name(\<<SQL); ( SELECT a.*, cd.cdid AS cdid, cd.title AS title, cd.year AS year FROM artist a JOIN cd ON cd.artist = a.artistid WHERE cd.year = ?) SQL sub sqlt_deploy_hook { $_[1]->schema->drop_table($_[1]) } 1; ������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/Employee.pm�����������������������������������������������0000644�0001750�0001750�00000002132�13555517102�020774� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::Employee; use warnings; use strict; use base qw/DBICTest::BaseResult/; __PACKAGE__->load_components(qw( Ordered )); __PACKAGE__->table('employee'); __PACKAGE__->add_columns( employee_id => { data_type => 'integer', is_auto_increment => 1 }, position => { data_type => 'integer', }, group_id => { data_type => 'integer', is_nullable => 1, }, group_id_2 => { data_type => 'integer', is_nullable => 1, }, group_id_3 => { data_type => 'integer', is_nullable => 1, }, name => { data_type => 'varchar', size => 100, is_nullable => 1, }, encoded => { data_type => 'integer', is_nullable => 1, }, ); __PACKAGE__->set_primary_key('employee_id'); __PACKAGE__->position_column('position'); # Do not add unique constraints here - different groups are used throughout # the ordered tests __PACKAGE__->belongs_to (secretkey => 'DBICTest::Schema::Encoded', 'encoded', { join_type => 'left' }); 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/ForceForeign.pm�������������������������������������������0000644�0001750�0001750�00000001550�13555517102�021570� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::ForceForeign; use warnings; use strict; use base qw/DBICTest::BaseResult/; __PACKAGE__->table('forceforeign'); __PACKAGE__->add_columns( 'artist' => { data_type => 'integer' }, 'cd' => { data_type => 'integer' }, ); __PACKAGE__->set_primary_key(qw/artist/); # Normally this would not appear as a FK constraint # since it uses the PK __PACKAGE__->might_have('artist_1', 'DBICTest::Schema::Artist', 'artistid', { is_foreign_key_constraint => 1 }, ); # Normally this would appear as a FK constraint __PACKAGE__->might_have('cd_1', 'DBICTest::Schema::CD', { 'foreign.cdid' => 'self.cd' }, { is_foreign_key_constraint => 0 }, ); # Normally this would appear as a FK constraint __PACKAGE__->belongs_to('cd_3', 'DBICTest::Schema::CD', { 'foreign.cdid' => 'self.cd' }, { is_foreign_key_constraint => 0 }, ); 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/EventTZDeprecated.pm��������������������������������������0000644�0001750�0001750�00000001203�14240132261�022522� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBICTest::Schema::EventTZDeprecated; use strict; use warnings; use base qw/DBICTest::BaseResult/; __PACKAGE__->load_components(qw/InflateColumn::DateTime/); __PACKAGE__->table('event'); __PACKAGE__->add_columns( id => { data_type => 'integer', is_auto_increment => 1 }, starts_at => { data_type => 'datetime', extra => { timezone => "America/Chicago", locale => 'de_DE' } }, created_on => { data_type => 'timestamp', extra => { timezone => "America/Chicago", floating_tz_ok => 1 } }, ); __PACKAGE__->set_primary_key('id'); sub _datetime_parser { require DateTime::Format::MySQL; DateTime::Format::MySQL->new(); } 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/Tag.pm����������������������������������������������������0000644�0001750�0001750�00000001426�13555517102�017735� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::Tag; use warnings; use strict; use base qw/DBICTest::BaseResult/; __PACKAGE__->table('tags'); __PACKAGE__->add_columns( 'tagid' => { data_type => 'integer', is_auto_increment => 1, }, 'cd' => { data_type => 'integer', }, 'tag' => { data_type => 'varchar', size => 100, }, ); __PACKAGE__->set_primary_key('tagid'); __PACKAGE__->add_unique_constraints( # do not remove, part of a test tagid_cd => [qw/ tagid cd /], tagid_cd_tag => [qw/ tagid cd tag /], ); __PACKAGE__->add_unique_constraints( # do not remove, part of a test [qw/ tagid tag /], [qw/ tagid tag cd /], ); __PACKAGE__->belongs_to( cd => 'DBICTest::Schema::CD', 'cd', { proxy => [ 'year', { cd_title => 'title' } ], }); 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/ArtistGUID.pm���������������������������������������������0000644�0001750�0001750�00000001352�13555517102�021137� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::ArtistGUID; use warnings; use strict; use base qw/DBICTest::BaseResult/; # test MSSQL uniqueidentifier type __PACKAGE__->table('artist_guid'); __PACKAGE__->add_columns( 'artistid' => { data_type => 'uniqueidentifier' # auto_nextval not necessary for PK }, 'name' => { data_type => 'varchar', size => 100, is_nullable => 1, }, rank => { data_type => 'integer', default_value => 13, }, charfield => { data_type => 'char', size => 10, is_nullable => 1, }, a_guid => { data_type => 'uniqueidentifier', auto_nextval => 1, # necessary here, because not a PK is_nullable => 1, } ); __PACKAGE__->set_primary_key('artistid'); 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/Event.pm��������������������������������������������������0000644�0001750�0001750�00000002010�13555517102�020271� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBICTest::Schema::Event; use strict; use warnings; use base qw/DBICTest::BaseResult/; __PACKAGE__->load_components(qw/InflateColumn::DateTime/); __PACKAGE__->table('event'); __PACKAGE__->add_columns( id => { data_type => 'integer', is_auto_increment => 1 }, # this MUST be 'date' for the Firebird and SQLAnywhere tests starts_at => { data_type => 'date', datetime_undef_if_invalid => 1 }, created_on => { data_type => 'timestamp' }, varchar_date => { data_type => 'varchar', size => 20, is_nullable => 1 }, varchar_datetime => { data_type => 'varchar', size => 20, is_nullable => 1 }, skip_inflation => { data_type => 'datetime', inflate_datetime => 0, is_nullable => 1 }, ts_without_tz => { data_type => 'datetime', is_nullable => 1 }, # used in EventTZPg ); __PACKAGE__->set_primary_key('id'); # Test add_columns '+colname' to augment a column definition. __PACKAGE__->add_columns( '+varchar_date' => { inflate_date => 1, }, '+varchar_datetime' => { inflate_datetime => 1, }, ); 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/ArtistUndirectedMap.pm������������������������������������0000644�0001750�0001750�00000001361�13555517102�023133� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::ArtistUndirectedMap; use warnings; use strict; use base qw/DBICTest::BaseResult/; __PACKAGE__->table('artist_undirected_map'); __PACKAGE__->add_columns( 'id1' => { data_type => 'integer' }, 'id2' => { data_type => 'integer' }, ); __PACKAGE__->set_primary_key(qw/id1 id2/); __PACKAGE__->belongs_to( 'artist1', 'DBICTest::Schema::Artist', 'id1', { on_delete => 'RESTRICT', on_update => 'CASCADE'} ); __PACKAGE__->belongs_to( 'artist2', 'DBICTest::Schema::Artist', 'id2', { on_delete => undef, on_update => undef} ); __PACKAGE__->has_many( 'mapped_artists', 'DBICTest::Schema::Artist', [ {'foreign.artistid' => 'self.id1'}, {'foreign.artistid' => 'self.id2'} ], { cascade_delete => 0 }, ); 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/SelfRef.pm������������������������������������������������0000644�0001750�0001750�00000000701�14240132261�020532� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::SelfRef; use warnings; use strict; use base qw/DBICTest::BaseResult/; __PACKAGE__->table('self_ref'); __PACKAGE__->add_columns( 'id' => { data_type => 'integer', is_auto_increment => 1, }, 'name' => { data_type => 'varchar', size => 100, }, ); __PACKAGE__->set_primary_key('id'); __PACKAGE__->has_many( aliases => 'DBICTest::Schema::SelfRefAlias' => 'self_ref' ); 1; ���������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/EventSmallDT.pm�������������������������������������������0000644�0001750�0001750�00000000617�13555517102�021525� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBICTest::Schema::EventSmallDT; use strict; use warnings; use base qw/DBICTest::BaseResult/; __PACKAGE__->load_components(qw/InflateColumn::DateTime/); __PACKAGE__->table('event_small_dt'); __PACKAGE__->add_columns( id => { data_type => 'integer', is_auto_increment => 1 }, small_dt => { data_type => 'smalldatetime', is_nullable => 1 }, ); __PACKAGE__->set_primary_key('id'); 1; �����������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/Track.pm��������������������������������������������������0000644�0001750�0001750�00000007030�14240132261�020252� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::Track; use warnings; use strict; use base 'DBICTest::BaseResult'; use DBICTest::Util 'check_customcond_args'; __PACKAGE__->load_components(qw{ +DBICTest::DeployComponent InflateColumn::DateTime Ordered }); __PACKAGE__->table('track'); __PACKAGE__->add_columns( 'trackid' => { data_type => 'integer', is_auto_increment => 1, }, 'cd' => { data_type => 'integer', }, 'position' => { data_type => 'int', accessor => 'pos', }, 'title' => { data_type => 'varchar', size => 100, }, last_updated_on => { data_type => 'datetime', accessor => 'updated_date', is_nullable => 1 }, last_updated_at => { data_type => 'datetime', is_nullable => 1 }, ); __PACKAGE__->set_primary_key('trackid'); __PACKAGE__->add_unique_constraint([ qw/cd position/ ]); __PACKAGE__->add_unique_constraint([ qw/cd title/ ]); __PACKAGE__->position_column ('position'); __PACKAGE__->grouping_column ('cd'); # the undef condition in this rel is *deliberate* # tests oddball legacy syntax __PACKAGE__->belongs_to( cd => 'DBICTest::Schema::CD', undef, { proxy => { cd_title => 'title' }, }); # custom condition coderef __PACKAGE__->belongs_to( cd_cref_cond => 'DBICTest::Schema::CD', sub { # This is for test purposes only. A regular user does not # need to sanity check the passed-in arguments, this is what # the tests are for :) my $args = &check_customcond_args; return ( { "$args->{foreign_alias}.cdid" => { -ident => "$args->{self_alias}.cd" }, }, ! $args->{self_result_object} ? () : { "$args->{foreign_alias}.cdid" => $args->{self_result_object}->get_column('cd') }, ! $args->{foreign_values} ? () : { "$args->{self_alias}.cd" => $args->{foreign_values}{cdid} }, ); } ); __PACKAGE__->belongs_to( disc => 'DBICTest::Schema::CD' => 'cd', { proxy => 'year' }); __PACKAGE__->might_have( cd_single => 'DBICTest::Schema::CD', 'single_track' ); __PACKAGE__->might_have( lyrics => 'DBICTest::Schema::Lyrics', 'track_id' ); __PACKAGE__->belongs_to( "year1999cd", "DBICTest::Schema::Year1999CDs", 'cd', { join_type => 'left' }, # the relationship is of course optional ); __PACKAGE__->belongs_to( "year2000cd", "DBICTest::Schema::Year2000CDs", 'cd', { join_type => 'left' }, ); __PACKAGE__->has_many ( next_tracks => __PACKAGE__, sub { # This is for test purposes only. A regular user does not # need to sanity check the passed-in arguments, this is what # the tests are for :) my $args = &check_customcond_args; return ( { "$args->{foreign_alias}.cd" => { -ident => "$args->{self_alias}.cd" }, "$args->{foreign_alias}.position" => { '>' => { -ident => "$args->{self_alias}.position" } }, }, $args->{self_result_object} && { "$args->{foreign_alias}.cd" => $args->{self_result_object}->get_column('cd'), "$args->{foreign_alias}.position" => { '>' => $args->{self_result_object}->pos }, } ) } ); __PACKAGE__->has_many ( deliberately_broken_all_cd_tracks => __PACKAGE__, sub { # This is for test purposes only. A regular user does not # need to sanity check the passed-in arguments, this is what # the tests are for :) my $args = &check_customcond_args; return { "$args->{foreign_alias}.cd" => "$args->{self_alias}.cd" }; } ); our $hook_cb; sub sqlt_deploy_hook { my $class = shift; $hook_cb->($class, @_) if $hook_cb; $class->next::method(@_) if $class->next::can; } 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/SequenceTest.pm�������������������������������������������0000644�0001750�0001750�00000001552�13555517102�021632� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::SequenceTest; use warnings; use strict; use base qw/DBICTest::BaseResult/; __PACKAGE__->table('sequence_test'); __PACKAGE__->source_info({ "source_info_key_A" => "source_info_value_A", "source_info_key_B" => "source_info_value_B", "source_info_key_C" => "source_info_value_C", "source_info_key_D" => "source_info_value_D", }); __PACKAGE__->add_columns( 'pkid1' => { data_type => 'integer', auto_nextval => 1, sequence => \'"pkid1_seq"', }, 'pkid2' => { data_type => 'integer', auto_nextval => 1, sequence => \'pkid2_seq', }, 'nonpkid' => { data_type => 'integer', auto_nextval => 1, sequence => 'nonpkid_seq', }, 'name' => { data_type => 'varchar', size => 100, is_nullable => 1, }, ); __PACKAGE__->set_primary_key('pkid1', 'pkid2'); 1; ������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/BooksInLibrary.pm�����������������������������������������0000644�0001750�0001750�00000001526�13560502346�022114� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::BooksInLibrary; use warnings; use strict; use base qw/DBICTest::BaseResult/; __PACKAGE__->table('books'); __PACKAGE__->add_columns( 'id' => { # part of a test (auto-retrieval of PK regardless of autoinc status) # DO NOT define #is_auto_increment => 1, data_type => 'integer', }, 'source' => { data_type => 'varchar', size => '100', }, 'owner' => { data_type => 'integer', }, 'title' => { data_type => 'varchar', size => '100', }, 'price' => { data_type => 'integer', is_nullable => 1, }, ); __PACKAGE__->set_primary_key('id'); __PACKAGE__->add_unique_constraint (['title']); __PACKAGE__->resultset_attributes({where => { source => "Library" } }); __PACKAGE__->belongs_to ( owner => 'DBICTest::Schema::Owners', 'owner' ); 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/LyricVersion.pm�������������������������������������������0000644�0001750�0001750�00000001102�13555517102�021641� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::LyricVersion; use warnings; use strict; use base qw/DBICTest::BaseResult/; __PACKAGE__->table('lyric_versions'); __PACKAGE__->add_columns( 'id' => { data_type => 'integer', is_auto_increment => 1, }, 'lyric_id' => { data_type => 'integer', is_foreign_key => 1, }, 'text' => { data_type => 'varchar', size => 100, }, ); __PACKAGE__->set_primary_key('id'); __PACKAGE__->add_unique_constraint ([qw/lyric_id text/]); __PACKAGE__->belongs_to('lyric', 'DBICTest::Schema::Lyrics', 'lyric_id'); 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/EventTZ.pm������������������������������������������������0000644�0001750�0001750�00000001176�14240132261�020552� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBICTest::Schema::EventTZ; use strict; use warnings; use base qw/DBICTest::BaseResult/; __PACKAGE__->load_components(qw/InflateColumn::DateTime/); __PACKAGE__->table('event'); __PACKAGE__->add_columns( id => { data_type => 'integer', is_auto_increment => 1 }, starts_at => { data_type => 'datetime', timezone => "America/Chicago", locale => 'de_DE', datetime_undef_if_invalid => 1 }, created_on => { data_type => 'timestamp', timezone => "America/Chicago", floating_tz_ok => 1 }, ); __PACKAGE__->set_primary_key('id'); sub _datetime_parser { require DateTime::Format::MySQL; DateTime::Format::MySQL->new(); } 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/NoPrimaryKey.pm�������������������������������������������0000644�0001750�0001750�00000000571�13555517102�021613� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::NoPrimaryKey; use warnings; use strict; use base qw/DBICTest::BaseResult/; __PACKAGE__->table('noprimarykey'); __PACKAGE__->add_columns( 'foo' => { data_type => 'integer' }, 'bar' => { data_type => 'integer' }, 'baz' => { data_type => 'integer' }, ); __PACKAGE__->add_unique_constraint(foo_bar => [ qw/foo bar/ ]); 1; ���������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/FourKeys.pm�����������������������������������������������0000644�0001750�0001750�00000001521�13555517102�020765� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::FourKeys; use warnings; use strict; use base qw/DBICTest::BaseResult/; __PACKAGE__->table('fourkeys'); __PACKAGE__->add_columns( 'foo' => { data_type => 'integer' }, 'bar' => { data_type => 'integer' }, 'hello' => { data_type => 'integer' }, 'goodbye' => { data_type => 'integer' }, 'sensors' => { data_type => 'character', size => 10 }, 'read_count' => { data_type => 'int', is_nullable => 1 }, ); __PACKAGE__->set_primary_key(qw/foo bar hello goodbye/); __PACKAGE__->has_many( 'fourkeys_to_twokeys', 'DBICTest::Schema::FourKeys_to_TwoKeys', { 'foreign.f_foo' => 'self.foo', 'foreign.f_bar' => 'self.bar', 'foreign.f_hello' => 'self.hello', 'foreign.f_goodbye' => 'self.goodbye', }); __PACKAGE__->many_to_many( 'twokeys', 'fourkeys_to_twokeys', 'twokeys', ); 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/Artist.pm�������������������������������������������������0000644�0001750�0001750�00000012506�14240132261�020460� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::Artist; use warnings; use strict; use base 'DBICTest::BaseResult'; use DBICTest::Util 'check_customcond_args'; __PACKAGE__->table('artist'); __PACKAGE__->source_info({ "source_info_key_A" => "source_info_value_A", "source_info_key_B" => "source_info_value_B", "source_info_key_C" => "source_info_value_C", }); __PACKAGE__->add_columns( 'artistid' => { data_type => 'integer', is_auto_increment => 1, }, 'name' => { data_type => 'varchar', size => 100, is_nullable => 1, }, rank => { data_type => 'integer', default_value => 13, }, charfield => { data_type => 'char', size => 10, is_nullable => 1, }, ); __PACKAGE__->set_primary_key('artistid'); __PACKAGE__->add_unique_constraint(['name']); __PACKAGE__->add_unique_constraint(artist => ['artistid']); # do not remove, part of a test __PACKAGE__->add_unique_constraint(u_nullable => [qw/charfield rank/]); __PACKAGE__->mk_classdata('field_name_for', { artistid => 'primary key', name => 'artist name', }); # the undef condition in this rel is *deliberate* # tests oddball legacy syntax __PACKAGE__->has_many( cds => 'DBICTest::Schema::CD', undef, { order_by => { -asc => 'year'} }, ); __PACKAGE__->has_many( cds_cref_cond => 'DBICTest::Schema::CD', sub { # This is for test purposes only. A regular user does not # need to sanity check the passed-in arguments, this is what # the tests are for :) my $args = &check_customcond_args; return ( { "$args->{foreign_alias}.artist" => { '=' => { -ident => "$args->{self_alias}.artistid"} }, }, $args->{self_result_object} && { "$args->{foreign_alias}.artist" => $args->{self_rowobj}->artistid, # keep old rowobj syntax as a test } ); }, ); __PACKAGE__->has_many( cds_80s => 'DBICTest::Schema::CD', sub { # This is for test purposes only. A regular user does not # need to sanity check the passed-in arguments, this is what # the tests are for :) my $args = &check_customcond_args; return ( { "$args->{foreign_alias}.artist" => { '=' => \ "$args->{self_alias}.artistid" }, "$args->{foreign_alias}.year" => { '>' => 1979, '<' => 1990 }, }, $args->{self_result_object} && { "$args->{foreign_alias}.artist" => { '=' => \[ '?', $args->{self_result_object}->artistid ] }, "$args->{foreign_alias}.year" => { '>' => 1979, '<' => 1990 }, } ); }, ); __PACKAGE__->has_many( cds_84 => 'DBICTest::Schema::CD', sub { # This is for test purposes only. A regular user does not # need to sanity check the passed-in arguments, this is what # the tests are for :) my $args = &check_customcond_args; return ( { "$args->{foreign_alias}.artist" => { -ident => "$args->{self_alias}.artistid" }, "$args->{foreign_alias}.year" => 1984, }, $args->{self_result_object} && { "$args->{foreign_alias}.artist" => $args->{self_result_object}->artistid, "$args->{foreign_alias}.year" => 1984, } ); } ); __PACKAGE__->has_many( cds_90s => 'DBICTest::Schema::CD', sub { # This is for test purposes only. A regular user does not # need to sanity check the passed-in arguments, this is what # the tests are for :) my $args = &check_customcond_args; return ( { "$args->{foreign_alias}.artist" => { -ident => "$args->{self_alias}.artistid" }, "$args->{foreign_alias}.year" => { '>' => 1989, '<' => 2000 }, } ); } ); __PACKAGE__->has_many( cds_unordered => 'DBICTest::Schema::CD' ); __PACKAGE__->has_many( cds_very_very_very_long_relationship_name => 'DBICTest::Schema::CD' ); __PACKAGE__->has_many( twokeys => 'DBICTest::Schema::TwoKeys' ); __PACKAGE__->has_many( onekeys => 'DBICTest::Schema::OneKey' ); __PACKAGE__->has_many( artist_undirected_maps => 'DBICTest::Schema::ArtistUndirectedMap', [ {'foreign.id1' => 'self.artistid'}, {'foreign.id2' => 'self.artistid'} ], { cascade_copy => 0 } # this would *so* not make sense ); __PACKAGE__->has_many( artwork_to_artist => 'DBICTest::Schema::Artwork_to_Artist' => 'artist_id' ); __PACKAGE__->many_to_many('artworks', 'artwork_to_artist', 'artwork'); __PACKAGE__->has_many( cds_without_genre => 'DBICTest::Schema::CD', sub { # This is for test purposes only. A regular user does not # need to sanity check the passed-in arguments, this is what # the tests are for :) my $args = &check_customcond_args; return ( { "$args->{foreign_alias}.artist" => { -ident => "$args->{self_alias}.artistid" }, "$args->{foreign_alias}.genreid" => undef, }, $args->{self_result_object} && { "$args->{foreign_alias}.artist" => $args->{self_result_object}->artistid, "$args->{foreign_alias}.genreid" => undef, } ), }, ); sub sqlt_deploy_hook { my ($self, $sqlt_table) = @_; if ($sqlt_table->schema->translator->producer_type =~ /SQLite$/ ) { $sqlt_table->add_index( name => 'artist_name_hookidx', fields => ['name'] ) or die $sqlt_table->error; } } sub store_column { my ($self, $name, $value) = @_; $value = 'X '.$value if ($name eq 'name' && $value && $value =~ /(X )?store_column test/); $self->next::method($name, $value); } 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/Owners.pm�������������������������������������������������0000644�0001750�0001750�00000000750�13555517102�020476� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::Owners; use warnings; use strict; use base qw/DBICTest::BaseResult/; __PACKAGE__->table('owners'); __PACKAGE__->add_columns( 'id' => { data_type => 'integer', is_auto_increment => 1, }, 'name' => { data_type => 'varchar', size => '100', }, ); __PACKAGE__->set_primary_key('id'); __PACKAGE__->add_unique_constraint(['name']); __PACKAGE__->has_many(books => "DBICTest::Schema::BooksInLibrary", "owner"); 1; ������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/ArtistSourceName.pm���������������������������������������0000644�0001750�0001750�00000000336�14240132261�022440� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::ArtistSourceName; use warnings; use strict; use base 'DBICTest::Schema::Artist'; __PACKAGE__->table(__PACKAGE__->table); __PACKAGE__->source_name('SourceNameArtists'); 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/CD_to_Producer.pm�����������������������������������������0000644�0001750�0001750�00000001263�13555517102�022054� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::CD_to_Producer; use warnings; use strict; use base qw/DBICTest::BaseResult/; __PACKAGE__->table('cd_to_producer'); __PACKAGE__->add_columns( cd => { data_type => 'integer' }, producer => { data_type => 'integer' }, attribute => { data_type => 'integer', is_nullable => 1 }, ); __PACKAGE__->set_primary_key(qw/cd producer/); # the undef condition in this rel is *deliberate* # tests oddball legacy syntax __PACKAGE__->belongs_to( 'cd', 'DBICTest::Schema::CD' ); __PACKAGE__->belongs_to( 'producer', 'DBICTest::Schema::Producer', { 'foreign.producerid' => 'self.producer' }, { on_delete => undef, on_update => undef }, ); 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/LinerNotes.pm���������������������������������������������0000644�0001750�0001750�00000000652�13555517102�021304� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::LinerNotes; use warnings; use strict; use base qw/DBICTest::BaseResult/; __PACKAGE__->table('liner_notes'); __PACKAGE__->add_columns( 'liner_id' => { data_type => 'integer', }, 'notes' => { data_type => 'varchar', size => 100, }, ); __PACKAGE__->set_primary_key('liner_id'); __PACKAGE__->belongs_to( 'cd', 'DBICTest::Schema::CD', 'liner_id' ); 1; ��������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/SelfRefAlias.pm�������������������������������������������0000644�0001750�0001750�00000000740�13555517102�021520� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::SelfRefAlias; use warnings; use strict; use base qw/DBICTest::BaseResult/; __PACKAGE__->table('self_ref_alias'); __PACKAGE__->add_columns( 'self_ref' => { data_type => 'integer', }, 'alias' => { data_type => 'integer', }, ); __PACKAGE__->set_primary_key(qw/self_ref alias/); __PACKAGE__->belongs_to( self_ref => 'DBICTest::Schema::SelfRef' ); __PACKAGE__->belongs_to( alias => 'DBICTest::Schema::SelfRef' ); 1; ��������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/TwoKeys.pm������������������������������������������������0000644�0001750�0001750�00000001464�13555517102�020631� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::TwoKeys; use warnings; use strict; use base qw/DBICTest::BaseResult/; __PACKAGE__->table('twokeys'); __PACKAGE__->add_columns( 'artist' => { data_type => 'integer' }, 'cd' => { data_type => 'integer' }, ); __PACKAGE__->set_primary_key(qw/artist cd/); __PACKAGE__->belongs_to( artist => 'DBICTest::Schema::Artist', {'foreign.artistid'=>'self.artist'}, ); __PACKAGE__->belongs_to( cd => 'DBICTest::Schema::CD', undef, { is_deferrable => 0, on_update => undef, on_delete => undef, add_fk_index => 0 } ); __PACKAGE__->has_many( 'fourkeys_to_twokeys', 'DBICTest::Schema::FourKeys_to_TwoKeys', { 'foreign.t_artist' => 'self.artist', 'foreign.t_cd' => 'self.cd', }); __PACKAGE__->many_to_many( 'fourkeys', 'fourkeys_to_twokeys', 'fourkeys', ); 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/Producer.pm�����������������������������������������������0000644�0001750�0001750�00000001126�13555517102�021002� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::Producer; use warnings; use strict; use base qw/DBICTest::BaseResult/; __PACKAGE__->table('producer'); __PACKAGE__->add_columns( 'producerid' => { data_type => 'integer', is_auto_increment => 1 }, 'name' => { data_type => 'varchar', size => 100, }, ); __PACKAGE__->set_primary_key('producerid'); __PACKAGE__->add_unique_constraint(prod_name => [ qw/name/ ]); __PACKAGE__->has_many( producer_to_cd => 'DBICTest::Schema::CD_to_Producer' => 'producer' ); __PACKAGE__->many_to_many('cds', 'producer_to_cd', 'cd'); 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/CollectionObject.pm���������������������������������������0000644�0001750�0001750�00000001261�13555517102�022441� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::CollectionObject; use warnings; use strict; use base qw/DBICTest::BaseResult/; __PACKAGE__->table('collection_object'); __PACKAGE__->add_columns( 'collection' => { data_type => 'integer', }, 'object' => { data_type => 'integer', }, ); __PACKAGE__->set_primary_key(qw/collection object/); __PACKAGE__->belongs_to( collection => "DBICTest::Schema::Collection", { "foreign.collectionid" => "self.collection" } ); __PACKAGE__->belongs_to( object => "DBICTest::Schema::TypedObject", { "foreign.objectid" => "self.object" } ); 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/Lyrics.pm�������������������������������������������������0000644�0001750�0001750�00000001232�13555517102�020462� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::Lyrics; use warnings; use strict; use base qw/DBICTest::BaseResult/; __PACKAGE__->table('lyrics'); __PACKAGE__->add_columns( 'lyric_id' => { data_type => 'integer', is_auto_increment => 1, }, 'track_id' => { data_type => 'integer', is_foreign_key => 1, }, ); __PACKAGE__->set_primary_key('lyric_id'); __PACKAGE__->belongs_to('track', 'DBICTest::Schema::Track', 'track_id'); __PACKAGE__->has_many('lyric_versions', 'DBICTest::Schema::LyricVersion', 'lyric_id'); __PACKAGE__->has_many('existing_lyric_versions', 'DBICTest::Schema::LyricVersion', 'lyric_id', { join_type => 'inner', }); 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/TwoKeyTreeLike.pm�����������������������������������������0000644�0001750�0001750�00000001276�13555517102�022074� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::TwoKeyTreeLike; use warnings; use strict; use base qw/DBICTest::BaseResult/; __PACKAGE__->table('twokeytreelike'); __PACKAGE__->add_columns( 'id1' => { data_type => 'integer' }, 'id2' => { data_type => 'integer' }, 'parent1' => { data_type => 'integer' }, 'parent2' => { data_type => 'integer' }, 'name' => { data_type => 'varchar', size => 100, }, ); __PACKAGE__->set_primary_key(qw/id1 id2/); __PACKAGE__->add_unique_constraint('tktlnameunique' => ['name']); __PACKAGE__->belongs_to('parent', 'DBICTest::Schema::TwoKeyTreeLike', { 'foreign.id1' => 'self.parent1', 'foreign.id2' => 'self.parent2'}); 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/ComputedColumn.pm�����������������������������������������0000644�0001750�0001750�00000001236�13555517102�022157� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::ComputedColumn; # for sybase and mssql computed column tests use warnings; use strict; use base qw/DBICTest::BaseResult/; __PACKAGE__->table('computed_column_test'); __PACKAGE__->add_columns( 'id' => { data_type => 'integer', is_auto_increment => 1, }, 'a_computed_column' => { data_type => undef, is_nullable => 0, default_value => \'getdate()', }, 'a_timestamp' => { data_type => 'timestamp', is_nullable => 0, }, 'charfield' => { data_type => 'varchar', size => 20, default_value => 'foo', is_nullable => 0, } ); __PACKAGE__->set_primary_key('id'); 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/OneKey.pm�������������������������������������������������0000644�0001750�0001750�00000000603�13555517102�020410� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::OneKey; use warnings; use strict; use base qw/DBICTest::BaseResult/; __PACKAGE__->table('onekey'); __PACKAGE__->add_columns( 'id' => { data_type => 'integer', is_auto_increment => 1, }, 'artist' => { data_type => 'integer', }, 'cd' => { data_type => 'integer', }, ); __PACKAGE__->set_primary_key('id'); 1; �����������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/Genre.pm��������������������������������������������������0000644�0001750�0001750�00000001055�13555517102�020260� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBICTest::Schema::Genre; use warnings; use strict; use base qw/DBICTest::BaseResult/; __PACKAGE__->table('genre'); __PACKAGE__->add_columns( genreid => { data_type => 'integer', is_auto_increment => 1, }, name => { data_type => 'varchar', size => 100, }, ); __PACKAGE__->set_primary_key('genreid'); __PACKAGE__->add_unique_constraint ( genre_name => [qw/name/] ); __PACKAGE__->has_many (cds => 'DBICTest::Schema::CD', 'genreid'); __PACKAGE__->has_one (model_cd => 'DBICTest::Schema::CD', 'genreid'); 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/Link.pm���������������������������������������������������0000644�0001750�0001750�00000001240�13555517102�020111� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::Link; use strict; use warnings; use base qw/DBICTest::BaseResult/; __PACKAGE__->table('link'); __PACKAGE__->add_columns( 'id' => { data_type => 'integer', is_auto_increment => 1 }, 'url' => { data_type => 'varchar', size => 100, is_nullable => 1, }, 'title' => { data_type => 'varchar', size => 100, is_nullable => 1, }, ); __PACKAGE__->set_primary_key('id'); __PACKAGE__->has_many ( bookmarks => 'DBICTest::Schema::Bookmark', 'link', { cascade_delete => 0 } ); use overload '""' => sub { shift->url }, fallback=> 1; 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/CD.pm�����������������������������������������������������0000644�0001750�0001750�00000010751�13555517102�017511� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::CD; use warnings; use strict; use base 'DBICTest::BaseResult'; use DBICTest::Util 'check_customcond_args'; # this tests table name as scalar ref # DO NOT REMOVE THE \ __PACKAGE__->table(\'cd'); __PACKAGE__->add_columns( 'cdid' => { data_type => 'integer', is_auto_increment => 1, }, 'artist' => { data_type => 'integer', }, 'title' => { data_type => 'varchar', size => 100, }, 'year' => { data_type => 'varchar', size => 100, }, 'genreid' => { data_type => 'integer', is_nullable => 1, accessor => undef, }, 'single_track' => { data_type => 'integer', is_nullable => 1, is_foreign_key => 1, } ); __PACKAGE__->set_primary_key('cdid'); __PACKAGE__->add_unique_constraint([ qw/artist title/ ]); __PACKAGE__->belongs_to( artist => 'DBICTest::Schema::Artist', undef, { is_deferrable => 1, proxy => { artist_name => 'name' }, }); __PACKAGE__->belongs_to( very_long_artist_relationship => 'DBICTest::Schema::Artist', 'artist', { is_deferrable => 1, }); # in case this is a single-cd it promotes a track from another cd __PACKAGE__->belongs_to( single_track => 'DBICTest::Schema::Track', { 'foreign.trackid' => 'self.single_track' }, { join_type => 'left'}, ); __PACKAGE__->belongs_to( single_track_opaque => 'DBICTest::Schema::Track', sub { my $args = &check_customcond_args; \ " $args->{foreign_alias}.trackid = $args->{self_alias}.single_track "; }, { join_type => 'left'}, ); # add a non-left single relationship for the complex prefetch tests __PACKAGE__->belongs_to( existing_single_track => 'DBICTest::Schema::Track', { 'foreign.trackid' => 'self.single_track' }, ); __PACKAGE__->has_many( tracks => 'DBICTest::Schema::Track' ); __PACKAGE__->has_many( tags => 'DBICTest::Schema::Tag', undef, { order_by => 'tag' }, ); __PACKAGE__->has_many( cd_to_producer => 'DBICTest::Schema::CD_to_Producer' => 'cd' ); __PACKAGE__->has_many( twokeys => 'DBICTest::Schema::TwoKeys', 'cd' ); # the undef condition in this rel is *deliberate* # tests oddball legacy syntax __PACKAGE__->might_have( liner_notes => 'DBICTest::Schema::LinerNotes', undef, { proxy => [ qw/notes/ ] }, ); __PACKAGE__->might_have(artwork => 'DBICTest::Schema::Artwork', 'cd_id'); __PACKAGE__->has_one(mandatory_artwork => 'DBICTest::Schema::Artwork', 'cd_id'); __PACKAGE__->many_to_many( producers => cd_to_producer => 'producer' ); __PACKAGE__->many_to_many( producers_sorted => cd_to_producer => 'producer', { order_by => 'producer.name' }, ); __PACKAGE__->belongs_to('genre', 'DBICTest::Schema::Genre', 'genreid', { join_type => 'left', on_delete => 'SET NULL', on_update => 'CASCADE', }, ); #This second relationship was added to test the short-circuiting of pointless #queries provided by undef_on_null_fk. the relevant test in 66relationship.t __PACKAGE__->belongs_to('genre_inefficient', 'DBICTest::Schema::Genre', { 'foreign.genreid' => 'self.genreid' }, { join_type => 'left', on_delete => 'SET NULL', on_update => 'CASCADE', undef_on_null_fk => 0, }, ); # This is insane. Don't ever do anything like that # This is for testing purposes only! # mst: mo: DBIC is an "object relational mapper" # mst: mo: not an "object relational hider-because-mo-doesn't-understand-databases # ribasushi: mo: try it with a subselect nevertheless, I'd love to be proven wrong # ribasushi: mo: does sqlite actually take this? # ribasushi: an order in a correlated subquery is insane - how long does it take you on real data? __PACKAGE__->might_have( 'last_track', 'DBICTest::Schema::Track', sub { # This is for test purposes only. A regular user does not # need to sanity check the passed-in arguments, this is what # the tests are for :) my $args = &check_customcond_args; return ( { "$args->{foreign_alias}.trackid" => { '=' => $args->{self_resultsource}->schema->resultset('Track')->search( { 'correlated_tracks.cd' => { -ident => "$args->{self_alias}.cdid" } }, { order_by => { -desc => 'position' }, rows => 1, alias => 'correlated_tracks', columns => ['trackid'] }, )->as_query } } ); }, ); 1; �����������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/Artwork.pm������������������������������������������������0000644�0001750�0001750�00000003013�14240132261�020634� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::Artwork; use warnings; use strict; use base 'DBICTest::BaseResult'; use DBICTest::Util 'check_customcond_args'; __PACKAGE__->table('cd_artwork'); __PACKAGE__->add_columns( 'cd_id' => { data_type => 'integer', is_nullable => 0, }, ); __PACKAGE__->set_primary_key('cd_id'); __PACKAGE__->belongs_to('cd', 'DBICTest::Schema::CD', 'cd_id'); __PACKAGE__->has_many('images', 'DBICTest::Schema::Image', 'artwork_id'); __PACKAGE__->has_many('artwork_to_artist', 'DBICTest::Schema::Artwork_to_Artist', 'artwork_cd_id'); __PACKAGE__->many_to_many('artists', 'artwork_to_artist', 'artist'); # both to test manytomany with custom rel __PACKAGE__->many_to_many('artists_test_m2m', 'artwork_to_artist', 'artist_test_m2m'); __PACKAGE__->many_to_many('artists_test_m2m_noopt', 'artwork_to_artist', 'artist_test_m2m_noopt'); # other test to manytomany __PACKAGE__->has_many('artwork_to_artist_test_m2m', 'DBICTest::Schema::Artwork_to_Artist', sub { # This is for test purposes only. A regular user does not # need to sanity check the passed-in arguments, this is what # the tests are for :) my $args = &check_customcond_args; return ( { "$args->{foreign_alias}.artwork_cd_id" => { -ident => "$args->{self_alias}.cd_id" }, }, $args->{self_result_object} && { "$args->{foreign_alias}.artwork_cd_id" => $args->{self_result_object}->cd_id, } ); } ); __PACKAGE__->many_to_many('artists_test_m2m2', 'artwork_to_artist_test_m2m', 'artist'); 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/Bookmark.pm�����������������������������������������������0000644�0001750�0001750�00000001234�13555517102�020764� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::Bookmark; use strict; use warnings; use base qw/DBICTest::BaseResult/; __PACKAGE__->table('bookmark'); __PACKAGE__->add_columns( 'id' => { data_type => 'integer', is_auto_increment => 1 }, 'link' => { data_type => 'integer', is_nullable => 1, }, ); __PACKAGE__->set_primary_key('id'); require DBICTest::Schema::Link; # so we can get a columnlist __PACKAGE__->belongs_to( link => 'DBICTest::Schema::Link', 'link', { on_delete => 'SET NULL', join_type => 'LEFT', proxy => { map { join('_', 'link', $_) => $_ } DBICTest::Schema::Link->columns }, }); 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/VaryingMAX.pm���������������������������������������������0000644�0001750�0001750�00000001242�13555517102�021203� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::VaryingMAX; use warnings; use strict; use base qw/DBICTest::BaseResult/; # Test VARCHAR(MAX) type for MSSQL (used in ADO tests) __PACKAGE__->table('varying_max_test'); __PACKAGE__->add_columns( 'id' => { data_type => 'integer', is_auto_increment => 1, }, 'varchar_max' => { data_type => 'varchar', size => 'max', is_nullable => 1, }, 'nvarchar_max' => { data_type => 'nvarchar', size => 'max', is_nullable => 1, }, 'varbinary_max' => { data_type => 'varbinary(max)', # alternately size => undef, is_nullable => 1, }, ); __PACKAGE__->set_primary_key('id'); 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/TypedObject.pm��������������������������������������������0000644�0001750�0001750�00000001301�13555517102�021426� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::TypedObject; use warnings; use strict; use base qw/DBICTest::BaseResult/; __PACKAGE__->table('typed_object'); __PACKAGE__->add_columns( 'objectid' => { data_type => 'integer', is_auto_increment => 1, }, 'type' => { data_type => 'varchar', size => '100', }, 'value' => { data_type => 'varchar', size => 100, }, ); __PACKAGE__->set_primary_key('objectid'); __PACKAGE__->has_many( collection_object => "DBICTest::Schema::CollectionObject", { "foreign.object" => "self.objectid" } ); __PACKAGE__->many_to_many( collections => collection_object => "collection" ); 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/TimestampPrimaryKey.pm������������������������������������0000644�0001750�0001750�00000000565�13560502346�023205� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema::TimestampPrimaryKey; use warnings; use strict; use base qw/DBICTest::BaseResult/; __PACKAGE__->table('timestamp_primary_key_test'); __PACKAGE__->add_columns( 'id' => { data_type => 'timestamp', default_value => \'current_timestamp', retrieve_on_insert => 1, }, ); __PACKAGE__->set_primary_key('id'); 1; �������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema/NoSuchClass.pm��������������������������������������������0000644�0001750�0001750�00000000224�13555517102�021402� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBICTest::Schema::NoSuchClass; use warnings; use strict; ## This is purposefully not a real DBIC class ## Used in t/102load_classes.t 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/DynamicForeignCols/����������������������������������������������0000755�0001750�0001750�00000000000�14240676463�021210� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/DynamicForeignCols/Computer.pm�����������������������������������0000644�0001750�0001750�00000000502�13555517102�023331� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBICTest::DynamicForeignCols::Computer; use warnings; use strict; use base 'DBIx::Class::Core'; __PACKAGE__->table('Computers'); __PACKAGE__->add_columns('id'); __PACKAGE__->set_primary_key('id'); __PACKAGE__->has_many(computer_test_links => 'DBICTest::DynamicForeignCols::TestComputer', 'computer_id'); 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/DynamicForeignCols/TestComputer.pm�������������������������������0000644�0001750�0001750�00000001730�13555517102�024175� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBICTest::DynamicForeignCols::TestComputer; use warnings; use strict; use base 'DBIx::Class::Core'; __PACKAGE__->table('TestComputer'); __PACKAGE__->add_columns(qw( test_id )); __PACKAGE__->_add_join_column({ class => 'DBICTest::DynamicForeignCols::Computer', method => 'computer' }); __PACKAGE__->set_primary_key('test_id', 'computer_id'); __PACKAGE__->belongs_to(computer => 'DBICTest::DynamicForeignCols::Computer', 'computer_id'); ### ### This is a pathological case lifted from production. Yes, there is code ### like this in the wild ### sub _add_join_column { my ($self, $params) = @_; my $class = $params->{class}; my $method = $params->{method}; $self->ensure_class_loaded($class); my @class_columns = $class->primary_columns; if (@class_columns = 1) { $self->add_columns( "${method}_id" ); } else { my $i = 0; for (@class_columns) { $i++; $self->add_columns( "${method}_${i}_id" ); } } } 1; ����������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/SyntaxErrorComponent2.pm�����������������������������������������0000644�0001750�0001750�00000000247�13555517102�022267� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# belongs to t/run/90ensure_class_loaded.tl package # hide from PAUSE DBICTest::SyntaxErrorComponent2; use warnings; use strict; my $str ''; # syntax error 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/DeployComponent.pm�����������������������������������������������0000644�0001750�0001750�00000000407�14240132261�021126� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# belongs to t/86sqlt.t package # hide from PAUSE DBICTest::DeployComponent; use warnings; use strict; our $hook_cb; sub sqlt_deploy_hook { my $class = shift; $hook_cb->($class, @_) if $hook_cb; $class->next::method(@_) if $class->next::can; } 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Util/������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�016406� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Util/LeakTracer.pm�����������������������������������������������0000644�0001750�0001750�00000025127�14240132261�020747� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBICTest::Util::LeakTracer; use warnings; use strict; use Carp; use Scalar::Util qw(isweak weaken blessed reftype); use DBIx::Class::_Util qw(refcount hrefaddr refdesc); use DBIx::Class::Optional::Dependencies; use Data::Dumper::Concise; use DBICTest::Util qw( stacktrace visit_namespaces ); use constant { CV_TRACING => !DBICTest::RunMode->is_plain && DBIx::Class::Optional::Dependencies->req_ok_for ('test_leaks_heavy'), SKIP_SCALAR_REFS => ( "$]" < 5.008004 ), }; use base 'Exporter'; our @EXPORT_OK = qw(populate_weakregistry assert_empty_weakregistry visit_refs); my $refs_traced = 0; my $leaks_found = 0; my %reg_of_regs; sub populate_weakregistry { my ($weak_registry, $target, $note) = @_; croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH'; croak 'Target is not a reference' unless length ref $target; my $refaddr = hrefaddr $target; # a registry could be fed to itself or another registry via recursive sweeps return $target if $reg_of_regs{$refaddr}; return $target if SKIP_SCALAR_REFS and reftype($target) eq 'SCALAR'; weaken( $reg_of_regs{ hrefaddr($weak_registry) } = $weak_registry ) unless( $reg_of_regs{ hrefaddr($weak_registry) } ); # an explicit "garbage collection" pass every time we store a ref # if we do not do this the registry will keep growing appearing # as if the traced program is continuously slowly leaking memory for my $reg (values %reg_of_regs) { (defined $reg->{$_}{weakref}) or delete $reg->{$_} for keys %$reg; } if (! defined $weak_registry->{$refaddr}{weakref}) { $weak_registry->{$refaddr} = { stacktrace => stacktrace(1), weakref => $target, }; weaken( $weak_registry->{$refaddr}{weakref} ); $refs_traced++; } my $desc = refdesc $target; $weak_registry->{$refaddr}{slot_names}{$desc} = 1; if ($note) { $note =~ s/\s*\Q$desc\E\s*//g; $weak_registry->{$refaddr}{slot_names}{$note} = 1; } $target; } # Regenerate the slots names on a thread spawn sub CLONE { my @individual_regs = grep { scalar keys %{$_||{}} } values %reg_of_regs; %reg_of_regs = (); for my $reg (@individual_regs) { my @live_slots = grep { defined $_->{weakref} } values %$reg or next; $reg = {}; # get a fresh hashref in the new thread ctx weaken( $reg_of_regs{hrefaddr($reg)} = $reg ); for my $slot_info (@live_slots) { my $new_addr = hrefaddr $slot_info->{weakref}; # replace all slot names $slot_info->{slot_names} = { map { my $name = $_; $name =~ s/\(0x[0-9A-F]+\)/sprintf ('(%s)', $new_addr)/ieg; ($name => 1); } keys %{$slot_info->{slot_names}} }; $reg->{$new_addr} = $slot_info; } } } sub visit_refs { my $args = { (ref $_[0]) ? %{$_[0]} : @_ }; $args->{seen_refs} ||= {}; my $visited_cnt = '0E0'; for my $i (0 .. $#{$args->{refs}} ) { next unless length ref $args->{refs}[$i]; # not-a-ref my $addr = hrefaddr $args->{refs}[$i]; # no diving into weakregistries next if $reg_of_regs{$addr}; next if $args->{seen_refs}{$addr}++; $visited_cnt++; my $r = $args->{refs}[$i]; $args->{action}->($r) or next; # This may end up being necessarry some day, but do not slow things # down for now #if ( defined( my $t = tied($r) ) ) { # $visited_cnt += visit_refs({ %$args, refs => [ $t ] }); #} my $type = reftype $r; local $@; eval { if ($type eq 'HASH') { $visited_cnt += visit_refs({ %$args, refs => [ map { ( !isweak($r->{$_}) ) ? $r->{$_} : () } keys %$r ] }); } elsif ($type eq 'ARRAY') { $visited_cnt += visit_refs({ %$args, refs => [ map { ( !isweak($r->[$_]) ) ? $r->[$_] : () } 0..$#$r ] }); } elsif ($type eq 'REF' and !isweak($$r)) { $visited_cnt += visit_refs({ %$args, refs => [ $$r ] }); } elsif (CV_TRACING and $type eq 'CODE') { $visited_cnt += visit_refs({ %$args, refs => [ map { ( !isweak($_) ) ? $_ : () } values %{ scalar PadWalker::closed_over($r) } ] }); # scalar due to RT#92269 } 1; } or warn "Could not descend into @{[ refdesc $r ]}: $@\n"; } $visited_cnt; } # compiles a list of addresses stored as globals (possibly even catching # class data in the form of method closures), so we can skip them further on sub symtable_referenced_addresses { my $refs_per_pkg; my $seen_refs = {}; visit_namespaces( action => sub { no strict 'refs'; my $pkg = shift; # the unless regex at the end skips some dangerous namespaces outright # (but does not prevent descent) $refs_per_pkg->{$pkg} += visit_refs ( seen_refs => $seen_refs, action => sub { 1 }, refs => [ map { my $sym = $_; # *{"${pkg}::$sym"}{CODE} won't simply work - MRO-cached CVs are invisible there ( CV_TRACING ? Class::MethodCache::get_cv("${pkg}::$sym") : () ), ( defined *{"${pkg}::$sym"}{SCALAR} and length ref ${"${pkg}::$sym"} and ! isweak( ${"${pkg}::$sym"} ) ) ? ${"${pkg}::$sym"} : () , ( map { ( defined *{"${pkg}::$sym"}{$_} and ! isweak(defined *{"${pkg}::$sym"}{$_}) ) ? *{"${pkg}::$sym"}{$_} : () } qw(HASH ARRAY IO GLOB) ), } keys %{"${pkg}::"} ], ) unless $pkg =~ /^ (?: DB | next | B | .+? ::::ISA (?: ::CACHE ) | Class::C3 | B::Hooks::EndOfScope::PP::HintHash::.+ ) $/x; } ); # use Devel::Dwarn; # Ddie [ map # { { $_ => $refs_per_pkg->{$_} } } # sort # {$refs_per_pkg->{$a} <=> $refs_per_pkg->{$b} } # keys %$refs_per_pkg # ]; $seen_refs; } sub assert_empty_weakregistry { my ($weak_registry, $quiet) = @_; # in case we hooked bless any extra object creation will wreak # havoc during the assert phase local *CORE::GLOBAL::bless; *CORE::GLOBAL::bless = sub { CORE::bless( $_[0], (@_ > 1) ? $_[1] : caller() ) }; croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH'; defined $weak_registry->{$_}{weakref} or delete $weak_registry->{$_} for keys %$weak_registry; return unless keys %$weak_registry; my $tb = eval { Test::Builder->new } or croak "Calling assert_empty_weakregistry in $0 without a loaded Test::Builder makes no sense"; for my $addr (keys %$weak_registry) { $weak_registry->{$addr}{display_name} = join ' | ', ( sort { length $a <=> length $b or $a cmp $b } keys %{$weak_registry->{$addr}{slot_names}} ); $tb->BAILOUT("!!!! WEAK REGISTRY SLOT $weak_registry->{$addr}{display_name} IS NOT A WEAKREF !!!!") if defined $weak_registry->{$addr}{weakref} and ! isweak( $weak_registry->{$addr}{weakref} ); } # the symtable walk is very expensive # if we are $quiet (running in an END block) we do not really need to be # that thorough - can get by with only %Sub::Quote::QUOTED delete $weak_registry->{$_} for $quiet ? do { my $refs = {}; visit_refs ( # only look at the closed over stuffs refs => [ grep { length ref $_ } ( # old style Sub::Quote ( map { values %{ $_->[2]} } grep { ref $_ eq 'ARRAY' } values %Sub::Quote::QUOTED ), # new style Sub::Quote ( map { values %{ $_->{captures}} } grep { ref $_ eq 'HASH' } values %Sub::Quote::QUOTED ), )], seen_refs => $refs, action => sub { 1 }, ); keys %$refs; } : ( # full sumtable walk, starting from :: keys %{ symtable_referenced_addresses() } ) ; for my $addr (sort { $weak_registry->{$a}{display_name} cmp $weak_registry->{$b}{display_name} } keys %$weak_registry) { next if ! defined $weak_registry->{$addr}{weakref}; $leaks_found++ unless $tb->in_todo; $tb->ok (0, "Expected garbage collection of $weak_registry->{$addr}{display_name}"); my $diag = do { local $Data::Dumper::Maxdepth = 1; sprintf "\n%s (refcnt %d) => %s\n", $weak_registry->{$addr}{display_name}, refcount($weak_registry->{$addr}{weakref}), ( ref($weak_registry->{$addr}{weakref}) eq 'CODE' and B::svref_2object($weak_registry->{$addr}{weakref})->XSUB ) ? '__XSUB__' : Dumper( $weak_registry->{$addr}{weakref} ) ; }; # FIXME - need to add a circular reference seeker based on the visitor # (will need a bunch of modifications, punting with just a stub for now) $diag .= Devel::FindRef::track ($weak_registry->{$addr}{weakref}, 50) . "\n" if ( $ENV{TEST_VERBOSE} && eval { require Devel::FindRef }); $diag =~ s/^/ /mg; if (my $stack = $weak_registry->{$addr}{stacktrace}) { $diag .= " Reference first seen$stack"; } $tb->diag($diag); # if ($leaks_found == 1) { # # using the fh dumper due to intermittent buffering issues # # in case we decide to exit soon after (possibly via _exit) # require Devel::MAT::Dumper; # local $Devel::MAT::Dumper::MAX_STRING = -1; # open( my $fh, '>:raw', "leaked_${addr}_pid$$.pmat" ) or die $!; # Devel::MAT::Dumper::dumpfh( $fh ); # close ($fh) or die $!; # # use POSIX; # POSIX::_exit(1); # } } if (! $quiet and !$leaks_found and ! $tb->in_todo) { $tb->ok(1, sprintf "No leaks found at %s line %d", (caller())[1,2] ); } } END { if ( $INC{'Test/Builder.pm'} and my $tb = do { local $@; my $t = eval { Test::Builder->new } or warn "Test::Builder->new failed:\n$@\n"; $t; } ) { # we check for test passage - a leak may be a part of a TODO if ($leaks_found and !$tb->is_passing) { $tb->diag(sprintf "\n\n%s\n%s\n\nInstall Devel::FindRef and re-run the test with set " . '$ENV{TEST_VERBOSE} (prove -v) to see a more detailed leak-report' . "\n\n%s\n%s\n\n", ('#' x 16) x 4 ) if ( !$ENV{TEST_VERBOSE} or !$INC{'Devel/FindRef.pm'} ); } else { $tb->note("Auto checked $refs_traced references for leaks - none detected"); } # also while we are here and not in plain runmode: make sure we never # loaded any of the strictures XS bullshit (it's a leak in a sense) unless ( $ENV{MOO_FATAL_WARNINGS} or # FIXME - SQLT loads strictures explicitly, /facedesk # remove this INC check when 0fb58589 and 45287c815 are rectified $INC{'SQL/Translator.pm'} or DBICTest::RunMode->is_plain ) { for my $mod (qw(indirect multidimensional bareword::filehandles)) { ( my $fn = "$mod.pm" ) =~ s|::|/|g; $tb->ok(0, "Load of '$mod' should not have been attempted!!!" ) if exists $INC{$fn}; } } } } 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Util/OverrideRequire.pm������������������������������������������0000644�0001750�0001750�00000007767�13555517102�022071� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBICTest::Util::OverrideRequire; # no use/require of any kind - work bare BEGIN { # Neat STDERR require call tracer # # 0 - no trace # 1 - just requires and return values # 2 - neat stacktrace (assumes that the supplied $override_cref does *not* (ab)use goto) # 3 - full stacktrace *TRACE = sub () { 0 }; } # Takes a single coderef and replaces CORE::GLOBAL::require with it. # # On subsequent require() calls, the coderef will be invoked with # two arguments - ($next_require, $module_name_copy) # # $next_require is a coderef closing over the module name. It needs # to be invoked at some point without arguments for the actual # require to take place (this way your coderef in essence becomes an # around modifier) # # $module_name_copy is a string-copy of what $next_require is closing # over. The reason for the copy is that you may trigger a side effect # on magical values, and subsequently abort the require (e.g. # require v.5.8.8 magic) # # All of this almost verbatim copied from Lexical::SealRequireHints # Zefram++ sub override_global_require (&) { my $override_cref = shift; our $next_require = defined(&CORE::GLOBAL::require) ? \&CORE::GLOBAL::require : sub { my ($arg) = @_; # The shenanigans with $CORE::GLOBAL::{require} # are required because if there's a # &CORE::GLOBAL::require when the eval is # executed then the CORE::require in there is # interpreted as plain require on some Perl # versions, leading to recursion. my $grequire = delete $CORE::GLOBAL::{require}; my $res = eval sprintf ' local $SIG{__DIE__}; $CORE::GLOBAL::{require} = $grequire; package %s; CORE::require($arg); ', scalar caller(0); # the caller already had its package replaced my $err = $@ if $@ ne ''; if( TRACE ) { if (TRACE == 1) { printf STDERR "Require of '%s' (returned: '%s')\n", (my $m_copy = $arg), (my $r_copy = $res), ; } else { my ($fr_num, @fr, @tr, $excise); while (@fr = caller($fr_num++)) { # Package::Stash::XS is a cock and gets mightily confused if one # uses a regex in the require hook. Even though it happens only # on < 5.8.7 it's still rather embarassing (also wtf does P::S::XS # even need to regex its own module name?!). So we do not use re :) if (TRACE == 3 or (index($fr[1], '(eval ') != 0 and index($fr[1], __FILE__) != 0) ) { push @tr, [@fr] } # the caller before this would be the override site - kill it away # if the cref writer uses goto - well tough, tracer won't work if ($fr[3] eq 'DBICTest::Util::OverrideRequire::__ANON__') { $excise ||= $tr[-2] if TRACE == 2; } } my @stack = map { "$_->[1], line $_->[2]" } grep { ! $excise or $_->[1] ne $excise->[1] or $_->[2] ne $excise->[2] } @tr ; printf STDERR "Require of '%s' (returned: '%s')\n%s\n\n", (my $m_copy = $arg), (my $r_copy = $res||''), join "\n", (map { " $_" } @stack) ; } } die $err if defined $err; return $res; } ; # Need to suppress the redefinition warning, without # invoking warnings.pm. BEGIN { ${^WARNING_BITS} = ""; } *CORE::GLOBAL::require = sub { die "wrong number of arguments to require\n" unless @_ == 1; # the copy is to prevent accidental overload firing (e.g. require v5.8.8) my ($arg_copy) = our ($arg) = @_; return $override_cref->(sub { die "The require delegate takes no arguments\n" if @_; my $res = eval sprintf ' local $SIG{__DIE__}; package %s; $next_require->($arg); ', scalar caller(2); # 2 for the indirection of the $override_cref around die $@ if $@ ne ''; return $res; }, $arg_copy); } } 1; ���������DBIx-Class-0.082843/t/lib/DBICTest/BaseSchema.pm����������������������������������������������������0000644�0001750�0001750�00000023623�14240132261�020007� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package #hide from pause DBICTest::BaseSchema; use strict; use warnings; use base qw(DBICTest::Base DBIx::Class::Schema); use Fcntl qw(:DEFAULT :seek :flock); use Scalar::Util 'weaken'; use Time::HiRes 'sleep'; use DBICTest::Util::LeakTracer qw(populate_weakregistry assert_empty_weakregistry); use DBICTest::Util qw( local_umask await_flock dbg DEBUG_TEST_CONCURRENCY_LOCKS ); use namespace::clean; sub capture_executed_sql_bind { my ($self, $cref) = @_; $self->throw_exception("Expecting a coderef to run") unless ref $cref eq 'CODE'; require DBICTest::SQLTracerObj; # hack around stupid, stupid API no warnings 'redefine'; local *DBIx::Class::Storage::DBI::_format_for_trace = sub { $_[1] }; Class::C3->reinitialize if DBIx::Class::_ENV_::OLD_MRO; local $self->storage->{debugcb}; local $self->storage->{debugobj} = my $tracer_obj = DBICTest::SQLTracerObj->new; local $self->storage->{debug} = 1; local $Test::Builder::Level = $Test::Builder::Level + 2; $cref->(); return $tracer_obj->{sqlbinds} || []; } sub is_executed_querycount { my ($self, $cref, $exp_counts, $msg) = @_; local $Test::Builder::Level = $Test::Builder::Level + 1; $self->throw_exception("Expecting an hashref of counts or an integer representing total query count") unless ref $exp_counts eq 'HASH' or (defined $exp_counts and ! ref $exp_counts); my @got = map { $_->[0] } @{ $self->capture_executed_sql_bind($cref) }; return Test::More::is( @got, $exp_counts, $msg ) unless ref $exp_counts; my $got_counts = { map { $_ => 0 } keys %$exp_counts }; $got_counts->{$_}++ for @got; return Test::More::is_deeply( $got_counts, $exp_counts, $msg, ); } sub is_executed_sql_bind { my ($self, $cref, $sqlbinds, $msg) = @_; local $Test::Builder::Level = $Test::Builder::Level + 1; $self->throw_exception("Expecting an arrayref of SQL/Bind pairs") unless ref $sqlbinds eq 'ARRAY'; my @expected = @$sqlbinds; my @got = map { $_->[1] } @{ $self->capture_executed_sql_bind($cref) }; return Test::Builder->new->ok(1, $msg || "No queries executed while running $cref") if !@got and !@expected; require SQL::Abstract::Test; my $ret = 1; while (@expected or @got) { my $left = shift @got; my $right = shift @expected; # allow the right side to "simplify" the entire shebang if ($left and $right) { $left = [ @$left ]; for my $i (1..$#$right) { if ( ! ref $right->[$i] and ref $left->[$i] eq 'ARRAY' and @{$left->[$i]} == 2 ) { $left->[$i] = $left->[$i][1] } } } $ret &= SQL::Abstract::Test::is_same_sql_bind( \( $left || [] ), \( $right || [] ), $msg, ); } return $ret; } our $locker; END { # we need the $locker to be referenced here for delayed destruction if ($locker->{lock_name} and ($ENV{DBICTEST_LOCK_HOLDER}||0) == $$) { DEBUG_TEST_CONCURRENCY_LOCKS and dbg "$locker->{type} LOCK RELEASED (END): $locker->{lock_name}"; # we were using a lock-able RDBMS: if we are failing - dump the last diag if ( $locker->{rdbms_connection_diag} and $INC{'Test/Builder.pm'} and my $tb = do { local $@; my $t = eval { Test::Builder->new } or warn "Test::Builder->new failed:\n$@\n"; $t; } ) { $tb->diag( "\nabove test failure almost certainly happened against:\n$locker->{rdbms_connection_diag}" ) if ( !$tb->is_passing or !defined( $tb->has_plan ) or ( $tb->has_plan ne 'no_plan' and $tb->has_plan != $tb->current_test ) ) } } } my $weak_registry = {}; sub connection { my( $proto, @args ) = @_; if( $ENV{DBICTEST_SWAPOUT_SQLAC_WITH} ) { my( $sqlac_like ) = $ENV{DBICTEST_SWAPOUT_SQLAC_WITH} =~ /(.+)/; Class::C3::Componentised->ensure_class_loaded( $sqlac_like ); require DBIx::Class::SQLMaker::ClassicExtensions; require SQL::Abstract::Classic; Class::C3::Componentised->inject_base( 'DBICTest::SQLAC::SwapOut', 'DBIx::Class::SQLMaker::ClassicExtensions', $sqlac_like, 'SQL::Abstract::Classic', ); # perl can be pretty disgusting... push @args, {} unless ref( $args[-1] ) eq 'HASH'; $args[-1] = { %{ $args[-1] } }; if( ref( $args[-1]{on_connect_call} ) ne 'ARRAY' ) { $args[-1]{on_connect_call} = [ $args[-1]{on_connect_call} ? [ $args[-1]{on_connect_call} ] : () ]; } elsif( ref( $args[-1]{on_connect_call}[0] ) ne 'ARRAY' ) { $args[-1]{on_connect_call} = [ map { [ $_ ] } @{ $args[-1]{on_connect_call} } ]; } push @{ $args[-1]{on_connect_call} }, ( [ rebase_sqlmaker => 'DBICTest::SQLAC::SwapOut' ], ); } my $self = $proto->next::method( @args ); # MASSIVE FIXME # we can't really lock based on DSN, as we do not yet have a way to tell that e.g. # DBICTEST_MSSQL_DSN=dbi:Sybase:server=192.168.0.11:1433;database=dbtst # and # DBICTEST_MSSQL_ODBC_DSN=dbi:ODBC:server=192.168.0.11;port=1433;database=dbtst;driver=FreeTDS;tds_version=8.0 # are the same server # hence we lock everything based on sqlt_type or just globally if not available # just pretend we are python you know? :) # when we get a proper DSN resolution sanitize to produce a portable lockfile name # this may look weird and unnecessary, but consider running tests from # windows over a samba share >.> #utf8::encode($dsn); #$dsn =~ s/([^A-Za-z0-9_\-\.\=])/ sprintf '~%02X', ord($1) /ge; #$dsn =~ s/^dbi/dbi/i; # provide locking for physical (non-memory) DSNs, so that tests can # safely run in parallel. While the harness (make -jN test) does set # an envvar, we can not detect when a user invokes prove -jN. Hence # perform the locking at all times, it shouldn't hurt. # the lock fh *should* inherit across forks/subprocesses if ( ! $DBICTest::global_exclusive_lock and ( ! $ENV{DBICTEST_LOCK_HOLDER} or $ENV{DBICTEST_LOCK_HOLDER} == $$ ) and ref($args[0]) ne 'CODE' and ($args[0]||'') !~ /^ (?i:dbi) \: SQLite (?: \: | \W ) .*? (?: dbname\= )? (?: \:memory\: | t [\/\\] var [\/\\] DBIxClass\-) /x ) { my $locktype; { # guard against infinite recursion local $ENV{DBICTEST_LOCK_HOLDER} = -1; # we need to work with a forced fresh clone so that we do not upset any state # of the main $schema (some tests examine it quite closely) local $SIG{__WARN__} = sub {}; local $@; # this will either give us an undef $locktype or will determine things # properly with a default ( possibly connecting in the process ) eval { my $s = ref($self)->connect(@{$self->storage->connect_info})->storage; $locktype = $s->sqlt_type || 'generic'; # in case sqlt_type did connect, doesn't matter if it fails or something $s->disconnect; }; } # Never hold more than one lock. This solves the "lock in order" issues # unrelated tests may have # Also if there is no connection - there is no lock to be had if ($locktype and (!$locker or $locker->{type} ne $locktype)) { # this will release whatever lock we may currently be holding # which is fine since the type does not match as checked above DEBUG_TEST_CONCURRENCY_LOCKS and $locker and dbg "$locker->{type} LOCK RELEASED (UNDEF): $locker->{lock_name}"; undef $locker; my $lockpath = DBICTest::RunMode->tmpdir->file("_dbictest_$locktype.lock"); DEBUG_TEST_CONCURRENCY_LOCKS and dbg "Waiting for $locktype LOCK: $lockpath..."; my $lock_fh; { my $u = local_umask(0); # so that the file opens as 666, and any user can lock sysopen ($lock_fh, $lockpath, O_RDWR|O_CREAT) or die "Unable to open $lockpath: $!"; } await_flock ($lock_fh, LOCK_EX) or die "Unable to lock $lockpath: $!"; DEBUG_TEST_CONCURRENCY_LOCKS and dbg "Got $locktype LOCK: $lockpath"; # see if anyone was holding a lock before us, and wait up to 5 seconds for them to terminate # if we do not do this we may end up trampling over some long-running END or somesuch seek ($lock_fh, 0, SEEK_SET) or die "seek failed $!"; my $old_pid; if ( read ($lock_fh, $old_pid, 100) and ($old_pid) = $old_pid =~ /^(\d+)$/ ) { DEBUG_TEST_CONCURRENCY_LOCKS and dbg "Post-grab WAIT for $old_pid START: $lockpath"; for (1..50) { kill (0, $old_pid) or last; sleep 0.1; } DEBUG_TEST_CONCURRENCY_LOCKS and dbg "Post-grab WAIT for $old_pid FINISHED: $lockpath"; } truncate $lock_fh, 0; seek ($lock_fh, 0, SEEK_SET) or die "seek failed $!"; $lock_fh->autoflush(1); print $lock_fh $$; $ENV{DBICTEST_LOCK_HOLDER} ||= $$; $locker = { type => $locktype, fh => $lock_fh, lock_name => "$lockpath", }; } } if ($INC{'Test/Builder.pm'}) { populate_weakregistry ( $weak_registry, $self->storage ); my $cur_connect_call = $self->storage->on_connect_call; # without this weaken() the sub added below *sometimes* leaks # ( can't reproduce locally :/ ) weaken( my $wlocker = $locker ); $self->storage->on_connect_call([ (ref $cur_connect_call eq 'ARRAY' ? @$cur_connect_call : ($cur_connect_call || ()) ), [ sub { populate_weakregistry( $weak_registry, $_[0]->_dbh ) } ], ( !$wlocker ? () : ( require Data::Dumper::Concise and [ sub { ($wlocker||{})->{rdbms_connection_diag} = Data::Dumper::Concise::Dumper( $_[0]->_describe_connection() ) } ], )), ]); } return $self; } sub clone { my $self = shift->next::method(@_); populate_weakregistry ( $weak_registry, $self ) if $INC{'Test/Builder.pm'}; $self; } END { assert_empty_weakregistry($weak_registry, 'quiet'); } 1; �������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/SQLTracerObj.pm��������������������������������������������������0000644�0001750�0001750�00000001253�14240132261�020242� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # moar hide DBICTest::SQLTracerObj; use strict; use warnings; use base 'DBIx::Class::Storage::Statistics'; sub query_start { push @{$_[0]{sqlbinds}}, [ ($_[1] =~ /^\s*(\S+)/)[0], [ $_[1], @{ $_[2]||[] } ] ] } # who the hell came up with this API >:( for my $txn (qw(begin rollback commit)) { no strict 'refs'; *{"txn_$txn"} = sub { push @{$_[0]{sqlbinds}}, [ uc $txn => [ uc $txn ] ] }; } sub svp_begin { push @{$_[0]{sqlbinds}}, [ SAVEPOINT => [ "SAVEPOINT $_[1]" ] ] } sub svp_release { push @{$_[0]{sqlbinds}}, [ RELEASE_SAVEPOINT => [ "RELEASE $_[1]" ] ] } sub svp_rollback { push @{$_[0]{sqlbinds}}, [ ROLLBACK_TO_SAVEPOINT => [ "ROLLBACK TO $_[1]" ] ] } 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/ResultSetManager/������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�020716� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/ResultSetManager/Foo.pm������������������������������������������0000644�0001750�0001750�00000000357�13555517102�021774� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::ResultSetManager::Foo; use warnings; use strict; use base 'DBIx::Class::Core'; __PACKAGE__->load_components(qw/ ResultSetManager /); __PACKAGE__->table('foo'); sub bar : ResultSet { 'good' } 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Schema.pm��������������������������������������������������������0000644�0001750�0001750�00000002120�14240132261�017201� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Schema; use strict; use warnings; no warnings 'qw'; use base 'DBICTest::BaseSchema'; __PACKAGE__->mk_group_accessors(simple => 'custom_attr'); __PACKAGE__->load_classes(qw/ Artist SequenceTest BindType Employee CD Genre Bookmark Link #dummy Track Tag Year2000CDs Year1999CDs CustomSql Money TimestampPrimaryKey /, { 'DBICTest::Schema' => [qw/ LinerNotes Artwork Artwork_to_Artist Image Lyrics LyricVersion OneKey #dummy TwoKeys Serialized /]}, ( 'FourKeys', 'FourKeys_to_TwoKeys', '#dummy', 'SelfRef', 'ArtistUndirectedMap', 'ArtistSourceName', 'ArtistSubclass', 'Producer', 'CD_to_Producer', 'Dummy', # this is a real result class we remove in the hook below ), qw/SelfRefAlias TreeLike TwoKeyTreeLike Event EventTZ NoPrimaryKey/, qw/Collection CollectionObject TypedObject Owners BooksInLibrary/, qw/ForceForeign Encoded/, ); sub sqlt_deploy_hook { my ($self, $sqlt_schema) = @_; $sqlt_schema->drop_table('dummy'); } 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/ForeignComponent.pm����������������������������������������������0000644�0001750�0001750�00000000343�13555517102�021273� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# belongs to t/05components.t package # hide from PAUSE DBICTest::ForeignComponent; use warnings; use strict; use base qw/ DBIx::Class /; __PACKAGE__->load_components( qw/ +DBICTest::ForeignComponent::TestComp / ); 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/SQLMRebase.pm����������������������������������������������������0000644�0001750�0001750�00000000434�14240132261�017705� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBICTest::SQLMRebase; use warnings; use strict; our @ISA = qw( DBIx::Class::SQLMaker::ClassicExtensions SQL::Abstract::Classic ); __PACKAGE__->mk_group_accessors( simple => '__select_counter' ); sub select { $_[0]->{__select_counter}++; shift->next::method(@_); } 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/ErrorComponent.pm������������������������������������������������0000644�0001750�0001750�00000000243�13555517102�020772� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# belongs to t/run/90ensure_class_loaded.tl package # hide from PAUSE DBICTest::ErrorComponent; use warnings; use strict; # this is missing on purpose # 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Base.pm����������������������������������������������������������0000644�0001750�0001750�00000000275�14240132261�016664� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package #hide from pause DBICTest::Base; use strict; use warnings; # must load before any DBIx::Class* namespaces use DBICTest::RunMode; sub _skip_namespace_frames { '^DBICTest' } 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/OptionalComponent.pm���������������������������������������������0000644�0001750�0001750�00000000207�13555517102�021466� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# belongs to t/run/90ensure_class_loaded.tl package # hide from PAUSE DBICTest::OptionalComponent; use warnings; use strict; 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/ResultSetManager.pm����������������������������������������������0000644�0001750�0001750�00000000236�13555517102�021245� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::ResultSetManager; use warnings; use strict; use base 'DBICTest::BaseSchema'; __PACKAGE__->load_classes("Foo"); 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/SyntaxErrorComponent1.pm�����������������������������������������0000644�0001750�0001750�00000000247�13555517102�022266� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# belongs to t/run/90ensure_class_loaded.tl package # hide from PAUSE DBICTest::SyntaxErrorComponent1; use warnings; use strict; my $str ''; # syntax error 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Taint/�����������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�016550� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Taint/Classes/���������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�020145� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Taint/Classes/Auto.pm��������������������������������������������0000644�0001750�0001750�00000000230�13555517102�021376� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Taint::Classes::Auto; use warnings; use strict; use base 'DBIx::Class::Core'; __PACKAGE__->table('test'); 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Taint/Classes/Manual.pm������������������������������������������0000644�0001750�0001750�00000000232�13555517102�021705� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Taint::Classes::Manual; use warnings; use strict; use base 'DBIx::Class::Core'; __PACKAGE__->table('test'); 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Taint/Namespaces/������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�020627� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Taint/Namespaces/Result/�����������������������������������������0000755�0001750�0001750�00000000000�14240676463�022105� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Taint/Namespaces/Result/Test.pm����������������������������������0000644�0001750�0001750�00000000243�13555517102�023351� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest::Taint::Namespaces::Result::Test; use warnings; use strict; use base 'DBIx::Class::Core'; __PACKAGE__->table('test'); 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/SyntaxErrorComponent3.pm�����������������������������������������0000644�0001750�0001750�00000000124�13555517102�022262� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBICErrorTest::SyntaxError; use strict; use warnings; I'm a syntax error! ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Cursor.pm��������������������������������������������������������0000644�0001750�0001750�00000000151�13555517102�017271� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBICTest::Cursor; use strict; use warnings; use base qw/DBIx::Class::Storage::DBI::Cursor/; 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/FakeComponent.pm�������������������������������������������������0000644�0001750�0001750�00000000203�13555517102�020543� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# belongs to t/run/90ensure_class_loaded.tl package # hide from PAUSE DBICTest::FakeComponent; use warnings; use strict; 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/Util.pm����������������������������������������������������������0000644�0001750�0001750�00000013711�14240132261�016726� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBICTest::Util; use warnings; use strict; # this noop trick initializes the STDOUT, so that the TAP::Harness # issued IO::Select->can_read calls (which are blocking wtf wtf wtf) # keep spinning and scheduling jobs # This results in an overall much smoother job-queue drainage, since # the Harness blocks less # (ideally this needs to be addressed in T::H, but a quick patchjob # broke everything so tabling it for now) BEGIN { if ($INC{'Test/Builder.pm'}) { local $| = 1; print "#\n"; } } use constant DEBUG_TEST_CONCURRENCY_LOCKS => ( ($ENV{DBICTEST_DEBUG_CONCURRENCY_LOCKS}||'') =~ /^(\d+)$/ )[0] || 0 ; use Config; use Carp 'confess'; use Fcntl ':flock'; use Scalar::Util qw(blessed refaddr); use DBIx::Class::_Util; use base 'Exporter'; our @EXPORT_OK = qw( dbg stacktrace local_umask visit_namespaces check_customcond_args await_flock DEBUG_TEST_CONCURRENCY_LOCKS ); if (DEBUG_TEST_CONCURRENCY_LOCKS) { require DBI; my $oc = DBI->can('connect'); no warnings 'redefine'; *DBI::connect = sub { DBICTest::Util::dbg("Connecting to $_[1]"); goto $oc; } } sub dbg ($) { require Time::HiRes; printf STDERR "\n%.06f %5s %-78s %s\n", scalar Time::HiRes::time(), $$, $_[0], $0, ; } # File locking is hard. Really hard. By far the best lock implementation # I've seen is part of the guts of File::Temp. However it is sadly not # reusable. Since I am not aware of folks doing NFS parallel testing, # nor are we known to work on VMS, I am just going to punt this and # use the portable-ish flock() provided by perl itself. If this does # not work for you - patches more than welcome. # # This figure esentially means "how long can a single test hold a # resource before everyone else gives up waiting and aborts" or # in other words "how long does the longest test-group legitimally run?" my $lock_timeout_minutes = 15; # yes, that's long, I know my $wait_step_seconds = 0.25; sub await_flock ($$) { my ($fh, $locktype) = @_; my ($res, $tries); while( ! ( $res = flock( $fh, $locktype | LOCK_NB ) ) and ++$tries <= $lock_timeout_minutes * 60 / $wait_step_seconds ) { select( undef, undef, undef, $wait_step_seconds ); # "say something" every 10 cycles to work around RT#108390 # jesus christ our tooling is such a crock of shit :( unless ( $tries % 10 ) { # Turning on autoflush is crucial: if stars align just right buffering # will ensure we never actually call write() underneath until the grand # timeout is reached (and that's too long). Reproducible via # # DBICTEST_VERSION_WARNS_INDISCRIMINATELY=1 \ # DBICTEST_RUN_ALL_TESTS=1 \ # strace -f \ # prove -lj10 xt/extra/internals/ # select( ( select(\*STDOUT), $|=1 )[0] ); print "#\n"; } } return $res; } sub local_umask { return unless defined $Config{d_umask}; die 'Calling local_umask() in void context makes no sense' if ! defined wantarray; my $old_umask = umask(shift()); die "Setting umask failed: $!" unless defined $old_umask; return bless \$old_umask, 'DBICTest::Util::UmaskGuard'; } { package DBICTest::Util::UmaskGuard; sub DESTROY { &DBIx::Class::_Util::detected_reinvoked_destructor; local ($@, $!); eval { defined (umask ${$_[0]}) or die }; warn ( "Unable to reset old umask ${$_[0]}: " . ($!||'Unknown error') ) if ($@ || $!); } } sub stacktrace { my $frame = shift; $frame++; my (@stack, @frame); while (@frame = caller($frame++)) { push @stack, [@frame[3,1,2]]; } return undef unless @stack; $stack[0][0] = ''; return join "\tinvoked as ", map { sprintf ("%s at %s line %d\n", @$_ ) } @stack; } sub check_customcond_args ($) { my $args = shift; confess "Expecting a hashref" unless ref $args eq 'HASH'; for (qw(rel_name foreign_relname self_alias foreign_alias)) { confess "Custom condition argument '$_' must be a plain string" if length ref $args->{$_} or ! length $args->{$_}; } confess "Current and legacy rel_name arguments do not match" if $args->{rel_name} ne $args->{foreign_relname}; confess "Custom condition argument 'self_resultsource' must be a rsrc instance" unless defined blessed $args->{self_resultsource} and $args->{self_resultsource}->isa('DBIx::Class::ResultSource'); confess "Passed resultsource has no record of the supplied rel_name - likely wrong \$rsrc" unless ref $args->{self_resultsource}->relationship_info($args->{rel_name}); my $struct_cnt = 0; if (defined $args->{self_result_object} or defined $args->{self_rowobj} ) { $struct_cnt++; for (qw(self_result_object self_rowobj)) { confess "Custom condition argument '$_' must be a result instance" unless defined blessed $args->{$_} and $args->{$_}->isa('DBIx::Class::Row'); } confess "Current and legacy self_result_object arguments do not match" if refaddr($args->{self_result_object}) != refaddr($args->{self_rowobj}); } if (defined $args->{foreign_values}) { $struct_cnt++; confess "Custom condition argument 'foreign_values' must be a hash reference" unless ref $args->{foreign_values} eq 'HASH'; } confess "Data structures supplied on both ends of a relationship" if $struct_cnt == 2; $args; } sub visit_namespaces { my $args = { (ref $_[0]) ? %{$_[0]} : @_ }; my $visited_count = 1; # A package and a namespace are subtly different things $args->{package} ||= 'main'; $args->{package} = 'main' if $args->{package} =~ /^ :: (?: main )? $/x; $args->{package} =~ s/^:://; if ( $args->{action}->($args->{package}) ) { my $ns = ( ($args->{package} eq 'main') ? '' : $args->{package} ) . '::' ; $visited_count += visit_namespaces( %$args, package => $_ ) for grep # this happens sometimes on %:: traversal { $_ ne '::main' } map { $_ =~ /^(.+?)::$/ ? "$ns$1" : () } do { no strict 'refs'; keys %$ns } ; } return $visited_count; } 1; �������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/BaseResultSet.pm�������������������������������������������������0000644�0001750�0001750�00000002203�14240132261�020530� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package #hide from pause DBICTest::BaseResultSet; use strict; use warnings; BEGIN { my @subclassing = qw(DBICTest::Base DBIx::Class::ResultSet); if( ! $ENV{DBICTEST_MOOIFIED_RESULTSETS} ) { # plain old vanilla base.pm require base; base->import(@subclassing); } else { # do a string eval to make sure Moo doesn't get confused require Carp; eval <<'EOM' use Moo; extends @subclassing; # ::RS::new() expects my ($class, $rsrc, $args) = @_ # Moo(se) expects a single hashref ( $args ), and makes it mandatory # # Ensure that unless we are called from a test - DBIC always fills it in sub BUILDARGS { if( ! defined $_[2] and # not a direct call from a test file (caller(1))[1] !~ m{ (?: ^ | \/ | \\ ) t [\/\\] .+ \.t $ }x ) { $Carp::CarpLevel += 2; Carp::confess( "...::ResultSet->new() called without supplying an ( empty ) hashref as argument: this fails with Moo(se) and incomplete BUILDARGS. Problematic stacktrace begins" ); } $_[2] || {}; } EOM } } sub all_hri { return [ shift->search ({}, { result_class => 'DBIx::Class::ResultClass::HashRefInflator' })->all ]; } 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest/BaseResult.pm����������������������������������������������������0000644�0001750�0001750�00000001402�13564417232�020070� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package #hide from pause DBICTest::BaseResult; use strict; use warnings; use base qw(DBICTest::Base DBIx::Class::Core); #use base qw/DBIx::Class::Relationship::Cascade::Rekey DBIx::Class::Core/; __PACKAGE__->table ('bogus'); __PACKAGE__->resultset_class ('DBICTest::BaseResultSet'); #sub add_relationship { # my $self = shift; # my $opts = $_[3] || {}; # if (grep { $_ eq $_[0] } qw/ # cds_90s cds_80s cds_84 artist_undirected_maps mapped_artists last_track # /) { # # nothing - join-dependent or non-cascadeable relationship # } # elsif ($opts->{is_foreign_key_constraint}) { # $opts->{on_update} ||= 'cascade'; # } # else { # $opts->{cascade_rekey} = 1 # unless ref $_[2] eq 'CODE'; # } # $self->next::method(@_[0..2], $opts); #} 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICNSTest/���������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�015732� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICNSTest/RtBug41083/����������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�017355� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICNSTest/RtBug41083/ResultSet_A/����������������������������������������0000755�0001750�0001750�00000000000�14240676463�021547� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICNSTest/RtBug41083/ResultSet_A/A.pm������������������������������������0000644�0001750�0001750�00000000216�13555517102�022254� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBICNSTest::RtBug41083::ResultSet_A::A; use strict; use warnings; use base 'DBICNSTest::RtBug41083::ResultSet'; sub fooBar { 1; } 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICNSTest/RtBug41083/ResultSet.pm����������������������������������������0000644�0001750�0001750�00000000153�13555517102�021634� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBICNSTest::RtBug41083::ResultSet; use strict; use warnings; use base 'DBIx::Class::ResultSet'; 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICNSTest/RtBug41083/Result_A/�������������������������������������������0000755�0001750�0001750�00000000000�14240676463�021073� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICNSTest/RtBug41083/Result_A/A/�����������������������������������������0000755�0001750�0001750�00000000000�14240676463�021253� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICNSTest/RtBug41083/Result_A/A/Sub.pm�����������������������������������0000644�0001750�0001750�00000000177�13555517102�022337� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBICNSTest::RtBug41083::Result_A::A::Sub; use strict; use warnings; use base 'DBICNSTest::RtBug41083::Result_A::A'; 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICNSTest/RtBug41083/Result_A/A.pm���������������������������������������0000644�0001750�0001750�00000000240�13555517102�021575� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBICNSTest::RtBug41083::Result_A::A; use strict; use warnings; use base 'DBIx::Class::Core'; __PACKAGE__->table('a'); __PACKAGE__->add_columns('a'); 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICNSTest/RtBug41083/Result/���������������������������������������������0000755�0001750�0001750�00000000000�14240676463�020633� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICNSTest/RtBug41083/Result/Foo.pm���������������������������������������0000644�0001750�0001750�00000000244�13555517102�021704� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBICNSTest::RtBug41083::Result::Foo; use strict; use warnings; use base 'DBIx::Class::Core'; __PACKAGE__->table('foo'); __PACKAGE__->add_columns('foo'); 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICNSTest/RtBug41083/Result/Foo/�����������������������������������������0000755�0001750�0001750�00000000000�14240676463�021356� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICNSTest/RtBug41083/Result/Foo/Sub.pm�����������������������������������0000644�0001750�0001750�00000000177�13555517102�022442� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBICNSTest::RtBug41083::Result::Foo::Sub; use strict; use warnings; use base 'DBICNSTest::RtBug41083::Result::Foo'; 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICNSTest/RtBug41083/ResultSet/������������������������������������������0000755�0001750�0001750�00000000000�14240676463�021307� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICNSTest/RtBug41083/ResultSet/Foo.pm������������������������������������0000644�0001750�0001750�00000000217�13555517102�022360� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBICNSTest::RtBug41083::ResultSet::Foo; use strict; use warnings; use base 'DBICNSTest::RtBug41083::ResultSet'; sub fooBar { 1; } 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICNSTest/ResultSet/�����������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�017664� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICNSTest/ResultSet/A.pm�������������������������������������������������0000644�0001750�0001750�00000000146�13555517102�020373� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBICNSTest::ResultSet::A; use warnings; use strict; use base qw/DBIx::Class::ResultSet/; 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICNSTest/ResultSet/D.pm�������������������������������������������������0000644�0001750�0001750�00000000101�13555517102�020365� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBICNSTest::ResultSet::D; use warnings; use strict; 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICNSTest/ResultSet/C.pm�������������������������������������������������0000644�0001750�0001750�00000000146�13555517102�020375� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBICNSTest::ResultSet::C; use warnings; use strict; use base qw/DBIx::Class::ResultSet/; 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICNSTest/Rslt/����������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�016656� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICNSTest/Rslt/A.pm������������������������������������������������������0000644�0001750�0001750�00000000341�13555517102�017362� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBICNSTest::Rslt::A; use warnings; use strict; use base qw/DBIx::Class::Core/; __PACKAGE__->table('a'); __PACKAGE__->add_columns('a'); # part of a test, do not remove $_ = 'something completely utterly bogus'; 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICNSTest/Rslt/B.pm������������������������������������������������������0000644�0001750�0001750�00000000224�13555517102�017363� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBICNSTest::Rslt::B; use warnings; use strict; use base qw/DBIx::Class::Core/; __PACKAGE__->table('b'); __PACKAGE__->add_columns('b'); 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICNSTest/Result/��������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�017210� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICNSTest/Result/D.pm����������������������������������������������������0000644�0001750�0001750�00000000226�13555517102�017721� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBICNSTest::Result::D; use warnings; use strict; use base qw/DBIx::Class::Core/; __PACKAGE__->table('d'); __PACKAGE__->add_columns('d'); 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICNSTest/Result/B.pm����������������������������������������������������0000644�0001750�0001750�00000000226�13555517102�017717� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBICNSTest::Result::B; use warnings; use strict; use base qw/DBIx::Class::Core/; __PACKAGE__->table('b'); __PACKAGE__->add_columns('b'); 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICNSTest/Result/A.pm����������������������������������������������������0000644�0001750�0001750�00000000226�13555517102�017716� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBICNSTest::Result::A; use warnings; use strict; use base qw/DBIx::Class::Core/; __PACKAGE__->table('a'); __PACKAGE__->add_columns('a'); 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICNSTest/OtherRslt/�����������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�017660� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICNSTest/OtherRslt/D.pm�������������������������������������������������0000644�0001750�0001750�00000000231�13555517102�020365� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBICNSTest::OtherRslt::D; use warnings; use strict; use base qw/DBIx::Class::Core/; __PACKAGE__->table('d'); __PACKAGE__->add_columns('d'); 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICNSTest/RSet/����������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�016607� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICNSTest/RSet/C.pm������������������������������������������������������0000644�0001750�0001750�00000000141�13555517102�017313� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBICNSTest::RSet::C; use warnings; use strict; use base qw/DBIx::Class::ResultSet/; 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICNSTest/RSet/A.pm������������������������������������������������������0000644�0001750�0001750�00000000141�13555517102�017311� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBICNSTest::RSet::A; use warnings; use strict; use base qw/DBIx::Class::ResultSet/; 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICNSTest/Bogus/���������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�017011� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICNSTest/Bogus/Bigos.pm�������������������������������������������������0000644�0001750�0001750�00000000102�13555517102�020373� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBICNSTest::Bogus::Bigos; use warnings; use strict; 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICNSTest/Bogus/B.pm�����������������������������������������������������0000644�0001750�0001750�00000000226�13555517102�017520� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBICNSTest::Result::B; use warnings; use strict; use base qw/DBIx::Class::Core/; __PACKAGE__->table('b'); __PACKAGE__->add_columns('b'); 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICNSTest/Bogus/A.pm�����������������������������������������������������0000644�0001750�0001750�00000000225�13555517102�017516� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBICNSTest::Bogus::A; use warnings; use strict; use base qw/DBIx::Class::Core/; __PACKAGE__->table('a'); __PACKAGE__->add_columns('a'); 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICNSTest/RSBase.pm������������������������������������������������������0000644�0001750�0001750�00000000140�13555517102�017372� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBICNSTest::RSBase; use warnings; use strict; use base qw/DBIx::Class::ResultSet/; 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/ViewDeps/�����������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�015656� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/ViewDeps/Result/����������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�017134� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/ViewDeps/Result/TrackNumberFives.pm���������������������������������������0000644�0001750�0001750�00000001350�13555517102�022673� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE ViewDeps::Result::TrackNumberFives; use strict; use warnings; use base 'ViewDeps::Result::Track'; __PACKAGE__->table_class('DBIx::Class::ResultSource::View'); __PACKAGE__->table('track_number_fives'); __PACKAGE__->result_source_instance->view_definition( "SELECT id,title,cd,track_number FROM track WHERE track_number = '5'"); __PACKAGE__->add_columns( id => { data_type => 'integer', is_auto_increment => 1 }, title => { data_type => 'text' }, cd => { data_type => 'integer' }, track_number => { data_type => 'integer' }, ); __PACKAGE__->set_primary_key('id'); __PACKAGE__->belongs_to( 'cd', 'ViewDeps::Result::CD', { "foreign.id" => "self.cd" }, ); 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/ViewDeps/Result/Year2010CDs.pm��������������������������������������������0000644�0001750�0001750�00000001626�13555517102�021264� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE ViewDeps::Result::Year2010CDs; use strict; use warnings; use base 'DBIx::Class::Core'; __PACKAGE__->table_class('DBIx::Class::ResultSource::View'); __PACKAGE__->table('year_2010_cds'); __PACKAGE__->result_source_instance->view_definition( "SELECT id,title,artist,year,number_tracks FROM cd WHERE year = '2010'"); __PACKAGE__->add_columns( id => { data_type => 'integer', is_auto_increment => 1 }, title => { data_type => 'text' }, artist => { data_type => 'integer', is_nullable => 0 }, year => { data_type => 'integer' }, number_tracks => { data_type => 'integer' }, ); __PACKAGE__->set_primary_key('id'); __PACKAGE__->belongs_to( 'artist', 'ViewDeps::Result::Artist', { "foreign.id" => "self.artist" }, ); __PACKAGE__->has_many( 'tracks', 'ViewDeps::Result::Track', { "foreign.cd" => "self.id" }, ); 1; ����������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/ViewDeps/Result/Artist.pm�������������������������������������������������0000644�0001750�0001750�00000000640�13555517102�020730� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE ViewDeps::Result::Artist; use strict; use warnings; use base 'DBIx::Class::Core'; __PACKAGE__->table('artist'); __PACKAGE__->add_columns( id => { data_type => 'integer', is_auto_increment => 1 }, name => { data_type => 'text' }, ); __PACKAGE__->set_primary_key('id'); __PACKAGE__->has_many( 'cds', 'ViewDeps::Result::CD', { "foreign.artist" => "self.id" }, ); 1; ������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/ViewDeps/Result/ANameArtists.pm�������������������������������������������0000644�0001750�0001750�00000001132�13555517102�022012� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE ViewDeps::Result::ANameArtists; use strict; use warnings; use base 'DBIx::Class::Core'; __PACKAGE__->table_class('DBIx::Class::ResultSource::View'); __PACKAGE__->table('a_name_artists'); __PACKAGE__->result_source_instance->view_definition( "SELECT id,name FROM artist WHERE name like 'a%'" ); __PACKAGE__->add_columns( id => { data_type => 'integer', is_auto_increment => 1 }, name => { data_type => 'text' }, ); __PACKAGE__->set_primary_key('id'); __PACKAGE__->has_many( 'cds', 'ViewDeps::Result::CD', { "foreign.artist" => "self.id" }, ); 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/ViewDeps/Result/AbaNameArtists.pm�����������������������������������������0000644�0001750�0001750�00000001314�13555517102�022317� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE ViewDeps::Result::AbaNameArtists; use strict; use warnings; use base 'DBIx::Class::Core'; __PACKAGE__->table_class('DBIx::Class::ResultSource::View'); __PACKAGE__->table('aba_name_artists'); __PACKAGE__->result_source_instance->view_definition( "SELECT id,name FROM ab_name_artists WHERE name like 'aba%'" ); __PACKAGE__->result_source_instance->deploy_depends_on( ["ViewDeps::Result::AbNameArtists"] ); __PACKAGE__->add_columns( id => { data_type => 'integer', is_auto_increment => 1 }, name => { data_type => 'text' }, ); __PACKAGE__->set_primary_key('id'); __PACKAGE__->has_many( 'cds', 'ViewDeps::Result::CD', { "foreign.artist" => "self.id" }, ); 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/ViewDeps/Result/CD.pm�����������������������������������������������������0000644�0001750�0001750�00000001301�13555517102�017743� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE ViewDeps::Result::CD; use strict; use warnings; use base 'DBIx::Class::Core'; __PACKAGE__->table('cd'); __PACKAGE__->add_columns( id => { data_type => 'integer', is_auto_increment => 1 }, title => { data_type => 'text' }, artist => { data_type => 'integer', is_nullable => 0 }, year => { data_type => 'integer' }, number_tracks => { data_type => 'integer' }, ); __PACKAGE__->set_primary_key('id'); __PACKAGE__->belongs_to( 'artist', 'ViewDeps::Result::Artist', { "foreign.id" => "self.artist" }, ); __PACKAGE__->has_many( 'tracks', 'ViewDeps::Result::Track', { "foreign.cd" => "self.id" }, ); 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/ViewDeps/Result/AbaNameArtistsAnd2010CDsWithManyTracks.pm�����������������0000644�0001750�0001750�00000001710�13555517102�026470� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE ViewDeps::Result::AbaNameArtistsAnd2010CDsWithManyTracks; use strict; use warnings; use base 'DBIx::Class::Core'; __PACKAGE__->table_class('DBIx::Class::ResultSource::View'); __PACKAGE__->table('aba_name_artists_and_2010_cds_with_many_tracks'); __PACKAGE__->result_source_instance->view_definition( "SELECT aba.id,aba.name,cd.title,cd.year,cd.number_tracks FROM aba_name_artists aba JOIN year_2010_cds_with_many_tracks cd on (aba.id = cd.artist)" ); __PACKAGE__->result_source_instance->deploy_depends_on( ["ViewDeps::Result::AbNameArtists","ViewDeps::Result::Year2010CDsWithManyTracks"] ); __PACKAGE__->add_columns( id => { data_type => 'integer', is_auto_increment => 1 }, name => { data_type => 'text' }, title => { data_type => 'text' }, year => { data_type => 'integer' }, number_tracks => { data_type => 'integer' }, ); __PACKAGE__->set_primary_key('id'); 1; ��������������������������������������������������������DBIx-Class-0.082843/t/lib/ViewDeps/Result/AbNameArtists.pm������������������������������������������0000644�0001750�0001750�00000001307�13555517102�022160� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE ViewDeps::Result::AbNameArtists; use strict; use warnings; use base 'DBIx::Class::Core'; __PACKAGE__->table_class('DBIx::Class::ResultSource::View'); __PACKAGE__->table('ab_name_artists'); __PACKAGE__->result_source_instance->view_definition( "SELECT id,name FROM a_name_artists WHERE name like 'ab%'" ); __PACKAGE__->result_source_instance->deploy_depends_on( ["ViewDeps::Result::ANameArtists"] ); __PACKAGE__->add_columns( id => { data_type => 'integer', is_auto_increment => 1 }, name => { data_type => 'text' }, ); __PACKAGE__->set_primary_key('id'); __PACKAGE__->has_many( 'cds', 'ViewDeps::Result::CD', { "foreign.artist" => "self.id" }, ); 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/ViewDeps/Result/Artwork.pm������������������������������������������������0000644�0001750�0001750�00000000737�13555517102�021122� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE ViewDeps::Result::Artwork; use strict; use warnings; use base 'DBIx::Class::Core'; __PACKAGE__->table('artwork'); __PACKAGE__->add_columns( id => { data_type => 'integer', is_auto_increment => 1 }, cd => { data_type => 'integer' }, file => { data_type => 'text' }, ); __PACKAGE__->set_primary_key('id'); __PACKAGE__->belongs_to( 'cd', 'ViewDeps::Result::CD', { "foreign.id" => "self.cd" }, ); 1; ���������������������������������DBIx-Class-0.082843/t/lib/ViewDeps/Result/Track.pm��������������������������������������������������0000644�0001750�0001750�00000001013�13555517102�020521� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE ViewDeps::Result::Track; use strict; use warnings; use base 'DBIx::Class::Core'; __PACKAGE__->table('track'); __PACKAGE__->add_columns( id => { data_type => 'integer', is_auto_increment => 1 }, title => { data_type => 'text' }, cd => { data_type => 'integer' }, track_number => { data_type => 'integer' }, ); __PACKAGE__->set_primary_key('id'); __PACKAGE__->belongs_to( 'cd', 'ViewDeps::Result::CD', { "foreign.id" => "self.cd" }, ); 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/ViewDeps/Result/Year2010CDsWithManyTracks.pm������������������������������0000644�0001750�0001750�00000002243�13555517102�024111� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE ViewDeps::Result::Year2010CDsWithManyTracks; use strict; use warnings; use base 'ViewDeps::Result::Year2010CDs'; __PACKAGE__->table_class('DBIx::Class::ResultSource::View'); __PACKAGE__->table('year_2010_cds_with_many_tracks'); __PACKAGE__->result_source_instance->view_definition( "SELECT cd.id,cd.title,cd.artist,cd.year,cd.number_tracks,art.file FROM year_2010_cds cd JOIN artwork art on art.cd = cd.id WHERE cd.number_tracks > 10" ); __PACKAGE__->result_source_instance->deploy_depends_on( ["ViewDeps::Result::Year2010CDs"] ); __PACKAGE__->add_columns( id => { data_type => 'integer', is_auto_increment => 1 }, title => { data_type => 'text' }, artist => { data_type => 'integer', is_nullable => 0 }, year => { data_type => 'integer' }, number_tracks => { data_type => 'integer' }, file => { data_type => 'integer' }, ); __PACKAGE__->set_primary_key('id'); __PACKAGE__->belongs_to( 'artist', 'ViewDeps::Result::Artist', { "foreign.id" => "self.artist" }, ); __PACKAGE__->has_many( 'tracks', 'ViewDeps::Result::Track', { "foreign.cd" => "self.id" }, ); 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICVersion_v2.pm���������������������������������������������������������0000644�0001750�0001750�00000002300�13555517102�017127� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBICVersion::Table; use base 'DBIx::Class::Core'; use strict; use warnings; __PACKAGE__->table('TestVersion'); __PACKAGE__->add_columns ( 'Version' => { 'data_type' => 'INTEGER', 'is_auto_increment' => 1, 'default_value' => undef, 'is_foreign_key' => 0, 'is_nullable' => 0, 'size' => '' }, 'VersionName' => { 'data_type' => 'VARCHAR', 'is_auto_increment' => 0, 'default_value' => undef, 'is_foreign_key' => 0, 'is_nullable' => 0, 'size' => '10' }, 'NewVersionName' => { 'data_type' => 'VARCHAR', 'is_auto_increment' => 0, 'default_value' => undef, 'is_foreign_key' => 0, 'is_nullable' => 1, 'size' => '20' } ); __PACKAGE__->set_primary_key('Version'); package DBICVersion::Schema; use base 'DBICTest::BaseSchema'; use strict; use warnings; our $VERSION = '2.0'; __PACKAGE__->register_class('Table', 'DBICVersion::Table'); __PACKAGE__->load_components('+DBIx::Class::Schema::Versioned'); __PACKAGE__->upgrade_directory("t/var/versioning_ddl-$$"); __PACKAGE__->backup_directory("t/var/versioning_backup-$$"); 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/test_deploy/��������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�016463� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/test_deploy/DBICTest-Schema-1.x-SQLite.sql��������������������������������0000644�0001750�0001750�00000000460�13555517102�023476� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������-- -- This table line should not be skipped -- CREATE TABLE artist ( artistid INTEGER PRIMARY KEY NOT NULL, name varchar(100), rank integer NOT NULL DEFAULT 13, charfield char(10) ); CREATE INDEX artist_name_hookidx ON artist (name); -- This line should error if artist was not parsed correctly ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/testinclude/��������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�016453� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/testinclude/DBICTestConfig.pm���������������������������������������������0000644�0001750�0001750�00000000511�14240132261�021454� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBICTestConfig; use warnings; use strict; use base 'DBICTest::BaseSchema'; sub connect { my($self, @opt) = @_; @opt == 4 and $opt[0] eq 'klaatu' and $opt[1] eq 'barada' and $opt[2] eq 'nikto' and $opt[3]->{ignore_version} and exit 71; # this is what the test will expect to see exit 1; } 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/testinclude/DBICTestAdminInc.pm�������������������������������������������0000644�0001750�0001750�00000000237�14240132261�021736� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBICTestAdminInc; use warnings; use strict; use base 'DBICTest::BaseSchema'; sub connect { exit 70 } # this is what the test will expect to see 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICTest.pm���������������������������������������������������������������0000644�0001750�0001750�00000037435�14240132261�016022� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBICTest; use strict; use warnings; use DBICTest::Util qw( local_umask await_flock dbg DEBUG_TEST_CONCURRENCY_LOCKS ); use DBICTest::Schema; use DBICTest::Util::LeakTracer qw/populate_weakregistry assert_empty_weakregistry/; use DBIx::Class::_Util 'detected_reinvoked_destructor'; use Carp; use Path::Class::File (); use File::Spec; use Fcntl qw/:DEFAULT :flock/; use Config; use Scope::Guard (); =head1 NAME DBICTest - Library to be used by DBIx::Class test scripts =head1 SYNOPSIS use lib qw(t/lib); use DBICTest; use Test::More; my $schema = DBICTest->init_schema(); =head1 DESCRIPTION This module provides the basic utilities to write tests against DBIx::Class. =head1 EXPORTS The module does not export anything by default, nor provides individual function exports in the conventional sense. Instead the following tags are recognized: =head2 :DiffSQL Same as C<use SQL::Abstract::Test qw(L<is_same_sql_bind|SQL::Abstract::Test/is_same_sql_bind> L<is_same_sql|SQL::Abstract::Test/is_same_sql> L<is_same_bind|SQL::Abstract::Test/is_same_bind>)> =head2 :GlobalLock Some tests are very time sensitive and need to run on their own, without being disturbed by anything else grabbing CPU or disk IO. Hence why everything using C<DBICTest> grabs a shared lock, and the few tests that request a C<:GlobalLock> will ask for an exclusive one and block until they can get it. =head1 METHODS =head2 init_schema my $schema = DBICTest->init_schema( no_deploy=>1, no_populate=>1, storage_type=>'::DBI::Replicated', storage_type_args=>{ balancer_type=>'DBIx::Class::Storage::DBI::Replicated::Balancer::Random' }, ); This method removes the test SQLite database in t/var/DBIxClass.db and then creates a new, empty database. This method will call L<deploy_schema()|/deploy_schema> by default, unless the C<no_deploy> flag is set. Also, by default, this method will call L<populate_schema()|/populate_schema> by default, unless the C<no_deploy> or C<no_populate> flags are set. =cut # see L</:GlobalLock> our ($global_lock_fh, $global_exclusive_lock); sub import { my $self = shift; my $lockpath = DBICTest::RunMode->tmpdir->file('_dbictest_global.lock'); { my $u = local_umask(0); # so that the file opens as 666, and any user can lock sysopen ($global_lock_fh, $lockpath, O_RDWR|O_CREAT) or die "Unable to open $lockpath: $!"; } for my $exp (@_) { if ($exp eq ':GlobalLock') { DEBUG_TEST_CONCURRENCY_LOCKS > 1 and dbg "Waiting for EXCLUSIVE global lock..."; await_flock ($global_lock_fh, LOCK_EX) or die "Unable to lock $lockpath: $!"; DEBUG_TEST_CONCURRENCY_LOCKS > 1 and dbg "Got EXCLUSIVE global lock"; $global_exclusive_lock = 1; } elsif ($exp eq ':DiffSQL') { require DBIx::Class::SQLMaker; require SQL::Abstract::Test; my $into = caller(0); for (qw(is_same_sql_bind is_same_sql is_same_bind)) { no strict 'refs'; *{"${into}::$_"} = \&{"SQL::Abstract::Test::$_"}; } } else { croak "Unknown export $exp requested from $self"; } } unless ($global_exclusive_lock) { DEBUG_TEST_CONCURRENCY_LOCKS > 1 and dbg "Waiting for SHARED global lock..."; await_flock ($global_lock_fh, LOCK_SH) or die "Unable to lock $lockpath: $!"; DEBUG_TEST_CONCURRENCY_LOCKS > 1 and dbg "Got SHARED global lock"; } } END { # referencing here delays destruction even more if ($global_lock_fh) { DEBUG_TEST_CONCURRENCY_LOCKS > 1 and dbg "Release @{[ $global_exclusive_lock ? 'EXCLUSIVE' : 'SHARED' ]} global lock (END)"; 1; } } { my $dir = Path::Class::File->new(__FILE__)->dir->parent->subdir('var'); $dir->mkpath unless -d "$dir"; $dir = "$dir"; sub _sqlite_dbfilename { my $holder = $ENV{DBICTEST_LOCK_HOLDER} || $$; $holder = $$ if $holder == -1; # useful for missing cleanup debugging #if ( $holder == $$) { # my $x = $0; # $x =~ s/\//#/g; # $holder .= "-$x"; #} return "$dir/DBIxClass-$holder.db"; } END { _cleanup_dbfile(); } } $SIG{INT} = sub { _cleanup_dbfile(); exit 1 }; my $need_global_cleanup; sub _cleanup_dbfile { # cleanup if this is us if ( ! $ENV{DBICTEST_LOCK_HOLDER} or $ENV{DBICTEST_LOCK_HOLDER} == -1 or $ENV{DBICTEST_LOCK_HOLDER} == $$ ) { if ($need_global_cleanup and my $dbh = DBICTest->schema->storage->_dbh) { $dbh->disconnect; } my $db_file = _sqlite_dbfilename(); unlink $_ for ($db_file, "${db_file}-journal"); } } sub has_custom_dsn { return $ENV{"DBICTEST_DSN"} ? 1:0; } sub _sqlite_dbname { my $self = shift; my %args = @_; return $self->_sqlite_dbfilename if ( defined $args{sqlite_use_file} ? $args{sqlite_use_file} : $ENV{'DBICTEST_SQLITE_USE_FILE'} ); return ":memory:"; } sub _database { my $self = shift; my %args = @_; if ($ENV{DBICTEST_DSN}) { return ( (map { $ENV{"DBICTEST_${_}"} || '' } qw/DSN DBUSER DBPASS/), { AutoCommit => 1, %args }, ); } my $db_file = $self->_sqlite_dbname(%args); for ($db_file, "${db_file}-journal") { next unless -e $_; unlink ($_) or carp ( "Unable to unlink existing test database file $_ ($!), creation of fresh database / further tests may fail!" ); } return ("dbi:SQLite:${db_file}", '', '', { AutoCommit => 1, # this is executed on every connect, and thus installs a disconnect/DESTROY # guard for every new $dbh on_connect_do => sub { my $storage = shift; my $dbh = $storage->_get_dbh; # no fsync on commit $dbh->do ('PRAGMA synchronous = OFF'); if ( $ENV{DBICTEST_SQLITE_REVERSE_DEFAULT_ORDER} and # the pragma does not work correctly before libsqlite 3.7.9 $storage->_server_info->{normalized_dbms_version} >= 3.007009 ) { $dbh->do ('PRAGMA reverse_unordered_selects = ON'); } # set a *DBI* disconnect callback, to make sure the physical SQLite # file is still there (i.e. the test does not attempt to delete # an open database, which fails on Win32) if (my $guard_cb = __mk_disconnect_guard($db_file)) { $dbh->{Callbacks} = { connect => sub { $guard_cb->('connect') }, disconnect => sub { $guard_cb->('disconnect') }, DESTROY => sub { &detected_reinvoked_destructor; $guard_cb->('DESTROY') }, }; } }, %args, }); } sub __mk_disconnect_guard { my $db_file = shift; return if ( # this perl leaks handles, delaying DESTROY, can't work right DBIx::Class::_ENV_::PEEPEENESS or ! -f $db_file ); my $orig_inode = (stat($db_file))[1] or return; my $clan_connect_caller = '*UNKNOWN*'; my $i; while ( my ($pack, $file, $line) = caller(++$i) ) { next if $file eq __FILE__; next if $pack =~ /^DBIx::Class|^Try::Tiny/; $clan_connect_caller = "$file line $line"; } my $failed_once = 0; my $connected = 1; return sub { return if $failed_once; my $event = shift; if ($event eq 'connect') { # this is necessary in case we are disconnected and connected again, all within the same $dbh object $connected = 1; return; } elsif ($event eq 'disconnect') { return unless $connected; # we already disconnected earlier $connected = 0; } elsif ($event eq 'DESTROY' and ! $connected ) { return; } my $fail_reason; if (! -e $db_file) { $fail_reason = 'is missing'; } else { my $cur_inode = (stat($db_file))[1]; if ($orig_inode != $cur_inode) { my @inodes = ($orig_inode, $cur_inode); # unless this is a fixed perl (P5RT#84590) pack/unpack before display # to match the unsigned longs returned by `stat` @inodes = map { unpack ('L', pack ('l', $_) ) } @inodes unless $Config{st_ino_size}; $fail_reason = sprintf 'was recreated (initially inode %s, now %s)', @inodes ; } } if ($fail_reason) { $failed_once++; require Test::Builder; my $t = Test::Builder->new; local $Test::Builder::Level = $Test::Builder::Level + 3; $t->ok (0, "$db_file originally created at $clan_connect_caller $fail_reason before $event " . 'of DBI handle - a strong indicator that the database file was tampered with while ' . 'still being open. This action would fail massively if running under Win32, hence ' . 'we make sure it fails on any OS :)' ); } return; # this empty return is a DBI requirement }; } my $weak_registry = {}; sub init_schema { my $self = shift; my %args = @_; my $schema; if ($args{compose_connection}) { $need_global_cleanup = 1; $schema = DBICTest::Schema->compose_connection( 'DBICTest', $self->_database(%args) ); } else { $schema = DBICTest::Schema->compose_namespace('DBICTest'); } if( $args{storage_type}) { $schema->storage_type($args{storage_type}); } if ( !$args{no_connect} ) { $schema = $schema->connect($self->_database(%args)); } if ( !$args{no_deploy} ) { __PACKAGE__->deploy_schema( $schema, $args{deploy_args} ); __PACKAGE__->populate_schema( $schema ) if( !$args{no_populate} ); } populate_weakregistry ( $weak_registry, $schema->storage ) if $INC{'Test/Builder.pm'} and $schema->storage; return $schema; } END { assert_empty_weakregistry($weak_registry, 'quiet'); } =head2 deploy_schema DBICTest->deploy_schema( $schema ); This method does one of two things to the schema. It can either call the experimental $schema->deploy() if the DBICTEST_SQLT_DEPLOY environment variable is set, otherwise the default is to read in the t/lib/sqlite.sql file and execute the SQL within. Either way you end up with a fresh set of tables for testing. =cut sub deploy_schema { my $self = shift; my $schema = shift; my $args = shift || {}; my $guard; if ( ($ENV{TRAVIS}||'') eq 'true' and my $old_dbg = $schema->storage->debug ) { $guard = Scope::Guard->new(sub { $schema->storage->debug($old_dbg) }); $schema->storage->debug(0); } if ($ENV{"DBICTEST_SQLT_DEPLOY"}) { $schema->deploy($args); } else { my $filename = Path::Class::File->new(__FILE__)->dir ->file('sqlite.sql')->stringify; my $sql = do { local (@ARGV, $/) = $filename ; <> }; for my $chunk ( split (/;\s*\n+/, $sql) ) { if ( $chunk =~ / ^ (?! --\s* ) \S /xm ) { # there is some real sql in the chunk - a non-space at the start of the string which is not a comment $schema->storage->dbh_do(sub { $_[1]->do($chunk) }) or print "Error on SQL: $chunk\n"; } } } return; } =head2 populate_schema DBICTest->populate_schema( $schema ); After you deploy your schema you can use this method to populate the tables with test data. =cut sub populate_schema { my $self = shift; my $schema = shift; my $guard; if ( ($ENV{TRAVIS}||'') eq 'true' and my $old_dbg = $schema->storage->debug ) { $guard = Scope::Guard->new(sub { $schema->storage->debug($old_dbg) }); $schema->storage->debug(0); } $schema->populate('Genre', [ [qw/genreid name/], [qw/1 emo /], ]); $schema->populate('Artist', [ [ qw/artistid name/ ], [ 1, 'Caterwauler McCrae' ], [ 2, 'Random Boy Band' ], [ 3, 'We Are Goth' ], ]); $schema->populate('CD', [ [ qw/cdid artist title year genreid/ ], [ 1, 1, "Spoonful of bees", 1999, 1 ], [ 2, 1, "Forkful of bees", 2001 ], [ 3, 1, "Caterwaulin' Blues", 1997 ], [ 4, 2, "Generic Manufactured Singles", 2001 ], [ 5, 3, "Come Be Depressed With Us", 1998 ], ]); $schema->populate('LinerNotes', [ [ qw/liner_id notes/ ], [ 2, "Buy Whiskey!" ], [ 4, "Buy Merch!" ], [ 5, "Kill Yourself!" ], ]); $schema->populate('Tag', [ [ qw/tagid cd tag/ ], [ 1, 1, "Blue" ], [ 2, 2, "Blue" ], [ 3, 3, "Blue" ], [ 4, 5, "Blue" ], [ 5, 2, "Cheesy" ], [ 6, 4, "Cheesy" ], [ 7, 5, "Cheesy" ], [ 8, 2, "Shiny" ], [ 9, 4, "Shiny" ], ]); $schema->populate('TwoKeys', [ [ qw/artist cd/ ], [ 1, 1 ], [ 1, 2 ], [ 2, 2 ], ]); $schema->populate('FourKeys', [ [ qw/foo bar hello goodbye sensors/ ], [ 1, 2, 3, 4, 'online' ], [ 5, 4, 3, 6, 'offline' ], ]); $schema->populate('OneKey', [ [ qw/id artist cd/ ], [ 1, 1, 1 ], [ 2, 1, 2 ], [ 3, 2, 2 ], ]); $schema->populate('SelfRef', [ [ qw/id name/ ], [ 1, 'First' ], [ 2, 'Second' ], ]); $schema->populate('SelfRefAlias', [ [ qw/self_ref alias/ ], [ 1, 2 ] ]); $schema->populate('ArtistUndirectedMap', [ [ qw/id1 id2/ ], [ 1, 2 ] ]); $schema->populate('Producer', [ [ qw/producerid name/ ], [ 1, 'Matt S Trout' ], [ 2, 'Bob The Builder' ], [ 3, 'Fred The Phenotype' ], ]); $schema->populate('CD_to_Producer', [ [ qw/cd producer/ ], [ 1, 1 ], [ 1, 2 ], [ 1, 3 ], ]); $schema->populate('TreeLike', [ [ qw/id parent name/ ], [ 1, undef, 'root' ], [ 2, 1, 'foo' ], [ 3, 2, 'bar' ], [ 6, 2, 'blop' ], [ 4, 3, 'baz' ], [ 5, 4, 'quux' ], [ 7, 3, 'fong' ], ]); $schema->populate('Track', [ [ qw/trackid cd position title/ ], [ 4, 2, 1, "Stung with Success"], [ 5, 2, 2, "Stripy"], [ 6, 2, 3, "Sticky Honey"], [ 7, 3, 1, "Yowlin"], [ 8, 3, 2, "Howlin"], [ 9, 3, 3, "Fowlin"], [ 10, 4, 1, "Boring Name"], [ 11, 4, 2, "Boring Song"], [ 12, 4, 3, "No More Ideas"], [ 13, 5, 1, "Sad"], [ 14, 5, 2, "Under The Weather"], [ 15, 5, 3, "Suicidal"], [ 16, 1, 1, "The Bees Knees"], [ 17, 1, 2, "Apiary"], [ 18, 1, 3, "Beehind You"], ]); $schema->populate('Event', [ [ qw/id starts_at created_on varchar_date varchar_datetime skip_inflation/ ], [ 1, '2006-04-25 22:24:33', '2006-06-22 21:00:05', '2006-07-23', '2006-05-22 19:05:07', '2006-04-21 18:04:06'], ]); $schema->populate('Link', [ [ qw/id url title/ ], [ 1, '', 'aaa' ] ]); $schema->populate('Bookmark', [ [ qw/id link/ ], [ 1, 1 ] ]); $schema->populate('Collection', [ [ qw/collectionid name/ ], [ 1, "Tools" ], [ 2, "Body Parts" ], ]); $schema->populate('TypedObject', [ [ qw/objectid type value/ ], [ 1, "pointy", "Awl" ], [ 2, "round", "Bearing" ], [ 3, "pointy", "Knife" ], [ 4, "pointy", "Tooth" ], [ 5, "round", "Head" ], ]); $schema->populate('CollectionObject', [ [ qw/collection object/ ], [ 1, 1 ], [ 1, 2 ], [ 1, 3 ], [ 2, 4 ], [ 2, 5 ], ]); $schema->populate('Owners', [ [ qw/id name/ ], [ 1, "Newton" ], [ 2, "Waltham" ], ]); $schema->populate('BooksInLibrary', [ [ qw/id owner title source price/ ], [ 1, 1, "Programming Perl", "Library", 23 ], [ 2, 1, "Dynamical Systems", "Library", 37 ], [ 3, 2, "Best Recipe Cookbook", "Library", 65 ], ]); } 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/ViewDepsBad/��������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�016265� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/ViewDepsBad/Result/�������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�017543� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/ViewDepsBad/Result/Year2010CDsWithManyTracks.pm���������������������������0000644�0001750�0001750�00000002262�13555517102�024521� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE ViewDepsBad::Result::Year2010CDsWithManyTracks; use strict; use warnings; use base 'ViewDepsBad::Result::Year2010CDs'; __PACKAGE__->table_class('DBIx::Class::ResultSource::View'); __PACKAGE__->table('year_2010_cds_with_many_tracks'); __PACKAGE__->result_source_instance->view_definition( "SELECT cd.id,cd.title,cd.artist,cd.year,cd.number_tracks,art.file FROM year_2010_cds cd JOIN artwork art on art.cd = cd.id WHERE cd.number_tracks > 10" ); __PACKAGE__->result_source_instance->deploy_depends_on( ["ViewDepsBad::Result::Year2010CDs"] ); __PACKAGE__->add_columns( id => { data_type => 'integer', is_auto_increment => 1 }, title => { data_type => 'text' }, artist => { data_type => 'integer', is_nullable => 0 }, year => { data_type => 'integer' }, number_tracks => { data_type => 'integer' }, file => { data_type => 'integer' }, ); __PACKAGE__->set_primary_key('id'); __PACKAGE__->belongs_to( 'artist', 'ViewDepsBad::Result::Artist', { "foreign.id" => "self.artist" }, ); __PACKAGE__->has_many( 'tracks', 'ViewDepsBad::Result::Track', { "foreign.cd" => "self.id" }, ); 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/ViewDepsBad/Result/TrackNumberFives.pm������������������������������������0000644�0001750�0001750�00000001361�13555517102�023304� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE ViewDepsBad::Result::TrackNumberFives; use strict; use warnings; use base 'ViewDepsBad::Result::Track'; __PACKAGE__->table_class('DBIx::Class::ResultSource::View'); __PACKAGE__->table('track_number_fives'); __PACKAGE__->result_source_instance->view_definition( "SELECT id,title,cd,track_number FROM track WHERE track_number = '5'"); __PACKAGE__->add_columns( id => { data_type => 'integer', is_auto_increment => 1 }, title => { data_type => 'text' }, cd => { data_type => 'integer' }, track_number => { data_type => 'integer' }, ); __PACKAGE__->set_primary_key('id'); __PACKAGE__->belongs_to( 'cd', 'ViewDepsBad::Result::CD', { "foreign.id" => "self.cd" }, ); 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/ViewDepsBad/Result/AbNameArtists.pm���������������������������������������0000644�0001750�0001750�00000001320�13555517102�022562� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE ViewDepsBad::Result::AbNameArtists; use strict; use warnings; use base 'DBIx::Class::Core'; __PACKAGE__->table_class('DBIx::Class::ResultSource::View'); __PACKAGE__->table('ab_name_artists'); __PACKAGE__->result_source_instance->view_definition( "SELECT id,name FROM a_name_artists WHERE name like 'ab%'" ); __PACKAGE__->result_source_instance->deploy_depends_on( ["ViewDepsBad::Result::ANameArtists"] ); __PACKAGE__->add_columns( id => { data_type => 'integer', is_auto_increment => 1 }, name => { data_type => 'text' }, ); __PACKAGE__->set_primary_key('id'); __PACKAGE__->has_many( 'cds', 'ViewDepsBad::Result::CD', { "foreign.artist" => "self.id" }, ); 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/ViewDepsBad/Result/ANameArtists.pm����������������������������������������0000644�0001750�0001750�00000001135�13555517102�022424� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE ViewDepsBad::Result::ANameArtists; use strict; use warnings; use base 'DBIx::Class::Core'; __PACKAGE__->table_class('DBIx::Class::ResultSource::View'); __PACKAGE__->table('a_name_artists'); __PACKAGE__->result_source_instance->view_definition( "SELECT id,name FROM artist WHERE name like 'a%'" ); __PACKAGE__->add_columns( id => { data_type => 'integer', is_auto_increment => 1 }, name => { data_type => 'text' }, ); __PACKAGE__->set_primary_key('id'); __PACKAGE__->has_many( 'cds', 'ViewDeps::Result::CD', { "foreign.artist" => "self.id" }, ); 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/ViewDepsBad/Result/Year2010CDs.pm�����������������������������������������0000644�0001750�0001750�00000001637�13555517102�021675� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE ViewDepsBad::Result::Year2010CDs; use strict; use warnings; use base 'DBIx::Class::Core'; __PACKAGE__->table_class('DBIx::Class::ResultSource::View'); __PACKAGE__->table('year_2010_cds'); __PACKAGE__->result_source_instance->view_definition( "SELECT id,title,artist,year,number_tracks FROM cd WHERE year = '2010'"); __PACKAGE__->add_columns( id => { data_type => 'integer', is_auto_increment => 1 }, title => { data_type => 'text' }, artist => { data_type => 'integer', is_nullable => 0 }, year => { data_type => 'integer' }, number_tracks => { data_type => 'integer' }, ); __PACKAGE__->set_primary_key('id'); __PACKAGE__->belongs_to( 'artist', 'ViewDepsBad::Result::Artist', { "foreign.id" => "self.artist" }, ); __PACKAGE__->has_many( 'tracks', 'ViewDepsBad::Result::Track', { "foreign.cd" => "self.id" }, ); 1; �������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/ViewDepsBad/Result/Track.pm�����������������������������������������������0000644�0001750�0001750�00000001021�13555517102�021127� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE ViewDepsBad::Result::Track; use strict; use warnings; use base 'DBIx::Class::Core'; __PACKAGE__->table('track'); __PACKAGE__->add_columns( id => { data_type => 'integer', is_auto_increment => 1 }, title => { data_type => 'text' }, cd => { data_type => 'integer' }, track_number => { data_type => 'integer' }, ); __PACKAGE__->set_primary_key('id'); __PACKAGE__->belongs_to( 'cd', 'ViewDepsBad::Result::CD', { "foreign.id" => "self.cd" }, ); 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/ViewDepsBad/Result/Artwork.pm���������������������������������������������0000644�0001750�0001750�00000000745�13555517102�021530� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE ViewDepsBad::Result::Artwork; use strict; use warnings; use base 'DBIx::Class::Core'; __PACKAGE__->table('artwork'); __PACKAGE__->add_columns( id => { data_type => 'integer', is_auto_increment => 1 }, cd => { data_type => 'integer' }, file => { data_type => 'text' }, ); __PACKAGE__->set_primary_key('id'); __PACKAGE__->belongs_to( 'cd', 'ViewDepsBad::Result::CD', { "foreign.id" => "self.cd" }, ); 1; ���������������������������DBIx-Class-0.082843/t/lib/ViewDepsBad/Result/AbaNameArtists.pm��������������������������������������0000644�0001750�0001750�00000001424�13555517102�022730� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE ViewDepsBad::Result::AbaNameArtists; use strict; use warnings; use base 'DBIx::Class::Core'; __PACKAGE__->table_class('DBIx::Class::ResultSource::View'); __PACKAGE__->table('aba_name_artists'); __PACKAGE__->result_source_instance->view_definition( "SELECT id,name FROM ab_name_artists WHERE name like 'aba%'" ); __PACKAGE__->result_source_instance->deploy_depends_on( ["ViewDepsBad::Result::AbNameArtists", "ViewDepsBad::Result::AbaNameArtistsAnd2010CDsWithManyTracks"] ); __PACKAGE__->add_columns( id => { data_type => 'integer', is_auto_increment => 1 }, name => { data_type => 'text' }, ); __PACKAGE__->set_primary_key('id'); __PACKAGE__->has_many( 'cds', 'ViewDepsBad::Result::CD', { "foreign.artist" => "self.id" }, ); 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/ViewDepsBad/Result/AbaNameArtistsAnd2010CDsWithManyTracks.pm��������������0000644�0001750�0001750�00000001721�13555517102�027101� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE ViewDepsBad::Result::AbaNameArtistsAnd2010CDsWithManyTracks; use strict; use warnings; use base 'DBIx::Class::Core'; __PACKAGE__->table_class('DBIx::Class::ResultSource::View'); __PACKAGE__->table('aba_name_artists_and_2010_cds_with_many_tracks'); __PACKAGE__->result_source_instance->view_definition( "SELECT aba.id,aba.name,cd.title,cd.year,cd.number_tracks FROM aba_name_artists aba JOIN year_2010_cds_with_many_tracks cd on (aba.id = cd.artist)" ); __PACKAGE__->result_source_instance->deploy_depends_on( ["ViewDepsBad::Result::AbNameArtists","ViewDepsBad::Result::Year2010CDsWithManyTracks"] ); __PACKAGE__->add_columns( id => { data_type => 'integer', is_auto_increment => 1 }, name => { data_type => 'text' }, title => { data_type => 'text' }, year => { data_type => 'integer' }, number_tracks => { data_type => 'integer' }, ); __PACKAGE__->set_primary_key('id'); 1; �����������������������������������������������DBIx-Class-0.082843/t/lib/ViewDepsBad/Result/CD.pm��������������������������������������������������0000644�0001750�0001750�00000001312�13555517102�020354� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE ViewDepsBad::Result::CD; use strict; use warnings; use base 'DBIx::Class::Core'; __PACKAGE__->table('cd'); __PACKAGE__->add_columns( id => { data_type => 'integer', is_auto_increment => 1 }, title => { data_type => 'text' }, artist => { data_type => 'integer', is_nullable => 0 }, year => { data_type => 'integer' }, number_tracks => { data_type => 'integer' }, ); __PACKAGE__->set_primary_key('id'); __PACKAGE__->belongs_to( 'artist', 'ViewDepsBad::Result::Artist', { "foreign.id" => "self.artist" }, ); __PACKAGE__->has_many( 'tracks', 'ViewDepsBad::Result::Track', { "foreign.cd" => "self.id" }, ); 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/ViewDepsBad/Result/Artist.pm����������������������������������������������0000644�0001750�0001750�00000000646�13555517102�021345� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE ViewDepsBad::Result::Artist; use strict; use warnings; use base 'DBIx::Class::Core'; __PACKAGE__->table('artist'); __PACKAGE__->add_columns( id => { data_type => 'integer', is_auto_increment => 1 }, name => { data_type => 'text' }, ); __PACKAGE__->set_primary_key('id'); __PACKAGE__->has_many( 'cds', 'ViewDepsBad::Result::CD', { "foreign.artist" => "self.id" }, ); 1; ������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICVersion_v1.pm���������������������������������������������������������0000644�0001750�0001750�00000001743�13555517102�017140� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBICVersion::Table; use base 'DBIx::Class::Core'; use strict; use warnings; __PACKAGE__->table('TestVersion'); __PACKAGE__->add_columns ( 'Version' => { 'data_type' => 'INTEGER', 'is_auto_increment' => 1, 'default_value' => undef, 'is_foreign_key' => 0, 'is_nullable' => 0, 'size' => '' }, 'VersionName' => { 'data_type' => 'VARCHAR', 'is_auto_increment' => 0, 'default_value' => undef, 'is_foreign_key' => 0, 'is_nullable' => 0, 'size' => '10' }, ); __PACKAGE__->set_primary_key('Version'); package DBICVersion::Schema; use base 'DBICTest::BaseSchema'; use strict; use warnings; our $VERSION = '1.0'; __PACKAGE__->register_class('Table', 'DBICVersion::Table'); __PACKAGE__->load_components('+DBIx::Class::Schema::Versioned'); __PACKAGE__->upgrade_directory("t/var/versioning_ddl-$$"); sub ordered_schema_versions { return('1.0','2.0','3.0'); } 1; �����������������������������DBIx-Class-0.082843/t/lib/ViewDeps.pm���������������������������������������������������������������0000644�0001750�0001750�00000000357�13555517102�016211� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE ViewDeps; ## Used in 105view_deps.t use strict; use warnings; use base 'DBICTest::BaseSchema'; __PACKAGE__->load_namespaces; sub sqlt_deploy_hook { my $self = shift; $self->{sqlt} = shift; } 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/awesome.json��������������������������������������������������������������0000644�0001750�0001750�00000000034�13555517102�016450� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������{"indent_string":"frioux"} ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/sqlite.sql����������������������������������������������������������������0000644�0001750�0001750�00000025722�14240676412�016154� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������CREATE TABLE "artist" ( "artistid" INTEGER PRIMARY KEY NOT NULL, "name" varchar(100), "rank" integer NOT NULL DEFAULT 13, "charfield" char(10) ); CREATE INDEX "artist_name_hookidx" ON "artist" ("name"); CREATE UNIQUE INDEX "artist_name" ON "artist" ("name"); CREATE UNIQUE INDEX "u_nullable" ON "artist" ("charfield", "rank"); CREATE TABLE "bindtype_test" ( "id" INTEGER PRIMARY KEY NOT NULL, "bytea" blob, "blob" blob, "clob" clob, "a_memo" memo ); CREATE TABLE "collection" ( "collectionid" INTEGER PRIMARY KEY NOT NULL, "name" varchar(100) NOT NULL ); CREATE TABLE "encoded" ( "id" INTEGER PRIMARY KEY NOT NULL, "encoded" varchar(100) ); CREATE TABLE "event" ( "id" INTEGER PRIMARY KEY NOT NULL, "starts_at" date NOT NULL, "created_on" timestamp NOT NULL, "varchar_date" varchar(20), "varchar_datetime" varchar(20), "skip_inflation" datetime, "ts_without_tz" datetime ); CREATE TABLE "fourkeys" ( "foo" integer NOT NULL, "bar" integer NOT NULL, "hello" integer NOT NULL, "goodbye" integer NOT NULL, "sensors" character(10) NOT NULL, "read_count" int, PRIMARY KEY ("foo", "bar", "hello", "goodbye") ); CREATE TABLE "genre" ( "genreid" INTEGER PRIMARY KEY NOT NULL, "name" varchar(100) NOT NULL ); CREATE UNIQUE INDEX "genre_name" ON "genre" ("name"); CREATE TABLE "link" ( "id" INTEGER PRIMARY KEY NOT NULL, "url" varchar(100), "title" varchar(100) ); CREATE TABLE "money_test" ( "id" INTEGER PRIMARY KEY NOT NULL, "amount" money ); CREATE TABLE "noprimarykey" ( "foo" integer NOT NULL, "bar" integer NOT NULL, "baz" integer NOT NULL ); CREATE UNIQUE INDEX "foo_bar" ON "noprimarykey" ("foo", "bar"); CREATE TABLE "onekey" ( "id" INTEGER PRIMARY KEY NOT NULL, "artist" integer NOT NULL, "cd" integer NOT NULL ); CREATE TABLE "owners" ( "id" INTEGER PRIMARY KEY NOT NULL, "name" varchar(100) NOT NULL ); CREATE UNIQUE INDEX "owners_name" ON "owners" ("name"); CREATE TABLE "producer" ( "producerid" INTEGER PRIMARY KEY NOT NULL, "name" varchar(100) NOT NULL ); CREATE UNIQUE INDEX "prod_name" ON "producer" ("name"); CREATE TABLE "self_ref" ( "id" INTEGER PRIMARY KEY NOT NULL, "name" varchar(100) NOT NULL ); CREATE TABLE "sequence_test" ( "pkid1" integer NOT NULL, "pkid2" integer NOT NULL, "nonpkid" integer NOT NULL, "name" varchar(100), PRIMARY KEY ("pkid1", "pkid2") ); CREATE TABLE "serialized" ( "id" INTEGER PRIMARY KEY NOT NULL, "serialized" text NOT NULL ); CREATE TABLE "timestamp_primary_key_test" ( "id" timestamp NOT NULL DEFAULT current_timestamp, PRIMARY KEY ("id") ); CREATE TABLE "treelike" ( "id" INTEGER PRIMARY KEY NOT NULL, "parent" integer, "name" varchar(100) NOT NULL, FOREIGN KEY ("parent") REFERENCES "treelike"("id") ON DELETE CASCADE ON UPDATE CASCADE ); CREATE INDEX "treelike_idx_parent" ON "treelike" ("parent"); CREATE TABLE "twokeytreelike" ( "id1" integer NOT NULL, "id2" integer NOT NULL, "parent1" integer NOT NULL, "parent2" integer NOT NULL, "name" varchar(100) NOT NULL, PRIMARY KEY ("id1", "id2"), FOREIGN KEY ("parent1", "parent2") REFERENCES "twokeytreelike"("id1", "id2") ); CREATE INDEX "twokeytreelike_idx_parent1_parent2" ON "twokeytreelike" ("parent1", "parent2"); CREATE UNIQUE INDEX "tktlnameunique" ON "twokeytreelike" ("name"); CREATE TABLE "typed_object" ( "objectid" INTEGER PRIMARY KEY NOT NULL, "type" varchar(100) NOT NULL, "value" varchar(100) NOT NULL ); CREATE TABLE "artist_undirected_map" ( "id1" integer NOT NULL, "id2" integer NOT NULL, PRIMARY KEY ("id1", "id2"), FOREIGN KEY ("id1") REFERENCES "artist"("artistid") ON DELETE RESTRICT ON UPDATE CASCADE, FOREIGN KEY ("id2") REFERENCES "artist"("artistid") ); CREATE INDEX "artist_undirected_map_idx_id1" ON "artist_undirected_map" ("id1"); CREATE INDEX "artist_undirected_map_idx_id2" ON "artist_undirected_map" ("id2"); CREATE TABLE "bookmark" ( "id" INTEGER PRIMARY KEY NOT NULL, "link" integer, FOREIGN KEY ("link") REFERENCES "link"("id") ON DELETE SET NULL ON UPDATE CASCADE ); CREATE INDEX "bookmark_idx_link" ON "bookmark" ("link"); CREATE TABLE "books" ( "id" INTEGER PRIMARY KEY NOT NULL, "source" varchar(100) NOT NULL, "owner" integer NOT NULL, "title" varchar(100) NOT NULL, "price" integer, FOREIGN KEY ("owner") REFERENCES "owners"("id") ON DELETE CASCADE ON UPDATE CASCADE ); CREATE INDEX "books_idx_owner" ON "books" ("owner"); CREATE UNIQUE INDEX "books_title" ON "books" ("title"); CREATE TABLE "employee" ( "employee_id" INTEGER PRIMARY KEY NOT NULL, "position" integer NOT NULL, "group_id" integer, "group_id_2" integer, "group_id_3" integer, "name" varchar(100), "encoded" integer, FOREIGN KEY ("encoded") REFERENCES "encoded"("id") ON DELETE CASCADE ON UPDATE CASCADE ); CREATE INDEX "employee_idx_encoded" ON "employee" ("encoded"); CREATE TABLE "forceforeign" ( "artist" INTEGER PRIMARY KEY NOT NULL, "cd" integer NOT NULL, FOREIGN KEY ("artist") REFERENCES "artist"("artistid") ); CREATE TABLE "self_ref_alias" ( "self_ref" integer NOT NULL, "alias" integer NOT NULL, PRIMARY KEY ("self_ref", "alias"), FOREIGN KEY ("alias") REFERENCES "self_ref"("id"), FOREIGN KEY ("self_ref") REFERENCES "self_ref"("id") ON DELETE CASCADE ON UPDATE CASCADE ); CREATE INDEX "self_ref_alias_idx_alias" ON "self_ref_alias" ("alias"); CREATE INDEX "self_ref_alias_idx_self_ref" ON "self_ref_alias" ("self_ref"); CREATE TABLE "track" ( "trackid" INTEGER PRIMARY KEY NOT NULL, "cd" integer NOT NULL, "position" int NOT NULL, "title" varchar(100) NOT NULL, "last_updated_on" datetime, "last_updated_at" datetime, FOREIGN KEY ("cd") REFERENCES "cd"("cdid") ON DELETE CASCADE ON UPDATE CASCADE ); CREATE INDEX "track_idx_cd" ON "track" ("cd"); CREATE UNIQUE INDEX "track_cd_position" ON "track" ("cd", "position"); CREATE UNIQUE INDEX "track_cd_title" ON "track" ("cd", "title"); CREATE TABLE "cd" ( "cdid" INTEGER PRIMARY KEY NOT NULL, "artist" integer NOT NULL, "title" varchar(100) NOT NULL, "year" varchar(100) NOT NULL, "genreid" integer, "single_track" integer, FOREIGN KEY ("artist") REFERENCES "artist"("artistid") ON DELETE CASCADE ON UPDATE CASCADE, FOREIGN KEY ("single_track") REFERENCES "track"("trackid") ON DELETE CASCADE, FOREIGN KEY ("genreid") REFERENCES "genre"("genreid") ON DELETE SET NULL ON UPDATE CASCADE ); CREATE INDEX "cd_idx_artist" ON "cd" ("artist"); CREATE INDEX "cd_idx_single_track" ON "cd" ("single_track"); CREATE INDEX "cd_idx_genreid" ON "cd" ("genreid"); CREATE UNIQUE INDEX "cd_artist_title" ON "cd" ("artist", "title"); CREATE TABLE "collection_object" ( "collection" integer NOT NULL, "object" integer NOT NULL, PRIMARY KEY ("collection", "object"), FOREIGN KEY ("collection") REFERENCES "collection"("collectionid") ON DELETE CASCADE ON UPDATE CASCADE, FOREIGN KEY ("object") REFERENCES "typed_object"("objectid") ON DELETE CASCADE ON UPDATE CASCADE ); CREATE INDEX "collection_object_idx_collection" ON "collection_object" ("collection"); CREATE INDEX "collection_object_idx_object" ON "collection_object" ("object"); CREATE TABLE "lyrics" ( "lyric_id" INTEGER PRIMARY KEY NOT NULL, "track_id" integer NOT NULL, FOREIGN KEY ("track_id") REFERENCES "track"("trackid") ON DELETE CASCADE ); CREATE INDEX "lyrics_idx_track_id" ON "lyrics" ("track_id"); CREATE TABLE "cd_artwork" ( "cd_id" INTEGER PRIMARY KEY NOT NULL, FOREIGN KEY ("cd_id") REFERENCES "cd"("cdid") ON DELETE CASCADE ); CREATE TABLE "liner_notes" ( "liner_id" INTEGER PRIMARY KEY NOT NULL, "notes" varchar(100) NOT NULL, FOREIGN KEY ("liner_id") REFERENCES "cd"("cdid") ON DELETE CASCADE ); CREATE TABLE "lyric_versions" ( "id" INTEGER PRIMARY KEY NOT NULL, "lyric_id" integer NOT NULL, "text" varchar(100) NOT NULL, FOREIGN KEY ("lyric_id") REFERENCES "lyrics"("lyric_id") ON DELETE CASCADE ON UPDATE CASCADE ); CREATE INDEX "lyric_versions_idx_lyric_id" ON "lyric_versions" ("lyric_id"); CREATE UNIQUE INDEX "lyric_versions_lyric_id_text" ON "lyric_versions" ("lyric_id", "text"); CREATE TABLE "tags" ( "tagid" INTEGER PRIMARY KEY NOT NULL, "cd" integer NOT NULL, "tag" varchar(100) NOT NULL, FOREIGN KEY ("cd") REFERENCES "cd"("cdid") ON DELETE CASCADE ON UPDATE CASCADE ); CREATE INDEX "tags_idx_cd" ON "tags" ("cd"); CREATE UNIQUE INDEX "tagid_cd" ON "tags" ("tagid", "cd"); CREATE UNIQUE INDEX "tagid_cd_tag" ON "tags" ("tagid", "cd", "tag"); CREATE UNIQUE INDEX "tags_tagid_tag" ON "tags" ("tagid", "tag"); CREATE UNIQUE INDEX "tags_tagid_tag_cd" ON "tags" ("tagid", "tag", "cd"); CREATE TABLE "cd_to_producer" ( "cd" integer NOT NULL, "producer" integer NOT NULL, "attribute" integer, PRIMARY KEY ("cd", "producer"), FOREIGN KEY ("cd") REFERENCES "cd"("cdid") ON DELETE CASCADE ON UPDATE CASCADE, FOREIGN KEY ("producer") REFERENCES "producer"("producerid") ); CREATE INDEX "cd_to_producer_idx_cd" ON "cd_to_producer" ("cd"); CREATE INDEX "cd_to_producer_idx_producer" ON "cd_to_producer" ("producer"); CREATE TABLE "images" ( "id" INTEGER PRIMARY KEY NOT NULL, "artwork_id" integer NOT NULL, "name" varchar(100) NOT NULL, "data" blob, FOREIGN KEY ("artwork_id") REFERENCES "cd_artwork"("cd_id") ON DELETE CASCADE ON UPDATE CASCADE ); CREATE INDEX "images_idx_artwork_id" ON "images" ("artwork_id"); CREATE TABLE "twokeys" ( "artist" integer NOT NULL, "cd" integer NOT NULL, PRIMARY KEY ("artist", "cd"), FOREIGN KEY ("artist") REFERENCES "artist"("artistid") ON DELETE CASCADE ON UPDATE CASCADE, FOREIGN KEY ("cd") REFERENCES "cd"("cdid") ); CREATE INDEX "twokeys_idx_artist" ON "twokeys" ("artist"); CREATE TABLE "artwork_to_artist" ( "artwork_cd_id" integer NOT NULL, "artist_id" integer NOT NULL, PRIMARY KEY ("artwork_cd_id", "artist_id"), FOREIGN KEY ("artist_id") REFERENCES "artist"("artistid") ON DELETE CASCADE ON UPDATE CASCADE, FOREIGN KEY ("artwork_cd_id") REFERENCES "cd_artwork"("cd_id") ON DELETE CASCADE ON UPDATE CASCADE ); CREATE INDEX "artwork_to_artist_idx_artist_id" ON "artwork_to_artist" ("artist_id"); CREATE INDEX "artwork_to_artist_idx_artwork_cd_id" ON "artwork_to_artist" ("artwork_cd_id"); CREATE TABLE "fourkeys_to_twokeys" ( "f_foo" integer NOT NULL, "f_bar" integer NOT NULL, "f_hello" integer NOT NULL, "f_goodbye" integer NOT NULL, "t_artist" integer NOT NULL, "t_cd" integer NOT NULL, "autopilot" character NOT NULL, "pilot_sequence" integer, PRIMARY KEY ("f_foo", "f_bar", "f_hello", "f_goodbye", "t_artist", "t_cd"), FOREIGN KEY ("f_foo", "f_bar", "f_hello", "f_goodbye") REFERENCES "fourkeys"("foo", "bar", "hello", "goodbye") ON DELETE CASCADE ON UPDATE CASCADE, FOREIGN KEY ("t_artist", "t_cd") REFERENCES "twokeys"("artist", "cd") ON DELETE CASCADE ON UPDATE CASCADE ); CREATE INDEX "fourkeys_to_twokeys_idx_f_foo_f_bar_f_hello_f_goodbye" ON "fourkeys_to_twokeys" ("f_foo", "f_bar", "f_hello", "f_goodbye"); CREATE INDEX "fourkeys_to_twokeys_idx_t_artist_t_cd" ON "fourkeys_to_twokeys" ("t_artist", "t_cd"); CREATE VIEW "year2000cds" AS SELECT cdid, artist, title, year, genreid, single_track FROM cd WHERE year = "2000"; ����������������������������������������������DBIx-Class-0.082843/t/lib/ViewDepsBad.pm������������������������������������������������������������0000644�0001750�0001750�00000000362�13555517102�016614� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE ViewDepsBad; ## Used in 105view_deps.t use strict; use warnings; use base 'DBICTest::BaseSchema'; __PACKAGE__->load_namespaces; sub sqlt_deploy_hook { my $self = shift; $self->{sqlt} = shift; } 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/admincfgtest.json���������������������������������������������������������0000644�0001750�0001750�00000000200�13555517102�017453� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������{ "Model" : { "Gort" : { "connect_info" : [ "klaatu", "barada", "nikto" ] } } } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/lib/DBICVersion_v3.pm���������������������������������������������������������0000644�0001750�0001750�00000002634�13555517102�017142� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package DBICVersion::Table; use base 'DBIx::Class::Core'; use strict; use warnings; __PACKAGE__->table('TestVersion'); __PACKAGE__->add_columns ( 'Version' => { 'data_type' => 'INTEGER', 'is_auto_increment' => 1, 'default_value' => undef, 'is_foreign_key' => 0, 'is_nullable' => 0, 'size' => '' }, 'VersionName' => { 'data_type' => 'VARCHAR', 'is_auto_increment' => 0, 'default_value' => undef, 'is_foreign_key' => 0, 'is_nullable' => 0, 'size' => '10' }, 'NewVersionName' => { 'data_type' => 'VARCHAR', 'is_auto_increment' => 0, 'default_value' => undef, 'is_foreign_key' => 0, 'is_nullable' => 1, 'size' => '20' }, 'ExtraColumn' => { 'data_type' => 'VARCHAR', 'is_auto_increment' => 0, 'default_value' => undef, 'is_foreign_key' => 0, 'is_nullable' => 1, 'size' => '20' } ); __PACKAGE__->set_primary_key('Version'); package DBICVersion::Schema; use base 'DBICTest::BaseSchema'; use strict; use warnings; our $VERSION = '3.0'; __PACKAGE__->register_class('Table', 'DBICVersion::Table'); __PACKAGE__->load_components('+DBIx::Class::Schema::Versioned'); __PACKAGE__->upgrade_directory("t/var/versioning_ddl-$$"); __PACKAGE__->backup_directory("t/var/versioning_backup-$$"); 1; ����������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/73oracle.t��������������������������������������������������������������������0000644�0001750�0001750�00000055251�14240132261�015155� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::Exception; use Test::More; use Sub::Name; use Try::Tiny; use DBIx::Class::Optional::Dependencies (); use lib qw(t/lib); use DBICTest; my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_ORA_${_}" } qw/DSN USER PASS/}; # optional: my ($dsn2, $user2, $pass2) = @ENV{map { "DBICTEST_ORA_EXTRAUSER_${_}" } qw/DSN USER PASS/}; plan skip_all => 'Set $ENV{DBICTEST_ORA_DSN}, _USER and _PASS to run this test.' unless ($dsn && $user && $pass); plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_oracle') unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_oracle'); $ENV{NLS_SORT} = "BINARY"; $ENV{NLS_COMP} = "BINARY"; $ENV{NLS_LANG} = "AMERICAN"; { package # hide from PAUSE DBICTest::Schema::ArtistFQN; use base 'DBIx::Class::Core'; __PACKAGE__->table( $ENV{DBICTEST_ORA_USER} ? (uc $ENV{DBICTEST_ORA_USER}) . '.artist' : '??_no_user_??' ); __PACKAGE__->add_columns( 'artistid' => { data_type => 'integer', is_auto_increment => 1, }, 'name' => { data_type => 'varchar', size => 100, is_nullable => 1, }, 'autoinc_col' => { data_type => 'integer', is_auto_increment => 1, }, 'default_value_col' => { data_type => 'varchar', size => 100, is_nullable => 0, retrieve_on_insert => 1, } ); __PACKAGE__->set_primary_key(qw/ artistid autoinc_col /); 1; } DBICTest::Schema->load_classes('ArtistFQN'); # This is in Core now, but it's here just to test that it doesn't break DBICTest::Schema::Artist->load_components('PK::Auto'); # These are compat shims for PK::Auto... DBICTest::Schema::CD->load_components('PK::Auto::Oracle'); DBICTest::Schema::Track->load_components('PK::Auto::Oracle'); # check if we indeed do support stuff my $v = do { my $si = DBICTest::Schema->connect($dsn, $user, $pass)->storage->_server_info; $si->{normalized_dbms_version} or die "Unparseable Oracle server version: $si->{dbms_version}\n"; }; my $test_server_supports_only_orajoins = $v < 9; # TODO find out which version supports the RETURNING syntax # 8i (8.1) has it and earlier docs are a 404 on oracle.com my $test_server_supports_insert_returning = $v >= 8.001; is ( DBICTest::Schema->connect($dsn, $user, $pass)->storage->_use_insert_returning, $test_server_supports_insert_returning, 'insert returning capability guessed correctly' ); isa_ok (DBICTest::Schema->connect($dsn, $user, $pass)->storage->sql_maker, 'DBIx::Class::SQLMaker::Oracle'); # see if determining a driver with bad credentials throws propely throws_ok { DBICTest::Schema->connect($dsn, "BORKED BORKED USER $user", $pass)->storage->sql_maker; } qr/DBI Connection failed/; ########## # the recyclebin (new for 10g) sometimes comes in the way my $on_connect_sql = $v >= 10 ? ["ALTER SESSION SET recyclebin = OFF"] : []; # iterate all tests on following options my @tryopt = ( { on_connect_do => $on_connect_sql }, { quote_char => '"', on_connect_do => $on_connect_sql }, ); # keep a database handle open for cleanup my ($dbh, $dbh2); my $schema; for my $use_insert_returning ($test_server_supports_insert_returning ? (1,0) : (0) ) { for my $force_ora_joins ($test_server_supports_only_orajoins ? (0) : (0,1) ) { no warnings qw/once redefine/; my $old_connection = DBICTest::Schema->can('connection'); local *DBICTest::Schema::connection = subname 'DBICTest::Schema::connection' => sub { my $s = shift->$old_connection (@_); $s->storage->_use_insert_returning ($use_insert_returning); $s->storage->sql_maker_class('DBIx::Class::SQLMaker::OracleJoins') if $force_ora_joins; $s; }; for my $opt (@tryopt) { # clean all cached sequences from previous run for (map { values %{DBICTest::Schema->source($_)->columns_info} } (qw/Artist CD Track/) ) { delete $_->{sequence}; } my $schema = DBICTest::Schema->connect($dsn, $user, $pass, $opt); $dbh = $schema->storage->dbh; my $q = $schema->storage->sql_maker->quote_char || ''; do_creates($dbh, $q); _run_tests($schema, $opt); } } } sub _run_tests { my ($schema, $opt) = @_; my $q = $schema->storage->sql_maker->quote_char || ''; # test primary key handling with multiple triggers my ($new, $seq); my $new_artist = $schema->resultset('Artist')->create({ name => 'foo' }); my $new_cd = $schema->resultset('CD')->create({ artist => 1, title => 'EP C', year => '2003' }); SKIP: { skip 'not detecting sequences when using INSERT ... RETURNING', 4 if $schema->storage->_use_insert_returning; is($new_artist->artistid, 1, "Oracle Auto-PK worked for standard sqlt-like trigger"); $seq = $new_artist->result_source->column_info('artistid')->{sequence}; $seq = $$seq if ref $seq; like ($seq, qr/\.${q}artist_pk_seq${q}$/, 'Correct PK sequence selected for sqlt-like trigger'); is($new_cd->cdid, 1, 'Oracle Auto-PK worked - using scalar ref as table name/custom weird trigger'); $seq = $new_cd->result_source->column_info('cdid')->{sequence}; $seq = $$seq if ref $seq; like ($seq, qr/\.${q}cd_seq${q}$/, 'Correct PK sequence selected for custom trigger'); } # test PKs again with fully-qualified table name my $artistfqn_rs = $schema->resultset('ArtistFQN'); my $artist_rsrc = $artistfqn_rs->result_source; delete $artist_rsrc->column_info('artistid')->{sequence}; $new = $artistfqn_rs->create( { name => 'bar' } ); is_deeply( {map { $_ => $new->$_ } $artist_rsrc->primary_columns}, { artistid => 2, autoinc_col => 2}, "Oracle Multi-Auto-PK worked with fully-qualified tablename" ); delete $artist_rsrc->column_info('artistid')->{sequence}; $new = $artistfqn_rs->create( { name => 'bar', autoinc_col => 1000 } ); is( $new->artistid, 3, "Oracle Auto-PK worked with fully-qualified tablename" ); is( $new->autoinc_col, 1000, "Oracle Auto-Inc overruled with fully-qualified tablename"); is( $new->default_value_col, 'default_value', $schema->storage->_use_insert_returning ? 'Check retrieve_on_insert on default_value_col with INSERT ... RETURNING' : 'Check retrieve_on_insert on default_value_col without INSERT ... RETURNING' ); SKIP: { skip 'not detecting sequences when using INSERT ... RETURNING', 1 if $schema->storage->_use_insert_returning; $seq = $new->result_source->column_info('artistid')->{sequence}; $seq = $$seq if ref $seq; like ($seq, qr/\.${q}artist_pk_seq${q}$/, 'Correct PK sequence selected for sqlt-like trigger'); } # test LIMIT support for (1..6) { $schema->resultset('Artist')->create({ name => 'Artist ' . $_ }); } my $it = $schema->resultset('Artist')->search( { name => { -like => 'Artist %' } }, { rows => 3, offset => 4, order_by => 'artistid' }); is( $it->count, 2, "LIMIT count past end of RS ok" ); is( $it->next->name, "Artist 5", "iterator->next ok" ); is( $it->next->name, "Artist 6", "iterator->next ok" ); is( $it->next, undef, "next past end of resultset ok" ); # test identifiers over the 30 char limit lives_ok { my @results = $schema->resultset('CD')->search(undef, { prefetch => 'very_long_artist_relationship', rows => 3, offset => 0, })->all; ok( scalar @results > 0, 'limit with long identifiers returned something'); } 'limit with long identifiers executed successfully'; # test rel names over the 30 char limit my $query = $schema->resultset('Artist')->search({ artistid => 1 }, { prefetch => 'cds_very_very_very_long_relationship_name' }); lives_and { is $query->first->cds_very_very_very_long_relationship_name->first->cdid, 1 } 'query with rel name over 30 chars survived and worked'; # test rel names over the 30 char limit using group_by and join { my @group_cols = ( 'me.name' ); my $query = $schema->resultset('Artist')->search({ artistid => 1 }, { select => \@group_cols, as => [map { /^\w+\.(\w+)$/ } @group_cols], join => [qw( cds_very_very_very_long_relationship_name )], group_by => \@group_cols, }); lives_and { my @got = $query->get_column('name')->all(); is_deeply \@got, [$new_artist->name]; } 'query with rel name over 30 chars worked on join, group_by for me col'; lives_and { is $query->count(), 1 } 'query with rel name over 30 chars worked on join, group_by, count for me col'; } { my @group_cols = ( 'cds_very_very_very_long_relationship_name.title' ); my $query = $schema->resultset('Artist')->search({ artistid => 1 }, { select => \@group_cols, as => [map { /^\w+\.(\w+)$/ } @group_cols], join => [qw( cds_very_very_very_long_relationship_name )], group_by => \@group_cols, }); lives_and { my @got = $query->get_column('title')->all(); is_deeply \@got, [$new_cd->title]; } 'query with rel name over 30 chars worked on join, group_by for long rel col'; lives_and { is $query->count(), 1 } 'query with rel name over 30 chars worked on join, group_by, count for long rel col'; } # rel name over 30 char limit with user condition # This requires walking the WHERE data structure. { $query = $schema->resultset('Artist')->search({ 'cds_very_very_very_long_relationship_name.title' => 'EP C' }, { prefetch => 'cds_very_very_very_long_relationship_name' }); lives_and { is $query->first->cds_very_very_very_long_relationship_name->first->cdid, 1 } 'query with rel name over 30 chars and user condition survived and worked'; } # test join with row count ambiguity my $cd = $schema->resultset('CD')->next; my $track = $cd->create_related('tracks', { position => 1, title => 'Track1'} ); my $tjoin = $schema->resultset('Track')->search({ 'me.title' => 'Track1'}, { join => 'cd', rows => 2 }); ok(my $row = $tjoin->next); is($row->title, 'Track1', "ambiguous column ok"); # check count distinct with multiple columns my $other_track = $schema->resultset('Track')->create({ cd => $cd->cdid, position => 1, title => 'Track2' }); my $tcount = $schema->resultset('Track')->search( {}, { select => [ qw/position title/ ], distinct => 1, } ); is($tcount->count, 2, 'multiple column COUNT DISTINCT ok'); $tcount = $schema->resultset('Track')->search( {}, { columns => [ qw/position title/ ], distinct => 1, } ); is($tcount->count, 2, 'multiple column COUNT DISTINCT ok'); $tcount = $schema->resultset('Track')->search( {}, { group_by => [ qw/position title/ ] } ); is($tcount->count, 2, 'multiple column COUNT DISTINCT using column syntax ok'); # check group_by my $g_rs = $schema->resultset('Track')->search( undef, { columns=>[qw/trackid position/], group_by=> [ qw/trackid position/ ] , rows => 2, offset => 1 }); is( scalar $g_rs->all, 1, "Group by with limit OK" ); # test with_deferred_fk_checks lives_ok { $schema->storage->with_deferred_fk_checks(sub { $schema->resultset('Track')->create({ trackid => 999, cd => 999, position => 1, title => 'deferred FK track' }); $schema->resultset('CD')->create({ artist => 1, cdid => 999, year => '2003', title => 'deferred FK cd' }); }); } 'with_deferred_fk_checks code survived'; is eval { $schema->resultset('Track')->find(999)->title }, 'deferred FK track', 'code in with_deferred_fk_checks worked'; throws_ok { $schema->resultset('Track')->create({ trackid => 1, cd => 9999, position => 1, title => 'Track1' }); } qr/constraint/i, 'with_deferred_fk_checks is off'; # test auto increment using sequences WITHOUT triggers for (1..5) { my $st = $schema->resultset('SequenceTest')->create({ name => 'foo' }); is($st->pkid1, $_, "Oracle Auto-PK without trigger: First primary key"); is($st->pkid2, $_ + 9, "Oracle Auto-PK without trigger: Second primary key"); is($st->nonpkid, $_ + 19, "Oracle Auto-PK without trigger: Non-primary key"); } my $st = $schema->resultset('SequenceTest')->create({ name => 'foo', pkid1 => 55 }); is($st->pkid1, 55, "Oracle Auto-PK without trigger: First primary key set manually"); # test populate (identity, success and error handling) my $art_rs = $schema->resultset('Artist'); my $seq_pos = $art_rs->get_column('artistid')->max; ok($seq_pos, 'Starting with something in the artist table'); my $pop_rs = $schema->resultset('Artist')->search( { name => { -like => 'pop_art_%' } }, { order_by => 'artistid' } ); $art_rs->delete; lives_ok { $pop_rs->populate([ map { +{ name => "pop_art_$_" } } (1,2,3) ]); is_deeply ( [ $pop_rs->get_column('artistid')->all ], [ map { $seq_pos + $_ } (1,2,3) ], 'Sequence works after empty-table insertion' ); } 'Populate without identity does not throw'; lives_ok { $pop_rs->populate([ map { +{ artistid => $_, name => "pop_art_$_" } } (1,2,3) ]); is_deeply ( [ $pop_rs->get_column('artistid')->all ], [ 1,2,3, map { $seq_pos + $_ } (1,2,3) ], 'Explicit id population works' ); } 'Populate with identity does not throw'; throws_ok { $pop_rs->populate([ map { +{ artistid => $_, name => "pop_art_$_" } } (200, 1, 300) ]); } qr/unique constraint.+populate slice.+name => "pop_art_1"/s, 'Partially failed populate throws'; is_deeply ( [ $pop_rs->get_column('artistid')->all ], [ 1,2,3, map { $seq_pos + $_ } (1,2,3) ], 'Partially failed populate did not alter table contents' ); # test complex join (exercise orajoins) lives_ok { is_deeply ( $schema->resultset('CD')->search( { 'artist.name' => 'pop_art_1', 'me.cdid' => { '!=', 999} }, { join => 'artist', prefetch => 'tracks', rows => 4, order_by => 'tracks.trackid' } )->all_hri, [{ artist => 1, cdid => 1, genreid => undef, single_track => undef, title => "EP C", tracks => [ { cd => 1, last_updated_at => undef, last_updated_on => undef, position => 1, title => "Track1", trackid => 1 }, { cd => 1, last_updated_at => undef, last_updated_on => undef, position => 1, title => "Track2", trackid => 2 }, ], year => 2003 }], 'Correct set of data prefetched', ) } 'complex prefetch ok'; # test sequence detection from a different schema SKIP: { TODO: { skip ((join '', 'Set DBICTEST_ORA_EXTRAUSER_DSN, _USER and _PASS to a *DIFFERENT* Oracle user', ' to run the cross-schema sequence detection test.'), 1) unless $dsn2 && $user2 && $user2 ne $user; skip 'not detecting cross-schema sequence name when using INSERT ... RETURNING', 1 if $schema->storage->_use_insert_returning; # Oracle8i Reference Release 2 (8.1.6) # http://download.oracle.com/docs/cd/A87860_01/doc/server.817/a76961/ch294.htm#993 # Oracle Database Reference 10g Release 2 (10.2) # http://download.oracle.com/docs/cd/B19306_01/server.102/b14237/statviews_2107.htm#sthref1297 todo_skip "On Oracle8i all_triggers view is empty, i don't yet know why...", 1 if $schema->storage->_server_info->{normalized_dbms_version} < 9; my $schema2 = $schema->connect($dsn2, $user2, $pass2, $opt); my $dbh2 = $schema2->storage->dbh; # create identically named tables/sequences in the other schema do_creates($dbh2, $q); # grant select privileges to the 2nd user $dbh->do("GRANT INSERT ON ${q}artist${q} TO " . uc $user2); $dbh->do("GRANT SELECT ON ${q}artist${q} TO " . uc $user2); $dbh->do("GRANT SELECT ON ${q}artist_pk_seq${q} TO " . uc $user2); $dbh->do("GRANT SELECT ON ${q}artist_autoinc_seq${q} TO " . uc $user2); # test with a fully qualified table (user1/schema prepended) my $rs2 = $schema2->resultset('ArtistFQN'); delete $rs2->result_source->column_info('artistid')->{sequence}; lives_and { my $row = $rs2->create({ name => 'From Different Schema' }); ok $row->artistid; } 'used autoinc sequence across schemas'; # now quote the sequence name (do_creates always uses an lc name) my $q_seq = $q ? '"artist_pk_seq"' : '"ARTIST_PK_SEQ"' ; delete $rs2->result_source->column_info('artistid')->{sequence}; $dbh->do(qq{ CREATE OR REPLACE TRIGGER ${q}artist_insert_trg_pk${q} BEFORE INSERT ON ${q}artist${q} FOR EACH ROW BEGIN IF :new.${q}artistid${q} IS NULL THEN SELECT $q_seq.nextval INTO :new.${q}artistid${q} FROM DUAL; END IF; END; }); lives_and { my $row = $rs2->create({ name => 'From Different Schema With Quoted Sequence' }); ok $row->artistid; } 'used quoted autoinc sequence across schemas'; is_deeply $rs2->result_source->column_info('artistid')->{sequence}, \( (uc $user) . ".$q_seq"), 'quoted sequence name correctly extracted'; # try an insert operation on the default user2 artist my $art1 = $schema->resultset('Artist'); my $art2 = $schema2->resultset('Artist'); my $art1_count = $art1->count || 0; my $art2_count = $art2->count; is( $art2_count, 0, 'No artists created yet in second schema' ); delete $art2->result_source->column_info('artistid')->{sequence}; my $new_art = $art2->create({ name => '2nd best' }); is ($art1->count, $art1_count, 'No new rows in main schema'); is ($art2->count, 1, 'One artist create in 2nd schema'); is( $new_art->artistid, 1, 'Expected first PK' ); do_clean ($dbh2); }} # test driver determination issues that led to the diagnosis/fix in 37b5ab51 # observed side-effect when count-is-first on a fresh env-based connect { local $ENV{DBI_DSN}; ($ENV{DBI_DSN}, my @user_pass_args) = @{ $schema->storage->connect_info }; my $s2 = DBICTest::Schema->connect( undef, @user_pass_args ); ok (! $s2->storage->connected, 'Not connected' ); is (ref $s2->storage, 'DBIx::Class::Storage::DBI', 'Undetermined driver' ); ok ( $s2->resultset('Artist')->search({ 'me.name' => { like => '%' } }, { prefetch => 'cds' })->count, 'Some artist count' ); ok ( scalar $s2->resultset('CD')->search({}, { join => 'tracks' } )->all, 'Some cds returned' ); $s2->storage->disconnect; } do_clean ($dbh); } done_testing; sub do_creates { my ($dbh, $q) = @_; do_clean($dbh); $dbh->do("CREATE SEQUENCE ${q}artist_autoinc_seq${q} START WITH 1 MAXVALUE 999999 MINVALUE 0"); $dbh->do("CREATE SEQUENCE ${q}artist_pk_seq${q} START WITH 1 MAXVALUE 999999 MINVALUE 0"); $dbh->do("CREATE SEQUENCE ${q}cd_seq${q} START WITH 1 MAXVALUE 999999 MINVALUE 0"); $dbh->do("CREATE SEQUENCE ${q}track_seq${q} START WITH 1 MAXVALUE 999999 MINVALUE 0"); $dbh->do("CREATE SEQUENCE ${q}nonpkid_seq${q} START WITH 20 MAXVALUE 999999 MINVALUE 0"); # this one is always quoted as per manually specified sequence => $dbh->do('CREATE SEQUENCE "pkid1_seq" START WITH 1 MAXVALUE 999999 MINVALUE 0'); # this one is always unquoted as per manually specified sequence => $dbh->do("CREATE SEQUENCE pkid2_seq START WITH 10 MAXVALUE 999999 MINVALUE 0"); $dbh->do("CREATE TABLE ${q}artist${q} (${q}artistid${q} NUMBER(12), ${q}name${q} VARCHAR(255),${q}default_value_col${q} VARCHAR(255) DEFAULT 'default_value', ${q}autoinc_col${q} NUMBER(12), ${q}rank${q} NUMBER(38), ${q}charfield${q} VARCHAR2(10))"); $dbh->do("ALTER TABLE ${q}artist${q} ADD (CONSTRAINT ${q}artist_pk${q} PRIMARY KEY (${q}artistid${q}))"); $dbh->do("CREATE TABLE ${q}sequence_test${q} (${q}pkid1${q} NUMBER(12), ${q}pkid2${q} NUMBER(12), ${q}nonpkid${q} NUMBER(12), ${q}name${q} VARCHAR(255))"); $dbh->do("ALTER TABLE ${q}sequence_test${q} ADD (CONSTRAINT ${q}sequence_test_constraint${q} PRIMARY KEY (${q}pkid1${q}, ${q}pkid2${q}))"); # table cd will be unquoted => Oracle will see it as uppercase $dbh->do("CREATE TABLE cd (${q}cdid${q} NUMBER(12), ${q}artist${q} NUMBER(12), ${q}title${q} VARCHAR(255), ${q}year${q} VARCHAR(4), ${q}genreid${q} NUMBER(12), ${q}single_track${q} NUMBER(12))"); $dbh->do("ALTER TABLE cd ADD (CONSTRAINT ${q}cd_pk${q} PRIMARY KEY (${q}cdid${q}))"); $dbh->do("CREATE TABLE ${q}track${q} (${q}trackid${q} NUMBER(12), ${q}cd${q} NUMBER(12) REFERENCES CD(${q}cdid${q}) DEFERRABLE, ${q}position${q} NUMBER(12), ${q}title${q} VARCHAR(255), ${q}last_updated_on${q} DATE, ${q}last_updated_at${q} DATE)"); $dbh->do("ALTER TABLE ${q}track${q} ADD (CONSTRAINT ${q}track_pk${q} PRIMARY KEY (${q}trackid${q}))"); $dbh->do(qq{ CREATE OR REPLACE TRIGGER ${q}artist_insert_trg_auto${q} BEFORE INSERT ON ${q}artist${q} FOR EACH ROW BEGIN IF :new.${q}autoinc_col${q} IS NULL THEN SELECT ${q}artist_autoinc_seq${q}.nextval INTO :new.${q}autoinc_col${q} FROM DUAL; END IF; END; }); $dbh->do(qq{ CREATE OR REPLACE TRIGGER ${q}artist_insert_trg_pk${q} BEFORE INSERT ON ${q}artist${q} FOR EACH ROW BEGIN IF :new.${q}artistid${q} IS NULL THEN SELECT ${q}artist_pk_seq${q}.nextval INTO :new.${q}artistid${q} FROM DUAL; END IF; END; }); $dbh->do(qq{ CREATE OR REPLACE TRIGGER ${q}cd_insert_trg${q} BEFORE INSERT OR UPDATE ON cd FOR EACH ROW DECLARE tmpVar NUMBER; BEGIN tmpVar := 0; IF :new.${q}cdid${q} IS NULL THEN SELECT ${q}cd_seq${q}.nextval INTO tmpVar FROM dual; :new.${q}cdid${q} := tmpVar; END IF; END; }); $dbh->do(qq{ CREATE OR REPLACE TRIGGER ${q}track_insert_trg${q} BEFORE INSERT ON ${q}track${q} FOR EACH ROW BEGIN IF :new.${q}trackid${q} IS NULL THEN SELECT ${q}track_seq${q}.nextval INTO :new.${q}trackid${q} FROM DUAL; END IF; END; }); } # clean up our mess sub do_clean { my $dbh = shift || return; for my $q ('', '"') { my @clean = ( "DROP TRIGGER ${q}track_insert_trg${q}", "DROP TRIGGER ${q}cd_insert_trg${q}", "DROP TRIGGER ${q}artist_insert_trg_auto${q}", "DROP TRIGGER ${q}artist_insert_trg_pk${q}", "DROP SEQUENCE ${q}nonpkid_seq${q}", "DROP SEQUENCE ${q}pkid2_seq${q}", "DROP SEQUENCE ${q}pkid1_seq${q}", "DROP SEQUENCE ${q}track_seq${q}", "DROP SEQUENCE ${q}cd_seq${q}", "DROP SEQUENCE ${q}artist_autoinc_seq${q}", "DROP SEQUENCE ${q}artist_pk_seq${q}", "DROP TABLE ${q}bindtype_test${q}", "DROP TABLE ${q}sequence_test${q}", "DROP TABLE ${q}track${q}", "DROP TABLE ${q}cd${q}", "DROP TABLE ${q}artist${q}", ); eval { $dbh -> do ($_) } for @clean; } } END { for ($dbh, $dbh2) { next unless $_; local $SIG{__WARN__} = sub {}; do_clean($_); } undef $dbh; undef $dbh2; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/sqlmaker/���������������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�015201� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/sqlmaker/quotes.t�������������������������������������������������������������0000644�0001750�0001750�00000003766�14240132261�016701� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema( no_deploy => 1 ); $schema->connection( @{ $schema->storage->_dbi_connect_info }, { AutoCommit => 1, quote_char => [qw/[ ]/] } ); my $rs = $schema->resultset('CD')->search( { 'me.year' => 2001, 'artist.name' => 'Caterwauler McCrae' }, { join => 'artist' } )->count_rs; my $expected_bind = [ [ { dbic_colname => "artist.name", sqlt_datatype => "varchar", sqlt_size => 100 } => 'Caterwauler McCrae' ], [ { dbic_colname => "me.year", sqlt_datatype => "varchar", sqlt_size => 100 } => 2001 ], ]; is_same_sql_bind( $rs->as_query, "(SELECT COUNT( * ) FROM cd [me] JOIN [artist] [artist] ON [artist].[artistid] = [me].[artist] WHERE ( [artist].[name] = ? AND [me].[year] = ? ))", $expected_bind, 'got correct SQL for count query with bracket quoting' ); $schema->storage->sql_maker->quote_char('`'); $schema->storage->sql_maker->name_sep('.'); is_same_sql_bind ( $rs->as_query, "(SELECT COUNT( * ) FROM cd `me` JOIN `artist` `artist` ON ( `artist`.`artistid` = `me`.`artist` ) WHERE ( `artist`.`name` = ? AND `me`.`year` = ? ))", $expected_bind, 'got correct SQL for count query with mysql quoting' ); # !!! talk to ribasushi *explicitly* before modfying these tests !!! { is_same_sql_bind( $schema->resultset('CD')->search({}, { order_by => 'year DESC', columns => 'cdid' })->as_query, '(SELECT `me`.`cdid` FROM cd `me` ORDER BY `year DESC`)', [], 'quoted ORDER BY with DESC (should use a scalarref anyway)' ); is_same_sql_bind( $schema->resultset('CD')->search({}, { order_by => \'year DESC', columns => 'cdid' })->as_query, '(SELECT `me`.`cdid` FROM cd `me` ORDER BY year DESC)', [], 'did not quote ORDER BY with scalarref', ); } is_same_sql( scalar $schema->storage->sql_maker->update('group', { order => 12, name => 'Bill' }), 'UPDATE `group` SET `name` = ?, `order` = ?', 'quoted table names for UPDATE' ); done_testing; ����������DBIx-Class-0.082843/t/sqlmaker/limit_dialects/������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�020167� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/sqlmaker/limit_dialects/custom.t����������������������������������������������0000644�0001750�0001750�00000002271�14240132261�021647� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Warn; use lib qw(t/lib); use DBICTest ':DiffSQL'; # This is legacy stuff from SQL::Absract::Limit # Keep it around just in case someone is using it { package DBICTest::SQLMaker::CustomDialect; use base qw/DBIx::Class::SQLMaker/; sub emulate_limit { my ($self, $sql, $rs_attrs, $limit, $offset) = @_; return sprintf ('shiny sproc ((%s), %d, %d)', $sql, $limit || 0, $offset || 0, ); } } my $s = DBICTest::Schema->connect (DBICTest->_database); $s->storage->sql_maker_class ('DBICTest::SQLMaker::CustomDialect'); my $rs = $s->resultset ('CD'); warnings_exist { is_same_sql_bind ( $rs->search ({}, { rows => 1, offset => 3,columns => [ { id => 'foo.id' }, { 'artist.id' => 'bar.id' }, { bleh => \ 'TO_CHAR (foo.womble, "blah")' }, ]})->as_query, '( shiny sproc ( ( SELECT foo.id, bar.id, TO_CHAR (foo.womble, "blah") FROM cd me ), 1, 3 ) )', [], 'Rownum subsel aliasing works correctly' )} qr/\Qthe legacy emulate_limit() mechanism inherited from SQL::Abstract::Limit has been deprecated/, 'deprecation warning' ; done_testing; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/sqlmaker/limit_dialects/torture.t���������������������������������������������0000644�0001750�0001750�00000070623�14240132261�022047� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use Storable 'dclone'; use lib qw(t/lib); use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema; my $native_limit_dialect = $schema->storage->sql_maker->{limit_dialect}; my $where_string = 'me.title = ? AND source != ? AND source = ?'; my @where_bind = ( [ {} => 'kama sutra' ], [ {} => 'Study' ], [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ], ); my @select_bind = ( [ { sqlt_datatype => 'numeric' } => 11 ], [ {} => 12 ], [ { sqlt_datatype => 'integer', dbic_colname => 'me.id' } => 13 ], ); my @group_bind = ( [ {} => 21 ], ); my @having_bind = ( [ {} => 31 ], ); my @order_bind = ( [ { sqlt_datatype => 'int' } => 1 ], [ { sqlt_datatype => 'varchar', dbic_colname => 'name', sqlt_size => 100 } => 2 ], [ {} => 3 ], ); my $tests = { LimitOffset => { limit_plain => [ "( SELECT me.artistid FROM artist me LIMIT ? )", [ [ { sqlt_datatype => 'integer' } => 5 ] ], ], limit => [ "( SELECT me.id, owner.id, owner.name, ? * ?, ? FROM books me JOIN owners owner ON owner.id = me.owner WHERE $where_string GROUP BY (me.id / ?), owner.id HAVING ? LIMIT ? )", [ @select_bind, @where_bind, @group_bind, @having_bind, [ { sqlt_datatype => 'integer' } => 4 ], ], ], limit_offset => [ "( SELECT me.id, owner.id, owner.name, ? * ?, ? FROM books me JOIN owners owner ON owner.id = me.owner WHERE $where_string GROUP BY (me.id / ?), owner.id HAVING ? LIMIT ? OFFSET ? )", [ @select_bind, @where_bind, @group_bind, @having_bind, [ { sqlt_datatype => 'integer' } => 4 ], [ { sqlt_datatype => 'integer' } => 3 ], ], ], ordered_limit => [ "( SELECT me.id, owner.id, owner.name, ? * ?, ? FROM books me JOIN owners owner ON owner.id = me.owner WHERE $where_string GROUP BY (me.id / ?), owner.id HAVING ? ORDER BY ? / ?, ? LIMIT ? )", [ @select_bind, @where_bind, @group_bind, @having_bind, @order_bind, [ { sqlt_datatype => 'integer' } => 4 ], ] ], ordered_limit_offset => [ "( SELECT me.id, owner.id, owner.name, ? * ?, ? FROM books me JOIN owners owner ON owner.id = me.owner WHERE $where_string GROUP BY (me.id / ?), owner.id HAVING ? ORDER BY ? / ?, ? LIMIT ? OFFSET ? )", [ @select_bind, @where_bind, @group_bind, @having_bind, @order_bind, [ { sqlt_datatype => 'integer' } => 4 ], [ { sqlt_datatype => 'integer' } => 3 ], ], ], limit_offset_prefetch => [ "( SELECT me.name, books.id, books.source, books.owner, books.title, books.price FROM ( SELECT me.name, me.id FROM owners me LIMIT ? OFFSET ? ) me LEFT JOIN books books ON books.owner = me.id )", [ [ { sqlt_datatype => 'integer' } => 3 ], [ { sqlt_datatype => 'integer' } => 1 ], ] ], }, LimitXY => { limit_plain => [ "( SELECT me.artistid FROM artist me LIMIT ? )", [ [ { sqlt_datatype => 'integer' } => 5 ] ], ], ordered_limit_offset => [ "( SELECT me.id, owner.id, owner.name, ? * ?, ? FROM books me JOIN owners owner ON owner.id = me.owner WHERE $where_string GROUP BY (me.id / ?), owner.id HAVING ? ORDER BY ? / ?, ? LIMIT ?, ? )", [ @select_bind, @where_bind, @group_bind, @having_bind, @order_bind, [ { sqlt_datatype => 'integer' } => 3 ], [ { sqlt_datatype => 'integer' } => 4 ], ], ], limit_offset_prefetch => [ "( SELECT me.name, books.id, books.source, books.owner, books.title, books.price FROM ( SELECT me.name, me.id FROM owners me LIMIT ?,? ) me LEFT JOIN books books ON books.owner = me.id )", [ [ { sqlt_datatype => 'integer' } => 1 ], [ { sqlt_datatype => 'integer' } => 3 ], ] ], }, SkipFirst => { limit_plain => [ "( SELECT FIRST ? me.artistid FROM artist me )", [ [ { sqlt_datatype => 'integer' } => 5 ] ], ], ordered_limit_offset => [ "( SELECT SKIP ? FIRST ? me.id, owner.id, owner.name, ? * ?, ? FROM books me JOIN owners owner ON owner.id = me.owner WHERE $where_string GROUP BY (me.id / ?), owner.id HAVING ? ORDER BY ? / ?, ? )", [ [ { sqlt_datatype => 'integer' } => 3 ], [ { sqlt_datatype => 'integer' } => 4 ], @select_bind, @where_bind, @group_bind, @having_bind, @order_bind, ], ], limit_offset_prefetch => [ "( SELECT me.name, books.id, books.source, books.owner, books.title, books.price FROM ( SELECT SKIP ? FIRST ? me.name, me.id FROM owners me ) me LEFT JOIN books books ON books.owner = me.id )", [ [ { sqlt_datatype => 'integer' } => 1 ], [ { sqlt_datatype => 'integer' } => 3 ], ] ], }, FirstSkip => { limit_plain => [ "( SELECT FIRST ? me.artistid FROM artist me )", [ [ { sqlt_datatype => 'integer' } => 5 ] ], ], ordered_limit_offset => [ "( SELECT FIRST ? SKIP ? me.id, owner.id, owner.name, ? * ?, ? FROM books me JOIN owners owner ON owner.id = me.owner WHERE $where_string GROUP BY (me.id / ?), owner.id HAVING ? ORDER BY ? / ?, ? )", [ [ { sqlt_datatype => 'integer' } => 4 ], [ { sqlt_datatype => 'integer' } => 3 ], @select_bind, @where_bind, @group_bind, @having_bind, @order_bind, ], ], limit_offset_prefetch => [ "( SELECT me.name, books.id, books.source, books.owner, books.title, books.price FROM ( SELECT FIRST ? SKIP ? me.name, me.id FROM owners me ) me LEFT JOIN books books ON books.owner = me.id )", [ [ { sqlt_datatype => 'integer' } => 3 ], [ { sqlt_datatype => 'integer' } => 1 ], ] ], }, RowNumberOver => do { my $unordered_sql = "( SELECT me.id, owner__id, owner__name, bar, baz FROM ( SELECT me.id, owner__id, owner__name, bar, baz, ROW_NUMBER() OVER() AS rno__row__index FROM ( SELECT me.id, owner.id AS owner__id, owner.name AS owner__name, ? * ? AS bar, ? AS baz FROM books me JOIN owners owner ON owner.id = me.owner WHERE $where_string GROUP BY (me.id / ?), owner.id HAVING ? ) me ) me WHERE rno__row__index >= ? AND rno__row__index <= ? )"; my $ordered_sql = "( SELECT me.id, owner__id, owner__name, bar, baz FROM ( SELECT me.id, owner__id, owner__name, bar, baz, ROW_NUMBER() OVER( ORDER BY ORDER__BY__001, ORDER__BY__002 ) AS rno__row__index FROM ( SELECT me.id, owner.id AS owner__id, owner.name AS owner__name, ? * ? AS bar, ? AS baz, ? / ? AS ORDER__BY__001, ? AS ORDER__BY__002 FROM books me JOIN owners owner ON owner.id = me.owner WHERE $where_string GROUP BY (me.id / ?), owner.id HAVING ? ) me ) me WHERE rno__row__index >= ? AND rno__row__index <= ? )"; { limit_plain => [ "( SELECT me.artistid FROM ( SELECT me.artistid, ROW_NUMBER() OVER( ) AS rno__row__index FROM ( SELECT me.artistid FROM artist me ) me ) me WHERE rno__row__index >= ? AND rno__row__index <= ? )", [ [ { sqlt_datatype => 'integer' } => 1 ], [ { sqlt_datatype => 'integer' } => 5 ], ], ], limit => [$unordered_sql, [ @select_bind, @where_bind, @group_bind, @having_bind, [ { sqlt_datatype => 'integer' } => 1 ], [ { sqlt_datatype => 'integer' } => 4 ], ], ], limit_offset => [$unordered_sql, [ @select_bind, @where_bind, @group_bind, @having_bind, [ { sqlt_datatype => 'integer' } => 4 ], [ { sqlt_datatype => 'integer' } => 7 ], ], ], ordered_limit => [$ordered_sql, [ @select_bind, @order_bind, @where_bind, @group_bind, @having_bind, [ { sqlt_datatype => 'integer' } => 1 ], [ { sqlt_datatype => 'integer' } => 4 ], ], ], ordered_limit_offset => [$ordered_sql, [ @select_bind, @order_bind, @where_bind, @group_bind, @having_bind, [ { sqlt_datatype => 'integer' } => 4 ], [ { sqlt_datatype => 'integer' } => 7 ], ], ], limit_offset_prefetch => [ "( SELECT me.name, books.id, books.source, books.owner, books.title, books.price FROM ( SELECT me.name, me.id FROM ( SELECT me.name, me.id, ROW_NUMBER() OVER() AS rno__row__index FROM ( SELECT me.name, me.id FROM owners me ) me ) me WHERE rno__row__index >= ? AND rno__row__index <= ? ) me LEFT JOIN books books ON books.owner = me.id )", [ [ { sqlt_datatype => 'integer' } => 2 ], [ { sqlt_datatype => 'integer' } => 4 ], ] ], }; }, RowNum => do { my $limit_sql = sub { sprintf "( SELECT me.id, owner__id, owner__name, bar, baz FROM ( SELECT me.id, owner.id AS owner__id, owner.name AS owner__name, ? * ? AS bar, ? AS baz FROM books me JOIN owners owner ON owner.id = me.owner WHERE $where_string GROUP BY (me.id / ?), owner.id HAVING ? %s ) me WHERE ROWNUM <= ? )", $_[0] || ''; }; { limit_plain => [ "( SELECT me.artistid FROM ( SELECT me.artistid FROM artist me ) me WHERE ROWNUM <= ? )", [ [ { sqlt_datatype => 'integer' } => 5 ], ], ], limit => [ $limit_sql->(), [ @select_bind, @where_bind, @group_bind, @having_bind, [ { sqlt_datatype => 'integer' } => 4 ], ], ], limit_offset => [ "( SELECT me.id, owner__id, owner__name, bar, baz FROM ( SELECT me.id, owner__id, owner__name, bar, baz, ROWNUM AS rownum__index FROM ( SELECT me.id, owner.id AS owner__id, owner.name AS owner__name, ? * ? AS bar, ? AS baz FROM books me JOIN owners owner ON owner.id = me.owner WHERE $where_string GROUP BY (me.id / ?), owner.id HAVING ? ) me ) me WHERE rownum__index BETWEEN ? AND ? )", [ @select_bind, @where_bind, @group_bind, @having_bind, [ { sqlt_datatype => 'integer' } => 4 ], [ { sqlt_datatype => 'integer' } => 7 ], ], ], ordered_limit => [ $limit_sql->('ORDER BY ? / ?, ?'), [ @select_bind, @where_bind, @group_bind, @having_bind, @order_bind, [ { sqlt_datatype => 'integer' } => 4 ], ], ], ordered_limit_offset => [ "( SELECT me.id, owner__id, owner__name, bar, baz FROM ( SELECT me.id, owner__id, owner__name, bar, baz, ROWNUM AS rownum__index FROM ( SELECT me.id, owner.id AS owner__id, owner.name AS owner__name, ? * ? AS bar, ? AS baz FROM books me JOIN owners owner ON owner.id = me.owner WHERE $where_string GROUP BY (me.id / ?), owner.id HAVING ? ORDER BY ? / ?, ? ) me WHERE ROWNUM <= ? ) me WHERE rownum__index >= ? )", [ @select_bind, @where_bind, @group_bind, @having_bind, @order_bind, [ { sqlt_datatype => 'integer' } => 7 ], [ { sqlt_datatype => 'integer' } => 4 ], ], ], limit_offset_prefetch => [ "( SELECT me.name, books.id, books.source, books.owner, books.title, books.price FROM ( SELECT me.name, me.id FROM ( SELECT me.name, me.id, ROWNUM AS rownum__index FROM ( SELECT me.name, me.id FROM owners me ) me ) me WHERE rownum__index BETWEEN ? AND ? ) me LEFT JOIN books books ON books.owner = me.id )", [ [ { sqlt_datatype => 'integer' } => 2 ], [ { sqlt_datatype => 'integer' } => 4 ], ] ], }; }, FetchFirst => { limit_plain => [ "( SELECT me.artistid FROM artist me FETCH FIRST 5 ROWS ONLY )", [], ], limit => [ "( SELECT me.id, owner.id, owner.name, ? * ?, ? FROM books me JOIN owners owner ON owner.id = me.owner WHERE $where_string GROUP BY (me.id / ?), owner.id HAVING ? FETCH FIRST 4 ROWS ONLY )", [ @select_bind, @where_bind, @group_bind, @having_bind, ], ], limit_offset => [ "( SELECT me.id, owner__id, owner__name, bar, baz FROM ( SELECT me.id, owner.id AS owner__id, owner.name AS owner__name, ? * ? AS bar, ? AS baz FROM books me JOIN owners owner ON owner.id = me.owner WHERE $where_string GROUP BY (me.id / ?), owner.id HAVING ? ORDER BY me.id FETCH FIRST 7 ROWS ONLY ) me ORDER BY me.id DESC FETCH FIRST 4 ROWS ONLY )", [ @select_bind, @where_bind, @group_bind, @having_bind, ], ], ordered_limit => [ "( SELECT me.id, owner.id, owner.name, ? * ?, ? FROM books me JOIN owners owner ON owner.id = me.owner WHERE $where_string GROUP BY (me.id / ?), owner.id HAVING ? ORDER BY ? / ?, ? FETCH FIRST 4 ROWS ONLY )", [ @select_bind, @where_bind, @group_bind, @having_bind, @order_bind, ], ], ordered_limit_offset => [ "( SELECT me.id, owner__id, owner__name, bar, baz FROM ( SELECT me.id, owner__id, owner__name, bar, baz, ORDER__BY__001, ORDER__BY__002 FROM ( SELECT me.id, owner.id AS owner__id, owner.name AS owner__name, ? * ? AS bar, ? AS baz, ? / ? AS ORDER__BY__001, ? AS ORDER__BY__002 FROM books me JOIN owners owner ON owner.id = me.owner WHERE $where_string GROUP BY (me.id / ?), owner.id HAVING ? ORDER BY ? / ?, ? FETCH FIRST 7 ROWS ONLY ) me ORDER BY ORDER__BY__001 DESC, ORDER__BY__002 DESC FETCH FIRST 4 ROWS ONLY ) me ORDER BY ORDER__BY__001, ORDER__BY__002 )", [ @select_bind, @order_bind, @where_bind, @group_bind, @having_bind, @{ dclone \@order_bind }, # without this is_deeply throws a fit ], ], limit_offset_prefetch => [ "( SELECT me.name, books.id, books.source, books.owner, books.title, books.price FROM ( SELECT me.name, me.id FROM ( SELECT me.name, me.id FROM owners me ORDER BY me.id FETCH FIRST 4 ROWS ONLY ) me ORDER BY me.id DESC FETCH FIRST 3 ROWS ONLY ) me LEFT JOIN books books ON books.owner = me.id )", [], ], }, Top => { limit_plain => [ "( SELECT TOP 5 me.artistid FROM artist me )", [], ], limit => [ "( SELECT TOP 4 me.id, owner.id, owner.name, ? * ?, ? FROM books me JOIN owners owner ON owner.id = me.owner WHERE $where_string GROUP BY (me.id / ?), owner.id HAVING ? )", [ @select_bind, @where_bind, @group_bind, @having_bind, ], ], limit_offset => [ "( SELECT TOP 4 me.id, owner__id, owner__name, bar, baz FROM ( SELECT TOP 7 me.id, owner.id AS owner__id, owner.name AS owner__name, ? * ? AS bar, ? AS baz FROM books me JOIN owners owner ON owner.id = me.owner WHERE $where_string GROUP BY (me.id / ?), owner.id HAVING ? ORDER BY me.id ) me ORDER BY me.id DESC )", [ @select_bind, @where_bind, @group_bind, @having_bind, ], ], ordered_limit => [ "( SELECT TOP 4 me.id, owner.id, owner.name, ? * ?, ? FROM books me JOIN owners owner ON owner.id = me.owner WHERE $where_string GROUP BY (me.id / ?), owner.id HAVING ? ORDER BY ? / ?, ? )", [ @select_bind, @where_bind, @group_bind, @having_bind, @order_bind, ], ], ordered_limit_offset => [ "( SELECT me.id, owner__id, owner__name, bar, baz FROM ( SELECT TOP 4 me.id, owner__id, owner__name, bar, baz, ORDER__BY__001, ORDER__BY__002 FROM ( SELECT TOP 7 me.id, owner.id AS owner__id, owner.name AS owner__name, ? * ? AS bar, ? AS baz, ? / ? AS ORDER__BY__001, ? AS ORDER__BY__002 FROM books me JOIN owners owner ON owner.id = me.owner WHERE $where_string GROUP BY (me.id / ?), owner.id HAVING ? ORDER BY ? / ?, ? ) me ORDER BY ORDER__BY__001 DESC, ORDER__BY__002 DESC ) me ORDER BY ORDER__BY__001, ORDER__BY__002 )", [ @select_bind, @order_bind, @where_bind, @group_bind, @having_bind, @{ dclone \@order_bind }, # without this is_deeply throws a fit ], ], limit_offset_prefetch => [ "( SELECT me.name, books.id, books.source, books.owner, books.title, books.price FROM ( SELECT TOP 3 me.name, me.id FROM ( SELECT TOP 4 me.name, me.id FROM owners me ORDER BY me.id ) me ORDER BY me.id DESC ) me LEFT JOIN books books ON books.owner = me.id )", [], ], }, GenericSubQ => { limit_plain => [ "( SELECT me.artistid FROM ( SELECT me.artistid FROM artist me ) me WHERE ( SELECT COUNT(*) FROM artist rownum__emulation WHERE rownum__emulation.artistid < me.artistid ) < ? ORDER BY me.artistid ASC )", [ [ { sqlt_datatype => 'integer' } => 5 ] ], ], ordered_limit => [ "( SELECT me.id, owner__id, owner__name, bar, baz FROM ( SELECT me.id, owner.id AS owner__id, owner.name AS owner__name, ? * ? AS bar, ? AS baz, me.price FROM books me JOIN owners owner ON owner.id = me.owner WHERE $where_string GROUP BY (me.id / ?), owner.id HAVING ? ) me WHERE ( SELECT COUNT( * ) FROM books rownum__emulation WHERE ( me.price IS NULL AND rownum__emulation.price IS NOT NULL ) OR ( rownum__emulation.price > me.price AND me.price IS NOT NULL AND rownum__emulation.price IS NOT NULL ) OR ( ( me.price = rownum__emulation.price OR ( me.price IS NULL AND rownum__emulation.price IS NULL ) ) AND rownum__emulation.id < me.id ) ) < ? ORDER BY me.price DESC, me.id ASC )", [ @select_bind, @where_bind, @group_bind, @having_bind, [ { sqlt_datatype => 'integer' } => 4 ], ], ], ordered_limit_offset => [ "( SELECT me.id, owner__id, owner__name, bar, baz FROM ( SELECT me.id, owner.id AS owner__id, owner.name AS owner__name, ? * ? AS bar, ? AS baz, me.price FROM books me JOIN owners owner ON owner.id = me.owner WHERE $where_string GROUP BY (me.id / ?), owner.id HAVING ? ) me WHERE ( SELECT COUNT( * ) FROM books rownum__emulation WHERE ( me.price IS NULL AND rownum__emulation.price IS NOT NULL ) OR ( rownum__emulation.price > me.price AND me.price IS NOT NULL AND rownum__emulation.price IS NOT NULL ) OR ( ( me.price = rownum__emulation.price OR ( me.price IS NULL AND rownum__emulation.price IS NULL ) ) AND rownum__emulation.id < me.id ) ) BETWEEN ? AND ? ORDER BY me.price DESC, me.id ASC )", [ @select_bind, @where_bind, @group_bind, @having_bind, [ { sqlt_datatype => 'integer' } => 3 ], [ { sqlt_datatype => 'integer' } => 6 ], ], ], limit_offset_prefetch => [ "( SELECT me.name, books.id, books.source, books.owner, books.title, books.price FROM ( SELECT me.name, me.id FROM ( SELECT me.name, me.id FROM owners me ) me WHERE ( SELECT COUNT(*) FROM owners rownum__emulation WHERE ( rownum__emulation.name < me.name OR ( me.name = rownum__emulation.name AND rownum__emulation.id > me.id ) ) ) BETWEEN ? AND ? ORDER BY me.name ASC, me.id DESC ) me LEFT JOIN books books ON books.owner = me.id ORDER BY me.name ASC, me.id DESC )", [ [ { sqlt_datatype => 'integer' } => 1 ], [ { sqlt_datatype => 'integer' } => 3 ], ], ], } }; for my $limtype (sort keys %$tests) { Test::Builder->new->is_passing or exit; delete $schema->storage->_sql_maker->{_cached_syntax}; $schema->storage->_sql_maker->limit_dialect ($limtype); # do the simplest thing possible first if ($tests->{$limtype}{limit_plain}) { is_same_sql_bind( $schema->resultset('Artist')->search( [ -and => [ {}, [] ], -or => [ {}, [] ] ], { columns => 'artistid', join => [ {}, [ [ {}, {} ] ], {} ], prefetch => [ [ [ {}, [] ], {} ], {}, [ {} ] ], order_by => ( $limtype eq 'GenericSubQ' ? 'artistid' : [] ), group_by => [], rows => 5, offset => 0, } )->as_query, @{$tests->{$limtype}{limit_plain}}, "$limtype: Plain unordered ungrouped select with limit and no offset", ) } # chained search is necessary to exercise the recursive {where} parser my $rs = $schema->resultset('BooksInLibrary')->search( { 'me.title' => { '=' => \[ '?', 'kama sutra' ] } } )->search( { source => { '!=', \[ '?', [ {} => 'Study' ] ] } }, { columns => [ { identifier => 'me.id' }, 'owner.id', 'owner.name' ], # people actually do that. BLEH!!! :) join => 'owner', # single-rel manual prefetch rows => 4, '+columns' => { bar => \['? * ?', [ \ 'numeric' => 11 ], 12 ], baz => \[ '?', [ 'me.id' => 13 ] ] }, group_by => \[ '(me.id / ?), owner.id', 21 ], having => \[ '?', 31 ], } ); # # not all tests run on all dialects (somewhere impossible, somewhere makes no sense) # my $can_run = ($limtype eq $native_limit_dialect or $limtype eq 'GenericSubQ'); # only limit, no offset, no order if ($tests->{$limtype}{limit}) { lives_ok { is_same_sql_bind( $rs->as_query, @{$tests->{$limtype}{limit}}, "$limtype: Unordered limit with select/group/having", ); $rs->all if $can_run; } "Grouped limit under $limtype"; } # limit + offset, no order if ($tests->{$limtype}{limit_offset}) { lives_ok { my $subrs = $rs->search({}, { offset => 3 }); is_same_sql_bind( $subrs->as_query, @{$tests->{$limtype}{limit_offset}}, "$limtype: Unordered limit+offset with select/group/having", ); $subrs->all if $can_run; } "Grouped limit+offset runs under $limtype"; } # order + limit, no offset $rs = $rs->search(undef, { order_by => ( $limtype =~ /GenericSubQ/ ? [ { -desc => 'price' }, 'me.id', \[ 'owner.name + ?', 'bah' ] ] # needs a same-table stable order to be happy : [ \['? / ?', [ \ 'int' => 1 ], [ name => 2 ]], \[ '?', 3 ] ] ), }); if ($tests->{$limtype}{ordered_limit}) { lives_ok { is_same_sql_bind( $rs->as_query, @{$tests->{$limtype}{ordered_limit}}, "$limtype: Ordered limit with select/group/having", ); $rs->all if $can_run; } "Grouped ordered limit runs under $limtype" } # order + limit + offset if ($tests->{$limtype}{ordered_limit_offset}) { lives_ok { my $subrs = $rs->search({}, { offset => 3 }); is_same_sql_bind( $subrs->as_query, @{$tests->{$limtype}{ordered_limit_offset}}, "$limtype: Ordered limit+offset with select/group/having", ); $subrs->all if $can_run; } "Grouped ordered limit+offset runs under $limtype"; } # complex prefetch on partial-fetch root with limit my $pref_rs = $schema->resultset('Owners')->search({}, { rows => 3, offset => 1, columns => 'name', # only the owner name, still prefetch all the books prefetch => 'books', ($limtype !~ /GenericSubQ/ ? () : ( # needs a same-table stable order to be happy order_by => [ { -asc => 'me.name' }, \ 'me.id DESC' ] )), }); lives_ok { is_same_sql_bind ( $pref_rs->as_query, @{$tests->{$limtype}{limit_offset_prefetch}}, "$limtype: Prefetch with limit+offset", ) if $tests->{$limtype}{limit_offset_prefetch}; is ($pref_rs->all, 1, 'Expected count of objects on limited prefetch') if $can_run; } "Complex limited prefetch runs under $limtype"; } done_testing; �������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/sqlmaker/limit_dialects/rownum.t����������������������������������������������0000644�0001750�0001750�00000015211�14240132261�021662� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest ':DiffSQL'; my ($TOTAL, $OFFSET, $ROWS) = ( DBIx::Class::SQLMaker::ClassicExtensions->__total_bindtype, DBIx::Class::SQLMaker::ClassicExtensions->__offset_bindtype, DBIx::Class::SQLMaker::ClassicExtensions->__rows_bindtype, ); my $s = DBICTest->init_schema (no_deploy => 1, ); $s->storage->sql_maker->limit_dialect ('RowNum'); my $rs = $s->resultset ('CD')->search({ id => 1 }); # important for a test below, never traversed $rs->result_source->add_relationship( ends_with_me => 'DBICTest::Schema::Artist', sub {} ); my $where_bind = [ { dbic_colname => 'id' }, 1 ]; for my $test_set ( { name => 'Rownum subsel aliasing works correctly', rs => $rs->search_rs(undef, { rows => 1, offset => 3, columns => [ { id => 'foo.id' }, { 'artist.id' => 'bar.id' }, { bleh => \'TO_CHAR (foo.womble, "blah")' }, ] }), sql => '( SELECT id, artist__id, bleh FROM ( SELECT id, artist__id, bleh, ROWNUM AS rownum__index FROM ( SELECT foo.id AS id, bar.id AS artist__id, TO_CHAR (foo.womble, "blah") AS bleh FROM cd me WHERE id = ? ) me ) me WHERE rownum__index BETWEEN ? AND ? )', binds => [ $where_bind, [ $OFFSET => 4 ], [ $TOTAL => 4 ], ], }, { name => 'Rownum subsel aliasing works correctly with unique order_by', rs => $rs->search_rs(undef, { rows => 1, offset => 3, columns => [ { id => 'foo.id' }, { 'artist.id' => 'bar.id' }, { bleh => \'TO_CHAR (foo.womble, "blah")' }, ], order_by => [qw( artist title )], }), sql => '( SELECT id, artist__id, bleh FROM ( SELECT id, artist__id, bleh, ROWNUM AS rownum__index FROM ( SELECT foo.id AS id, bar.id AS artist__id, TO_CHAR(foo.womble, "blah") AS bleh FROM cd me WHERE id = ? ORDER BY artist, title ) me WHERE ROWNUM <= ? ) me WHERE rownum__index >= ? )', binds => [ $where_bind, [ $TOTAL => 4 ], [ $OFFSET => 4 ], ], }, { name => 'Rownum subsel aliasing works correctly with non-unique order_by', rs => $rs->search_rs(undef, { rows => 1, offset => 3, columns => [ { id => 'foo.id' }, { 'artist.id' => 'bar.id' }, { bleh => \'TO_CHAR (foo.womble, "blah")' }, ], order_by => 'artist', }), sql => '( SELECT id, artist__id, bleh FROM ( SELECT id, artist__id, bleh, ROWNUM AS rownum__index FROM ( SELECT foo.id AS id, bar.id AS artist__id, TO_CHAR(foo.womble, "blah") AS bleh FROM cd me WHERE id = ? ORDER BY artist ) me ) me WHERE rownum__index BETWEEN ? and ? )', binds => [ $where_bind, [ $OFFSET => 4 ], [ $TOTAL => 4 ], ], }, { name => 'Rownum subsel aliasing #2 works correctly', rs => $rs->search_rs(undef, { rows => 2, offset => 3, columns => [ { id => 'foo.id' }, { 'ends_with_me.id' => 'ends_with_me.id' }, ] }), sql => '( SELECT id, ends_with_me__id FROM ( SELECT id, ends_with_me__id, ROWNUM AS rownum__index FROM ( SELECT foo.id AS id, ends_with_me.id AS ends_with_me__id FROM cd me WHERE id = ? ) me ) me WHERE rownum__index BETWEEN ? AND ? )', binds => [ $where_bind, [ $OFFSET => 4 ], [ $TOTAL => 5 ], ], }, { name => 'Rownum subsel aliasing #2 works correctly with unique order_by', rs => $rs->search_rs(undef, { rows => 2, offset => 3, columns => [ { id => 'foo.id' }, { 'ends_with_me.id' => 'ends_with_me.id' }, ], order_by => [qw( year artist title )], }), sql => '( SELECT id, ends_with_me__id FROM ( SELECT id, ends_with_me__id, ROWNUM AS rownum__index FROM ( SELECT foo.id AS id, ends_with_me.id AS ends_with_me__id FROM cd me WHERE id = ? ORDER BY year, artist, title ) me WHERE ROWNUM <= ? ) me WHERE rownum__index >= ? )', binds => [ $where_bind, [ $TOTAL => 5 ], [ $OFFSET => 4 ], ], } ) { is_same_sql_bind( $test_set->{rs}->as_query, $test_set->{sql}, $test_set->{binds}, $test_set->{name}); } { my $subq = $s->resultset('Owners')->search({ 'count.id' => { -ident => 'owner.id' }, }, { alias => 'owner' })->count_rs; my $rs_selectas_rel = $s->resultset('BooksInLibrary')->search ({}, { columns => [ { owner_name => 'owner.name' }, { owner_books => $subq->as_query }, ], join => 'owner', rows => 2, offset => 3, }); is_same_sql_bind( $rs_selectas_rel->as_query, '( SELECT owner_name, owner_books FROM ( SELECT owner_name, owner_books, ROWNUM AS rownum__index FROM ( SELECT owner.name AS owner_name, ( SELECT COUNT( * ) FROM owners owner WHERE (count.id = owner.id)) AS owner_books FROM books me JOIN owners owner ON owner.id = me.owner WHERE ( source = ? ) ) me ) me WHERE rownum__index BETWEEN ? AND ? )', [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ], [ $OFFSET => 4 ], [ $TOTAL => 5 ], ], 'pagination with subquery works' ); } { $rs = $s->resultset('Artist')->search({}, { columns => 'name', offset => 1, order_by => 'name', }); local $rs->result_source->{name} = "weird \n newline/multi \t \t space containing \n table"; like ( ${$rs->as_query}->[0], qr| weird \s \n \s newline/multi \s \t \s \t \s space \s containing \s \n \s table|x, 'Newlines/spaces preserved in final sql', ); } { my $subq = $s->resultset('Owners')->search({ 'books.owner' => { -ident => 'owner.id' }, }, { alias => 'owner', select => ['id'] } )->count_rs; my $rs_selectas_rel = $s->resultset('BooksInLibrary')->search( { -exists => $subq->as_query }, { select => ['id','owner'], rows => 1 } ); is_same_sql_bind( $rs_selectas_rel->as_query, '( SELECT me.id, me.owner FROM ( SELECT me.id, me.owner FROM books me WHERE ( ( (EXISTS (SELECT COUNT( * ) FROM owners owner WHERE ( books.owner = owner.id ))) AND source = ? ) ) ) me WHERE ROWNUM <= ? )', [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ], [ $ROWS => 1 ], ], 'Pagination with sub-query in WHERE works' ); } done_testing; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/sqlmaker/limit_dialects/skip_first.t������������������������������������������0000644�0001750�0001750�00000007753�14240132261�022524� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest ':DiffSQL'; my ($LIMIT, $OFFSET) = ( DBIx::Class::SQLMaker::ClassicExtensions->__rows_bindtype, DBIx::Class::SQLMaker::ClassicExtensions->__offset_bindtype, ); my $schema = DBICTest->init_schema; $schema->storage->_sql_maker->limit_dialect ('SkipFirst'); my $rs_selectas_col = $schema->resultset ('BooksInLibrary')->search ({}, { '+select' => ['owner.name'], '+as' => ['owner.name'], join => 'owner', rows => 1, offset => 2, }); is_same_sql_bind( $rs_selectas_col->as_query, '( SELECT SKIP ? FIRST ? me.id, me.source, me.owner, me.title, me.price, owner.name FROM books me JOIN owners owner ON owner.id = me.owner WHERE ( source = ? ) )', [ [ $OFFSET => 2 ], [ $LIMIT => 1 ], [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ], ], ); $schema->storage->_sql_maker->quote_char ([qw/ [ ] /]); $schema->storage->_sql_maker->name_sep ('.'); my $rs_selectas_rel = $schema->resultset ('BooksInLibrary')->search ({}, { '+select' => ['owner.name'], '+as' => ['owner_name'], join => 'owner', rows => 1, offset => 2, }); is_same_sql_bind( $rs_selectas_rel->as_query, '( SELECT SKIP ? FIRST ? [me].[id], [me].[source], [me].[owner], [me].[title], [me].[price], [owner].[name] FROM [books] [me] JOIN [owners] [owner] ON [owner].[id] = [me].[owner] WHERE ( [source] = ? ) )', [ [ $OFFSET => 2 ], [ $LIMIT => 1 ], [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ], ], ); { my $subq = $schema->resultset('Owners')->search({ 'count.id' => { -ident => 'owner.id' }, 'count.name' => 'fail', # no one would do this in real life, the rows makes even less sense }, { alias => 'owner', rows => 1 })->count_rs; my $rs_selectas_rel = $schema->resultset('BooksInLibrary')->search ({}, { columns => [ { owner_name => 'owner.name' }, { owner_books => $subq->as_query }, ], join => 'owner', rows => 1, offset => 2, }); is_same_sql_bind( $rs_selectas_rel->as_query, '( SELECT SKIP ? FIRST ? [owner].[name], ( SELECT COUNT(*) FROM ( SELECT FIRST ? [owner].[id] FROM [owners] [owner] WHERE [count].[id] = [owner].[id] and [count].[name] = ? ) [owner] ) FROM [books] [me] JOIN [owners] [owner] ON [owner].[id] = [me].[owner] WHERE ( [source] = ? ) )', [ [ $OFFSET => 2 ], # outer [ $LIMIT => 1 ], # outer [ {%$LIMIT} => 1 ], # inner [ { dbic_colname => 'count.name' } => 'fail' ], [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ], ], ) }; { my $rs = $schema->resultset('Artist')->search({}, { columns => 'name', offset => 1, order_by => 'name', }); local $rs->result_source->{name} = "weird \n newline/multi \t \t space containing \n table"; like ( ${$rs->as_query}->[0], qr| weird \s \n \s newline/multi \s \t \s \t \s space \s containing \s \n \s table|x, 'Newlines/spaces preserved in final sql', ); } { my $subq = $schema->resultset('Owners')->search({ 'books.owner' => { -ident => 'owner.id' }, }, { alias => 'owner', select => ['id'], offset => 3, rows => 4 }); my $rs_selectas_rel = $schema->resultset('BooksInLibrary')->search( { -exists => $subq->as_query }, { select => ['id','owner'], rows => 1, offset => 2 } ); is_same_sql_bind( $rs_selectas_rel->as_query, '( SELECT SKIP ? FIRST ? [me].[id], [me].[owner] FROM [books] [me] WHERE ( ( (EXISTS ( SELECT SKIP ? FIRST ? [owner].[id] FROM [owners] [owner] WHERE ( [books].[owner] = [owner].[id] ) )) AND [source] = ? ) ) )', [ [ $OFFSET => 2 ], #outer [ $LIMIT => 1 ], #outer [ {%$OFFSET} => 3 ], #inner [ {%$LIMIT} => 4 ], #inner [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ], ], 'Pagination with sub-query in WHERE works' ); } done_testing; ���������������������DBIx-Class-0.082843/t/sqlmaker/limit_dialects/fetch_first.t�����������������������������������������0000644�0001750�0001750�00000016126�14240132261�022641� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema; # based on toplimit.t delete $schema->storage->_sql_maker->{_cached_syntax}; $schema->storage->_sql_maker->limit_dialect ('FetchFirst'); my $books_45_and_owners = $schema->resultset ('BooksInLibrary')->search ({}, { prefetch => 'owner', rows => 2, offset => 3, columns => [ grep { $_ ne 'title' } $schema->source('BooksInLibrary')->columns ], }); for my $null_order ( undef, '', {}, [], [{}], ) { my $rs = $books_45_and_owners->search ({}, {order_by => $null_order }); is_same_sql_bind( $rs->as_query, '(SELECT me.id, me.source, me.owner, me.price, owner__id, owner__name FROM ( SELECT me.id, me.source, me.owner, me.price, owner.id AS owner__id, owner.name AS owner__name FROM books me JOIN owners owner ON owner.id = me.owner WHERE ( source = ? ) ORDER BY me.id FETCH FIRST 5 ROWS ONLY ) me ORDER BY me.id DESC FETCH FIRST 2 ROWS ONLY )', [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ] ], ); } for my $ord_set ( { order_by => \'title DESC', order_inner => 'title DESC', order_outer => 'ORDER__BY__001 ASC', order_req => 'ORDER__BY__001 DESC', exselect_outer => 'ORDER__BY__001', exselect_inner => 'title AS ORDER__BY__001', }, { order_by => { -asc => 'title' }, order_inner => 'title ASC', order_outer => 'ORDER__BY__001 DESC', order_req => 'ORDER__BY__001 ASC', exselect_outer => 'ORDER__BY__001', exselect_inner => 'title AS ORDER__BY__001', }, { order_by => { -desc => 'title' }, order_inner => 'title DESC', order_outer => 'ORDER__BY__001 ASC', order_req => 'ORDER__BY__001 DESC', exselect_outer => 'ORDER__BY__001', exselect_inner => 'title AS ORDER__BY__001', }, { order_by => 'title', order_inner => 'title', order_outer => 'ORDER__BY__001 DESC', order_req => 'ORDER__BY__001', exselect_outer => 'ORDER__BY__001', exselect_inner => 'title AS ORDER__BY__001', }, { order_by => [ qw{ title me.owner} ], order_inner => 'title, me.owner', order_outer => 'ORDER__BY__001 DESC, me.owner DESC', order_req => 'ORDER__BY__001, me.owner', exselect_outer => 'ORDER__BY__001', exselect_inner => 'title AS ORDER__BY__001', }, { order_by => ['title', { -desc => 'bar' } ], order_inner => 'title, bar DESC', order_outer => 'ORDER__BY__001 DESC, ORDER__BY__002 ASC', order_req => 'ORDER__BY__001, ORDER__BY__002 DESC', exselect_outer => 'ORDER__BY__001, ORDER__BY__002', exselect_inner => 'title AS ORDER__BY__001, bar AS ORDER__BY__002', }, { order_by => { -asc => [qw{ title bar }] }, order_inner => 'title ASC, bar ASC', order_outer => 'ORDER__BY__001 DESC, ORDER__BY__002 DESC', order_req => 'ORDER__BY__001 ASC, ORDER__BY__002 ASC', exselect_outer => 'ORDER__BY__001, ORDER__BY__002', exselect_inner => 'title AS ORDER__BY__001, bar AS ORDER__BY__002', }, { order_by => [ 'title', { -desc => [qw{bar}] }, { -asc => [qw{me.owner sensors}]}, ], order_inner => 'title, bar DESC, me.owner ASC, sensors ASC', order_outer => 'ORDER__BY__001 DESC, ORDER__BY__002 ASC, me.owner DESC, ORDER__BY__003 DESC', order_req => 'ORDER__BY__001, ORDER__BY__002 DESC, me.owner ASC, ORDER__BY__003 ASC', exselect_outer => 'ORDER__BY__001, ORDER__BY__002, ORDER__BY__003', exselect_inner => 'title AS ORDER__BY__001, bar AS ORDER__BY__002, sensors AS ORDER__BY__003', }, { order_by => [ 'name', ], order_inner => 'name', order_outer => 'name DESC', order_req => 'name', }, ) { my $o_sel = $ord_set->{exselect_outer} ? ', ' . $ord_set->{exselect_outer} : '' ; my $i_sel = $ord_set->{exselect_inner} ? ', ' . $ord_set->{exselect_inner} : '' ; my $rs = $books_45_and_owners->search ({}, {order_by => $ord_set->{order_by}}); # query actually works ok( defined $rs->count, 'Query actually works' ); is_same_sql_bind( $rs->as_query, "(SELECT me.id, me.source, me.owner, me.price, owner__id, owner__name FROM ( SELECT me.id, me.source, me.owner, me.price, owner__id, owner__name$o_sel FROM ( SELECT me.id, me.source, me.owner, me.price, owner.id AS owner__id, owner.name AS owner__name$i_sel FROM books me JOIN owners owner ON owner.id = me.owner WHERE ( source = ? ) ORDER BY $ord_set->{order_inner} FETCH FIRST 5 ROWS ONLY ) me ORDER BY $ord_set->{order_outer} FETCH FIRST 2 ROWS ONLY ) me ORDER BY $ord_set->{order_req} )", [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ] ], ); } # with groupby is_same_sql_bind ( $books_45_and_owners->search ({}, { group_by => 'title', order_by => 'title' })->as_query, '(SELECT me.id, me.source, me.owner, me.price, owner.id, owner.name FROM ( SELECT me.id, me.source, me.owner, me.price, me.title FROM ( SELECT me.id, me.source, me.owner, me.price, me.title FROM ( SELECT me.id, me.source, me.owner, me.price, me.title FROM books me JOIN owners owner ON owner.id = me.owner WHERE ( source = ? ) GROUP BY title ORDER BY title FETCH FIRST 5 ROWS ONLY ) me ORDER BY title DESC FETCH FIRST 2 ROWS ONLY ) me ORDER BY title ) me JOIN owners owner ON owner.id = me.owner WHERE ( source = ? ) ORDER BY title )', [ map { [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ] } (1,2) ], ); # test deprecated column mixing over join boundaries my $rs_selectas_top = $schema->resultset ('BooksInLibrary')->search ({}, { '+select' => ['owner.name'], '+as' => ['owner_name'], join => 'owner', rows => 1 }); is_same_sql_bind( $rs_selectas_top->search({})->as_query, '(SELECT me.id, me.source, me.owner, me.title, me.price, owner.name FROM books me JOIN owners owner ON owner.id = me.owner WHERE ( source = ? ) FETCH FIRST 1 ROWS ONLY )', [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ] ], ); { my $rs = $schema->resultset('Artist')->search({}, { columns => 'artistid', offset => 1, order_by => 'artistid', }); local $rs->result_source->{name} = "weird \n newline/multi \t \t space containing \n table"; like ( ${$rs->as_query}->[0], qr| weird \s \n \s newline/multi \s \t \s \t \s space \s containing \s \n \s table|x, 'Newlines/spaces preserved in final sql', ); } done_testing; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/sqlmaker/limit_dialects/basic.t�����������������������������������������������0000644�0001750�0001750�00000003463�14240132261�021422� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); # test LIMIT my $it = $schema->resultset("CD")->search( {}, { rows => 3, order_by => 'title' } ); is( $it->count, 3, "count ok" ); is( $it->next->title, "Caterwaulin' Blues", "iterator->next ok" ); $it->next; $it->next; is( $it->next, undef, "next past end of resultset ok" ); # test OFFSET my @cds = $schema->resultset("CD")->search( {}, { rows => 2, offset => 2, order_by => 'year' } ); is( $cds[0]->title, "Spoonful of bees", "offset ok" ); # test software-based limiting $it = $schema->resultset("CD")->search( {}, { rows => 3, software_limit => 1, order_by => 'title' } ); is( $it->count, 3, "software limit count ok" ); is( $it->next->title, "Caterwaulin' Blues", "software iterator->next ok" ); $it->next; $it->next; is( $it->next, undef, "software next past end of resultset ok" ); @cds = $schema->resultset("CD")->search( {}, { rows => 2, offset => 2, software_limit => 1, order_by => 'year' } ); is( $cds[0]->title, "Spoonful of bees", "software offset ok" ); throws_ok { $schema->resultset("CD")->search({}, { rows => 2, software_limit => 1, })->as_query; } qr/Unable to generate limited query representation with 'software_limit' enabled/; @cds = $schema->resultset("CD")->search( {}, { offset => 2, order_by => 'year' } ); is( $cds[0]->title, "Spoonful of bees", "offset with no limit" ); $it = $schema->resultset("CD")->search( { title => [ -and => { -like => '%bees' }, { -not_like => 'Forkful%' } ] }, { rows => 5 } ); is( $it->count, 1, "complex abstract count ok" ); done_testing; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/sqlmaker/limit_dialects/generic_subq.t����������������������������������������0000644�0001750�0001750�00000024152�14240132261�023005� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use List::Util 'min'; use DBICTest ':DiffSQL'; my ($ROWS, $TOTAL, $OFFSET) = ( DBIx::Class::SQLMaker::ClassicExtensions->__rows_bindtype, DBIx::Class::SQLMaker::ClassicExtensions->__total_bindtype, DBIx::Class::SQLMaker::ClassicExtensions->__offset_bindtype, ); my $schema = DBICTest->init_schema; $schema->storage->_sql_maker->limit_dialect ('GenericSubQ'); my $rs = $schema->resultset ('BooksInLibrary')->search ({}, { '+columns' => [{ owner_name => 'owner.name' }], join => 'owner', rows => 2, order_by => 'me.title', }); is_same_sql_bind( $rs->as_query, '( SELECT me.id, me.source, me.owner, me.title, me.price, owner_name FROM ( SELECT me.id, me.source, me.owner, me.title, me.price, owner.name AS owner_name FROM books me JOIN owners owner ON owner.id = me.owner WHERE ( source = ? ) ) me WHERE ( SELECT COUNT(*) FROM books rownum__emulation WHERE rownum__emulation.title < me.title ) < ? ORDER BY me.title ASC )', [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ], [ $ROWS => 2 ], ], ); is_deeply ( [ $rs->get_column ('title')->all ], ['Best Recipe Cookbook', 'Dynamical Systems'], 'Correct columns selected with rows', ); $schema->storage->_sql_maker->quote_char ('"'); $schema->storage->_sql_maker->name_sep ('.'); $rs = $schema->resultset ('BooksInLibrary')->search ({}, { order_by => { -desc => 'title' }, '+select' => ['owner.name'], '+as' => ['owner.name'], join => 'owner', rows => 3, offset => 1, }); is_same_sql_bind( $rs->as_query, '( SELECT "me"."id", "me"."source", "me"."owner", "me"."title", "me"."price", "owner__name" FROM ( SELECT "me"."id", "me"."source", "me"."owner", "me"."title", "me"."price", "owner"."name" AS "owner__name" FROM "books" "me" JOIN "owners" "owner" ON "owner"."id" = "me"."owner" WHERE ( "source" = ? ) ) "me" WHERE ( SELECT COUNT(*) FROM "books" "rownum__emulation" WHERE "rownum__emulation"."title" > "me"."title" ) BETWEEN ? AND ? ORDER BY "me"."title" DESC )', [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ], [ $OFFSET => 1 ], [ $TOTAL => 3 ], ], ); is_deeply ( [ $rs->get_column ('title')->all ], [ 'Dynamical Systems', 'Best Recipe Cookbook' ], 'Correct columns selected with rows', ); $rs = $schema->resultset ('BooksInLibrary')->search ({}, { order_by => 'title', 'select' => ['owner.name'], 'as' => ['owner_name'], join => 'owner', offset => 1, }); is_same_sql_bind( $rs->as_query, '( SELECT "owner_name" FROM ( SELECT "owner"."name" AS "owner_name", "me"."title" FROM "books" "me" JOIN "owners" "owner" ON "owner"."id" = "me"."owner" WHERE ( "source" = ? ) ) "me" WHERE ( SELECT COUNT(*) FROM "books" "rownum__emulation" WHERE "rownum__emulation"."title" < "me"."title" ) BETWEEN ? AND ? ORDER BY "me"."title" ASC )', [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ], [ $OFFSET => 1 ], [ $TOTAL => 2147483647 ], ], ); is_deeply ( [ $rs->get_column ('owner_name')->all ], [ ('Newton') x 2 ], 'Correct columns selected with rows', ); $rs = $schema->resultset('CD')->search({}, { columns => [qw( me.cdid me.title me.genreid me.year tracks.position tracks.title )], join => 'tracks', collapse => 1, order_by => [ { -asc => 'me.genreid' }, { -desc => 'year' }, 'me.title', \ 'single_track DESC', { -desc => [qw( me.cdid tracks.position )] } ], }); my @full_res = @{$rs->all_hri}; is (@full_res, 5, 'Expected amount of CDs'); is_deeply ( \@full_res, [ { cdid => 2, genreid => undef, title => "Forkful of bees", year => 2001, tracks => [ { position => 3, title => "Sticky Honey" }, { position => 2, title => "Stripy" }, { position => 1, title => "Stung with Success" }, ] }, { cdid => 4, genreid => undef, title => "Generic Manufactured Singles", year => 2001, tracks => [ { position => 3, title => "No More Ideas" }, { position => 2, title => "Boring Song" }, { position => 1, title => "Boring Name" }, ] }, { cdid => 5, genreid => undef, title => "Come Be Depressed With Us", year => 1998, tracks => [ { position => 3, title => "Suicidal" }, { position => 2, title => "Under The Weather" }, { position => 1, title => "Sad" }, ] }, { cdid => 3, genreid => undef, title => "Caterwaulin' Blues", year => 1997, tracks => [ { position => 3, title => "Fowlin" }, { position => 2, title => "Howlin" }, { position => 1, title => "Yowlin" }, ] }, { cdid => 1, genreid => 1, title => "Spoonful of bees", year => 1999, tracks => [ { position => 3, title => "Beehind You" }, { position => 2, title => "Apiary" }, { position => 1, title => "The Bees Knees" }, ] }, ], 'Complex ordered gensubq limited cds and tracks in expected sqlite order' ); for my $slice ( [0, 10], [3, 5 ], [4, 6 ], [0, 2 ], [1, 3 ], ) { my $rownum_cmp_op = $slice->[0] ? 'BETWEEN ? AND ?' : ' < ?' ; { local $TODO = "Temporary workaround until fix of https://twitter.com/dbix_class/status/957271153751527424 proliferates"; is_deeply( $rs->slice(@$slice)->all_hri, [ @full_res[ $slice->[0] .. min($#full_res, $slice->[1]) ] ], "Expected array slice on complex ordered limited gensubq ($slice->[0] : $slice->[1])", ); } is_same_sql_bind( $rs->slice(@$slice)->as_query, qq{( SELECT "me"."cdid", "me"."title", "me"."genreid", "me"."year", "tracks"."position", "tracks"."title" FROM ( SELECT "me"."cdid", "me"."title", "me"."genreid", "me"."year", "me"."single_track" FROM ( SELECT "me"."cdid", "me"."title", "me"."genreid", "me"."year", "me"."single_track" FROM cd "me" LEFT JOIN "track" "tracks" ON "tracks"."cd" = "me"."cdid" GROUP BY "me"."cdid", "me"."title", "me"."genreid", "me"."year", "me"."single_track" ) "me" WHERE ( SELECT COUNT( * ) FROM cd "rownum__emulation" WHERE ( ( "me"."genreid" IS NOT NULL AND "rownum__emulation"."genreid" IS NULL ) OR ( "rownum__emulation"."genreid" < "me"."genreid" AND "me"."genreid" IS NOT NULL AND "rownum__emulation"."genreid" IS NOT NULL ) OR ( ( "me"."genreid" = "rownum__emulation"."genreid" OR ( "me"."genreid" IS NULL AND "rownum__emulation"."genreid" IS NULL ) ) AND "rownum__emulation"."year" > "me"."year" ) OR ( ( "me"."genreid" = "rownum__emulation"."genreid" OR ( "me"."genreid" IS NULL AND "rownum__emulation"."genreid" IS NULL ) ) AND "me"."year" = "rownum__emulation"."year" AND "rownum__emulation"."title" < "me"."title" ) OR ( ( "me"."genreid" = "rownum__emulation"."genreid" OR ( "me"."genreid" IS NULL AND "rownum__emulation"."genreid" IS NULL ) ) AND "me"."year" = "rownum__emulation"."year" AND "me"."title" = "rownum__emulation"."title" AND ( ("me"."single_track" IS NULL AND "rownum__emulation"."single_track" IS NOT NULL ) OR ( "rownum__emulation"."single_track" > "me"."single_track" AND "me"."single_track" IS NOT NULL AND "rownum__emulation"."single_track" IS NOT NULL ) ) ) OR ( ( "me"."genreid" = "rownum__emulation"."genreid" OR ( "me"."genreid" IS NULL AND "rownum__emulation"."genreid" IS NULL ) ) AND "me"."year" = "rownum__emulation"."year" AND "me"."title" = "rownum__emulation"."title" AND ( ( "me"."single_track" = "rownum__emulation"."single_track" ) OR ( "me"."single_track" IS NULL AND "rownum__emulation"."single_track" IS NULL ) ) AND "rownum__emulation"."cdid" > "me"."cdid" ) ) ) $rownum_cmp_op ORDER BY "me"."genreid" ASC, "me"."year" DESC, "me"."title" ASC, "me"."single_track" DESC, "me"."cdid" DESC ) "me" LEFT JOIN "track" "tracks" ON "tracks"."cd" = "me"."cdid" ORDER BY "me"."genreid" ASC, "year" DESC, "me"."title", single_track DESC, "me"."cdid" DESC, "tracks"."position" DESC )}, [ ( $slice->[0] ? [ $OFFSET => $slice->[0] ] : () ), [ $TOTAL => $slice->[1] + ($slice->[0] ? 0 : 1 ) ], ], "Expected sql on complex ordered limited gensubq ($slice->[0] : $slice->[1])", ); } { $rs = $schema->resultset('Artist')->search({}, { columns => 'artistid', offset => 1, order_by => 'artistid', }); local $rs->result_source->{name} = "weird \n newline/multi \t \t space containing \n table"; like ( ${$rs->as_query}->[0], qr| weird \s \n \s newline/multi \s \t \s \t \s space \s containing \s \n \s table|x, 'Newlines/spaces preserved in final sql', ); } done_testing; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/sqlmaker/limit_dialects/rno.t�������������������������������������������������0000644�0001750�0001750�00000014206�14240132261�021134� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest ':DiffSQL'; my ($TOTAL, $OFFSET) = ( DBIx::Class::SQLMaker::ClassicExtensions->__total_bindtype, DBIx::Class::SQLMaker::ClassicExtensions->__offset_bindtype, ); my $schema = DBICTest->init_schema; $schema->storage->_sql_maker->limit_dialect ('RowNumberOver'); my $rs_selectas_col = $schema->resultset ('BooksInLibrary')->search ({}, { '+select' => ['owner.name'], '+as' => ['owner.name'], join => 'owner', rows => 1, }); is_same_sql_bind( $rs_selectas_col->as_query, '( SELECT me.id, me.source, me.owner, me.title, me.price, owner__name FROM ( SELECT me.id, me.source, me.owner, me.title, me.price, owner__name, ROW_NUMBER() OVER( ) AS rno__row__index FROM ( SELECT me.id, me.source, me.owner, me.title, me.price, owner.name AS owner__name FROM books me JOIN owners owner ON owner.id = me.owner WHERE ( source = ? ) ) me ) me WHERE rno__row__index >= ? AND rno__row__index <= ? )', [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ], [ $OFFSET => 1 ], [ $TOTAL => 1 ], ], ); $schema->storage->_sql_maker->quote_char ([qw/ [ ] /]); $schema->storage->_sql_maker->name_sep ('.'); my $rs_selectas_rel = $schema->resultset ('BooksInLibrary')->search ({}, { '+select' => ['owner.name'], '+as' => ['owner_name'], join => 'owner', rows => 1, }); is_same_sql_bind( $rs_selectas_rel->as_query, '( SELECT [me].[id], [me].[source], [me].[owner], [me].[title], [me].[price], [owner_name] FROM ( SELECT [me].[id], [me].[source], [me].[owner], [me].[title], [me].[price], [owner_name], ROW_NUMBER() OVER( ) AS [rno__row__index] FROM ( SELECT [me].[id], [me].[source], [me].[owner], [me].[title], [me].[price], [owner].[name] AS [owner_name] FROM [books] [me] JOIN [owners] [owner] ON [owner].[id] = [me].[owner] WHERE ( [source] = ? ) ) [me] ) [me] WHERE [rno__row__index] >= ? AND [rno__row__index] <= ? )', [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ], [ $OFFSET => 1 ], [ $TOTAL => 1 ], ], ); { my $subq = $schema->resultset('Owners')->search({ 'count.id' => { -ident => 'owner.id' }, 'count.name' => 'fail', # no one would do this in real life }, { alias => 'owner' })->count_rs; my $rs_selectas_rel = $schema->resultset('BooksInLibrary')->search ({}, { columns => [ { owner_name => 'owner.name' }, { owner_books => $subq->as_query }, ], join => 'owner', rows => 1, order_by => 'me.id', }); is_same_sql_bind( $rs_selectas_rel->as_query, '( SELECT [owner_name], [owner_books] FROM ( SELECT [owner_name], [owner_books], ROW_NUMBER() OVER( ORDER BY [ORDER__BY__001] ) AS [rno__row__index] FROM ( SELECT [owner].[name] AS [owner_name], ( SELECT COUNT( * ) FROM [owners] [owner] WHERE [count].[id] = [owner].[id] and [count].[name] = ? ) AS [owner_books], [me].[id] AS [ORDER__BY__001] FROM [books] [me] JOIN [owners] [owner] ON [owner].[id] = [me].[owner] WHERE ( [source] = ? ) ) [me] ) [me] WHERE [rno__row__index] >= ? AND [rno__row__index] <= ? )', [ [ { dbic_colname => 'count.name' } => 'fail' ], [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ], [ $OFFSET => 1 ], [ $TOTAL => 1 ], ], ); }{ my $subq = $schema->resultset('Owners')->search({ 'count.id' => { -ident => 'owner.id' }, }, { alias => 'owner' })->count_rs; my $rs_selectas_rel = $schema->resultset('BooksInLibrary')->search ({}, { columns => [ { owner_name => 'owner.name' }, { owner_books => $subq->as_query }, ], join => 'owner', rows => 1, }); is_same_sql_bind( $rs_selectas_rel->as_query, '( SELECT [owner_name], [owner_books] FROM ( SELECT [owner_name], [owner_books], ROW_NUMBER() OVER( ) AS [rno__row__index] FROM ( SELECT [owner].[name] AS [owner_name], ( SELECT COUNT( * ) FROM [owners] [owner] WHERE [count].[id] = [owner].[id] ) AS [owner_books] FROM [books] [me] JOIN [owners] [owner] ON [owner].[id] = [me].[owner] WHERE ( [source] = ? ) ) [me] ) [me] WHERE [rno__row__index] >= ? AND [rno__row__index] <= ? )', [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ], [ $OFFSET => 1 ], [ $TOTAL => 1 ], ], ); } { my $rs = $schema->resultset('Artist')->search({}, { columns => 'name', offset => 1, order_by => 'name', }); local $rs->result_source->{name} = "weird \n newline/multi \t \t space containing \n table"; like ( ${$rs->as_query}->[0], qr| weird \s \n \s newline/multi \s \t \s \t \s space \s containing \s \n \s table|x, 'Newlines/spaces preserved in final sql', ); } { my $subq = $schema->resultset('Owners')->search({ 'books.owner' => { -ident => 'owner.id' }, }, { alias => 'owner', select => ['id'] } )->count_rs; my $rs_selectas_rel = $schema->resultset('BooksInLibrary')->search( { -exists => $subq->as_query }, { select => ['id','owner'], rows => 1 } ); is_same_sql_bind( $rs_selectas_rel->as_query, '( SELECT [me].[id], [me].[owner] FROM ( SELECT [me].[id], [me].[owner], ROW_NUMBER() OVER( ) AS [rno__row__index] FROM ( SELECT [me].[id], [me].[owner] FROM [books] [me] WHERE ( ( (EXISTS ( SELECT COUNT( * ) FROM [owners] [owner] WHERE ( [books].[owner] = [owner].[id] ) )) AND [source] = ? ) ) ) [me] ) [me] WHERE [rno__row__index] >= ? AND [rno__row__index] <= ? )', [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ], [ $OFFSET => 1 ], [ $TOTAL => 1 ], ], 'Pagination with sub-query in WHERE works' ); } done_testing; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/sqlmaker/limit_dialects/mssql_torture.t���������������������������������������0000644�0001750�0001750�00000023135�14240132261�023262� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest ':DiffSQL'; my $OFFSET = DBIx::Class::SQLMaker::ClassicExtensions->__offset_bindtype; my $TOTAL = DBIx::Class::SQLMaker::ClassicExtensions->__total_bindtype; my $schema = DBICTest->init_schema ( storage_type => 'DBIx::Class::Storage::DBI::MSSQL', no_deploy => 1, quote_names => 1 ); # prime caches $schema->storage->sql_maker; # more involved limit dialect torture testcase migrated from the # live mssql tests my $tests = { pref_hm_and_page_and_group_rs => { rs => scalar $schema->resultset ('Owners')->search ( { 'books.id' => { '!=', undef }, 'me.name' => { '!=', 'somebogusstring' }, }, { prefetch => 'books', order_by => [ { -asc => \['name + ?', [ test => 'xxx' ]] }, 'me.id' ], # test bindvar propagation group_by => [ map { "me.$_" } $schema->source('Owners')->columns ], # the literal order_by requires an explicit group_by rows => 3, unsafe_subselect_ok => 1, }, )->page(3), result => { Top => [ '( SELECT TOP 2147483647 [me].[id], [me].[name], [books].[id], [books].[source], [books].[owner], [books].[title], [books].[price] FROM ( SELECT TOP 2147483647 [me].[id], [me].[name] FROM ( SELECT TOP 3 [me].[id], [me].[name], [ORDER__BY__001] FROM ( SELECT TOP 9 [me].[id], [me].[name], name + ? AS [ORDER__BY__001] FROM [owners] [me] LEFT JOIN [books] [books] ON [books].[owner] = [me].[id] WHERE [books].[id] IS NOT NULL AND [me].[name] != ? GROUP BY [me].[id], [me].[name] ORDER BY name + ? ASC, [me].[id] ) [me] ORDER BY [ORDER__BY__001] DESC, [me].[id] DESC ) [me] ORDER BY [ORDER__BY__001] ASC, [me].[id] ) [me] LEFT JOIN [books] [books] ON [books].[owner] = [me].[id] WHERE [books].[id] IS NOT NULL AND [me].[name] != ? ORDER BY name + ? ASC, [me].[id] )', [ [ { dbic_colname => 'test' } => 'xxx' ], [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'me.name' } => 'somebogusstring' ], [ { dbic_colname => 'test' } => 'xxx' ], # the extra re-order bind [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'me.name' } => 'somebogusstring' ], [ { dbic_colname => 'test' } => 'xxx' ], ], ], RowNumberOver => [ '( SELECT TOP 2147483647 [me].[id], [me].[name], [books].[id], [books].[source], [books].[owner], [books].[title], [books].[price] FROM ( SELECT TOP 2147483647 [me].[id], [me].[name] FROM ( SELECT [me].[id], [me].[name], ROW_NUMBER() OVER( ORDER BY [ORDER__BY__001] ASC, [me].[id] ) AS [rno__row__index] FROM ( SELECT [me].[id], [me].[name], name + ? AS [ORDER__BY__001] FROM [owners] [me] LEFT JOIN [books] [books] ON [books].[owner] = [me].[id] WHERE [books].[id] IS NOT NULL AND [me].[name] != ? GROUP BY [me].[id], [me].[name] ) [me] ) [me] WHERE [rno__row__index] >= ? AND [rno__row__index] <= ? ) [me] LEFT JOIN [books] [books] ON [books].[owner] = [me].[id] WHERE [books].[id] IS NOT NULL AND [me].[name] != ? ORDER BY name + ? ASC, [me].[id] )', [ [ { dbic_colname => 'test' } => 'xxx' ], [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'me.name' } => 'somebogusstring' ], [ $OFFSET => 7 ], # parameterised RNO [ $TOTAL => 9 ], [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'me.name' } => 'somebogusstring' ], [ { dbic_colname => 'test' } => 'xxx' ], ], ], } }, pref_bt_and_page_and_group_rs => { rs => scalar $schema->resultset ('BooksInLibrary')->search ( { 'owner.name' => [qw/wiggle woggle/], }, { distinct => 1, having => \['1 = ?', [ test => 1 ] ], #test having propagation prefetch => 'owner', rows => 2, # 3 results total order_by => [{ -desc => 'me.owner' }, 'me.id'], unsafe_subselect_ok => 1, }, )->page(3), result => { Top => [ '( SELECT TOP 2147483647 [me].[id], [me].[source], [me].[owner], [me].[title], [me].[price], [owner].[id], [owner].[name] FROM ( SELECT TOP 2147483647 [me].[id], [me].[source], [me].[owner], [me].[title], [me].[price] FROM ( SELECT TOP 2 [me].[id], [me].[source], [me].[owner], [me].[title], [me].[price] FROM ( SELECT TOP 6 [me].[id], [me].[source], [me].[owner], [me].[title], [me].[price] FROM [books] [me] JOIN [owners] [owner] ON [owner].[id] = [me].[owner] WHERE ( [owner].[name] = ? OR [owner].[name] = ? ) AND [source] = ? GROUP BY [me].[id], [me].[source], [me].[owner], [me].[title], [me].[price] HAVING 1 = ? ORDER BY [me].[owner] DESC, [me].[id] ) [me] ORDER BY [me].[owner] ASC, [me].[id] DESC ) [me] ORDER BY [me].[owner] DESC, [me].[id] ) [me] JOIN [owners] [owner] ON [owner].[id] = [me].[owner] WHERE ( [owner].[name] = ? OR [owner].[name] = ? ) AND [source] = ? ORDER BY [me].[owner] DESC, [me].[id] )', [ # inner [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'owner.name' } => 'wiggle' ], [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'owner.name' } => 'woggle' ], [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ], [ { dbic_colname => 'test' } => '1' ], # outer [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'owner.name' } => 'wiggle' ], [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'owner.name' } => 'woggle' ], [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ], ], ], RowNumberOver => [ '( SELECT TOP 2147483647 [me].[id], [me].[source], [me].[owner], [me].[title], [me].[price], [owner].[id], [owner].[name] FROM ( SELECT TOP 2147483647 [me].[id], [me].[source], [me].[owner], [me].[title], [me].[price] FROM ( SELECT [me].[id], [me].[source], [me].[owner], [me].[title], [me].[price], ROW_NUMBER() OVER( ORDER BY [me].[owner] DESC, [me].[id] ) AS [rno__row__index] FROM ( SELECT [me].[id], [me].[source], [me].[owner], [me].[title], [me].[price] FROM [books] [me] JOIN [owners] [owner] ON [owner].[id] = [me].[owner] WHERE ( [owner].[name] = ? OR [owner].[name] = ? ) AND [source] = ? GROUP BY [me].[id], [me].[source], [me].[owner], [me].[title], [me].[price] HAVING 1 = ? ) [me] ) [me] WHERE [rno__row__index] >= ? AND [rno__row__index] <= ? ) [me] JOIN [owners] [owner] ON [owner].[id] = [me].[owner] WHERE ( [owner].[name] = ? OR [owner].[name] = ? ) AND [source] = ? ORDER BY [me].[owner] DESC, [me].[id] )', [ # inner [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'owner.name' } => 'wiggle' ], [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'owner.name' } => 'woggle' ], [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ], [ { dbic_colname => 'test' } => '1' ], [ $OFFSET => 5 ], [ $TOTAL => 6 ], # outer [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'owner.name' } => 'wiggle' ], [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'owner.name' } => 'woggle' ], [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ], ], ], }, }, }; for my $tname (keys %$tests) { for my $limtype (keys %{$tests->{$tname}{result}} ) { delete $schema->storage->_sql_maker->{_cached_syntax}; $schema->storage->_sql_maker->limit_dialect ($limtype); is_same_sql_bind( $tests->{$tname}{rs}->as_query, @{ $tests->{$tname}{result}{$limtype} }, "Correct SQL for $limtype on $tname", ); } } done_testing; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/sqlmaker/limit_dialects/toplimit.t��������������������������������������������0000644�0001750�0001750�00000020743�14240132261�022202� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema; # Trick the sqlite DB to use Top limit emulation # We could test all of this via $sq->$op directly, # but some conditions need a $rsrc delete $schema->storage->_sql_maker->{_cached_syntax}; $schema->storage->_sql_maker->limit_dialect ('Top'); my $books_45_and_owners = $schema->resultset ('BooksInLibrary')->search ({}, { prefetch => 'owner', rows => 2, offset => 3, columns => [ grep { $_ ne 'title' } $schema->source('BooksInLibrary')->columns ], }); for my $null_order ( undef, '', {}, [], [{}], ) { my $rs = $books_45_and_owners->search ({}, {order_by => $null_order }); is_same_sql_bind( $rs->as_query, '(SELECT TOP 2 me.id, me.source, me.owner, me.price, owner__id, owner__name FROM ( SELECT TOP 5 me.id, me.source, me.owner, me.price, owner.id AS owner__id, owner.name AS owner__name FROM books me JOIN owners owner ON owner.id = me.owner WHERE ( source = ? ) ORDER BY me.id ) me ORDER BY me.id DESC )', [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ] ], ); } { my $subq = $schema->resultset('Owners')->search({ 'count.id' => { -ident => 'owner.id' }, }, { alias => 'owner' })->count_rs; my $rs_selectas_rel = $schema->resultset('BooksInLibrary')->search ({}, { columns => [ { owner_name => 'owner.name' }, { owner_books => $subq->as_query }, ], join => 'owner', rows => 2, offset => 3, }); is_same_sql_bind( $rs_selectas_rel->as_query, '( SELECT TOP 2 owner_name, owner_books FROM ( SELECT TOP 5 owner.name AS owner_name, ( SELECT COUNT( * ) FROM owners owner WHERE ( count.id = owner.id ) ) AS owner_books FROM books me JOIN owners owner ON owner.id = me.owner WHERE ( source = ? ) ORDER BY me.id ) me ORDER BY me.id DESC )', [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ] ], 'pagination with subqueries works' ); } for my $ord_set ( { order_by => \'title DESC', order_inner => 'title DESC', order_outer => 'ORDER__BY__001 ASC', order_req => 'ORDER__BY__001 DESC', exselect_outer => 'ORDER__BY__001', exselect_inner => 'title AS ORDER__BY__001', }, { order_by => { -asc => 'title' }, order_inner => 'title ASC', order_outer => 'ORDER__BY__001 DESC', order_req => 'ORDER__BY__001 ASC', exselect_outer => 'ORDER__BY__001', exselect_inner => 'title AS ORDER__BY__001', }, { order_by => { -desc => 'title' }, order_inner => 'title DESC', order_outer => 'ORDER__BY__001 ASC', order_req => 'ORDER__BY__001 DESC', exselect_outer => 'ORDER__BY__001', exselect_inner => 'title AS ORDER__BY__001', }, { order_by => 'title', order_inner => 'title', order_outer => 'ORDER__BY__001 DESC', order_req => 'ORDER__BY__001', exselect_outer => 'ORDER__BY__001', exselect_inner => 'title AS ORDER__BY__001', }, { order_by => [ qw{ title me.owner} ], order_inner => 'title, me.owner', order_outer => 'ORDER__BY__001 DESC, me.owner DESC', order_req => 'ORDER__BY__001, me.owner', exselect_outer => 'ORDER__BY__001', exselect_inner => 'title AS ORDER__BY__001', }, { order_by => ['title', { -desc => 'bar' } ], order_inner => 'title, bar DESC', order_outer => 'ORDER__BY__001 DESC, ORDER__BY__002 ASC', order_req => 'ORDER__BY__001, ORDER__BY__002 DESC', exselect_outer => 'ORDER__BY__001, ORDER__BY__002', exselect_inner => 'title AS ORDER__BY__001, bar AS ORDER__BY__002', }, { order_by => { -asc => [qw{ title bar }] }, order_inner => 'title ASC, bar ASC', order_outer => 'ORDER__BY__001 DESC, ORDER__BY__002 DESC', order_req => 'ORDER__BY__001 ASC, ORDER__BY__002 ASC', exselect_outer => 'ORDER__BY__001, ORDER__BY__002', exselect_inner => 'title AS ORDER__BY__001, bar AS ORDER__BY__002', }, { order_by => [ 'title', { -desc => [qw{bar}] }, { -asc => [qw{me.owner sensors}]}, ], order_inner => 'title, bar DESC, me.owner ASC, sensors ASC', order_outer => 'ORDER__BY__001 DESC, ORDER__BY__002 ASC, me.owner DESC, ORDER__BY__003 DESC', order_req => 'ORDER__BY__001, ORDER__BY__002 DESC, me.owner ASC, ORDER__BY__003 ASC', exselect_outer => 'ORDER__BY__001, ORDER__BY__002, ORDER__BY__003', exselect_inner => 'title AS ORDER__BY__001, bar AS ORDER__BY__002, sensors AS ORDER__BY__003', }, ) { my $o_sel = $ord_set->{exselect_outer} ? ', ' . $ord_set->{exselect_outer} : '' ; my $i_sel = $ord_set->{exselect_inner} ? ', ' . $ord_set->{exselect_inner} : '' ; is_same_sql_bind( $books_45_and_owners->search ({}, {order_by => $ord_set->{order_by}})->as_query, "(SELECT me.id, me.source, me.owner, me.price, owner__id, owner__name FROM ( SELECT TOP 2 me.id, me.source, me.owner, me.price, owner__id, owner__name$o_sel FROM ( SELECT TOP 5 me.id, me.source, me.owner, me.price, owner.id AS owner__id, owner.name AS owner__name$i_sel FROM books me JOIN owners owner ON owner.id = me.owner WHERE ( source = ? ) ORDER BY $ord_set->{order_inner} ) me ORDER BY $ord_set->{order_outer} ) me ORDER BY $ord_set->{order_req} )", [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ] ], ); } # with groupby is_same_sql_bind ( $books_45_and_owners->search ({}, { group_by => 'title', order_by => 'title' })->as_query, '(SELECT me.id, me.source, me.owner, me.price, owner.id, owner.name FROM ( SELECT me.id, me.source, me.owner, me.price, me.title FROM ( SELECT TOP 2 me.id, me.source, me.owner, me.price, me.title FROM ( SELECT TOP 5 me.id, me.source, me.owner, me.price, me.title FROM books me JOIN owners owner ON owner.id = me.owner WHERE ( source = ? ) GROUP BY title ORDER BY title ) me ORDER BY title DESC ) me ORDER BY title ) me JOIN owners owner ON owner.id = me.owner WHERE ( source = ? ) ORDER BY title )', [ map { [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ] } (1,2) ], ); # test deprecated column mixing over join boundaries my $rs_selectas_top = $schema->resultset ('BooksInLibrary')->search ({}, { '+select' => ['owner.name'], '+as' => ['owner_name'], join => 'owner', rows => 1 }); is_same_sql_bind( $rs_selectas_top->search({})->as_query, '(SELECT TOP 1 me.id, me.source, me.owner, me.title, me.price, owner.name FROM books me JOIN owners owner ON owner.id = me.owner WHERE ( source = ? ) )', [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ] ], ); { my $rs = $schema->resultset('Artist')->search({}, { columns => 'artistid', offset => 1, order_by => 'artistid', }); local $rs->result_source->{name} = "weird \n newline/multi \t \t space containing \n table"; like ( ${$rs->as_query}->[0], qr| weird \s \n \s newline/multi \s \t \s \t \s space \s containing \s \n \s table|x, 'Newlines/spaces preserved in final sql', ); } { my $subq = $schema->resultset('Owners')->search({ 'books.owner' => { -ident => 'owner.id' }, }, { alias => 'owner', select => ['id'] } )->count_rs; my $rs_selectas_rel = $schema->resultset('BooksInLibrary')->search( { -exists => $subq->as_query }, { select => ['id','owner'], rows => 1 } ); is_same_sql_bind( $rs_selectas_rel->as_query, '(SELECT TOP 1 me.id, me.owner FROM books me WHERE ( ( (EXISTS (SELECT COUNT( * ) FROM owners owner WHERE ( books.owner = owner.id ))) AND source = ? ) ) )', [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ], ], 'Pagination with sub-query in WHERE works' ); } done_testing; �����������������������������DBIx-Class-0.082843/t/sqlmaker/limit_dialects/first_skip.t������������������������������������������0000644�0001750�0001750�00000007752�14240132261�022523� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest ':DiffSQL'; my ($LIMIT, $OFFSET) = ( DBIx::Class::SQLMaker::ClassicExtensions->__rows_bindtype, DBIx::Class::SQLMaker::ClassicExtensions->__offset_bindtype, ); my $schema = DBICTest->init_schema; $schema->storage->_sql_maker->limit_dialect ('FirstSkip'); my $rs_selectas_col = $schema->resultset ('BooksInLibrary')->search ({}, { '+select' => ['owner.name'], '+as' => ['owner.name'], join => 'owner', rows => 1, offset => 2, }); is_same_sql_bind( $rs_selectas_col->as_query, '( SELECT FIRST ? SKIP ? me.id, me.source, me.owner, me.title, me.price, owner.name FROM books me JOIN owners owner ON owner.id = me.owner WHERE ( source = ? ) )', [ [ $LIMIT => 1 ], [ $OFFSET => 2 ], [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ], ], ); $schema->storage->_sql_maker->quote_char ([qw/ [ ] /]); $schema->storage->_sql_maker->name_sep ('.'); my $rs_selectas_rel = $schema->resultset ('BooksInLibrary')->search ({}, { '+select' => ['owner.name'], '+as' => ['owner_name'], join => 'owner', rows => 1, offset => 2, }); is_same_sql_bind( $rs_selectas_rel->as_query, '( SELECT FIRST ? SKIP ? [me].[id], [me].[source], [me].[owner], [me].[title], [me].[price], [owner].[name] FROM [books] [me] JOIN [owners] [owner] ON [owner].[id] = [me].[owner] WHERE ( [source] = ? ) )', [ [ $LIMIT => 1 ], [ $OFFSET => 2 ], [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ], ], ); { my $subq = $schema->resultset('Owners')->search({ 'count.id' => { -ident => 'owner.id' }, 'count.name' => 'fail', # no one would do this in real life, the rows makes even less sense }, { alias => 'owner', rows => 1 })->count_rs; my $rs_selectas_rel = $schema->resultset('BooksInLibrary')->search ({}, { columns => [ { owner_name => 'owner.name' }, { owner_books => $subq->as_query }, ], join => 'owner', rows => 1, offset => 2, }); is_same_sql_bind( $rs_selectas_rel->as_query, '( SELECT FIRST ? SKIP ? [owner].[name], ( SELECT COUNT(*) FROM ( SELECT FIRST ? [owner].[id] FROM [owners] [owner] WHERE [count].[id] = [owner].[id] and [count].[name] = ? ) [owner] ) FROM [books] [me] JOIN [owners] [owner] ON [owner].[id] = [me].[owner] WHERE ( [source] = ? ) )', [ [ $LIMIT => 1 ], # outer [ $OFFSET => 2 ], # outer [ {%$LIMIT} => 1 ], # inner [ { dbic_colname => 'count.name' } => 'fail' ], [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ], ], ) }; { my $rs = $schema->resultset('Artist')->search({}, { columns => 'name', offset => 1, order_by => 'name', }); local $rs->result_source->{name} = "weird \n newline/multi \t \t space containing \n table"; like ( ${$rs->as_query}->[0], qr| weird \s \n \s newline/multi \s \t \s \t \s space \s containing \s \n \s table|x, 'Newlines/spaces preserved in final sql', ); } { my $subq = $schema->resultset('Owners')->search({ 'books.owner' => { -ident => 'owner.id' }, }, { alias => 'owner', select => ['id'], offset => 3, rows => 4 }); my $rs_selectas_rel = $schema->resultset('BooksInLibrary')->search( { -exists => $subq->as_query }, { select => ['id','owner'], rows => 1, offset => 2 } ); is_same_sql_bind( $rs_selectas_rel->as_query, '( SELECT FIRST ? SKIP ? [me].[id], [me].[owner] FROM [books] [me] WHERE ( ( (EXISTS ( SELECT FIRST ? SKIP ? [owner].[id] FROM [owners] [owner] WHERE ( [books].[owner] = [owner].[id] ) )) AND [source] = ? ) ) )', [ [ $LIMIT => 1 ], #outer [ $OFFSET => 2 ], #outer [ {%$LIMIT} => 4 ], #inner [ {%$OFFSET} => 3 ], #inner [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ], ], 'Pagination with sub-query in WHERE works' ); } done_testing; ����������������������DBIx-Class-0.082843/t/sqlmaker/bind_transport.t�����������������������������������������������������0000644�0001750�0001750�00000007216�14240132261�020403� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use Math::BigInt; use lib qw(t/lib); use DBICTest ':DiffSQL'; my ($ROWS, $OFFSET) = ( DBIx::Class::SQLMaker::ClassicExtensions->__rows_bindtype, DBIx::Class::SQLMaker::ClassicExtensions->__offset_bindtype, ); my $schema = DBICTest->init_schema(); my $rs = $schema->resultset('CD')->search({ -and => [ 'me.artist' => { '!=', '666' }, 'me.artist' => { '!=', \[ '?', [ _ne => 'bar' ] ] }, ]}); # bogus sql query to make sure bind composition happens properly my $complex_rs = $rs->search({}, { '+columns' => { cnt => $rs->count_rs->as_query }, '+select' => \[ 'me.artist + ?', [ _add => 1 ] ], # free select group_by => ['me.cdid', \[ 'me.artist - ?', [ _sub => 2 ] ] ], having => \[ 'me.artist < ?', [ _lt => 3 ] ], order_by => \[ 'me.artist * ? ', [ _mu => 4 ] ], rows => 1, page => 3, }); for (1,2) { is_same_sql_bind ( $complex_rs->as_query, '( SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track, (SELECT COUNT( * ) FROM cd me WHERE me.artist != ? AND me.artist != ?), me.artist + ? FROM cd me WHERE me.artist != ? AND me.artist != ? GROUP BY me.cdid, me.artist - ? HAVING me.artist < ? ORDER BY me.artist * ? LIMIT ? OFFSET ? )', [ [ { sqlt_datatype => 'integer', dbic_colname => 'me.artist' } => 666 ], [ { dbic_colname => '_ne' } => 'bar' ], [ { dbic_colname => '_add' } => 1 ], [ { sqlt_datatype => 'integer', dbic_colname => 'me.artist' } => 666 ], [ { dbic_colname => '_ne' } => 'bar' ], [ { dbic_colname => '_sub' } => 2 ], [ { dbic_colname => '_lt' } => 3 ], [ { dbic_colname => '_mu' } => 4 ], [ $ROWS => 1 ], [ $OFFSET => 2 ], ], 'Correct crazy sql', ); } # see if we get anything back at all isa_ok ($complex_rs->next, 'DBIx::Class::Row'); # Make sure that the bind shorthand syntax translation is accurate (and doesn't error) shorthand_check( [ _sub => 2 ], [ { dbic_colname => '_sub' } => 2 ], '[ $name => $val ] === [ { dbic_colname => $name }, $val ]', ); shorthand_check( [ artist => 2 ], [ { dbic_colname => 'artist', sqlt_datatype => 'integer' } => 2 ], 'resolution of known column during [ $name => $val ] === [ { dbic_colname => $name }, $val ]', ); shorthand_check( [ \ 'number' => 2 ], [ { sqlt_datatype => 'number' } => 2 ], '[ \$dt => $val ] === [ { sqlt_datatype => $dt }, $val ]', ); shorthand_check( [ {} => 2 ], [ {} => 2 ], '[ {} => $val ] === [ {}, $val ]', ); shorthand_check( [ undef, 2 ], [ {} => 2 ], '[ undef, $val ] === [ {}, $val ]', ); shorthand_check( 2, [ {} => 2 ], '$val === [ {}, $val ]', ); shorthand_check( Math::BigInt->new(42), [ {} => Math::BigInt->new(42) ], 'stringifyable $object === [ {}, $object ]', ); shorthand_check( [ 2 ], [ {} => [ 2 ] ], ); shorthand_check( [ {} => [ 2 ] ], [ {} => [ 2 ] ], ); shorthand_check( [ {}, 2, 3 ], [ {} => [ {}, 2, 3 ] ], ); shorthand_check( bless( {}, 'Foo'), [ {} => bless( {}, 'Foo') ], ); shorthand_check( [ {}, bless( {}, 'Foo') ], [ {}, bless( {}, 'Foo') ], ); sub shorthand_check { my ($bind_shorthand, $bind_expected, $testname) = @_; local $Test::Builder::Level = $Test::Builder::Level + 1; is_same_sql_bind ( $schema->resultset('CD')->search({}, { columns => [qw(cdid artist)], group_by => ['cdid', \[ 'artist - ?', $bind_shorthand ] ], })->as_query, '( SELECT me.cdid, me.artist FROM cd me GROUP BY cdid, artist - ? )', [ $bind_expected ], $testname||(), ); } undef $schema; done_testing; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/sqlmaker/core_quoted.t��������������������������������������������������������0000644�0001750�0001750�00000017666�14240132261�017676� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); my $sql_maker = $schema->storage->sql_maker; $sql_maker->quote_char('`'); $sql_maker->name_sep('.'); my ($sql, @bind) = $sql_maker->select( [ { 'me' => 'cd' }, [ { 'artist' => 'artist', '-join_type' => '' }, { 'artist.artistid' => { -ident => 'me.artist' }, } ], [ { 'tracks' => 'tracks', '-join_type' => 'left' }, { 'tracks.cd' => { -ident => 'me.cdid' }, } ], ], [ 'me.cdid', { count => 'tracks.cd' }, { min => 'me.year', -as => 'minyear' }, ], { 'artist.name' => 'Caterwauler McCrae', 'me.year' => 2001 }, {}, undef, undef ); is_same_sql_bind( $sql, \@bind, q/ SELECT `me`.`cdid`, COUNT( `tracks`.`cd` ), MIN( `me`.`year` ) AS `minyear` FROM `cd` `me` JOIN `artist` `artist` ON ( `artist`.`artistid` = `me`.`artist` ) LEFT JOIN `tracks` `tracks` ON ( `tracks`.`cd` = `me`.`cdid` ) WHERE ( `artist`.`name` = ? AND `me`.`year` = ? ) /, [ ['artist.name' => 'Caterwauler McCrae'], ['me.year' => 2001] ], 'got correct SQL and bind parameters for complex select query with quoting' ); ($sql, @bind) = $sql_maker->select( [ { 'me' => 'cd' } ], [ 'me.cdid', 'me.artist', 'me.title', 'me.year' ], undef, { order_by => 'year DESC' }, undef, undef ); is_same_sql_bind( $sql, \@bind, q/SELECT `me`.`cdid`, `me`.`artist`, `me`.`title`, `me`.`year` FROM `cd` `me` ORDER BY `year DESC`/, [], 'scalar ORDER BY okay (single value)' ); ($sql, @bind) = $sql_maker->select( [ { 'me' => 'cd' } ], [ 'me.cdid', 'me.artist', 'me.title', 'me.year' ], undef, { order_by => [ 'year DESC', 'title ASC' ]}, undef, undef ); is_same_sql_bind( $sql, \@bind, q/SELECT `me`.`cdid`, `me`.`artist`, `me`.`title`, `me`.`year` FROM `cd` `me` ORDER BY `year DESC`, `title ASC`/, [], 'scalar ORDER BY okay (multiple values)' ); { ($sql, @bind) = $sql_maker->select( [ { 'me' => 'cd' } ], [ 'me.cdid', 'me.artist', 'me.title', 'me.year' ], undef, { order_by => { -desc => 'year' } }, undef, undef ); is_same_sql_bind( $sql, \@bind, q/SELECT `me`.`cdid`, `me`.`artist`, `me`.`title`, `me`.`year` FROM `cd` `me` ORDER BY `year` DESC/, [], 'hashref ORDER BY okay (single value)' ); ($sql, @bind) = $sql_maker->select( [ { 'me' => 'cd' } ], [ 'me.cdid', 'me.artist', 'me.title', 'me.year' ], undef, { order_by => [ { -desc => 'year' }, { -asc => 'title' }, ]}, undef, undef ); is_same_sql_bind( $sql, \@bind, q/SELECT `me`.`cdid`, `me`.`artist`, `me`.`title`, `me`.`year` FROM `cd` `me` ORDER BY `year` DESC, `title` ASC/, [], 'hashref ORDER BY okay (multiple values)' ); } ($sql, @bind) = $sql_maker->select( [ { 'me' => 'cd' } ], [ 'me.cdid', 'me.artist', 'me.title', 'me.year' ], undef, { order_by => \'year DESC' }, undef, undef ); is_same_sql_bind( $sql, \@bind, q/SELECT `me`.`cdid`, `me`.`artist`, `me`.`title`, `me`.`year` FROM `cd` `me` ORDER BY year DESC/, [], 'did not quote ORDER BY with scalarref (single value)' ); ($sql, @bind) = $sql_maker->select( [ { 'me' => 'cd' } ], [ 'me.cdid', 'me.artist', 'me.title', 'me.year' ], undef, { order_by => [ \'year DESC', \'title ASC' ]}, undef, undef ); is_same_sql_bind( $sql, \@bind, q/SELECT `me`.`cdid`, `me`.`artist`, `me`.`title`, `me`.`year` FROM `cd` `me` ORDER BY year DESC, title ASC/, [], 'did not quote ORDER BY with scalarref (multiple values)' ); ($sql, @bind) = $sql_maker->select( [ { me => 'cd' } ], [qw/ me.cdid me.artist me.title /], { cdid => \['rlike ?', [cdid => 'X'] ] }, { group_by => 'title', having => \['count(me.artist) > ?', [ cnt => 2] ] }, ); is_same_sql_bind( $sql, \@bind, q/SELECT `me`.`cdid`, `me`.`artist`, `me`.`title` FROM `cd` `me` WHERE ( `cdid` rlike ? ) GROUP BY `title` HAVING count(me.artist) > ?/, [ [ cdid => 'X'], ['cnt' => '2'] ], 'Quoting works with where/having arrayrefsrefs', ); ($sql, @bind) = $sql_maker->select( [ { me => 'cd' } ], [qw/ me.cdid me.artist me.title /], { cdid => \'rlike X' }, { group_by => 'title', having => \'count(me.artist) > 2' }, ); is_same_sql_bind( $sql, \@bind, q/SELECT `me`.`cdid`, `me`.`artist`, `me`.`title` FROM `cd` `me` WHERE ( `cdid` rlike X ) GROUP BY `title` HAVING count(me.artist) > 2/, [], 'Quoting works with where/having scalarrefs', ); ($sql, @bind) = $sql_maker->update( 'group', { 'order' => '12', 'name' => 'Bill' } ); is_same_sql_bind( $sql, \@bind, q/UPDATE `group` SET `name` = ?, `order` = ?/, [ ['name' => 'Bill'], ['order' => '12'] ], 'quoted table names for UPDATE' ); { ($sql, @bind) = $sql_maker->select( [ { 'me' => 'cd' } ], [ 'me.*' ], undef, undef, undef, undef, ); is_same_sql_bind( $sql, \@bind, q/SELECT `me`.* FROM `cd` `me`/, [], 'select attr with me.* is right' ); } $sql_maker->quote_char([qw/[ ]/]); ($sql, @bind) = $sql_maker->select( [ { 'me' => 'cd' }, [ { 'artist' => 'artist', '-join_type' => '' }, { 'artist.artistid' => { -ident => 'me.artist' } } ] ], [ { max => 'rank', -as => 'max_rank', }, 'rank', { 'count' => '*', -as => 'cnt', } ], { 'artist.name' => 'Caterwauler McCrae', 'me.year' => 2001 }, undef, undef, undef, ); is_same_sql_bind( $sql, \@bind, q/SELECT MAX ( [rank] ) AS [max_rank], [rank], COUNT( * ) AS [cnt] FROM [cd] [me] JOIN [artist] [artist] ON ( [artist].[artistid] = [me].[artist] ) WHERE ( [artist].[name] = ? AND [me].[year] = ? )/, [ ['artist.name' => 'Caterwauler McCrae'], ['me.year' => 2001] ], 'got correct SQL and bind parameters for count query with bracket quoting' ); ($sql, @bind) = $sql_maker->update( 'group', { 'order' => '12', 'name' => 'Bill' } ); is_same_sql_bind( $sql, \@bind, q/UPDATE [group] SET [name] = ?, [order] = ?/, [ ['name' => 'Bill'], ['order' => '12'] ], 'bracket quoted table names for UPDATE' ); done_testing; ��������������������������������������������������������������������������DBIx-Class-0.082843/t/sqlmaker/pg.t�����������������������������������������������������������������0000644�0001750�0001750�00000005751�14240132261�015763� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib 't/lib'; use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema( no_deploy => 1, quote_names => 1, storage_type => 'DBIx::Class::Storage::DBI::Pg' ); my $rs = $schema->resultset('Artist')->search_related('cds_unordered', { "me.rank" => 13 }, { prefetch => 'tracks', join => 'genre', order_by => [ 'genre.name', { -desc => \ 'tracks.title' }, { -asc => "me.name" }, { -desc => [qw(year cds_unordered.title)] } ], # me. is the artist, *NOT* the cd rows => 1, }, ); { # THIS IS AN OFFLINE TEST # We only need this so that the thing can be verified to work without PG_DSN # Executing it while "lying" this way won't work local $rs->result_source->related_source('tracks')->column_info('title')->{data_type} = 'bool'; local $rs->result_source->related_source('genre')->column_info('name')->{data_type} = 'BOOLEAN'; is_same_sql_bind( $rs->as_query, q{( SELECT "cds_unordered"."cdid", "cds_unordered"."artist", "cds_unordered"."title", "cds_unordered"."year", "cds_unordered"."genreid", "cds_unordered"."single_track", "tracks"."trackid", "tracks"."cd", "tracks"."position", "tracks"."title", "tracks"."last_updated_on", "tracks"."last_updated_at" FROM "artist" "me" JOIN ( SELECT "cds_unordered"."cdid", "cds_unordered"."artist", "cds_unordered"."title", "cds_unordered"."year", "cds_unordered"."genreid", "cds_unordered"."single_track" FROM "artist" "me" JOIN cd "cds_unordered" ON "cds_unordered"."artist" = "me"."artistid" LEFT JOIN "genre" "genre" ON "genre"."genreid" = "cds_unordered"."genreid" LEFT JOIN "track" "tracks" ON "tracks"."cd" = "cds_unordered"."cdid" WHERE "me"."rank" = ? GROUP BY "cds_unordered"."cdid", "cds_unordered"."artist", "cds_unordered"."title", "cds_unordered"."year", "cds_unordered"."genreid", "cds_unordered"."single_track", "me"."name" ORDER BY BOOL_AND("genre"."name"), BOOL_OR( tracks.title ) DESC, "me"."name" ASC, "year" DESC, "cds_unordered"."title" DESC LIMIT ? ) "cds_unordered" ON "cds_unordered"."artist" = "me"."artistid" LEFT JOIN "genre" "genre" ON "genre"."genreid" = "cds_unordered"."genreid" LEFT JOIN "track" "tracks" ON "tracks"."cd" = "cds_unordered"."cdid" WHERE "me"."rank" = ? ORDER BY "genre"."name", tracks.title DESC, "me"."name" ASC, "year" DESC, "cds_unordered"."title" DESC )}, [ [ { sqlt_datatype => 'integer', dbic_colname => 'me.rank' } => 13 ], [ DBIx::Class::SQLMaker::ClassicExtensions->__rows_bindtype => 1 ], [ { sqlt_datatype => 'integer', dbic_colname => 'me.rank' } => 13 ], ], 'correct SQL with aggregate boolean order on Pg', ); } done_testing; �����������������������DBIx-Class-0.082843/t/sqlmaker/order_by_bindtransport.t���������������������������������������������0000644�0001750�0001750�00000005444�14240132261�022132� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use Data::Dumper::Concise; use lib qw(t/lib); use DBICTest ':DiffSQL'; sub test_order { my $rs = shift; my $args = shift; local $TODO = "Not implemented" if $args->{todo}; lives_ok { is_same_sql_bind( $rs->search( { foo => 'bar' }, { order_by => $args->{order_by}, having => [ { read_count => { '>' => 5 } }, \[ 'read_count < ?', [ read_count => 8 ] ] ] } )->as_query, "( SELECT me.foo, me.bar, me.hello, me.goodbye, me.sensors, me.read_count FROM fourkeys me WHERE ( foo = ? ) HAVING read_count > ? OR read_count < ? ORDER BY $args->{order_req} )", [ [ { sqlt_datatype => 'integer', dbic_colname => 'foo' } => 'bar' ], [ { sqlt_datatype => 'int', dbic_colname => 'read_count' } => 5 ], [ { sqlt_datatype => 'int', dbic_colname => 'read_count' } => 8 ], $args->{bind} ? map { [ { dbic_colname => $_->[0] } => $_->[1] ] } @{ $args->{bind} } : () ], ) || diag Dumper $args->{order_by}; }; } my @tests = ( { order_by => \'foo DESC', order_req => 'foo DESC', bind => [], }, { order_by => { -asc => 'foo' }, order_req => 'foo ASC', bind => [], }, { order_by => { -desc => \[ 'colA LIKE ?', [ colA => 'test' ] ] }, order_req => 'colA LIKE ? DESC', bind => [ [ colA => 'test' ] ], }, { order_by => \[ 'colA LIKE ? DESC', [ colA => 'test' ] ], order_req => 'colA LIKE ? DESC', bind => [ [ colA => 'test' ] ], }, { order_by => [ { -asc => \['colA'] }, { -desc => \[ 'colB LIKE ?', [ colB => 'test' ] ] }, { -asc => \[ 'colC LIKE ?', [ colC => 'tost' ] ] }, ], order_req => 'colA ASC, colB LIKE ? DESC, colC LIKE ? ASC', bind => [ [ colB => 'test' ], [ colC => 'tost' ] ], }, { todo => 1, order_by => [ { -asc => 'colA' }, { -desc => { colB => { 'LIKE' => 'test' } } }, { -asc => { colC => { 'LIKE' => 'tost' } } } ], order_req => 'colA ASC, colB LIKE ? DESC, colC LIKE ? ASC', bind => [ [ colB => 'test' ], [ colC => 'tost' ] ], }, { todo => 1, order_by => { -desc => { colA => { LIKE => 'test' } } }, order_req => 'colA LIKE ? DESC', bind => [ [ colA => 'test' ] ], }, ); my $rs = DBICTest->init_schema->resultset('FourKeys'); test_order($rs, $_) for @tests; done_testing; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/sqlmaker/literal_with_bind.t��������������������������������������������������0000644�0001750�0001750�00000002354�14240132261�021034� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(no_populate => 1); my $ars = $schema->resultset('Artist'); my $rank = \13; my $ref1 = \['?', [name => 'foo']]; my $ref2 = \['?', [name => 'bar']]; my $ref3 = \['?', [name => 'baz']]; # do it twice, make sure the args are untouched for (1,2) { $ars->delete; lives_ok { $ars->create({ artistid => 666, name => $ref1, rank => $rank }); } 'inserted row using literal sql'; ok (($ars->search({ name => 'foo' })->first), 'row was inserted'); lives_ok { $ars->search({ name => { '=' => $ref1} })->update({ name => $ref2, rank => $rank }); } 'search/updated row using literal sql'; ok (($ars->search({ name => 'bar' })->first), 'row was updated'); lives_ok { $ars->populate([{ artistid => 777, name => $ref3, rank => $rank }]); } 'populated row using literal sql'; ok (($ars->search({ name => 'baz' })->first), 'row was populated'); } is_deeply( $ref1, \['?', [name => 'foo']], 'ref1 unchanged', ); is_deeply( $ref2, \['?', [name => 'bar']], 'ref2 unchanged', ); is_deeply( $ref3, \['?', [name => 'baz']], 'ref3 unchanged', ); done_testing; # vim:sts=2 sw=2: ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/sqlmaker/oraclejoin.t���������������������������������������������������������0000644�0001750�0001750�00000005547�14240132261�017505� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; BEGIN { require DBIx::Class::Optional::Dependencies; plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('id_shortener') unless DBIx::Class::Optional::Dependencies->req_ok_for ('id_shortener'); } use lib qw(t/lib); use DBICTest ':DiffSQL'; use DBIx::Class::SQLMaker::OracleJoins; my $sa = DBIx::Class::SQLMaker::OracleJoins->new; for my $rhs ( "me.artist", { -ident => "me.artist" } ) { # my ($self, $table, $fields, $where, $order, @rest) = @_; my ($sql, @bind) = $sa->select( [ { me => "cd" }, [ { "-join_type" => "LEFT", artist => "artist" }, { "artist.artistid" => $rhs }, ], ], [ 'cd.cdid', 'cd.artist', 'cd.title', 'cd.year', 'artist.artistid', 'artist.name' ], undef, undef ); is_same_sql_bind( $sql, \@bind, 'SELECT cd.cdid, cd.artist, cd.title, cd.year, artist.artistid, artist.name FROM cd me, artist artist WHERE ( artist.artistid(+) = me.artist )', [], 'WhereJoins search with empty where clause' ); ($sql, @bind) = $sa->select( [ { me => "cd" }, [ { "-join_type" => "", artist => "artist" }, { "artist.artistid" => $rhs }, ], ], [ 'cd.cdid', 'cd.artist', 'cd.title', 'cd.year', 'artist.artistid', 'artist.name' ], { 'artist.artistid' => 3 }, undef ); is_same_sql_bind( $sql, \@bind, 'SELECT cd.cdid, cd.artist, cd.title, cd.year, artist.artistid, artist.name FROM cd me, artist artist WHERE ( ( ( artist.artistid = me.artist ) AND ( artist.artistid = ? ) ) )', [3], 'WhereJoins search with where clause' ); ($sql, @bind) = $sa->select( [ { me => "cd" }, [ { "-join_type" => "right", artist => "artist" }, { "artist.artistid" => $rhs }, ], ], [ 'cd.cdid', 'cd.artist', 'cd.title', 'cd.year', 'artist.artistid', 'artist.name' ], { 'artist.artistid' => 3 }, undef ); is_same_sql_bind( $sql, \@bind, 'SELECT cd.cdid, cd.artist, cd.title, cd.year, artist.artistid, artist.name FROM cd me, artist artist WHERE ( ( ( artist.artistid = me.artist(+) ) AND ( artist.artistid = ? ) ) )', [3], 'WhereJoins search with where clause' ); ($sql, @bind) = $sa->select( [ { me => "cd" }, [ { "-join_type" => "LEFT", artist => "artist" }, { "artist.artistid" => $rhs }, ], ], [ 'cd.cdid', 'cd.artist', 'cd.title', 'cd.year', 'artist.artistid', 'artist.name' ], [{ 'artist.artistid' => 3 }, { 'me.cdid' => 5 }], undef ); is_same_sql_bind( $sql, \@bind, 'SELECT cd.cdid, cd.artist, cd.title, cd.year, artist.artistid, artist.name FROM cd me, artist artist WHERE ( ( ( artist.artistid(+) = me.artist ) AND ( ( ( artist.artistid = ? ) OR ( me.cdid = ? ) ) ) ) )', [3, 5], 'WhereJoins search with or in where clause' ); } done_testing; ���������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/sqlmaker/nest_deprec.t��������������������������������������������������������0000644�0001750�0001750�00000001212�14240132261�017634� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Warn; use lib qw(t/lib); use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); my $sql_maker = $schema->storage->sql_maker; # a loop so that the callsite line does not change for my $expect_warn (1, 0) { warnings_like ( sub { my ($sql, @bind) = $sql_maker->select ('foo', undef, { -nest => \ 'bar' } ); is_same_sql_bind ( $sql, \@bind, 'SELECT * FROM foo WHERE ( bar )', [], '-nest still works' ); }, ($expect_warn ? qr/\Q-nest in search conditions is deprecated/ : []), 'Only one deprecation warning' ); } done_testing; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/sqlmaker/core.t���������������������������������������������������������������0000644�0001750�0001750�00000004647�14240132261�016310� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use lib qw(t/lib); use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(no_deploy => 1); my $sql_maker = $schema->storage->sql_maker; { my ($sql, @bind) = $sql_maker->insert( 'lottery', { 'day' => '2008-11-16', 'numbers' => [13, 21, 34, 55, 89] } ); is_same_sql_bind( $sql, \@bind, q/INSERT INTO lottery (day, numbers) VALUES (?, ?)/, [ ['day' => '2008-11-16'], ['numbers' => [13, 21, 34, 55, 89]] ], 'sql_maker passes arrayrefs in insert' ); ($sql, @bind) = $sql_maker->update( 'lottery', { 'day' => '2008-11-16', 'numbers' => [13, 21, 34, 55, 89] } ); is_same_sql_bind( $sql, \@bind, q/UPDATE lottery SET day = ?, numbers = ?/, [ ['day' => '2008-11-16'], ['numbers' => [13, 21, 34, 55, 89]] ], 'sql_maker passes arrayrefs in update' ); } # make sure the cookbook caveat of { $op, \'...' } no longer applies { my ($sql, @bind) = $sql_maker->where({ last_attempt => \ '< now() - interval "12 hours"', next_attempt => { '<', \ 'now() - interval "12 hours"' }, created => [ { '<=', \ '1969' }, \ '> 1984', ], }); is_same_sql_bind( $sql, \@bind, 'WHERE (created <= 1969 OR created > 1984 ) AND last_attempt < now() - interval "12 hours" AND next_attempt < now() - interval "12 hours" ', [], ); } # Tests base class for => \'FOO' actually generates proper query. for => # 'READ'|'SHARE' is tested in db-specific subclasses # we have to instantiate base because SQLMaker::SQLite disables _lock_select { require DBIx::Class::SQLMaker; my $sa = DBIx::Class::SQLMaker->new; { my ($sql, @bind) = $sa->select('foo', '*', {}, { for => 'update' } ); is_same_sql_bind( $sql, \@bind, 'SELECT * FROM foo FOR UPDATE', [], ); } { my ($sql, @bind) = $sa->select('bar', '*', {}, { for => \'baz' } ); is_same_sql_bind( $sql, \@bind, 'SELECT * FROM bar FOR baz', [], ); } } # Make sure the carp/croak override in SQLAC works (via SQLMaker) my $file = quotemeta (__FILE__); throws_ok (sub { $schema->resultset ('Artist')->search ({}, { order_by => { -asc => 'stuff', -desc => 'staff' } } )->as_query; }, qr/$file/, 'Exception correctly croak()ed'); done_testing; �����������������������������������������������������������������������������������������DBIx-Class-0.082843/t/sqlmaker/oracle.t�������������������������������������������������������������0000644�0001750�0001750�00000032176�14240132261�016623� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; BEGIN { require DBIx::Class::Optional::Dependencies; plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('id_shortener') unless DBIx::Class::Optional::Dependencies->req_ok_for ('id_shortener'); } use Test::Exception; use Data::Dumper::Concise; use lib qw(t/lib); use DBICTest ':DiffSQL'; use DBIx::Class::SQLMaker::Oracle; # FIXME - TEMPORARY until this merges with master use constant IGNORE_NONLOCAL_BINDTYPES => 1; # # Offline test for connect_by # ( without active database connection) # my @handle_tests = ( { connect_by => { 'parentid' => { '-prior' => \'artistid' } }, stmt => '"parentid" = PRIOR artistid', bind => [], msg => 'Simple: "parentid" = PRIOR artistid', }, { connect_by => { 'parentid' => { '!=' => { '-prior' => { -ident => 'artistid' } } } }, stmt => '"parentid" != ( PRIOR "artistid" )', bind => [], msg => 'Simple: "parentid" != ( PRIOR "artistid" )', }, # Examples from http://download.oracle.com/docs/cd/B19306_01/server.102/b14200/queries003.htm # CONNECT BY last_name != 'King' AND PRIOR employee_id = manager_id ... { connect_by => [ last_name => { '!=' => 'King' }, manager_id => { '-prior' => { -ident => 'employee_id' } }, ], stmt => '( "last_name" != ? OR "manager_id" = PRIOR "employee_id" )', bind => ['King'], msg => 'oracle.com example #1', }, # CONNECT BY PRIOR employee_id = manager_id and # PRIOR account_mgr_id = customer_id ... { connect_by => { manager_id => { '-prior' => { -ident => 'employee_id' } }, customer_id => { '>', { '-prior' => \'account_mgr_id' } }, }, stmt => '( "customer_id" > ( PRIOR account_mgr_id ) AND "manager_id" = PRIOR "employee_id" )', bind => [], msg => 'oracle.com example #2', }, # CONNECT BY NOCYCLE PRIOR employee_id = manager_id AND LEVEL <= 4; # TODO: NOCYCLE parameter doesn't work ); my $sqla_oracle = DBIx::Class::SQLMaker::Oracle->new( quote_char => '"', name_sep => '.' ); isa_ok($sqla_oracle, 'DBIx::Class::SQLMaker::Oracle'); for my $case (@handle_tests) { my ( $stmt, @bind ); my $msg = sprintf("Offline: %s", $case->{msg} || substr($case->{stmt},0,25), ); lives_ok( sub { ( $stmt, @bind ) = $sqla_oracle->_recurse_where( $case->{connect_by} ); is_same_sql_bind( $stmt, \@bind, $case->{stmt}, $case->{bind},$msg ) || diag "Search term:\n" . Dumper $case->{connect_by}; } ,sprintf("lives is ok from '%s'",$msg)); } is ( $sqla_oracle->_shorten_identifier('short_id'), 'short_id', '_shorten_identifier for short id without keywords ok' ); is ( $sqla_oracle->_shorten_identifier('short_id', [qw/ foo /]), 'short_id', '_shorten_identifier for short id with one keyword ok' ); is ( $sqla_oracle->_shorten_identifier('short_id', [qw/ foo bar baz /]), 'short_id', '_shorten_identifier for short id with keywords ok' ); is ( $sqla_oracle->_shorten_identifier('very_long_identifier_which_exceeds_the_30char_limit'), 'VryLngIdntfrWhchExc_72M8CIDTM7', '_shorten_identifier without keywords ok', ); is ( $sqla_oracle->_shorten_identifier('very_long_identifier_which_exceeds_the_30char_limit',[qw/ foo /]), 'Foo_72M8CIDTM7KBAUPXG48B22P4E', '_shorten_identifier with one keyword ok', ); is ( $sqla_oracle->_shorten_identifier('very_long_identifier_which_exceeds_the_30char_limit',[qw/ foo bar baz /]), 'FooBarBaz_72M8CIDTM7KBAUPXG48B', '_shorten_identifier with keywords ok', ); # test SQL generation for INSERT ... RETURNING sub UREF { \do { my $x } }; $sqla_oracle->{bindtype} = 'columns'; for my $q ('', '"') { local $sqla_oracle->{quote_char} = $q; my ($sql, @bind) = $sqla_oracle->insert( 'artist', { 'name' => 'Testartist', }, { 'returning' => 'artistid', 'returning_container' => [], }, ); is_same_sql_bind( $sql, \@bind, "INSERT INTO ${q}artist${q} (${q}name${q}) VALUES (?) RETURNING ${q}artistid${q} INTO ?", [ [ name => 'Testartist' ], [ artistid => UREF ] ], 'sql_maker generates insert returning for one column' ); ($sql, @bind) = $sqla_oracle->insert( 'artist', { 'name' => 'Testartist', }, { 'returning' => \'artistid', 'returning_container' => [], }, ); is_same_sql_bind( $sql, \@bind, "INSERT INTO ${q}artist${q} (${q}name${q}) VALUES (?) RETURNING artistid INTO ?", [ [ name => 'Testartist' ], [ artistid => UREF ] ], 'sql_maker generates insert returning for one column' ); ($sql, @bind) = $sqla_oracle->insert( 'computed_column_test', { 'a_timestamp' => '2010-05-26 18:22:00', }, { 'returning' => [ 'id', 'a_computed_column', 'charfield' ], 'returning_container' => [], }, ); is_same_sql_bind( $sql, \@bind, "INSERT INTO ${q}computed_column_test${q} (${q}a_timestamp${q}) VALUES (?) RETURNING ${q}id${q}, ${q}a_computed_column${q}, ${q}charfield${q} INTO ?, ?, ?", [ [ a_timestamp => '2010-05-26 18:22:00' ], [ id => UREF ], [ a_computed_column => UREF ], [ charfield => UREF ] ], 'sql_maker generates insert returning for multiple columns' ); # offline version of a couple live tests my $schema = DBICTest->init_schema( # pretend this is Oracle storage_type => '::DBI::Oracle::Generic', quote_names => $q, ); # This one is testing ROWNUM, thus not directly executable on SQLite is_same_sql_bind( $schema->resultset('CD')->search(undef, { prefetch => 'very_long_artist_relationship', rows => 3, offset => 0, })->as_query, "( SELECT ${q}me${q}.${q}cdid${q}, ${q}me${q}.${q}artist${q}, ${q}me${q}.${q}title${q}, ${q}me${q}.${q}year${q}, ${q}me${q}.${q}genreid${q}, ${q}me${q}.${q}single_track${q}, ${q}VryLngArtstRltnshpA_5L2NK8TAMJ${q}, ${q}VryLngArtstRltnshpN_AZ6MM6EO7A${q}, ${q}VryLngArtstRltnshpR_D3D5S4YO5D${q}, ${q}VryLngArtstRltnshpC_94JLUHA0OX${q} FROM ( SELECT ${q}me${q}.${q}cdid${q}, ${q}me${q}.${q}artist${q}, ${q}me${q}.${q}title${q}, ${q}me${q}.${q}year${q}, ${q}me${q}.${q}genreid${q}, ${q}me${q}.${q}single_track${q}, ${q}very_long_artist_relationship${q}.${q}artistid${q} AS ${q}VryLngArtstRltnshpA_5L2NK8TAMJ${q}, ${q}very_long_artist_relationship${q}.${q}name${q} AS ${q}VryLngArtstRltnshpN_AZ6MM6EO7A${q}, ${q}very_long_artist_relationship${q}.${q}rank${q} AS ${q}VryLngArtstRltnshpR_D3D5S4YO5D${q}, ${q}very_long_artist_relationship${q}.${q}charfield${q} AS ${q}VryLngArtstRltnshpC_94JLUHA0OX${q} FROM cd ${q}me${q} JOIN ${q}artist${q} ${q}very_long_artist_relationship${q} ON ${q}very_long_artist_relationship${q}.${q}artistid${q} = ${q}me${q}.${q}artist${q} ) ${q}me${q} WHERE ROWNUM <= ? )", [ [ $sqla_oracle->__rows_bindtype => 3 ], ], 'Basic test of identifiers over the 30 char limit' ); # but the rest are directly runnable $schema->is_executed_sql_bind( sub { my @rows = $schema->resultset('Artist')->search( { 'cds_very_very_very_long_relationship_name.title' => { '!=', 'EP C' } }, { prefetch => 'cds_very_very_very_long_relationship_name', order_by => 'cds_very_very_very_long_relationship_name.title', } )->all; isa_ok( $rows[0], 'DBICTest::Schema::Artist', 'At least one artist from db', ); }, [[ "SELECT ${q}me${q}.${q}artistid${q}, ${q}me${q}.${q}name${q}, ${q}me${q}.${q}rank${q}, ${q}me${q}.${q}charfield${q}, ${q}CdsVryVryVryLngRltn_3BW932XK2E${q}.${q}cdid${q}, ${q}CdsVryVryVryLngRltn_3BW932XK2E${q}.${q}artist${q}, ${q}CdsVryVryVryLngRltn_3BW932XK2E${q}.${q}title${q}, ${q}CdsVryVryVryLngRltn_3BW932XK2E${q}.${q}year${q}, ${q}CdsVryVryVryLngRltn_3BW932XK2E${q}.${q}genreid${q}, ${q}CdsVryVryVryLngRltn_3BW932XK2E${q}.${q}single_track${q} FROM ${q}artist${q} ${q}me${q} LEFT JOIN cd ${q}CdsVryVryVryLngRltn_3BW932XK2E${q} ON ${q}CdsVryVryVryLngRltn_3BW932XK2E${q}.${q}artist${q} = ${q}me${q}.${q}artistid${q} WHERE ${q}CdsVryVryVryLngRltn_3BW932XK2E${q}.${q}title${q} != ? ORDER BY ${q}CdsVryVryVryLngRltn_3BW932XK2E${q}.${q}title${q} ", ( IGNORE_NONLOCAL_BINDTYPES ? 'EP C' : [{ dbic_colname => 'cds_very_very_very_long_relationship_name.title', sqlt_datatype => 'varchar', sqlt_size => 100, } => 'EP C' ] ), ]], 'rel name over 30 char limit with user condition, requiring walking the WHERE data structure', ); my $pain_rs = $schema->resultset('Artist')->search( { 'me.artistid' => 1 }, { join => 'cds_very_very_very_long_relationship_name', select => 'cds_very_very_very_long_relationship_name.title', as => 'title', group_by => 'cds_very_very_very_long_relationship_name.title', } ); $schema->is_executed_sql_bind( sub { my $megapain_rs = $pain_rs->search( {}, { prefetch => { cds_very_very_very_long_relationship_name => 'very_long_artist_relationship' }, having => { 'cds_very_very_very_long_relationship_name.title' => { '!=', '' } }, }, ); isa_ok( ( $megapain_rs->all )[0], 'DBICTest::Schema::Artist', 'At least one artist from db', ); ok( defined( ( $megapain_rs->get_column('title')->all )[0] ), 'get_column returns a non-null result' ); }, [ [ "SELECT ${q}CdsVryVryVryLngRltn_3BW932XK2E${q}.${q}title${q}, ${q}CdsVryVryVryLngRltn_3BW932XK2E${q}.${q}cdid${q}, ${q}CdsVryVryVryLngRltn_3BW932XK2E${q}.${q}artist${q}, ${q}CdsVryVryVryLngRltn_3BW932XK2E${q}.${q}title${q}, ${q}CdsVryVryVryLngRltn_3BW932XK2E${q}.${q}year${q}, ${q}CdsVryVryVryLngRltn_3BW932XK2E${q}.${q}genreid${q}, ${q}CdsVryVryVryLngRltn_3BW932XK2E${q}.${q}single_track${q}, ${q}very_long_artist_relationship${q}.${q}artistid${q}, ${q}very_long_artist_relationship${q}.${q}name${q}, ${q}very_long_artist_relationship${q}.${q}rank${q}, ${q}very_long_artist_relationship${q}.${q}charfield${q} FROM ${q}artist${q} ${q}me${q} LEFT JOIN cd ${q}CdsVryVryVryLngRltn_3BW932XK2E${q} ON ${q}CdsVryVryVryLngRltn_3BW932XK2E${q}.${q}artist${q} = ${q}me${q}.${q}artistid${q} LEFT JOIN ${q}artist${q} ${q}very_long_artist_relationship${q} ON ${q}very_long_artist_relationship${q}.${q}artistid${q} = ${q}CdsVryVryVryLngRltn_3BW932XK2E${q}.${q}artist${q} WHERE ${q}me${q}.${q}artistid${q} = ? GROUP BY ${q}CdsVryVryVryLngRltn_3BW932XK2E${q}.${q}title${q} HAVING ${q}CdsVryVryVryLngRltn_3BW932XK2E${q}.${q}title${q} != ? ", [{ dbic_colname => 'me.artistid', sqlt_datatype => 'integer', } => 1 ], ( IGNORE_NONLOCAL_BINDTYPES ? '' : [{ dbic_colname => 'cds_very_very_very_long_relationship_name.title', sqlt_datatype => 'varchar', sqlt_size => 100, } => '' ] ), ], [ "SELECT ${q}CdsVryVryVryLngRltn_3BW932XK2E${q}.${q}title${q} FROM ${q}artist${q} ${q}me${q} LEFT JOIN cd ${q}CdsVryVryVryLngRltn_3BW932XK2E${q} ON ${q}CdsVryVryVryLngRltn_3BW932XK2E${q}.${q}artist${q} = ${q}me${q}.${q}artistid${q} WHERE ${q}me${q}.${q}artistid${q} = ? GROUP BY ${q}CdsVryVryVryLngRltn_3BW932XK2E${q}.${q}title${q} HAVING ${q}CdsVryVryVryLngRltn_3BW932XK2E${q}.${q}title${q} != ? ", [{ dbic_colname => 'me.artistid', sqlt_datatype => 'integer', } => 1 ], ( IGNORE_NONLOCAL_BINDTYPES ? '' : [{ dbic_colname => 'cds_very_very_very_long_relationship_name.title', sqlt_datatype => 'varchar', sqlt_size => 100, } => '' ] ), ], ], 'rel names over the 30 char limit using group_by/having and join' ); is_same_sql_bind( $pain_rs->count_rs->as_query, "( SELECT COUNT( * ) FROM ( SELECT ${q}CdsVryVryVryLngRltn_3BW932XK2E${q}.${q}title${q} AS ${q}CdsVryVryVryLngRltn_7TT4PIXZGX${q} FROM ${q}artist${q} ${q}me${q} LEFT JOIN cd ${q}CdsVryVryVryLngRltn_3BW932XK2E${q} ON ${q}CdsVryVryVryLngRltn_3BW932XK2E${q}.${q}artist${q} = ${q}me${q}.${q}artistid${q} WHERE ${q}me${q}.${q}artistid${q} = ? GROUP BY ${q}CdsVryVryVryLngRltn_3BW932XK2E${q}.${q}title${q} ) ${q}me${q} )", [ [{ dbic_colname => 'me.artistid', sqlt_datatype => 'integer', } => 1 ], ], 'Expected count subquery', ); } done_testing; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/sqlmaker/legacy_joins.t�������������������������������������������������������0000644�0001750�0001750�00000005613�14240132261�020020� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest ':DiffSQL'; use DBIx::Class::_Util 'sigwarn_silencer'; use DBIx::Class::SQLMaker; my $sa = DBIx::Class::SQLMaker->new; $SIG{__WARN__} = sigwarn_silencer( qr/\Q{from} structures with conditions not conforming to the SQL::Abstract::Classic syntax are deprecated/ ); my @j = ( { child => 'person' }, [ { father => 'person' }, { 'father.person_id' => 'child.father_id' }, ], [ { mother => 'person' }, { 'mother.person_id' => 'child.mother_id' } ], ); my $match = 'person child JOIN person father ON ( father.person_id = ' . 'child.father_id ) JOIN person mother ON ( mother.person_id ' . '= child.mother_id )' ; is_same_sql( $sa->_recurse_from(@j), $match, 'join 1 ok' ); my @j2 = ( { mother => 'person' }, [ [ { child => 'person' }, [ { father => 'person' }, { 'father.person_id' => 'child.father_id' } ] ], { 'mother.person_id' => 'child.mother_id' } ], ); $match = 'person mother JOIN (person child JOIN person father ON (' . ' father.person_id = child.father_id )) ON ( mother.person_id = ' . 'child.mother_id )' ; is_same_sql( $sa->_recurse_from(@j2), $match, 'join 2 ok' ); my @j3 = ( { child => 'person' }, [ { father => 'person', -join_type => 'inner' }, { 'father.person_id' => 'child.father_id' }, ], [ { mother => 'person', -join_type => 'inner' }, { 'mother.person_id' => 'child.mother_id' } ], ); $match = 'person child INNER JOIN person father ON ( father.person_id = ' . 'child.father_id ) INNER JOIN person mother ON ( mother.person_id ' . '= child.mother_id )' ; is_same_sql( $sa->_recurse_from(@j3), $match, 'join 3 (inner join) ok' ); my @j4 = ( { mother => 'person' }, [ [ { child => 'person', -join_type => 'left' }, [ { father => 'person', -join_type => 'right' }, { 'father.person_id' => 'child.father_id' } ] ], { 'mother.person_id' => 'child.mother_id' } ], ); $match = 'person mother LEFT JOIN (person child RIGHT JOIN person father ON (' . ' father.person_id = child.father_id )) ON ( mother.person_id = ' . 'child.mother_id )' ; is_same_sql( $sa->_recurse_from(@j4), $match, 'join 4 (nested joins + join types) ok' ); my @j5 = ( { child => 'person' }, [ { father => 'person' }, { 'father.person_id' => \'!= child.father_id' }, ], [ { mother => 'person' }, { 'mother.person_id' => 'child.mother_id' } ], ); $match = 'person child JOIN person father ON ( father.person_id != ' . 'child.father_id ) JOIN person mother ON ( mother.person_id ' . '= child.mother_id )' ; is_same_sql( $sa->_recurse_from(@j5), $match, 'join 5 (SCALAR reference for ON statement) ok' ); done_testing; ���������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/sqlmaker/dbihacks_internals.t�������������������������������������������������0000644�0001750�0001750�00000053773�14240132261�021213� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Warn; use Test::Exception; use lib qw(t/lib); use DBICTest ':DiffSQL'; use DBIx::Class::_Util 'UNRESOLVABLE_CONDITION'; use Data::Dumper; BEGIN { if ( eval { require Test::Differences } ) { no warnings 'redefine'; *is_deeply = \&Test::Differences::eq_or_diff; } } my $schema = DBICTest->init_schema( no_deploy => 1); my $sm = $schema->storage->sql_maker; { package # hideee DBICTest::SillyInt; use overload fallback => 1, '0+' => sub { ${$_[0]} }, ; } my $num = bless( \do { my $foo = 69 }, 'DBICTest::SillyInt' ); is($num, 69, 'test overloaded object is "sane"'); is("$num", 69, 'test overloaded object is "sane"'); my @tests = ( { where => { artistid => 1, charfield => undef }, cc_result => { artistid => 1, charfield => undef }, sql => 'WHERE artistid = ? AND charfield IS NULL', efcc_result => { artistid => 1 }, efcc_n_result => { artistid => 1, charfield => undef }, }, { where => { -and => [ artistid => 1, charfield => undef, { rank => 13 } ] }, cc_result => { artistid => 1, charfield => undef, rank => 13 }, sql => 'WHERE artistid = ? AND charfield IS NULL AND rank = ?', efcc_result => { artistid => 1, rank => 13 }, efcc_n_result => { artistid => 1, charfield => undef, rank => 13 }, }, { where => { -and => [ { artistid => 1, charfield => undef}, { rank => 13 } ] }, cc_result => { artistid => 1, charfield => undef, rank => 13 }, sql => 'WHERE artistid = ? AND charfield IS NULL AND rank = ?', efcc_result => { artistid => 1, rank => 13 }, efcc_n_result => { artistid => 1, charfield => undef, rank => 13 }, }, { where => { -and => [ -or => { name => 'Caterwauler McCrae' }, 'rank' ] }, cc_result => { name => 'Caterwauler McCrae', rank => undef }, sql => 'WHERE name = ? AND rank IS NULL', efcc_result => { name => 'Caterwauler McCrae' }, efcc_n_result => { name => 'Caterwauler McCrae', rank => undef }, }, { where => { -and => [ [ [ artist => {'=' => \'foo' } ] ], { name => \[ '= ?', 'bar' ] } ] }, cc_result => { artist => {'=' => \'foo' }, name => \[ '= ?', 'bar' ] }, sql => 'WHERE artist = foo AND name = ?', efcc_result => { artist => \'foo' }, }, { where => { -and => [ -or => { name => 'Caterwauler McCrae', artistid => 2 } ] }, cc_result => { -or => [ artistid => 2, name => 'Caterwauler McCrae' ] }, sql => 'WHERE artistid = ? OR name = ?', efcc_result => {}, }, { where => { -or => { name => 'Caterwauler McCrae', artistid => 2 } }, cc_result => { -or => [ artistid => 2, name => 'Caterwauler McCrae' ] }, sql => 'WHERE artistid = ? OR name = ?', efcc_result => {}, }, { where => { -and => [ \'foo=bar', [ { artistid => { '=', $num } } ], { name => 'Caterwauler McCrae'} ] }, cc_result => { -and => [ \'foo=bar' ], name => 'Caterwauler McCrae', artistid => $num }, sql => 'WHERE foo=bar AND artistid = ? AND name = ?', efcc_result => { name => 'Caterwauler McCrae', artistid => $num }, }, { where => { -and => [ \'foo=bar', [ { artistid => { '=', $num } } ], { name => 'Caterwauler McCrae'}, \'buzz=bozz' ] }, cc_result => { -and => [ \'foo=bar', \'buzz=bozz' ], name => 'Caterwauler McCrae', artistid => $num }, sql => 'WHERE foo=bar AND artistid = ? AND name = ? AND buzz=bozz', collapsed_sql => 'WHERE foo=bar AND buzz=bozz AND artistid = ? AND name = ?', efcc_result => { name => 'Caterwauler McCrae', artistid => $num }, }, { where => { artistid => [ $num ], rank => [ 13, 2, 3 ], charfield => [ undef ] }, cc_result => { artistid => $num, charfield => undef, rank => [13, 2, 3] }, sql => 'WHERE artistid = ? AND charfield IS NULL AND ( rank = ? OR rank = ? OR rank = ? )', efcc_result => { artistid => $num }, efcc_n_result => { artistid => $num, charfield => undef }, }, { where => { artistid => { '=' => 1 }, rank => { '>' => 12 }, charfield => { '=' => undef } }, cc_result => { artistid => 1, charfield => undef, rank => { '>' => 12 } }, sql => 'WHERE artistid = ? AND charfield IS NULL AND rank > ?', efcc_result => { artistid => 1 }, efcc_n_result => { artistid => 1, charfield => undef }, }, { where => { artistid => { '=' => [ 1 ], }, charfield => { '=' => [ -AND => \'1', \['?',2] ] }, rank => { '=' => [ -OR => $num, $num ] } }, cc_result => { artistid => 1, charfield => [-and => { '=' => \['?',2] }, { '=' => \'1' } ], rank => { '=' => [$num, $num] } }, sql => 'WHERE artistid = ? AND charfield = 1 AND charfield = ? AND ( rank = ? OR rank = ? )', collapsed_sql => 'WHERE artistid = ? AND charfield = ? AND charfield = 1 AND ( rank = ? OR rank = ? )', efcc_result => { artistid => 1, charfield => UNRESOLVABLE_CONDITION }, }, { where => { -and => [ artistid => 1, artistid => 2 ], name => [ -and => { '!=', 1 }, 2 ], charfield => [ -or => { '=', 2 } ], rank => [-and => undef, { '=', undef }, { '!=', 2 } ] }, cc_result => { artistid => [ -and => 1, 2 ], name => [ -and => { '!=', 1 }, 2 ], charfield => 2, rank => [ -and => { '!=', 2 }, undef ] }, sql => 'WHERE artistid = ? AND artistid = ? AND charfield = ? AND name != ? AND name = ? AND rank IS NULL AND rank IS NULL AND rank != ?', collapsed_sql => 'WHERE artistid = ? AND artistid = ? AND charfield = ? AND name != ? AND name = ? AND rank != ? AND rank IS NULL', efcc_result => { artistid => UNRESOLVABLE_CONDITION, name => 2, charfield => 2, }, efcc_n_result => { artistid => UNRESOLVABLE_CONDITION, name => 2, charfield => 2, rank => undef, }, }, (map { { where => $_, sql => 'WHERE (rank = 13 OR charfield IS NULL OR artistid = ?) AND (artistid = ? OR charfield IS NULL OR rank != 42)', collapsed_sql => 'WHERE (artistid = ? OR charfield IS NULL OR rank = 13) AND (artistid = ? OR charfield IS NULL OR rank != 42)', cc_result => { -and => [ { -or => [ artistid => 1, charfield => undef, rank => { '=' => \13 } ] }, { -or => [ artistid => 1, charfield => undef, rank => { '!=' => \42 } ] }, ] }, efcc_result => {}, efcc_n_result => {}, } } ( { -and => [ -or => [ rank => { '=' => \13 }, charfield => { '=' => undef }, artistid => 1 ], -or => { artistid => { '=' => 1 }, charfield => undef, rank => { '!=' => \42 } }, ] }, { -OR => [ rank => { '=' => \13 }, charfield => { '=' => undef }, artistid => 1 ], -or => { artistid => { '=' => 1 }, charfield => undef, rank => { '!=' => \42 } }, }, ) ), { where => { -or => [ -and => [ foo => { '!=', { -value => undef } }, bar => { -in => [ 69, 42 ] } ], foo => { '=', { -value => undef } }, baz => { '!=' => { -ident => 'bozz' } }, baz => { -ident => 'buzz' }, ] }, sql => 'WHERE ( foo IS NOT NULL AND bar IN ( ?, ? ) ) OR foo IS NULL OR baz != bozz OR baz = buzz', collapsed_sql => 'WHERE baz != bozz OR baz = buzz OR foo IS NULL OR ( bar IN ( ?, ? ) AND foo IS NOT NULL )', cc_result => { -or => [ baz => { '!=' => { -ident => 'bozz' } }, baz => { '=' => { -ident => 'buzz' } }, foo => undef, { bar => { -in => [ 69, 42 ] }, foo => { '!=', undef } } ] }, efcc_result => {}, }, { where => { -or => [ rank => { '=' => \13 }, charfield => { '=' => undef }, artistid => { '=' => 1 }, genreid => { '=' => \['?', 2] } ] }, sql => 'WHERE rank = 13 OR charfield IS NULL OR artistid = ? OR genreid = ?', collapsed_sql => 'WHERE artistid = ? OR charfield IS NULL OR genreid = ? OR rank = 13', cc_result => { -or => [ artistid => 1, charfield => undef, genreid => { '=' => \['?', 2] }, rank => { '=' => \13 } ] }, efcc_result => {}, efcc_n_result => {}, }, { where => { -and => [ -or => [ rank => { '=' => \13 }, charfield => { '=' => undef }, artistid => 1 ], -or => { artistid => { '=' => 1 }, charfield => undef, rank => { '=' => \13 } }, ] }, cc_result => { -and => [ { -or => [ artistid => 1, charfield => undef, rank => { '=' => \13 } ] }, { -or => [ artistid => 1, charfield => undef, rank => { '=' => \13 } ] }, ] }, sql => 'WHERE (rank = 13 OR charfield IS NULL OR artistid = ?) AND (artistid = ? OR charfield IS NULL OR rank = 13)', collapsed_sql => 'WHERE (artistid = ? OR charfield IS NULL OR rank = 13) AND (artistid = ? OR charfield IS NULL OR rank = 13)', efcc_result => {}, efcc_n_result => {}, }, { where => { -and => [ -or => [ rank => { '=' => \13 }, charfield => { '=' => undef }, artistid => 1 ], -or => { artistid => { '=' => 1 }, charfield => undef, rank => { '!=' => \42 } }, -and => [ foo => { '=' => \1 }, bar => 2 ], -and => [ foo => 3, bar => { '=' => \4 } ], -exists => \'(SELECT 1)', -exists => \'(SELECT 2)', -not => { foo => 69 }, -not => { foo => 42 }, ]}, sql => 'WHERE ( rank = 13 OR charfield IS NULL OR artistid = ? ) AND ( artistid = ? OR charfield IS NULL OR rank != 42 ) AND foo = 1 AND bar = ? AND foo = ? AND bar = 4 AND (EXISTS (SELECT 1)) AND (EXISTS (SELECT 2)) AND NOT foo = ? AND NOT foo = ? ', collapsed_sql => 'WHERE ( artistid = ? OR charfield IS NULL OR rank = 13 ) AND ( artistid = ? OR charfield IS NULL OR rank != 42 ) AND (EXISTS (SELECT 1)) AND (EXISTS (SELECT 2)) AND NOT foo = ? AND NOT foo = ? AND bar = 4 AND bar = ? AND foo = 1 AND foo = ? ', cc_result => { -and => [ { -or => [ artistid => 1, charfield => undef, rank => { '=' => \13 } ] }, { -or => [ artistid => 1, charfield => undef, rank => { '!=' => \42 } ] }, { -exists => \'(SELECT 1)' }, { -exists => \'(SELECT 2)' }, { -not => { foo => 69 } }, { -not => { foo => 42 } }, ], foo => [ -and => { '=' => \1 }, 3 ], bar => [ -and => { '=' => \4 }, 2 ], }, efcc_result => { foo => UNRESOLVABLE_CONDITION, bar => UNRESOLVABLE_CONDITION, }, efcc_n_result => { foo => UNRESOLVABLE_CONDITION, bar => UNRESOLVABLE_CONDITION, }, }, { where => { -and => [ [ '_macro.to' => { -like => '%correct%' }, '_wc_macros.to' => { -like => '%correct%' } ], { -and => [ { 'group.is_active' => 1 }, { 'me.is_active' => 1 } ] } ] }, cc_result => { 'group.is_active' => 1, 'me.is_active' => 1, -or => [ '_macro.to' => { -like => '%correct%' }, '_wc_macros.to' => { -like => '%correct%' }, ], }, sql => 'WHERE ( _macro.to LIKE ? OR _wc_macros.to LIKE ? ) AND group.is_active = ? AND me.is_active = ?', efcc_result => { 'group.is_active' => 1, 'me.is_active' => 1 }, }, { where => { -and => [ artistid => { -value => [1] }, charfield => { -ident => 'foo' }, name => { '=' => { -value => undef } }, rank => { '=' => { -ident => 'bar' } }, ] }, sql => 'WHERE artistid = ? AND charfield = foo AND name IS NULL AND rank = bar', cc_result => { artistid => { -value => [1] }, name => undef, charfield => { '=', { -ident => 'foo' } }, rank => { '=' => { -ident => 'bar' } }, }, efcc_result => { artistid => [1], charfield => { -ident => 'foo' }, rank => { -ident => 'bar' }, }, efcc_n_result => { artistid => [1], name => undef, charfield => { -ident => 'foo' }, rank => { -ident => 'bar' }, }, }, { where => { artistid => [] }, cc_result => { artistid => [] }, efcc_result => {}, }, (map { { where => { -and => $_ }, cc_result => undef, efcc_result => {}, sql => '', }, { where => { -or => $_ }, cc_result => undef, efcc_result => {}, sql => '', }, { where => { -or => [ foo => 1, $_ ] }, cc_result => { foo => 1 }, efcc_result => { foo => 1 }, sql => 'WHERE foo = ?', }, { where => { -or => [ $_, foo => 1 ] }, cc_result => { foo => 1 }, efcc_result => { foo => 1 }, sql => 'WHERE foo = ?', }, { where => { -and => [ fuu => 2, $_, foo => 1 ] }, sql => 'WHERE fuu = ? AND foo = ?', collapsed_sql => 'WHERE foo = ? AND fuu = ?', cc_result => { foo => 1, fuu => 2 }, efcc_result => { foo => 1, fuu => 2 }, }, } ( # bare [], {}, # singles [ {} ], [ [] ], # doubles [ [], [] ], [ {}, {} ], [ [], {} ], [ {}, [] ], # tripples [ {}, [], {} ], [ [], {}, [] ] )), # FIXME legacy compat crap, possibly worth undef/dieing in SQLMaker { where => { artistid => {} }, sql => '', cc_result => undef, efcc_result => {}, efcc_n_result => {} }, # batshit insanity, just to be thorough { where => { -and => [ [ 'artistid' ], [ -and => [ artistid => { '!=', 69 }, artistid => undef, artistid => { '=' => 200 } ]], artistid => [], { -or => [] }, { -and => [] }, [ 'charfield' ], { name => [] }, 'rank' ] }, cc_result => { artistid => [ -and => [], { '!=', 69 }, undef, 200 ], charfield => undef, name => [], rank => undef }, sql => 'WHERE artistid IS NULL AND artistid != ? AND artistid IS NULL AND artistid = ? AND 0=1 AND charfield IS NULL AND 0=1 AND rank IS NULL', collapsed_sql => 'WHERE 0=1 AND artistid != ? AND artistid IS NULL AND artistid = ? AND charfield IS NULL AND 0=1 AND rank IS NULL', efcc_result => { artistid => UNRESOLVABLE_CONDITION }, efcc_n_result => { artistid => UNRESOLVABLE_CONDITION, charfield => undef, rank => undef }, }, # original test from RT#93244 { where => { -and => [ \[ "LOWER(me.title) LIKE ?", '%spoon%', ], [ { 'me.title' => 'Spoonful of bees' } ], ]}, cc_result => { -and => [ \[ "LOWER(me.title) LIKE ?", '%spoon%', ]], 'me.title' => 'Spoonful of bees', }, sql => 'WHERE LOWER(me.title) LIKE ? AND me.title = ?', efcc_result => { 'me.title' => 'Spoonful of bees' }, }, # original from RT#132390 { where => { array_col => { '@>' => { -value => [ 1,2,3 ] } } }, cc_result => { array_col => { '@>' => { -value => [ 1,2,3 ] } } }, sql => 'WHERE array_col @> ?', efcc_result => {}, }, # crazy literals { where => { -or => [ \'foo = bar', ], }, sql => 'WHERE foo = bar', cc_result => { -and => [ \'foo = bar', ], }, efcc_result => {}, }, { where => { -or => [ \'foo = bar', \'baz = ber', ], }, sql => 'WHERE foo = bar OR baz = ber', collapsed_sql => 'WHERE baz = ber OR foo = bar', cc_result => { -or => [ \'baz = ber', \'foo = bar', ], }, efcc_result => {}, }, { where => { -and => [ \'foo = bar', \'baz = ber', ], }, sql => 'WHERE foo = bar AND baz = ber', cc_result => { -and => [ \'foo = bar', \'baz = ber', ], }, efcc_result => {}, }, { where => { -and => [ \'foo = bar', \'baz = ber', x => { -ident => 'y' }, ], }, sql => 'WHERE foo = bar AND baz = ber AND x = y', cc_result => { -and => [ \'foo = bar', \'baz = ber', ], x => { '=' => { -ident => 'y' } } }, efcc_result => { x => { -ident => 'y' } }, }, ); # these die as of SQLAC 1.80 - make sure we do not transform them # into something usable instead for my $lhs (undef, '', { -ident => 'foo' }, { -value => 'foo' } ) { no warnings 'uninitialized'; for my $w ( ( map { { -or => $_ }, (ref $lhs ? () : { @$_ } ) } [ $lhs => "foo" ], [ $lhs => { "=" => "bozz" } ], [ $lhs => { "=" => \"bozz" } ], [ $lhs => { -max => \"bizz" } ], ), (ref $lhs) ? () : ( { -or => [ -and => { $lhs => "baz" }, bizz => "buzz" ] }, { -or => [ foo => "bar", { $lhs => "baz" }, bizz => "buzz" ] }, { foo => "bar", -or => { $lhs => "baz" } }, { foo => "bar", -or => { $lhs => \"baz" }, bizz => "buzz" }, ), { foo => "bar", -and => [ $lhs => \"baz" ], bizz => "buzz" }, { foo => "bar", -or => [ $lhs => \"baz" ], bizz => "buzz" }, { -or => [ foo => "bar", [ $lhs => \"baz" ], bizz => "buzz" ] }, { -or => [ foo => "bar", $lhs => \"baz", bizz => "buzz" ] }, { -or => [ foo => "bar", $lhs => \["baz"], bizz => "buzz" ] }, { -or => [ $lhs => \"baz" ] }, { -or => [ $lhs => \["baz"] ] }, ) { push @tests, { where => $w, throw => qr/ \QSupplying an empty left hand side argument is not supported in \E(?:array|hash)-pairs | \QIllegal use of top-level '-\E(?:value|ident)' /x, } } } # these are deprecated as of SQLAC 1.79 - make sure we do not transform # them without losing the warning for my $lhs (undef, '') { for my $rhs ( \"baz", \[ "baz" ] ) { no warnings 'uninitialized'; my $expected_warning = qr/\QHash-pairs consisting of an empty string with a literal are deprecated/; push @tests, { where => { $lhs => $rhs }, cc_result => { -and => [ $rhs ] }, efcc_result => {}, sql => 'WHERE baz', warn => $expected_warning, }; for my $w ( { foo => "bar", -and => { $lhs => $rhs }, bizz => "buzz" }, { foo => "bar", $lhs => $rhs, bizz => "buzz" }, ) { push @tests, { where => $w, cc_result => { -and => [ $rhs ], bizz => "buzz", foo => "bar", }, efcc_result => { foo => "bar", bizz => "buzz", }, sql => 'WHERE baz AND bizz = ? AND foo = ?', warn => $expected_warning, }; } } } # lots of extra silly tests with a false column for my $eq ( \"= baz", \[ "= baz" ], { '=' => { -ident => 'baz' } }, { '=' => \'baz' }, ) { for my $where ( { foo => "bar", -and => [ 0 => $eq ], bizz => "buzz" }, { foo => "bar", -or => [ 0 => $eq ], bizz => "buzz" }, { foo => "bar", -and => { 0 => $eq }, bizz => "buzz" }, { foo => "bar", -or => { 0 => $eq }, bizz => "buzz" }, { foo => "bar", 0 => $eq, bizz => "buzz" }, ) { push @tests, { where => $where, cc_result => { 0 => $eq, foo => 'bar', bizz => 'buzz', }, efcc_result => { foo => 'bar', bizz => 'buzz', ( ref $eq eq 'HASH' ? ( 0 => $eq->{'='} ) : () ), }, sql => 'WHERE 0 = baz AND bizz = ? AND foo = ?', }; push @tests, { where => { -or => $where }, cc_result => { -or => [ "0" => $eq, bizz => 'buzz', foo => 'bar', ]}, efcc_result => {}, sql => 'WHERE 0 = baz OR bizz = ? OR foo = ?', } } for my $where ( [ foo => "bar", -and => [ 0 => $eq ], bizz => "buzz" ], [ foo => "bar", -or => [ 0 => $eq ], bizz => "buzz" ], [ foo => "bar", -and => { 0 => $eq }, bizz => "buzz" ], [ foo => "bar", -or => { 0 => $eq }, bizz => "buzz" ], [ foo => "bar", 0 => $eq, bizz => "buzz" ], ) { push @tests, { where => { -or => $where }, cc_result => { -or => [ "0" => $eq, bizz => 'buzz', foo => 'bar', ]}, efcc_result => {}, sql => 'WHERE foo = ? OR 0 = baz OR bizz = ?', collapsed_sql => 'WHERE 0 = baz OR bizz = ? OR foo = ?', } } for my $where ( [ {foo => "bar"}, -and => { 0 => "baz" }, bizz => "buzz" ], [ -or => [ foo => "bar", -or => { 0 => "baz" }, bizz => "buzz" ] ], ) { push @tests, { where => { -or => $where }, cc_result => { -or => [ "0" => 'baz', bizz => 'buzz', foo => 'bar', ]}, efcc_result => {}, sql => 'WHERE foo = ? OR 0 = ? OR bizz = ?', collapsed_sql => 'WHERE 0 = ? OR bizz = ? OR foo = ?', }; } }; for my $t (@tests) { for my $w ( $t->{where}, $t->{where}, # do it twice, make sure we didn't destory the condition [ -and => $t->{where} ], [ -AND => $t->{where} ], { -OR => [ -AND => $t->{where} ] }, ( ( keys %{$t->{where}} == 1 and length( (keys %{$t->{where}})[0] ) ) ? [ %{$t->{where}} ] : () ), ( (keys %{$t->{where}} == 1 and $t->{where}{-or}) ? ( ref $t->{where}{-or} eq 'HASH' ? [ map { $_ => $t->{where}{-or}{$_} } sort keys %{$t->{where}{-or}} ] : $t->{where}{-or} ) : () ), ) { die unless Test::Builder->new->is_passing; my $name = do { local ($Data::Dumper::Indent, $Data::Dumper::Terse, $Data::Dumper::Sortkeys) = (0, 1, 1); Dumper $w }; my ($collapsed_cond, $collapsed_cond_as_sql); if ($t->{throw}) { throws_ok { $collapsed_cond = $schema->storage->_collapse_cond($w); ($collapsed_cond_as_sql) = $sm->where($collapsed_cond); } $t->{throw}, "Exception on attempted collapse/render of $name" and next; } warnings_exist { $collapsed_cond = $schema->storage->_collapse_cond($w); ($collapsed_cond_as_sql) = $sm->where($collapsed_cond); } $t->{warn} || [], "Expected warning when collapsing/rendering $name"; is_deeply( $collapsed_cond, $t->{cc_result}, "Expected collapsed condition produced on $name", ); my ($original_sql) = do { local $SIG{__WARN__} = sub {}; $sm->where($w); }; is_same_sql ( $original_sql, $t->{sql}, "Expected original SQL from $name" ) if exists $t->{sql}; is_same_sql( $collapsed_cond_as_sql, ( $t->{collapsed_sql} || $t->{sql} || $original_sql ), "Collapse did not alter *the semantics* of the final SQL based on $name", ); is_deeply( $schema->storage->_extract_fixed_condition_columns($collapsed_cond), $t->{efcc_result}, "Expected fixed_condition produced on $name", ); is_deeply( $schema->storage->_extract_fixed_condition_columns($collapsed_cond, 'consider_nulls'), $t->{efcc_n_result}, "Expected fixed_condition including NULLs produced on $name", ) if $t->{efcc_n_result}; is_deeply( $collapsed_cond, $t->{cc_result}, "Collapsed condition result unaltered by fixed condition extractor", ); } } done_testing; �����DBIx-Class-0.082843/t/sqlmaker/rebase.t�������������������������������������������������������������0000644�0001750�0001750�00000003177�14240132261�016616� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; # test relies on the original default BEGIN { delete @ENV{qw( DBICTEST_SWAPOUT_SQLAC_WITH )} } use Test::More; use lib qw(t/lib); use DBICTest ':DiffSQL'; my $base_schema = DBICTest->init_schema( no_deploy => 1, ); my $schema = $base_schema->connect( sub { $base_schema->storage->dbh }, { on_connect_call => [ [ rebase_sqlmaker => 'DBICTest::SQLMRebase' ] ], }, ); ok (! $base_schema->storage->connected, 'No connection on base schema yet'); ok (! $schema->storage->connected, 'No connection on experimental schema yet'); $schema->storage->ensure_connected; is( $schema->storage->sql_maker->__select_counter, undef, "No statements registered yet", ); is_deeply( mro::get_linear_isa( ref( $schema->storage->sql_maker ) ), [ qw( DBIx::Class::SQLMaker::SQLite__REBASED_ON__DBICTest::SQLMRebase DBIx::Class::SQLMaker::SQLite DBIx::Class::SQLMaker DBICTest::SQLMRebase DBIx::Class::SQLMaker::ClassicExtensions ), @{ mro::get_linear_isa( 'DBIx::Class' ) }, @{ mro::get_linear_isa( 'SQL::Abstract::Classic' ) }, ], 'Expected SQLM object inheritance after rebase', ); $schema->resultset('Artist')->count_rs->as_query; is( $schema->storage->sql_maker->__select_counter, 1, "1 SELECT fired off, tickling override", ); $base_schema->resultset('Artist')->count_rs->as_query; is( ref( $base_schema->storage->sql_maker ), 'DBIx::Class::SQLMaker::SQLite', 'Expected core SQLM object on original schema remains', ); is( $schema->storage->sql_maker->__select_counter, 1, "No further SELECTs seen by experimental override", ); done_testing; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/sqlmaker/hierarchical/��������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�017617� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/sqlmaker/hierarchical/oracle.t������������������������������������������������0000644�0001750�0001750�00000023754�14240132261�021243� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBIx::Class::Optional::Dependencies; plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('id_shortener') unless DBIx::Class::Optional::Dependencies->req_ok_for ('id_shortener'); use DBICTest::Schema::Artist; BEGIN { DBICTest::Schema::Artist->add_column('parentid'); DBICTest::Schema::Artist->has_many( children => 'DBICTest::Schema::Artist', { 'foreign.parentid' => 'self.artistid' } ); DBICTest::Schema::Artist->belongs_to( parent => 'DBICTest::Schema::Artist', { 'foreign.artistid' => 'self.parentid' } ); } use DBICTest ':DiffSQL'; my $ROWS = DBIx::Class::SQLMaker::ClassicExtensions->__rows_bindtype; my $TOTAL = DBIx::Class::SQLMaker::ClassicExtensions->__total_bindtype; for my $q ( '', '"' ) { my $schema = DBICTest->init_schema( storage_type => 'DBIx::Class::Storage::DBI::Oracle::Generic', no_deploy => 1, quote_char => $q, ); # select the whole tree { my $rs = $schema->resultset('Artist')->search({}, { start_with => { name => 'root' }, connect_by => { parentid => { -prior => { -ident => 'artistid' } } }, }); is_same_sql_bind ( $rs->as_query, "( SELECT ${q}me${q}.${q}artistid${q}, ${q}me${q}.${q}name${q}, ${q}me${q}.${q}rank${q}, ${q}me${q}.${q}charfield${q}, ${q}me${q}.${q}parentid${q} FROM ${q}artist${q} ${q}me${q} START WITH ${q}name${q} = ? CONNECT BY ${q}parentid${q} = PRIOR ${q}artistid${q} )", [ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 } => 'root'] ], ); is_same_sql_bind ( $rs->count_rs->as_query, "( SELECT COUNT( * ) FROM ${q}artist${q} ${q}me${q} START WITH ${q}name${q} = ? CONNECT BY ${q}parentid${q} = PRIOR ${q}artistid${q} )", [ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 } => 'root'] ], ); } # use order siblings by statement { my $rs = $schema->resultset('Artist')->search({}, { start_with => { name => 'root' }, connect_by => { parentid => { -prior => { -ident => 'artistid' } } }, order_siblings_by => { -desc => 'name' }, }); is_same_sql_bind ( $rs->as_query, "( SELECT ${q}me${q}.${q}artistid${q}, ${q}me${q}.${q}name${q}, ${q}me${q}.${q}rank${q}, ${q}me${q}.${q}charfield${q}, ${q}me${q}.${q}parentid${q} FROM ${q}artist${q} ${q}me${q} START WITH ${q}name${q} = ? CONNECT BY ${q}parentid${q} = PRIOR ${q}artistid${q} ORDER SIBLINGS BY ${q}name${q} DESC )", [ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 } => 'root'] ], ); } # get the root node { my $rs = $schema->resultset('Artist')->search({ parentid => undef }, { start_with => { name => 'root' }, connect_by => { parentid => { -prior => { -ident => 'artistid' } } }, }); is_same_sql_bind ( $rs->as_query, "( SELECT ${q}me${q}.${q}artistid${q}, ${q}me${q}.${q}name${q}, ${q}me${q}.${q}rank${q}, ${q}me${q}.${q}charfield${q}, ${q}me${q}.${q}parentid${q} FROM ${q}artist${q} ${q}me${q} WHERE ( ${q}parentid${q} IS NULL ) START WITH ${q}name${q} = ? CONNECT BY ${q}parentid${q} = PRIOR ${q}artistid${q} )", [ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 } => 'root'] ], ); } # combine a connect by with a join { my $rs = $schema->resultset('Artist')->search( {'cds.title' => { -like => '%cd'} }, { join => 'cds', start_with => { 'me.name' => 'root' }, connect_by => { parentid => { -prior => { -ident => 'artistid' } } }, } ); is_same_sql_bind ( $rs->as_query, "( SELECT ${q}me${q}.${q}artistid${q}, ${q}me${q}.${q}name${q}, ${q}me${q}.${q}rank${q}, ${q}me${q}.${q}charfield${q}, ${q}me${q}.${q}parentid${q} FROM ${q}artist${q} ${q}me${q} LEFT JOIN cd ${q}cds${q} ON ${q}cds${q}.${q}artist${q} = ${q}me${q}.${q}artistid${q} WHERE ( ${q}cds${q}.${q}title${q} LIKE ? ) START WITH ${q}me${q}.${q}name${q} = ? CONNECT BY ${q}parentid${q} = PRIOR ${q}artistid${q} )", [ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'cds.title', 'sqlt_size' => 100 } => '%cd'], [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'me.name', 'sqlt_size' => 100 } => 'root'], ], ); is_same_sql_bind ( $rs->count_rs->as_query, "( SELECT COUNT( * ) FROM ${q}artist${q} ${q}me${q} LEFT JOIN cd ${q}cds${q} ON ${q}cds${q}.${q}artist${q} = ${q}me${q}.${q}artistid${q} WHERE ( ${q}cds${q}.${q}title${q} LIKE ? ) START WITH ${q}me${q}.${q}name${q} = ? CONNECT BY ${q}parentid${q} = PRIOR ${q}artistid${q} )", [ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'cds.title', 'sqlt_size' => 100 } => '%cd'], [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'me.name', 'sqlt_size' => 100 } => 'root'], ], ); } # combine a connect by with order_by { my $rs = $schema->resultset('Artist')->search({}, { start_with => { name => 'root' }, connect_by => { parentid => { -prior => { -ident => 'artistid' } } }, order_by => { -asc => [ 'LEVEL', 'name' ] }, }); is_same_sql_bind ( $rs->as_query, "( SELECT ${q}me${q}.${q}artistid${q}, ${q}me${q}.${q}name${q}, ${q}me${q}.${q}rank${q}, ${q}me${q}.${q}charfield${q}, ${q}me${q}.${q}parentid${q} FROM ${q}artist${q} ${q}me${q} START WITH ${q}name${q} = ? CONNECT BY ${q}parentid${q} = PRIOR ${q}artistid${q} ORDER BY ${q}LEVEL${q} ASC, ${q}name${q} ASC )", [ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 } => 'root'], ], ); } # limit a connect by { my $rs = $schema->resultset('Artist')->search({}, { start_with => { name => 'root' }, connect_by => { parentid => { -prior => { -ident => 'artistid' } } }, order_by => [ { -asc => 'name' }, { -desc => 'artistid' } ], rows => 2, }); is_same_sql_bind ( $rs->as_query, "( SELECT ${q}me${q}.${q}artistid${q}, ${q}me${q}.${q}name${q}, ${q}me${q}.${q}rank${q}, ${q}me${q}.${q}charfield${q}, ${q}me${q}.${q}parentid${q} FROM ( SELECT ${q}me${q}.${q}artistid${q}, ${q}me${q}.${q}name${q}, ${q}me${q}.${q}rank${q}, ${q}me${q}.${q}charfield${q}, ${q}me${q}.${q}parentid${q} FROM ${q}artist${q} ${q}me${q} START WITH ${q}name${q} = ? CONNECT BY ${q}parentid${q} = PRIOR ${q}artistid${q} ORDER BY ${q}name${q} ASC, ${q}artistid${q} DESC ) ${q}me${q} WHERE ROWNUM <= ? )", [ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 } => 'root'], [ $ROWS => 2 ], ], ); is_same_sql_bind ( $rs->count_rs->as_query, "( SELECT COUNT( * ) FROM ( SELECT ${q}me${q}.${q}artistid${q} FROM ( SELECT ${q}me${q}.${q}artistid${q} FROM ${q}artist${q} ${q}me${q} START WITH ${q}name${q} = ? CONNECT BY ${q}parentid${q} = PRIOR ${q}artistid${q} ) ${q}me${q} WHERE ROWNUM <= ? ) ${q}me${q} )", [ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 } => 'root'], [ $ROWS => 2 ], ], ); } # combine a connect_by with group_by and having # add some bindvals to make sure things still work { my $rs = $schema->resultset('Artist')->search({}, { select => \[ 'COUNT(rank) + ?', [ __cbind => 3 ] ], as => 'cnt', start_with => { name => 'root' }, connect_by => { parentid => { -prior => { -ident => 'artistid' } } }, group_by => \[ 'rank + ? ', [ __gbind => 1] ], having => \[ 'count(rank) < ?', [ cnt => 2 ] ], }); is_same_sql_bind ( $rs->as_query, "( SELECT COUNT(rank) + ? FROM ${q}artist${q} ${q}me${q} START WITH ${q}name${q} = ? CONNECT BY ${q}parentid${q} = PRIOR ${q}artistid${q} GROUP BY( rank + ? ) HAVING count(rank) < ? )", [ [ { dbic_colname => '__cbind' } => 3 ], [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 } => 'root'], [ { dbic_colname => '__gbind' } => 1 ], [ { dbic_colname => 'cnt' } => 2 ], ], ); } # select the whole cycle tree with nocylce { my $rs = $schema->resultset('Artist')->search({}, { start_with => { name => 'cycle-root' }, '+select' => \ 'CONNECT_BY_ISCYCLE', '+as' => [ 'connector' ], connect_by_nocycle => { parentid => { -prior => { -ident => 'artistid' } } }, }); is_same_sql_bind ( $rs->as_query, "( SELECT ${q}me${q}.${q}artistid${q}, ${q}me${q}.${q}name${q}, ${q}me${q}.${q}rank${q}, ${q}me${q}.${q}charfield${q}, ${q}me${q}.${q}parentid${q}, CONNECT_BY_ISCYCLE FROM ${q}artist${q} ${q}me${q} START WITH ${q}name${q} = ? CONNECT BY NOCYCLE ${q}parentid${q} = PRIOR ${q}artistid${q} )", [ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 } => 'cycle-root'], ], ); is_same_sql_bind ( $rs->count_rs->as_query, "( SELECT COUNT( * ) FROM ${q}artist${q} ${q}me${q} START WITH ${q}name${q} = ? CONNECT BY NOCYCLE ${q}parentid${q} = PRIOR ${q}artistid${q} )", [ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 } => 'cycle-root'], ], ); } } done_testing; ��������������������DBIx-Class-0.082843/t/sqlmaker/mysql.t��������������������������������������������������������������0000644�0001750�0001750�00000012022�14240132261�016507� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest ':DiffSQL'; my $schema = DBICTest::Schema->connect (DBICTest->_database, { quote_char => '`' }); # cheat require DBIx::Class::Storage::DBI::mysql; *DBIx::Class::Storage::DBI::mysql::_get_server_version = sub { 5 }; bless ( $schema->storage, 'DBIx::Class::Storage::DBI::mysql' ); # check that double-subqueries are properly wrapped { # the expected SQL may seem wastefully nonsensical - this is due to # CD's tablename being \'cd', which triggers the "this can be anything" # mode, and forces a subquery. This in turn forces *another* subquery # because mysql is being mysql # Also we know it will fail - never deployed. All we care about is the # SQL to compare, hence the eval $schema->is_executed_sql_bind( sub { eval { $schema->resultset ('CD')->update({ genreid => undef }) } },[[ 'UPDATE cd SET `genreid` = ? WHERE `cdid` IN ( SELECT * FROM ( SELECT `me`.`cdid` FROM cd `me` ) `_forced_double_subquery` )', [ { dbic_colname => "genreid", sqlt_datatype => "integer" } => undef ], ]], 'Correct update-SQL with double-wrapped subquery' ); # same comment as above $schema->is_executed_sql_bind( sub { eval { $schema->resultset ('CD')->delete } }, [[ 'DELETE FROM cd WHERE `cdid` IN ( SELECT * FROM ( SELECT `me`.`cdid` FROM cd `me` ) `_forced_double_subquery` )', ]], 'Correct delete-SQL with double-wrapped subquery' ); # and a couple of really contrived examples (we test them live in t/71mysql.t) my $rs = $schema->resultset('Artist')->search({ name => { -like => 'baby_%' } }); my ($count_sql, @count_bind) = @${$rs->count_rs->as_query}; $schema->is_executed_sql_bind( sub { eval { $schema->resultset('Artist')->search( { artistid => { -in => $rs->get_column('artistid') ->as_query } }, )->update({ name => \[ "CONCAT( `name`, '_bell_out_of_', $count_sql )", @count_bind ] }); } }, [[ q( UPDATE `artist` SET `name` = CONCAT(`name`, '_bell_out_of_', ( SELECT * FROM ( SELECT COUNT( * ) FROM `artist` `me` WHERE `name` LIKE ? ) `_forced_double_subquery` )) WHERE `artistid` IN ( SELECT * FROM ( SELECT `me`.`artistid` FROM `artist` `me` WHERE `name` LIKE ? ) `_forced_double_subquery` ) ), ( [ { dbic_colname => "name", sqlt_datatype => "varchar", sqlt_size => 100 } => 'baby_%' ] ) x 2 ]]); $schema->is_executed_sql_bind( sub { eval { $schema->resultset('CD')->search_related('artist', { 'artist.name' => { -like => 'baby_with_%' } } )->delete } }, [[ q( DELETE FROM `artist` WHERE `artistid` IN ( SELECT * FROM ( SELECT `artist`.`artistid` FROM cd `me` JOIN `artist` `artist` ON `artist`.`artistid` = `me`.`artist` WHERE `artist`.`name` LIKE ? ) `_forced_double_subquery` ) ), [ { dbic_colname => "artist.name", sqlt_datatype => "varchar", sqlt_size => 100 } => 'baby_with_%' ], ]] ); } # Test support for straight joins { my $cdsrc = $schema->source('CD'); my $artrel_info = $cdsrc->relationship_info ('artist'); $cdsrc->add_relationship( 'straight_artist', $artrel_info->{class}, $artrel_info->{cond}, { %{$artrel_info->{attrs}}, join_type => 'straight' }, ); is_same_sql_bind ( $cdsrc->resultset->search({}, { prefetch => 'straight_artist' })->as_query, '( SELECT `me`.`cdid`, `me`.`artist`, `me`.`title`, `me`.`year`, `me`.`genreid`, `me`.`single_track`, `straight_artist`.`artistid`, `straight_artist`.`name`, `straight_artist`.`rank`, `straight_artist`.`charfield` FROM cd `me` STRAIGHT_JOIN `artist` `straight_artist` ON `straight_artist`.`artistid` = `me`.`artist` )', [], 'straight joins correctly supported for mysql' ); } # Test support for inner joins on mysql v3 for ( [ 3 => 'INNER JOIN' ], [ 4 => 'JOIN' ], ) { my ($ver, $join_op) = @$_; # we do not care at this point if data is available, just do a reconnect cycle # to clear the server version cache and then get a new maker { $schema->storage->disconnect; $schema->storage->_sql_maker(undef); no warnings 'redefine'; local *DBIx::Class::Storage::DBI::mysql::_get_server_version = sub { $ver }; $schema->storage->ensure_connected; $schema->storage->sql_maker; } is_same_sql_bind ( $schema->resultset('CD')->search ({}, { prefetch => 'artist' })->as_query, "( SELECT `me`.`cdid`, `me`.`artist`, `me`.`title`, `me`.`year`, `me`.`genreid`, `me`.`single_track`, `artist`.`artistid`, `artist`.`name`, `artist`.`rank`, `artist`.`charfield` FROM cd `me` $join_op `artist` `artist` ON `artist`.`artistid` = `me`.`artist` )", [], "default join type works for version $ver", ); } done_testing; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/sqlmaker/sqlite.t�������������������������������������������������������������0000644�0001750�0001750�00000000470�14240132261�016647� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema; is_same_sql_bind( $schema->resultset('Artist')->search ({}, {for => 'update'})->as_query, '(SELECT me.artistid, me.name, me.rank, me.charfield FROM artist me)', [], ); done_testing; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/sqlmaker/msaccess.t�����������������������������������������������������������0000644�0001750�0001750�00000006511�14240132261�017151� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest ':DiffSQL'; # the entire point of the subclass is that parenthesis have to be # just right for ACCESS to be happy # globalize for entirety of the test $SQL::Abstract::Test::parenthesis_significant = 1; my $schema = DBICTest->init_schema (storage_type => 'DBIx::Class::Storage::DBI::ACCESS', no_deploy => 1, quote_names => 1); is_same_sql_bind( $schema->resultset('Artist')->search( { artistid => 1, }, { join => [{ cds => 'tracks' }], '+select' => [ 'tracks.title' ], '+as' => [ 'track_title' ], } )->as_query, '( SELECT [me].[artistid], [me].[name], [me].[rank], [me].[charfield], [tracks].[title] FROM ( ( [artist] [me] LEFT JOIN cd [cds] ON [cds].[artist] = [me].[artistid] ) LEFT JOIN [track] [tracks] ON [tracks].[cd] = [cds].[cdid] ) WHERE ( [artistid] = ? ) )', [ [{ sqlt_datatype => 'integer', dbic_colname => 'artistid' } => 1 ], ], 'correct SQL for two-step left join' ); is_same_sql_bind( $schema->resultset('Track')->search( { trackid => 1, }, { join => [{ cd => 'artist' }], '+select' => [ 'artist.name' ], '+as' => [ 'artist_name' ], } )->as_query, '( SELECT [me].[trackid], [me].[cd], [me].[position], [me].[title], [me].[last_updated_on], [me].[last_updated_at], [artist].[name] FROM ( ( [track] [me] INNER JOIN cd [cd] ON [cd].[cdid] = [me].[cd] ) INNER JOIN [artist] [artist] ON [artist].[artistid] = [cd].[artist] ) WHERE ( [trackid] = ? ) )', [ [{ sqlt_datatype => 'integer', dbic_colname => 'trackid' } => 1 ], ], 'correct SQL for two-step inner join', ); my $sa = $schema->storage->sql_maker; # the legacy tests assume no quoting - leave things as-is local $sa->{quote_char}; # my ($self, $table, $fields, $where, $order, @rest) = @_; my ($sql, @bind) = $sa->select( [ { me => "cd" }, [ { "-join_type" => "LEFT", artist => "artist" }, { "artist.artistid" => { -ident => "me.artist" } }, ], ], [ 'cd.cdid', 'cd.artist', 'cd.title', 'cd.year', 'artist.artistid', 'artist.name' ], undef, undef ); is_same_sql_bind( $sql, \@bind, 'SELECT cd.cdid, cd.artist, cd.title, cd.year, artist.artistid, artist.name FROM (cd me LEFT JOIN artist artist ON artist.artistid = me.artist)', [], 'one-step join parenthesized' ); ($sql, @bind) = $sa->select( [ { me => "cd" }, [ { "-join_type" => "LEFT", track => "track" }, { "track.cd" => { -ident => "me.cdid" } }, ], [ { artist => "artist" }, { "artist.artistid" => { -ident => "me.artist" } }, ], ], [ 'track.title', 'cd.cdid', 'cd.artist', 'cd.title', 'cd.year', 'artist.artistid', 'artist.name' ], undef, undef ); is_same_sql_bind( $sql, \@bind, 'SELECT track.title, cd.cdid, cd.artist, cd.title, cd.year, artist.artistid, artist.name FROM ((cd me LEFT JOIN track track ON track.cd = me.cdid) INNER JOIN artist artist ON artist.artistid = me.artist)', [], 'two-step join parenthesized and inner join prepended with INNER' ); done_testing; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/sqlmaker/order_by_func.t������������������������������������������������������0000644�0001750�0001750�00000001422�14240132261�020164� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); my $rs = $schema->resultset('CD')->search({}, { 'join' => 'tracks', order_by => { -desc => { count => 'tracks.track_id', }, }, distinct => 1, rows => 2, page => 1, }); my $match = q{ SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me GROUP BY me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track ORDER BY COUNT(tracks.trackid) DESC }; TODO: { todo_skip 'order_by using function', 2; is_same_sql($rs->as_query, $match, 'order by with func query'); ok($rs->count == 2, 'amount of rows return in order by func query'); } done_testing; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/multi_create/�����������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�016037� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/multi_create/reentrance_count.t�����������������������������������������������0000644�0001750�0001750�00000011625�14240132261�021546� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; BEGIN { plan skip_all => 'Disable test entirely until multicreate is rewritten in terms of subqueries'; } use Test::Exception; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); my $query_stats; $schema->storage->debugcb (sub { push @{$query_stats->{$_[0]}}, $_[1] }); $schema->storage->debug (1); lives_ok (sub { undef $query_stats; $schema->resultset('Artist')->create ({ name => 'poor artist', cds => [ { title => 'cd1', year => 2001, }, { title => 'cd2', year => 2002, }, ], }); is ( @{$query_stats->{INSERT} || []}, 3, 'number of inserts during creation of artist with 2 cds' ); is ( @{$query_stats->{SELECT} || []}, 0, 'number of selects during creation of artist with 2 cds' ) || $ENV{DBIC_MULTICREATE_DEBUG} && diag join "\n", @{$query_stats->{SELECT} || []}; }); lives_ok (sub { undef $query_stats; $schema->resultset('Artist')->create ({ name => 'poorer artist', cds => [ { title => 'cd3', year => 2003, genre => { name => 'vague genre' }, }, { title => 'cd4', year => 2004, genre => { name => 'vague genre' }, }, ], }); is ( @{$query_stats->{INSERT} || []}, 4, 'number of inserts during creation of artist with 2 cds, converging on the same genre' ); is ( @{$query_stats->{SELECT} || []}, 0, 'number of selects during creation of artist with 2 cds, converging on the same genre' ) || $ENV{DBIC_MULTICREATE_DEBUG} && diag join "\n", @{$query_stats->{SELECT} || []}; }); lives_ok (sub { my $genre = $schema->resultset('Genre')->first; undef $query_stats; $schema->resultset('Artist')->create ({ name => 'poorest artist', cds => [ { title => 'cd5', year => 2005, genre => $genre, }, { title => 'cd6', year => 2004, genre => $genre, }, ], }); is ( @{$query_stats->{INSERT} || []}, 3, 'number of inserts during creation of artist with 2 cds, converging on the same existing genre' ); is ( @{$query_stats->{SELECT} || []}, 0, 'number of selects during creation of artist with 2 cds, converging on the same existing genre' ) || $ENV{DBIC_MULTICREATE_DEBUG} && diag join "\n", @{$query_stats->{SELECT} || []}; }); lives_ok (sub { undef $query_stats; $schema->resultset('Artist')->create ({ name => 'poorer than the poorest artist', cds => [ { title => 'cd7', year => 2007, cd_to_producer => [ { producer => { name => 'jolly producer', producer_to_cd => [ { cd => { title => 'cd8', year => 2008, artist => { name => 'poorer than the poorest artist', }, }, }, ], }, }, ], }, ], }); is ( @{$query_stats->{INSERT} || []}, 6, 'number of inserts during creation of artist->cd->producer->cd->same_artist' ); is ( @{$query_stats->{SELECT} || []}, 0, 'number of selects during creation of artist->cd->producer->cd->same_artist' ) || $ENV{DBIC_MULTICREATE_DEBUG} && diag join "\n", @{$query_stats->{SELECT} || []}; }); lives_ok (sub { undef $query_stats; $schema->resultset ('Artist')->find(1)->create_related (cds => { title => 'cd9', year => 2009, cd_to_producer => [ { producer => { name => 'jolly producer', producer_to_cd => [ { cd => { title => 'cd10', year => 2010, artist => { name => 'poorer than the poorest artist', }, }, }, ], }, }, ], }); is ( @{$query_stats->{INSERT} || []}, 4, 'number of inserts during creation of existing_artist->cd->existing_producer->cd->existing_artist2' ); is ( @{$query_stats->{SELECT} || []}, 0, 'number of selects during creation of existing_artist->cd->existing_producer->cd->existing_artist2' ) || $ENV{DBIC_MULTICREATE_DEBUG} && diag join "\n", @{$query_stats->{SELECT} || []}; }); lives_ok (sub { undef $query_stats; my $artist = $schema->resultset ('Artist')->first; my $producer = $schema->resultset ('Producer')->first; $schema->resultset ('CD')->create ({ title => 'cd11', year => 2011, artist => $artist, cd_to_producer => [ { producer => $producer, }, ], }); is ( @{$query_stats->{INSERT} || []}, 2, 'number of inserts during creation of artist_object->cd->producer_object' ); is ( @{$query_stats->{SELECT} || []}, 0, 'number of selects during creation of artist_object->cd->producer_object' ) || $ENV{DBIC_MULTICREATE_DEBUG} && diag join "\n", @{$query_stats->{SELECT} || []}; }); done_testing; �����������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/multi_create/diamond.t��������������������������������������������������������0000644�0001750�0001750�00000002177�14240132261�017625� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use lib qw(t/lib); use DBICTest; sub mc_diag { diag (@_) if $ENV{DBIC_MULTICREATE_DEBUG} }; my $schema = DBICTest->init_schema(); mc_diag (<<'DG'); * Try a diamond multicreate Artist -> has_many -> Artwork_to_Artist -> belongs_to / belongs_to <- CD <- belongs_to <- Artwork <-/ \ \-> Artist2 DG lives_ok (sub { $schema->resultset ('Artist')->create ({ name => 'The wooled wolf', artwork_to_artist => [{ artwork => { cd => { title => 'Wool explosive', year => 1999, artist => { name => 'The black exploding sheep' }, } } }], }); my $art2 = $schema->resultset ('Artist')->find ({ name => 'The black exploding sheep' }); ok ($art2, 'Second artist exists'); my $cd = $art2->cds->single; is ($cd->title, 'Wool explosive', 'correctly created CD'); is_deeply ( [ $cd->artwork->artists->get_column ('name')->all ], [ 'The wooled wolf' ], 'Artist correctly attached to artwork', ); }, 'Diamond chain creation ok'); done_testing; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/multi_create/insert_defaults.t������������������������������������������������0000644�0001750�0001750�00000004111�14240132261�021373� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; use DBIx::Class::_Util 'sigwarn_silencer'; my $schema = DBICTest->init_schema(); # Attempt sequential nested find_or_create with autoinc # As a side effect re-test nested default create (both the main object and the relation are {}) my $bookmark_rs = $schema->resultset('Bookmark'); my $last_bookmark = $bookmark_rs->search ({}, { order_by => { -desc => 'id' }, rows => 1})->single; my $last_link = $bookmark_rs->search_related ('link', {}, { order_by => { -desc => 'link.id' }, rows => 1})->single; # find_or_create a bookmark-link combo with data for a non-existing link my $o1 = $bookmark_rs->find_or_create ({ link => { url => 'something-weird' } }); is ($o1->id, $last_bookmark->id + 1, '1st bookmark ID'); is ($o1->link->id, $last_link->id + 1, '1st related link ID'); # find_or_create a bookmark-link combo without any data at all (default insert) # should extend this test to all available Storage's, and fix them accordingly my $o2 = $bookmark_rs->find_or_create ({ link => {} }); is ($o2->id, $last_bookmark->id + 2, '2nd bookmark ID'); is ($o2->link->id, $last_link->id + 2, '2nd related link ID'); # make sure the pre-existing link has only one related bookmark is ($last_link->bookmarks->count, 1, 'Expecting only 1 bookmark and 1 link, someone mucked with the table!'); # find_or_create a bookmark withouyt any data, but supplying an existing link object # should return $last_bookmark my $o0 = $bookmark_rs->find_or_create ({ link => $last_link }); is_deeply ({ $o0->columns}, {$last_bookmark->columns}, 'Correctly identify a row given a relationship'); # inject an additional bookmark and repeat the test # should warn and return the first row my $o3 = $last_link->create_related ('bookmarks', {}); is ($o3->id, $last_bookmark->id + 3, '3rd bookmark ID'); local $SIG{__WARN__} = sigwarn_silencer( qr/Query returned more than one row/ ); my $oX = $bookmark_rs->find_or_create ({ link => $last_link }); is_deeply ({ $oX->columns}, {$last_bookmark->columns}, 'Correctly identify a row given a relationship'); done_testing; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/multi_create/in_memory.t������������������������������������������������������0000644�0001750�0001750�00000012747�14240132261�020214� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); # Test various new() invocations - this is all about backcompat, making # sure that insert() still works as expected by legacy code. # # What we essentially do is multi-instantiate objects, making sure nothing # gets inserted. Then we add some more objects to the mix either via # new_related() or by setting an accessor directly (or both) - again # expecting no inserts. Then after calling insert() on the starter object # we expect everything supplied to new() to get inserted, as well as any # relations whose PK's are necessary to complete the objects supplied # to new(). All other objects should be insert()able afterwards too. { my $new_artist = $schema->resultset("Artist")->new_result({ 'name' => 'Depeche Mode' }); my $new_related_cd = $new_artist->new_related('cds', { 'title' => 'Leave in Silence', 'year' => 1982}); lives_ok { $new_artist->insert; $new_related_cd->insert; } 'Staged insertion successful'; ok($new_artist->in_storage, 'artist inserted'); ok($new_related_cd->in_storage, 'new_related_cd inserted'); } { my $new_artist = $schema->resultset("Artist")->new_result({ 'name' => 'Mode Depeche' }); my $new_related_cd = $new_artist->new_related('cds', { 'title' => 'Leave Slightly Noisily', 'year' => 1982}); lives_ok { $new_related_cd->insert; } 'CD insertion survives by finding artist'; ok($new_artist->in_storage, 'artist inserted'); ok($new_related_cd->in_storage, 'new_related_cd inserted'); } { my $new_cd = $schema->resultset('CD')->new ({ 'title' => 'Leave Loudly While Singing Off Key', 'year' => 1982}); my $new_artist = $schema->resultset("Artist")->new ({ 'name' => 'Depeche Mode 2: Insertion Boogaloo' }); $new_cd->artist ($new_artist); lives_ok { $new_cd->insert; } 'CD insertion survives by inserting artist'; ok($new_cd->in_storage, 'new_related_cd inserted'); ok($new_artist->in_storage, 'artist inserted'); my $retrieved_cd = $schema->resultset('CD')->find ({ 'title' => 'Leave Loudly While Singing Off Key'}); ok ($retrieved_cd, 'CD found in db'); is ($retrieved_cd->artist->name, 'Depeche Mode 2: Insertion Boogaloo', 'Correct artist attached to cd'); } { my $new_cd = $schema->resultset('CD')->new ({ 'title' => 'Leave screaming Off Key in the nude', 'year' => 1982}); my $new_related_artist = $new_cd->new_related( artist => { 'name' => 'Depeche Mode 3: Insertion Boogaloo' }); lives_ok { $new_related_artist->insert; $new_cd->insert; } 'CD insertion survives after inserting artist'; ok($new_cd->in_storage, 'cd inserted'); ok($new_related_artist->in_storage, 'artist inserted'); my $retrieved_cd = $schema->resultset('CD')->find ({ 'title' => 'Leave screaming Off Key in the nude'}); ok ($retrieved_cd, 'CD found in db'); is ($retrieved_cd->artist->name, 'Depeche Mode 3: Insertion Boogaloo', 'Correct artist attached to cd'); } # test both sides of a 1:(1|0) { for my $reldir ('might_have', 'belongs_to') { my $artist = $schema->resultset('Artist')->find(1); my $new_track = $schema->resultset('Track')->new ({ title => "$reldir: First track of latest cd", cd => { title => "$reldir: Latest cd", year => 2666, artist => $artist, }, }); my $new_single = $schema->resultset('CD')->new ({ artist => $artist, title => "$reldir: Awesome first single", year => 2666, }); if ($reldir eq 'might_have') { $new_track->cd_single ($new_single); $new_track->insert; } else { $new_single->single_track ($new_track); $new_single->insert; } ok ($new_single->in_storage, "$reldir single inserted"); ok ($new_track->in_storage, "$reldir track inserted"); my $new_cds = $artist->search_related ('cds', { year => '2666' }, { prefetch => 'tracks', order_by => 'cdid' } ); is_deeply ( [$new_cds->search ({}, { result_class => 'DBIx::Class::ResultClass::HashRefInflator'})->all ], [ { artist => 1, cdid => 10, genreid => undef, single_track => undef, title => "$reldir: Latest cd", tracks => [ { cd => 10, last_updated_at => undef, last_updated_on => undef, position => 1, title => "$reldir: First track of latest cd", trackid => 19 } ], year => 2666 }, { artist => 1, cdid => 11, genreid => undef, single_track => 19, title => "$reldir: Awesome first single", tracks => [], year => 2666 }, ], 'Expected rows created in database', ); $new_cds->delete_all; } } { my $new_cd = $schema->resultset("CD")->new_result({}); my $new_related_artist = $new_cd->new_related('artist', { 'name' => 'Marillion',}); lives_ok ( sub { $new_related_artist->insert; $new_cd->title( 'Misplaced Childhood' ); $new_cd->year ( 1985 ); $new_cd->artist( $new_related_artist ); # For exact backward compatibility $new_cd->insert; }, 'Reversed staged insertion successful' ); ok($new_related_artist->in_storage, 'related artist inserted'); ok($new_cd->in_storage, 'cd inserted'); } done_testing; �������������������������DBIx-Class-0.082843/t/multi_create/multilev_single_PKeqFK.t�����������������������������������������0000644�0001750�0001750�00000005166�14240132261�022556� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use lib qw(t/lib); use DBICTest; sub mc_diag { diag (@_) if $ENV{DBIC_MULTICREATE_DEBUG} }; my $schema = DBICTest->init_schema(); mc_diag (<<'DG'); * Test a multilevel might-have/has_one with a PK == FK in the mid-table CD -> might have -> Artwork \- has_one -/ \ \ \-> has_many \ --> Artwork_to_Artist /-> has_many / / Artist DG my $rels = { has_one => 'mandatory_artwork', might_have => 'artwork', }; for my $type (qw/has_one might_have/) { lives_ok (sub { my $rel = $rels->{$type}; my $cd_title = "Simple test $type cd"; my $cd = $schema->resultset('CD')->create ({ artist => 1, title => $cd_title, year => 2008, $rel => {}, }); isa_ok ($cd, 'DBICTest::CD', 'Main CD object created'); is ($cd->title, $cd_title, 'Correct CD title'); isa_ok ($cd->$rel, 'DBICTest::Artwork', 'Related artwork present'); ok ($cd->$rel->in_storage, 'And in storage'); }, "Simple $type creation"); } my $artist_rs = $schema->resultset('Artist'); for my $type (qw/has_one might_have/) { my $rel = $rels->{$type}; my $cd_title = "Test $type cd"; my $artist_names = [ map { "Artist via $type $_" } (1, 2) ]; my $someartist = $artist_rs->next; lives_ok (sub { my $cd = $schema->resultset('CD')->create ({ artist => $someartist, title => $cd_title, year => 2008, $rel => { artwork_to_artist => [ map { { artist => { name => $_ } } } (@$artist_names) ] }, }); isa_ok ($cd, 'DBICTest::CD', 'Main CD object created'); is ($cd->title, $cd_title, 'Correct CD title'); my $art_obj = $cd->$rel; ok ($art_obj->has_column_loaded ('cd_id'), 'PK/FK present on artwork object'); is ($art_obj->artists->count, 2, 'Correct artwork creator count via the new object'); is_deeply ( [ sort $art_obj->artists->get_column ('name')->all ], $artist_names, 'Artists named correctly when queried via object', ); my $artwork = $schema->resultset('Artwork')->search ( { 'cd.title' => $cd_title }, { join => 'cd' }, )->single; is ($artwork->artists->count, 2, 'Correct artwork creator count via a new search'); is_deeply ( [ sort $artwork->artists->get_column ('name')->all ], $artist_names, 'Artists named correctly queried via a new search', ); }, "multilevel $type with a PK == FK in the $type/has_many table ok"); } done_testing; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/multi_create/torture.t��������������������������������������������������������0000644�0001750�0001750�00000016147�14240132261�017720� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; plan tests => 23; # an insane multicreate # (should work, despite the fact that no one will probably use it this way) my $schema = DBICTest->init_schema(); # first count how many rows do we initially have my $counts; $counts->{$_} = $schema->resultset($_)->count for qw/Artist CD Genre Producer Tag/; # do the crazy create eval { $schema->resultset('CD')->create ({ artist => { name => 'james', }, title => 'Greatest hits 1', year => '2012', genre => { name => '"Greatest" collections', }, tags => [ { tag => 'A' }, { tag => 'B' }, ], cd_to_producer => [ { producer => { name => 'bob', producer_to_cd => [ { cd => { artist => { name => 'lars', cds => [ { title => 'Greatest hits 2', year => 2012, genre => { name => '"Greatest" collections', }, tags => [ { tag => 'A' }, { tag => 'B' }, ], # This cd is created via artist so it doesn't know about producers cd_to_producer => [ { producer => { name => 'bob' } }, { producer => { name => 'paul' } }, { producer => { name => 'flemming', producer_to_cd => [ { cd => { artist => { name => 'kirk', cds => [ { title => 'Greatest hits 3', year => 2012, genre => { name => '"Greatest" collections', }, tags => [ { tag => 'A' }, { tag => 'B' }, ], }, { title => 'Greatest hits 4', year => 2012, genre => { name => '"Greatest" collections2', }, tags => [ { tag => 'A' }, { tag => 'B' }, ], }, ], }, title => 'Greatest hits 5', year => 2013, genre => { name => '"Greatest" collections2', }, }}, ], }}, ], }, ], }, title => 'Greatest hits 6', year => 2012, genre => { name => '"Greatest" collections', }, tags => [ { tag => 'A' }, { tag => 'B' }, ], }, }, { cd => { artist => { name => 'lars', # should already exist # even though the artist 'name' is not uniquely constrained # find_or_create will arguably DWIM }, title => 'Greatest hits 7', year => 2013, }, }, ], }, }, ], }); is ($schema->resultset ('Artist')->count, $counts->{Artist} + 3, '3 new artists created'); is ($schema->resultset ('Genre')->count, $counts->{Genre} + 2, '2 additional genres created'); is ($schema->resultset ('Producer')->count, $counts->{Producer} + 3, '3 new producer'); is ($schema->resultset ('CD')->count, $counts->{CD} + 7, '7 new CDs'); is ($schema->resultset ('Tag')->count, $counts->{Tag} + 10, '10 new Tags'); my $cd_rs = $schema->resultset ('CD') ->search ({ title => { -like => 'Greatest hits %' }}, { order_by => 'title'} ); is ($cd_rs->count, 7, '7 greatest hits created'); my $cds_2012 = $cd_rs->search ({ year => 2012}); is ($cds_2012->count, 5, '5 CDs created in 2012'); is ( $cds_2012->search( { 'tags.tag' => { -in => [qw/A B/] } }, { join => 'tags', group_by => 'me.cdid', having => 'count(me.cdid) = 2', } ), 5, 'All 10 tags were pairwise distributed between 5 year-2012 CDs' ); my $paul_prod = $cd_rs->search ( { 'producer.name' => 'paul'}, { join => { cd_to_producer => 'producer' } } ); is ($paul_prod->count, 1, 'Paul had 1 production'); my $pauls_cd = $paul_prod->single; is ($pauls_cd->cd_to_producer->count, 3, 'Paul had two co-producers'); is ( $pauls_cd->search_related ('cd_to_producer', { 'producer.name' => 'flemming'}, { join => 'producer' } )->count, 1, 'The second producer is flemming', ); my $kirk_cds = $cd_rs->search ({ 'artist.name' => 'kirk' }, { join => 'artist' }); is ($kirk_cds, 3, 'Kirk had 3 CDs'); is ( $kirk_cds->search ( { 'cd_to_producer.cd' => { '!=', undef } }, { join => 'cd_to_producer' }, ), 1, 'Kirk had a producer only on one cd', ); my $lars_cds = $cd_rs->search ({ 'artist.name' => 'lars' }, { join => 'artist' }); is ($lars_cds->count, 3, 'Lars had 3 CDs'); is ( $lars_cds->search ( { 'cd_to_producer.cd' => undef }, { join => 'cd_to_producer' }, ), 0, 'Lars always had a producer', ); is ( $lars_cds->search_related ('cd_to_producer', { 'producer.name' => 'flemming'}, { join => 'producer' } )->count, 1, 'Lars produced 1 CD with flemming', ); is ( $lars_cds->search_related ('cd_to_producer', { 'producer.name' => 'bob'}, { join => 'producer' } )->count, 3, 'Lars produced 3 CDs with bob', ); my $bob_prod = $cd_rs->search ( { 'producer.name' => 'bob'}, { join => { cd_to_producer => 'producer' } } ); is ($bob_prod->count, 4, 'Bob produced a total of 4 CDs'); ok ($bob_prod->find ({ title => 'Greatest hits 1'}), '1st Bob production name correct'); ok ($bob_prod->find ({ title => 'Greatest hits 6'}), '2nd Bob production name correct'); ok ($bob_prod->find ({ title => 'Greatest hits 2'}), '3rd Bob production name correct'); ok ($bob_prod->find ({ title => 'Greatest hits 7'}), '4th Bob production name correct'); is ( $bob_prod->search ({ 'artist.name' => 'james' }, { join => 'artist' })->count, 1, "Bob produced james' only CD", ); }; diag $@ if $@; 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/multi_create/existing_in_chain.t����������������������������������������������0000644�0001750�0001750�00000006211�14240132261�021665� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); # For fully intuitive multicreate any relationships in a chain # that do not exist for one reason or another should be created, # even if the preceeding relationship already exists. # # To get this to work a minor rewrite of find() is necessary, and # more importantly some sort of recursive_insert() call needs to # be available. The way things will work then is: # *) while traversing the hierarchy code calls find_or_create() # *) this in turn calls find(%\nested_dataset) # *) this should return not only the existing object, but must # also attach all non-existing (in fact maybe existing) related # bits of data to it, with in_storage => 0 # *) then before returning the result of the succesful find(), we # simply call $obj->recursive_insert and all is dandy # # Since this will not be a very clean solution, todoifying for the # time being until an actual need arises # # ribasushi my $TODO_msg = "See comment at top of @{[ __FILE__ ]} for discussion of the TODO"; { my $counts; $counts->{$_} = $schema->resultset($_)->count for qw/Track CD Genre/; my $existing_nogen_cd = $schema->resultset('CD')->search ( { 'genre.genreid' => undef }, { join => 'genre' }, )->first; $schema->resultset('Track')->create ({ title => 'Sugar-coated', cd => { title => $existing_nogen_cd->title, genre => { name => 'sugar genre', } } }); is ($schema->resultset('Track')->count, $counts->{Track} + 1, '1 new track'); is ($schema->resultset('CD')->count, $counts->{CD}, 'No new cds'); TODO: { todo_skip $TODO_msg, 1; is ($schema->resultset('Genre')->count, $counts->{Genre} + 1, '1 new genre'); is ($existing_nogen_cd->genre->title, 'sugar genre', 'Correct genre assigned to CD'); } } { my $counts; $counts->{$_} = $schema->resultset($_)->count for qw/Artist CD Producer/; lives_ok (sub { my $artist = $schema->resultset('Artist')->first; my $producer = $schema->resultset('Producer')->create ({ name => 'the queen of england' }); $schema->resultset('CD')->create ({ artist => $artist, title => 'queen1', year => 2007, cd_to_producer => [ { producer => { name => $producer->name, producer_to_cd => [ { cd => { title => 'queen2', year => 2008, artist => $artist, }, }, ], }, }, ], }); is ($schema->resultset('Artist')->count, $counts->{Artist}, 'No new artists'); is ($schema->resultset('Producer')->count, $counts->{Producer} + 1, '1 new producers'); local $TODO = $TODO_msg; is ($schema->resultset('CD')->count, $counts->{CD} + 2, '2 new cds'); is ($producer->cds->count, 2, 'CDs assigned to correct producer'); is_deeply ( [ $producer->cds->search ({}, { order_by => 'title' })->get_column('title')->all], [ qw/queen1 queen2/ ], 'Correct cd names', ); }, 'create() did not throw'); } done_testing; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/multi_create/m2m.t������������������������������������������������������������0000644�0001750�0001750�00000001712�14240132261�016677� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use lib qw(t/lib); use DBICTest; plan tests => 4; my $schema = DBICTest->init_schema(); lives_ok ( sub { my $prod_rs = $schema->resultset ('Producer'); my $prod_count = $prod_rs->count; my $cd = $schema->resultset('CD')->first; $cd->add_to_producers ({name => 'new m2m producer'}); is ($prod_rs->count, $prod_count + 1, 'New producer created'); ok ($cd->producers->find ({name => 'new m2m producer'}), 'Producer created with correct name'); my $cd2 = $schema->resultset('CD')->search ( { cdid => { '!=', $cd->cdid } }, {rows => 1} )->single; # retrieve a cd different from the first $cd2->add_to_producers ({name => 'new m2m producer'}); # attach to an existing producer ok ($cd2->producers->find ({name => 'new m2m producer'}), 'Existing producer attached to existing cd'); }, 'Test far-end find_or_create over many_to_many'); 1; ������������������������������������������������������DBIx-Class-0.082843/t/multi_create/cd_single.t������������������������������������������������������0000644�0001750�0001750�00000001230�14240132261�020126� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); eval { my $cd = $schema->resultset('CD')->first; my $track = $schema->resultset('Track')->new_result({ cd => $cd, title => 'Multicreate rocks', cd_single => { artist => $cd->artist, year => 2008, title => 'Disemboweling MultiCreate', }, }); isa_ok ($track, 'DBICTest::Track', 'Main Track object created'); $track->insert; ok(1, 'created track'); is($track->title, 'Multicreate rocks', 'Correct Track title'); my $single = $track->cd_single; ok($single->cdid, 'Got cdid'); }; done_testing; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/multi_create/standard.t�������������������������������������������������������0000644�0001750�0001750�00000034753�14240132261�020017� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use Test::Warn; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); lives_ok ( sub { my $cd = $schema->resultset('CD')->create({ artist => { name => 'Fred Bloggs' }, title => 'Some CD', year => 1996 }); isa_ok($cd, 'DBICTest::CD', 'Created CD object'); isa_ok($cd->artist, 'DBICTest::Artist', 'Created related Artist'); is($cd->artist->name, 'Fred Bloggs', 'Artist created correctly'); }, 'simple create + parent (the stuff $rs belongs_to) ok'); lives_ok ( sub { my $bm_rs = $schema->resultset('Bookmark'); my $bookmark = $bm_rs->create({ link => { id => 66, }, }); isa_ok($bookmark, 'DBICTest::Bookmark', 'Created Bookrmark object'); isa_ok($bookmark->link, 'DBICTest::Link', 'Created related Link'); is ( $bm_rs->search ( { 'link.title' => $bookmark->link->title }, { join => 'link' }, )->count, 1, 'Bookmark and link made it to the DB', ); }, 'simple create where the child and parent have no values, except for an explicit parent pk ok'); lives_ok ( sub { my $artist = $schema->resultset('Artist')->first; my $cd = $artist->create_related (cds => { title => 'Music to code by', year => 2007, tags => [ { 'tag' => 'rock' }, ], }); isa_ok($cd, 'DBICTest::CD', 'Created CD'); is($cd->title, 'Music to code by', 'CD created correctly'); is($cd->tags->count, 1, 'One tag created for CD'); is($cd->tags->first->tag, 'rock', 'Tag created correctly'); }, 'create over > 1 levels of has_many create (A => { has_many => { B => has_many => C } } )'); throws_ok ( sub { # Create via update - add a new CD <--- THIS SHOULD HAVE NEVER WORKED! $schema->resultset('Artist')->first->update({ cds => [ { title => 'Yet another CD', year => 2006, }, ], }); }, qr/Recursive update is not supported over relationships of type 'multi'/, 'create via update of multi relationships throws an exception' ); lives_ok ( sub { my $artist = $schema->resultset('Artist')->first; my $c2p = $schema->resultset('CD_to_Producer')->create ({ cd => { artist => $artist, title => 'Bad investment', year => 2008, tracks => [ { title => 'Just buy' }, { title => 'Why did we do it' }, { title => 'Burn baby burn' }, ], }, producer => { name => 'Lehman Bros.', }, }); isa_ok ($c2p, 'DBICTest::CD_to_Producer', 'Linker object created'); my $prod = $schema->resultset ('Producer')->find ({ name => 'Lehman Bros.' }); isa_ok ($prod, 'DBICTest::Producer', 'Producer row found'); is ($prod->cds->count, 1, 'Producer has one production'); my $cd = $prod->cds->first; is ($cd->title, 'Bad investment', 'CD created correctly'); is ($cd->tracks->count, 3, 'CD has 3 tracks'); }, 'Create m2m while originating in the linker table'); #CD -> has_many -> Tracks -> might have -> Single -> has_many -> Tracks # \ # \-> has_many \ # --> CD2Producer # /-> has_many / # / # Producer lives_ok ( sub { my $artist = $schema->resultset('Artist')->find(1); my $cd = $schema->resultset('CD')->create ({ artist => $artist, title => 'Music to code by at night', year => 2008, tracks => [ { title => 'Off by one again', }, { title => 'The dereferencer', cd_single => { artist => $artist, year => 2008, title => 'Was that a null (Single)', tracks => [ { title => 'The dereferencer' }, { title => 'The dereferencer II' }, ], cd_to_producer => [ { producer => { name => 'K&R', } }, { producer => { name => 'Don Knuth', } }, ] }, }, ], }); isa_ok ($cd, 'DBICTest::CD', 'Main CD object created'); is ($cd->title, 'Music to code by at night', 'Correct CD title'); is ($cd->tracks->count, 2, 'Two tracks on main CD'); my ($t1, $t2) = sort { $a->id <=> $b->id } $cd->tracks->all; is ($t1->title, 'Off by one again', 'Correct 1st track name'); is ($t1->cd_single, undef, 'No single for 1st track'); is ($t2->title, 'The dereferencer', 'Correct 2nd track name'); isa_ok ($t2->cd_single, 'DBICTest::CD', 'Created a single for 2nd track'); my $single = $t2->cd_single; is ($single->tracks->count, 2, 'Two tracks on single CD'); is ($single->tracks->find ({ position => 1})->title, 'The dereferencer', 'Correct 1st track title'); is ($single->tracks->find ({ position => 2})->title, 'The dereferencer II', 'Correct 2nd track title'); is ($single->cd_to_producer->count, 2, 'Two producers created for the single cd'); is_deeply ( [ sort map { $_->producer->name } ($single->cd_to_producer->all) ], ['Don Knuth', 'K&R'], 'Producers named correctly', ); }, 'Create over > 1 levels of might_have with multiple has_many and multiple m2m but starting at a has_many level'); #Track -> might have -> Single -> has_many -> Tracks # \ # \-> has_many \ # --> CD2Producer # /-> has_many / # / # Producer lives_ok ( sub { my $cd = $schema->resultset('CD')->first; my $track = $schema->resultset('Track')->create ({ cd => $cd, title => 'Multicreate rocks', cd_single => { artist => $cd->artist, year => 2008, title => 'Disemboweling MultiCreate', tracks => [ { title => 'Why does mst write this way' }, { title => 'Chainsaw celebration' }, { title => 'Purl cleans up' }, ], cd_to_producer => [ { producer => { name => 'mst', } }, { producer => { name => 'castaway', } }, { producer => { name => 'theorbtwo', } }, ] }, }); isa_ok ($track, 'DBICTest::Track', 'Main Track object created'); is ($track->title, 'Multicreate rocks', 'Correct Track title'); my $single = $track->cd_single; isa_ok ($single, 'DBICTest::CD', 'Created a single with the track'); is ($single->tracks->count, 3, '3 tracks on single CD'); is ($single->tracks->find ({ position => 1})->title, 'Why does mst write this way', 'Correct 1st track title'); is ($single->tracks->find ({ position => 2})->title, 'Chainsaw celebration', 'Correct 2nd track title'); is ($single->tracks->find ({ position => 3})->title, 'Purl cleans up', 'Correct 3rd track title'); is ($single->cd_to_producer->count, 3, '3 producers created for the single cd'); is_deeply ( [ sort map { $_->producer->name } ($single->cd_to_producer->all) ], ['castaway', 'mst', 'theorbtwo'], 'Producers named correctly', ); }, 'Create over > 1 levels of might_have with multiple has_many and multiple m2m but starting at the might_have directly'); lives_ok ( sub { my $artist = $schema->resultset('Artist')->first; my $cd = $schema->resultset('CD')->create ({ artist => $artist, title => 'Music to code by at twilight', year => 2008, artwork => { images => [ { name => 'recursive descent' }, { name => 'tail packing' }, ], }, }); isa_ok ($cd, 'DBICTest::CD', 'Main CD object created'); is ($cd->title, 'Music to code by at twilight', 'Correct CD title'); isa_ok ($cd->artwork, 'DBICTest::Artwork', 'Artwork created'); # this test might look weird, but it failed at one point, keep it there my $art_obj = $cd->artwork; ok ($art_obj->has_column_loaded ('cd_id'), 'PK/FK present on artwork object'); is ($art_obj->images->count, 2, 'Correct artwork image count via the new object'); is_deeply ( [ sort $art_obj->images->get_column ('name')->all ], [ 'recursive descent', 'tail packing' ], 'Images named correctly in objects', ); my $artwork = $schema->resultset('Artwork')->search ( { 'cd.title' => 'Music to code by at twilight' }, { join => 'cd' }, )->single; is ($artwork->images->count, 2, 'Correct artwork image count via a new search'); is_deeply ( [ sort $artwork->images->get_column ('name')->all ], [ 'recursive descent', 'tail packing' ], 'Images named correctly after search', ); }, 'Test might_have again but with a PK == FK in the middle (obviously not specified)'); lives_ok ( sub { my $cd = $schema->resultset('CD')->first; my $track = $schema->resultset ('Track')->create ({ cd => $cd, title => 'Black', lyrics => { lyric_versions => [ { text => 'The color black' }, { text => 'The colour black' }, ], }, }); isa_ok ($track, 'DBICTest::Track', 'Main track object created'); is ($track->title, 'Black', 'Correct track title'); isa_ok ($track->lyrics, 'DBICTest::Lyrics', 'Lyrics created'); # this test might look weird, but it was failing at one point, keep it there my $lyric_obj = $track->lyrics; ok ($lyric_obj->has_column_loaded ('lyric_id'), 'PK present on lyric object'); ok ($lyric_obj->has_column_loaded ('track_id'), 'FK present on lyric object'); is ($lyric_obj->lyric_versions->count, 2, 'Correct lyric versions count via the new object'); is_deeply ( [ sort $lyric_obj->lyric_versions->get_column ('text')->all ], [ 'The color black', 'The colour black' ], 'Lyrics text in objects matches', ); my $lyric = $schema->resultset('Lyrics')->search ( { 'track.title' => 'Black' }, { join => 'track' }, )->single; is ($lyric->lyric_versions->count, 2, 'Correct lyric versions count via a new search'); is_deeply ( [ sort $lyric->lyric_versions->get_column ('text')->all ], [ 'The color black', 'The colour black' ], 'Lyrics text via search matches', ); }, 'Test might_have again but with just a PK and FK (neither specified) in the mid-table'); lives_ok ( sub { my $newartist2 = $schema->resultset('Artist')->find_or_create({ name => 'Fred 3', cds => [ { title => 'Noah Act', year => 2007, }, ], }); is($newartist2->name, 'Fred 3', 'Created new artist with cds via find_or_create'); }, 'Nested find_or_create'); lives_ok ( sub { my $artist = $schema->resultset('Artist')->first; my $cd_result = $artist->create_related('cds', { title => 'TestOneCD1', year => 2007, tracks => [ { title => 'TrackOne' }, { title => 'TrackTwo' }, ], }); isa_ok( $cd_result, 'DBICTest::CD', "Got Good CD Class"); ok( $cd_result->title eq "TestOneCD1", "Got Expected Title"); my $tracks = $cd_result->tracks; isa_ok( $tracks, 'DBIx::Class::ResultSet', 'Got Expected Tracks ResultSet'); foreach my $track ($tracks->all) { isa_ok( $track, 'DBICTest::Track', 'Got Expected Track Class'); } }, 'First create_related pass'); lives_ok ( sub { my $artist = $schema->resultset('Artist')->first; my $cd_result = $artist->create_related('cds', { title => 'TestOneCD2', year => 2007, tracks => [ { title => 'TrackOne' }, { title => 'TrackTwo' }, ], liner_notes => { notes => 'I can haz liner notes?' }, }); isa_ok( $cd_result, 'DBICTest::CD', "Got Good CD Class"); ok( $cd_result->title eq "TestOneCD2", "Got Expected Title"); ok( $cd_result->notes eq 'I can haz liner notes?', 'Liner notes'); my $tracks = $cd_result->tracks; isa_ok( $tracks, 'DBIx::Class::ResultSet', "Got Expected Tracks ResultSet"); foreach my $track ($tracks->all) { isa_ok( $track, 'DBICTest::Track', 'Got Expected Track Class'); } }, 'second create_related with same arguments'); lives_ok ( sub { my $cdp = $schema->resultset('CD_to_Producer')->create({ cd => { artist => 1, title => 'foo', year => 2000 }, producer => { name => 'jorge' } }); ok($cdp, 'join table record created ok'); }, 'create of parents of a record linker table'); lives_ok ( sub { my $kurt_cobain = { name => 'Kurt Cobain' }; my $in_utero = $schema->resultset('CD')->new({ title => 'In Utero', year => 1993 }); $kurt_cobain->{cds} = [ $in_utero ]; warnings_exist { $schema->resultset('Artist')->populate([ $kurt_cobain ]); } qr/\QFast-path populate() with supplied related objects is not possible/; my $artist = $schema->resultset('Artist')->find({name => 'Kurt Cobain'}); is($artist->name, 'Kurt Cobain', 'Artist insertion ok'); is($artist->cds && $artist->cds->first && $artist->cds->first->title, 'In Utero', 'CD insertion ok'); }, 'populate'); ## Create foreign key col obj including PK ## See test 20 in 66relationships.t lives_ok ( sub { my $new_cd_hashref = { cdid => 27, title => 'Boogie Woogie', year => '2007', artist => { artistid => 17, name => 'king luke' } }; my $cd = $schema->resultset("CD")->find(1); is($cd->artist->id, 1, 'rel okay'); my $new_cd = $schema->resultset("CD")->create($new_cd_hashref); is($new_cd->artist->id, 17, 'new id retained okay'); }, 'Create foreign key col obj including PK'); lives_ok ( sub { $schema->resultset("CD")->create({ cdid => 28, title => 'Boogie Wiggle', year => '2007', artist => { artistid => 18, name => 'larry' } }); }, 'new cd created without clash on related artist'); throws_ok ( sub { my $t = $schema->resultset("Track")->new({ cd => { artist => undef } }); #$t->cd($t->new_related('cd', { artist => undef } ) ); #$t->{_rel_in_storage} = 0; $t->insert; }, qr/DBI Exception.+(?x: \QNOT NULL constraint failed: cd.artist\E | \Qcd.artist may not be NULL\E )/s, "Exception propogated properly"); lives_ok ( sub { $schema->resultset('CD')->create ({ artist => { name => 'larry', # should already exist }, title => 'Warble Marble', year => '2009', cd_to_producer => [ { producer => { name => 'Cowboy Neal' } }, ], }); my $m2m_cd = $schema->resultset('CD')->search ({ title => 'Warble Marble'}); is ($m2m_cd->count, 1, 'One CD row created via M2M create'); is ($m2m_cd->first->producers->count, 1, 'CD row created with one producer'); is ($m2m_cd->first->producers->first->name, 'Cowboy Neal', 'Correct producer row created'); }, 'Test multi create over many_to_many'); done_testing; ���������������������DBIx-Class-0.082843/t/multi_create/find_or_multicreate.t��������������������������������������������0000644�0001750�0001750�00000003731�14240132261�022225� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema( no_populate => 1 ); my $t11 = $schema->resultset('Track')->find_or_create({ trackid => 1, title => 'Track one cd one', cd => { year => 1, title => 'CD one', very_long_artist_relationship => { name => 'Artist one', } } }); my $t12 = $schema->resultset('Track')->find_or_create({ trackid => 2, title => 'Track two cd one', cd => { title => 'CD one', very_long_artist_relationship => { name => 'Artist one', } } }); # FIXME - MC should be smart enough to infer this on its own... $schema->resultset('Artist')->create({ name => 'Artist two' }); my $t2 = $schema->resultset('Track')->find_or_create({ trackid => 3, title => 'Track one cd one', cd => { year => 1, title => 'CD one', very_long_artist_relationship => { name => 'Artist two', } } }); is_deeply( $schema->resultset('Artist')->search({}, { prefetch => { cds => 'tracks' }, order_by => 'tracks.title', })->all_hri, [ { artistid => 1, charfield => undef, name => "Artist one", rank => 13, cds => [ { artist => 1, cdid => 1, genreid => undef, single_track => undef, title => "CD one", year => 1, tracks => [ { cd => 1, last_updated_at => undef, last_updated_on => undef, position => 1, title => "Track one cd one", trackid => 1 }, { cd => 1, last_updated_at => undef, last_updated_on => undef, position => 2, title => "Track two cd one", trackid => 2 }, ]}, ]}, { artistid => 2, charfield => undef, name => "Artist two", rank => 13, cds => [ { artist => 2, cdid => 2, genreid => undef, single_track => undef, title => "CD one", year => 1, tracks => [ { cd => 2, last_updated_at => undef, last_updated_on => undef, position => 1, title => "Track one cd one", trackid => 3 }, ]}, ]}, ], 'Expected state of database after several find_or_create rounds' ); done_testing; ���������������������������������������DBIx-Class-0.082843/t/multi_create/has_many.t�������������������������������������������������������0000644�0001750�0001750�00000001110�14240132261�017773� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); my $link = $schema->resultset ('Link')->create ({ url => 'loldogs!', bookmarks => [ { link => 'Mein Hund ist schwul'}, { link => 'Mein Hund ist schwul'}, ] }); is ($link->bookmarks->count, 2, "Two identical default-insert has_many's created"); $link = $schema->resultset ('Link')->create ({ url => 'lolcats!', bookmarks => [ {}, {}, ] }); is ($link->bookmarks->count, 2, "Two identical default-insert has_many's created"); done_testing; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/prefetch/���������������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�015162� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/prefetch/one_to_many_to_one.t�������������������������������������������������0000644�0001750�0001750�00000001416�14240132261�021202� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); my $artist = $schema->resultset ('Artist')->find ({artistid => 1}); is ($artist->cds->count, 3, 'Correct number of CDs'); is ($artist->cds->search_related ('genre')->count, 1, 'Only one of the cds has a genre'); $schema->is_executed_querycount( sub { my $pref = $schema->resultset ('Artist') ->search ({ 'me.artistid' => $artist->id }, { prefetch => { cds => 'genre' } }) ->next; is ($pref->cds->count, 3, 'Correct number of CDs prefetched'); is ($pref->cds->search_related ('genre')->count, 1, 'Only one of the prefetched cds has a prefetched genre'); }, 1, 'All happened within one query only'); done_testing; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/prefetch/correlated.t���������������������������������������������������������0000644�0001750�0001750�00000017332�14240132261�017460� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Deep; use lib qw(t/lib); use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); my $cdrs = $schema->resultset('CD')->search({ 'me.artist' => { '!=', 2 }}); my $cd_data = { map { $_->cdid => { siblings => $cdrs->search ({ artist => $_->get_column('artist') })->count - 1, track_titles => [ sort $_->tracks->get_column('title')->all ], }, } ( $cdrs->all ) }; my $c_rs = $cdrs->search ({}, { prefetch => 'tracks', '+columns' => { sibling_count => $cdrs->search( { 'siblings.artist' => { -ident => 'me.artist' }, 'siblings.cdid' => { '!=' => ['-and', { -ident => 'me.cdid' }, 23414] }, }, { alias => 'siblings' }, )->count_rs->as_query, }, }); is_same_sql_bind( $c_rs->as_query, '( SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track, (SELECT COUNT( * ) FROM cd siblings WHERE me.artist != ? AND siblings.artist = me.artist AND siblings.cdid != me.cdid AND siblings.cdid != ? ), tracks.trackid, tracks.cd, tracks.position, tracks.title, tracks.last_updated_on, tracks.last_updated_at FROM cd me LEFT JOIN track tracks ON tracks.cd = me.cdid WHERE me.artist != ? )', [ # subselect [ { sqlt_datatype => 'integer', dbic_colname => 'me.artist' } => 2 ], [ { sqlt_datatype => 'integer', dbic_colname => 'siblings.cdid' } => 23414 ], # outher WHERE [ { sqlt_datatype => 'integer', dbic_colname => 'me.artist' } => 2 ], ], 'Expected SQL on correlated realiased subquery' ); $schema->is_executed_querycount( sub { cmp_deeply ( { map { $_->cdid => { track_titles => [ sort map { $_->title } ($_->tracks->all) ], siblings => $_->get_column ('sibling_count'), } } $c_rs->all }, $cd_data, 'Proper information retrieved from correlated subquery' ); }, 1, 'Only 1 query fired to retrieve everything'); # now add an unbalanced select/as pair $c_rs = $c_rs->search ({}, { '+select' => $cdrs->search( { 'siblings.artist' => { -ident => 'me.artist' } }, { alias => 'siblings', columns => [ { first_year => { min => 'year' }}, { last_year => { max => 'year' }}, ]}, )->as_query, '+as' => [qw/active_from active_to/], }); is_same_sql_bind( $c_rs->as_query, '( SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track, (SELECT COUNT( * ) FROM cd siblings WHERE me.artist != ? AND siblings.artist = me.artist AND siblings.cdid != me.cdid AND siblings.cdid != ? ), (SELECT MIN( year ), MAX( year ) FROM cd siblings WHERE me.artist != ? AND siblings.artist = me.artist ), tracks.trackid, tracks.cd, tracks.position, tracks.title, tracks.last_updated_on, tracks.last_updated_at FROM cd me LEFT JOIN track tracks ON tracks.cd = me.cdid WHERE me.artist != ? )', [ # first subselect [ { sqlt_datatype => 'integer', dbic_colname => 'me.artist' } => 2 ], [ { sqlt_datatype => 'integer', dbic_colname => 'siblings.cdid' } => 23414 ], # second subselect [ { sqlt_datatype => 'integer', dbic_colname => 'me.artist' } => 2 ], # outher WHERE [ { sqlt_datatype => 'integer', dbic_colname => 'me.artist' } => 2 ], ], 'Expected SQL on correlated realiased subquery' ); $schema->storage->disconnect; # test for subselect identifier leakage # NOTE - the hodge-podge mix of literal and regular identifuers is *deliberate* for my $quote_names (0,1) { my $schema = DBICTest->init_schema( quote_names => $quote_names ); my ($ql, $qr) = $schema->storage->sql_maker->_quote_chars; my $art_rs = $schema->resultset('Artist')->search ({}, { order_by => 'me.artistid', prefetch => 'cds', rows => 2, }); my $inner_lim_bindtype = { sqlt_datatype => 'integer' }; for my $inner_relchain (qw( cds_unordered cds ) ) { my $stupid_latest_competition_release_query = $schema->resultset('Artist')->search( { 'competition.artistid' => { '!=', { -ident => 'me.artistid' } } }, { alias => 'competition' }, )->search_related( $inner_relchain, {}, { rows => 1, order_by => 'year', columns => { year => \'year' }, distinct => 1 })->get_column(\'year')->max_rs; my $final_query = $art_rs->search( {}, { '+columns' => { max_competition_release => \[ @${ $stupid_latest_competition_release_query->as_query } ]}, }); # we are using cds_unordered explicitly above - do the sorting manually my @results = sort { $a->{artistid} <=> $b->{artistid} } @{$final_query->all_hri}; @$_ = sort { $a->{cdid} <=> $b->{cdid} } @$_ for map { $_->{cds} } @results; is_deeply ( \@results, [ { artistid => 1, charfield => undef, max_competition_release => 1998, name => "Caterwauler McCrae", rank => 13, cds => [ { artist => 1, cdid => 1, genreid => 1, single_track => undef, title => "Spoonful of bees", year => 1999 }, { artist => 1, cdid => 2, genreid => undef, single_track => undef, title => "Forkful of bees", year => 2001 }, { artist => 1, cdid => 3, genreid => undef, single_track => undef, title => "Caterwaulin' Blues", year => 1997 }, ] }, { artistid => 2, charfield => undef, max_competition_release => 1997, name => "Random Boy Band", rank => 13, cds => [ { artist => 2, cdid => 4, genreid => undef, single_track => undef, title => "Generic Manufactured Singles", year => 2001 }, ] }, ], "Expected result from weird query", ); # the decomposition to sql/bind is *deliberate* in both instances # we want to ensure this keeps working for lietral sql, even when # as_query switches to return an overloaded dq node my ($sql, @bind) = @${ $final_query->as_query }; my $correlated_sql = qq{ ( SELECT MAX( year ) FROM ( SELECT year FROM ${ql}artist${qr} ${ql}competition${qr} JOIN cd ${ql}${inner_relchain}${qr} ON ${ql}${inner_relchain}${qr}.${ql}artist${qr} = ${ql}competition${qr}.${ql}artistid${qr} WHERE ${ql}competition${qr}.${ql}artistid${qr} != ${ql}me${qr}.${ql}artistid${qr} GROUP BY year ORDER BY MIN( ${ql}year${qr} ) LIMIT ? ) ${ql}${inner_relchain}${qr} )}; is_same_sql_bind( $sql, \@bind, qq{ ( SELECT ${ql}me${qr}.${ql}artistid${qr}, ${ql}me${qr}.${ql}name${qr}, ${ql}me${qr}.${ql}rank${qr}, ${ql}me${qr}.${ql}charfield${qr}, $correlated_sql, ${ql}cds${qr}.${ql}cdid${qr}, ${ql}cds${qr}.${ql}artist${qr}, ${ql}cds${qr}.${ql}title${qr}, ${ql}cds${qr}.${ql}year${qr}, ${ql}cds${qr}.${ql}genreid${qr}, ${ql}cds${qr}.${ql}single_track${qr} FROM ( SELECT ${ql}me${qr}.${ql}artistid${qr}, ${ql}me${qr}.${ql}name${qr}, ${ql}me${qr}.${ql}rank${qr}, ${ql}me${qr}.${ql}charfield${qr}, $correlated_sql FROM ${ql}artist${qr} ${ql}me${qr} ORDER BY ${ql}me${qr}.${ql}artistid${qr} LIMIT ? ) ${ql}me${qr} LEFT JOIN cd ${ql}cds${qr} ON ${ql}cds${qr}.${ql}artist${qr} = ${ql}me${qr}.${ql}artistid${qr} ORDER BY ${ql}me${qr}.${ql}artistid${qr} ) }, [ [ $inner_lim_bindtype => 1 ], [ $inner_lim_bindtype => 1 ], [ { sqlt_datatype => 'integer' } => 2 ], ], "No leakage of correlated subquery identifiers (quote_names => $quote_names, inner alias '$inner_relchain')" ); } } done_testing; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/prefetch/incomplete.t���������������������������������������������������������0000644�0001750�0001750�00000014607�14240132261�017475� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Deep; use Test::Exception; use lib qw(t/lib); use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); lives_ok(sub { # while cds.* will be selected anyway (prefetch implies it) # only the requested me.name column will be fetched. # reference sql with select => [...] # SELECT me.name, cds.title, cds.cdid, cds.artist, cds.title, cds.year, cds.genreid, cds.single_track FROM ... my $rs = $schema->resultset('Artist')->search( { 'cds.title' => { '!=', 'Generic Manufactured Singles' } }, { prefetch => [ qw/ cds / ], order_by => [ { -desc => 'me.name' }, 'cds.title' ], select => [qw/ me.name cds.title / ], }, ); is ($rs->count, 2, 'Correct number of collapsed artists'); my ($we_are_goth) = $rs->all; is ($we_are_goth->name, 'We Are Goth', 'Correct first artist'); is ($we_are_goth->cds->count, 1, 'Correct number of CDs for first artist'); is ($we_are_goth->cds->first->title, 'Come Be Depressed With Us', 'Correct cd for artist'); }, 'explicit prefetch on a keyless object works'); lives_ok ( sub { my $rs = $schema->resultset('CD')->search( {}, { order_by => [ { -desc => 'me.year' } ], } ); my $years = [qw/ 2001 2001 1999 1998 1997/]; cmp_deeply ( [ $rs->search->get_column('me.year')->all ], $years, 'Expected years (at least one duplicate)', ); my @cds_and_tracks; for my $cd ($rs->all) { my $data = { year => $cd->year, cdid => $cd->cdid }; for my $tr ($cd->tracks->all) { push @{$data->{tracks}}, { $tr->get_columns }; } @{$data->{tracks}} = sort { $a->{trackid} <=> $b->{trackid} } @{$data->{tracks}}; push @cds_and_tracks, $data; } my $pref_rs = $rs->search ({}, { columns => [qw/year cdid/], prefetch => 'tracks' }); my @pref_cds_and_tracks; for my $cd ($pref_rs->all) { my $data = { $cd->get_columns }; for my $tr ($cd->tracks->all) { push @{$data->{tracks}}, { $tr->get_columns }; } @{$data->{tracks}} = sort { $a->{trackid} <=> $b->{trackid} } @{$data->{tracks}}; push @pref_cds_and_tracks, $data; } cmp_deeply ( \@pref_cds_and_tracks, \@cds_and_tracks, 'Correct collapsing on non-unique primary object' ); cmp_deeply ( $pref_rs->search ({}, { order_by => [ { -desc => 'me.year' }, 'trackid' ] })->all_hri, \@cds_and_tracks, 'Correct HRI collapsing on non-unique primary object' ); }, 'weird collapse lives'); lives_ok(sub { # test implicit prefetch as well my $rs = $schema->resultset('CD')->search( { title => 'Generic Manufactured Singles' }, { join=> 'artist', select => [qw/ me.title artist.name / ], } ); my $cd = $rs->next; is ($cd->title, 'Generic Manufactured Singles', 'CD title prefetched correctly'); isa_ok ($cd->artist, 'DBICTest::Artist'); is ($cd->artist->name, 'Random Boy Band', 'Artist object has correct name'); }, 'implicit keyless prefetch works'); # sane error throws_ok( sub { $schema->resultset('Track')->search({}, { join => { cd => 'artist' }, '+columns' => 'artist.name' } )->next; }, qr|\QInflation into non-existent relationship 'artist' of 'Track' requested, check the inflation specification (columns/as) ending in '...artist.name'|, 'Sensible error message on mis-specified "as"', ); # check complex limiting prefetch without the join-able columns { my $pref_rs = $schema->resultset('Owners')->search({}, { rows => 3, offset => 1, order_by => 'name', columns => 'name', # only the owner name, still prefetch all the books prefetch => 'books', }); is_same_sql_bind( $pref_rs->as_query, '( SELECT me.name, books.id, books.source, books.owner, books.title, books.price FROM ( SELECT me.name, me.id FROM owners me ORDER BY name LIMIT ? OFFSET ? ) me LEFT JOIN books books ON books.owner = me.id ORDER BY name )', [ [ { sqlt_datatype => "integer" } => 3 ], [ { sqlt_datatype => "integer" } => 1 ] ], 'Expected SQL on complex limited prefetch with non-selected join condition', ); is_deeply ( $pref_rs->all_hri, [ { name => "Waltham", books => [ { id => 3, owner => 2, price => 65, source => "Library", title => "Best Recipe Cookbook", } ], } ], 'Expected result on complex limited prefetch with non-selected join condition' ); my $empty_ordered_pref_rs = $pref_rs->search({}, { columns => [], # nothing, we only prefetch the book data order_by => 'me.name', }); my $empty_ordered_pref_hri = [ { books => [ { id => 3, owner => 2, price => 65, source => "Library", title => "Best Recipe Cookbook", } ], } ]; is_same_sql_bind( $empty_ordered_pref_rs->as_query, '( SELECT books.id, books.source, books.owner, books.title, books.price FROM ( SELECT me.id, me.name FROM owners me ORDER BY me.name LIMIT ? OFFSET ? ) me LEFT JOIN books books ON books.owner = me.id ORDER BY me.name )', [ [ { sqlt_datatype => "integer" } => 3 ], [ { sqlt_datatype => "integer" } => 1 ] ], 'Expected SQL on *ordered* complex limited prefetch with non-selected root data', ); is_deeply ( $empty_ordered_pref_rs->all_hri, $empty_ordered_pref_hri, 'Expected result on *ordered* complex limited prefetch with non-selected root data' ); $empty_ordered_pref_rs = $empty_ordered_pref_rs->search({}, { order_by => [ \ 'LENGTH(me.name)', \ 'RANDOM()' ], }); is_same_sql_bind( $empty_ordered_pref_rs->as_query, '( SELECT books.id, books.source, books.owner, books.title, books.price FROM ( SELECT me.id, me.name FROM owners me ORDER BY LENGTH(me.name), RANDOM() LIMIT ? OFFSET ? ) me LEFT JOIN books books ON books.owner = me.id ORDER BY LENGTH(me.name), RANDOM() )', [ [ { sqlt_datatype => "integer" } => 3 ], [ { sqlt_datatype => "integer" } => 1 ] ], 'Expected SQL on *function-ordered* complex limited prefetch with non-selected root data', ); is_deeply ( $empty_ordered_pref_rs->all_hri, $empty_ordered_pref_hri, 'Expected result on *function-ordered* complex limited prefetch with non-selected root data' ); } done_testing; �������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/prefetch/via_search_related.t�������������������������������������������������0000644�0001750�0001750�00000015757�14240132261�021151� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); lives_ok ( sub { my $no_prefetch = $schema->resultset('Track')->search_related(cd => { 'cd.year' => "2000", }, { join => 'tags', order_by => 'me.trackid', rows => 1, } ); my $use_prefetch = $no_prefetch->search( {}, { prefetch => 'tags', } ); is($use_prefetch->count, $no_prefetch->count, 'counts with and without prefetch match'); is( scalar ($use_prefetch->all), scalar ($no_prefetch->all), "Amount of returned rows is right" ); }, 'search_related prefetch with order_by works'); lives_ok ( sub { my $no_prefetch = $schema->resultset('Track')->search_related(cd => { 'cd.year' => "2000", 'tagid' => 1, }, { join => 'tags', rows => 1, } ); my $use_prefetch = $no_prefetch->search( undef, { prefetch => 'tags', } ); is( scalar ($use_prefetch->all), scalar ($no_prefetch->all), "Amount of returned rows is right" ); is($use_prefetch->count, $no_prefetch->count, 'counts with and without prefetch match'); }, 'search_related prefetch with condition referencing unqualified column of a joined table works'); # make sure chains off prefetched results still work { my $cd = $schema->resultset('CD')->search({}, { prefetch => 'cd_to_producer' })->find(1); $schema->is_executed_querycount( sub { is( $cd->cd_to_producer->count, 3 ,'Count of prefetched m2m links via accessor' ); is( scalar $cd->cd_to_producer->all, 3, 'Amount of prefetched m2m link objects via accessor' ); is( $cd->search_related('cd_to_producer')->count, 3, 'Count of prefetched m2m links via search_related' ); is( scalar $cd->search_related('cd_to_producer')->all, 3, 'Amount of prefetched m2m links via search_related' ); }, 0, 'No queries ran so far'); is( scalar $cd->cd_to_producer->search_related('producer')->all, 3, 'Amount of objects via search_related off prefetched linker' ); is( $cd->cd_to_producer->search_related('producer')->count, 3, 'Count via search_related off prefetched linker' ); is( scalar $cd->search_related('cd_to_producer')->search_related('producer')->all, 3, 'Amount of objects via chained search_related off prefetched linker' ); is( $cd->search_related('cd_to_producer')->search_related('producer')->count, 3, 'Count via chained search_related off prefetched linker' ); is( scalar $cd->producers->all, 3, 'Amount of objects via m2m accessor' ); is( $cd->producers->count, 3, 'Count via m2m accessor' ); $schema->is_executed_querycount( sub { is( $cd->cd_to_producer->count, 3 ,'Review count of prefetched m2m links via accessor' ); is( scalar $cd->cd_to_producer->all, 3, 'Review amount of prefetched m2m link objects via accessor' ); is( $cd->search_related('cd_to_producer')->count, 3, 'Review count of prefetched m2m links via search_related' ); is( scalar $cd->search_related('cd_to_producer')->all, 3, 'Rreview amount of prefetched m2m links via search_related' ); }, 0, 'Still no queries on prefetched linker'); } # tests with distinct => 1 lives_ok (sub { my $rs = $schema->resultset("Artwork")->search(undef, {distinct => 1}) ->search_related('artwork_to_artist')->search_related('artist', undef, { prefetch => 'cds' }, ); is($rs->all, 0, 'prefetch without WHERE (objects)'); is($rs->count, 0, 'prefetch without WHERE (count)'); $rs = $schema->resultset("Artwork")->search(undef, {distinct => 1}) ->search_related('artwork_to_artist')->search_related('artist', { 'cds.title' => 'foo' }, { prefetch => 'cds' }, ); is($rs->all, 0, 'prefetch with WHERE (objects)'); is($rs->count, 0, 'prefetch with WHERE (count)'); # test where conditions at the root of the related chain my $artist_rs = $schema->resultset("Artist")->search({artistid => 2}); my $artist = $artist_rs->next; $artist->create_related ('cds', $_) for ( { year => 1999, title => 'vague cd', genre => { name => 'vague genre' } }, { year => 1999, title => 'vague cd2', genre => { name => 'vague genre' } }, ); $rs = $artist_rs->search_related('cds')->search_related('genre', { 'genre.name' => 'vague genre' }, { prefetch => 'cds' }, ); is($rs->all, 1, 'base without distinct (objects)'); is($rs->count, 1, 'base without distinct (count)'); # artist -> 2 cds -> 2 genres -> 2 cds for each genre = 4 is($rs->search_related('cds')->all, 4, 'prefetch without distinct (objects)'); is($rs->search_related('cds')->count, 4, 'prefetch without distinct (count)'); $rs = $artist_rs->search_related('cds', {}, { distinct => 1})->search_related('genre', { 'genre.name' => 'vague genre' }, ); is($rs->all, 2, 'distinct does not propagate over search_related (objects)'); is($rs->count, 2, 'distinct does not propagate over search_related (count)'); $rs = $rs->search ({}, { distinct => 1} ); is($rs->all, 1, 'distinct without prefetch (objects)'); is($rs->count, 1, 'distinct without prefetch (count)'); $rs = $artist_rs->search_related('cds')->search_related('genre', { 'genre.name' => 'vague genre' }, { prefetch => 'cds', distinct => 1 }, ); is($rs->all, 1, 'distinct with prefetch (objects)'); is($rs->count, 1, 'distinct with prefetch (count)'); local $TODO = "This makes another 2 trips to the database, it can't be right"; $schema->is_executed_querycount( sub { # the is() calls are not todoified local $TODO; # artist -> 2 cds -> 2 genres -> 2 cds for each genre + distinct = 2 is($rs->search_related('cds')->all, 2, 'prefetched distinct with prefetch (objects)'); is($rs->search_related('cds')->count, 2, 'prefetched distinct with prefetch (count)'); }, 0, 'No extra queries fired (prefetch survives search_related)'); }, 'distinct generally works with prefetch on deep search_related chains'); # pathological "user knows what they're doing" case # lifted from production somewhere { $schema->resultset('CD') ->search({ cdid => [1,2] }) ->search_related('tracks', { position => [3,1] }) ->delete_all; my $rs = $schema->resultset('CD')->search_related('tracks', {}, { group_by => 'me.title', columns => { title => 'me.title', max_trk => \ 'MAX(tracks.position)' }, }); is_deeply( $rs->search({}, { order_by => 'me.title' })->all_hri, [ { title => "Caterwaulin' Blues", max_trk => 3 }, { title => "Come Be Depressed With Us", max_trk => 3 }, { title => "Forkful of bees", max_trk => 1 }, { title => "Generic Manufactured Singles", max_trk => 3 }, { title => "Spoonful of bees", max_trk => 1 }, ], 'Expected nonsense', ); } done_testing; �����������������DBIx-Class-0.082843/t/prefetch/lazy_cursor.t��������������������������������������������������������0000644�0001750�0001750�00000004724�14240132261�017711� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Warn; use Test::Exception; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); my $rs = $schema->resultset('Artist')->search({}, { select => 'artistid', prefetch => { cds => 'tracks' }, }); my $initial_artists_cnt = $rs->count; # create one extra artist with just one cd with just one track # and then an artist with nothing at all # the implicit order by me.artistid will get them back in correct order $rs->create({ name => 'foo', cds => [{ year => 2012, title => 'foocd', tracks => [{ title => 'footrack', }] }], }); $rs->create({ name => 'bar' }); $rs->create({ name => 'baz' }); # make sure we are reentrant, and also check with explicit order_by for (undef, undef, 'me.artistid') { $rs = $rs->search({}, { order_by => $_ }) if $_; for (1 .. $initial_artists_cnt) { is ($rs->next->artistid, $_, 'Default fixture artists in order') || exit; } my $foo_artist = $rs->next; is ($foo_artist->cds->next->tracks->next->title, 'footrack', 'Right track'); is ( [$rs->cursor->next]->[0], $initial_artists_cnt + 3, 'Very last artist still on the cursor' ); is_deeply ([$rs->cursor->next], [], 'Nothing else left'); is ($rs->next->artistid, $initial_artists_cnt + 2, 'Row stashed in resultset still accessible'); is ($rs->next, undef, 'Nothing left in resultset either'); $rs->reset; } $rs->next; my @objs = $rs->all; is (@objs, $initial_artists_cnt + 3, '->all resets everything correctly'); is ( ($rs->cursor->next)[0], 1, 'Cursor auto-rewound after all()'); is ($rs->{_stashed_rows}, undef, 'Nothing else left in $rs stash'); my $unordered_rs = $rs->search({}, { order_by => 'cds.title' }); warnings_exist { ok ($unordered_rs->next, 'got row 1'); } qr/performed an eager cursor slurp underneath/, 'Warned on auto-eager cursor'; is_deeply ([$unordered_rs->cursor->next], [], 'Nothing left on cursor, eager slurp'); ok ($unordered_rs->next, "got row $_") for (2 .. $initial_artists_cnt + 3); is ($unordered_rs->next, undef, 'End of RS reached'); is ($unordered_rs->next, undef, 'End of RS not lost'); { my $non_uniquely_ordered_constrained = $schema->resultset('CD')->search( { artist => 1 }, { order_by => [qw( me.genreid me.title me.year )], prefetch => 'tracks' }, ); isa_ok ($non_uniquely_ordered_constrained->next, 'DBICTest::CD' ); ok( defined $non_uniquely_ordered_constrained->cursor->next, 'Cursor not exhausted' ); } done_testing; ��������������������������������������������DBIx-Class-0.082843/t/prefetch/attrs_untouched.t����������������������������������������������������0000644�0001750�0001750�00000001426�14240132261�020544� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use warnings; use strict; use Test::More; use lib qw(t/lib); use DBICTest; use Data::Dumper; $Data::Dumper::Sortkeys = 1; my $schema = DBICTest->init_schema(); plan tests => 3; # bug in 0.07000 caused attr (join/prefetch) to be modifed by search # so we check the search & attr arrays are not modified my $search = { 'artist.name' => 'Caterwauler McCrae' }; my $attr = { prefetch => [ qw/artist liner_notes/ ], order_by => 'me.cdid' }; my $search_str = Dumper($search); my $attr_str = Dumper($attr); my $rs = $schema->resultset("CD")->search($search, $attr); is(Dumper($search), $search_str, 'Search hash untouched after search()'); is(Dumper($attr), $attr_str, 'Attribute hash untouched after search()'); cmp_ok($rs + 0, '==', 3, 'Correct number of records returned'); ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/prefetch/restricted_children_set.t��������������������������������������������0000644�0001750�0001750�00000004463�14240132261�022230� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); my $cds_rs = $schema->resultset('CD')->search( [ { 'me.title' => "Caterwaulin' Blues", 'cds.title' => { '!=' => 'Forkful of bees' } }, { 'me.title' => { '!=', => "Caterwaulin' Blues" }, 'cds.title' => 'Forkful of bees' }, ], { order_by => [qw(me.cdid cds.title)], prefetch => { artist => 'cds' }, result_class => 'DBIx::Class::ResultClass::HashRefInflator', }, ); is_deeply [ $cds_rs->all ], [ { 'single_track' => undef, 'cdid' => '1', 'artist' => { 'cds' => [ { 'single_track' => undef, 'artist' => '1', 'cdid' => '2', 'title' => 'Forkful of bees', 'genreid' => undef, 'year' => '2001' }, ], 'artistid' => '1', 'charfield' => undef, 'name' => 'Caterwauler McCrae', 'rank' => '13' }, 'title' => 'Spoonful of bees', 'year' => '1999', 'genreid' => '1' }, { 'single_track' => undef, 'cdid' => '2', 'artist' => { 'cds' => [ { 'single_track' => undef, 'artist' => '1', 'cdid' => '2', 'title' => 'Forkful of bees', 'genreid' => undef, 'year' => '2001' }, ], 'artistid' => '1', 'charfield' => undef, 'name' => 'Caterwauler McCrae', 'rank' => '13' }, 'title' => 'Forkful of bees', 'year' => '2001', 'genreid' => undef }, { 'single_track' => undef, 'cdid' => '3', 'artist' => { 'cds' => [ { 'single_track' => undef, 'artist' => '1', 'cdid' => '3', 'title' => 'Caterwaulin\' Blues', 'genreid' => undef, 'year' => '1997' }, { 'single_track' => undef, 'artist' => '1', 'cdid' => '1', 'title' => 'Spoonful of bees', 'genreid' => '1', 'year' => '1999' } ], 'artistid' => '1', 'charfield' => undef, 'name' => 'Caterwauler McCrae', 'rank' => '13' }, 'title' => 'Caterwaulin\' Blues', 'year' => '1997', 'genreid' => undef } ], 'multi-level prefetch with restrictions ok'; done_testing; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/prefetch/o2m_o2m_order_by_with_limit.t����������������������������������������0000644�0001750�0001750�00000013772�14240132261�022730� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use List::Util 'min'; use DBICTest ':DiffSQL'; my ($ROWS, $OFFSET) = ( DBIx::Class::SQLMaker::ClassicExtensions->__rows_bindtype, DBIx::Class::SQLMaker::ClassicExtensions->__offset_bindtype, ); my $schema = DBICTest->init_schema(quote_names => 1); my $artist_rs = $schema->resultset('Artist'); my $filtered_cd_rs = $artist_rs->search_related('cds_unordered', { "me.rank" => 13 }, { prefetch => 'tracks', join => 'genre', order_by => [ { -desc => 'genre.name' }, { -desc => \ 'tracks.title' }, { -asc => "me.name" }, { -desc => [qw(year cds_unordered.title)] } ], # me. is the artist, *NOT* the cd }, ); my $hri_contents = [ { artist => 1, cdid => 1, genreid => 1, single_track => undef, title => "Spoonful of bees", year => 1999, tracks => [ { cd => 1, last_updated_at => undef, last_updated_on => undef, position => 1, title => "The Bees Knees", trackid => 16 }, { cd => 1, last_updated_at => undef, last_updated_on => undef, position => 3, title => "Beehind You", trackid => 18 }, { cd => 1, last_updated_at => undef, last_updated_on => undef, position => 2, title => "Apiary", trackid => 17 }, ], }, { artist => 1, cdid => 3, genreid => undef, single_track => undef, title => "Caterwaulin' Blues", year => 1997, tracks => [ { cd => 3, last_updated_at => undef, last_updated_on => undef, position => 1, title => "Yowlin", trackid => 7 }, { cd => 3, last_updated_at => undef, last_updated_on => undef, position => 2, title => "Howlin", trackid => 8 }, { cd => 3, last_updated_at => undef, last_updated_on => undef, position => 3, title => "Fowlin", trackid => 9 }, ], }, { artist => 3, cdid => 5, genreid => undef, single_track => undef, title => "Come Be Depressed With Us", year => 1998, tracks => [ { cd => 5, last_updated_at => undef, last_updated_on => undef, position => 2, title => "Under The Weather", trackid => 14 }, { cd => 5, last_updated_at => undef, last_updated_on => undef, position => 3, title => "Suicidal", trackid => 15 }, { cd => 5, last_updated_at => undef, last_updated_on => undef, position => 1, title => "Sad", trackid => 13 }, ], }, { artist => 1, cdid => 2, genreid => undef, single_track => undef, title => "Forkful of bees", year => 2001, tracks => [ { cd => 2, last_updated_at => undef, last_updated_on => undef, position => 1, title => "Stung with Success", trackid => 4 }, { cd => 2, last_updated_at => undef, last_updated_on => undef, position => 2, title => "Stripy", trackid => 5 }, { cd => 2, last_updated_at => undef, last_updated_on => undef, position => 3, title => "Sticky Honey", trackid => 6 }, ], }, { artist => 2, cdid => 4, genreid => undef, single_track => undef, title => "Generic Manufactured Singles", year => 2001, tracks => [ { cd => 4, last_updated_at => undef, last_updated_on => undef, position => 3, title => "No More Ideas", trackid => 12 }, { cd => 4, last_updated_at => undef, last_updated_on => undef, position => 2, title => "Boring Song", trackid => 11 }, { cd => 4, last_updated_at => undef, last_updated_on => undef, position => 1, title => "Boring Name", trackid => 10}, ], }, ]; is_deeply( $filtered_cd_rs->all_hri, $hri_contents, 'Expected ordered unlimited contents', ); for ( [ 0, 1 ], [ 2, 0 ], [ 20, 2 ], [ 1, 3 ], [ 2, 4 ], ) { my ($limit, $offset) = @$_; my $rs = $filtered_cd_rs->search({}, { $limit ? (rows => $limit) : (), offset => $offset }); my $used_limit = $limit || $schema->storage->sql_maker->__max_int; my $offset_str = $offset ? 'OFFSET ?' : ''; is_same_sql_bind( $rs->as_query, qq{( SELECT "cds_unordered"."cdid", "cds_unordered"."artist", "cds_unordered"."title", "cds_unordered"."year", "cds_unordered"."genreid", "cds_unordered"."single_track", "tracks"."trackid", "tracks"."cd", "tracks"."position", "tracks"."title", "tracks"."last_updated_on", "tracks"."last_updated_at" FROM "artist" "me" JOIN ( SELECT "cds_unordered"."cdid", "cds_unordered"."artist", "cds_unordered"."title", "cds_unordered"."year", "cds_unordered"."genreid", "cds_unordered"."single_track" FROM "artist" "me" JOIN cd "cds_unordered" ON "cds_unordered"."artist" = "me"."artistid" LEFT JOIN "genre" "genre" ON "genre"."genreid" = "cds_unordered"."genreid" LEFT JOIN "track" "tracks" ON "tracks"."cd" = "cds_unordered"."cdid" WHERE "me"."rank" = ? GROUP BY "cds_unordered"."cdid", "cds_unordered"."artist", "cds_unordered"."title", "cds_unordered"."year", "cds_unordered"."genreid", "cds_unordered"."single_track", "me"."name" ORDER BY MAX("genre"."name") DESC, MAX( tracks.title ) DESC, "me"."name" ASC, "year" DESC, "cds_unordered"."title" DESC LIMIT ? $offset_str ) "cds_unordered" ON "cds_unordered"."artist" = "me"."artistid" LEFT JOIN "genre" "genre" ON "genre"."genreid" = "cds_unordered"."genreid" LEFT JOIN "track" "tracks" ON "tracks"."cd" = "cds_unordered"."cdid" WHERE "me"."rank" = ? ORDER BY "genre"."name" DESC, tracks.title DESC, "me"."name" ASC, "year" DESC, "cds_unordered"."title" DESC )}, [ [ { sqlt_datatype => 'integer', dbic_colname => 'me.rank' } => 13 ], [ $ROWS => $used_limit ], $offset ? [ $OFFSET => $offset ] : (), [ { sqlt_datatype => 'integer', dbic_colname => 'me.rank' } => 13 ], ], "correct SQL on prefetch over search_related ordered by external joins with limit '$limit', offset '$offset'", ); is_deeply( $rs->all_hri, [ @{$hri_contents}[$offset .. min( $used_limit+$offset-1, $#$hri_contents)] ], "Correct slice of the resultset returned with limit '$limit', offset '$offset'", ); } done_testing; ������DBIx-Class-0.082843/t/prefetch/count.t��������������������������������������������������������������0000644�0001750�0001750�00000007114�14240132261�016461� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); my $cd_rs = $schema->resultset('CD')->search ( { 'tracks.cd' => { '!=', undef } }, { prefetch => ['tracks', 'artist'] }, ); is($cd_rs->count, 5, 'CDs with tracks count'); is($cd_rs->search_related('tracks')->count, 15, 'Tracks associated with CDs count (before SELECT()ing)'); is($cd_rs->all, 5, 'Amount of CD objects with tracks'); is($cd_rs->search_related('tracks')->count, 15, 'Tracks associated with CDs count (after SELECT()ing)'); is($cd_rs->search_related ('tracks')->all, 15, 'Track objects associated with CDs (after SELECT()ing)'); my $artist = $schema->resultset('Artist')->create({name => 'xxx'}); my $artist_rs = $schema->resultset('Artist')->search( {artistid => $artist->id}, {prefetch=>'cds', join => 'twokeys' } ); is($artist_rs->count, 1, "New artist found with prefetch turned on"); is(scalar($artist_rs->all), 1, "New artist fetched with prefetch turned on"); is($artist_rs->related_resultset('cds')->count, 0, "No CDs counted on a brand new artist"); is(scalar($artist_rs->related_resultset('cds')->all), 0, "No CDs fetched on a brand new artist (count == fetch)"); # create a cd, and make sure the non-existing join does not skew the count $artist->create_related ('cds', { title => 'yyy', year => '1999' }); is($artist_rs->related_resultset('cds')->count, 1, "1 CDs counted on a brand new artist"); is(scalar($artist_rs->related_resultset('cds')->all), 1, "1 CDs prefetched on a brand new artist (count == fetch)"); # Really fuck shit up with one more cd and some insanity # this doesn't quite work as there are the prefetch gets lost # on search_related. This however is too esoteric to fix right # now my $cd2 = $artist->create_related ('cds', { title => 'zzz', year => '1999', tracks => [{ title => 'ping' }, { title => 'pong' }], }); my $cds = $cd2->search_related ('artist', {}, { join => 'twokeys' }) ->search_related ('cds'); my $tracks = $cds->search_related ('tracks'); is($tracks->count, 2, "2 Tracks counted on cd via artist via one of the cds"); is(scalar($tracks->all), 2, "2 Track objects on cd via artist via one of the cds"); is($cds->count, 2, "2 CDs counted on artist via one of the cds"); is(scalar($cds->all), 2, "2 CD objectson artist via one of the cds"); # make sure the join collapses all the way is_same_sql_bind ( $tracks->count_rs->as_query, '( SELECT COUNT( * ) FROM artist me LEFT JOIN twokeys twokeys ON twokeys.artist = me.artistid JOIN cd cds ON cds.artist = me.artistid JOIN track tracks ON tracks.cd = cds.cdid WHERE ( me.artistid = ? ) )', [ [ { sqlt_datatype => 'integer', dbic_colname => 'me.artistid' } => 4 ] ], ); { local $TODO = "Chaining with prefetch is fundamentally broken"; $schema->is_executed_querycount( sub { my $cds = $cd2->search_related ('artist', {}, { prefetch => { cds => 'tracks' }, join => 'twokeys' }) ->search_related ('cds'); my $tracks = $cds->search_related ('tracks'); is($tracks->count, 2, "2 Tracks counted on cd via artist via one of the cds"); is(scalar($tracks->all), 2, "2 Tracks prefetched on cd via artist via one of the cds"); is($tracks->count, 2, "Cached 2 Tracks counted on cd via artist via one of the cds"); is($cds->count, 2, "2 CDs counted on artist via one of the cds"); is(scalar($cds->all), 2, "2 CDs prefetched on artist via one of the cds"); is($cds->count, 2, "Cached 2 CDs counted on artist via one of the cds"); }, 3, '2 counts + 1 prefetch?' ); } done_testing; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/prefetch/grouped.t������������������������������������������������������������0000644�0001750�0001750�00000036234�14240132261�017003� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest ':DiffSQL'; my $ROWS = DBIx::Class::SQLMaker::ClassicExtensions->__rows_bindtype; my $OFFSET = DBIx::Class::SQLMaker::ClassicExtensions->__offset_bindtype; my $schema = DBICTest->init_schema(); my $cd_rs = $schema->resultset('CD')->search ( { 'tracks.cd' => { '!=', undef } }, { prefetch => 'tracks' }, ); # Database sanity check is($cd_rs->count, 5, 'CDs with tracks count'); for ($cd_rs->all) { is ($_->tracks->count, 3, '3 tracks for CD' . $_->id ); } my @cdids = sort $cd_rs->get_column ('cdid')->all; # Test a belongs_to prefetch of a has_many { my $track_rs = $schema->resultset ('Track')->search ( { 'me.cd' => { -in => \@cdids } }, { select => [ 'me.cd', { count => 'me.trackid' }, ], as => [qw/ cd track_count /], group_by => [qw/me.cd/], prefetch => 'cd', }, ); # this used to fuck up ->all, do not remove! ok ($track_rs->first, 'There is stuff in the rs'); is($track_rs->count, 5, 'Prefetched count with groupby'); is($track_rs->all, 5, 'Prefetched objects with groupby'); $schema->is_executed_querycount( sub { while (my $collapsed_track = $track_rs->next) { my $cdid = $collapsed_track->get_column('cd'); is($collapsed_track->get_column('track_count'), 3, "Correct count of tracks for CD $cdid" ); ok($collapsed_track->cd->title, "Prefetched title for CD $cdid" ); } }, 1, 'Single query on prefetched titles'); # Test sql by hand, as the sqlite db will simply paper over # improper group/select combinations # is_same_sql_bind ( $track_rs->count_rs->as_query, '( SELECT COUNT( * ) FROM ( SELECT me.cd FROM track me JOIN cd cd ON cd.cdid = me.cd WHERE ( me.cd IN ( ?, ?, ?, ?, ? ) ) GROUP BY me.cd ) me )', [ map { [ { sqlt_datatype => 'integer', dbic_colname => 'me.cd' } => $_ ] } @cdids ], 'count() query generated expected SQL', ); is_same_sql_bind ( $track_rs->as_query, '( SELECT me.cd, me.track_count, cd.cdid, cd.artist, cd.title, cd.year, cd.genreid, cd.single_track FROM ( SELECT me.cd, COUNT (me.trackid) AS track_count FROM track me JOIN cd cd ON cd.cdid = me.cd WHERE ( me.cd IN ( ?, ?, ?, ?, ? ) ) GROUP BY me.cd ) me JOIN cd cd ON cd.cdid = me.cd WHERE ( me.cd IN ( ?, ?, ?, ?, ? ) ) )', [ map { [ { sqlt_datatype => 'integer', dbic_colname => 'me.cd' } => $_ ] } (@cdids) x 2 ], 'next() query generated expected SQL', ); # add an extra track to one of the cds, and then make sure we can get it on top # (check if limit works) my $top_cd = $cd_rs->search({}, { order_by => 'cdid' })->slice (1,1)->next; $top_cd->create_related ('tracks', { title => 'over the top', }); my $top_cd_collapsed_track = $track_rs->search ({}, { rows => 2, order_by => [ { -desc => 'track_count' }, ], }); is ($top_cd_collapsed_track->count, 2); is ( $top_cd->title, $top_cd_collapsed_track->first->cd->title, 'Correct collapsed track with prefetched CD returned on top' ); } # test a has_many/might_have prefetch at the same level # Note that one of the CDs now has 4 tracks instead of 3 { my $most_tracks_rs = $schema->resultset ('CD')->search ( { 'me.cdid' => { '!=' => undef }, # duh - this is just to test WHERE }, { prefetch => [qw/tracks liner_notes/], select => ['me.cdid', { count => 'tracks.trackid' }, { max => 'tracks.trackid', -as => 'maxtr'} ], as => [qw/cdid track_count max_track_id/], group_by => 'me.cdid', order_by => [ { -desc => 'track_count' }, { -asc => 'maxtr' } ], rows => 2, } ); is_same_sql_bind ( $most_tracks_rs->count_rs->as_query, '( SELECT COUNT( * ) FROM ( SELECT me.cdid FROM cd me WHERE ( me.cdid IS NOT NULL ) GROUP BY me.cdid LIMIT ? ) me )', [[$ROWS => 2]], 'count() query generated expected SQL', ); is_same_sql_bind ( $most_tracks_rs->as_query, '( SELECT me.cdid, me.track_count, me.maxtr, tracks.trackid, tracks.cd, tracks.position, tracks.title, tracks.last_updated_on, tracks.last_updated_at, liner_notes.liner_id, liner_notes.notes FROM ( SELECT me.cdid, COUNT( tracks.trackid ) AS track_count, MAX( tracks.trackid ) AS maxtr FROM cd me LEFT JOIN track tracks ON tracks.cd = me.cdid WHERE ( me.cdid IS NOT NULL ) GROUP BY me.cdid ORDER BY track_count DESC, maxtr ASC LIMIT ? ) me LEFT JOIN track tracks ON tracks.cd = me.cdid LEFT JOIN liner_notes liner_notes ON liner_notes.liner_id = me.cdid WHERE ( me.cdid IS NOT NULL ) ORDER BY track_count DESC, maxtr ASC )', [[$ROWS => 2]], 'next() query generated expected SQL', ); is ($most_tracks_rs->count, 2, 'Limit works'); my ($top_cd) = $most_tracks_rs->all; is ($top_cd->id, 2, 'Correct cd fetched on top'); # 2 because of the slice(1,1) earlier $schema->is_executed_querycount( sub { is ($top_cd->get_column ('track_count'), 4, 'Track count fetched correctly'); is ($top_cd->tracks->count, 4, 'Count of prefetched tracks rs still correct'); is ($top_cd->tracks->all, 4, 'Number of prefetched track objects still correct'); is ( $top_cd->liner_notes->notes, 'Buy Whiskey!', 'Correct liner pre-fetched with top cd', ); }, 0, 'No queries executed during prefetched data access'); } { # test lifted from soulchild my $most_tracks_rs = $schema->resultset ('CD')->search ( { 'me.cdid' => { '!=' => undef }, # this is just to test WHERE 'tracks.trackid' => { '!=' => undef }, }, { join => 'tracks', prefetch => 'liner_notes', select => ['me.cdid', 'liner_notes.notes', { count => 'tracks.trackid', -as => 'tr_count' }, { max => 'tracks.trackid', -as => 'tr_maxid'} ], as => [qw/cdid notes track_count max_track_id/], order_by => [ { -desc => 'tr_count' }, { -asc => 'tr_maxid' } ], group_by => 'me.cdid', rows => 2, } ); is_same_sql_bind( $most_tracks_rs->as_query, '(SELECT me.cdid, liner_notes.notes, me.tr_count, me.tr_maxid, liner_notes.liner_id, liner_notes.notes FROM ( SELECT me.cdid, COUNT(tracks.trackid) AS tr_count, MAX(tracks.trackid) AS tr_maxid FROM cd me LEFT JOIN track tracks ON tracks.cd = me.cdid WHERE me.cdid IS NOT NULL AND tracks.trackid IS NOT NULL GROUP BY me.cdid ORDER BY tr_count DESC, tr_maxid ASC LIMIT ? ) me LEFT JOIN track tracks ON tracks.cd = me.cdid LEFT JOIN liner_notes liner_notes ON liner_notes.liner_id = me.cdid WHERE me.cdid IS NOT NULL AND tracks.trackid IS NOT NULL ORDER BY tr_count DESC, tr_maxid ASC )', [[$ROWS => 2]], 'Oddball mysql-ish group_by usage yields valid SQL', ); is ($most_tracks_rs->count, 2, 'Limit works'); my ($top_cd) = $most_tracks_rs->all; is ($top_cd->id, 2, 'Correct cd fetched on top'); # 2 because of the slice(1,1) earlier $schema->is_executed_querycount( sub { is ($top_cd->get_column ('track_count'), 4, 'Track count fetched correctly'); is ( $top_cd->liner_notes->notes, 'Buy Whiskey!', 'Correct liner pre-fetched with top cd', ); }, 0, 'No queries executed during prefetched data access'); } # make sure that distinct still works { my $rs = $schema->resultset("CD")->search({}, { prefetch => 'tags', order_by => 'cdid', distinct => 1, }); is_same_sql_bind ( $rs->as_query, '( SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track, tags.tagid, tags.cd, tags.tag FROM ( SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me GROUP BY me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track ) me LEFT JOIN tags tags ON tags.cd = me.cdid ORDER BY cdid )', [], 'Prefetch + distinct resulted in correct group_by', ); is ($rs->all, 5, 'Correct number of CD objects'); is ($rs->count, 5, 'Correct count of CDs'); } # RT 47779, test group_by as a scalar ref { my $track_rs = $schema->resultset ('Track')->search ( { 'me.cd' => { -in => \@cdids } }, { select => [ 'me.cd', { count => 'me.trackid' }, ], as => [qw/ cd track_count /], group_by => \'SUBSTR(me.cd, 1, 1)', prefetch => 'cd', }, ); is_same_sql_bind ( $track_rs->count_rs->as_query, '( SELECT COUNT( * ) FROM ( SELECT SUBSTR(me.cd, 1, 1) FROM track me JOIN cd cd ON cd.cdid = me.cd WHERE ( me.cd IN ( ?, ?, ?, ?, ? ) ) GROUP BY SUBSTR(me.cd, 1, 1) ) me )', [ map { [ { sqlt_datatype => 'integer', dbic_colname => 'me.cd' } => $_ ] } (@cdids) ], 'count() query generated expected SQL', ); } { my $cd_rs = $schema->resultset('CD')->search({}, { distinct => 1, join => [qw/ tracks /], prefetch => [qw/ artist /], }); is($cd_rs->count, 5, 'complex prefetch + non-prefetching has_many join count correct'); is($cd_rs->all, 5, 'complex prefetch + non-prefetching has_many join number of objects correct'); # make sure join tracks was thrown out is_same_sql_bind ( $cd_rs->as_query, '( SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track, artist.artistid, artist.name, artist.rank, artist.charfield FROM ( SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me JOIN artist artist ON artist.artistid = me.artist GROUP BY me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track ) me JOIN artist artist ON artist.artistid = me.artist )', [], ); # try the same as above, but add a condition so the tracks join can not be thrown away my $cd_rs2 = $cd_rs->search ({ 'tracks.title' => { '!=' => 'ugabuganoexist' } }); is($cd_rs2->count, 5, 'complex prefetch + non-prefetching restricted has_many join count correct'); is($cd_rs2->all, 5, 'complex prefetch + non-prefetching restricted has_many join number of objects correct'); # the outer group_by seems like a necessary evil, if someone can figure out how to take it away # without breaking compat - be my guest is_same_sql_bind ( $cd_rs2->as_query, '( SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track, artist.artistid, artist.name, artist.rank, artist.charfield FROM ( SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me LEFT JOIN track tracks ON tracks.cd = me.cdid JOIN artist artist ON artist.artistid = me.artist WHERE ( tracks.title != ? ) GROUP BY me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track ) me LEFT JOIN track tracks ON tracks.cd = me.cdid JOIN artist artist ON artist.artistid = me.artist WHERE ( tracks.title != ? ) GROUP BY me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track, artist.artistid, artist.name, artist.rank, artist.charfield )', [ map { [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'tracks.title' } => 'ugabuganoexist' ] } (1,2) ], ); } # make sure distinct applies to the CD part only, not to the prefetched/collapsed order_by part { my $rs = $schema->resultset('CD')->search({}, { columns => [qw( cdid title )], '+select' => [{ count => 'tags.tag' }], '+as' => ['test_count'], prefetch => ['tags'], distinct => 1, order_by => {'-desc' => 'tags.tag'}, offset => 1, rows => 3, }); is_same_sql_bind($rs->as_query, '( SELECT me.cdid, me.title, me.test_count, tags.tagid, tags.cd, tags.tag FROM ( SELECT me.cdid, me.title, COUNT( tags.tag ) AS test_count FROM cd me LEFT JOIN tags tags ON tags.cd = me.cdid GROUP BY me.cdid, me.title ORDER BY MAX( tags.tag ) DESC LIMIT ? OFFSET ? ) me LEFT JOIN tags tags ON tags.cd = me.cdid ORDER BY tags.tag DESC )', [ [$ROWS => 3], [$OFFSET => 1] ], 'Expected limited prefetch with distinct SQL', ); my $expected_hri = [ { cdid => 4, test_count => 2, title => "Generic Manufactured Singles", tags => [ { cd => 4, tag => "Shiny", tagid => 9 }, { cd => 4, tag => "Cheesy", tagid => 6 }, ]}, { cdid => 5, test_count => 2, title => "Come Be Depressed With Us", tags => [ { cd => 5, tag => "Cheesy", tagid => 7 }, { cd => 5, tag => "Blue", tagid => 4 }, ]}, { cdid => 1, test_count => 1, title => "Spoonful of bees", tags => [ { cd => 1, tag => "Blue", tagid => 1 }, ]}, ]; is_deeply ( $rs->all_hri, $expected_hri, 'HRI dump of limited prefetch with distinct as expected' ); # pre-multiplied main source also should work $rs = $schema->resultset('CD')->search_related('artist')->search_related('cds', {}, { columns => [qw( cdid title )], '+select' => [{ count => 'tags.tag' }], '+as' => ['test_count'], prefetch => ['tags'], distinct => 1, order_by => {'-desc' => 'tags.tag'}, offset => 1, rows => 3, }); is_same_sql_bind($rs->as_query, '( SELECT cds.cdid, cds.title, cds.test_count, tags.tagid, tags.cd, tags.tag FROM cd me JOIN artist artist ON artist.artistid = me.artist JOIN ( SELECT cds.cdid, cds.title, COUNT( tags.tag ) AS test_count, cds.artist FROM cd me JOIN artist artist ON artist.artistid = me.artist JOIN cd cds ON cds.artist = artist.artistid LEFT JOIN tags tags ON tags.cd = cds.cdid GROUP BY cds.cdid, cds.title, cds.artist ORDER BY MAX( tags.tag ) DESC LIMIT ? OFFSET ? ) cds ON cds.artist = artist.artistid LEFT JOIN tags tags ON tags.cd = cds.cdid ORDER BY tags.tag DESC )', [ [$ROWS => 3], [$OFFSET => 1] ], 'Expected limited prefetch with distinct SQL on premultiplied head', ); # Tag counts are multiplied by the cd->artist->cds multiplication # I would *almost* call this "expected" without wraping an as_subselect_rs { local $TODO = 'Not sure if we can stop the count/group of premultiplication abstraction leak'; is_deeply ( $rs->all_hri, $expected_hri, 'HRI dump of limited prefetch with distinct as expected on premultiplid head' ); } } done_testing; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/prefetch/multiple_hasmany.t���������������������������������������������������0000644�0001750�0001750�00000003531�14240132261�020703� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Warn; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); #( 1 -> M + M ) my $cd_rs = $schema->resultset('CD')->search( { 'me.title' => 'Forkful of bees' } ); my $pr_cd_rs = $cd_rs->search( {}, { prefetch => [qw/tracks tags/], } ); my $tracks_rs = $cd_rs->first->tracks; my $tracks_count = $tracks_rs->count; $schema->is_executed_querycount( sub { my $pcr = $pr_cd_rs; my $pr_tracks_rs; warnings_exist { $pr_tracks_rs = $pcr->first->tracks; } [], 'no warning on attempt to prefetch several same level has_many\'s (1 -> M + M)' ; is( $pr_tracks_rs->count, $tracks_count, 'equal count of prefetched relations over several same level has_many\'s (1 -> M + M)' ); is( $pr_tracks_rs->all, $tracks_count, 'equal amount of objects returned with and without prefetch over several same level has_many\'s (1 -> M + M)' ); }, 1, 'prefetch one->(has_many,has_many) ran exactly 1 query' ); #( M -> 1 -> M + M ) my $note_rs = $schema->resultset('LinerNotes')->search( { notes => 'Buy Whiskey!' } ); my $pr_note_rs = $note_rs->search( {}, { prefetch => { cd => [qw/tracks tags/] }, } ); my $tags_rs = $note_rs->first->cd->tags; my $tags_count = $tags_rs->count; $schema->is_executed_querycount( sub { my $pnr = $pr_note_rs; my $pr_tags_rs; warnings_exist { $pr_tags_rs = $pnr->first->cd->tags; } [], 'no warning on attempt to prefetch several same level has_many\'s (M -> 1 -> M + M)'; is( $pr_tags_rs->count, $tags_count, 'equal count of prefetched relations over several same level has_many\'s (M -> 1 -> M + M)' ); is( $pr_tags_rs->all, $tags_count, 'equal amount of objects with and without prefetch over several same level has_many\'s (M -> 1 -> M + M)' ); }, 1, 'prefetch one->(has_many,has_many) ran exactly 1 query' ); done_testing; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/prefetch/diamond.t������������������������������������������������������������0000644�0001750�0001750�00000005214�14240132261�016743� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Test if prefetch and join in diamond relationship fetching the correct rows use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); $schema->populate('Artwork', [ [ qw/cd_id/ ], [ 1 ], ]); $schema->populate('Artwork_to_Artist', [ [ qw/artwork_cd_id artist_id/ ], [ 1, 2 ], ]); my $ars = $schema->resultset ('Artwork'); # The relationship diagram here is: # # $ars --> artwork_to_artist # | | # | | # V V # cd ------> artist # # The current artwork belongs to a cd by artist1 # but the artwork itself is painted by artist2 # # What we try is all possible permutations of join/prefetch # combinations in both directions, while always expecting to # arrive at the specific artist at the end of each path. my $cd_paths = { 'no cd' => [], 'no cd empty' => [ '' ], 'no cd undef' => [ undef ], 'no cd href' => [ {} ], 'no cd aoh' => [ [{}] ], 'no cd complex' => [ [ [ undef ] ] ], 'cd' => ['cd'], 'cd->artist1' => [{'cd' => 'artist'}] }; my $a2a_paths = { 'no a2a' => [], 'no a2a empty ' => [ '' ], 'no a2a undef' => [ undef ], 'no a2a href' => [ {} ], 'no a2a aoh' => [ [{}] ], 'no a2a complex' => [ [ '' ] ], 'a2a' => ['artwork_to_artist'], 'a2a->artist2' => [{'artwork_to_artist' => 'artist'}] }; my %tests; foreach my $cd_path (keys %$cd_paths) { foreach my $a2a_path (keys %$a2a_paths) { $tests{sprintf "join %s, %s", $cd_path, $a2a_path} = $ars->search({}, { 'join' => [ @{ $cd_paths->{$cd_path} }, @{ $a2a_paths->{$a2a_path} }, ], 'prefetch' => [ ], }); $tests{sprintf "prefetch %s, %s", $cd_path, $a2a_path} = $ars->search({}, { 'join' => [ ], 'prefetch' => [ @{ $cd_paths->{$cd_path} }, @{ $a2a_paths->{$a2a_path} }, ], }); $tests{sprintf "join %s, prefetch %s", $cd_path, $a2a_path} = $ars->search({}, { 'join' => [ @{ $cd_paths->{$cd_path} }, ], 'prefetch' => [ @{ $a2a_paths->{$a2a_path} }, ], }); $tests{sprintf "join %s, prefetch %s", $a2a_path, $cd_path} = $ars->search({}, { 'join' => [ @{ $a2a_paths->{$a2a_path} }, ], 'prefetch' => [ @{ $cd_paths->{$cd_path} }, ], }); } } foreach my $name (keys %tests) { foreach my $artwork ($tests{$name}->all()) { is($artwork->id, 1, $name . ', correct artwork'); is($artwork->cd->artist->artistid, 1, $name . ', correct artist_id over cd'); is($artwork->artwork_to_artist->first->artist->artistid, 2, $name . ', correct artist_id over A2A'); } } done_testing; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/prefetch/double_prefetch.t����������������������������������������������������0000644�0001750�0001750�00000002352�14240132261�020462� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use warnings; use strict; use Test::More; use lib qw(t/lib); use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); # While this is a rather GIGO case, make sure it behaves as pre-103, # as it may result in hard-to-track bugs my $cds = $schema->resultset('Artist') ->search_related ('cds') ->search ({}, { prefetch => [ 'single_track', { single_track => 'cd' } ], }); is_same_sql( ${$cds->as_query}->[0], '( SELECT cds.cdid, cds.artist, cds.title, cds.year, cds.genreid, cds.single_track, single_track.trackid, single_track.cd, single_track.position, single_track.title, single_track.last_updated_on, single_track.last_updated_at, single_track_2.trackid, single_track_2.cd, single_track_2.position, single_track_2.title, single_track_2.last_updated_on, single_track_2.last_updated_at, cd.cdid, cd.artist, cd.title, cd.year, cd.genreid, cd.single_track FROM artist me JOIN cd cds ON cds.artist = me.artistid LEFT JOIN track single_track ON single_track.trackid = cds.single_track LEFT JOIN track single_track_2 ON single_track_2.trackid = cds.single_track LEFT JOIN cd cd ON cd.cdid = single_track_2.cd )', ); done_testing; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/prefetch/with_limit.t���������������������������������������������������������0000644�0001750�0001750�00000022140�14240132261�017476� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Test to ensure we get a consistent result set wether or not we use the # prefetch option in combination rows (LIMIT). use strict; use warnings; use Test::More; use Test::Exception; use lib qw(t/lib); use DBICTest ':DiffSQL'; my $ROWS = DBIx::Class::SQLMaker::ClassicExtensions->__rows_bindtype; my $schema = DBICTest->init_schema(); my $no_prefetch = $schema->resultset('Artist')->search( [ # search deliberately contrived { 'artwork.cd_id' => undef }, { 'tracks.title' => { '!=' => 'blah-blah-1234568' }} ], { rows => 3, join => { cds => [qw/artwork tracks/] }, } ); my $use_prefetch = $no_prefetch->search( {}, { select => ['me.artistid', 'me.name'], as => ['artistid', 'name'], prefetch => 'cds', order_by => { -desc => 'name' }, } ); # add an extra +select to make sure it does not throw things off # we also expect it to appear in both selectors, as we can not know # for sure which part of the query it applies to (may be order_by, # maybe something else) # # we use a reference to the same array in bind vals, because # is_deeply picks up this difference too (not sure if bug or # feature) $use_prefetch = $use_prefetch->search({}, { '+columns' => { monkeywrench => \[ 'me.artistid + ?', [ \ 'inTEger' => 1 ] ] }, }); my $bind_int_resolved = sub { [ { sqlt_datatype => 'inTEger' } => 1 ] }; my $bind_vc_resolved = sub { [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'tracks.title' } => 'blah-blah-1234568' ] }; is_same_sql_bind ( $use_prefetch->as_query, '( SELECT me.artistid + ?, me.artistid, me.name, cds.cdid, cds.artist, cds.title, cds.year, cds.genreid, cds.single_track FROM ( SELECT me.artistid + ?, me.artistid, me.name FROM artist me LEFT JOIN cd cds ON cds.artist = me.artistid LEFT JOIN cd_artwork artwork ON artwork.cd_id = cds.cdid LEFT JOIN track tracks ON tracks.cd = cds.cdid WHERE artwork.cd_id IS NULL OR tracks.title != ? GROUP BY me.artistid + ?, me.artistid, me.name ORDER BY name DESC LIMIT ? ) me LEFT JOIN cd cds ON cds.artist = me.artistid LEFT JOIN cd_artwork artwork ON artwork.cd_id = cds.cdid LEFT JOIN track tracks ON tracks.cd = cds.cdid WHERE artwork.cd_id IS NULL OR tracks.title != ? ORDER BY name DESC )', [ $bind_int_resolved->(), # outer select $bind_int_resolved->(), # inner select $bind_vc_resolved->(), # inner where $bind_int_resolved->(), # inner group_by [ $ROWS => 3 ], $bind_vc_resolved->(), # outer where ], 'Expected SQL on complex limited prefetch' ); is($no_prefetch->count, $use_prefetch->count, '$no_prefetch->count == $use_prefetch->count'); is( scalar ($no_prefetch->all), scalar ($use_prefetch->all), "Amount of returned rows is right" ); my $artist_many_cds = $schema->resultset('Artist')->search ( {}, { join => 'cds', group_by => 'me.artistid', having => \ 'count(cds.cdid) > 1', })->first; $no_prefetch = $schema->resultset('Artist')->search( { artistid => $artist_many_cds->id }, { rows => 1 } ); $use_prefetch = $no_prefetch->search ({}, { prefetch => 'cds' }); my $normal_artist = $no_prefetch->single; my $prefetch_artist = $use_prefetch->find({ name => $artist_many_cds->name }); my $prefetch2_artist = $use_prefetch->first; is( $prefetch_artist->cds->count, $normal_artist->cds->count, "Count of child rel with prefetch + rows => 1 is right (find)" ); is( $prefetch2_artist->cds->count, $normal_artist->cds->count, "Count of child rel with prefetch + rows => 1 is right (first)" ); is ( scalar ($prefetch_artist->cds->all), scalar ($normal_artist->cds->all), "Amount of child rel rows with prefetch + rows => 1 is right (find)" ); is ( scalar ($prefetch2_artist->cds->all), scalar ($normal_artist->cds->all), "Amount of child rel rows with prefetch + rows => 1 is right (first)" ); throws_ok ( sub { $use_prefetch->single }, qr/\Qsingle() can not be used on resultsets collapsing a has_many/, 'single() with multiprefetch is illegal', ); throws_ok ( sub { $use_prefetch->search( {'tracks.title' => { '!=' => 'foo' }}, { order_by => \ 'some oddball literal sql', join => { cds => 'tracks' } } )->next }, qr/Unable to programatically derive a required group_by from the supplied order_by criteria/, ); my $artist = $use_prefetch->search({'cds.title' => $artist_many_cds->cds->first->title })->next; is($artist->cds->count, 1, "count on search limiting prefetched has_many"); # try with double limit my $artist2 = $use_prefetch->search({'cds.title' => { '!=' => $artist_many_cds->cds->first->title } })->slice (0,0)->next; is($artist2->cds->count, 2, "count on search limiting prefetched has_many"); # make sure 1:1 joins do not force a subquery (no point to exercise the optimizer, if at all available) # get cd's that have any tracks and their artists my $single_prefetch_rs = $schema->resultset ('CD')->search ( { 'me.year' => 2010, 'artist.name' => 'foo' }, { prefetch => ['tracks', 'artist'], rows => 15 }, ); is_same_sql_bind ( $single_prefetch_rs->as_query, '( SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track, tracks.trackid, tracks.cd, tracks.position, tracks.title, tracks.last_updated_on, tracks.last_updated_at, artist.artistid, artist.name, artist.rank, artist.charfield FROM ( SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me JOIN artist artist ON artist.artistid = me.artist WHERE ( ( artist.name = ? AND me.year = ? ) ) LIMIT ? ) me LEFT JOIN track tracks ON tracks.cd = me.cdid JOIN artist artist ON artist.artistid = me.artist WHERE ( ( artist.name = ? AND me.year = ? ) ) )', [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'artist.name' } => 'foo' ], [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'me.year' } => 2010 ], [ $ROWS => 15 ], [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'artist.name' } => 'foo' ], [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'me.year' } => 2010 ], ], 'No grouping of non-multiplying resultsets', ); my $many_one_many_rs = $schema->resultset('CD')->search({}, { prefetch => { tracks => { lyrics => 'lyric_versions' } }, rows => 2, order_by => ['lyrics.track_id'], }); is_same_sql_bind( $many_one_many_rs->as_query, '( SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track, tracks.trackid, tracks.cd, tracks.position, tracks.title, tracks.last_updated_on, tracks.last_updated_at, lyrics.lyric_id, lyrics.track_id, lyric_versions.id, lyric_versions.lyric_id, lyric_versions.text FROM ( SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me LEFT JOIN track tracks ON tracks.cd = me.cdid LEFT JOIN lyrics lyrics ON lyrics.track_id = tracks.trackid GROUP BY me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track ORDER BY MIN(lyrics.track_id) LIMIT ? ) me LEFT JOIN track tracks ON tracks.cd = me.cdid LEFT JOIN lyrics lyrics ON lyrics.track_id = tracks.trackid LEFT JOIN lyric_versions lyric_versions ON lyric_versions.lyric_id = lyrics.lyric_id ORDER BY lyrics.track_id )', [ [ { sqlt_datatype => 'integer' } => 2 ] ], 'Correct SQL on indirectly multiplied orderer', ); my $cond_on_multi_ord_by_single = $schema->resultset('CD')->search( { 'tracks.position' => { '!=', 1 }, }, { prefetch => [qw( tracks artist )], order_by => 'artist.name', rows => 1, }, ); is_same_sql_bind( $cond_on_multi_ord_by_single->as_query, '( SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track, tracks.trackid, tracks.cd, tracks.position, tracks.title, tracks.last_updated_on, tracks.last_updated_at, artist.artistid, artist.name, artist.rank, artist.charfield FROM ( SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me LEFT JOIN track tracks ON tracks.cd = me.cdid JOIN artist artist ON artist.artistid = me.artist WHERE tracks.position != ? GROUP BY me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track, artist.name ORDER BY artist.name LIMIT ? ) me LEFT JOIN track tracks ON tracks.cd = me.cdid JOIN artist artist ON artist.artistid = me.artist WHERE tracks.position != ? ORDER BY artist.name )', [ [ { dbic_colname => "tracks.position", sqlt_datatype => "int" } => 1 ], [ { sqlt_datatype => "integer" } => 1 ], [ { dbic_colname => "tracks.position", sqlt_datatype => "int" } => 1 ], ], 'Correct SQl on prefetch with limit of restricting multi ordered by a single' ); done_testing; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/prefetch/manual.t�������������������������������������������������������������0000644�0001750�0001750�00000034631�14240132261�016612� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Deep; use Test::Warn; use Test::Exception; use lib qw(t/lib); use DBICTest; delete $ENV{DBIC_COLUMNS_INCLUDE_FILTER_RELS}; my $schema = DBICTest->init_schema(no_populate => 1); $schema->resultset('Artist')->create({ name => 'JMJ', cds => [{ title => 'Magnetic Fields', year => 1981, genre => { name => 'electro' }, tracks => [ { title => 'm1' }, { title => 'm2' }, { title => 'm3' }, { title => 'm4' }, ], } ] }); $schema->resultset('CD')->create({ title => 'Equinoxe', year => 1978, artist => { name => 'JMJ' }, genre => { name => 'electro' }, tracks => [ { title => 'e1' }, { title => 'e2' }, { title => 'e3' }, ], single_track => { title => 'o1', cd => { title => 'Oxygene', year => 1976, artist => { name => 'JMJ' }, tracks => [ { title => 'o2', position => 2}, # the position should not be here, bug in MC ], }, }, }); my $rs = $schema->resultset ('CD')->search ({}, { join => [ 'tracks', { single_track => { cd => { artist => { cds => 'tracks' } } } } ], collapse => 1, columns => [ { 'year' => 'me.year' }, # non-unique { 'genreid' => 'me.genreid' }, # nullable { 'tracks.title' => 'tracks.title' }, # non-unique (no me.id) { 'single_track.cd.artist.cds.cdid' => 'cds.cdid' }, # to give uniquiness to ...tracks.title below { 'single_track.cd.artist.artistid' => 'artist.artistid' }, # uniqufies entire parental chain { 'single_track.cd.artist.cds.year' => 'cds.year' }, # non-unique { 'single_track.cd.artist.cds.genreid' => 'cds.genreid' }, # nullable { 'single_track.cd.artist.cds.tracks.title' => 'tracks_2.title' }, # unique when combined with ...cds.cdid above { 'latest_cd' => \ "(SELECT MAX(year) FROM cd)" }, # random function { 'title' => 'me.title' }, # uniquiness for me { 'artist' => 'me.artist' }, # uniquiness for me ], order_by => [{ -desc => 'cds.year' }, { -desc => 'me.title'}, 'tracks.title', 'tracks_2.title' ], }); my $hri_rs = $rs->search({}, { result_class => 'DBIx::Class::ResultClass::HashRefInflator' }); cmp_deeply ( [$hri_rs->all], [ { artist => 1, genreid => 1, latest_cd => 1981, title => "Equinoxe", year => 1978, single_track => { cd => { artist => { artistid => 1, cds => [ { cdid => 1, genreid => 1, year => 1981, tracks => [ { title => "m1" }, { title => "m2" }, { title => "m3" }, { title => "m4" }, ]}, { cdid => 3, genreid => 1, year => 1978, tracks => [ { title => "e1" }, { title => "e2" }, { title => "e3" }, ]}, { cdid => 2, genreid => undef, year => 1976, tracks => [ { title => "o1" }, { title => "o2" }, ]}, ]}, }, }, tracks => [ { title => "e1" }, { title => "e2" }, { title => "e3" }, ], }, { artist => 1, genreid => undef, latest_cd => 1981, title => "Oxygene", year => 1976, single_track => undef, tracks => [ { title => "o1" }, { title => "o2" }, ], }, { artist => 1, genreid => 1, latest_cd => 1981, title => "Magnetic Fields", year => 1981, single_track => undef, tracks => [ { title => "m1" }, { title => "m2" }, { title => "m3" }, { title => "m4" }, ], }, ], 'W00T, manual prefetch with collapse works' ); lives_ok { my $dummy = $rs; warnings_exist { ############## ### This is a bunch of workarounds for deprecated behavior - delete entire block when fixed my $cd_obj = ($rs->all)[0]->single_track->cd; my $art_obj = $cd_obj->artist; my $empty_single_columns = { cd => undef }; my $empty_single_inflated_columns = { cd => $cd_obj }; my $empty_cd_columns = { artist => $art_obj->artistid }; my $empty_cd_inflated_columns = { artist => $art_obj }; { local $TODO = "Returning prefetched 'filter' rels as part of get_columns/get_inflated_columns is deprecated"; is_deeply($_, {}) for ( $empty_single_columns, $empty_single_inflated_columns, $empty_cd_columns, $empty_cd_inflated_columns ); } ############## ### this tests the standard root -> single -> filter ->filter my ($row) = $rs->all; # don't trigger order warnings is_deeply( { $row->single_track->get_columns }, $empty_single_columns, "No unexpected columns available on intermediate 'single' rel with a chained 'filter' prefetch", ); is_deeply( { $row->single_track->get_inflated_columns }, $empty_single_inflated_columns, "No unexpected inflated columns available on intermediate 'single' rel with a chained 'filter' prefetch", ); is_deeply( { $row->single_track->cd->get_columns }, $empty_cd_columns, "No unexpected columns available on intermediate 'single' rel with 2x chained 'filter' prefetch", ); is_deeply( { $row->single_track->cd->get_inflated_columns }, $empty_cd_inflated_columns, "No unexpected inflated columns available on intermediate 'single' rel with 2x chained 'filter' prefetch", ); ### also try a different arangement root -> single -> single ->filter ($row) = $rs->result_source->resultset->search({ 'artist.artistid' => 1 }, { join => { single_track => { disc => { artist => 'cds' } } }, '+columns' => { 'single_track.disc.artist.artistid' => 'artist.artistid', 'single_track.disc.artist.cds.cdid' => 'cds.cdid', }, collapse => 1, })->all; is_deeply( { $row->single_track->get_columns }, {}, "No unexpected columns available on intermediate 'single' rel with a chained 'single' prefetch", ); is_deeply( { $row->single_track->get_inflated_columns }, {}, "No unexpected inflated columns available on intermediate 'single' rel with a chained 'single' prefetch", ); is_deeply( { $row->single_track->disc->get_columns }, $empty_cd_columns, "No unexpected columns available on intermediate 'single' rel with chained 'single' and chained 'filter' prefetch", ); is_deeply( { $row->single_track->disc->get_inflated_columns }, $empty_cd_inflated_columns, "No unexpected inflated columns available on intermediate 'single' rel with chained 'single' and chained 'filter' prefetch", ); } [ qr/\QReturning primary keys of prefetched 'filter' rels as part of get_columns()/, qr/\QUnable to deflate 'filter'-type relationship 'cd' (related object primary key not retrieved)/, qr/\QReturning prefetched 'filter' rels as part of get_inflated_columns()/, qr/\QReturning primary keys of prefetched 'filter' rels as part of get_columns()/, qr/\QReturning prefetched 'filter' rels as part of get_inflated_columns()/, qr/\QReturning primary keys of prefetched 'filter' rels as part of get_columns()/, qr/\QReturning prefetched 'filter' rels as part of get_inflated_columns()/, ], 'expected_warnings' } 'traversing prefetch chain with empty intermediates works'; # multi-has_many with underdefined root, with rather random order $rs = $schema->resultset ('CD')->search ({}, { join => [ 'tracks', { single_track => { cd => { artist => { cds => 'tracks' } } } } ], collapse => 1, columns => [ { 'single_track.trackid' => 'single_track.trackid' }, # definitive link to root from 1:1:1:1:M:M chain { 'year' => 'me.year' }, # non-unique { 'tracks.cd' => 'tracks.cd' }, # \ together both uniqueness for second multirel { 'tracks.title' => 'tracks.title' }, # / and definitive link back to root { 'single_track.cd.artist.cds.cdid' => 'cds.cdid' }, # to give uniquiness to ...tracks.title below { 'single_track.cd.artist.cds.year' => 'cds.year' }, # non-unique { 'single_track.cd.artist.artistid' => 'artist.artistid' }, # uniqufies entire parental chain { 'single_track.cd.artist.cds.genreid' => 'cds.genreid' }, # nullable { 'single_track.cd.artist.cds.tracks.title' => 'tracks_2.title' }, # unique when combined with ...cds.cdid above ], }); for (1..3) { $rs->create({ artist => 1, year => 1977, title => "fuzzy_$_" }); } my $rs_random = $rs->search({}, { order_by => \ 'RANDOM()' }); is ($rs_random->count, 6, 'row count matches'); if ($ENV{TEST_VERBOSE}) { my @lines = ( [ "What are we actually trying to collapse (Select/As, tests below will see a *DIFFERENT* random order):" ], [ map { my $s = $_; $s =~ s/single_track\./sngl_tr./; $s } @{$rs_random->{_attrs}{select} } ], $rs_random->{_attrs}{as}, [ "-" x 159 ], $rs_random->cursor->all, ); diag join ' # ', map { sprintf '% 15s', (defined $_ ? $_ : 'NULL') } @$_ for @lines; } $schema->is_executed_querycount( sub { for my $use_next (0, 1) { my @random_cds; my $rs_r = $rs_random; if ($use_next) { warnings_exist { while (my $o = $rs_r->next) { push @random_cds, $o; } } qr/performed an eager cursor slurp underneath/, 'Warned on auto-eager cursor'; } else { @random_cds = $rs_r->all; } is (@random_cds, 6, 'object count matches'); for my $cd (@random_cds) { if ($cd->year == 1977) { is( scalar $cd->tracks, 0, 'no tracks on 1977 cd' ); is( $cd->single_track, undef, 'no single_track on 1977 cd' ); } elsif ($cd->year == 1976) { is( scalar $cd->tracks, 2, 'Two tracks on 1976 cd' ); like( $_->title, qr/^o\d/, "correct title" ) for $cd->tracks; is( $cd->single_track, undef, 'no single_track on 1976 cd' ); } elsif ($cd->year == 1981) { is( scalar $cd->tracks, 4, 'Four tracks on 1981 cd' ); like( $_->title, qr/^m\d/, "correct title" ) for $cd->tracks; is( $cd->single_track, undef, 'no single_track on 1981 cd' ); } elsif ($cd->year == 1978) { is( scalar $cd->tracks, 3, 'Three tracks on 1978 cd' ); like( $_->title, qr/^e\d/, "correct title" ) for $cd->tracks; ok( defined $cd->single_track, 'single track prefetched on 1987 cd' ); is( $cd->single_track->cd->artist->id, 1, 'Single_track->cd->artist prefetched on 1978 cd' ); is( scalar $cd->single_track->cd->artist->cds, 6, '6 cds prefetched on artist' ); } } } }, 2, "Only two queries for two prefetch calls total"); # can't cmp_deeply a random set - need *some* order my $ord_rs = $rs->search({}, { order_by => [ 'tracks_2.title', 'tracks.title', 'cds.cdid', \ 'RANDOM()' ], result_class => 'DBIx::Class::ResultClass::HashRefInflator', }); my @hris_all = sort { $a->{year} cmp $b->{year} } $ord_rs->all; is (@hris_all, 6, 'hri count matches' ); my $iter_rs = $rs->search({}, { order_by => [ 'me.year', 'me.cdid', 'tracks_2.title', 'tracks.title', 'cds.cdid', \ 'RANDOM()' ], result_class => 'DBIx::Class::ResultClass::HashRefInflator', }); my @hris_iter; while (my $r = $iter_rs->next) { push @hris_iter, $r; } cmp_deeply( \@hris_iter, \@hris_all, 'Iteration works correctly', ); my @hri_contents = ( { year => 1976, single_track => undef, tracks => [ { cd => 2, title => "o1" }, { cd => 2, title => "o2" }, ]}, { year => 1977, single_track => undef, tracks => [] }, { year => 1977, single_track => undef, tracks => [] }, { year => 1977, single_track => undef, tracks => [] }, { year => 1978, single_track => { trackid => 6, cd => { artist => { artistid => 1, cds => [ { cdid => 4, genreid => undef, year => 1977, tracks => [] }, { cdid => 5, genreid => undef, year => 1977, tracks => [] }, { cdid => 6, genreid => undef, year => 1977, tracks => [] }, { cdid => 3, genreid => 1, year => 1978, tracks => [ { title => "e1" }, { title => "e2" }, { title => "e3" }, ]}, { cdid => 1, genreid => 1, year => 1981, tracks => [ { title => "m1" }, { title => "m2" }, { title => "m3" }, { title => "m4" }, ]}, { cdid => 2, genreid => undef, year => 1976, tracks => [ { title => "o1" }, { title => "o2" }, ]}, ] }, }, }, tracks => [ { cd => 3, title => "e1" }, { cd => 3, title => "e2" }, { cd => 3, title => "e3" }, ], }, { year => 1981, single_track => undef, tracks => [ { cd => 1, title => "m1" }, { cd => 1, title => "m2" }, { cd => 1, title => "m3" }, { cd => 1, title => "m4" }, ]}, ); cmp_deeply (\@hris_all, \@hri_contents, 'W00T, multi-has_many manual underdefined root prefetch with collapse works'); cmp_deeply( $rs->search({}, { order_by => [ 'me.year', 'tracks_2.title', 'tracks.title', 'cds.cdid', { -desc => 'name' } ], rows => 4, offset => 2, })->all_hri, [ @hri_contents[2..5] ], 'multi-has_many prefetch with limit works too', ); # left-ordered real iterator $rs = $rs->search({}, { order_by => [ 'me.year', 'me.cdid', \ 'RANDOM()' ] }); my @objs_iter; while (my $r = $rs->next) { push @objs_iter, $r; } for my $i (0 .. $#objs_iter) { is ($objs_iter[$i]->year, $hris_all[$i]{year}, "Expected year on object $i" ); is ( (defined $objs_iter[$i]->single_track), (defined $hris_all[$i]{single_track}), "Expected single relation on object $i" ); } $rs = $schema->resultset('Artist')->search({}, { join => 'cds', columns => ['cds.title', 'cds.artist' ], collapse => 1, order_by => [qw( me.name cds.title )], }); $rs->create({ name => "${_}_cdless" }) for (qw( Z A )); cmp_deeply ( $rs->all_hri, [ { cds => [] }, { cds => [ { artist => 1, title => "Equinoxe" }, { artist => 1, title => "Magnetic Fields" }, { artist => 1, title => "Oxygene" }, { artist => 1, title => "fuzzy_1" }, { artist => 1, title => "fuzzy_2" }, { artist => 1, title => "fuzzy_3" }, ] }, { cds => [] }, ], 'Expected HRI of 1:M with empty root selection', ); done_testing; �������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/prefetch/empty_cache.t��������������������������������������������������������0000644�0001750�0001750�00000001743�14240132261�017614� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); my $queries; my $debugcb = sub { $queries++; }; my $orig_debug = $schema->storage->debug; { $queries = 0; $schema->storage->debugcb($debugcb); $schema->storage->debug(1); my $cds_rs = $schema->resultset('CD') ->search(\'0 = 1', { prefetch => 'tracks', cache => 1 }); my @cds = $cds_rs->all; is( $queries, 1, '->all on empty original resultset hit db' ); is_deeply( $cds_rs->get_cache, [], 'empty cache on original resultset' ); is( 0+@cds, 0, 'empty original resultset' ); my $tracks_rs = $cds_rs->related_resultset('tracks'); is_deeply( $tracks_rs->get_cache, [], 'empty cache on related resultset' ); my @tracks = $tracks_rs->all; is( $queries, 1, "->all on empty related resultset didn't hit db" ); is( 0+@tracks, 0, 'empty related resultset' ); $schema->storage->debugcb(undef); $schema->storage->debug($orig_debug); } done_testing; �����������������������������DBIx-Class-0.082843/t/prefetch/refined_search_on_relation.t�����������������������������������������0000644�0001750�0001750�00000001523�14240132261�022661� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); my $art = $schema->resultset('Artist')->find( { 'me.artistid' => 1 }, { prefetch => 'cds', order_by => { -desc => 'cds.year' } } ); is ( $art->cds->search({ year => 1999 })->next->year, 1999, 'Found expected CD with year 1999 after refined search', ); is ( $art->cds->count({ year => 1999 }), 1, 'Correct refined count', ); # this still should emit no queries: $schema->is_executed_querycount( sub { my $cds = $art->cds; is ( $cds->count, 3, 'Correct prefetched count', ); my @years = qw(2001 1999 1997); while (my $cd = $cds->next) { is ( $cd->year, (shift @years), 'Correct prefetched cd year', ); } }, 0, 'No queries on prefetched operations'); done_testing; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/prefetch/join_type.t����������������������������������������������������������0000644�0001750�0001750�00000002761�14240132261�017334� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use warnings; use strict; use Test::More; use lib qw(t/lib); use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); # a regular belongs_to prefetch my $cds = $schema->resultset('CD')->search ({}, { prefetch => 'artist' } ); my $nulls = { hashref => {}, arrayref => [], undef => undef, }; # make sure null-prefetches do not screw with the final sql: for my $type (keys %$nulls) { is_same_sql_bind ( $cds->search({}, { prefetch => { artist => $nulls->{$type} } })->as_query, '( SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track, artist.artistid, artist.name, artist.rank, artist.charfield FROM cd me JOIN artist artist ON artist.artistid = me.artist )', [], "same sql with null $type prefetch" ); } # make sure left join is carried only starting from the first has_many is_same_sql_bind ( $cds->search({}, { prefetch => { artist => { cds => 'artist' } } })->as_query, '( SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track, artist.artistid, artist.name, artist.rank, artist.charfield, cds.cdid, cds.artist, cds.title, cds.year, cds.genreid, cds.single_track, artist_2.artistid, artist_2.name, artist_2.rank, artist_2.charfield FROM cd me JOIN artist artist ON artist.artistid = me.artist LEFT JOIN cd cds ON cds.artist = artist.artistid LEFT JOIN artist artist_2 ON artist_2.artistid = cds.artist )', [], ); done_testing; ���������������DBIx-Class-0.082843/t/prefetch/standard.t�����������������������������������������������������������0000644�0001750�0001750�00000022157�14240132261�017135� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); my $rs; $schema->is_executed_querycount( sub { my $search = { 'artist.name' => 'Caterwauler McCrae' }; my $attr = { prefetch => [ qw/artist liner_notes/ ], order_by => 'me.cdid' }; $rs = $schema->resultset("CD")->search($search, $attr); my @cd = $rs->all; is($cd[0]->title, 'Spoonful of bees', 'First record returned ok'); ok(!defined $cd[0]->liner_notes, 'No prefetch for NULL LEFT join'); is($cd[1]->liner_notes->notes, 'Buy Whiskey!', 'Prefetch for present LEFT JOIN'); is(ref $cd[1]->liner_notes, 'DBICTest::LinerNotes', 'Prefetch returns correct class'); is($cd[2]->artist->name, 'Caterwauler McCrae', 'Prefetch on parent object ok'); }, 1, 'prefetch ran only 1 select statement'); # test for partial prefetch via columns attr my $cd; $schema->is_executed_querycount( sub { $cd = $schema->resultset('CD')->find(1, { columns => [qw/title artist artist.name/], join => { 'artist' => {} } } ); is( $cd->artist->name, 'Caterwauler McCrae', 'single related column prefetched'); }, 1, 'manual prefetch ran only 1 select statement'); # start test for nested prefetch SELECT count my $tag; $schema->is_executed_querycount( sub { $rs = $schema->resultset('Tag')->search( { 'me.tagid' => 1 }, { prefetch => { cd => 'artist' } } ); $tag = $rs->first; is( $tag->cd->title, 'Spoonful of bees', 'step 1 ok for nested prefetch' ); is( $tag->cd->artist->name, 'Caterwauler McCrae', 'step 2 ok for nested prefetch'); }, 1, 'nested prefetch ran exactly 1 select statement'); $schema->is_executed_querycount( sub { is($tag->search_related('cd')->search_related('artist')->first->name, 'Caterwauler McCrae', 'chained belongs_to->belongs_to search_related ok'); }, 0, 'chained search_related after belongs_to->belongs_to prefetch ran no queries'); $schema->is_executed_querycount( sub { $cd = $schema->resultset('CD')->find(1, { prefetch => 'artist' }); is($cd->artist->name, 'Caterwauler McCrae', 'artist prefetched correctly on find'); }, 1, 'find with prefetch ran exactly 1 select statement'); $schema->is_executed_querycount( sub { $cd = $schema->resultset('CD')->find(1, { prefetch => { cd_to_producer => 'producer' }, order_by => 'producer.producerid' }); is($cd->producers->first->name, 'Matt S Trout', 'many_to_many accessor ok'); }, 1, 'many_to_many accessor with nested prefetch ran exactly 1 query'); $schema->is_executed_querycount( sub { my $producers = $cd->search_related('cd_to_producer')->search_related('producer'); is($producers->first->name, 'Matt S Trout', 'chained many_to_many search_related ok'); }, 0, 'chained search_related after many_to_many prefetch ran no queries'); $rs = $schema->resultset('Tag')->search( {}, { join => { cd => 'artist' }, prefetch => { cd => 'artist' } } ); cmp_ok( $rs->count, '>=', 0, 'nested prefetch does not duplicate joins' ); my ($artist) = $schema->resultset("Artist")->search({ 'cds.year' => 2001 }, { order_by => 'artistid DESC', join => 'cds' }); is($artist->name, 'Random Boy Band', "Join search by object ok"); my @cds = $schema->resultset("CD")->search({ 'liner_notes.notes' => 'Buy Merch!' }, { join => 'liner_notes' }); cmp_ok(scalar @cds, '==', 1, "Single CD retrieved via might_have"); is($cds[0]->title, "Generic Manufactured Singles", "Correct CD retrieved"); my @artists = $schema->resultset("Artist")->search({ 'tags.tag' => 'Shiny' }, { join => { 'cds' => 'tags' } }); cmp_ok( @artists, '==', 2, "two-join search ok" ); $rs = $schema->resultset("CD")->search( {}, { group_by => [qw/ title me.cdid /] } ); cmp_ok( $rs->count, '==', 5, "count() ok after group_by on main pk" ); cmp_ok( scalar $rs->all, '==', 5, "all() returns same count as count() after group_by on main pk" ); $rs = $schema->resultset("CD")->search( {}, { join => [qw/ artist /], group_by => [qw/ artist.name /] } ); cmp_ok( $rs->count, '==', 3, "count() ok after group_by on related column" ); $rs = $schema->resultset("Artist")->search({}, { join => [qw/ cds /], group_by => [qw/ me.name /], having => \[ 'MAX(cds.cdid) < ?', [ \'int' => 5 ] ], }); cmp_ok( $rs->all, '==', 2, "results ok after group_by on related column with a having" ); $rs = $rs->search( undef, { having =>{ 'count(*)'=> \'> 2' }}); cmp_ok( $rs->all, '==', 1, "count() ok after group_by on related column with a having" ); $rs = $schema->resultset("Artist")->search( { 'cds.title' => 'Spoonful of bees', 'cds_2.title' => 'Forkful of bees' }, { join => [ 'cds', 'cds' ] }); cmp_ok($rs->count, '==', 1, "single artist returned from multi-join"); is($rs->next->name, 'Caterwauler McCrae', "Correct artist returned"); $cd = $schema->resultset('Artist')->first->create_related('cds', { title => 'Unproduced Single', year => 2007 }); my $left_join = $schema->resultset('CD')->search( { 'me.cdid' => $cd->cdid }, { prefetch => { cd_to_producer => 'producer' } } ); cmp_ok($left_join, '==', 1, 'prefetch with no join record present'); my $tree_like; $schema->is_executed_querycount( sub { $tree_like = $schema->resultset('TreeLike')->find(5, { join => { parent => { parent => 'parent' } }, prefetch => { parent => { parent => 'parent' } } }); is($tree_like->name, 'quux', 'Bottom of tree ok'); $tree_like = $tree_like->parent; is($tree_like->name, 'baz', 'First level up ok'); $tree_like = $tree_like->parent; is($tree_like->name, 'bar', 'Second level up ok'); $tree_like = $tree_like->parent; is($tree_like->name, 'foo', 'Third level up ok'); }, 1, 'Only one query run'); $tree_like = $schema->resultset('TreeLike')->search({'me.id' => 2}); $tree_like = $tree_like->search_related('children')->search_related('children')->search_related('children')->first; is($tree_like->name, 'quux', 'Tree search_related ok'); $tree_like = $schema->resultset('TreeLike')->search_related('children', { 'children.id' => 3, 'children_2.id' => 4 }, { prefetch => { children => 'children' } } )->first; is( $tree_like->children->first->children->first->name, 'quux', 'Tree search_related with prefetch ok'); $tree_like = $schema->resultset('TreeLike')->search( { 'children.id' => 3, 'children_2.id' => 6 }, { join => [qw/children children children/] } )->search_related('children', { 'children_4.id' => 7 }, { prefetch => 'children' } )->first->children->first; is( $tree_like->name, 'fong', 'Tree with multiple has_many joins ok'); $rs = $schema->resultset('Artist'); $rs->create({ artistid => 4, name => 'Unknown singer-songwriter' }); $rs->create({ artistid => 5, name => 'Emo 4ever' }); @artists = $rs->search(undef, { prefetch => 'cds', order_by => 'artistid' }); is(scalar @artists, 5, 'has_many prefetch with adjacent empty rows ok'); lives_ok { @artists = $rs->search(undef, { join => ['cds'], prefetch => [], rows => 20, }); } 'join and empty prefetch ok'; # ------------- # # Tests for multilevel has_many prefetch # artist resultsets - with and without prefetch my $art_rs = $schema->resultset('Artist'); my $art_rs_pr = $art_rs->search( {}, { join => [ { cds => ['tracks'] } ], prefetch => [ { cds => ['tracks'] } ], cache => 1 # last test needs this } ); # This test does the same operation twice - once on a # set of items fetched from the db with no prefetch of has_many rels # The second prefetches 2 levels of has_many # We check things are the same by comparing the name or title # we build everything into a hash structure and compare the one # from each rs to see what differs sub make_hash_struc { my $rs = shift; my $struc = {}; # all of these ought to work, but do not for some reason # a noop cloning search() pollution? #foreach my $art ( $rs->search({}, { order_by => 'me.artistid' })->all ) { #foreach my $art ( $rs->search({}, {})->all ) { #foreach my $art ( $rs->search()->all ) { foreach my $art ( $rs->all ) { foreach my $cd ( $art->cds ) { foreach my $track ( $cd->tracks ) { $struc->{ $art->name }{ $cd->title }{ $track->title }++; } } } return $struc; } my $prefetch_result; $schema->is_executed_querycount( sub { $prefetch_result = make_hash_struc($art_rs_pr); }, 1, 'nested prefetch across has_many->has_many ran exactly 1 query'); my $nonpre_result = make_hash_struc($art_rs); is_deeply( $prefetch_result, $nonpre_result, 'Compare 2 level prefetch result to non-prefetch result' ); $schema->is_executed_querycount( sub { is_deeply( [ sort map { $_->title } $art_rs_pr->search_related('cds')->search_related('tracks')->all ], [ 'Apiary', 'Beehind You', 'Boring Name', 'Boring Song', 'Fowlin', 'Howlin', 'No More Ideas', 'Sad', 'Sticky Honey', 'Stripy', 'Stung with Success', 'Suicidal', 'The Bees Knees', 'Under The Weather', 'Yowlin' ], 'chained has_many->has_many search_related ok' ); }, 0, 'chained search_related after has_many->has_many prefetch ran no queries'); done_testing; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/prefetch/multiple_hasmany_torture.t�������������������������������������������0000644�0001750�0001750�00000014074�14240132261�022473� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Deep; use Test::Exception; use lib qw(t/lib); use DBICTest; use DBIx::Class::_Util 'sigwarn_silencer'; my $schema = DBICTest->init_schema(); $schema->resultset('Artist')->create( { name => 'mo', rank => '1337', cds => [ { title => 'Song of a Foo', year => '1999', tracks => [ { title => 'Foo Me Baby One More Time' }, { title => 'Foo Me Baby One More Time II' }, { title => 'Foo Me Baby One More Time III' }, { title => 'Foo Me Baby One More Time IV', cd_single => { artist => 1, title => 'MO! Single', year => 2021, tracks => [ { title => 'singled out' }, { title => 'still alone' }, ] } } ], cd_to_producer => [ { producer => { name => 'riba' } }, { producer => { name => 'sushi' } }, ] }, { title => 'Song of a Foo II', year => '2002', tracks => [ { title => 'Quit Playing Games With My Heart' }, { title => 'Bar Foo' }, { title => 'Foo Bar', cd_single => { artist => 2, title => 'MO! Single', year => 2020, tracks => [ { title => 'singled out' }, { title => 'still alone' }, ] } } ], cd_to_producer => [ { producer => { name => 'riba' } }, { producer => { name => 'sushi' } }, ], } ], artwork_to_artist => [ { artwork => { cd_id => 1 } }, { artwork => { cd_id => 2 } } ] } ); my $artist_with_extras = { artistid => 4, charfield => undef, name => 'mo', rank => 1337, artwork_to_artist => [ { artist_id => 4, artwork_cd_id => 1, artwork => { cd_id => 1 } }, { artist_id => 4, artwork_cd_id => 2, artwork => { cd_id => 2 } }, ], cds => [ { artist => 4, cdid => 6, title => 'Song of a Foo', genreid => undef, year => 1999, single_track => undef, cd_to_producer => [ { attribute => undef, cd => 6, producer => { name => 'riba', producerid => 4 } }, { attribute => undef, cd => 6, producer => { name => 'sushi', producerid => 5 } }, ], tracks => [ { cd => 6, position => 1, trackid => 19, title => 'Foo Me Baby One More Time', last_updated_on => undef, last_updated_at => undef, cd_single => undef }, { cd => 6, position => 2, trackid => 20, title => 'Foo Me Baby One More Time II', last_updated_on => undef, last_updated_at => undef, cd_single => undef }, { cd => 6, position => 3, trackid => 21, title => 'Foo Me Baby One More Time III', last_updated_on => undef, last_updated_at => undef, cd_single => undef }, { cd => 6, position => 4, trackid => 22, title => 'Foo Me Baby One More Time IV', last_updated_on => undef, last_updated_at => undef, cd_single => { single_track => 22, artist => 1, cdid => 7, title => 'MO! Single', genreid => undef, year => 2021, tracks => [ { cd => 7, position => 1, title => 'singled out', trackid => '23', last_updated_at => undef, last_updated_on => undef }, { cd => 7, position => 2, title => 'still alone', trackid => '24', last_updated_at => undef, last_updated_on => undef }, ], } } ], }, { artist => 4, cdid => 8, title => 'Song of a Foo II', genreid => undef, year => 2002, single_track => undef, cd_to_producer => [ { attribute => undef, cd => 8, producer => { name => 'riba', producerid => 4 } }, { attribute => undef, cd => 8, producer => { name => 'sushi', producerid => 5 } }, ], tracks => [ { cd => 8, position => 1, trackid => 25, title => 'Quit Playing Games With My Heart', last_updated_on => undef, last_updated_at => undef, cd_single => undef }, { cd => 8, position => 2, trackid => 26, title => 'Bar Foo', last_updated_on => undef, last_updated_at => undef, cd_single => undef }, { cd => 8, position => 3, trackid => 27, title => 'Foo Bar', last_updated_on => undef, last_updated_at => undef, cd_single => { single_track => 27, artist => 2, cdid => 9, title => 'MO! Single', genreid => undef, year => 2020, tracks => [ { cd => 9, position => 1, title => 'singled out', trackid => '28', last_updated_at => undef, last_updated_on => undef }, { cd => 9, position => 2, title => 'still alone', trackid => '29', last_updated_at => undef, last_updated_on => undef }, ], } } ], } ], }; my $art_rs = $schema->resultset('Artist')->search({ 'me.artistid' => 4 }); my $art_rs_prefetch = $art_rs->search({}, { order_by => [qw/tracks.position tracks.trackid producer.producerid tracks_2.trackid artwork.cd_id/], result_class => 'DBIx::Class::ResultClass::HashRefInflator', prefetch => [ { cds => [ { tracks => { cd_single => 'tracks' } }, { cd_to_producer => 'producer' } ] }, { artwork_to_artist => 'artwork' } ], }); cmp_deeply( $art_rs_prefetch->next, $artist_with_extras ); for my $order ( [ [qw( cds.cdid tracks.position )] ], [ [qw( artistid tracks.cd tracks.position )], 'we need to proxy the knowledge from the collapser that tracks.cd is a stable sorter for CDs' ], ) { my $cds_rs_prefetch = $art_rs->related_resultset('cds')->search({}, { order_by => [ $order->[0], qw(producer.name tracks_2.position) ], result_class => 'DBIx::Class::ResultClass::HashRefInflator', prefetch => [ { tracks => { cd_single => 'tracks' } }, { cd_to_producer => 'producer' }, ], }); local $SIG{__WARN__} = sigwarn_silencer(qr/Unable to properly collapse has_many results/) if $order->[1]; cmp_deeply( $cds_rs_prefetch->next, $artist_with_extras->{cds}[0], '1st cd structure matches' ); cmp_deeply( $cds_rs_prefetch->next, $artist_with_extras->{cds}[1], '2nd cd structure matches' ); # INTERNALS! (a.k.a boars, gore and whores) DO NOT CARGOCULT!!! local $TODO = $order->[1] if $order->[1]; ok( $cds_rs_prefetch->_resolved_attrs->{_ordered_for_collapse}, 'ordered_for_collapse detected properly' ); } done_testing; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/prefetch/false_colvalues.t����������������������������������������������������0000644�0001750�0001750�00000001513�14240132261�020475� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use warnings; use strict; use Test::More; use Test::Deep; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema( no_populate => 1 ); $schema->resultset('CD')->create({ cdid => 0, title => '', year => 0, genreid => 0, single_track => 0, artist => { artistid => 0, name => '', rank => 0, charfield => 0, }, }); $schema->is_executed_querycount( sub { my $cd = $schema->resultset('CD')->search( {}, { prefetch => 'artist' })->next; cmp_deeply { $cd->get_columns }, { artist => 0, cdid => 0, genreid => 0, single_track => 0, title => '', year => 0 }, 'Expected CD columns present', ; cmp_deeply { $cd->artist->get_columns }, { artistid => 0, charfield => 0, name => "", rank => 0 }, 'Expected Artist columns present', ; }, 1, 'Only one query fired - prefetch worked' ); done_testing; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/inflate/����������������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�015004� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/inflate/hri_torture.t���������������������������������������������������������0000644�0001750�0001750�00000020275�14240132261�017524� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Deep; use lib qw(t/lib); use DBICTest; # More tests like this in t/prefetch/manual.t my $schema = DBICTest->init_schema(no_populate => 1, quote_names => 1); $schema->resultset('Artist')->create({ name => 'JMJ', cds => [{ title => 'Magnetic Fields', year => 1981, genre => { name => 'electro' }, tracks => [ { title => 'm1' }, { title => 'm2' }, { title => 'm3' }, { title => 'm4' }, ], } ] }); $schema->resultset('CD')->create({ title => 'Equinoxe', year => 1978, artist => { name => 'JMJ' }, genre => { name => 'electro' }, tracks => [ { title => 'e1' }, { title => 'e2' }, { title => 'e3' }, ], single_track => { title => 'o1', cd => { title => 'Oxygene', year => 1976, artist => { name => 'JMJ' }, tracks => [ { title => 'o2', position => 2}, # the position should not be needed here, bug in MC ], }, }, }); for (1,2) { $schema->resultset('CD')->create({ artist => 1, year => 1977, title => "fuzzy_$_" }); } { package DBICTest::HRI::Subclass; use base 'DBIx::Class::ResultClass::HashRefInflator'; } { package DBICTest::HRI::Around; use base 'DBIx::Class::ResultClass::HashRefInflator'; sub inflate_result { shift->next::method(@_) } } for my $rs ( $schema->resultset('CD')->search_rs({}, { result_class => 'DBIx::Class::ResultClass::HashRefInflator' }), $schema->resultset('CD')->search_rs({}, { result_class => 'DBICTest::HRI::Subclass' }), $schema->resultset('CD')->search_rs({}, { result_class => 'DBICTest::HRI::Around' }), ) { cmp_deeply [ $rs->search({}, { columns => { year => 'me.year', 'single_track.cd.artist.name' => 'artist.name', }, join => { single_track => { cd => 'artist' } }, order_by => [qw/me.cdid artist.artistid/], })->all ], [ { year => 1981, single_track => undef }, { year => 1976, single_track => undef }, { year => 1978, single_track => { cd => { artist => { name => "JMJ" } }, }}, { year => 1977, single_track => undef }, { year => 1977, single_track => undef }, ], 'plain 1:1 descending chain ' . $rs->result_class ; cmp_deeply [ $rs->search({}, { columns => { 'artist' => 'me.artist', 'title' => 'me.title', 'year' => 'me.year', 'single_track.cd.artist.artistid' => 'artist.artistid', 'single_track.cd.artist.cds.cdid' => 'cds.cdid', 'single_track.cd.artist.cds.tracks.title' => 'tracks.title', }, join => { single_track => { cd => { artist => { cds => 'tracks' } } } }, order_by => [qw/me.cdid artist.artistid cds.cdid tracks.trackid/], })->all ], [ { artist => 1, title => "Magnetic Fields", year => 1981, single_track => undef, }, { artist => 1, title => "Oxygene", year => 1976, single_track => undef, }, { artist => 1, title => "Equinoxe", year => 1978, single_track => { cd => { artist => { artistid => 1, cds => { cdid => 1, tracks => { title => "m1" } } } } }, }, { artist => 1, title => "Equinoxe", year => 1978, single_track => { cd => { artist => { artistid => 1, cds => { cdid => 1, tracks => { title => "m2" } } } } }, }, { artist => 1, title => "Equinoxe", year => 1978, single_track => { cd => { artist => { artistid => 1, cds => { cdid => 1, tracks => { title => "m3" } } } } }, }, { artist => 1, title => "Equinoxe", year => 1978, single_track => { cd => { artist => { artistid => 1, cds => { cdid => 1, tracks => { title => "m4" } } } } }, }, { artist => 1, title => "Equinoxe", year => 1978, single_track => { cd => { artist => { artistid => 1, cds => { cdid => 2, tracks => { title => "o2" } } } } }, }, { artist => 1, title => "Equinoxe", year => 1978, single_track => { cd => { artist => { artistid => 1, cds => { cdid => 2, tracks => { title => "o1" } } } } }, }, { artist => 1, title => "Equinoxe", year => 1978, single_track => { cd => { artist => { artistid => 1, cds => { cdid => 3, tracks => { title => "e1" } } } } }, }, { artist => 1, title => "Equinoxe", year => 1978, single_track => { cd => { artist => { artistid => 1, cds => { cdid => 3, tracks => { title => "e2" } } } } }, }, { artist => 1, title => "Equinoxe", year => 1978, single_track => { cd => { artist => { artistid => 1, cds => { cdid => 3, tracks => { title => "e3" } } } } }, }, { artist => 1, title => "Equinoxe", year => 1978, single_track => { cd => { artist => { artistid => 1, cds => { cdid => 4, tracks => undef } } } }, }, { artist => 1, title => "Equinoxe", year => 1978, single_track => { cd => { artist => { artistid => 1, cds => { cdid => 5, tracks => undef } } } }, }, { artist => 1, title => "fuzzy_1", year => 1977, single_track => undef, }, { artist => 1, title => "fuzzy_2", year => 1977, single_track => undef, } ], 'non-collapsing 1:1:1:M:M chain ' . $rs->result_class, ; cmp_deeply [ $rs->search({}, { columns => { 'artist' => 'me.artist', 'title' => 'me.title', 'year' => 'me.year', 'single_track.cd.artist.artistid' => 'artist.artistid', 'single_track.cd.artist.cds.cdid' => 'cds.cdid', 'single_track.cd.artist.cds.tracks.title' => 'tracks.title', }, join => { single_track => { cd => { artist => { cds => 'tracks' } } } }, order_by => [qw/me.cdid artist.artistid cds.cdid tracks.trackid/], collapse => 1, })->all ], [ { artist => 1, title => "Magnetic Fields", year => 1981, single_track => undef, }, { artist => 1, title => "Oxygene", year => 1976, single_track => undef, }, { artist => 1, title => "Equinoxe", year => 1978, single_track => { cd => { artist => { artistid => 1, cds => [ { cdid => 1, tracks => [ { title => "m1" }, { title => "m2" }, { title => "m3" }, { title => "m4" }, ] }, { cdid => 2, tracks => [ { title => "o2" }, { title => "o1" }, ] }, { cdid => 3, tracks => [ { title => "e1" }, { title => "e2" }, { title => "e3" }, ] }, { cdid => 4, tracks => [], }, { cdid => 5, tracks => [], } ] } } }, }, { artist => 1, title => "fuzzy_1", year => 1977, single_track => undef, }, { artist => 1, title => "fuzzy_2", year => 1977, single_track => undef, } ], 'collapsing 1:1:1:M:M chain ' . $rs->result_class, ; } done_testing; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/inflate/datetime_oracle.t�����������������������������������������������������0000644�0001750�0001750�00000006600�14240132261�020273� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use DBIx::Class::Optional::Dependencies (); use lib qw(t/lib); use DBICTest; my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_ORA_${_}" } qw/DSN USER PASS/}; if (not ($dsn && $user && $pass)) { plan skip_all => 'Set $ENV{DBICTEST_ORA_DSN}, _USER and _PASS to run this test. ' . 'Warning: This test drops and creates a table called \'event\''; } plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_oracle') unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_oracle'); # DateTime::Format::Oracle needs this set $ENV{NLS_DATE_FORMAT} = 'DD-MON-YY'; $ENV{NLS_TIMESTAMP_FORMAT} = 'YYYY-MM-DD HH24:MI:SSXFF'; $ENV{NLS_LANG} = 'AMERICAN_AMERICA.WE8ISO8859P1'; $ENV{NLS_SORT} = "BINARY"; $ENV{NLS_COMP} = "BINARY"; my $schema = DBICTest::Schema->connect($dsn, $user, $pass); # older oracles do not support a TIMESTAMP datatype my $timestamp_datatype = ($schema->storage->_server_info->{normalized_dbms_version}||0) < 9 ? 'DATE' : 'TIMESTAMP' ; my $dbh = $schema->storage->dbh; #$dbh->do("alter session set nls_timestamp_format = 'YYYY-MM-DD HH24:MI:SSXFF'"); eval { $dbh->do("DROP TABLE event"); }; $dbh->do(<<EOS); CREATE TABLE event ( id number NOT NULL, starts_at date NOT NULL, created_on $timestamp_datatype NOT NULL, varchar_date varchar(20), varchar_datetime varchar(20), skip_inflation date, ts_without_tz date, PRIMARY KEY (id) ) EOS # TODO is in effect for the rest of the tests local $TODO = 'FIXME - something odd is going on with Oracle < 9 datetime support' if ($schema->storage->_server_info->{normalized_dbms_version}||0) < 9; lives_ok { # insert a row to play with my $new = $schema->resultset('Event')->create({ id => 1, starts_at => '06-MAY-07', created_on => '2009-05-03 21:17:18.5' }); is($new->id, 1, "insert sucessful"); my $event = $schema->resultset('Event')->find( 1 ); is( ref($event->starts_at), 'DateTime', "starts_at inflated ok"); is( $event->starts_at->month, 5, "DateTime methods work on inflated column"); is( ref($event->created_on), 'DateTime', "created_on inflated ok"); is( $event->created_on->nanosecond, 500_000_000, "DateTime methods work with nanosecond precision"); my $dt = DateTime->now(); $event->starts_at($dt); $event->created_on($dt); $event->update; is( $event->starts_at->month, $dt->month, "deflate ok"); is( int $event->created_on->nanosecond, int $dt->nanosecond, "deflate ok with nanosecond precision"); # test datetime_setup $schema->storage->disconnect; delete $ENV{NLS_DATE_FORMAT}; delete $ENV{NLS_TIMESTAMP_FORMAT}; $schema->connection($dsn, $user, $pass, { on_connect_call => 'datetime_setup' }); $dt = DateTime->now(); my $timestamp = $dt->clone; $timestamp->set_nanosecond( int 500_000_000 ); $event = $schema->resultset('Event')->find( 1 ); $event->update({ starts_at => $dt, created_on => $timestamp }); $event = $schema->resultset('Event')->find(1); is( $event->starts_at, $dt, 'DateTime round-trip as DATE' ); is( $event->created_on, $timestamp, 'DateTime round-trip as TIMESTAMP' ); is( int $event->created_on->nanosecond, int 500_000_000, 'TIMESTAMP nanoseconds survived' ); } 'dateteime operations executed correctly'; done_testing; # clean up our mess END { if($schema && (my $dbh = $schema->storage->dbh)) { $dbh->do("DROP TABLE event"); } undef $schema; } ��������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/inflate/file_column.t���������������������������������������������������������0000644�0001750�0001750�00000005604�14240132261�017451� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; use DBICTest::Schema; use File::Compare; use Path::Class qw/file/; { local $ENV{DBIC_IC_FILE_NOWARN} = 1; package DBICTest::Schema::FileColumn; use strict; use warnings; use base qw/DBICTest::BaseResult/; use File::Temp qw/tempdir/; __PACKAGE__->load_components (qw/InflateColumn::File/); __PACKAGE__->table('file_columns'); __PACKAGE__->add_columns( id => { data_type => 'integer', is_auto_increment => 1 }, file => { data_type => 'varchar', is_file_column => 1, file_column_path => tempdir(CLEANUP => 1), size => 255 } ); __PACKAGE__->set_primary_key('id'); } DBICTest::Schema->load_classes('FileColumn'); my $schema = DBICTest->init_schema; plan tests => 10; if (not $ENV{DBICTEST_SQLT_DEPLOY}) { $schema->storage->dbh->do(<<'EOF'); CREATE TABLE file_columns ( id INTEGER PRIMARY KEY, file VARCHAR(255) ) EOF } my $rs = $schema->resultset('FileColumn'); my $source_file = file(__FILE__); my $fname = $source_file->basename; my $fh = $source_file->open('r') or die "failed to open $source_file: $!\n"; my $fc = eval { $rs->create({ file => { handle => $fh, filename => $fname } }) }; is ( $@, '', 'created' ); $fh->close; my $storage = file( $fc->column_info('file')->{file_column_path}, $fc->id, $fc->file->{filename}, ); ok ( -e $storage, 'storage exists' ); # read it back $fc = $rs->find({ id => $fc->id }); is ( $fc->file->{filename}, $fname, 'filename matches' ); ok ( compare($storage, $source_file) == 0, 'file contents matches' ); # update my $new_fname = 'File.pm'; my $new_source_file = file(qw/lib DBIx Class InflateColumn File.pm/); my $new_storage = file( $fc->column_info('file')->{file_column_path}, $fc->id, $new_fname, ); $fh = $new_source_file->open('r') or die "failed to open $new_source_file: $!\n"; $fc->file({ handle => $fh, filename => $new_fname }); $fc->update; { local $TODO = 'design change required'; ok ( ! -e $storage, 'old storage does not exist' ); }; ok ( -e $new_storage, 'new storage exists' ); # read it back $fc = $rs->find({ id => $fc->id }); is ( $fc->file->{filename}, $new_fname, 'new filname matches' ); ok ( compare($new_storage, $new_source_file) == 0, 'new content matches' ); if ($^O eq 'MSWin32') { close $fc->file->{handle}; # can't delete open files on Win32 } $fc->delete; ok ( ! -e $storage, 'storage deleted' ); $fh = $source_file->openr or die "failed to open $source_file: $!\n"; $fc = $rs->create({ file => { handle => $fh, filename => $fname } }); # read it back $fc->discard_changes; $storage = file( $fc->column_info('file')->{file_column_path}, $fc->id, $fc->file->{filename}, ); { local $TODO = 'need resultset delete override to delete_all'; $rs->delete; ok ( ! -e $storage, 'storage does not exist after $rs->delete' ); } ����������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/inflate/datetime_firebird.t���������������������������������������������������0000644�0001750�0001750�00000005504�14240132261�020616� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use DBIx::Class::Optional::Dependencies (); use lib qw(t/lib); use DBICTest; use Scope::Guard (); my $env2optdep = { DBICTEST_FIREBIRD => 'test_rdbms_firebird', DBICTEST_FIREBIRD_INTERBASE => 'test_rdbms_firebird_interbase', DBICTEST_FIREBIRD_ODBC => 'test_rdbms_firebird_odbc', }; plan skip_all => join (' ', 'Set $ENV{DBICTEST_FIREBIRD_DSN} and/or $ENV{DBICTEST_FIREBIRD_INTERBASE_DSN}', 'and/or $ENV{DBICTEST_FIREBIRD_ODBC_DSN},', '_USER and _PASS to run these tests.', "WARNING: This test drops and creates a table called 'event'", ) unless grep { $ENV{"${_}_DSN"} } keys %$env2optdep; plan skip_all => ( 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for('test_dt') ) unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt'); my $schema; for my $prefix (keys %$env2optdep) { SKIP: { my ($dsn, $user, $pass) = map { $ENV{"${prefix}_$_"} } qw/DSN USER PASS/; next unless $dsn; # FIXME - work around https://github.com/google/sanitizers/issues/934 $prefix eq 'DBICTEST_FIREBIRD_ODBC' and $Config::Config{config_args} =~ m{fsanitize\=address} and skip( "ODBC Firebird driver doesn't yet work with ASAN: https://github.com/google/sanitizers/issues/934", 1 ); skip ("Testing with ${prefix}_DSN needs " . DBIx::Class::Optional::Dependencies->req_missing_for( $env2optdep->{$prefix} ), 1) unless DBIx::Class::Optional::Dependencies->req_ok_for($env2optdep->{$prefix}); note "Testing with ${prefix}_DSN"; $schema = DBICTest::Schema->connect($dsn, $user, $pass, { quote_char => '"', name_sep => '.', on_connect_call => [ 'datetime_setup' ], }); my $sg = Scope::Guard->new(sub { cleanup($schema) } ); eval { $schema->storage->dbh->do('DROP TABLE "event"') }; $schema->storage->dbh->do(<<'SQL'); CREATE TABLE "event" ( "id" INT PRIMARY KEY, "starts_at" DATE, "created_on" TIMESTAMP ) SQL my $rs = $schema->resultset('Event'); my $dt = DateTime->now; $dt->set_nanosecond(555600000); my $date_only = DateTime->new( year => $dt->year, month => $dt->month, day => $dt->day ); my $row; ok( $row = $rs->create({ id => 1, starts_at => $date_only, created_on => $dt, })); ok( $row = $rs->search({ id => 1 }, { select => [qw/starts_at created_on/] }) ->first ); is $row->created_on, $dt, 'TIMESTAMP as DateTime roundtrip'; cmp_ok $row->created_on->nanosecond, '==', $dt->nanosecond, 'fractional part of a second survived'; is $row->starts_at, $date_only, 'DATE as DateTime roundtrip'; } } done_testing; # clean up our mess sub cleanup { my $schema = shift; my $dbh; eval { $schema->storage->disconnect; # to avoid object FOO is in use errors $dbh = $schema->storage->dbh; }; return unless $dbh; eval { $dbh->do(qq{DROP TABLE "$_"}) } for qw/event/; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/inflate/datetime_missing_deps.t�����������������������������������������������0000644�0001750�0001750�00000000711�14240132261�021507� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use lib qw(t/lib); use DBICTest; my $no_class = '_DBICTEST_NONEXISTENT_CLASS_'; my $schema = DBICTest->init_schema(); $schema->storage->datetime_parser_type($no_class); my $event = $schema->resultset('Event')->find(1); # test that datetime_undef_if_invalid does not eat the missing dep exception throws_ok { my $dt = $event->starts_at; } qr{Can't locate ${no_class}\.pm}; done_testing; �������������������������������������������������������DBIx-Class-0.082843/t/inflate/datetime_informix.t���������������������������������������������������0000644�0001750�0001750�00000003720�14240132261�020661� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use DBIx::Class::Optional::Dependencies (); use lib qw(t/lib); use DBICTest; use Scope::Guard (); plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_dt') . ' and ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_informix') unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt') && DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_informix'); my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_INFORMIX_${_}" } qw/DSN USER PASS/}; if (not $dsn) { plan skip_all => <<'EOF'; Set $ENV{DBICTEST_INFORMIX_DSN} _USER and _PASS to run this test'. Warning: This test drops and creates a table called 'event'"; EOF } my $schema; { $schema = DBICTest::Schema->connect($dsn, $user, $pass, { on_connect_call => [ 'datetime_setup' ], }); my $sg = Scope::Guard->new(sub { cleanup($schema) } ); eval { $schema->storage->dbh->do('DROP TABLE event') }; $schema->storage->dbh->do(<<'SQL'); CREATE TABLE event ( id INT PRIMARY KEY, starts_at DATE, created_on DATETIME YEAR TO FRACTION(5) ); SQL my $rs = $schema->resultset('Event'); my $dt = DateTime->now; $dt->set_nanosecond(555640000); my $date_only = DateTime->new( year => $dt->year, month => $dt->month, day => $dt->day ); my $row; ok( $row = $rs->create({ id => 1, starts_at => $date_only, created_on => $dt, })); ok( $row = $rs->search({ id => 1 }, { select => [qw/starts_at created_on/] }) ->first ); is $row->created_on, $dt, 'TIMESTAMP as DateTime roundtrip'; cmp_ok $row->created_on->nanosecond, '==', $dt->nanosecond, 'fractional part of a second survived'; is $row->starts_at, $date_only, 'DATE as DateTime roundtrip'; } done_testing; # clean up our mess sub cleanup { my $schema = shift; my $dbh; eval { $dbh = $schema->storage->dbh; }; return unless $dbh; eval { $dbh->do(qq{DROP TABLE $_}) } for qw/event/; } ������������������������������������������������DBIx-Class-0.082843/t/inflate/datetime_msaccess.t���������������������������������������������������0000644�0001750�0001750�00000005002�14240132261�020622� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Scope::Guard (); use Try::Tiny; use DBIx::Class::Optional::Dependencies (); use lib qw(t/lib); use DBICTest; my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSACCESS_ODBC_${_}" } qw/DSN USER PASS/}; my ($dsn2, $user2, $pass2) = @ENV{map { "DBICTEST_MSACCESS_ADO_${_}" } qw/DSN USER PASS/}; plan skip_all => 'Test needs ' . (join ' and ', map { $_ ? $_ : () } DBIx::Class::Optional::Dependencies->req_missing_for('test_dt'), (join ' or ', map { $_ ? $_ : () } DBIx::Class::Optional::Dependencies->req_missing_for('test_rdbms_msaccess_odbc'), DBIx::Class::Optional::Dependencies->req_missing_for('test_rdbms_msaccess_ado'))) unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt') && ( $dsn && DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_msaccess_odbc') or $dsn2 && DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_msaccess_ado')) or (not $dsn || $dsn2); plan skip_all => <<'EOF' unless $dsn || $dsn2; Set $ENV{DBICTEST_MSACCESS_ODBC_DSN} and/or $ENV{DBICTEST_MSACCESS_ADO_DSN} (and optionally _USER and _PASS) to run these tests. Warning: this test drops and creates the table 'track'. EOF my @connect_info = ( [ $dsn, $user || '', $pass || '' ], [ $dsn2, $user2 || '', $pass2 || '' ], ); for my $connect_info (@connect_info) { my ($dsn, $user, $pass) = @$connect_info; next unless $dsn; my $schema = DBICTest::Schema->connect($dsn, $user, $pass, { on_connect_call => 'datetime_setup', quote_names => 1, }); my $guard = Scope::Guard->new(sub { cleanup($schema) }); try { local $^W = 0; $schema->storage->dbh->do('DROP TABLE track') }; $schema->storage->dbh->do(<<"SQL"); CREATE TABLE track ( trackid AUTOINCREMENT PRIMARY KEY, cd INT, [position] INT, last_updated_at DATETIME ) SQL ok(my $dt = DateTime->new({ year => 2004, month => 8, day => 21, hour => 14, minute => 36, second => 48, })); ok(my $row = $schema->resultset('Track')->create({ last_updated_at => $dt, cd => 1 })); ok($row = $schema->resultset('Track') ->search({ trackid => $row->trackid }, { select => ['last_updated_at'] }) ->first ); is($row->last_updated_at, $dt, "DATETIME roundtrip" ); } done_testing; # clean up our mess sub cleanup { my $schema = shift; # have to reconnect to drop a table that's in use if (my $storage = eval { $schema->storage }) { local $^W = 0; $storage->disconnect; $storage->dbh->do('DROP TABLE track'); } } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/inflate/datetime_mssql.t������������������������������������������������������0000644�0001750�0001750�00000011710�14240132261�020163� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use Scope::Guard (); use Try::Tiny; use DBIx::Class::Optional::Dependencies (); use lib qw(t/lib); use DBICTest; my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSSQL_ODBC_${_}" } qw/DSN USER PASS/}; my ($dsn2, $user2, $pass2) = @ENV{map { "DBICTEST_MSSQL_${_}" } qw/DSN USER PASS/}; my ($dsn3, $user3, $pass3) = @ENV{map { "DBICTEST_MSSQL_ADO_${_}" } qw/DSN USER PASS/}; plan skip_all => 'Test needs ' . (join ' and ', map { $_ ? $_ : () } DBIx::Class::Optional::Dependencies->req_missing_for('test_dt'), (join ' or ', map { $_ ? $_ : () } DBIx::Class::Optional::Dependencies->req_missing_for('test_rdbms_mssql_odbc'), DBIx::Class::Optional::Dependencies->req_missing_for('test_rdbms_mssql_sybase'), DBIx::Class::Optional::Dependencies->req_missing_for('test_rdbms_mssql_ado'))) unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt') && ( $dsn && DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_mssql_odbc') or $dsn2 && DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_mssql_sybase') or $dsn3 && DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_mssql_ado')) or (not $dsn || $dsn2 || $dsn3); if (not ($dsn || $dsn2 || $dsn3)) { plan skip_all => 'Set $ENV{DBICTEST_MSSQL_ODBC_DSN} and/or $ENV{DBICTEST_MSSQL_DSN} and/or ' .'$ENV{DBICTEST_MSSQL_ADO_DSN} _USER and _PASS to run this test' . "\nWarning: This test drops and creates tables called 'event_small_dt' and" ." 'track'."; } DBICTest::Schema->load_classes('EventSmallDT'); my @connect_info = ( [ $dsn, $user, $pass ], [ $dsn2, $user2, $pass2 ], [ $dsn3, $user3, $pass3 ], ); my $schema; SKIP: for my $connect_info (@connect_info) { my ($dsn, $user, $pass) = @$connect_info; next unless $dsn; $schema = DBICTest::Schema->connect($dsn, $user, $pass, { on_connect_call => 'datetime_setup' }); { my $w; local $SIG{__WARN__} = sub { $w = shift }; $schema->storage->ensure_connected; if ($w =~ /Your DBD::Sybase is too old to support DBIx::Class::InflateColumn::DateTime/) { skip "Skipping tests on old DBD::Sybase " . DBD::Sybase->VERSION, 1; } } my $guard = Scope::Guard->new(sub{ cleanup($schema) }); # $^W because DBD::ADO is a piece of crap try { local $^W = 0; $schema->storage->dbh->do("DROP TABLE track") }; $schema->storage->dbh->do(<<"SQL"); CREATE TABLE track ( trackid INT IDENTITY PRIMARY KEY, cd INT, position INT, last_updated_at DATETIME, ) SQL try { local $^W = 0; $schema->storage->dbh->do("DROP TABLE event_small_dt") }; $schema->storage->dbh->do(<<"SQL"); CREATE TABLE event_small_dt ( id INT IDENTITY PRIMARY KEY, small_dt SMALLDATETIME, ) SQL try { local $^W = 0; $schema->storage->dbh->do("DROP TABLE event") }; $schema->storage->dbh->do(<<"SQL"); CREATE TABLE event ( id int IDENTITY(1,1) NOT NULL, starts_at smalldatetime NULL, created_on datetime NULL, varchar_date varchar(20) NULL, varchar_datetime varchar(20) NULL, skip_inflation datetime NULL, ts_without_tz datetime NULL ) SQL # coltype, column, source, pk, create_extra, datehash my @dt_types = ( ['DATETIME', 'last_updated_at', 'Track', 'trackid', { cd => 1 }, { year => 2004, month => 8, day => 21, hour => 14, minute => 36, second => 48, nanosecond => 500000000, }], ['SMALLDATETIME', # minute precision 'small_dt', 'EventSmallDT', 'id', {}, { year => 2004, month => 8, day => 21, hour => 14, minute => 36, }], ); for my $dt_type (@dt_types) { my ($type, $col, $source, $pk, $create_extra, $sample_dt) = @$dt_type; delete $sample_dt->{nanosecond} if $dsn =~ /:ADO:/; ok(my $dt = DateTime->new($sample_dt)); my $row; ok( $row = $schema->resultset($source)->create({ $col => $dt, %$create_extra, })); ok( $row = $schema->resultset($source) ->search({ $pk => $row->$pk }, { select => [$col] }) ->first ); is( $row->$col, $dt, "$type roundtrip" ); cmp_ok( $row->$col->nanosecond, '==', $sample_dt->{nanosecond}, 'DateTime fractional portion roundtrip' ) if exists $sample_dt->{nanosecond}; } # Check for bulk insert SQL_DATE funtimes when using DBD::ODBC and sqlncli # dbi:ODBC:driver=SQL Server Native Client 10.0;server=10.6.0.9;database=odbctest; lives_ok { $schema->resultset('Event')->populate([{ id => 1, starts_at => undef, },{ id => 2, starts_at => '2011-03-22', }]) } 'populate with datetime does not throw'; ok ( my $row = $schema->resultset('Event')->find(2), 'SQL_DATE bulk insert check' ); } done_testing; # clean up our mess sub cleanup { my $schema = shift; if (my $dbh = eval { $schema->storage->dbh }) { $dbh->do('DROP TABLE track'); $dbh->do('DROP TABLE event_small_dt'); $dbh->do('DROP TABLE event'); } } ��������������������������������������������������������DBIx-Class-0.082843/t/inflate/datetime_mysql.t������������������������������������������������������0000644�0001750�0001750�00000006763�14240132261�020205� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use Test::Warn; use DBIx::Class::Optional::Dependencies (); use lib qw(t/lib); use DBICTest; use DBICTest::Schema; use DBIx::Class::_Util 'sigwarn_silencer'; plan skip_all => 'Inflation tests need ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_dt_mysql') unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt_mysql'); { DBICTest::Schema->load_classes('EventTZ'); local $SIG{__WARN__} = sigwarn_silencer( qr/extra \=\> .+? has been deprecated/ ); DBICTest::Schema->load_classes('EventTZDeprecated'); } my $schema = DBICTest->init_schema(); # Test "timezone" parameter foreach my $tbl (qw/EventTZ EventTZDeprecated/) { my $event_tz = $schema->resultset($tbl)->create({ starts_at => DateTime->new(year=>2007, month=>12, day=>31, time_zone => "America/Chicago" ), created_on => DateTime->new(year=>2006, month=>1, day=>31, hour => 13, minute => 34, second => 56, time_zone => "America/New_York" ), }); is ($event_tz->starts_at->day_name, "Montag", 'Locale de_DE loaded: day_name'); is ($event_tz->starts_at->month_name, "Dezember", 'Locale de_DE loaded: month_name'); is ($event_tz->created_on->day_name, "Tuesday", 'Default locale loaded: day_name'); is ($event_tz->created_on->month_name, "January", 'Default locale loaded: month_name'); my $starts_at = $event_tz->starts_at; is("$starts_at", '2007-12-31T00:00:00', 'Correct date/time using timezone'); my $created_on = $event_tz->created_on; is("$created_on", '2006-01-31T12:34:56', 'Correct timestamp using timezone'); is($event_tz->created_on->time_zone->name, "America/Chicago", "Correct timezone"); my $loaded_event = $schema->resultset($tbl)->find( $event_tz->id ); isa_ok($loaded_event->starts_at, 'DateTime', 'DateTime returned'); $starts_at = $loaded_event->starts_at; is("$starts_at", '2007-12-31T00:00:00', 'Loaded correct date/time using timezone'); is($starts_at->time_zone->name, 'America/Chicago', 'Correct timezone'); isa_ok($loaded_event->created_on, 'DateTime', 'DateTime returned'); $created_on = $loaded_event->created_on; is("$created_on", '2006-01-31T12:34:56', 'Loaded correct timestamp using timezone'); is($created_on->time_zone->name, 'America/Chicago', 'Correct timezone'); # Test floating timezone warning # We expect one warning SKIP: { skip "ENV{DBIC_FLOATING_TZ_OK} was set, skipping", 1 if $ENV{DBIC_FLOATING_TZ_OK}; warnings_exist ( sub { $schema->resultset($tbl)->create({ starts_at => DateTime->new(year=>2007, month=>12, day=>31 ), created_on => DateTime->new(year=>2006, month=>1, day=>31, hour => 13, minute => 34, second => 56 ), }); }, qr/You're using a floating timezone, please see the documentation of DBIx::Class::InflateColumn::DateTime for an explanation/, 'Floating timezone warning' ); }; # This should fail to set my $prev_str = "$created_on"; $loaded_event->update({ created_on => '0000-00-00' }); is("$created_on", $prev_str, "Don't update invalid dates"); } # Test invalid DT my $invalid = $schema->resultset('EventTZ')->create({ starts_at => '0000-00-00', created_on => DateTime->now, }); is( $invalid->get_column('starts_at'), '0000-00-00', "Invalid date stored" ); is( $invalid->starts_at, undef, "Inflate to undef" ); $invalid->created_on('0000-00-00'); $invalid->update; throws_ok ( sub { $invalid->created_on }, qr/invalid date format/i, "Invalid date format exception" ); done_testing; �������������DBIx-Class-0.082843/t/inflate/datetime.t������������������������������������������������������������0000644�0001750�0001750�00000010200�14240132261�016735� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Warn; use Try::Tiny; use lib qw(t/lib); use DBICTest; # so user's env doesn't screw us delete $ENV{DBIC_DT_SEARCH_OK}; my $schema = DBICTest->init_schema(); plan skip_all => 'DT inflation tests need ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_dt_sqlite') unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt_sqlite'); # inflation test my $event = $schema->resultset("Event")->find(1); isa_ok($event->starts_at, 'DateTime', 'DateTime returned'); # klunky, but makes older Test::More installs happy my $starts = $event->starts_at; is("$starts", '2006-04-25T22:24:33', 'Correct date/time'); my $dt_warn_re = qr/DateTime objects.+not supported properly/; my $row; { local $ENV{DBIC_DT_SEARCH_OK} = 1; local $SIG{__WARN__} = sub { fail('Disabled warning still issued') if $_[0] =~ $dt_warn_re; warn @_; }; $row = $schema->resultset('Event')->search({ starts_at => $starts })->single } warnings_exist { $row = $schema->resultset('Event')->search({ starts_at => $starts })->single } [$dt_warn_re], 'using a DateTime object in ->search generates a warning'; { local $TODO = "This stuff won't work without a -dt operator of some sort" unless eval { require DBIx::Class::SQLMaker::DateOps }; is(eval { $row->id }, 1, 'DT in search'); local $ENV{DBIC_DT_SEARCH_OK} = 1; ok($row = $schema->resultset('Event')->search({ starts_at => { '>=' => $starts } }) ->single); is(eval { $row->id }, 1, 'DT in search with condition'); } # create using DateTime my $created = $schema->resultset('Event')->create({ starts_at => DateTime->new(year=>2006, month=>6, day=>18), created_on => DateTime->new(year=>2006, month=>6, day=>23) }); my $created_start = $created->starts_at; isa_ok($created->starts_at, 'DateTime', 'DateTime returned'); is("$created_start", '2006-06-18T00:00:00', 'Correct date/time'); ## timestamp field isa_ok($event->created_on, 'DateTime', 'DateTime returned'); ## varchar fields isa_ok($event->varchar_date, 'DateTime', 'DateTime returned'); isa_ok($event->varchar_datetime, 'DateTime', 'DateTime returned'); ## skip inflation field isnt(ref($event->skip_inflation), 'DateTime', 'No DateTime returned for skip inflation column'); # klunky, but makes older Test::More installs happy my $createo = $event->created_on; is("$createo", '2006-06-22T21:00:05', 'Correct date/time'); my $created_cron = $created->created_on; isa_ok($created->created_on, 'DateTime', 'DateTime returned'); is("$created_cron", '2006-06-23T00:00:00', 'Correct date/time'); ## varchar field using inflate_date => 1 my $varchar_date = $event->varchar_date; is("$varchar_date", '2006-07-23T00:00:00', 'Correct date/time'); ## varchar field using inflate_datetime => 1 my $varchar_datetime = $event->varchar_datetime; is("$varchar_datetime", '2006-05-22T19:05:07', 'Correct date/time'); ## skip inflation field my $skip_inflation = $event->skip_inflation; is ("$skip_inflation", '2006-04-21 18:04:06', 'Correct date/time'); # create and update with literals { my $d = { created_on => \ '2001-09-11', starts_at => \[ '?' => '2001-10-26' ], }; my $ev = $schema->resultset('Event')->create($d); for my $col (qw(created_on starts_at)) { ok (ref $ev->$col, "literal untouched in $col"); is_deeply( $ev->$col, $d->{$col}); is_deeply( $ev->get_inflated_column($col), $d->{$col}); is_deeply( $ev->get_column($col), $d->{$col}); } $ev->discard_changes; is_deeply( { $ev->get_dirty_columns }, {} ); for my $col (qw(created_on starts_at)) { isa_ok ($ev->$col, "DateTime", "$col properly inflated on retrieve"); } for my $meth (qw(set_inflated_columns set_columns)) { $ev->$meth({%$d}); is_deeply( { $ev->get_dirty_columns }, $d, "Expected dirty cols after setting literals via $meth", ); $ev->update; for my $col (qw(created_on starts_at)) { ok (ref $ev->$col, "literal untouched in $col updated via $meth"); is_deeply( $ev->$col, $d->{$col}); is_deeply( $ev->get_inflated_column($col), $d->{$col}); is_deeply( $ev->get_column($col), $d->{$col}); } } } done_testing; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/inflate/datetime_sqlanywhere.t������������������������������������������������0000644�0001750�0001750�00000005302�14240132261�021366� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Scope::Guard (); use DBIx::Class::Optional::Dependencies (); use lib qw(t/lib); use DBICTest; my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_SQLANYWHERE_${_}" } qw/DSN USER PASS/}; my ($dsn2, $user2, $pass2) = @ENV{map { "DBICTEST_SQLANYWHERE_ODBC_${_}" } qw/DSN USER PASS/}; plan skip_all => 'Test needs ' . (join ' and ', map { $_ ? $_ : () } DBIx::Class::Optional::Dependencies->req_missing_for('test_dt'), (join ' or ', map { $_ ? $_ : () } DBIx::Class::Optional::Dependencies->req_missing_for('test_rdbms_sqlanywhere'), DBIx::Class::Optional::Dependencies->req_missing_for('test_rdbms_sqlanywhere_odbc'))) unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt') && ( $dsn && DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_sqlanywhere') or $dsn2 && DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_sqlanywhere_odbc')) or (not $dsn || $dsn2); if (not ($dsn || $dsn2)) { plan skip_all => <<'EOF'; Set $ENV{DBICTEST_SQLANYWHERE_DSN} and/or $ENV{DBICTEST_SQLANYWHERE_ODBC_DSN} _USER and _PASS to run this test'. Warning: This test drops and creates a table called 'event'"; EOF } my @info = ( [ $dsn, $user, $pass ], [ $dsn2, $user2, $pass2 ], ); my $schema; foreach my $info (@info) { my ($dsn, $user, $pass) = @$info; next unless $dsn; $schema = DBICTest::Schema->clone; $schema->connection($dsn, $user, $pass, { on_connect_call => 'datetime_setup', }); my $sg = Scope::Guard->new(sub { cleanup($schema) } ); eval { $schema->storage->dbh->do('DROP TABLE event') }; $schema->storage->dbh->do(<<"SQL"); CREATE TABLE event ( id INT IDENTITY PRIMARY KEY, created_on TIMESTAMP, starts_at DATE ) SQL # coltype, col, date my @dt_types = ( [ 'TIMESTAMP', 'created_on', '2004-08-21 14:36:48.080445', ], # date only (but minute precision according to ASA docs) [ 'DATE', 'starts_at', '2004-08-21 00:00:00.000000', ], ); for my $dt_type (@dt_types) { my ($type, $col, $sample_dt) = @$dt_type; ok(my $dt = $schema->storage->datetime_parser->parse_datetime($sample_dt)); my $row; ok( $row = $schema->resultset('Event')->create({ $col => $dt, })); ok( $row = $schema->resultset('Event') ->search({ id => $row->id }, { select => [$col] }) ->first ); is( $row->$col, $dt, "$type roundtrip" ); is $row->$col->nanosecond, $dt->nanosecond, 'nanoseconds survived' if 0+$dt->nanosecond; } } done_testing; # clean up our mess sub cleanup { my $schema = shift; if (my $dbh = $schema->storage->dbh) { eval { $dbh->do("DROP TABLE $_") } for qw/event/; } } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/inflate/hri.t�����������������������������������������������������������������0000644�0001750�0001750�00000015734�14240132261�015744� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use DBIx::Class::_Util 'modver_gt_or_eq_and_lt'; use base(); BEGIN { plan skip_all => 'base.pm 2.20 (only present in perl 5.19.7) is known to break this test' if modver_gt_or_eq_and_lt( 'base', '2.19_01', '2.21' ); } use Test::Exception; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); # Under some versions of SQLite if the $rs is left hanging around it will lock # So we create a scope here cos I'm lazy { my $rs = $schema->resultset('CD')->search ({}, { order_by => 'cdid', }); my $orig_resclass = $rs->result_class; eval "package DBICTest::CDSubclass; use base '$orig_resclass'"; # override on a specific $rs object, should not chain $rs->result_class ('DBICTest::CDSubclass'); my $cd = $rs->find ({cdid => 1}); is (ref $cd, 'DBICTest::CDSubclass', 'result_class override propagates to find'); $cd = $rs->search({ cdid => 1 })->single; is (ref $cd, $orig_resclass, 'result_class override does not propagate over seach+single'); $cd = $rs->search()->find ({ cdid => 1 }); is (ref $cd, $orig_resclass, 'result_class override does not propagate over seach+find'); # set as attr - should propagate my $hri_rs = $rs->search ({}, { result_class => 'DBIx::Class::ResultClass::HashRefInflator' }); is ($rs->result_class, 'DBICTest::CDSubclass', 'original class unchanged'); is ($hri_rs->result_class, 'DBIx::Class::ResultClass::HashRefInflator', 'result_class accessor pre-set via attribute'); my $datahashref1 = $hri_rs->next; is_deeply( [ sort keys %$datahashref1 ], [ sort $rs->result_source->columns ], 'returned correct columns', ); $hri_rs->reset; $cd = $hri_rs->find ({cdid => 1}); is_deeply ( $cd, $datahashref1, 'first/find return the same thing (result_class attr propagates)'); $cd = $hri_rs->search({ cdid => 1 })->single; is_deeply ( $cd, $datahashref1, 'first/search+single return the same thing (result_class attr propagates)'); $hri_rs->result_class ('DBIx::Class::Row'); # something bogus is( $hri_rs->search->result_class, 'DBIx::Class::ResultClass::HashRefInflator', 'result_class set using accessor does not propagate over unused search' ); # test result class auto-loading throws_ok ( sub { $rs->result_class ('nonexsitant_bogus_class') }, qr/Can't locate nonexsitant_bogus_class.pm/, 'Attempt to load on accessor override', ); is ($rs->result_class, 'DBICTest::CDSubclass', 'class unchanged'); throws_ok ( sub { $rs->search ({}, { result_class => 'nonexsitant_bogus_class' }) }, qr/Can't locate nonexsitant_bogus_class.pm/, 'Attempt to load on accessor override', ); is ($rs->result_class, 'DBICTest::CDSubclass', 'class unchanged'); } sub check_cols_of { my ($dbic_obj, $datahashref) = @_; foreach my $col (keys %$datahashref) { # plain column if (not ref ($datahashref->{$col}) ) { is ($datahashref->{$col}, $dbic_obj->get_column($col), 'same value'); } # related table entry (belongs_to) elsif (ref ($datahashref->{$col}) eq 'HASH') { check_cols_of($dbic_obj->$col, $datahashref->{$col}); } # multiple related entries (has_many) elsif (ref ($datahashref->{$col}) eq 'ARRAY') { my @dbic_reltable = $dbic_obj->$col; my @hashref_reltable = @{$datahashref->{$col}}; is (scalar @hashref_reltable, scalar @dbic_reltable, 'number of related entries'); # for my $index (0..scalar @hashref_reltable) { for my $index (0..scalar @dbic_reltable) { my $dbic_reltable_obj = $dbic_reltable[$index]; my $hashref_reltable_entry = $hashref_reltable[$index]; check_cols_of($dbic_reltable_obj, $hashref_reltable_entry); } } } } # create a cd without tracks for testing empty has_many relationship $schema->resultset('CD')->create({ title => 'Silence is golden', artist => 3, year => 2006 }); # order_by to ensure both resultsets have the rows in the same order # also check result_class-as-an-attribute syntax my $rs_dbic = $schema->resultset('CD')->search(undef, { prefetch => [ qw/ artist tracks / ], order_by => [ 'me.cdid', 'tracks.position' ], } ); my $rs_hashrefinf = $schema->resultset('CD')->search(undef, { prefetch => [ qw/ artist tracks / ], order_by => [ 'me.cdid', 'tracks.position' ], result_class => 'DBIx::Class::ResultClass::HashRefInflator', } ); my @dbic = $rs_dbic->all; my @hashrefinf = $rs_hashrefinf->all; for my $index (0 .. $#hashrefinf) { my $dbic_obj = $dbic[$index]; my $datahashref = $hashrefinf[$index]; check_cols_of($dbic_obj, $datahashref); } # sometimes for ultra-mega-speed you want to fetch columns in esoteric ways # check the inflator over a non-fetching join $rs_dbic = $schema->resultset ('Artist')->search ({ 'me.artistid' => 1}, { prefetch => { cds => 'tracks' }, order_by => [qw/cds.cdid tracks.trackid/], }); $rs_hashrefinf = $schema->resultset ('Artist')->search ({ 'me.artistid' => 1}, { join => { cds => 'tracks' }, select => [qw/name tracks.title tracks.cd /], as => [qw/name cds.tracks.title cds.tracks.cd /], order_by => [qw/cds.cdid tracks.trackid/], result_class => 'DBIx::Class::ResultClass::HashRefInflator', }); @dbic = map { $_->tracks->all } ($rs_dbic->first->cds->all); @hashrefinf = $rs_hashrefinf->all; is (scalar @dbic, scalar @hashrefinf, 'Equal number of tracks fetched'); for my $index (0 .. $#hashrefinf) { my $track = $dbic[$index]; my $datahashref = $hashrefinf[$index]; is ($track->cd->artist->name, $datahashref->{name}, 'Brought back correct artist'); for my $col (keys %{$datahashref->{cds}{tracks}}) { is ($track->get_column ($col), $datahashref->{cds}{tracks}{$col}, "Correct track '$col'"); } } # check for same query as above but using extended columns syntax $rs_hashrefinf = $schema->resultset ('Artist')->search ({ 'me.artistid' => 1}, { join => { cds => 'tracks' }, columns => {name => 'name', 'cds.tracks.title' => 'tracks.title', 'cds.tracks.cd' => 'tracks.cd'}, order_by => [qw/cds.cdid tracks.trackid/], }); $rs_hashrefinf->result_class('DBIx::Class::ResultClass::HashRefInflator'); is_deeply [$rs_hashrefinf->all], \@hashrefinf, 'Check query using extended columns syntax'; # check nested prefetching of has_many relationships which return nothing my $artist = $schema->resultset ('Artist')->create ({ name => 'unsuccessful artist without CDs'}); $artist->discard_changes; my $rs_artists = $schema->resultset ('Artist')->search ({ 'me.artistid' => $artist->id}, { prefetch => { cds => 'tracks' }, result_class => 'DBIx::Class::ResultClass::HashRefInflator', }); is_deeply( [$rs_artists->all], [{ $artist->get_columns, cds => [] }], 'nested has_many prefetch without entries' ); done_testing; ������������������������������������DBIx-Class-0.082843/t/inflate/datetime_sybase.t�����������������������������������������������������0000644�0001750�0001750�00000007305�14240132261�020317� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use Scope::Guard (); use Try::Tiny; use DBIx::Class::Optional::Dependencies (); use lib qw(t/lib); use DBICTest; plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_dt') . ' and ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_ase') unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt') && DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_ase'); my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_SYBASE_${_}" } qw/DSN USER PASS/}; if (not ($dsn && $user)) { plan skip_all => 'Set $ENV{DBICTEST_SYBASE_DSN}, _USER and _PASS to run this test' . "\nWarning: This test drops and creates a table called 'track' and " . "'event_small_dt'"; } DBICTest::Schema->load_classes('EventSmallDT'); my @storage_types = ( 'DBI::Sybase::ASE', 'DBI::Sybase::ASE::NoBindVars', ); my $schema; for my $storage_type (@storage_types) { $schema = DBICTest::Schema->clone; unless ($storage_type eq 'DBI::Sybase::ASE') { # autodetect $schema->storage_type("::$storage_type"); } $schema->connection($dsn, $user, $pass, { on_connect_call => 'datetime_setup', }); my $guard = Scope::Guard->new(sub { cleanup($schema) } ); $schema->storage->ensure_connected; isa_ok( $schema->storage, "DBIx::Class::Storage::$storage_type" ); eval { $schema->storage->dbh->do("DROP TABLE track") }; $schema->storage->dbh->do(<<"SQL"); CREATE TABLE track ( trackid INT IDENTITY PRIMARY KEY, cd INT NULL, position INT NULL, last_updated_at DATETIME NULL ) SQL eval { $schema->storage->dbh->do("DROP TABLE event_small_dt") }; $schema->storage->dbh->do(<<"SQL"); CREATE TABLE event_small_dt ( id INT IDENTITY PRIMARY KEY, small_dt SMALLDATETIME NULL, ) SQL # coltype, column, source, pk, create_extra, datehash my @dt_types = ( ['DATETIME', 'last_updated_at', 'Track', 'trackid', { cd => 1 }, { year => 2004, month => 8, day => 21, hour => 14, minute => 36, second => 48, nanosecond => 500000000, }], ['SMALLDATETIME', # minute precision 'small_dt', 'EventSmallDT', 'id', {}, { year => 2004, month => 8, day => 21, hour => 14, minute => 36, }], ); for my $dt_type (@dt_types) { my ($type, $col, $source, $pk, $create_extra, $sample_dt) = @$dt_type; ok(my $dt = DateTime->new($sample_dt)); my $row; ok( $row = $schema->resultset($source)->create({ $col => $dt, %$create_extra, })); ok( $row = $schema->resultset($source) ->search({ $pk => $row->$pk }, { select => [$col] }) ->first ); is( $row->$col, $dt, "$type roundtrip" ); cmp_ok( $row->$col->nanosecond, '==', $sample_dt->{nanosecond}, 'DateTime fractional portion roundtrip' ) if exists $sample_dt->{nanosecond}; } # test a computed datetime column eval { $schema->storage->dbh->do("DROP TABLE track") }; $schema->storage->dbh->do(<<"SQL"); CREATE TABLE track ( trackid INT IDENTITY PRIMARY KEY, cd INT NULL, position INT NULL, title VARCHAR(100) NULL, last_updated_on DATETIME NULL, last_updated_at AS getdate(), ) SQL my $now = DateTime->now; sleep 1; my $new_row = $schema->resultset('Track')->create({}); $new_row->discard_changes; lives_and { cmp_ok (($new_row->last_updated_at - $now)->seconds, '>=', 1) } 'getdate() computed column works'; } done_testing; # clean up our mess sub cleanup { my $schema = shift; if (my $dbh = eval { $schema->storage->dbh }) { $dbh->do('DROP TABLE track'); $dbh->do('DROP TABLE event_small_dt'); } } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/inflate/datetime_pg.t���������������������������������������������������������0000644�0001750�0001750�00000002755�14240132261�017443� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Warn; use DBIx::Class::Optional::Dependencies (); use lib qw(t/lib); use DBICTest; plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_dt_pg') unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt_pg'); DBICTest::Schema->load_classes('EventTZPg'); my $schema = DBICTest->init_schema(); # this may generate warnings under certain CI flags, hence do it outside of # the warnings_are below my $dt = DateTime->new( year => 2000, time_zone => "America/Chicago" ); warnings_are { my $event = $schema->resultset("EventTZPg")->find(1); $event->update({created_on => '2009-01-15 17:00:00+00'}); $event->discard_changes; isa_ok($event->created_on, "DateTime") or diag $event->created_on; is($event->created_on->time_zone->name, "America/Chicago", "Timezone changed"); # Time zone difference -> -6hours is($event->created_on->iso8601, "2009-01-15T11:00:00", "Time with TZ correct"); # test 'timestamp without time zone' my $dt = DateTime->from_epoch(epoch => time); $dt->set_nanosecond(int 500_000_000); $event->update({ts_without_tz => $dt}); $event->discard_changes; isa_ok($event->ts_without_tz, "DateTime") or diag $event->created_on; is($event->ts_without_tz, $dt, 'timestamp without time zone inflation'); is($event->ts_without_tz->microsecond, $dt->microsecond, 'timestamp without time zone microseconds survived'); } [], 'No warnings during DT manipulations'; done_testing; �������������������DBIx-Class-0.082843/t/inflate/datetime_determine_parser.t�������������������������������������������0000644�0001750�0001750�00000001461�14240132261�022356� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_dt_sqlite') unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt_sqlite'); my $schema = DBICTest->init_schema( no_deploy => 1, # Deploying would cause an early rebless ); is( ref $schema->storage, 'DBIx::Class::Storage::DBI', 'Starting with generic storage' ); # Calling date_time_parser should cause the storage to be reblessed, # so that we can pick up datetime_parser_type from subclasses my $parser = $schema->storage->datetime_parser(); is($parser, 'DateTime::Format::SQLite', 'Got expected storage-set datetime_parser'); isa_ok($schema->storage, 'DBIx::Class::Storage::DBI::SQLite', 'storage'); done_testing; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/inflate/core.t����������������������������������������������������������������0000644�0001750�0001750�00000007707�14240132261�016113� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); plan skip_all => 'Inflation tests need ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_dt') unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt'); $schema->class('CD') ->inflate_column( 'year', { inflate => sub { DateTime->new( year => shift ) }, deflate => sub { shift->year } } ); my $rs = $schema->resultset('CD'); # inflation test my $cd = $rs->find(3); is( ref($cd->year), 'DateTime', 'year is a DateTime, ok' ); is( $cd->year->year, 1997, 'inflated year ok' ); is( $cd->year->month, 1, 'inflated month ok' ); lives_ok ( sub { $cd->year(\'year +1') }, 'updated year using a scalarref' ); $cd->update(); $cd->discard_changes(); is( ref($cd->year), 'DateTime', 'year is still a DateTime, ok' ); is( $cd->year->year, 1998, 'updated year, bypassing inflation' ); is( $cd->year->month, 1, 'month is still 1' ); # get_inflated_column test is( ref($cd->get_inflated_column('year')), 'DateTime', 'get_inflated_column produces a DateTime'); # deflate test my $now = DateTime->now; $cd->year( $now ); $cd->update; $cd = $rs->find(3); is( $cd->year->year, $now->year, 'deflate ok' ); # set_inflated_column test lives_ok ( sub { $cd->set_inflated_column('year', $now) }, 'set_inflated_column with DateTime object' ); $cd->update; $cd = $rs->find(3); is( $cd->year->year, $now->year, 'deflate ok' ); $cd = $rs->find(3); my $before_year = $cd->year->year; lives_ok ( sub { $cd->set_inflated_column('year', \'year + 1') }, 'set_inflated_column to "year + 1"', ); $cd->update; $cd->store_inflated_column('year', \'year + 1'); is_deeply( $cd->year, \'year + 1', 'scalarref deflate passthrough ok' ); $cd = $rs->find(3); is( $cd->year->year, $before_year+1, 'deflate ok' ); # store_inflated_column test $cd = $rs->find(3); lives_ok ( sub { $cd->store_inflated_column('year', $now) }, 'store_inflated_column with DateTime object' ); $cd->update; is( $cd->year->year, $now->year, 'deflate ok' ); # update tests $cd = $rs->find(3); lives_ok ( sub { $cd->update({'year' => $now}) }, 'update using DateTime object ok' ); is($cd->year->year, $now->year, 'deflate ok'); $cd = $rs->find(3); $before_year = $cd->year->year; lives_ok ( sub { $cd->update({'year' => \'year + 1'}) }, 'update using scalarref ok' ); $cd = $rs->find(3); is($cd->year->year, $before_year + 1, 'deflate ok'); # discard_changes test $cd = $rs->find(3); # inflate the year $before_year = $cd->year->year; $cd->update({ year => \'year + 1'}); $cd->discard_changes; is($cd->year->year, $before_year + 1, 'discard_changes clears the inflated value'); my $copy = $cd->copy({ year => $now, title => "zemoose" }); is( $copy->year->year, $now->year, "copy" ); my $artist = $cd->artist; my $sval = \ '2012'; $cd = $rs->create ({ artist => $artist, year => $sval, title => 'create with scalarref', }); is ($cd->year, $sval, 'scalar value retained'); my $cd2 = $cd->copy ({ title => 'copy with scalar in coldata' }); is ($cd2->year, $sval, 'copied scalar value retained'); $cd->discard_changes; is ($cd->year->year, 2012, 'infation upon reload'); $cd2->discard_changes; is ($cd2->year->year, 2012, 'infation upon reload of copy'); my $precount = $rs->count; $cd = $rs->update_or_create ({artist => $artist, title => 'nonexisting update/create test row', year => $sval }); is ($rs->count, $precount + 1, 'Row created'); is ($cd->year, $sval, 'scalar value retained on creating update_or_create'); $cd->discard_changes; is ($cd->year->year, 2012, 'infation upon reload'); my $sval2 = \ '2013'; $cd = $rs->update_or_create ({artist => $artist, title => 'nonexisting update/create test row', year => $sval2 }); is ($rs->count, $precount + 1, 'No more rows created'); is ($cd->year, $sval2, 'scalar value retained on updating update_or_create'); $cd->discard_changes; is ($cd->year->year, 2013, 'infation upon reload'); done_testing; ���������������������������������������������������������DBIx-Class-0.082843/t/inflate/serialize.t�����������������������������������������������������������0000644�0001750�0001750�00000005325�14240132261�017144� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); my @serializers = ( { module => 'YAML.pm', inflater => sub { YAML::Load (shift) }, deflater => sub { die "Expecting a reference" unless (ref $_[0]); YAML::Dump (shift) }, }, { module => 'Storable.pm', inflater => sub { Storable::thaw (shift) }, deflater => sub { die "Expecting a reference" unless (ref $_[0]); Storable::nfreeze (shift) }, }, ); my $selected; foreach my $serializer (@serializers) { eval { require $serializer->{module} }; unless ($@) { $selected = $serializer; last; } } plan (skip_all => "No suitable serializer found") unless $selected; DBICTest::Schema::Serialized->inflate_column( 'serialized', { inflate => $selected->{inflater}, deflate => $selected->{deflater}, }, ); Class::C3->reinitialize if DBIx::Class::_ENV_::OLD_MRO; my $struct_hash = { a => 1, b => [ { c => 2 }, ], d => 3, }; my $struct_array = [ 'a', { b => 1, c => 2, }, 'd', ]; my $rs = $schema->resultset('Serialized'); my $inflated; #======= testing hashref serialization my $object = $rs->create( { serialized => '', } ); ok($object->update( { serialized => $struct_hash } ), 'hashref deflation'); ok($inflated = $object->serialized, 'hashref inflation'); is_deeply($inflated, $struct_hash, 'inflated hash matches original'); $object = $rs->create( { serialized => '', } ); $object->set_inflated_column('serialized', $struct_hash); is_deeply($object->serialized, $struct_hash, 'inflated hash matches original'); $object = $rs->new({}); $object->serialized ($struct_hash); $object->insert; is_deeply ( $rs->find ({id => $object->id})->serialized, $struct_hash, 'new/insert works', ); #====== testing arrayref serialization ok($object->update( { serialized => $struct_array } ), 'arrayref deflation'); ok($inflated = $object->serialized, 'arrayref inflation'); is_deeply($inflated, $struct_array, 'inflated array matches original'); $object = $rs->new({}); $object->serialized ($struct_array); $object->insert; is_deeply ( $rs->find ({id => $object->id})->serialized, $struct_array, 'new/insert works', ); #===== make sure make_column_dirty interacts reasonably with inflation $object = $rs->first; $object->update ({serialized => { x => 'y'}}); $object->serialized->{x} = 'z'; # change state without notifying $object ok (!$object->get_dirty_columns, 'no dirty columns yet'); is_deeply ($object->serialized, { x => 'z' }, 'object data correct'); $object->make_column_dirty('serialized'); $object->update; is_deeply ($rs->first->serialized, { x => 'z' }, 'changes made it to the db' ); done_testing; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/search/�����������������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�014627� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/search/subquery.t�������������������������������������������������������������0000644�0001750�0001750�00000012071�14240132261�016653� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest ':DiffSQL'; use DBIx::Class::_Util 'sigwarn_silencer'; my $ROWS = DBIx::Class::SQLMaker::ClassicExtensions->__rows_bindtype; my $schema = DBICTest->init_schema(); my $art_rs = $schema->resultset('Artist'); my $cdrs = $schema->resultset('CD'); my @tests = ( { rs => $cdrs, search => \[ "title = ? AND year LIKE ?", [ title => 'buahaha' ], [ year => '20%' ] ], attrs => { rows => 5 }, sqlbind => \[ "( SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE (title = ? AND year LIKE ?) LIMIT ?)", [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'title' } => 'buahaha' ], [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'year' } => '20%' ], [ $ROWS => 5 ], ], }, { rs => $cdrs, search => { artistid => { 'in' => $art_rs->search({}, { rows => 1 })->get_column( 'artistid' )->as_query }, }, sqlbind => \[ "( SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE artistid IN ( SELECT me.artistid FROM artist me LIMIT ? ) )", [ $ROWS => 1 ], ], }, { rs => $art_rs, attrs => { 'select' => [ $cdrs->search({}, { rows => 1 })->get_column('id')->as_query, ], }, sqlbind => \[ "( SELECT (SELECT me.id FROM cd me LIMIT ?) FROM artist me )", [ $ROWS => 1 ], ], }, { rs => $art_rs, attrs => { '+select' => [ $cdrs->search({}, { rows => 1 })->get_column('id')->as_query, ], }, sqlbind => \[ "( SELECT me.artistid, me.name, me.rank, me.charfield, (SELECT me.id FROM cd me LIMIT ?) FROM artist me )", [ $ROWS => 1 ], ], }, { rs => $cdrs, attrs => { alias => 'cd2', from => [ { cd2 => $cdrs->search({ artist => { '>' => 20 } })->as_query }, ], }, sqlbind => \[ "( SELECT cd2.cdid, cd2.artist, cd2.title, cd2.year, cd2.genreid, cd2.single_track FROM ( SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE artist > ? ) cd2 )", [ { sqlt_datatype => 'integer', dbic_colname => 'artist' } => 20 ] ], }, { rs => $art_rs, attrs => { from => [ { 'me' => 'artist' }, [ { 'cds' => $cdrs->search({}, { 'select' => [\'me.artist as cds_artist' ]})->as_query }, { 'me.artistid' => 'cds_artist' } ] ] }, sqlbind => \[ "( SELECT me.artistid, me.name, me.rank, me.charfield FROM artist me JOIN (SELECT me.artist as cds_artist FROM cd me) cds ON me.artistid = cds_artist )" ], }, { rs => $cdrs, attrs => { alias => 'cd2', from => [ { cd2 => $cdrs->search( { artist => { '>' => 20 } }, { alias => 'cd3', from => [ { cd3 => $cdrs->search( { artist => { '<' => 40 } } )->as_query } ], }, )->as_query }, ], }, sqlbind => \[ "( SELECT cd2.cdid, cd2.artist, cd2.title, cd2.year, cd2.genreid, cd2.single_track FROM (SELECT cd3.cdid, cd3.artist, cd3.title, cd3.year, cd3.genreid, cd3.single_track FROM (SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE artist < ?) cd3 WHERE artist > ?) cd2 )", [ { sqlt_datatype => 'integer', dbic_colname => 'artist' } => 40 ], [ { dbic_colname => 'artist' } => 20 ], # no rsrc in outer manual from - hence no resolution ], }, { rs => $cdrs, search => { year => { '=' => $cdrs->search( { artistid => { '=' => \'me.artistid' } }, { alias => 'inner' } )->get_column('year')->max_rs->as_query, }, }, sqlbind => \[ "( SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE year = (SELECT MAX(inner.year) FROM cd inner WHERE artistid = me.artistid) )", ], }, { rs => $cdrs, attrs => { alias => 'cd2', from => [ { cd2 => $cdrs->search({ title => 'Thriller' })->as_query }, ], }, sqlbind => \[ "(SELECT cd2.cdid, cd2.artist, cd2.title, cd2.year, cd2.genreid, cd2.single_track FROM ( SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE title = ? ) cd2 )", [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'title' } => 'Thriller' ] ], }, ); for my $i (0 .. $#tests) { my $t = $tests[$i]; for my $p (1, 2) { # repeat everything twice, make sure we do not clobber search arguments local $SIG{__WARN__} = sigwarn_silencer( qr/\Q{from} structures with conditions not conforming to the SQL::Abstract::Classic syntax are deprecated/ ); is_same_sql_bind ( $t->{rs}->search ($t->{search}, $t->{attrs})->as_query, $t->{sqlbind}, sprintf 'Testcase %d, pass %d', $i+1, $p, ); } } done_testing; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/search/reentrancy.t�����������������������������������������������������������0000644�0001750�0001750�00000001536�14240132261�017152� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); my $track_titles = { map { @$_ } $schema->resultset('Track') ->search({}, { columns => [qw(trackid title)] }) ->cursor ->all }; my $rs = $schema->resultset('Track'); for my $pass (1,2,3) { for my $meth (qw(search single find)) { my $id = (keys %$track_titles)[0]; my $tit = delete $track_titles->{$id}; my ($o) = $rs->$meth({ trackid => $id }); is( $rs->count({ trackid => $id }), 1, "Count works (pass $pass)", ); is( $o->title, $tit, "Correct object retrieved via $meth() (pass $pass)" ); $o->delete; is( $rs->count_rs({ trackid => $id })->next, 0, "Count_rs works (pass $pass)", ); } } done_testing; ������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/search/select_chains_unbalanced.t���������������������������������������������0000644�0001750�0001750�00000007030�14240132261�021753� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use lib qw(t/lib); use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); my $multicol_rs = $schema->resultset('Artist')->search({ artistid => \'1' }, { columns => [qw/name rank/] }); my @chain = ( { select => 'cdid', as => 'cd_id', columns => [ 'title' ], } => 'SELECT me.title, me.cdid FROM cd me' => [qw/title cd_id/], { '+select' => \ 'DISTINCT(foo, bar)', '+as' => [qw/foo bar/], } => 'SELECT me.title, me.cdid, DISTINCT(foo, bar) FROM cd me' => [qw/title cd_id foo bar/], { '+select' => [ 'genreid', $multicol_rs->as_query ], '+as' => [qw/genreid name rank/], } => 'SELECT me.title, me.cdid, DISTINCT(foo, bar), me.genreid, (SELECT me.name, me.rank FROM artist me WHERE ( artistid 1 )) FROM cd me' => [qw/title cd_id foo bar genreid name rank/], { '+select' => { count => 'me.cdid', -as => 'cnt' }, # lack of 'as' infers from '-as' '+columns' => { len => { length => 'me.title' } }, } => 'SELECT me.title, LENGTH( me.title ), me.cdid, DISTINCT(foo, bar), me.genreid, (SELECT me.name, me.rank FROM artist me WHERE ( artistid 1 )), COUNT( me.cdid ) AS cnt FROM cd me' => [qw/title len cd_id foo bar genreid name rank cnt/], { '+select' => \'unaliased randomness', } => 'SELECT me.title, LENGTH( me.title ), me.cdid, DISTINCT(foo, bar), me.genreid, (SELECT me.name, me.rank FROM artist me WHERE ( artistid 1 )), COUNT( me.cdid ) AS cnt, unaliased randomness FROM cd me' => [qw/title len cd_id foo bar genreid name rank cnt/], { '+select' => \'MOAR unaliased randomness', } => 'SELECT me.title, LENGTH( me.title ), me.cdid, DISTINCT(foo, bar), me.genreid, (SELECT me.name, me.rank FROM artist me WHERE ( artistid 1 )), COUNT( me.cdid ) AS cnt, unaliased randomness, MOAR unaliased randomness FROM cd me' => [qw/title len cd_id foo bar genreid name rank cnt/], ); my $rs = $schema->resultset('CD'); my $testno = 1; while (@chain) { my $attrs = shift @chain; my $sql = shift @chain; my $as = shift @chain; $rs = $rs->search ({}, $attrs); is_same_sql_bind ( $rs->as_query, "($sql)", [], "Test $testno of SELECT assembly ok", ); is_deeply( $rs->_resolved_attrs->{as}, $as, "Correct dbic-side aliasing for test $testno", ); $testno++; } # make sure proper exceptions are thrown on unbalanced use { my $rs = $schema->resultset('CD')->search({}, { select => \'count(me.cdid)'}); lives_ok(sub { $rs->search({}, { '+select' => 'me.cdid' })->next }, 'Two dark selectors are ok'); throws_ok(sub { $rs->search({}, { '+select' => 'me.cdid', '+as' => 'cdid' })->next }, qr/resultset contains an unnamed selector/, 'Unnamed followed by named is not'); throws_ok(sub { $rs->search_rs({}, { prefetch => 'tracks' })->next }, qr/resultset contains an unnamed selector/, 'Throw on unaliased selector followed by prefetch'); throws_ok(sub { $rs->search_rs({}, { '+select' => 'me.title', '+as' => 'title' })->next }, qr/resultset contains an unnamed selector/, 'Throw on unaliased selector followed by +select/+as'); } done_testing; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/search/empty_attrs.t����������������������������������������������������������0000644�0001750�0001750�00000001757�14240132261�017360� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); my $rs = $schema->resultset('Artist')->search( [ -and => [ {}, [] ], -or => [ {}, [] ] ], { select => [], columns => {}, '+columns' => 'artistid', join => [ {}, [ [ {}, {} ] ], {} ], prefetch => [ [ [ {}, [] ], {} ], {}, [ {} ] ], order_by => [], group_by => [], offset => 0, } ); is_same_sql_bind( $rs->as_query, '(SELECT me.artistid FROM artist me)', [], ); is_same_sql_bind( $rs->count_rs->as_query, '(SELECT COUNT(*) FROM artist me)', [], ); is_same_sql_bind( $rs->as_subselect_rs->search({}, { columns => 'artistid' })->as_query, '(SELECT me.artistid FROM (SELECT me.artistid FROM artist me) me)', [], ); { local $TODO = 'Stupid misdesigned as_subselect_rs'; is_same_sql_bind( $rs->as_subselect_rs->as_query, $rs->as_subselect_rs->search({}, { columns => 'artistid' })->as_query, ); } done_testing; �����������������DBIx-Class-0.082843/t/search/preserve_original_rs.t�������������������������������������������������0000644�0001750�0001750�00000007362�14240132261�021226� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use lib qw(t/lib); use DBICTest ':DiffSQL'; use Storable 'dclone'; my $schema = DBICTest->init_schema(); # A search() with prefetch seems to pollute an already joined resultset # in a way that offsets future joins (adapted from a test case by Debolaz) { my ($cd_rs, $attrs); # test a real-life case - rs is obtained by an implicit m2m join $cd_rs = $schema->resultset ('Producer')->first->cds; $attrs = dclone( $cd_rs->{attrs} ); $cd_rs->search ({})->all; is_deeply (dclone($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after a simple search'); lives_ok (sub { $cd_rs->search ({'artist.artistid' => 1}, { prefetch => 'artist' })->all; is_deeply (dclone($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after search with prefetch'); }, 'first prefetching search ok'); lives_ok (sub { $cd_rs->search ({'artist.artistid' => 1}, { prefetch => 'artist' })->all; is_deeply (dclone($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after another search with prefetch') }, 'second prefetching search ok'); # test a regular rs with an empty seen_join injected - it should still work! $cd_rs = $schema->resultset ('CD'); $cd_rs->{attrs}{seen_join} = {}; $attrs = dclone( $cd_rs->{attrs} ); $cd_rs->search ({})->all; is_deeply (dclone($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after a simple search'); lives_ok (sub { $cd_rs->search ({'artist.artistid' => 1}, { prefetch => 'artist' })->all; is_deeply (dclone($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after search with prefetch'); }, 'first prefetching search ok'); lives_ok (sub { $cd_rs->search ({'artist.artistid' => 1}, { prefetch => 'artist' })->all; is_deeply (dclone($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after another search with prefetch') }, 'second prefetching search ok'); } # Also test search_related, but now that we have as_query simply compare before and after my $artist = $schema->resultset ('Artist')->first; my %q; $q{a2a}{rs} = $artist->search_related ('artwork_to_artist'); $q{a2a}{query} = $q{a2a}{rs}->as_query; $q{artw}{rs} = $q{a2a}{rs}->search_related ('artwork', { }, { join => ['cd', 'artwork_to_artist'] }, ); $q{artw}{query} = $q{artw}{rs}->as_query; $q{cd}{rs} = $q{artw}{rs}->search_related ('cd', {}, { join => [ 'artist', 'tracks' ] } ); $q{cd}{query} = $q{cd}{rs}->as_query; $q{artw_back}{rs} = $q{cd}{rs}->search_related ('artwork', {}, { join => { artwork_to_artist => 'artist' } } )->search_related ('artwork_to_artist', {}, { join => 'artist' }); $q{artw_back}{query} = $q{artw_back}{rs}->as_query; for my $s (qw/a2a artw cd artw_back/) { my $rs = $q{$s}{rs}; lives_ok ( sub { $rs->first }, "first() on $s does not throw an exception" ); lives_ok ( sub { $rs->count }, "count() on $s does not throw an exception" ); is_same_sql_bind ($rs->as_query, $q{$s}{query}, "$s resultset unmodified (as_query matches)" ); } # ensure nothing pollutes the attrs of an existing rs { my $fresh = $schema->resultset('CD'); isa_ok ($fresh->find(1), 'DBICTest::CD' ); isa_ok ($fresh->single({ cdid => 1}), 'DBICTest::CD' ); isa_ok ($fresh->search({ cdid => 1})->next, 'DBICTest::CD' ); is ($fresh->count({ cdid => 1}), 1 ); is ($fresh->count_rs({ cdid => 1})->next, 1 ); ok (! exists $fresh->{cursor}, 'Still no cursor on fresh rs'); ok (! exists $fresh->{_attrs}{_last_sqlmaker_alias_map}, 'aliasmap did not leak through' ); my $n = $fresh->next; # check that we are not testing for deprecated slotnames ok ($fresh->{cursor}, 'Cursor at expected slot after fire'); ok (exists $fresh->{_attrs}{_last_sqlmaker_alias_map}, 'aliasmap at expected slot after fire' ); } done_testing; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/search/deprecated_attributes.t������������������������������������������������0000644�0001750�0001750�00000001703�14240132261�021342� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Warn; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); my $cd_rs = $schema->resultset("CD")->search({ 'me.cdid' => 1 }); warnings_exist( sub { my $cd = $cd_rs->search( undef, { cols => [ { name => 'artist.name' } ], join => 'artist', })->next; is_deeply ( { $cd->get_inflated_columns }, { name => 'Caterwauler McCrae' }, 'cols attribute still works', ); }, qr/Resultset attribute 'cols' is deprecated/, 'deprecation warning when passing cols attribute'); warnings_exist( sub { my $cd = $cd_rs->search_rs( undef, { include_columns => [ { name => 'artist.name' } ], join => 'artist', })->next; is ( $cd->get_column('name'), 'Caterwauler McCrae', 'include_columns attribute still works', ); }, qr/Resultset attribute 'include_columns' is deprecated/, 'deprecation warning when passing include_columns attribute'); done_testing; �������������������������������������������������������������DBIx-Class-0.082843/t/search/stack_cond.t�����������������������������������������������������������0000644�0001750�0001750�00000005716�14240132261�017114� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest ':DiffSQL'; use SQL::Abstract::Util qw(is_plain_value is_literal_value); use List::Util 'shuffle'; use Data::Dumper; $Data::Dumper::Terse = 1; $Data::Dumper::Useqq = 1; $Data::Dumper::Indent = 0; my $schema = DBICTest->init_schema(); for my $c ( { cond => undef, sql => 'IS NULL' }, { cond => { -value => undef }, sql => 'IS NULL' }, { cond => \'foo', sql => '= foo' }, { cond => 'foo', sql => '= ?', bind => [ [ { dbic_colname => "title", sqlt_datatype => "varchar", sqlt_size => 100 } => 'foo' ], [ { dbic_colname => "year", sqlt_datatype => "varchar", sqlt_size => 100 } => 'foo' ], ]}, { cond => { -value => 'foo' }, sql => '= ?', bind => [ [ { dbic_colname => "title", sqlt_datatype => "varchar", sqlt_size => 100 } => 'foo' ], [ { dbic_colname => "year", sqlt_datatype => "varchar", sqlt_size => 100 } => 'foo' ], ]}, { cond => \[ '?', "foo" ], sql => '= ?', bind => [ [ {} => 'foo' ], [ {} => 'foo' ], ]}, { cond => { '@>' => { -value => [ 1,2,3 ] } }, sql => '@> ?', bind => [ [ { dbic_colname => "title", sqlt_datatype => "varchar", sqlt_size => 100 } => [1, 2, 3] ], [ { dbic_colname => "year", sqlt_datatype => "varchar", sqlt_size => 100 } => [1, 2, 3] ], ]}, ) { my $rs = $schema->resultset('CD')->search({}, { columns => 'title' }); my $bare_cond = is_literal_value($c->{cond}) ? { '=', $c->{cond} } : $c->{cond}; my @query_steps = ( # these are monkey-wrenches, always there { title => { '!=', [ -and => \'bar' ] }, year => { '!=', [ -and => 'bar' ] } }, { -or => [ genreid => undef, genreid => { '!=' => \42 } ] }, { -or => [ genreid => undef, genreid => { '!=' => \42 } ] }, { title => $bare_cond, year => { '=', $c->{cond} } }, { -and => [ year => $bare_cond, { title => { '=', $c->{cond} } } ] }, [ year => $bare_cond ], [ title => $bare_cond ], { -and => [ { year => { '=', $c->{cond} } }, { title => { '=', $c->{cond} } } ] }, { -and => { -or => { year => { '=', $c->{cond} } } }, -or => { title => $bare_cond } }, ); if (my $v = is_plain_value($c->{cond})) { push @query_steps, { year => $$v }, { title => $$v }, { -and => [ year => $$v, title => $$v ] }, ; } @query_steps = shuffle @query_steps; $rs = $rs->search($_) for @query_steps; my @bind = @{$c->{bind} || []}; { no warnings 'misc'; splice @bind, 1, 0, [ { dbic_colname => "year", sqlt_datatype => "varchar", sqlt_size => 100 } => 'bar' ]; } is_same_sql_bind ( $rs->as_query, "( SELECT me.title FROM cd me WHERE ( genreid != 42 OR genreid IS NULL ) AND ( genreid != 42 OR genreid IS NULL ) AND title != bar AND title $c->{sql} AND year != ? AND year $c->{sql} )", \@bind, 'Double condition correctly collapsed for steps' . Dumper \@query_steps, ); } done_testing; ��������������������������������������������������DBIx-Class-0.082843/t/search/select_chains.t��������������������������������������������������������0000644�0001750�0001750�00000011032�14240132261�017574� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); my @chain = ( { columns => [ 'cdid' ], '+columns' => [ { title_lc => { lower => 'title', -as => 'lctitle' } } ], '+select' => [ 'genreid' ], '+as' => [ 'genreid' ], } => 'SELECT me.cdid, LOWER( title ) AS lctitle, me.genreid FROM cd me', { '+columns' => [ { max_year => { max => 'me.year', -as => 'last_y' }}, ], '+select' => [ { count => 'me.cdid' }, ], '+as' => [ 'cnt' ], } => 'SELECT me.cdid, LOWER( title ) AS lctitle, MAX( me.year ) AS last_y, me.genreid, COUNT( me.cdid ) FROM cd me', { select => [ { min => 'me.cdid' }, ], as => [ 'min_id' ], } => 'SELECT MIN( me.cdid ) FROM cd me', { '+columns' => [ { cnt => { count => 'cdid', -as => 'cnt' } } ], } => 'SELECT COUNT ( cdid ) AS cnt, MIN( me.cdid ) FROM cd me', { columns => [ { foo => { coalesce => [qw/a b c/], -as => 'firstfound' } } ], } => 'SELECT COALESCE( a, b, c ) AS firstfound FROM cd me', { '+columns' => [ 'me.year' ], '+select' => [ { max => 'me.year', -as => 'last_y' } ], '+as' => [ 'ly' ], } => 'SELECT COALESCE( a, b, c ) AS firstfound, me.year, MAX( me.year ) AS last_y FROM cd me', { '+select' => [ { count => 'me.cdid', -as => 'cnt' } ], '+as' => [ 'cnt' ], } => 'SELECT COALESCE( a, b, c ) AS firstfound, me.year, MAX( me.year ) AS last_y, COUNT( me.cdid ) AS cnt FROM cd me', # adding existing stuff should not alter selector { '+select' => [ 'me.year' ], '+as' => [ 'year' ], } => 'SELECT COALESCE( a, b, c ) AS firstfound, me.year, MAX( me.year ) AS last_y, COUNT( me.cdid ) AS cnt, me.year FROM cd me', { '+columns' => [ 'me.year' ], } => 'SELECT COALESCE( a, b, c ) AS firstfound, me.year, MAX( me.year ) AS last_y, COUNT( me.cdid ) AS cnt, me.year FROM cd me', { '+columns' => 'me.year', } => 'SELECT COALESCE( a, b, c ) AS firstfound, me.year, MAX( me.year ) AS last_y, COUNT( me.cdid ) AS cnt, me.year FROM cd me', # naked selector at the end should just work { '+select' => 'me.moar_stuff', } => 'SELECT COALESCE( a, b, c ) AS firstfound, me.year, MAX( me.year ) AS last_y, COUNT( me.cdid ) AS cnt, me.year, me.moar_stuff FROM cd me', { '+select' => [ { MOAR => 'f', -as => 'func' } ], } => 'SELECT COALESCE( a, b, c ) AS firstfound, me.year, MAX( me.year ) AS last_y, COUNT( me.cdid ) AS cnt, me.year, me.moar_stuff, MOAR(f) AS func FROM cd me', ); my $rs = $schema->resultset('CD'); my $testno = 1; while (@chain) { my $attrs = shift @chain; my $sql = shift @chain; $rs = $rs->search ({}, $attrs); is_same_sql_bind ( $rs->as_query, "($sql)", [], "Test $testno of SELECT assembly ok", ); $testno++; } # Make sure we don't lose bits even with weird selector specs # also check that the default selector list is lazy # and make sure that unaliased +select does not go crazy $rs = $schema->resultset('CD'); for my $attr ( { '+columns' => [ 'me.title' ] }, # this one should be de-duplicated but not the select's { '+select' => \'me.year AS foo' }, # duplication of identical select expected (FIXME ?) { '+select' => \['me.year AS foo'] }, { '+select' => [ \'me.artistid AS bar' ] }, { '+select' => { count => 'artistid', -as => 'baz' } }, ) { for (qw/columns select as/) { ok (! exists $rs->{attrs}{$_}, "No eager '$_' attr on fresh resultset" ); } $rs = $rs->search({}, $attr); } is_same_sql_bind ( $rs->as_query, '( SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track, me.year AS foo, me.year AS foo, me.artistid AS bar, COUNT( artistid ) AS baz FROM cd me )', [], 'Correct chaining before attr resolution' ); # Test the order of columns $rs = $schema->resultset('CD')->search ({}, { 'select' => [ 'me.cdid', 'me.title' ], }); is_same_sql_bind ( $rs->as_query, '( SELECT me.cdid, me.title FROM cd me )', [], 'Correct order of selected columns' ); # Test bare +select with as from root of resultset $rs = $schema->resultset('CD')->search ({}, { '+select' => [ \ 'foo', { MOAR => 'f', -as => 'func' }, ], }); is_same_sql_bind ( $rs->as_query, '( SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track, foo, MOAR( f ) AS func FROM cd me )', [], 'Correct order of selected columns' ); done_testing; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/search/void.t�����������������������������������������������������������������0000644�0001750�0001750�00000000447�14240132261�015741� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(no_deploy => 1); throws_ok { $schema->resultset('Artist')->search } qr/\Qsearch is *not* a mutator/, 'Proper exception on search in void ctx'; done_testing; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/search/distinct.t�������������������������������������������������������������0000644�0001750�0001750�00000005043�14240132261�016616� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); # make sure order + distinct do not double-inject group criteria my $rs = $schema->resultset ('CD')->search ({}, { distinct => 1, columns => 'title', }); # title + cdid == unique constraint my $unique_rs = $rs->search ({}, { '+columns' => 'cdid', }); is_same_sql_bind ( $rs->search({}, { order_by => 'title' })->as_query, '( SELECT me.title FROM cd me GROUP BY me.title ORDER BY title )', [], 'Correct GROUP BY on selection+order_by on same column', ); is_same_sql_bind ( $rs->search({}, { order_by => 'year' })->as_query, '( SELECT me.title FROM cd me GROUP BY me.title ORDER BY MIN(year) )', [], 'Correct GROUP BY on non-unique selection and order by a different column', ); is_same_sql_bind ( $unique_rs->search({}, { order_by => 'year' })->as_query, '( SELECT me.title, me.cdid FROM cd me GROUP BY me.title, me.cdid, me.year ORDER BY year )', [], 'Correct GROUP BY on unique selection and order by a different column', ); is_same_sql_bind ( $rs->search({}, { order_by => 'artist.name', join => 'artist' })->as_query, '( SELECT me.title FROM cd me JOIN artist artist ON artist.artistid = me.artist GROUP BY me.title ORDER BY MIN(artist.name) )', [], 'Correct GROUP BY on non-unique selection and external single order_by', ); is_same_sql_bind ( $unique_rs->search({}, { order_by => 'artist.name', join => 'artist' })->as_query, '( SELECT me.title, me.cdid FROM cd me JOIN artist artist ON artist.artistid = me.artist GROUP BY me.title, me.cdid, artist.name ORDER BY artist.name )', [], 'Correct GROUP BY on unique selection and external single order_by', ); is_same_sql_bind ( $rs->search({}, { order_by => 'tracks.title', join => 'tracks' })->as_query, '( SELECT me.title FROM cd me LEFT JOIN track tracks ON tracks.cd = me.cdid GROUP BY me.title ORDER BY MIN(tracks.title) )', [], 'Correct GROUP BY on non-unique selection and external multi order_by', ); is_same_sql_bind ( $unique_rs->search({}, { order_by => 'tracks.title', join => 'tracks' })->as_query, '( SELECT me.title, me.cdid FROM cd me LEFT JOIN track tracks ON tracks.cd = me.cdid GROUP BY me.title, me.cdid ORDER BY MIN(tracks.title) )', [], 'Correct GROUP BY on unique selection and external multi order_by', ); done_testing; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/search/related_strip_prefetch.t�����������������������������������������������0000644�0001750�0001750�00000002246�14240132261�021520� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest ':DiffSQL'; my $ROWS = DBIx::Class::SQLMaker::ClassicExtensions->__rows_bindtype; my $schema = DBICTest->init_schema(); my $rs = $schema->resultset('CD')->search ( { 'tracks.trackid' => { '!=', 666 }}, { join => 'artist', prefetch => 'tracks', rows => 2 } ); my $rel_rs = $rs->search_related ('tags', { 'tags.tag' => { '!=', undef }}, { distinct => 1}); is_same_sql_bind ( $rel_rs->as_query, '( SELECT tags.tagid, tags.cd, tags.tag FROM ( SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me JOIN artist artist ON artist.artistid = me.artist LEFT JOIN track tracks ON tracks.cd = me.cdid WHERE ( tracks.trackid != ? ) LIMIT ? ) me JOIN artist artist ON artist.artistid = me.artist JOIN tags tags ON tags.cd = me.cdid WHERE ( tags.tag IS NOT NULL ) GROUP BY tags.tagid, tags.cd, tags.tag )', [ [ { sqlt_datatype => 'integer', dbic_colname => 'tracks.trackid' } => 666 ], [ $ROWS => 2 ] ], 'Prefetch spec successfully stripped on search_related' ); done_testing; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/search/related_has_many.t�����������������������������������������������������0000644�0001750�0001750�00000001307�14240132261�020273� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); my $cd_rs = $schema->resultset('CD')->search ({ artist => { '!=', undef }}); # create some CDs without tracks $cd_rs->create({ artist => 1, title => 'trackless_foo', year => 2010 }); $cd_rs->create({ artist => 1, title => 'trackless_bar', year => 2010 }); my $tr_count = $schema->resultset('Track')->count; my $tr_rs = $cd_rs->search_related('tracks'); my @tracks; while ($tr_rs->next) { push @tracks, $_; } is (scalar @tracks, $tr_count, 'Iteration is correct'); is ($tr_rs->count, $tr_count, 'Count is correct'); is (scalar ($tr_rs->all), $tr_count, 'All is correct'); done_testing; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/storage/����������������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�015026� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/storage/stats.t���������������������������������������������������������������0000644�0001750�0001750�00000003670�14240132261�016336� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; plan tests => 12; use lib qw(t/lib); use_ok('DBICTest'); my $schema = DBICTest->init_schema(); my $cbworks = 0; $schema->storage->debugcb(sub { $cbworks = 1; }); $schema->storage->debug(0); my $rs = $schema->resultset('CD')->search({}); $rs->count(); ok(!$cbworks, 'Callback not called with debug disabled'); $schema->storage->debug(1); $rs->count(); ok($cbworks, 'Debug callback worked.'); my $prof = new DBIx::Test::Profiler(); $schema->storage->debugobj($prof); # Test non-transaction calls. $rs->count(); ok($prof->{'query_start'}, 'query_start called'); ok($prof->{'query_end'}, 'query_end called'); ok(!$prof->{'txn_begin'}, 'txn_begin not called'); ok(!$prof->{'txn_commit'}, 'txn_commit not called'); $prof->reset(); # Test transaction calls $schema->txn_begin(); ok($prof->{'txn_begin'}, 'txn_begin called'); $rs = $schema->resultset('CD')->search({}); $rs->count(); ok($prof->{'query_start'}, 'query_start called'); ok($prof->{'query_end'}, 'query_end called'); $schema->txn_commit(); ok($prof->{'txn_commit'}, 'txn_commit called'); $prof->reset(); # Test a rollback $schema->txn_begin(); $rs = $schema->resultset('CD')->search({}); $rs->count(); $schema->txn_rollback(); ok($prof->{'txn_rollback'}, 'txn_rollback called'); $schema->storage->debug(0); package DBIx::Test::Profiler; use strict; sub new { my $self = bless({}); } sub query_start { my $self = shift(); $self->{'query_start'} = 1; } sub query_end { my $self = shift(); $self->{'query_end'} = 1; } sub txn_begin { my $self = shift(); $self->{'txn_begin'} = 1; } sub txn_rollback { my $self = shift(); $self->{'txn_rollback'} = 1; } sub txn_commit { my $self = shift(); $self->{'txn_commit'} = 1; } sub reset { my $self = shift(); $self->{'query_start'} = 0; $self->{'query_end'} = 0; $self->{'txn_begin'} = 0; $self->{'txn_rollback'} = 0; $self->{'txn_end'} = 0; } 1; ������������������������������������������������������������������������DBIx-Class-0.082843/t/storage/prefer_stringification.t����������������������������������������������0000644�0001750�0001750�00000001244�14240132261�021732� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use warnings; use strict; use Test::More; use lib qw(t/lib); use DBICTest; { package # hideee DBICTest::CrazyInt; use overload '0+' => sub { 666 }, '""' => sub { 999 }, fallback => 1, ; } # check DBI behavior when fed a stringifiable/nummifiable value { my $crazynum = bless {}, 'DBICTest::CrazyInt'; cmp_ok( $crazynum, '==', 666 ); cmp_ok( $crazynum, 'eq', 999 ); my $schema = DBICTest->init_schema( no_populate => 1 ); $schema->storage->dbh_do(sub { $_[1]->do('INSERT INTO artist (name) VALUES (?)', {}, $crazynum ); }); is( $schema->resultset('Artist')->next->name, 999, 'DBI preferred stringified version' ); } done_testing; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/storage/dbh_do.t��������������������������������������������������������������0000644�0001750�0001750�00000001763�14240132261�016420� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); my $storage = $schema->storage; # test (re)connection for my $disconnect (0, 1) { $schema->storage->_dbh->disconnect if $disconnect; is_deeply ( $schema->storage->dbh_do(sub { $_[1]->selectall_arrayref('SELECT 1') }), [ [ 1 ] ], 'dbh_do on fresh handle worked', ); } my @args; my $test_func = sub { @args = @_ }; $storage->dbh_do($test_func, "foo", "bar"); is_deeply ( \@args, [ $storage, $storage->dbh, "foo", "bar" ], ); my $storage_class = ref $storage; { no strict 'refs'; local *{$storage_class .'::__test_method'} = $test_func; $storage->dbh_do("__test_method", "baz", "buz"); } is_deeply ( \@args, [ $storage, $storage->dbh, "baz", "buz" ], ); # test nested aliasing my $res = 'original'; $storage->dbh_do (sub { shift->dbh_do(sub { $_[3] = 'changed' }, @_) }, $res); is ($res, 'changed', "Arguments properly aliased for dbh_do"); done_testing; �������������DBIx-Class-0.082843/t/storage/deprecated_exception_source_bind_attrs.t������������������������������0000644�0001750�0001750�00000001206�14240132261�025140� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Warn; use Test::Exception; use lib qw(t/lib); use DBICTest; { package DBICTest::Legacy::Storage; use base 'DBIx::Class::Storage::DBI::SQLite'; use Data::Dumper::Concise; sub source_bind_attributes { return {} } } my $schema = DBICTest::Schema->clone; $schema->storage_type('DBICTest::Legacy::Storage'); $schema->connection('dbi:SQLite::memory:'); throws_ok { $schema->storage->ensure_connected } qr/\Qstorage subclass DBICTest::Legacy::Storage provides (or inherits) the method source_bind_attributes()/, 'deprecated use of source_bind_attributes throws', ; done_testing; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/storage/deploy.t��������������������������������������������������������������0000644�0001750�0001750�00000004131�14240132261�016465� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use Path::Class qw/dir/; use lib qw(t/lib); use DBICTest; BEGIN { require DBIx::Class; plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('deploy') unless DBIx::Class::Optional::Dependencies->req_ok_for ('deploy') } local $ENV{DBI_DSN}; # this is how maint/gen_schema did it (connect() to force a storage # instance, but no conninfo) # there ought to be more code like this in the wild like( DBICTest::Schema->connect->deployment_statements('SQLite'), qr/\bCREATE TABLE artist\b/i # ensure quoting *is* disabled ); lives_ok( sub { my $parse_schema = DBICTest->init_schema(no_deploy => 1); $parse_schema->deploy({},'t/lib/test_deploy'); $parse_schema->resultset("Artist")->all(); }, 'artist table deployed correctly' ); my $schema = DBICTest->init_schema( quote_names => 1 ); my $var = dir ("t/var/ddl_dir-$$"); $var->mkpath unless -d $var; my $test_dir_1 = $var->subdir ('test1', 'foo', 'bar' ); $test_dir_1->rmtree if -d $test_dir_1; $schema->create_ddl_dir( [qw(SQLite MySQL)], 1, $test_dir_1 ); ok( -d $test_dir_1, 'create_ddl_dir did a make_path on its target dir' ); ok( scalar( glob $test_dir_1.'/*.sql' ), 'there are sql files in there' ); my $less = $schema->clone; $less->unregister_source('BindType'); $less->create_ddl_dir( [qw(SQLite MySQL)], 2, $test_dir_1, 1 ); for ( [ SQLite => '"' ], [ MySQL => '`' ], ) { my $type = $_->[0]; my $q = quotemeta($_->[1]); for my $f (map { $test_dir_1->file("DBICTest-Schema-${_}-$type.sql") } qw(1 2) ) { like scalar $f->slurp, qr/CREATE TABLE ${q}track${q}/, "Proper quoting in $f"; } { local $TODO = 'SQLT::Producer::MySQL has no knowledge of the mythical beast of quoting...' if $type eq 'MySQL'; my $f = $test_dir_1->file("DBICTest-Schema-1-2-$type.sql"); like scalar $f->slurp, qr/DROP TABLE ${q}bindtype_test${q}/, "Proper quoting in diff $f"; } } { local $TODO = 'we should probably add some tests here for actual deployability of the DDL?'; ok( 0 ); } END { $var->rmtree; } done_testing; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/storage/on_connect_call.t�����������������������������������������������������0000644�0001750�0001750�00000005672�14240132261�020324� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; no warnings qw/once redefine/; use lib qw(t/lib); use DBI; use DBICTest; use DBICTest::Schema; use DBIx::Class::Storage::DBI; # !!! do not replace this with done_testing - tests reside in the callbacks # !!! number of calls is important use Test::More tests => 17; # !!! use Test::Warn; my $schema = DBICTest::Schema->clone; { *DBIx::Class::Storage::DBI::connect_call_foo = sub { isa_ok $_[0], 'DBIx::Class::Storage::DBI', 'got storage in connect_call method'; is $_[1], 'bar', 'got param in connect_call method'; }; *DBIx::Class::Storage::DBI::disconnect_call_foo = sub { isa_ok $_[0], 'DBIx::Class::Storage::DBI', 'got storage in disconnect_call method'; }; ok $schema->connection( DBICTest->_database, { on_connect_call => [ [ do_sql => 'create table test1 (id integer)' ], [ do_sql => [ 'insert into test1 values (?)', {}, 1 ] ], [ do_sql => sub { ['insert into test1 values (2)'] } ], [ sub { $_[0]->dbh->do($_[1]) }, 'insert into test1 values (3)' ], # this invokes $storage->connect_call_foo('bar') (above) [ foo => 'bar' ], ], on_connect_do => 'insert into test1 values (4)', on_disconnect_call => 'foo', }, ), 'connection()'; ok (! $schema->storage->connected, 'start disconnected'); is_deeply ( $schema->storage->dbh->selectall_arrayref('select * from test1'), [ [ 1 ], [ 2 ], [ 3 ], [ 4 ] ], 'on_connect_call/do actions worked' ); $schema->storage->disconnect; } { *DBIx::Class::Storage::DBI::connect_call_foo = sub { isa_ok $_[0], 'DBIx::Class::Storage::DBI', 'got storage in connect_call method'; }; *DBIx::Class::Storage::DBI::connect_call_bar = sub { isa_ok $_[0], 'DBIx::Class::Storage::DBI', 'got storage in connect_call method'; }; ok $schema->connection( DBICTest->_database, { # method list form on_connect_call => [ 'foo', sub { ok 1, "coderef in list form" }, 'bar' ], }, ), 'connection()'; ok (! $schema->storage->connected, 'start disconnected'); $schema->storage->ensure_connected; $schema->storage->disconnect; # this should not fire any tests } { ok $schema->connection( sub { DBI->connect(DBICTest->_database, undef, undef, { AutoCommit => 0 } ) }, { # method list form on_connect_call => [ sub { ok 1, "on_connect_call after DT parser" }, ], on_disconnect_call => [ sub { ok 1, "on_disconnect_call after DT parser" }, ], }, ), 'connection()'; ok (! $schema->storage->connected, 'start disconnected'); # this should connect due to the coderef, and also warn due to the false autocommit above warnings_exist { $schema->storage->_determine_driver } qr/The 'RaiseError' of the externally supplied DBI handle is set to false/, 'Warning on clobbered AutoCommit => 0 fired'; ok ($schema->storage->connected, 'determine driver connects'); $schema->storage->disconnect; } ����������������������������������������������������������������������DBIx-Class-0.082843/t/storage/savepoints.t����������������������������������������������������������0000644�0001750�0001750�00000016353�14240132261�017375� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use DBIx::Class::Optional::Dependencies; use DBIx::Class::_Util qw(sigwarn_silencer scope_guard); use Scalar::Util 'weaken'; use lib qw(t/lib); use DBICTest; { package # moar hide DBICTest::SVPTracerObj; use base 'DBIx::Class::Storage::Statistics'; sub query_start { 'do notning'} sub callback { 'dummy '} for my $svpcall (map { "svp_$_" } qw(begin rollback release)) { no strict 'refs'; *$svpcall = sub { $_[0]{uc $svpcall}++ }; } } my $env2optdep = { DBICTEST_PG => 'test_rdbms_pg', DBICTEST_MYSQL => 'test_rdbms_mysql', }; my $schema; for ('', keys %$env2optdep) { SKIP: { my $prefix; if ($prefix = $_) { my ($dsn, $user, $pass) = map { $ENV{"${prefix}_$_"} } qw/DSN USER PASS/; skip ("Skipping tests with $prefix: set \$ENV{${prefix}_DSN} _USER and _PASS", 1) unless $dsn; skip ("Testing with ${prefix}_DSN needs " . DBIx::Class::Optional::Dependencies->req_missing_for( $env2optdep->{$prefix} ), 1) unless DBIx::Class::Optional::Dependencies->req_ok_for($env2optdep->{$prefix}); $schema = DBICTest::Schema->connect ($dsn,$user,$pass,{ auto_savepoint => 1 }); my $create_sql; $schema->storage->ensure_connected; if ($schema->storage->isa('DBIx::Class::Storage::DBI::Pg')) { $create_sql = "CREATE TABLE artist (artistid serial PRIMARY KEY, name VARCHAR(100), rank INTEGER NOT NULL DEFAULT '13', charfield CHAR(10))"; $schema->storage->dbh->do('SET client_min_messages=WARNING'); } elsif ($schema->storage->isa('DBIx::Class::Storage::DBI::mysql')) { $create_sql = "CREATE TABLE artist (artistid INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY, name VARCHAR(100), rank INTEGER NOT NULL DEFAULT '13', charfield CHAR(10)) ENGINE=InnoDB"; } else { skip( 'Untested driver ' . $schema->storage, 1 ); } $schema->storage->dbh_do (sub { $_[1]->do('DROP TABLE IF EXISTS artist'); $_[1]->do($create_sql); }); } else { $prefix = 'SQLite Internal DB'; $schema = DBICTest->init_schema( no_populate => 1, auto_savepoint => 1 ); } note "Testing $prefix"; local $schema->storage->{debugobj} = my $stats = DBICTest::SVPTracerObj->new; local $schema->storage->{debug} = 1; $schema->resultset('Artist')->create({ name => 'foo' }); $schema->txn_begin; my $arty = $schema->resultset('Artist')->find(1); my $name = $arty->name; # First off, test a generated savepoint name $schema->svp_begin; cmp_ok($stats->{'SVP_BEGIN'}, '==', 1, 'Statistics svp_begin tickled'); $arty->update({ name => 'Jheephizzy' }); $arty->discard_changes; cmp_ok($arty->name, 'eq', 'Jheephizzy', 'Name changed'); # Rollback the generated name # Active: 0 $schema->svp_rollback; cmp_ok($stats->{'SVP_ROLLBACK'}, '==', 1, 'Statistics svp_rollback tickled'); $arty->discard_changes; cmp_ok($arty->name, 'eq', $name, 'Name rolled back'); $arty->update({ name => 'Jheephizzy'}); # Active: 0 1 $schema->svp_begin('testing1'); $arty->update({ name => 'yourmom' }); # Active: 0 1 2 $schema->svp_begin('testing2'); $arty->update({ name => 'gphat' }); $arty->discard_changes; cmp_ok($arty->name, 'eq', 'gphat', 'name changed'); # Active: 0 1 2 # Rollback doesn't DESTROY the savepoint, it just rolls back to the value # at its conception $schema->svp_rollback('testing2'); $arty->discard_changes; cmp_ok($arty->name, 'eq', 'yourmom', 'testing2 reverted'); # Active: 0 1 2 3 $schema->svp_begin('testing3'); $arty->update({ name => 'coryg' }); # Active: 0 1 2 3 4 $schema->svp_begin('testing4'); $arty->update({ name => 'watson' }); # Release 3, which implicitly releases 4 # Active: 0 1 2 $schema->svp_release('testing3'); $arty->discard_changes; cmp_ok($arty->name, 'eq', 'watson', 'release left data'); # This rolls back savepoint 2 # Active: 0 1 2 $schema->svp_rollback; $arty->discard_changes; cmp_ok($arty->name, 'eq', 'yourmom', 'rolled back to 2'); # Rollback the original savepoint, taking us back to the beginning, implicitly # rolling back savepoint 1 and 2 $schema->svp_rollback('savepoint_0'); $arty->discard_changes; cmp_ok($arty->name, 'eq', 'foo', 'rolled back to start'); $schema->txn_commit; is_deeply( $schema->storage->savepoints, [], 'All savepoints forgotten' ); # And now to see if txn_do will behave correctly $schema->txn_do (sub { my $artycp = $arty; $schema->txn_do (sub { $artycp->name ('Muff'); $artycp->update; }); eval { $schema->txn_do (sub { $artycp->name ('Moff'); $artycp->update; $artycp->discard_changes; is($artycp->name,'Moff','Value updated in nested transaction'); $schema->storage->dbh->do ("GUARANTEED TO PHAIL"); }); }; ok ($@,'Nested transaction failed (good)'); $arty->discard_changes; is($arty->name,'Muff','auto_savepoint rollback worked'); $arty->name ('Miff'); $arty->update; }); is_deeply( $schema->storage->savepoints, [], 'All savepoints forgotten' ); $arty->discard_changes; is($arty->name,'Miff','auto_savepoint worked'); cmp_ok($stats->{'SVP_BEGIN'},'==',7,'Correct number of savepoints created'); cmp_ok($stats->{'SVP_RELEASE'},'==',3,'Correct number of savepoints released'); cmp_ok($stats->{'SVP_ROLLBACK'},'==',5,'Correct number of savepoint rollbacks'); ### test originally written for SQLite exclusively (git blame -w -C -M) # test two-phase commit and inner transaction rollback from nested transactions my $ars = $schema->resultset('Artist'); $schema->txn_do(sub { $ars->create({ name => 'in_outer_transaction' }); $schema->txn_do(sub { $ars->create({ name => 'in_inner_transaction' }); }); ok($ars->search({ name => 'in_inner_transaction' })->first, 'commit from inner transaction visible in outer transaction'); throws_ok { $schema->txn_do(sub { $ars->create({ name => 'in_inner_transaction_rolling_back' }); die 'rolling back inner transaction'; }); } qr/rolling back inner transaction/, 'inner transaction rollback executed'; $ars->create({ name => 'in_outer_transaction2' }); }); is_deeply( $schema->storage->savepoints, [], 'All savepoints forgotten' ); ok($ars->search({ name => 'in_outer_transaction' })->first, 'commit from outer transaction'); ok($ars->search({ name => 'in_outer_transaction2' })->first, 'second commit from outer transaction'); ok($ars->search({ name => 'in_inner_transaction' })->first, 'commit from inner transaction'); is $ars->search({ name => 'in_inner_transaction_rolling_back' })->first, undef, 'rollback from inner transaction'; # make sure a fresh txn will work after above $schema->storage->txn_do(sub { ok "noop" } ); ### Make sure non-existend savepoint release doesn't infloop itself { weaken( my $s = $schema ); throws_ok { $s->storage->txn_do(sub { $s->svp_release('wibble') }) } qr/Savepoint 'wibble' does not exist/, "Calling svp_release on a non-existant savepoint throws expected error" ; } ### cleanupz $schema->storage->dbh->do ("DROP TABLE artist"); }} done_testing; END { eval { $schema->storage->dbh_do(sub { $_[1]->do("DROP TABLE artist") }) } if defined $schema; undef $schema; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/storage/txn.t�����������������������������������������������������������������0000644�0001750�0001750�00000030735�14240132261�016013� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Warn; use Test::Exception; use lib qw(t/lib); use DBICTest; my $code = sub { my ($artist, @cd_titles) = @_; $artist->create_related('cds', { title => $_, year => 2006, }) foreach (@cd_titles); return $artist->cds->all; }; # Test checking of parameters { my $schema = DBICTest->init_schema; throws_ok (sub { (ref $schema)->txn_do(sub{}); }, qr/storage/, "can't call txn_do without storage"); throws_ok { $schema->txn_do(''); } qr/\Qrun() requires a coderef to execute as its first argument/, '$coderef parameter check ok'; } # Test successful txn_do() - scalar/list context for my $want (0,1) { my $schema = DBICTest->init_schema; is( $schema->storage->{transaction_depth}, 0, 'txn depth starts at 0'); my @titles = map {'txn_do test CD ' . $_} (1..5); my $artist = $schema->resultset('Artist')->find(1); my $count_before = $artist->cds->count; my @res; if ($want) { @res = $schema->txn_do($code, $artist, @titles); is(scalar @res, $count_before+5, 'successful txn added 5 cds'); } else { $res[0] = $schema->txn_do($code, $artist, @titles); is($res[0], $count_before+5, 'successful txn added 5 cds'); } is($artist->cds({ title => "txn_do test CD $_", })->first->year, 2006, "new CD $_ year correct") for (1..5); is( $schema->storage->{transaction_depth}, 0, 'txn depth has been reset'); } # Test txn_do() @_ aliasing support { my $schema = DBICTest->init_schema; my $res = 'original'; $schema->storage->txn_do (sub { $_[0] = 'changed' }, $res); is ($res, 'changed', "Arguments properly aliased for txn_do"); } # Test nested successful txn_do() { my $schema = DBICTest->init_schema; is( $schema->storage->{transaction_depth}, 0, 'txn depth starts at 0'); my $nested_code = sub { my ($schema, $artist, $code) = @_; my @titles1 = map {'nested txn_do test CD ' . $_} (1..5); my @titles2 = map {'nested txn_do test CD ' . $_} (6..10); $schema->txn_do($code, $artist, @titles1); $schema->txn_do($code, $artist, @titles2); }; my $artist = $schema->resultset('Artist')->find(2); my $count_before = $artist->cds->count; lives_ok (sub { $schema->txn_do($nested_code, $schema, $artist, $code); }, 'nested txn_do succeeded'); is($artist->cds({ title => 'nested txn_do test CD '.$_, })->first->year, 2006, qq{nested txn_do CD$_ year ok}) for (1..10); is($artist->cds->count, $count_before+10, 'nested txn_do added all CDs'); is( $schema->storage->{transaction_depth}, 0, 'txn depth has been reset'); } # test nested txn_begin on fresh connection { my $schema = DBICTest->init_schema(sqlite_use_file => 1, no_deploy => 1); $schema->storage->ensure_connected; is ($schema->storage->transaction_depth, 0, 'Start outside txn'); my @pids; SKIP: for my $action ( sub { my $s = shift; die "$$ starts in txn!" if $s->storage->transaction_depth != 0; $s->txn_do ( sub { die "$$ not in txn!" if $s->storage->transaction_depth == 0; $s->storage->dbh->do('SELECT 1') } ); die "$$ did not finish txn!" if $s->storage->transaction_depth != 0; }, sub { $_[0]->txn_begin; $_[0]->storage->dbh->do('SELECT 1'); $_[0]->txn_commit }, sub { my $guard = $_[0]->txn_scope_guard; $_[0]->storage->dbh->do('SELECT 1'); $guard->commit }, ) { my $pid = fork(); if( ! defined $pid ) { skip "EAGAIN encountered, your system is likely bogged down: skipping forking test", 1 if $! == Errno::EAGAIN(); die "Unable to fork: $!" } if ($pid) { push @pids, $pid; next; } $action->($schema); exit 0; } is ($schema->storage->transaction_depth, 0, 'Parent still outside txn'); for my $pid (@pids) { waitpid ($pid, 0); ok (! $?, "Child $pid exit ok"); } } # Test txn_do/scope_guard with forking: outer txn_do { my $schema = DBICTest->init_schema( sqlite_use_file => 1 ); for my $pass (1..2) { # do something trying to destabilize the depth count for (1..2) { eval { my $guard = $schema->txn_scope_guard; $schema->txn_do( sub { die } ); }; is( $schema->storage->transaction_depth, 0, 'Transaction successfully aborted' ); $schema->txn_do( sub { ok ($schema->storage->_dbh->do ('SELECT 1'), "Query after exceptions ok ($_)"); }); } $schema->txn_do ( sub { _test_forking_action ($schema, $pass) } ); } } # same test with outer guard { my $schema = DBICTest->init_schema( sqlite_use_file => 1 ); for my $pass (1..2) { # do something trying to destabilize the depth count for (1..2) { eval { my $guard = $schema->txn_scope_guard; $schema->txn_do( sub { die } ); }; is( $schema->storage->transaction_depth, 0, 'Transaction successfully aborted' ); $schema->txn_do( sub { ok ($schema->storage->_dbh->do ('SELECT 1'), "Query after exceptions ok ($_)"); }); } my $guard = $schema->txn_scope_guard; my @pids = _test_forking_action ($schema, $pass); $guard->commit; } } sub _test_forking_action { my ($schema, $pass) = @_; my @pids; SKIP: for my $count (1 .. 5) { skip 'Weird DBI General Protection Faults, skip forking tests (RT#63104)', 5 if $^O eq 'MSWin32'; my $pid = fork(); if( ! defined $pid ) { skip "EAGAIN encountered, your system is likely bogged down: skipping forking test", 1 if $! == Errno::EAGAIN(); die "Unable to fork: $!" } if ($pid) { push @pids, $pid; next; } if ($count % 2) { $schema->txn_do (sub { my $depth = $schema->storage->transaction_depth; die "$$(txn_do)unexpected txn depth $depth!" if $depth != 1; $schema->resultset ('Artist')->create ({ name => "forking action $$"}); }); } else { my $guard = $schema->txn_scope_guard; my $depth = $schema->storage->transaction_depth; die "$$(scope_guard) unexpected txn depth $depth!" if $depth != 1; $schema->resultset ('Artist')->create ({ name => "forking action $$"}); $guard->commit; } exit 0; } for my $pid (@pids) { waitpid ($pid, 0); ok (! $?, "Child $pid exit ok (pass $pass)"); } # it is important to reap all children before checking the final db-state # otherwise a deadlock may occur between the transactions running in the # children and the query of the parent for my $pid (@pids) { isa_ok ($schema->resultset ('Artist')->find ({ name => "forking action $pid" }), 'DBIx::Class::Row'); } } my $fail_code = sub { my ($artist) = @_; $artist->create_related('cds', { title => 'this should not exist', year => 2005, }); die "the sky is falling"; }; { my $schema = DBICTest->init_schema; # Test failed txn_do() for my $pass (1,2) { is( $schema->storage->{transaction_depth}, 0, "txn depth starts at 0 (pass $pass)"); my $artist = $schema->resultset('Artist')->find(3); throws_ok (sub { $schema->txn_do($fail_code, $artist); }, qr/the sky is falling/, "failed txn_do threw an exception (pass $pass)"); my $cd = $artist->cds({ title => 'this should not exist', year => 2005, })->first; ok(!defined($cd), qq{failed txn_do didn't change the cds table (pass $pass)}); is( $schema->storage->{transaction_depth}, 0, "txn depth has been reset (pass $pass)"); } # Test failed txn_do() with failed rollback { is( $schema->storage->{transaction_depth}, 0, 'txn depth starts at 0'); my $artist = $schema->resultset('Artist')->find(3); # Force txn_rollback() to throw an exception no warnings qw/once redefine/; # this should logically work just fine - but it does not, # only direct override of the existing method dtrt #local *DBIx::Class::Storage::DBI::SQLite::txn_rollback = sub { die 'FAILED' }; local *DBIx::Class::Storage::DBI::txn_rollback = sub { die 'FAILED' }; Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO; throws_ok ( sub { $schema->txn_do($fail_code, $artist); }, qr/the sky is falling.+Rollback failed/s, 'txn_rollback threw a rollback exception (and included the original exception' ); my $cd = $artist->cds({ title => 'this should not exist', year => 2005, })->first; isa_ok($cd, 'DBICTest::CD', q{failed txn_do with a failed txn_rollback }. q{changed the cds table}); $cd->delete; # Rollback failed $cd = $artist->cds({ title => 'this should not exist', year => 2005, })->first; ok(!defined($cd), q{deleted the failed txn's cd}); $schema->storage->_dbh->rollback; } } # Test nested failed txn_do() { my $schema = DBICTest->init_schema(); is( $schema->storage->{transaction_depth}, 0, 'txn depth starts at 0'); my $nested_fail_code = sub { my ($schema, $artist, $code1, $code2) = @_; my @titles = map {'nested txn_do test CD ' . $_} (1..5); $schema->txn_do($code1, $artist, @titles); # successful txn $schema->txn_do($code2, $artist); # failed txn }; my $artist = $schema->resultset('Artist')->find(3); throws_ok ( sub { $schema->txn_do($nested_fail_code, $schema, $artist, $code, $fail_code); }, qr/the sky is falling/, 'nested failed txn_do threw exception'); ok(!defined($artist->cds({ title => 'nested txn_do test CD '.$_, year => 2006, })->first), qq{failed txn_do didn't add first txn's cd $_}) for (1..5); my $cd = $artist->cds({ title => 'this should not exist', year => 2005, })->first; ok(!defined($cd), q{failed txn_do didn't add failed txn's cd}); } # Grab a new schema to test txn before connect # also test nested txn exception { my $schema = DBICTest->init_schema(no_deploy => 1); lives_ok (sub { $schema->txn_begin(); $schema->txn_begin(); }, 'Pre-connection nested transactions.'); throws_ok( sub { $schema->txn_rollback }, 'DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION', 'got proper nested rollback exception' ); } # make sure AutoCommit => 0 on external handles behaves correctly with scope_guard warnings_are { my $factory = DBICTest->init_schema; cmp_ok ($factory->resultset('CD')->count, '>', 0, 'Something to delete'); my $dbh = $factory->storage->dbh; $dbh->{AutoCommit} = 0; ok (!$dbh->{AutoCommit}, 'AutoCommit is off on $dbh'); my $schema = DBICTest::Schema->connect (sub { $dbh }); lives_ok ( sub { my $guard = $schema->txn_scope_guard; $schema->resultset('CD')->delete; $guard->commit; }, 'No attempt to start a transaction with scope guard'); is ($schema->resultset('CD')->count, 0, 'Deletion successful in txn'); # this will commit the implicitly started txn $dbh->commit; } [], 'No warnings on AutoCommit => 0 with txn_guard'; # make sure AutoCommit => 0 on external handles behaves correctly with txn_do warnings_are { my $factory = DBICTest->init_schema; cmp_ok ($factory->resultset('CD')->count, '>', 0, 'Something to delete'); my $dbh = $factory->storage->dbh; $dbh->{AutoCommit} = 0; ok (!$dbh->{AutoCommit}, 'AutoCommit is off on $dbh'); my $schema = DBICTest::Schema->connect (sub { $dbh }); lives_ok ( sub { $schema->txn_do (sub { $schema->resultset ('CD')->delete }); }, 'No attempt to start a atransaction with txn_do'); is ($schema->resultset('CD')->count, 0, 'Deletion successful'); # this will commit the implicitly started txn $dbh->commit; } [], 'No warnings on AutoCommit => 0 with txn_do'; # make sure we are not fucking up the stacktrace on broken overloads { package DBICTest::BrokenOverload; use overload '""' => sub { $_[0] }; } { my @w; local $SIG{__WARN__} = sub { $_[0] =~ /\QExternal exception class DBICTest::BrokenOverload implements partial (broken) overloading preventing its instances from being used in simple (\E\$x eq \$y\Q) comparisons/ ? push @w, @_ : warn @_ }; my $s = DBICTest->init_schema(no_deploy => 1); $s->stacktrace(0); my $g = $s->storage->txn_scope_guard; my $broken_exception = bless {}, 'DBICTest::BrokenOverload'; # FIXME - investigate what confuses the regex engine below # do not reformat - line-num part of the test my $ln = __LINE__ + 6; throws_ok { $s->txn_do( sub { $s->txn_do( sub { $s->storage->_dbh->disconnect; die $broken_exception }); }) } qr/\QTransaction aborted: $broken_exception. Rollback failed: lost connection to storage at @{[__FILE__]} line $ln\E\n/; # FIXME wtf - ...\E$/m doesn't work here is @w, 1, 'One matching warning only'; } done_testing; �����������������������������������DBIx-Class-0.082843/t/storage/replicated.t����������������������������������������������������������0000644�0001750�0001750�00000070633�14240132261�017317� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; BEGIN { require DBIx::Class; plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_replicated') unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_replicated'); if (DBICTest::RunMode->is_smoker) { my $mver = Moose->VERSION; plan skip_all => "A trial version $mver of Moose detected known to break replication - skipping test known to fail" if ($mver >= 1.99 and $mver <= 1.9902); } } use Test::Moose; use Test::Exception; use Scalar::Util 'reftype'; use File::Spec; use Moose(); use MooseX::Types(); note "Using Moose version $Moose::VERSION and MooseX::Types version $MooseX::Types::VERSION"; my $var_dir = quotemeta ( File::Spec->catdir(qw/t var/) ); ## Add a connect_info option to test option merging. use DBIx::Class::Storage::DBI::Replicated; { package DBIx::Class::Storage::DBI::Replicated; use Moose; __PACKAGE__->meta->make_mutable; around connect_info => sub { my ($next, $self, $info) = @_; $info->[3]{master_option} = 1; $self->$next($info); }; __PACKAGE__->meta->make_immutable; no Moose; } =head1 HOW TO USE This is a test of the replicated storage system. This will work in one of two ways, either it was try to fake replication with a couple of SQLite DBs and creative use of copy, or if you define a couple of %ENV vars correctly will try to test those. If you do that, it will assume the setup is properly replicating. Your results may vary, but I have demonstrated this to work with mysql native replication. =cut ## ---------------------------------------------------------------------------- ## Build a class to hold all our required testing data and methods. ## ---------------------------------------------------------------------------- TESTSCHEMACLASSES: { ## --------------------------------------------------------------------- ## ## Create an object to contain your replicated stuff. ## --------------------------------------------------------------------- ## package DBIx::Class::DBI::Replicated::TestReplication; use DBICTest; use base 'Class::Accessor::Grouped'; __PACKAGE__->mk_group_accessors( simple => 'schema' ); ## Initialize the object sub new { my ($class, $schema_method) = (shift, shift); my $self = bless( (shift || {}), $class ); $self->schema( $self->init_schema($schema_method) ); return $self; } ## Get the Schema and set the replication storage type sub init_schema { #my ($class, $schema_getter) = @_; shift->${\ ( 'get_schema_' . shift ) }; } sub get_schema_by_storage_type { DBICTest->init_schema( sqlite_use_file => 1, storage_type=>{ '::DBI::Replicated' => { balancer_type=>'::Random', balancer_args=>{ auto_validate_every=>100, master_read_weight => 1 }, } }, deploy_args=>{ add_drop_table => 1, }, ); } sub get_schema_by_connect_info { DBICTest->init_schema( sqlite_use_file => 1, storage_type=> '::DBI::Replicated', balancer_type=>'::Random', balancer_args=> { auto_validate_every=>100, master_read_weight => 1 }, pool_args=>{ maximum_lag=>1, }, deploy_args=>{ add_drop_table => 1, }, ); } sub generate_replicant_connect_info {} sub replicate {} sub cleanup {} ## --------------------------------------------------------------------- ## ## Subclass for when you are using SQLite for testing, this provides a fake ## replication support. ## --------------------------------------------------------------------- ## package DBIx::Class::DBI::Replicated::TestReplication::SQLite; use DBICTest; use File::Copy; use base 'DBIx::Class::DBI::Replicated::TestReplication'; __PACKAGE__->mk_group_accessors( simple => qw( master_path slave_paths ) ); ## Set the master path from DBICTest sub new { my $self = shift->next::method(@_); $self->master_path( DBICTest->_sqlite_dbfilename ); $self->slave_paths([ File::Spec->catfile(qw/t var DBIxClass_slave1.db/), File::Spec->catfile(qw/t var DBIxClass_slave2.db/), ]); return $self; } ## Return an Array of ArrayRefs where each ArrayRef is suitable to use for ## $storage->connect_info to be used for connecting replicants. sub generate_replicant_connect_info { my $self = shift @_; my @dsn = map { "dbi:SQLite:${_}"; } @{$self->slave_paths}; my @connect_infos = map { [$_,'','',{AutoCommit=>1}] } @dsn; ## Make sure nothing is left over from a failed test $self->cleanup; ## try a hashref too my $c = $connect_infos[0]; $connect_infos[0] = { dsn => $c->[0], user => $c->[1], password => $c->[2], %{ $c->[3] } }; @connect_infos } ## Do a 'good enough' replication by copying the master dbfile over each of ## the slave dbfiles. If the master is SQLite we do this, otherwise we ## just do a one second pause to let the slaves catch up. sub replicate { my $self = shift @_; foreach my $slave (@{$self->slave_paths}) { copy($self->master_path, $slave); } } ## Cleanup after ourselves. Unlink all the slave paths. sub cleanup { my $self = shift @_; $_->disconnect for values %{ $self->schema->storage->replicants }; foreach my $slave (@{$self->slave_paths}) { if(-e $slave) { unlink $slave; } } } ## --------------------------------------------------------------------- ## ## Subclass for when you are setting the databases via custom export vars ## This is for when you have a replicating database setup that you are ## going to test against. You'll need to define the correct $ENV and have ## two slave databases to test against, as well as a replication system ## that will replicate in less than 1 second. ## --------------------------------------------------------------------- ## package DBIx::Class::DBI::Replicated::TestReplication::Custom; use base 'DBIx::Class::DBI::Replicated::TestReplication'; ## Return an Array of ArrayRefs where each ArrayRef is suitable to use for ## $storage->connect_info to be used for connecting replicants. sub generate_replicant_connect_info { return ( [$ENV{"DBICTEST_SLAVE0_DSN"}, $ENV{"DBICTEST_SLAVE0_DBUSER"}, $ENV{"DBICTEST_SLAVE0_DBPASS"}, {AutoCommit => 1}], [$ENV{"DBICTEST_SLAVE1_DSN"}, $ENV{"DBICTEST_SLAVE1_DBUSER"}, $ENV{"DBICTEST_SLAVE1_DBPASS"}, {AutoCommit => 1}], ); } ## pause a bit to let the replication catch up sub replicate { sleep 1; } } ## ---------------------------------------------------------------------------- ## Create an object and run some tests ## ---------------------------------------------------------------------------- ## Thi first bunch of tests are basic, just make sure all the bits are behaving my $replicated_class = DBICTest->has_custom_dsn ? 'DBIx::Class::DBI::Replicated::TestReplication::Custom' : 'DBIx::Class::DBI::Replicated::TestReplication::SQLite'; my $replicated; for my $method (qw/by_connect_info by_storage_type/) { undef $replicated; ok $replicated = $replicated_class->new($method) => "Created a replication object $method"; isa_ok $replicated->schema => 'DBIx::Class::Schema'; isa_ok $replicated->schema->storage => 'DBIx::Class::Storage::DBI::Replicated'; isa_ok $replicated->schema->storage->balancer => 'DBIx::Class::Storage::DBI::Replicated::Balancer::Random' => 'configured balancer_type'; } ### check that all Storage::DBI methods are handled by ::Replicated { my @storage_dbi_methods = Class::MOP::Class ->initialize('DBIx::Class::Storage::DBI')->get_all_method_names; my @replicated_methods = DBIx::Class::Storage::DBI::Replicated->meta ->get_all_method_names; # remove constants and OTHER_CRAP @storage_dbi_methods = grep !/^[A-Z_]+\z/, @storage_dbi_methods; # remove CAG accessors @storage_dbi_methods = grep !/_accessor\z/, @storage_dbi_methods; # remove DBIx::Class (the root parent, with CAG and stuff) methods my @root_methods = Class::MOP::Class->initialize('DBIx::Class') ->get_all_method_names; my %count; $count{$_}++ for (@storage_dbi_methods, @root_methods); @storage_dbi_methods = grep $count{$_} != 2, @storage_dbi_methods; # make hashes my %storage_dbi_methods; @storage_dbi_methods{@storage_dbi_methods} = (); my %replicated_methods; @replicated_methods{@replicated_methods} = (); # remove ::Replicated-specific methods for my $method (@replicated_methods) { delete $replicated_methods{$method} unless exists $storage_dbi_methods{$method}; } @replicated_methods = keys %replicated_methods; # check that what's left is implemented %count = (); $count{$_}++ for (@storage_dbi_methods, @replicated_methods); if ((grep $count{$_} == 2, @storage_dbi_methods) == @storage_dbi_methods) { pass 'all DBIx::Class::Storage::DBI methods implemented'; } else { my @unimplemented = grep $count{$_} == 1, @storage_dbi_methods; fail 'the following DBIx::Class::Storage::DBI methods are unimplemented: ' . "@unimplemented"; } } ok $replicated->schema->storage->meta => 'has a meta object'; isa_ok $replicated->schema->storage->master => 'DBIx::Class::Storage::DBI'; isa_ok $replicated->schema->storage->pool => 'DBIx::Class::Storage::DBI::Replicated::Pool'; does_ok $replicated->schema->storage->balancer => 'DBIx::Class::Storage::DBI::Replicated::Balancer'; ok my @replicant_connects = $replicated->generate_replicant_connect_info => 'got replication connect information'; ok my @replicated_storages = $replicated->schema->storage->connect_replicants(@replicant_connects) => 'Created some storages suitable for replicants'; our %debug; $replicated->schema->storage->debug(1); $replicated->schema->storage->debugcb(sub { my ($op, $info) = @_; ##warn "\n$op, $info\n"; %debug = ( op => $op, info => $info, dsn => ($info=~m/\[(.+)\]/)[0], storage_type => $info=~m/REPLICANT/ ? 'REPLICANT' : 'MASTER', ); }); ok my @all_storages = $replicated->schema->storage->all_storages => '->all_storages'; is scalar @all_storages, 3 => 'correct number of ->all_storages'; is ((grep $_->isa('DBIx::Class::Storage::DBI'), @all_storages), 3 => '->all_storages are correct type'); my @all_storage_opts = grep { (reftype($_)||'') eq 'HASH' } map @{ $_->_connect_info }, @all_storages; is ((grep $_->{master_option}, @all_storage_opts), 3 => 'connect_info was merged from master to replicants'); my @replicant_names = keys %{ $replicated->schema->storage->replicants }; ok @replicant_names, "found replicant names @replicant_names"; ## Silence warning about not supporting the is_replicating method if using the ## sqlite dbs. $replicated->schema->storage->debugobj->silence(1) if grep { $_ =~ /$var_dir/ } @replicant_names; isa_ok $replicated->schema->storage->balancer->current_replicant => 'DBIx::Class::Storage::DBI'; $replicated->schema->storage->debugobj->silence(0); ok $replicated->schema->storage->pool->has_replicants => 'does have replicants'; is $replicated->schema->storage->pool->num_replicants => 2 => 'has two replicants'; does_ok $replicated_storages[0] => 'DBIx::Class::Storage::DBI::Replicated::Replicant'; does_ok $replicated_storages[1] => 'DBIx::Class::Storage::DBI::Replicated::Replicant'; does_ok $replicated->schema->storage->replicants->{$replicant_names[0]} => 'DBIx::Class::Storage::DBI::Replicated::Replicant'; does_ok $replicated->schema->storage->replicants->{$replicant_names[1]} => 'DBIx::Class::Storage::DBI::Replicated::Replicant'; ## Add some info to the database $replicated ->schema ->populate('Artist', [ [ qw/artistid name/ ], [ 4, "Ozric Tentacles"], ]); is $debug{storage_type}, 'MASTER', "got last query from a master: $debug{dsn}"; like $debug{info}, qr/INSERT/, 'Last was an insert'; ## Make sure all the slaves have the table definitions $replicated->replicate; $replicated->schema->storage->replicants->{$replicant_names[0]}->active(1); $replicated->schema->storage->replicants->{$replicant_names[1]}->active(1); ## Silence warning about not supporting the is_replicating method if using the ## sqlite dbs. $replicated->schema->storage->debugobj->silence(1) if grep { $_ =~ /$var_dir/ } @replicant_names; $replicated->schema->storage->pool->validate_replicants; $replicated->schema->storage->debugobj->silence(0); ## Make sure we can read the data. ok my $artist1 = $replicated->schema->resultset('Artist')->find(4) => 'Created Result'; ## We removed testing here since master read weight is on, so we can't tell in ## advance what storage to expect. We turn master read weight off a bit lower ## is $debug{storage_type}, 'REPLICANT' ## => "got last query from a replicant: $debug{dsn}, $debug{info}"; isa_ok $artist1 => 'DBICTest::Artist'; is $artist1->name, 'Ozric Tentacles' => 'Found expected name for first result'; ## Check that master_read_weight is honored { no warnings qw/once redefine/; local *DBIx::Class::Storage::DBI::Replicated::Balancer::Random::_random_number = sub { 999 }; $replicated->schema->storage->balancer->increment_storage; is $replicated->schema->storage->balancer->current_replicant, $replicated->schema->storage->master => 'master_read_weight is honored'; ## turn it off for the duration of the test $replicated->schema->storage->balancer->master_read_weight(0); $replicated->schema->storage->balancer->increment_storage; } ## Add some new rows that only the master will have This is because ## we overload any type of write operation so that is must hit the master ## database. $replicated ->schema ->populate('Artist', [ [ qw/artistid name/ ], [ 5, "Doom's Children"], [ 6, "Dead On Arrival"], [ 7, "Watergate"], ]); is $debug{storage_type}, 'MASTER', "got last query from a master: $debug{dsn}"; like $debug{info}, qr/INSERT/, 'Last was an insert'; ## Make sure all the slaves have the table definitions $replicated->replicate; ## Should find some data now ok my $artist2 = $replicated->schema->resultset('Artist')->find(5) => 'Sync succeed'; is $debug{storage_type}, 'REPLICANT' => "got last query from a replicant: $debug{dsn}"; isa_ok $artist2 => 'DBICTest::Artist'; is $artist2->name, "Doom's Children" => 'Found expected name for first result'; ## What happens when we disconnect all the replicants? is $replicated->schema->storage->pool->connected_replicants => 2 => "both replicants are connected"; $replicated->schema->storage->replicants->{$replicant_names[0]}->disconnect; $replicated->schema->storage->replicants->{$replicant_names[1]}->disconnect; is $replicated->schema->storage->pool->connected_replicants => 0 => "both replicants are now disconnected"; ## All these should pass, since the database should automatically reconnect ok my $artist3 = $replicated->schema->resultset('Artist')->find(6) => 'Still finding stuff.'; is $debug{storage_type}, 'REPLICANT' => "got last query from a replicant: $debug{dsn}"; isa_ok $artist3 => 'DBICTest::Artist'; is $artist3->name, "Dead On Arrival" => 'Found expected name for first result'; is $replicated->schema->storage->pool->connected_replicants => 1 => "At Least One replicant reconnected to handle the job"; ## What happens when we try to select something that doesn't exist? ok ! $replicated->schema->resultset('Artist')->find(666) => 'Correctly failed to find something.'; is $debug{storage_type}, 'REPLICANT' => "got last query from a replicant: $debug{dsn}"; ## test the reliable option TESTRELIABLE: { $replicated->schema->storage->set_reliable_storage; ok $replicated->schema->resultset('Artist')->find(2) => 'Read from master 1'; is $debug{storage_type}, 'MASTER', "got last query from a master: $debug{dsn}"; ok $replicated->schema->resultset('Artist')->find(5) => 'Read from master 2'; is $debug{storage_type}, 'MASTER', "got last query from a master: $debug{dsn}"; $replicated->schema->storage->set_balanced_storage; ok $replicated->schema->resultset('Artist')->find(3) => 'Read from replicant'; is $debug{storage_type}, 'REPLICANT', "got last query from a replicant: $debug{dsn}"; } ## Make sure when reliable goes out of scope, we are using replicants again ok $replicated->schema->resultset('Artist')->find(1) => 'back to replicant 1.'; is $debug{storage_type}, 'REPLICANT', "got last query from a replicant: $debug{dsn}"; ok $replicated->schema->resultset('Artist')->find(2) => 'back to replicant 2.'; is $debug{storage_type}, 'REPLICANT', "got last query from a replicant: $debug{dsn}"; ## set all the replicants to inactive, and make sure the balancer falls back to ## the master. $replicated->schema->storage->replicants->{$replicant_names[0]}->active(0); $replicated->schema->storage->replicants->{$replicant_names[1]}->active(0); { ## catch the fallback to master warning open my $debugfh, '>', \my $fallback_warning; my $oldfh = $replicated->schema->storage->debugfh; $replicated->schema->storage->debugfh($debugfh); ok $replicated->schema->resultset('Artist')->find(2) => 'Fallback to master'; is $debug{storage_type}, 'MASTER', "got last query from a master: $debug{dsn}"; like $fallback_warning, qr/falling back to master/ => 'emits falling back to master debug'; $replicated->schema->storage->debugfh($oldfh); } $replicated->schema->storage->replicants->{$replicant_names[0]}->active(1); $replicated->schema->storage->replicants->{$replicant_names[1]}->active(1); ## Silence warning about not supporting the is_replicating method if using the ## sqlite dbs. $replicated->schema->storage->debugobj->silence(1) if grep { $_ =~ /$var_dir/ } @replicant_names; $replicated->schema->storage->pool->validate_replicants; $replicated->schema->storage->debugobj->silence(0); { ## catch the fallback to master warning open my $debugfh, '>', \my $return_warning; my $oldfh = $replicated->schema->storage->debugfh; $replicated->schema->storage->debugfh($debugfh); ok $replicated->schema->resultset('Artist')->find(2) => 'Return to replicants'; is $debug{storage_type}, 'REPLICANT', "got last query from a replicant: $debug{dsn}"; like $return_warning, qr/Moved back to slave/ => 'emits returning to slave debug'; $replicated->schema->storage->debugfh($oldfh); } ## Getting slave status tests SKIP: { ## We skip this tests unless you have a custom replicants, since the default ## sqlite based replication tests don't support these functions. skip 'Cannot Test Replicant Status on Non Replicating Database', 10 unless DBICTest->has_custom_dsn && $ENV{"DBICTEST_SLAVE0_DSN"}; $replicated->replicate; ## Give the slaves a chance to catchup. ok $replicated->schema->storage->replicants->{$replicant_names[0]}->is_replicating => 'Replicants are replicating'; is $replicated->schema->storage->replicants->{$replicant_names[0]}->lag_behind_master, 0 => 'Replicant is zero seconds behind master'; ## Test the validate replicants $replicated->schema->storage->pool->validate_replicants; is $replicated->schema->storage->pool->active_replicants, 2 => 'Still have 2 replicants after validation'; ## Force the replicants to fail the validate test by required their lag to ## be negative (ie ahead of the master!) $replicated->schema->storage->pool->maximum_lag(-10); $replicated->schema->storage->pool->validate_replicants; is $replicated->schema->storage->pool->active_replicants, 0 => 'No way a replicant be be ahead of the master'; ## Let's be fair to the replicants again. Let them lag up to 5 $replicated->schema->storage->pool->maximum_lag(5); $replicated->schema->storage->pool->validate_replicants; is $replicated->schema->storage->pool->active_replicants, 2 => 'Both replicants in good standing again'; ## Check auto validate is $replicated->schema->storage->balancer->auto_validate_every, 100 => "Got the expected value for auto validate"; ## This will make sure we auto validatge everytime $replicated->schema->storage->balancer->auto_validate_every(0); ## set all the replicants to inactive, and make sure the balancer falls back to ## the master. $replicated->schema->storage->replicants->{$replicant_names[0]}->active(0); $replicated->schema->storage->replicants->{$replicant_names[1]}->active(0); ## Ok, now when we go to run a query, autovalidate SHOULD reconnect is $replicated->schema->storage->pool->active_replicants => 0 => "both replicants turned off"; ok $replicated->schema->resultset('Artist')->find(5) => 'replicant reactivated'; is $debug{storage_type}, 'REPLICANT', "got last query from a replicant: $debug{dsn}"; is $replicated->schema->storage->pool->active_replicants => 2 => "both replicants reactivated"; } ## Test the reliably callback ok my $reliably = sub { ok $replicated->schema->resultset('Artist')->find(5) => 'replicant reactivated'; is $debug{storage_type}, 'MASTER', "got last query from a master: $debug{dsn}"; $_[1] = 9; } => 'created coderef properly'; my @list_to_mangle = (1, 2, 3); $replicated->schema->storage->execute_reliably($reliably, @list_to_mangle); is_deeply \@list_to_mangle, [ 1, 9, 3], 'Aliasing of values passed to execute_reliably works' ; ## Try something with an error ok my $unreliably = sub { ok $replicated->schema->resultset('ArtistXX')->find(5) => 'replicant reactivated'; } => 'created coderef properly'; throws_ok {$replicated->schema->storage->execute_reliably($unreliably)} qr/Can't find source for ArtistXX/ => 'Bad coderef throws proper error'; throws_ok { $replicated->schema->storage->execute_reliably(sub{ die bless [], 'SomeExceptionThing'; }); } 'SomeExceptionThing', "Blessed exception kept intact"; ## Make sure replication came back ok $replicated->schema->resultset('Artist')->find(3) => 'replicant reactivated'; is $debug{storage_type}, 'REPLICANT', "got last query from a replicant: $debug{dsn}"; ## make sure transactions are set to execute_reliably ok my $transaction = sub { my $id = shift @_; $replicated ->schema ->populate('Artist', [ [ qw/artistid name/ ], [ $id, "Children of the Grave $id"], ]); ok my $result = $replicated->schema->resultset('Artist')->find($id) => "Found expected artist for $id"; is $debug{storage_type}, 'MASTER', "got last query from a master: $debug{dsn}"; ok my $more = $replicated->schema->resultset('Artist')->find(1) => 'Found expected artist again for 1'; is $debug{storage_type}, 'MASTER', "got last query from a master: $debug{dsn}"; return ($result, $more); } => 'Created a coderef properly'; ## Test the transaction with multi return { ok my @return = $replicated->schema->txn_do($transaction, 666) => 'did transaction'; is $return[0]->id, 666 => 'first returned value is correct'; is $debug{storage_type}, 'MASTER', "got last query from a master: $debug{dsn}"; is $return[1]->id, 1 => 'second returned value is correct'; is $debug{storage_type}, 'MASTER', "got last query from a master: $debug{dsn}"; } ## Test that asking for single return works { ok my @return = $replicated->schema->txn_do($transaction, 777) => 'did transaction'; is $return[0]->id, 777 => 'first returned value is correct'; is $return[1]->id, 1 => 'second returned value is correct'; } ## Test transaction returning a single value { ok my $result = $replicated->schema->txn_do(sub { ok my $more = $replicated->schema->resultset('Artist')->find(1) => 'found inside a transaction'; is $debug{storage_type}, 'MASTER', "got last query from a master: $debug{dsn}"; return $more; }) => 'successfully processed transaction'; is $result->id, 1 => 'Got expected single result from transaction'; } ## Make sure replication came back ok $replicated->schema->resultset('Artist')->find(1) => 'replicant reactivated'; is $debug{storage_type}, 'REPLICANT', "got last query from a replicant: $debug{dsn}"; ## Test Discard changes { ok my $artist = $replicated->schema->resultset('Artist')->find(2) => 'got an artist to test discard changes'; is $debug{storage_type}, 'REPLICANT', "got last query from a replicant: $debug{dsn}"; ok $artist->get_from_storage({force_pool=>'master'}) => 'properly discard changes'; is $debug{storage_type}, 'MASTER', "got last query from a master: $debug{dsn}"; ok $artist->discard_changes({force_pool=>'master'}) => 'properly called discard_changes against master (manual attrs)'; is $debug{storage_type}, 'MASTER', "got last query from a master: $debug{dsn}"; ok $artist->discard_changes() => 'properly called discard_changes against master (default attrs)'; is $debug{storage_type}, 'MASTER', "got last query from a master: $debug{dsn}"; ok $artist->discard_changes({force_pool=>$replicant_names[0]}) => 'properly able to override the default attributes'; is $debug{storage_type}, 'REPLICANT', "got last query from a replicant: $debug{dsn}" } ## Test some edge cases, like trying to do a transaction inside a transaction, etc { ok my $result = $replicated->schema->txn_do(sub { return $replicated->schema->txn_do(sub { ok my $more = $replicated->schema->resultset('Artist')->find(1) => 'found inside a transaction inside a transaction'; is $debug{storage_type}, 'MASTER', "got last query from a master: $debug{dsn}"; return $more; }); }) => 'successfully processed transaction'; is $result->id, 1 => 'Got expected single result from transaction'; } { ok my $result = $replicated->schema->txn_do(sub { return $replicated->schema->storage->execute_reliably(sub { return $replicated->schema->txn_do(sub { return $replicated->schema->storage->execute_reliably(sub { ok my $more = $replicated->schema->resultset('Artist')->find(1) => 'found inside crazy deep transactions and execute_reliably'; is $debug{storage_type}, 'MASTER', "got last query from a master: $debug{dsn}"; return $more; }); }); }); }) => 'successfully processed transaction'; is $result->id, 1 => 'Got expected single result from transaction'; } ## Test the force_pool resultset attribute. { ok my $artist_rs = $replicated->schema->resultset('Artist') => 'got artist resultset'; ## Turn on Forced Pool Storage ok my $reliable_artist_rs = $artist_rs->search(undef, {force_pool=>'master'}) => 'Created a resultset using force_pool storage'; ok my $artist = $reliable_artist_rs->find(2) => 'got an artist result via force_pool storage'; is $debug{storage_type}, 'MASTER', "got last query from a master: $debug{dsn}"; } ## Test the force_pool resultset attribute part two. { ok my $artist_rs = $replicated->schema->resultset('Artist') => 'got artist resultset'; ## Turn on Forced Pool Storage ok my $reliable_artist_rs = $artist_rs->search(undef, {force_pool=>$replicant_names[0]}) => 'Created a resultset using force_pool storage'; ok my $artist = $reliable_artist_rs->find(2) => 'got an artist result via force_pool storage'; is $debug{storage_type}, 'REPLICANT', "got last query from a replicant: $debug{dsn}"; } ## Delete the old database files $replicated->cleanup; done_testing; # vim: sw=4 sts=4 : �����������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/storage/on_connect_do.t�������������������������������������������������������0000644�0001750�0001750�00000005560�14240132261�020007� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; # !!! do not replace this with done_testing - tests reside in the callbacks # !!! number of calls is important use Test::More tests => 13; # !!! use Test::Warn; use Test::Exception; use lib qw(t/lib); use DBICTest; require DBI; my $schema = DBICTest->init_schema( no_connect => 1, no_deploy => 1, ); ok $schema->connection( DBICTest->_database, { on_connect_do => 'CREATE TABLE TEST_empty (id INTEGER)', }, ), 'connection()'; is_deeply ( $schema->storage->dbh->selectall_arrayref('SELECT * FROM TEST_empty'), [], 'string version on_connect_do() worked' ); $schema->storage->disconnect; ok $schema->connection( sub { DBI->connect(DBICTest->_database, undef, undef, { AutoCommit => 0 }) }, { # DO NOT REMOVE - this seems like an unrelated piece of info, # but is in fact a test for a bug where setting an accessor-via-option # would trigger an early connect *bypassing* the on_connect_* pieces cursor_class => 'DBIx::Class::Storage::Cursor', on_connect_do => [ 'CREATE TABLE TEST_empty (id INTEGER)', [ 'INSERT INTO TEST_empty VALUES (?)', {}, 2 ], \&insert_from_subref, ], on_disconnect_do => [\&check_exists, 'DROP TABLE TEST_empty', \&check_dropped], }, ), 'connection()'; warnings_exist { $schema->storage->ensure_connected } qr/The 'RaiseError' of the externally supplied DBI handle is set to false/, 'Warning on clobbered AutoCommit => 0 fired'; is_deeply ( $schema->storage->dbh->selectall_arrayref('SELECT * FROM TEST_empty'), [ [ 2 ], [ 3 ], [ 7 ] ], 'on_connect_do() worked' ); dies_ok { $schema->storage->dbh->do('SELECT 1 FROM TEST_nonexistent'); } 'Searching for nonexistent table dies'; $schema->storage->disconnect(); my($connected, $disconnected, @cb_args); ok $schema->connection( DBICTest->_database, { on_connect_do => sub { $connected = 1; @cb_args = @_; }, on_disconnect_do => sub { $disconnected = 1 }, }, ), 'second connection()'; $schema->storage->dbh->do('SELECT 1'); ok $connected, 'on_connect_do() called after connect()'; ok ! $disconnected, 'on_disconnect_do() not called after connect()'; $schema->storage->disconnect(); ok $disconnected, 'on_disconnect_do() called after disconnect()'; isa_ok($cb_args[0], 'DBIx::Class::Storage', 'first arg to on_connect_do hook'); @cb_args = (); sub check_exists { my $storage = shift; ok $storage->dbh->do('SELECT 1 FROM TEST_empty'), 'Table still exists'; return; } sub check_dropped { my $storage = shift; dies_ok { $storage->dbh->do('SELECT 1 FROM TEST_empty'); } 'Reading from dropped table fails'; return; } sub insert_from_subref { my $storage = shift; return [ [ 'INSERT INTO TEST_empty VALUES (?)', {}, 3 ], 'INSERT INTO TEST_empty VALUES (7)', ]; } ������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/storage/dbi_env.t�������������������������������������������������������������0000644�0001750�0001750�00000010246�14240132261�016603� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use lib qw(t/lib); use DBICTest; use Test::More; use Test::Exception; use DBIx::Class::_Util 'sigwarn_silencer'; BEGIN { delete @ENV{qw(DBI_DSN DBI_DRIVER)} } $ENV{DBICTEST_LOCK_HOLDER} = -1; # pre-populate my $schema = DBICTest->init_schema(sqlite_use_file => 1); my $dbname = DBICTest->_sqlite_dbname(sqlite_use_file => 1); sub count_sheep { my $schema = shift; local $SIG{__WARN__} = sigwarn_silencer( qr/ \QThis version of DBIC does not yet seem to supply a driver for your particular RDBMS\E | \QUnable to extract a driver name from connect info\E | \QYour storage class (DBIx::Class::Storage::DBI) does not set sql_limit_dialect\E /x ); scalar $schema->resultset('Artist')->search( { name => "Exploding Sheep" } ) ->all; } $schema = DBICTest::Schema->connect("dbi::$dbname"); throws_ok { count_sheep($schema) } qr{I can't work out what driver to use}, 'Driver in DSN empty'; isa_ok $schema->storage, 'DBIx::Class::Storage::DBI'; $schema = DBICTest::Schema->connect("dbi:Test_NonExistant_DBD:$dbname"); throws_ok { count_sheep($schema) } qr{Can't locate DBD/Test_NonExistant_DBD\.pm in \@INC}, "Driver class doesn't exist"; isa_ok $schema->storage, 'DBIx::Class::Storage::DBI'; $ENV{DBI_DSN} = "dbi::$dbname"; $schema = DBICTest::Schema->connect; throws_ok { count_sheep($schema) } qr{I can't work out what driver to use}, "Driver class not defined in DBI_DSN either."; isa_ok $schema->storage, 'DBIx::Class::Storage::DBI'; $ENV{DBI_DSN} = "dbi:Test_NonExistant_DBD2:$dbname"; $schema = DBICTest::Schema->connect; throws_ok { count_sheep($schema) } qr{Can't locate DBD/Test_NonExistant_DBD2\.pm in \@INC}, "Driver class defined in DBI_DSN doesn't exist"; isa_ok $schema->storage, 'DBIx::Class::Storage::DBI'; $ENV{DBI_DSN} = "dbi::$dbname"; $ENV{DBI_DRIVER} = 'Test_NonExistant_DBD3'; $schema = DBICTest::Schema->connect; throws_ok { count_sheep($schema) } qr{Can't locate DBD/Test_NonExistant_DBD3\.pm in \@INC}, "Driver class defined in DBI_DRIVER doesn't exist"; isa_ok $schema->storage, 'DBIx::Class::Storage::DBI'; $ENV{DBI_DSN} = "dbi:Test_NonExistant_DBD4:$dbname"; $schema = DBICTest::Schema->connect; throws_ok { count_sheep($schema) } qr{Can't locate DBD/Test_NonExistant_DBD4\.pm in \@INC}, "Driver class defined in DBI_DSN doesn't exist"; isa_ok $schema->storage, 'DBIx::Class::Storage::DBI'; delete @ENV{qw(DBI_DSN DBI_DRIVER)}; $schema = DBICTest::Schema->connect("dbi:SQLite:$dbname"); lives_ok { count_sheep($schema) } 'SQLite passed to connect_info'; isa_ok $schema->storage, 'DBIx::Class::Storage::DBI::SQLite'; $schema = DBICTest::Schema->connect("dbi:SQLite(ReadOnly=1):$dbname"); lives_ok { count_sheep($schema) } 'SQLite passed to connect_info despite extra arguments present'; isa_ok $schema->storage, 'DBIx::Class::Storage::DBI::SQLite'; $ENV{DBI_DRIVER} = 'SQLite'; $schema = DBICTest::Schema->connect("dbi::$dbname"); lives_ok { count_sheep($schema) } 'SQLite in DBI_DRIVER'; isa_ok $schema->storage, 'DBIx::Class::Storage::DBI::SQLite'; delete $ENV{DBI_DRIVER}; $ENV{DBI_DSN} = "dbi:SQLite:$dbname"; $schema = DBICTest::Schema->connect; lives_ok { count_sheep($schema) } 'SQLite in DBI_DSN'; isa_ok $schema->storage, 'DBIx::Class::Storage::DBI::SQLite'; $ENV{DBI_DRIVER} = 'SQLite'; $schema = DBICTest::Schema->connect; lives_ok { count_sheep($schema) } 'SQLite in DBI_DSN (and DBI_DRIVER)'; isa_ok $schema->storage, 'DBIx::Class::Storage::DBI::SQLite'; $ENV{DBI_DSN} = "dbi::$dbname"; $ENV{DBI_DRIVER} = 'SQLite'; $schema = DBICTest::Schema->connect; lives_ok { count_sheep($schema) } 'SQLite in DBI_DRIVER (not DBI_DSN)'; isa_ok $schema->storage, 'DBIx::Class::Storage::DBI::SQLite'; # make sure that dynamically setting DBI_DSN post-connect works { local $ENV{DBI_DSN}; my $s = DBICTest::Schema->connect(); throws_ok { $s->storage->ensure_connected } qr/You did not provide any connection_info/, 'sensible exception on empty conninfo connect'; $ENV{DBI_DSN} = 'dbi:SQLite::memory:'; lives_ok { $s->storage->ensure_connected } 'Second connection attempt worked'; isa_ok ( $s->storage, 'DBIx::Class::Storage::DBI::SQLite' ); } done_testing; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/storage/base.t����������������������������������������������������������������0000644�0001750�0001750�00000013026�14240132261�016106� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Warn; use Test::Exception; use lib qw(t/lib); use DBICTest; use Data::Dumper; my $schema = DBICTest->init_schema( sqlite_use_file => 1 ); is( ref($schema->storage), 'DBIx::Class::Storage::DBI::SQLite', 'Storage reblessed correctly into DBIx::Class::Storage::DBI::SQLite' ); my $storage = $schema->storage; $storage->ensure_connected; throws_ok { $schema->storage->throw_exception('test_exception_42'); } qr/\btest_exception_42\b/, 'basic exception'; throws_ok { $schema->resultset('CD')->search_literal('broken +%$#$1')->all; } qr/prepare_cached failed/, 'exception via DBI->HandleError, etc'; # make sure repeated disconnection works { my $fn = DBICTest->_sqlite_dbfilename; lives_ok { $schema->storage->ensure_connected; my $dbh = $schema->storage->dbh; $schema->storage->disconnect for 1,2; unlink $fn; $dbh->disconnect; }; lives_ok { $schema->storage->ensure_connected; $schema->storage->disconnect for 1,2; unlink $fn; $schema->storage->disconnect for 1,2; }; lives_ok { $schema->storage->ensure_connected; $schema->storage->_dbh->disconnect; unlink $fn; $schema->storage->disconnect for 1,2; }; } # testing various invocations of connect_info ([ ... ]) my $coderef = sub { 42 }; my $invocations = { 'connect_info ([ $d, $u, $p, \%attr, \%extra_attr])' => { args => [ 'foo', 'bar', undef, { on_connect_do => [qw/a b c/], PrintError => 0, }, { AutoCommit => 1, on_disconnect_do => [qw/d e f/], }, { unsafe => 1, auto_savepoint => 1, }, ], dbi_connect_info => [ 'foo', 'bar', undef, { %{$storage->_default_dbi_connect_attributes || {} }, PrintError => 0, AutoCommit => 1, }, ], }, 'connect_info ([ \%code, \%extra_attr ])' => { args => [ $coderef, { on_connect_do => [qw/a b c/], PrintError => 0, AutoCommit => 1, on_disconnect_do => [qw/d e f/], }, { unsafe => 1, auto_savepoint => 1, }, ], dbi_connect_info => [ $coderef, ], }, 'connect_info ([ \%attr ])' => { args => [ { on_connect_do => [qw/a b c/], PrintError => 1, AutoCommit => 0, on_disconnect_do => [qw/d e f/], user => 'bar', dsn => 'foo', }, { unsafe => 1, auto_savepoint => 1, }, ], dbi_connect_info => [ 'foo', 'bar', undef, { %{$storage->_default_dbi_connect_attributes || {} }, PrintError => 1, AutoCommit => 0, }, ], warn => qr/\QYou provided explicit AutoCommit => 0 in your connection_info/, }, 'connect_info ([ \%attr_with_coderef ])' => { args => [ { dbh_maker => $coderef, dsn => 'blah', user => 'bleh', on_connect_do => [qw/a b c/], on_disconnect_do => [qw/d e f/], } ], dbi_connect_info => [ $coderef ], warn => qr/Attribute\(s\) 'dsn', 'user' in connect_info were ignored/, }, }; for my $type (keys %$invocations) { local $ENV{DBIC_UNSAFE_AUTOCOMMIT_OK}; # we can not use a cloner portably because of the coderef # so compare dumps instead local $Data::Dumper::Sortkeys = 1; my $arg_dump = Dumper ($invocations->{$type}{args}); warnings_exist ( sub { $storage->connect_info ($invocations->{$type}{args}) }, $invocations->{$type}{warn} || [], 'Warned about ignored attributes', ); is ($arg_dump, Dumper ($invocations->{$type}{args}), "$type didn't modify passed arguments"); is_deeply ($storage->_dbi_connect_info, $invocations->{$type}{dbi_connect_info}, "$type produced correct _dbi_connect_info"); ok ( (not $storage->auto_savepoint and not $storage->unsafe), "$type correctly ignored extra hashref"); is_deeply ( [$storage->on_connect_do, $storage->on_disconnect_do ], [ [qw/a b c/], [qw/d e f/] ], "$type correctly parsed DBIC specific on_[dis]connect_do", ); } # make sure connection-less storages do not throw on _determine_driver # but work with ENV at the same time SKIP: for my $env_dsn (undef, (DBICTest->_database)[0] ) { skip( 'Subtest relies on being connected to SQLite without overrides', 1 ) if ( $ENV{DBICTEST_SWAPOUT_SQLAC_WITH} or ( $env_dsn and $env_dsn !~ /\:SQLite\:/ ) ); local $ENV{DBI_DSN} = $env_dsn || ''; my $s = DBICTest::Schema->connect(); is_deeply ( $s->storage->connect_info, [], 'Starting with no explicitly passed in connect info' . ($env_dsn ? ' (with DBI_DSN)' : ''), ); my $sm = $s->storage->sql_maker; ok (! $s->storage->connected, 'Storage does not appear connected after SQLMaker instance is taken'); if ($env_dsn) { isa_ok($sm, 'DBIx::Class::SQLMaker'); ok ( $s->storage->_driver_determined, 'Driver determined (with DBI_DSN)'); isa_ok ( $s->storage, 'DBIx::Class::Storage::DBI::SQLite' ); } else { isa_ok($sm, 'DBIx::Class::SQLMaker'); ok (! $s->storage->_driver_determined, 'Driver undetermined'); throws_ok { $s->storage->ensure_connected } qr/You did not provide any connection_info/, 'sensible exception on empty conninfo connect'; } } done_testing; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/storage/disable_sth_caching.t�������������������������������������������������0000644�0001750�0001750�00000001451�14240132261�021130� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; ##!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ## This test uses undocumented internal methods ## DO NOT USE THEM IN THE SAME MANNER ## They are subject to ongoing change ##!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! # Set up the "usual" sqlite for DBICTest my $schema = DBICTest->init_schema; my $dbh = $schema->storage->_get_dbh; my $sth_one = $schema->storage->_prepare_sth($dbh, 'SELECT 42'); my $sth_two = $schema->storage->_prepare_sth($dbh, 'SELECT 42'); $schema->storage->disable_sth_caching(1); my $sth_three = $schema->storage->_prepare_sth($dbh, 'SELECT 42'); ok($sth_one == $sth_two, "statement caching works"); ok($sth_two != $sth_three, "disabling statement caching works"); done_testing; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/storage/reconnect.t�����������������������������������������������������������0000644�0001750�0001750�00000006234�14240132261�017157� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use FindBin; use File::Copy 'move'; use Test::More; use Test::Exception; use lib qw(t/lib); use DBICTest; my $db_orig = DBICTest->_sqlite_dbfilename; my $db_tmp = "$db_orig.tmp"; # Set up the "usual" sqlite for DBICTest my $schema = DBICTest->init_schema( sqlite_use_file => 1 ); # Make sure we're connected by doing something my @art = $schema->resultset("Artist")->search({ }, { order_by => { -desc => 'name' }}); cmp_ok(@art, '==', 3, "Three artists returned"); # Disconnect the dbh, and be sneaky about it # Also test if DBD::SQLite finaly knows how to ->disconnect properly { my $w; local $SIG{__WARN__} = sub { $w = shift }; $schema->storage->_dbh->disconnect; ok ($w !~ /active statement handles/, 'SQLite can disconnect properly'); } # Try the operation again - What should happen here is: # 1. S::DBI blindly attempts the SELECT, which throws an exception # 2. It catches the exception, checks ->{Active}/->ping, sees the disconnected state... # 3. Reconnects, and retries the operation # 4. Success! my @art_two = $schema->resultset("Artist")->search({ }, { order_by => { -desc => 'name' }}); cmp_ok(@art_two, '==', 3, "Three artists returned"); ### Now, disconnect the dbh, and move the db file; # create a new one full of garbage, prevent SQLite from connecting. $schema->storage->_dbh->disconnect; move( $db_orig, $db_tmp ) or die "failed to move $db_orig to $db_tmp: $!"; open my $db_file, '>', $db_orig; print $db_file 'THIS IS NOT A REAL DATABASE'; close $db_file; ### Try the operation again... it should fail, since there's no valid db { # Catch the DBI connection error local $SIG{__WARN__} = sub {}; throws_ok { my @art_three = $schema->resultset("Artist")->search( {}, { order_by => { -desc => 'name' } } ); } qr/not a database/, 'The operation failed'; } ok (! $schema->storage->connected, 'We are not connected' ); ### Now, move the db file back to the correct name unlink($db_orig) or die "could not delete $db_orig: $!"; move( $db_tmp, $db_orig ) or die "could not move $db_tmp to $db_orig: $!"; ### Try the operation again... this time, it should succeed my @art_four; lives_ok { @art_four = $schema->resultset("Artist")->search( {}, { order_by => { -desc => 'name' } } ); } 'The operation succeeded'; cmp_ok( @art_four, '==', 3, "Three artists returned" ); # check that reconnection contexts are preserved in txn_do / dbh_do my $args = [1, 2, 3]; my $ctx_map = { VOID => { invoke => sub { shift->(); 1 }, wa => undef, }, SCALAR => { invoke => sub { my $foo = shift->() }, wa => '', }, LIST => { invoke => sub { my @foo = shift->() }, wa => 1, }, }; for my $ctx (keys %$ctx_map) { # start disconnected and then connected $schema->storage->disconnect; for (1, 2) { my $disarmed; $ctx_map->{$ctx}{invoke}->(sub { $schema->txn_do(sub { is_deeply (\@_, $args, 'Args propagated correctly' ); is (wantarray(), $ctx_map->{$ctx}{wa}, "Correct $ctx context"); # this will cause a retry $schema->storage->_dbh->disconnect unless $disarmed++; isa_ok ($schema->resultset('Artist')->next, 'DBICTest::Artist'); }, @$args) }); } }; done_testing; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/storage/ping_count.t����������������������������������������������������������0000644�0001750�0001750�00000002202�14240132261�017333� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $ping_count = 0; { local $SIG{__WARN__} = sub {}; require DBIx::Class::Storage::DBI; my $ping = \&DBIx::Class::Storage::DBI::_ping; *DBIx::Class::Storage::DBI::_ping = sub { $ping_count++; goto &$ping; }; } # measure pings around deploy() separately my $schema = DBICTest->init_schema( sqlite_use_file => 1, no_populate => 1 ); is ($ping_count, 0, 'no _ping() calls during deploy'); $ping_count = 0; DBICTest->populate_schema ($schema); # perform some operations and make sure they don't ping $schema->resultset('CD')->create({ cdid => 6, artist => 3, title => 'mtfnpy', year => 2009 }); $schema->resultset('CD')->create({ cdid => 7, artist => 3, title => 'mtfnpy2', year => 2009 }); $schema->storage->_dbh->disconnect; $schema->resultset('CD')->create({ cdid => 8, artist => 3, title => 'mtfnpy3', year => 2009 }); $schema->storage->_dbh->disconnect; $schema->txn_do(sub { $schema->resultset('CD')->create({ cdid => 9, artist => 3, title => 'mtfnpy4', year => 2009 }); }); is $ping_count, 0, 'no _ping() calls'; done_testing; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/storage/dbi_coderef.t���������������������������������������������������������0000644�0001750�0001750�00000001411�14240132261�017414� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; plan tests => 1; # Set up the "usual" sqlite for DBICTest and disconnect my $normal_schema = DBICTest->init_schema( sqlite_use_file => 1 ); $normal_schema->storage->disconnect; # Steal the dsn, which should be like 'dbi:SQLite:t/var/DBIxClass.db' my @dsn = ($normal_schema->storage->_dbi_connect_info->[0], undef, undef, { RaiseError => 1 }); # Make a new clone with a new connection, using a code reference my $code_ref_schema = $normal_schema->connect(sub { DBI->connect(@dsn); }); # Stolen from 60core.t - this just verifies things seem to work at all my @art = $code_ref_schema->resultset("Artist")->search({ }, { order_by => 'name DESC'}); cmp_ok(@art, '==', 3, "Three artists returned"); �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/storage/global_destruction.t��������������������������������������������������0000644�0001750�0001750�00000003663�14240132261�021065� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use DBIx::Class::Optional::Dependencies (); use lib qw(t/lib); use DBICTest; for my $type (qw/PG MYSQL SQLite/) { SKIP: { my @dsn = $type eq 'SQLite' ? DBICTest->_database(sqlite_use_file => 1) : do { skip "Skipping $type tests without DBICTEST_${type}_DSN", 1 unless $ENV{"DBICTEST_${type}_DSN"}; @ENV{map { "DBICTEST_${type}_${_}" } qw/DSN USER PASS/} } ; if ($type eq 'PG') { skip "skipping Pg tests without dependencies installed", 1 unless DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_pg'); } elsif ($type eq 'MYSQL') { skip "skipping MySQL tests without dependencies installed", 1 unless DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_mysql'); } my $schema = DBICTest::Schema->connect (@dsn); # emulate a singleton-factory, just cache the object *somewhere in a different package* # to induce out-of-order destruction $DBICTest::FakeSchemaFactory::schema = $schema; # so we can see the retry exceptions (if any) $ENV{DBIC_DBIRETRY_DEBUG} = 1; ok (!$schema->storage->connected, "$type: start disconnected"); $schema->txn_do (sub { ok ($schema->storage->connected, "$type: transaction starts connected"); my $pid = fork(); SKIP: { skip "Fork failed: $!", 1 if (! defined $pid); if ($pid) { note "Parent $$ sleeping..."; wait(); note "Parent $$ woken up after child $pid exit"; } else { note "Child $$ terminating"; undef $DBICTest::FakeSchemaFactory::schema; exit 0; } ok ($schema->storage->connected, "$type: parent still connected (in txn_do)"); } }); ok ($schema->storage->connected, "$type: parent still connected (outside of txn_do)"); undef $DBICTest::FakeSchemaFactory::schema; } } done_testing; �����������������������������������������������������������������������������DBIx-Class-0.082843/t/storage/txn_scope_guard.t�����������������������������������������������������0000644�0001750�0001750�00000015450�14240132261�020363� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Warn; use Test::Exception; use lib qw(t/lib); use DBICTest; # Test txn_scope_guard { my $schema = DBICTest->init_schema(); is($schema->storage->transaction_depth, 0, "Correct transaction depth"); my $artist_rs = $schema->resultset('Artist'); my $fn = __FILE__; throws_ok { my $guard = $schema->txn_scope_guard; $artist_rs->create({ name => 'Death Cab for Cutie', made_up_column => 1, }); $guard->commit; } qr/No such column 'made_up_column' .*? at .*?\Q$fn\E line \d+/s, "Error propogated okay"; ok(!$artist_rs->find({name => 'Death Cab for Cutie'}), "Artist not created"); my $inner_exception = ''; # set in inner() below throws_ok (sub { outer($schema, 1); }, qr/$inner_exception/, "Nested exceptions propogated"); ok(!$artist_rs->find({name => 'Death Cab for Cutie'}), "Artist not created"); lives_ok (sub { # this weird assignment is to stop perl <= 5.8.9 leaking $schema on nested sub{}s my $s = $schema; warnings_exist ( sub { # The 0 arg says don't die, just let the scope guard go out of scope # forcing a txn_rollback to happen outer($s, 0); }, qr/A DBIx::Class::Storage::TxnScopeGuard went out of scope without explicit commit or error. Rolling back./, 'Out of scope warning detected'); ok(!$artist_rs->find({name => 'Death Cab for Cutie'}), "Artist not created"); }, 'rollback successful withot exception'); sub outer { my ($schema, $fatal) = @_; my $guard = $schema->txn_scope_guard; $schema->resultset('Artist')->create({ name => 'Death Cab for Cutie', }); inner($schema, $fatal); } sub inner { my ($schema, $fatal) = @_; my $inner_guard = $schema->txn_scope_guard; is($schema->storage->transaction_depth, 2, "Correct transaction depth"); my $artist = $schema->resultset('Artist')->find({ name => 'Death Cab for Cutie' }); eval { $artist->cds->create({ title => 'Plans', year => 2005, $fatal ? ( foo => 'bar' ) : () }); }; if ($@) { # Record what got thrown so we can test it propgates out properly. $inner_exception = $@; die $@; } # inner guard should commit without consequences $inner_guard->commit; } } # make sure the guard does not eat exceptions { my $schema = DBICTest->init_schema; no strict 'refs'; no warnings 'redefine'; local *{DBIx::Class::Storage::DBI::txn_rollback} = sub { die 'die die my darling' }; Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO; throws_ok (sub { my $guard = $schema->txn_scope_guard; $schema->resultset ('Artist')->create ({ name => 'bohhoo'}); # this should freak out the guard rollback # but it won't work because DBD::SQLite is buggy # instead just install a toxic rollback above #$schema->storage->_dbh( $schema->storage->_dbh->clone ); die 'Deliberate exception'; }, ($] >= 5.013008 ) ? qr/Deliberate exception/s # temporary until we get the generic exception wrapper rolling : qr/Deliberate exception.+Rollback failed/s ); # just to mask off warning since we could not disconnect above $schema->storage->_dbh->disconnect; } # make sure it warns *big* on failed rollbacks # test with and without a poisoned $@ for my $pre_poison (0,1) { for my $post_poison (0,1) { my $schema = DBICTest->init_schema(no_populate => 1); no strict 'refs'; no warnings 'redefine'; local *{DBIx::Class::Storage::DBI::txn_rollback} = sub { die 'die die my darling' }; Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO; #The warn from within a DESTROY callback freaks out Test::Warn, do it old-school =begin warnings_exist ( sub { my $guard = $schema->txn_scope_guard; $schema->resultset ('Artist')->create ({ name => 'bohhoo'}); # this should freak out the guard rollback # but it won't work because DBD::SQLite is buggy # instead just install a toxic rollback above #$schema->storage->_dbh( $schema->storage->_dbh->clone ); }, [ qr/A DBIx::Class::Storage::TxnScopeGuard went out of scope without explicit commit or error. Rolling back./, qr/\*+ ROLLBACK FAILED\!\!\! \*+/, ], 'proper warnings generated on out-of-scope+rollback failure' ); =cut # delete this once the above works properly (same test) my @want = ( qr/A DBIx::Class::Storage::TxnScopeGuard went out of scope without explicit commit or error. Rolling back./, qr/\*+ ROLLBACK FAILED\!\!\! \*+/, ); my @w; local $SIG{__WARN__} = sub { if (grep {$_[0] =~ $_} (@want)) { push @w, $_[0]; } else { warn $_[0]; } }; { eval { die 'pre-GIFT!' if $pre_poison }; my $guard = $schema->txn_scope_guard; eval { die 'post-GIFT!' if $post_poison }; $schema->resultset ('Artist')->create ({ name => 'bohhoo'}); } local $TODO = 'Do not know how to deal with trapped exceptions occuring after guard instantiation...' if ( $post_poison and ( # take no chances on installation ( DBICTest::RunMode->is_plain and ($ENV{TRAVIS}||'') ne 'true' ) or # this always fails ! $pre_poison or # I do not understand why but on <= 5.8.8 and on 5.10.0 "$pre_poison && $post_poison" passes... ($] > 5.008008 and $] < 5.010000 ) or $] > 5.010000 )); is (@w, 2, "Both expected warnings found - \$\@ pre-poison: $pre_poison, post-poison: $post_poison" ); # just to mask off warning since we could not disconnect above $schema->storage->_dbh->disconnect; }} # add a TODO to catch when Text::Balanced is finally fixed # https://rt.cpan.org/Public/Bug/Display.html?id=74994 # # while it doesn't matter much for DBIC itself, this particular bug # is a *BANE*, and DBIC is to bump its dep as soon as possible { require Text::Balanced; my @w; local $SIG{__WARN__} = sub { $_[0] =~ /External exception class .+? \Qimplements partial (broken) overloading/ ? push @w, @_ : warn @_ }; lives_ok { # this is what poisons $@ Text::Balanced::extract_bracketed( '(foo', '()' ); my $s = DBICTest::Schema->connect('dbi:SQLite::memory:'); my $g = $s->txn_scope_guard; $g->commit; } 'Broken Text::Balanced is not screwing up txn_guard'; local $TODO = 'RT#74994 *STILL* not fixed'; is(scalar @w, 0, 'no warnings \o/'); } # ensure Devel::StackTrace-refcapture-like effects are countered { my $s = DBICTest::Schema->connect('dbi:SQLite::memory:'); my $g = $s->txn_scope_guard; my @arg_capture; { local $SIG{__WARN__} = sub { package DB; my $frnum; while (my @f = caller(++$frnum) ) { push @arg_capture, @DB::args; } }; undef $g; 1; } warnings_exist { @arg_capture = () } qr/\QPreventing *MULTIPLE* DESTROY() invocations on DBIx::Class::Storage::TxnScopeGuard/ ; } done_testing; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/storage/cursor.t��������������������������������������������������������������0000644�0001750�0001750�00000001127�14240132261�016510� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(cursor_class => 'DBICTest::Cursor'); lives_ok { is($schema->resultset("Artist")->search(), 3, "Three artists returned"); } 'Custom cursor autoloaded'; SKIP: { eval { require Class::Unload } or skip 'component_class reentrancy test requires Class::Unload', 1; Class::Unload->unload('DBICTest::Cursor'); lives_ok { is($schema->resultset("Artist")->search(), 3, "Three artists still returned"); } 'Custom cursor auto re-loaded'; } done_testing; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/storage/nobindvars.t����������������������������������������������������������0000644�0001750�0001750�00000002231�14240132261�017335� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; { # Fake storage driver for SQLite + no bind variables package DBICTest::SQLite::NoBindVars; use base qw( DBIx::Class::Storage::DBI::NoBindVars DBIx::Class::Storage::DBI::SQLite ); use mro 'c3'; } my $schema = DBICTest->init_schema (storage_type => 'DBICTest::SQLite::NoBindVars', no_populate => 1); # test primary key handling my $new = $schema->resultset('Artist')->create({ name => 'foo' }); ok($new->artistid, "Auto-PK worked"); # test LIMIT support for (1..6) { $schema->resultset('Artist')->create({ name => 'Artist ' . $_ }); } my $it = $schema->resultset('Artist')->search( {}, { rows => 3, offset => 2, order_by => 'artistid' } ); is( $it->count, 3, "LIMIT count ok" ); # ask for 3 rows out of 7 artists $schema->is_executed_sql_bind( sub { is( $it->next->name, "Artist 2", "iterator->next ok" ); $it->next; $it->next; is( $it->next, undef, "next past end of resultset ok" ); }, [ [ 'SELECT me.artistid, me.name, me.rank, me.charfield FROM artist me ORDER BY artistid LIMIT 3 OFFSET 2' ], ], 'Correctly interpolated SQL' ); done_testing; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/storage/quote_names.t���������������������������������������������������������0000644�0001750�0001750�00000011354�14240132261�017516� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Data::Dumper::Concise; use Try::Tiny; use lib qw(t/lib); use DBICTest; my %expected = ( 'DBIx::Class::Storage::DBI' => # no default quote_char { name_sep => '.' }, 'DBIx::Class::Storage::DBI::MSSQL' => { quote_char => [ '[', ']' ], name_sep => '.' }, 'DBIx::Class::Storage::DBI::DB2' => { quote_char => '"', name_sep => '.' }, 'DBIx::Class::Storage::DBI::Informix' => { quote_char => '"', name_sep => '.' }, 'DBIx::Class::Storage::DBI::InterBase' => { quote_char => '"', name_sep => '.' }, 'DBIx::Class::Storage::DBI::mysql' => { quote_char => '`', name_sep => '.' }, 'DBIx::Class::Storage::DBI::Pg' => { quote_char => '"', name_sep => '.' }, 'DBIx::Class::Storage::DBI::ODBC::ACCESS' => { quote_char => [ '[', ']' ], name_sep => '.' }, # Not testing this one, it's a pain. # 'DBIx::Class::Storage::DBI::ODBC::DB2_400_SQL' => # { quote_char => '"', name_sep => qr/must be connected/ }, 'DBIx::Class::Storage::DBI::Oracle::Generic' => { quote_char => '"', name_sep => '.' }, 'DBIx::Class::Storage::DBI::SQLAnywhere' => { quote_char => '"', name_sep => '.' }, 'DBIx::Class::Storage::DBI::SQLite' => { quote_char => '"', name_sep => '.' }, 'DBIx::Class::Storage::DBI::Sybase::ASE' => { quote_char => [ '[', ']' ], name_sep => '.' }, ); for my $class (keys %expected) { SKIP: { eval "require ${class}" or skip "Skipping test of quotes for $class due to missing dependencies", 1; my $mapping = $expected{$class}; my ($quote_char, $name_sep) = @$mapping{qw/quote_char name_sep/}; my $instance = $class->new; my $quote_char_text = dumper($quote_char); if (exists $mapping->{quote_char}) { is_deeply $instance->sql_quote_char, $quote_char, "sql_quote_char for $class is $quote_char_text"; } is $instance->sql_name_sep, $name_sep, "sql_name_sep for $class is '$name_sep'"; }} # Try quote_names with available DBs. # Env var to base class mapping, these are the DBs I actually have. # the SQLITE is a fake memory dsn local $ENV{DBICTEST_SQLITE_DSN} = 'dbi:SQLite::memory:'; my %dbs = ( SQLITE => 'DBIx::Class::Storage::DBI::SQLite', ORA => 'DBIx::Class::Storage::DBI::Oracle::Generic', PG => 'DBIx::Class::Storage::DBI::Pg', MYSQL => 'DBIx::Class::Storage::DBI::mysql', DB2 => 'DBIx::Class::Storage::DBI::DB2', SYBASE => 'DBIx::Class::Storage::DBI::Sybase::ASE', SQLANYWHERE => 'DBIx::Class::Storage::DBI::SQLAnywhere', SQLANYWHERE_ODBC => 'DBIx::Class::Storage::DBI::SQLAnywhere', FIREBIRD => 'DBIx::Class::Storage::DBI::InterBase', FIREBIRD_ODBC => 'DBIx::Class::Storage::DBI::InterBase', INFORMIX => 'DBIx::Class::Storage::DBI::Informix', MSSQL_ODBC => 'DBIx::Class::Storage::DBI::MSSQL', ); # lie that we already locked stuff - the tests below do not touch anything # unless we are under travis, where the OOM killers reign and things are rough $ENV{DBICTEST_LOCK_HOLDER} = -1 unless DBICTest::RunMode->is_ci; # Make sure oracle is tried last - some clients (e.g. 10.2) have symbol # clashes with libssl, and will segfault everything coming after them for my $db (sort { $a eq 'ORA' ? 1 : $b eq 'ORA' ? -1 : $a cmp $b } keys %dbs) { my ($dsn, $user, $pass) = map $ENV{"DBICTEST_${db}_$_"}, qw/DSN USER PASS/; next unless $dsn; my $schema; my $sql_maker = try { $schema = DBICTest::Schema->connect($dsn, $user, $pass, { quote_names => 1 }); $schema->storage->ensure_connected; $schema->storage->sql_maker; } || next; my ($exp_quote_char, $exp_name_sep) = @{$expected{$dbs{$db}}}{qw/quote_char name_sep/}; my ($quote_char_text, $name_sep_text) = map { dumper($_) } ($exp_quote_char, $exp_name_sep); is_deeply $sql_maker->quote_char, $exp_quote_char, "$db quote_char with quote_names => 1 is $quote_char_text"; is $sql_maker->name_sep, $exp_name_sep, "$db name_sep with quote_names => 1 is $name_sep_text"; # if something was produced - it better be quoted if ( # the SQLT producer has no idea what quotes are :/ ! grep { $db eq $_ } qw( SYBASE DB2 ) and my $ddl = try { $schema->deployment_statements } ) { my $quoted_artist = $sql_maker->_quote('artist'); like ($ddl, qr/^CREATE\s+TABLE\s+\Q$quoted_artist/msi, "$db DDL contains expected quoted table name"); } } done_testing; sub dumper { my $val = shift; my $dd = DumperObject; $dd->Indent(0); return $dd->Values([ $val ])->Dump; } 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/storage/exception.t�����������������������������������������������������������0000644�0001750�0001750�00000001721�14240132261�017171� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use lib qw(t/lib); use DBICTest; use DBICTest::Schema; # make sure nothing eats the exceptions (an unchecked eval in Storage::DESTROY used to be a problem) { package Dying::Storage; use warnings; use strict; use base 'DBIx::Class::Storage::DBI'; __PACKAGE__->sql_limit_dialect ('LimitOffset'); sub _populate_dbh { my $self = shift; my $death = $self->_dbi_connect_info->[3]{die}; die "storage test died: $death" if $death eq 'before_populate'; my $ret = $self->next::method (@_); die "storage test died: $death" if $death eq 'after_populate'; return $ret; } } for (qw/before_populate after_populate/) { throws_ok (sub { my $schema = DBICTest::Schema->clone; $schema->storage_type ('Dying::Storage'); $schema->connection (DBICTest->_database, { die => $_ }); $schema->storage->ensure_connected; }, qr/$_/, "$_ exception found"); } done_testing; �����������������������������������������������DBIx-Class-0.082843/t/storage/error.t���������������������������������������������������������������0000644�0001750�0001750�00000005722�14240132261�016331� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Warn; use Test::Exception; use lib qw(t/lib); use DBICTest; for my $conn_args ( [ on_connect_do => "_NOPE_" ], [ on_connect_call => sub { shift->_dbh->do("_NOPE_") } ], [ on_connect_call => "_NOPE_" ], ) { for my $method (qw( ensure_connected _server_info _get_server_version _get_dbh )) { my $s = DBICTest->init_schema( no_deploy => 1, on_disconnect_call => sub { fail 'Disconnector should not be invoked' }, @$conn_args ); my $storage = $s->storage; $storage = $storage->master if $storage->isa('DBIx::Class::Storage::DBI::Replicated'); ok( ! $storage->connected, 'Starting unconnected' ); my $desc = "calling $method with broken on_connect action @{[ explain $conn_args ]}"; throws_ok { $storage->$method } qr/ _NOPE_ \b/x, "Throwing correctly when $desc"; ok( ! $storage->connected, "Still not connected after $desc" ); # this checks that the on_disconect_call FAIL won't trigger $storage->disconnect; } } for my $conn_args ( [ on_disconnect_do => "_NOPE_" ], [ on_disconnect_call => sub { shift->_dbh->do("_NOPE_") } ], [ on_disconnect_call => "_NOPE_" ], ) { my $s = DBICTest->init_schema( no_deploy => 1, @$conn_args ); my $storage = $s->storage; $storage = $storage->master if $storage->isa('DBIx::Class::Storage::DBI::Replicated'); my $desc = "broken on_disconnect action @{[ explain $conn_args ]}"; # connect + ping my $dbh = $storage->dbh; ok ($dbh->FETCH('Active'), 'Freshly connected DBI handle is healthy'); warnings_exist { eval { $storage->disconnect } } [ qr/\QDisconnect action failed\E .+ _NOPE_ \b/x ], "Found warning of failed $desc"; ok (! $dbh->FETCH('Active'), "Actual DBI disconnect was not prevented by $desc" ); } my $schema = DBICTest->init_schema; warnings_are ( sub { throws_ok ( sub { $schema->resultset('CD')->create({ title => 'vacation in antarctica' }) }, qr/DBI Exception.+(?x: \QNOT NULL constraint failed: cd.artist\E | \Qcd.artist may not be NULL\E )/s ); # as opposed to some other error }, [], 'No warnings besides exception' ); my $dbh = $schema->storage->dbh; throws_ok ( sub { $dbh->do ('INSERT INTO nonexistent_table VALUES (1)') }, qr/DBI Exception.+no such table.+nonexistent_table/s, 'DBI exceptions properly handled by dbic-installed callback' ); # This usage is a bit unusual but it was actually seen in the wild # destruction of everything except the $dbh should use the proper # exception fallback: SKIP: { if ( !!DBIx::Class::_ENV_::PEEPEENESS ) { skip "Your perl version $] appears to leak like a sieve - skipping garbage collected \$schema test", 1; } undef ($schema); throws_ok ( sub { $dbh->do ('INSERT INTO nonexistent_table VALUES (1)') }, qr/DBI Exception.+unhandled by DBIC.+no such table.+nonexistent_table/s, 'callback works after $schema is gone' ); } done_testing; ����������������������������������������������DBIx-Class-0.082843/t/51threadtxn.t�����������������������������������������������������������������0000644�0001750�0001750�00000006233�14240132261�015701� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# README: If you set the env var to a number greater than 10, # we will use that many children use Config; BEGIN { unless ($Config{useithreads}) { print "1..0 # SKIP your perl does not support ithreads\n"; exit 0; } if ($INC{'Devel/Cover.pm'}) { print "1..0 # SKIP Devel::Cover does not work with threads yet\n"; exit 0; } } use threads; use strict; use warnings; use Test::More; plan skip_all => 'DBIC does not actively support threads before perl 5.8.5' if $] < '5.008005'; use DBIx::Class::Optional::Dependencies (); use Scalar::Util 'weaken'; use lib qw(t/lib); use DBICTest; my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/}; plan skip_all => 'Set $ENV{DBICTEST_PG_DSN}, _USER and _PASS to run this test' . ' (note: creates and drops a table named artist!)' unless ($dsn && $user); plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('rdbms_pg') unless DBIx::Class::Optional::Dependencies->req_ok_for ('rdbms_pg'); my $num_children = $ENV{DBICTEST_THREAD_STRESS} || 1; if($num_children !~ /^[0-9]+$/ || $num_children < 10) { $num_children = 10; } use_ok('DBICTest::Schema'); my $schema = DBICTest::Schema->connect($dsn, $user, $pass, { AutoCommit => 1, RaiseError => 1, PrintError => 0 }); my $parent_rs; eval { my $dbh = $schema->storage->dbh; { local $SIG{__WARN__} = sub {}; eval { $dbh->do("DROP TABLE cd") }; $dbh->do("CREATE TABLE cd (cdid serial PRIMARY KEY, artist INTEGER NOT NULL UNIQUE, title VARCHAR(100) NOT NULL UNIQUE, year VARCHAR(100) NOT NULL, genreid INTEGER, single_track INTEGER);"); } $schema->resultset('CD')->create({ title => 'vacation in antarctica', artist => 123, year => 1901 }); $schema->resultset('CD')->create({ title => 'vacation in antarctica part 2', artist => 456, year => 1901 }); $parent_rs = $schema->resultset('CD')->search({ year => 1901 }); is ($parent_rs->count, 2); }; ok(!$@) or diag "Creation eval failed: $@"; my @children; while(@children < $num_children) { my $newthread = async { my $tid = threads->tid; weaken(my $weak_schema = $schema); weaken(my $weak_parent_rs = $parent_rs); $schema->txn_do(sub { my $child_rs = $weak_schema->resultset('CD')->search({ year => 1901 }); my $row = $weak_parent_rs->next; if($row && $row->get_column('artist') =~ /^(?:123|456)$/) { $weak_schema->resultset('CD')->create({ title => "test success $tid", artist => $tid, year => scalar(@children) }); } }); sleep(1); # tasty crashes without this }; die "Thread creation failed: $! $@" if !defined $newthread; push(@children, $newthread); } ok(1, "past spawning"); { $_->join for(@children); } ok(1, "past joining"); while(@children) { my $child = pop(@children); my $tid = $child->tid; my $rs = $schema->resultset('CD')->search({ title => "test success $tid", artist => $tid, year => scalar(@children) }); is($rs->next->get_column('artist'), $tid, "Child $tid successful"); } ok(1, "Made it to the end"); $schema->storage->dbh->do("DROP TABLE cd"); done_testing; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/resultset/��������������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�015414� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/resultset/as_query.t����������������������������������������������������������0000644�0001750�0001750�00000004211�14240132261�017406� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); my $art_rs = $schema->resultset('Artist'); my $cdrs = $schema->resultset('CD'); { is_same_sql_bind( $art_rs->as_query, "(SELECT me.artistid, me.name, me.rank, me.charfield FROM artist me)", [], ); } $art_rs = $art_rs->search({ name => 'Billy Joel' }); my $name_resolved_bind = [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'name' } => 'Billy Joel' ]; { is_same_sql_bind( $art_rs->as_query, "(SELECT me.artistid, me.name, me.rank, me.charfield FROM artist me WHERE ( name = ? ))", [ $name_resolved_bind ], ); } $art_rs = $art_rs->search({ rank => 2 }); my $rank_resolved_bind = [ { sqlt_datatype => 'integer', dbic_colname => 'rank' } => 2 ]; { is_same_sql_bind( $art_rs->as_query, "(SELECT me.artistid, me.name, me.rank, me.charfield FROM artist me WHERE name = ? AND rank = ? )", [ $name_resolved_bind, $rank_resolved_bind ], ); } my $rscol = $art_rs->get_column( 'charfield' ); { is_same_sql_bind( $rscol->as_query, "(SELECT me.charfield FROM artist me WHERE name = ? AND rank = ? )", [ $name_resolved_bind, $rank_resolved_bind ], ); } { my $rs = $schema->resultset("CD")->search( { 'artist.name' => 'Caterwauler McCrae' }, { join => [qw/artist/]} ); my $subsel_rs = $schema->resultset("CD")->search( { cdid => { IN => $rs->get_column('cdid')->as_query } } ); is($subsel_rs->count, $rs->count, 'Subselect on PK got the same row count'); } is_same_sql_bind($schema->resultset('Artist')->search({ rank => 1, }, { from => $schema->resultset('Artist')->search({ 'name' => 'frew'})->as_query, })->as_query, '(SELECT me.artistid, me.name, me.rank, me.charfield FROM ( SELECT me.artistid, me.name, me.rank, me.charfield FROM artist me WHERE ( ( name = ? ) ) ) WHERE ( ( rank = ? ) ) )', [ [{ dbic_colname => 'name', sqlt_datatype => 'varchar', sqlt_size => 100 }, 'frew'], [{ dbic_colname => 'rank' }, 1], ], 'from => ...->as_query works' ); done_testing; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/resultset/find_on_subquery_cond.t���������������������������������������������0000644�0001750�0001750�00000001066�14240132261�022141� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); my $rs = $schema->resultset('Artist'); for my $id ( 2, \' = 2 ', \[ '= ?', 2 ], ) { lives_ok { is( $rs->find({ artistid => $id })->id, 2 ) } "Correctly found artist with id of @{[ explain $id ]}"; } for my $id ( 2, \'2', \[ '?', 2 ], ) { my $cond = { artistid => { '=', $id } }; lives_ok { is( $rs->find($cond)->id, 2 ) } "Correctly found artist with id of @{[ explain $cond ]}"; } done_testing; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/resultset/nulls_only.t��������������������������������������������������������0000644�0001750�0001750�00000001215�14240132261�017755� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use lib qw(t/lib); use Test::More; use DBICTest; my $schema = DBICTest->init_schema(); my $cd_rs = $schema->resultset('CD')->search ({ genreid => undef }, { columns => [ 'genreid' ]} ); my $count = $cd_rs->count; cmp_ok ( $count, '>', 1, 'several CDs with no genre'); my @objects = $cd_rs->all; is (scalar @objects, $count, 'Correct amount of objects without limit'); isa_ok ($_, 'DBICTest::CD') for @objects; is_deeply ( [ map { values %{{$_->get_columns}} } (@objects) ], [ (undef) x $count ], 'All values are indeed undef' ); isa_ok ($cd_rs->search ({}, { rows => 1 })->single, 'DBICTest::CD'); done_testing; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/resultset/as_subselect_rs.t���������������������������������������������������0000644�0001750�0001750�00000004412�14240132261�020741� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use lib qw(t/lib); use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); my $new_rs = $schema->resultset('Artist')->search({ 'artwork_to_artist.artist_id' => 1 }, { join => 'artwork_to_artist' }); lives_ok { $new_rs->count } 'regular search works'; lives_ok { $new_rs->search({ 'artwork_to_artist.artwork_cd_id' => 1})->count } '... and chaining off that using join works'; lives_ok { $new_rs->search({ 'artwork_to_artist.artwork_cd_id' => 1})->as_subselect_rs->count } '... and chaining off the virtual view works'; dies_ok { $new_rs->as_subselect_rs->search({'artwork_to_artist.artwork_cd_id'=> 1})->count } q{... but chaining off of a virtual view using join doesn't work}; my $book_rs = $schema->resultset ('BooksInLibrary')->search ({}, { join => 'owner' }); is_same_sql_bind ( $book_rs->as_subselect_rs->as_query, '(SELECT me.id, me.source, me.owner, me.title, me.price FROM ( SELECT me.id, me.source, me.owner, me.title, me.price FROM books me JOIN owners owner ON owner.id = me.owner WHERE ( source = ? ) ) me )', [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ] ], 'Resultset-class attributes do not seep outside of the subselect', ); is_same_sql_bind( $schema->resultset('CD')->search ({}, { rows => 2, join => [ 'genre', { artist => 'cds' } ], distinct => 1, columns => { title => 'me.title', artist__name => 'artist.name', genre__name => 'genre.name', cds_for_artist => \ '(SELECT COUNT(*) FROM cds WHERE cd.artist = artist.id)', }, order_by => { -desc => 'me.year' }, })->count_rs->as_query, '( SELECT COUNT( * ) FROM ( SELECT artist.name AS artist__name, (SELECT COUNT(*) FROM cds WHERE cd.artist = artist.id), genre.name AS genre__name, me.title, me.year FROM cd me LEFT JOIN genre genre ON genre.genreid = me.genreid JOIN artist artist ON artist.artistid = me.artist GROUP BY artist.name, (SELECT COUNT(*) FROM cds WHERE cd.artist = artist.id), genre.name, me.title, me.year LIMIT ? ) me )', [ [{ sqlt_datatype => 'integer' } => 2 ] ], ); done_testing; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/resultset/is_paged.t����������������������������������������������������������0000644�0001750�0001750�00000000530�14240132261�017331� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use lib qw(t/lib); use Test::More; use DBICTest; my $schema = DBICTest->init_schema(); my $tkfks = $schema->resultset('Artist'); ok !$tkfks->is_paged, 'vanilla resultset is not paginated'; my $paginated = $tkfks->search(undef, { page => 5 }); ok $paginated->is_paged, 'resultset is paginated now'; done_testing; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/resultset/inflatemap_abuse.t��������������������������������������������������0000644�0001750�0001750�00000005646�14240132261�021072� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use lib qw(t/lib); use DBICTest; # From http://lists.scsys.co.uk/pipermail/dbix-class/2013-February/011119.html # # > Right, at this point we have an "undefined situation turned into an # > unplanned feature", therefore 0.08242 will downgrade the exception to a # > single-warning-per-process. This seems like a sane middle ground for # > "you gave me an 'as' that worked by accident before - fix it at your # > convenience". # # When the things were reshuffled it became apparent implementing a warning # for the HRI case *only* is going to complicate the code a lot, without # adding much benefit at this point. So just make sure everything works the # way it used to and move on my $s = DBICTest->init_schema; my $rs_2nd_track = $s->resultset('Track')->search( { 'me.position' => 2 }, { join => { cd => 'artist' }, columns => [ 'me.title', { 'artist.cdtitle' => 'cd.title' }, 'artist.name' ], order_by => [ 'artist.name', { -desc => 'cd.cdid' }, 'me.trackid' ], } ); is_deeply ( [ map { $_->[-1] } $rs_2nd_track->cursor->all ], [ ('Caterwauler McCrae') x 3, 'Random Boy Band', 'We Are Goth' ], 'Artist name cartesian product correct off cursor', ); is_deeply ( $rs_2nd_track->all_hri, [ { artist => { cdtitle => "Caterwaulin' Blues", name => "Caterwauler McCrae" }, title => "Howlin" }, { artist => { cdtitle => "Forkful of bees", name => "Caterwauler McCrae" }, title => "Stripy" }, { artist => { cdtitle => "Spoonful of bees", name => "Caterwauler McCrae" }, title => "Apiary" }, { artist => { cdtitle => "Generic Manufactured Singles", name => "Random Boy Band" }, title => "Boring Song" }, { artist => { cdtitle => "Come Be Depressed With Us", name => "We Are Goth" }, title => "Under The Weather" } ], 'HRI with invalid inflate map works' ); throws_ok { $rs_2nd_track->next } qr!\QInflation into non-existent relationship 'artist' of 'Track' requested, check the inflation specification (columns/as) ending in '...artist.name'!, 'Correct exception on illegal ::Row inflation attempt' ; # make sure has_many column redirection does not do weird stuff when collapse is requested for my $pref_args ( { prefetch => 'cds'}, { collapse => 1 } ) { for my $col_and_join_args ( { '+columns' => { 'cd_title' => 'cds_2.title' }, join => [ 'cds', 'cds' ] }, { '+columns' => { 'cd_title' => 'cds.title' }, join => 'cds' }, { '+columns' => { 'cd_gr_name' => 'genre.name' }, join => { cds => 'genre' } }, ) { for my $call (qw(next all first)) { my $weird_rs = $s->resultset('Artist')->search({}, { %$col_and_join_args, %$pref_args, }); throws_ok { $weird_rs->$call } qr/\QResult collapse not possible - selection from a has_many source redirected to the main object/ for (1,2); } } } done_testing; ������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/resultset/is_ordered.t��������������������������������������������������������0000644�0001750�0001750�00000004663�14240132261�017710� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use lib qw(t/lib); use Test::More; use DBICTest; my $schema = DBICTest->init_schema(); my $rs = $schema->resultset('Artist'); ok !$rs->is_ordered, 'vanilla resultset is not ordered'; # Simple ordering with a single column { my $ordered = $rs->search(undef, { order_by => 'artistid' }); ok $ordered->is_ordered, 'Simple column ordering detected by is_ordered'; } # Hashref order direction { my $ordered = $rs->search(undef, { order_by => { -desc => 'artistid' } }); ok $ordered->is_ordered, 'resultset with order direction is_ordered'; } # Column ordering with literal SQL { my $ordered = $rs->search(undef, { order_by => \'artistid DESC' }); ok $ordered->is_ordered, 'resultset with literal SQL is_ordered'; } # Multiple column ordering { my $ordered = $rs->search(undef, { order_by => ['artistid', 'name'] }); ok $ordered->is_ordered, 'ordering with multiple columns as arrayref is ordered'; } # More complicated ordering { my $ordered = $rs->search(undef, { order_by => [ { -asc => 'artistid' }, { -desc => 'name' }, ] }); ok $ordered->is_ordered, 'more complicated resultset ordering is_ordered'; } # Empty multi-column ordering arrayref { my $ordered = $rs->search(undef, { order_by => [] }); ok !$ordered->is_ordered, 'ordering with empty arrayref is not ordered'; } # Multi-column ordering syntax with empty hashref { my $ordered = $rs->search(undef, { order_by => [{}] }); ok !$ordered->is_ordered, 'ordering with [{}] is not ordered'; } # Remove ordering after being set { my $ordered = $rs->search(undef, { order_by => 'artistid' }); ok $ordered->is_ordered, 'resultset with ordering applied works..'; my $unordered = $ordered->search(undef, { order_by => undef }); ok !$unordered->is_ordered, '..and is not ordered with ordering removed'; } # Search without ordering { my $ordered = $rs->search({ name => 'We Are Goth' }, { join => 'cds' }); ok !$ordered->is_ordered, 'WHERE clause but no order_by is not ordered'; } # Other functions without ordering { # Join my $joined = $rs->search(undef, { join => 'cds' }); ok !$joined->is_ordered, 'join but no order_by is not ordered'; # Group By my $grouped = $rs->search(undef, { group_by => 'rank' }); ok !$grouped->is_ordered, 'group_by but no order_by is not ordered'; # Paging my $paged = $rs->search(undef, { page=> 5 }); ok !$paged->is_ordered, 'paging but no order_by is not ordered'; } done_testing; �����������������������������������������������������������������������������DBIx-Class-0.082843/t/resultset/inflate_result_api.t������������������������������������������������0000644�0001750�0001750�00000051274�14240132261�021442� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; no warnings 'exiting'; use Test::More; use Test::Deep; use lib qw(t/lib); use Test::Exception; use DBICTest; my $schema = DBICTest->init_schema(no_populate => 1); $schema->resultset('Artist')->create({ name => 'JMJ', cds => [{ title => 'Magnetic Fields', year => 1981, genre => { name => 'electro' }, tracks => [ { title => 'm1' }, { title => 'm2' }, { title => 'm3' }, { title => 'm4' }, ], } ] }); $schema->resultset('CD')->create({ title => 'Equinoxe', year => 1978, artist => { name => 'JMJ' }, genre => { name => 'electro' }, tracks => [ { title => 'e1' }, { title => 'e2' }, { title => 'e3' }, ], single_track => { title => 'o1', cd => { title => 'Oxygene', year => 1976, artist => { name => 'JMJ' }, tracks => [ { title => 'o2', position => 2}, # the position should not be needed here, bug in MC ], }, }, }); $schema->resultset('CD')->create({ artist => 1, year => 1977, title => "fuzzy_1" }); $schema->resultset('Artist')->create({ name => "${_}_cdless" }) for (qw( Z A )); # subs at the end of the test refer to this my $native_inflator; ### TESTS START # run entire test twice - with and without "native inflator" INFTYPE: for ('', '(native inflator)') { $native_inflator = $_; cmp_structures( rs_contents( $schema->resultset ('CD')->search_rs ({}, { prefetch => { single_track => { cd => 'artist' } }, order_by => 'me.cdid', }) ), [ [ { cdid => 1, single_track => undef, artist => 1, genreid => 1, year => 1981, title => "Magnetic Fields" }, { single_track => code(sub { null_branch ( \@_, [ { trackid => undef, title => undef, position => undef, cd => undef, last_updated_at => undef, last_updated_on => undef }, { cd => code(sub { null_branch ( \@_, [ { cdid => undef, single_track => undef, artist => undef, genreid => undef, year => undef, title => undef }, { artist => code(sub { null_branch ( \@_, [ { artistid => undef, name => undef, charfield => undef, rank => undef } ] ) } ) } ] ) } ) } ] ) } ) } ], [ { cdid => 2, single_track => undef, artist => 1, genreid => undef, year => 1976, title => "Oxygene" }, { single_track => code(sub { null_branch ( \@_, [ { trackid => undef, title => undef, position => undef, cd => undef, last_updated_at => undef, last_updated_on => undef }, { cd => code(sub { null_branch ( \@_, [ { cdid => undef, single_track => undef, artist => undef, genreid => undef, year => undef, title => undef }, { artist => code(sub { null_branch ( \@_, [ { artistid => undef, name => undef, charfield => undef, rank => undef } ] ) } ) } ] ) } ) } ] ) } ) } ], [ { cdid => 3, single_track => 6, artist => 1, genreid => 1, year => 1978, title => "Equinoxe" }, { single_track => [ { trackid => 6, title => 'o1', position => 1, cd => 2, last_updated_at => undef, last_updated_on => undef }, { cd => [ { cdid => 2, single_track => undef, artist => 1, genreid => undef, year => 1976, title => "Oxygene" }, { artist => [ { artistid => 1, name => 'JMJ', charfield => undef, rank => 13 } ] } ] } ] } ], [ { cdid => 4, single_track => undef, artist => 1, genreid => undef, year => 1977, title => "fuzzy_1" }, { single_track => code(sub { null_branch ( \@_, [ { trackid => undef, title => undef, position => undef, cd => undef, last_updated_at => undef, last_updated_on => undef }, { cd => code(sub { null_branch ( \@_, [ { cdid => undef, single_track => undef, artist => undef, genreid => undef, year => undef, title => undef }, { artist => code(sub { null_branch ( \@_, [ { artistid => undef, name => undef, charfield => undef, rank => undef } ] ) } ) } ] ) } ) } ] ) } ) } ], ], "Simple 1:1 descend with classic prefetch $native_inflator" ); cmp_structures( rs_contents( $schema->resultset ('CD')->search_rs ({}, { join => { single_track => { cd => 'artist' } }, columns => [ { 'year' => 'me.year' }, { 'genreid' => 'me.genreid' }, { 'single_track.cd.artist.artistid' => 'artist.artistid' }, { 'title' => 'me.title' }, { 'artist' => 'me.artist' }, ], order_by => 'me.cdid', }) ), [ [ { artist => 1, genreid => 1, year => 1981, title => "Magnetic Fields" }, { single_track => code(sub { null_branch ( \@_, [ undef, { cd => [ undef, { artist => [ { artistid => undef } ] } ] } ] ) } ) } ], [ { artist => 1, genreid => undef, year => 1976, title => "Oxygene" }, { single_track => code(sub { null_branch ( \@_, [ undef, { cd => [ undef, { artist => [ { artistid => undef } ] } ] } ] ) } ) } ], [ { artist => 1, genreid => 1, year => 1978, title => "Equinoxe" }, { single_track => [ undef, { cd => [ undef, { artist => [ { artistid => 1 } ] } ] } ] } ], [ { artist => 1, genreid => undef, year => 1977, title => "fuzzy_1" }, { single_track => code(sub { null_branch ( \@_, [ undef, { cd => [ undef, { artist => [ { artistid => undef } ] } ] } ] ) } ) } ], ], "Simple 1:1 descend with missing selectors $native_inflator", ); cmp_structures( rs_contents( $schema->resultset ('CD')->search_rs ({}, { prefetch => [ { single_track => { cd => { artist => { cds => 'tracks' } } } } ], order_by => [qw/me.cdid tracks.trackid/], }) ), [ [ { cdid => 1, single_track => undef, artist => 1, genreid => 1, year => 1981, title => "Magnetic Fields" }, { single_track => code(sub { null_collapsed_branch ( \@_, [ { trackid => undef, title => undef, position => undef, cd => undef, last_updated_at => undef, last_updated_on => undef }, { cd => [ { cdid => undef, single_track => undef, artist => undef, genreid => undef, year => undef, title => undef }, { artist => [ { artistid => undef, name => undef, charfield => undef, rank => undef }, { cds => code(sub { null_collapsed_branch ( \@_, [ [ { cdid => undef, single_track => undef, artist => undef, genreid => undef, year => undef, title => undef }, { tracks => code(sub { null_collapsed_branch ( \@_, [ [ { trackid => undef, title => undef, position => undef, cd => undef, last_updated_at => undef, last_updated_on => undef }, ] ] ) } ) }, ] ] ) } ) }, ], }, ] }, ] ) } ) }, ], [ { cdid => 2, single_track => undef, artist => 1, genreid => undef, year => 1976, title => "Oxygene" }, { single_track => code(sub { null_collapsed_branch ( \@_, [ { trackid => undef, title => undef, position => undef, cd => undef, last_updated_at => undef, last_updated_on => undef }, { cd => [ { cdid => undef, single_track => undef, artist => undef, genreid => undef, year => undef, title => undef }, { artist => [ { artistid => undef, name => undef, charfield => undef, rank => undef }, { cds => code(sub { null_collapsed_branch ( \@_, [ [ { cdid => undef, single_track => undef, artist => undef, genreid => undef, year => undef, title => undef }, { tracks => code(sub { null_collapsed_branch ( \@_, [ [ { trackid => undef, title => undef, position => undef, cd => undef, last_updated_at => undef, last_updated_on => undef }, ] ] ) } ) }, ] ] ) } ) }, ], }, ] }, ] ) } ) }, ], [ { cdid => 3, single_track => 6, artist => 1, genreid => 1, year => 1978, title => "Equinoxe" }, { single_track => [ { trackid => 6, title => 'o1', position => 1, cd => 2, last_updated_at => undef, last_updated_on => undef }, { cd => [ { cdid => 2, single_track => undef, artist => 1, genreid => undef, year => 1976, title => "Oxygene" }, { artist => [ { artistid => 1, name => 'JMJ', charfield => undef, rank => 13 }, { cds => [ [ { cdid => 4, single_track => undef, artist => 1, genreid => undef, year => 1977, title => "fuzzy_1" }, { tracks => code(sub { null_collapsed_branch ( \@_, [ [ { trackid => undef, title => undef, position => undef, cd => undef, last_updated_at => undef, last_updated_on => undef } ], ] ) } ) }, ], [ { cdid => 1, single_track => undef, artist => 1, genreid => 1, year => 1981, title => "Magnetic Fields" }, { tracks => [ [ { trackid => 1, title => 'm1', position => 1, cd => 1, last_updated_at => undef, last_updated_on => undef } ], [ { trackid => 2, title => 'm2', position => 2, cd => 1, last_updated_at => undef, last_updated_on => undef } ], [ { trackid => 3, title => 'm3', position => 3, cd => 1, last_updated_at => undef, last_updated_on => undef } ], [ { trackid => 4, title => 'm4', position => 4, cd => 1, last_updated_at => undef, last_updated_on => undef } ], ]}, ], [ { cdid => 2, single_track => undef, artist => 1, genreid => undef, year => 1976, title => "Oxygene" }, { tracks => [ [ { trackid => 5, title => 'o2', position => 2, cd => 2, last_updated_at => undef, last_updated_on => undef } ], [ { trackid => 6, title => 'o1', position => 1, cd => 2, last_updated_at => undef, last_updated_on => undef } ], ]}, ], [ { cdid => 3, single_track => 6, artist => 1, genreid => 1, year => 1978, title => "Equinoxe" }, { tracks => [ [ { trackid => 7, title => 'e1', position => 1, cd => 3, last_updated_at => undef, last_updated_on => undef } ], [ { trackid => 8, title => 'e2', position => 2, cd => 3, last_updated_at => undef, last_updated_on => undef } ], [ { trackid => 9, title => 'e3', position => 3, cd => 3, last_updated_at => undef, last_updated_on => undef } ], ]}, ], ]}, ] } ] } ] } ], [ { cdid => 4, single_track => undef, artist => 1, genreid => undef, year => 1977, title => "fuzzy_1" }, { single_track => code(sub { null_collapsed_branch ( \@_, [ { trackid => undef, title => undef, position => undef, cd => undef, last_updated_at => undef, last_updated_on => undef }, { cd => [ { cdid => undef, single_track => undef, artist => undef, genreid => undef, year => undef, title => undef }, { artist => [ { artistid => undef, name => undef, charfield => undef, rank => undef }, { cds => code(sub { null_collapsed_branch ( \@_, [ [ { cdid => undef, single_track => undef, artist => undef, genreid => undef, year => undef, title => undef }, { tracks => code(sub { null_collapsed_branch ( \@_, [ [ { trackid => undef, title => undef, position => undef, cd => undef, last_updated_at => undef, last_updated_on => undef }, ] ] ) } ) }, ] ] ) } ) }, ], }, ] }, ] ) } ) }, ], ], "Collapsing 1:1 ending in chained has_many with classic prefetch $native_inflator", ); cmp_structures ( rs_contents( $schema->resultset ('Artist')->search_rs ({}, { join => { cds => 'tracks' }, '+columns' => [ (map { "cds.$_" } $schema->source('CD')->columns), (map { +{ "cds.tracks.$_" => "tracks.$_" } } $schema->source('Track')->columns), ], order_by => [qw/cds.cdid tracks.trackid me.name/], }) ), [ [ { artistid => 3, name => 'A_cdless', charfield => undef, rank => 13 }, { cds => code(sub { null_branch ( \@_, [ { cdid => undef, single_track => undef, artist => undef, genreid => undef, year => undef, title => undef }, { tracks => code(sub { null_branch ( \@_, [ { trackid => undef, title => undef, position => undef, cd => undef, last_updated_at => undef, last_updated_on => undef }, ] ) } ) }, ] ) } ) }, ], [ { artistid => 2, name => 'Z_cdless', charfield => undef, rank => 13 }, { cds => code(sub { null_branch ( \@_, [ { cdid => undef, single_track => undef, artist => undef, genreid => undef, year => undef, title => undef }, { tracks => code(sub { null_branch ( \@_, [ { trackid => undef, title => undef, position => undef, cd => undef, last_updated_at => undef, last_updated_on => undef }, ] ) } ) }, ] ) } ) }, ], [ { artistid => 1, name => 'JMJ', charfield => undef, rank => 13 }, { cds => [ { cdid => 1, single_track => undef, artist => 1, genreid => 1, year => 1981, title => "Magnetic Fields" }, { tracks => [ { trackid => 1, title => 'm1', position => 1, cd => 1, last_updated_at => undef, last_updated_on => undef }, ]}, ]}, ], [ { artistid => 1, name => 'JMJ', charfield => undef, rank => 13 }, { cds => [ { cdid => 1, single_track => undef, artist => 1, genreid => 1, year => 1981, title => "Magnetic Fields" }, { tracks => [ { trackid => 2, title => 'm2', position => 2, cd => 1, last_updated_at => undef, last_updated_on => undef }, ]}, ]}, ], [ { artistid => 1, name => 'JMJ', charfield => undef, rank => 13 }, { cds => [ { cdid => 1, single_track => undef, artist => 1, genreid => 1, year => 1981, title => "Magnetic Fields" }, { tracks => [ { trackid => 3, title => 'm3', position => 3, cd => 1, last_updated_at => undef, last_updated_on => undef }, ]}, ]}, ], [ { artistid => 1, name => 'JMJ', charfield => undef, rank => 13 }, { cds => [ { cdid => 1, single_track => undef, artist => 1, genreid => 1, year => 1981, title => "Magnetic Fields" }, { tracks => [ { trackid => 4, title => 'm4', position => 4, cd => 1, last_updated_at => undef, last_updated_on => undef }, ]}, ]}, ], [ { artistid => 1, name => 'JMJ', charfield => undef, rank => 13 }, { cds => [ { cdid => 2, single_track => undef, artist => 1, genreid => undef, year => 1976, title => "Oxygene" }, { tracks => [ { trackid => 5, title => 'o2', position => 2, cd => 2, last_updated_at => undef, last_updated_on => undef }, ]}, ]}, ], [ { artistid => 1, name => 'JMJ', charfield => undef, rank => 13 }, { cds => [ { cdid => 2, single_track => undef, artist => 1, genreid => undef, year => 1976, title => "Oxygene" }, { tracks => [ { trackid => 6, title => 'o1', position => 1, cd => 2, last_updated_at => undef, last_updated_on => undef }, ]}, ]}, ], [ { artistid => 1, name => 'JMJ', charfield => undef, rank => 13 }, { cds => [ { cdid => 3, single_track => 6, artist => 1, genreid => 1, year => 1978, title => "Equinoxe" }, { tracks => [ { trackid => 7, title => 'e1', position => 1, cd => 3, last_updated_at => undef, last_updated_on => undef }, ]}, ]}, ], [ { artistid => 1, name => 'JMJ', charfield => undef, rank => 13 }, { cds => [ { cdid => 3, single_track => 6, artist => 1, genreid => 1, year => 1978, title => "Equinoxe" }, { tracks => [ { trackid => 8, title => 'e2', position => 2, cd => 3, last_updated_at => undef, last_updated_on => undef }, ]}, ]}, ], [ { artistid => 1, name => 'JMJ', charfield => undef, rank => 13 }, { cds => [ { cdid => 3, single_track => 6, artist => 1, genreid => 1, year => 1978, title => "Equinoxe" }, { tracks => [ { trackid => 9, title => 'e3', position => 3, cd => 3, last_updated_at => undef, last_updated_on => undef }, ]}, ]}, ], [ { artistid => 1, name => 'JMJ', charfield => undef, rank => 13 }, { cds => [ { cdid => 4, single_track => undef, artist => 1, genreid => undef, year => 1977, title => "fuzzy_1" }, { tracks => code(sub { null_branch ( \@_, [ { trackid => undef, title => undef, position => undef, cd => undef, last_updated_at => undef, last_updated_on => undef }, ] ) } ) }, ]}, ], ], "Non-Collapsing chained has_many $native_inflator", ); cmp_structures ( rs_contents( $schema->resultset ('Artist')->search_rs ({}, { collapse => 1, join => 'cds', columns => [qw( cds.title cds.artist )], order_by => [qw( me.name cds.title )], }) ), [ [ undef, { cds => code(sub { null_collapsed_branch ( \@_, [ [ { artist => undef, title => undef } ] ] ) } ) }, ], [ undef, { cds => [ [ { artist => 1, title => "Equinoxe" } ], [ { artist => 1, title => "Magnetic Fields" } ], [ { artist => 1, title => "Oxygene" } ], [ { artist => 1, title => "fuzzy_1" } ], ] } ], [ undef, { cds => code(sub { null_collapsed_branch ( \@_, [ [ { artist => undef, title => undef } ] ] ) } ) }, ], ], "Expected output of collapsing 1:M with empty root selection $native_inflator", ); } sub null_branch { cmp_deeply( $_[0][0], $native_inflator ? undef : bless( $_[1], $DBIx::Class::ResultSource::RowParser::Util::null_branch_class ), ); } sub null_collapsed_branch { cmp_deeply( $_[0][0], $native_inflator ? [] : bless( $_[1], $DBIx::Class::ResultSource::RowParser::Util::null_branch_class ), ); } { package DBICTest::_IRCapture; sub inflate_result { [@_[2,3]] }; } sub rs_contents { my $rs = shift; $rs->result_class('DBICTest::_IRCapture'); die 'eeeeek - preprocessed $rs' if defined $rs->{_result_inflator}{is_core_row}; $rs->{_result_inflator}{is_core_row} = 1 if $native_inflator; [$rs->all], } sub cmp_structures { my ($left, $right, $msg) = @_; local $Test::Builder::Level = $Test::Builder::Level + 1; cmp_deeply($left, $right, $msg||()) or next INFTYPE; } { package DBICTest::_DoubleResult; sub inflate_result { my $class = shift; return map { DBIx::Class::ResultClass::HashRefInflator->inflate_result(@_) } (1,2); } } my $oxygene_rs = $schema->resultset('CD')->search({ 'me.title' => 'Oxygene' }); is_deeply( [ $oxygene_rs->search({}, { result_class => 'DBICTest::_DoubleResult' })->all ], [ ({ $oxygene_rs->single->get_columns }) x 2 ], ); is_deeply( [ $oxygene_rs->search({}, { result_class => 'DBICTest::_DoubleResult', prefetch => [qw(artist tracks)], order_by => [qw(me.cdid tracks.title)], })->all ], [ (@{$oxygene_rs->search({}, { prefetch=> [qw(artist tracks)], order_by => [qw(me.cdid tracks.title)], })->all_hri}) x 2 ], ); { package DBICTest::_DieTrying; sub inflate_result { die "nyah nyah nyah"; } } throws_ok { $schema->resultset('CD')->search({}, { result_class => 'DBICTest::_DieTrying' })->all } qr/nyah nyah nyah/, 'Exception in custom inflate_result propagated correctly'; done_testing; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/resultset/plus_select.t�������������������������������������������������������0000644�0001750�0001750�00000004025�14240132261�020103� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); my $cd_rs = $schema->resultset('CD')->search ({genreid => { '!=', undef } }, { order_by => 'cdid' }); my $track_cnt = $cd_rs->search({}, { rows => 1 })->search_related ('tracks')->count; my %basecols = $cd_rs->first->get_columns; # the current implementation of get_inflated_columns will "inflate" # relationships by simply calling the accessor, when you have # identically named columns and relationships (you shouldn't anyway) # I consider this wrong, but at the same time appreciate the # ramifications of changing this. Thus the value override and the # TODO to go with it. Delete all of this if ever resolved. my %todo_rel_inflation_override = ( artist => $basecols{artist} ); { local $TODO = 'Treating relationships as inflatable data is wrong - see comment in ' . __FILE__; ok (! keys %todo_rel_inflation_override); } my $plus_rs = $cd_rs->search ( {}, { join => 'tracks', distinct => 1, '+select' => { count => 'tracks.trackid' }, '+as' => 'tr_cnt' }, ); is_deeply ( { $plus_rs->first->get_columns }, { %basecols, tr_cnt => $track_cnt }, 'extra columns returned by get_columns', ); is_deeply ( { $plus_rs->first->get_inflated_columns, %todo_rel_inflation_override }, { %basecols, tr_cnt => $track_cnt }, 'extra columns returned by get_inflated_columns without inflatable columns', ); SKIP: { skip ( "+select/get_inflated_columns tests need " . DBIx::Class::Optional::Dependencies->req_missing_for ('test_dt'), 1 ) unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt'); $schema->class('CD')->inflate_column( 'year', { inflate => sub { DateTime->new( year => shift ) }, deflate => sub { shift->year } } ); $basecols{year} = DateTime->new ( year => $basecols{year} ); is_deeply ( { $plus_rs->first->get_inflated_columns, %todo_rel_inflation_override }, { %basecols, tr_cnt => $track_cnt }, 'extra columns returned by get_inflated_columns', ); } done_testing; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/resultset/bind_attr.t���������������������������������������������������������0000644�0001750�0001750�00000007623�14240132261�017536� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema; my $where_bind = { where => \'name like ?', bind => [ 'Cat%' ], }; my $rs; { # First, the simple cases... $rs = $schema->resultset('Artist')->search( { artistid => 1 }, $where_bind, ); is ( $rs->count, 1, 'where/bind combined' ); $rs= $schema->resultset('Artist')->search({}, $where_bind) ->search({ artistid => 1}); is ( $rs->count, 1, 'where/bind first' ); $rs = $schema->resultset('Artist')->search({ artistid => 1}) ->search({}, $where_bind); is ( $rs->count, 1, 'where/bind last' ); # and the complex case $rs = $schema->resultset('CustomSql')->search({}, { bind => [ 1999 ] }) ->search({ 'artistid' => 1 }, { where => \'title like ?', bind => [ 'Spoon%' ] }); is ( $rs->count, 1, '...cookbook + chained search with extra bind' ); } { # More complex cases, based primarily on the Cookbook # "Arbitrary SQL through a custom ResultSource" technique, # which seems to be the only place the bind attribute is # documented. Breaking this technique probably breaks existing # application code. my $source = DBICTest::Artist->result_source_instance; my $new_source = $source->new($source); $new_source->source_name('Complex'); $new_source->name(\<<''); ( SELECT a.*, cd.cdid AS cdid, cd.title AS title, cd.year AS year FROM artist a JOIN cd ON cd.artist = a.artistid WHERE cd.year = ?) $schema->register_extra_source('Complex' => $new_source); $rs = $schema->resultset('Complex')->search({}, { bind => [ 1999 ] }); is ( $rs->count, 1, 'cookbook arbitrary sql example' ); $rs = $schema->resultset('Complex')->search({ 'artistid' => 1 }, { bind => [ 1999 ] }); is ( $rs->count, 1, '...cookbook + search condition' ); $rs = $schema->resultset('Complex')->search({}, { bind => [ 1999 ] }) ->search({ 'artistid' => 1 }); is ( $rs->count, 1, '...cookbook (bind first) + chained search' ); $rs = $schema->resultset('Complex')->search({}, { bind => [ [{ sqlt_datatype => 'datetime'} => 1999 ] ] })->search({}, { where => \"title LIKE ?", bind => [ 'Spoon%' ] }); is_same_sql_bind( $rs->as_query, "(SELECT me.artistid, me.name, me.rank, me.charfield FROM (SELECT a.*, cd.cdid AS cdid, cd.title AS title, cd.year AS year FROM artist a JOIN cd ON cd.artist = a.artistid WHERE cd.year = ?) me WHERE title LIKE ?)", [ [ { sqlt_datatype => 'datetime' } => '1999' ], [ {} => 'Spoon%' ] ], 'got correct SQL' ); } { # More complex cases, based primarily on the Cookbook # "Arbitrary SQL through a custom ResultSource" technique, # which seems to be the only place the bind attribute is # documented. Breaking this technique probably breaks existing # application code. $rs = $schema->resultset('CustomSql')->search({}, { bind => [ 1999 ] }); is ( $rs->count, 1, 'cookbook arbitrary sql example (in separate file)' ); $rs = $schema->resultset('CustomSql')->search({ 'artistid' => 1 }, { bind => [ 1999 ] }); is ( $rs->count, 1, '...cookbook (in separate file) + search condition' ); $rs = $schema->resultset('CustomSql')->search({}, { bind => [ 1999 ] }) ->search({ 'artistid' => 1 }); is ( $rs->count, 1, '...cookbook (bind first, in separate file) + chained search' ); $rs = $schema->resultset('CustomSql')->search({}, { bind => [ 1999 ] })->search({}, { where => \"title LIKE ?", bind => [ 'Spoon%' ] }); is_same_sql_bind( $rs->as_query, "(SELECT me.artistid, me.name, me.rank, me.charfield FROM (SELECT a.*, cd.cdid AS cdid, cd.title AS title, cd.year AS year FROM artist a JOIN cd ON cd.artist = a.artistid WHERE cd.year = ?) me WHERE title LIKE ?)", [ [ {} => '1999' ], [ {} => 'Spoon%' ] ], 'got correct SQL (cookbook arbitrary SQL, in separate file)' ); } done_testing; �������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/resultset/update_delete.t�����������������������������������������������������0000644�0001750�0001750�00000045752�14240132261�020401� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use lib qw(t/lib); use Test::More; use Test::Exception; # MASSIVE FIXME - there is a hole in ::RSC / as_subselect_rs # losing the order. Needs a rework/extract of the realiaser, # and that's a whole another bag of dicks BEGIN { $ENV{DBIC_SHUFFLE_UNORDERED_RESULTSETS} = 0 } use DBICTest::Schema::CD; BEGIN { # the default scalarref table name will not work well for this test DBICTest::Schema::CD->table('cd'); } use DBIx::Class::_Util 'scope_guard'; use DBICTest; my $schema = DBICTest->init_schema; my $tkfks = $schema->resultset('FourKeys_to_TwoKeys'); my ($fa, $fb, $fc) = $tkfks->related_resultset ('fourkeys')->populate ([ [qw/foo bar hello goodbye sensors read_count/], [qw/1 1 1 1 a 10 /], [qw/2 2 2 2 b 20 /], [qw/1 1 1 2 c 30 /], ]); # This is already provided by DBICTest #my ($ta, $tb) = $tkfk->related_resultset ('twokeys')->populate ([ # [qw/artist cd /], # [qw/1 1 /], # [qw/2 2 /], #]); my ($ta, $tb) = $schema->resultset ('TwoKeys') ->search ( [ { artist => 1, cd => 1 }, { artist => 2, cd => 2 } ], { order_by => 'artist' }) ->all; my $tkfk_cnt = $tkfks->count; my $non_void_ctx = $tkfks->populate ([ { autopilot => 'a', fourkeys => $fa, twokeys => $ta, pilot_sequence => 10 }, { autopilot => 'b', fourkeys => $fb, twokeys => $tb, pilot_sequence => 20 }, { autopilot => 'x', fourkeys => $fa, twokeys => $tb, pilot_sequence => 30 }, { autopilot => 'y', fourkeys => $fb, twokeys => $ta, pilot_sequence => 40 }, ]); is ($tkfks->count, $tkfk_cnt += 4, 'FourKeys_to_TwoKeys populated succesfully'); # # Make sure the forced group by works (i.e. the joining does not cause double-updates) # # create a resultset matching $fa and $fb only my $fks = $schema->resultset ('FourKeys')->search ( { sensors => { '!=', 'c' }, ( map { $_ => [1, 2] } qw/foo bar hello goodbye/ ), }, { join => { fourkeys_to_twokeys => 'twokeys' }} ); my $read_count_inc = 0; is ($fks->count, 4, 'Joined FourKey count correct (2x2)'); $schema->is_executed_sql_bind( sub { $fks->update ({ read_count => \ 'read_count + 1' }); $read_count_inc++; }, [[ 'UPDATE fourkeys SET read_count = read_count + 1 WHERE ( ( ( bar = ? OR bar = ? ) AND ( foo = ? OR foo = ? ) AND ( goodbye = ? OR goodbye = ? ) AND ( hello = ? OR hello = ? ) AND sensors != ? ) ) ', (1, 2) x 4, 'c', ]], 'Correct update-SQL with multijoin with pruning' ); is ($fa->discard_changes->read_count, 10 + $read_count_inc, 'Update ran only once on discard-join resultset'); is ($fb->discard_changes->read_count, 20 + $read_count_inc, 'Update ran only once on discard-join resultset'); is ($fc->discard_changes->read_count, 30, 'Update did not touch outlier'); # make the multi-join stick my $fks_multi = $fks->search( { 'fourkeys_to_twokeys.pilot_sequence' => { '!=' => 666 } }, { order_by => [ $fks->result_source->primary_columns ] }, ); # Versions of libsqlite before 3.14 do not support multicolumn-in # namely WHERE ( foo, bar ) IN ( SELECT foo, bar FROM ... ) # # Run both variants to ensure the SQL is correct, and also observe whether # the autodetection worked correctly for the current SQLite version { my $detected_can_mci = $schema->storage->_use_multicolumn_in ? 1 : 0; for my $force_use_mci (0, 1) { my $orig_use_mci = $schema->storage->_use_multicolumn_in; my $sg = scope_guard { $schema->storage->_use_multicolumn_in($orig_use_mci); }; $schema->storage->_use_multicolumn_in( $force_use_mci); $schema->is_executed_sql_bind( sub { my $executed = 0; eval { $fks_multi->update ({ read_count => \ 'read_count + 1' }); $executed = 1; $read_count_inc++; }; is( $executed, ( ( ! $detected_can_mci and $force_use_mci) ? 0 : 1 ), "Executed status as expected with multicolumn-in capability ($detected_can_mci) combined with forced-mci-use ($force_use_mci)" ); }, [ $force_use_mci ?( [ 'UPDATE fourkeys SET read_count = read_count + 1 WHERE (foo, bar, hello, goodbye) IN ( SELECT me.foo, me.bar, me.hello, me.goodbye FROM fourkeys me LEFT JOIN fourkeys_to_twokeys fourkeys_to_twokeys ON fourkeys_to_twokeys.f_bar = me.bar AND fourkeys_to_twokeys.f_foo = me.foo AND fourkeys_to_twokeys.f_goodbye = me.goodbye AND fourkeys_to_twokeys.f_hello = me.hello WHERE ( bar = ? OR bar = ? ) AND ( foo = ? OR foo = ? ) AND fourkeys_to_twokeys.pilot_sequence != ? AND ( goodbye = ? OR goodbye = ? ) AND ( hello = ? OR hello = ? ) AND sensors != ? ORDER BY foo, bar, hello, goodbye ) ', ( 1, 2) x 2, 666, ( 1, 2) x 2, 'c', ] ) :( [ 'BEGIN' ], [ 'SELECT me.foo, me.bar, me.hello, me.goodbye FROM fourkeys me LEFT JOIN fourkeys_to_twokeys fourkeys_to_twokeys ON fourkeys_to_twokeys.f_bar = me.bar AND fourkeys_to_twokeys.f_foo = me.foo AND fourkeys_to_twokeys.f_goodbye = me.goodbye AND fourkeys_to_twokeys.f_hello = me.hello WHERE ( bar = ? OR bar = ? ) AND ( foo = ? OR foo = ? ) AND fourkeys_to_twokeys.pilot_sequence != ? AND ( goodbye = ? OR goodbye = ? ) AND ( hello = ? OR hello = ? ) AND sensors != ? GROUP BY me.foo, me.bar, me.hello, me.goodbye ORDER BY foo, bar, hello, goodbye ', (1, 2) x 2, 666, (1, 2) x 2, 'c', ], [ 'UPDATE fourkeys SET read_count = read_count + 1 WHERE ( bar = ? AND foo = ? AND goodbye = ? AND hello = ? ) OR ( bar = ? AND foo = ? AND goodbye = ? AND hello = ? ) ', ( (1) x 4, (2) x 4 ), ], [ 'COMMIT' ], ) ], "Correct update-SQL with multijoin without pruning ( use_multicolumn_in forced to: $force_use_mci )" ); is ($fa->discard_changes->read_count, 10 + $read_count_inc, 'Update ran expected amount of times on joined resultset'); is ($fb->discard_changes->read_count, 20 + $read_count_inc, 'Update ran expected amount of times on joined resultset'); is ($fc->discard_changes->read_count, 30, 'Update did not touch outlier'); $schema->is_executed_sql_bind( sub { my $executed = 0; eval { my $res = $fks_multi->search (\' "blah" = "bleh" ')->delete; $executed = 1; ok ($res, 'operation is true'); cmp_ok ($res, '==', 0, 'zero rows affected'); }; is( $executed, ( ( ! $detected_can_mci and $force_use_mci) ? 0 : 1 ), "Executed status as expected with multicolumn-in capability ($detected_can_mci) combined with forced-mci-use ($force_use_mci)" ); }, [ $force_use_mci ? ( [ 'DELETE FROM fourkeys WHERE ( foo, bar, hello, goodbye ) IN ( SELECT me.foo, me.bar, me.hello, me.goodbye FROM fourkeys me LEFT JOIN fourkeys_to_twokeys fourkeys_to_twokeys ON fourkeys_to_twokeys.f_bar = me.bar AND fourkeys_to_twokeys.f_foo = me.foo AND fourkeys_to_twokeys.f_goodbye = me.goodbye AND fourkeys_to_twokeys.f_hello = me.hello WHERE "blah" = "bleh" AND ( bar = ? OR bar = ? ) AND ( foo = ? OR foo = ? ) AND fourkeys_to_twokeys.pilot_sequence != ? AND ( goodbye = ? OR goodbye = ? ) AND ( hello = ? OR hello = ? ) AND sensors != ? ORDER BY foo, bar, hello, goodbye )', (1, 2) x 2, 666, (1, 2) x 2, 'c', ] ) : ( [ 'BEGIN' ], [ 'SELECT me.foo, me.bar, me.hello, me.goodbye FROM fourkeys me LEFT JOIN fourkeys_to_twokeys fourkeys_to_twokeys ON fourkeys_to_twokeys.f_bar = me.bar AND fourkeys_to_twokeys.f_foo = me.foo AND fourkeys_to_twokeys.f_goodbye = me.goodbye AND fourkeys_to_twokeys.f_hello = me.hello WHERE "blah" = "bleh" AND ( bar = ? OR bar = ? ) AND ( foo = ? OR foo = ? ) AND fourkeys_to_twokeys.pilot_sequence != ? AND ( goodbye = ? OR goodbye = ? ) AND ( hello = ? OR hello = ? ) AND sensors != ? GROUP BY me.foo, me.bar, me.hello, me.goodbye ORDER BY foo, bar, hello, goodbye ', (1, 2) x 2, 666, (1, 2) x 2, 'c', ], [ 'COMMIT' ], ) ], 'Correct null-delete-SQL with multijoin without pruning' ); is ($fa->discard_changes->read_count, 10 + $read_count_inc, 'Noop update did not touch anything'); is ($fb->discard_changes->read_count, 20 + $read_count_inc, 'Noop update did not touch anything'); is ($fc->discard_changes->read_count, 30, 'Update did not touch outlier'); $schema->is_executed_sql_bind( sub { my $executed = 0; eval { $fks->search({ 'twokeys.artist' => { '!=' => 666 } })->update({ read_count => \ 'read_count + 1' }); $executed = 1; $read_count_inc++; }; is( $executed, ( ( ! $detected_can_mci and $force_use_mci) ? 0 : 1 ), "Executed status as expected with multicolumn-in capability ($detected_can_mci) combined with forced-mci-use ($force_use_mci)" ); }, [ $force_use_mci ? ( [ 'UPDATE fourkeys SET read_count = read_count + 1 WHERE ( foo, bar, hello, goodbye ) IN ( SELECT me.foo, me.bar, me.hello, me.goodbye FROM fourkeys me LEFT JOIN fourkeys_to_twokeys fourkeys_to_twokeys ON fourkeys_to_twokeys.f_bar = me.bar AND fourkeys_to_twokeys.f_foo = me.foo AND fourkeys_to_twokeys.f_goodbye = me.goodbye AND fourkeys_to_twokeys.f_hello = me.hello LEFT JOIN twokeys twokeys ON twokeys.artist = fourkeys_to_twokeys.t_artist AND twokeys.cd = fourkeys_to_twokeys.t_cd WHERE ( bar = ? OR bar = ? ) AND ( foo = ? OR foo = ? ) AND ( goodbye = ? OR goodbye = ? ) AND ( hello = ? OR hello = ? ) AND sensors != ? AND twokeys.artist != ? )', (1, 2) x 4, 'c', 666, ] ) : ( [ 'BEGIN' ], [ 'SELECT me.foo, me.bar, me.hello, me.goodbye FROM fourkeys me LEFT JOIN fourkeys_to_twokeys fourkeys_to_twokeys ON fourkeys_to_twokeys.f_bar = me.bar AND fourkeys_to_twokeys.f_foo = me.foo AND fourkeys_to_twokeys.f_goodbye = me.goodbye AND fourkeys_to_twokeys.f_hello = me.hello LEFT JOIN twokeys twokeys ON twokeys.artist = fourkeys_to_twokeys.t_artist AND twokeys.cd = fourkeys_to_twokeys.t_cd WHERE ( bar = ? OR bar = ? ) AND ( foo = ? OR foo = ? ) AND ( goodbye = ? OR goodbye = ? ) AND ( hello = ? OR hello = ? ) AND sensors != ? AND twokeys.artist != ? GROUP BY me.foo, me.bar, me.hello, me.goodbye ', (1, 2) x 4, 'c', 666, ], [ 'UPDATE fourkeys SET read_count = read_count + 1 WHERE ( bar = ? AND foo = ? AND goodbye = ? AND hello = ? ) OR ( bar = ? AND foo = ? AND goodbye = ? AND hello = ? ) ', ( (1) x 4, (2) x 4 ), ], [ 'COMMIT' ], ) ], 'Correct update-SQL with premultiplied restricting join without pruning' ); is ($fa->discard_changes->read_count, 10 + $read_count_inc, 'Update ran expected amount of times on joined resultset'); is ($fb->discard_changes->read_count, 20 + $read_count_inc, 'Update ran expected amount of times on joined resultset'); is ($fc->discard_changes->read_count, 30, 'Update did not touch outlier'); } } # # Make sure multicolumn in or the equivalent functions correctly # my $sub_rs = $tkfks->search ( [ { map { $_ => 1 } qw/artist.artistid cd.cdid fourkeys.foo fourkeys.bar fourkeys.hello fourkeys.goodbye/ }, { map { $_ => 2 } qw/artist.artistid cd.cdid fourkeys.foo fourkeys.bar fourkeys.hello fourkeys.goodbye/ }, ], { join => [ 'fourkeys', { twokeys => [qw/artist cd/] } ], }, ); is ($sub_rs->count, 2, 'Only two rows from fourkeys match'); # ensure we do not do something dumb on MCI-not-supporting engines { my $orig_use_mci = $schema->storage->_use_multicolumn_in; my $sg = scope_guard { $schema->storage->_use_multicolumn_in($orig_use_mci); }; $schema->storage->_use_multicolumn_in(0); # attempts to delete a global-grouped rs should fail miserably throws_ok ( sub { $sub_rs->search ({}, { distinct => 1 })->delete }, qr/attempted a delete operation on a resultset which does group_by on columns other than the primary keys/, 'Grouped rs update/delete not allowed', ); } # grouping on PKs only should pass $sub_rs->search ( {}, { group_by => [ reverse $sub_rs->result_source->primary_columns ], # reverse to make sure the PK-list comparison works }, )->update ({ pilot_sequence => \ 'pilot_sequence + 1' }); is_deeply ( [ $tkfks->search ({ autopilot => [qw/a b x y/]}, { order_by => 'autopilot' }) ->get_column ('pilot_sequence')->all ], [qw/11 21 30 40/], 'Only two rows incremented', ); # also make sure weird scalarref usage works (RT#51409) $tkfks->search ( \ 'pilot_sequence BETWEEN 11 AND 21', )->update ({ pilot_sequence => \ 'pilot_sequence + 1' }); is_deeply ( [ $tkfks->search ({ autopilot => [qw/a b x y/]}, { order_by => 'autopilot' }) ->get_column ('pilot_sequence')->all ], [qw/12 22 30 40/], 'Only two rows incremented (where => scalarref works)', ); { my $rs = $schema->resultset('FourKeys_to_TwoKeys')->search ( { -or => [ { 'me.pilot_sequence' => 12 }, { 'me.autopilot' => 'b' }, ], } ); lives_ok { $rs->update({ autopilot => 'z' }) } 'Update with table name qualifier in -or conditions lives'; is_deeply ( [ $tkfks->search ({ pilot_sequence => [12, 22]}) ->get_column ('autopilot')->all ], [qw/z z/], '... and yields the right data', ); } $sub_rs->delete; is ($tkfks->count, $tkfk_cnt -= 2, 'Only two rows deleted'); # make sure limit-only deletion works cmp_ok ($tkfk_cnt, '>', 1, 'More than 1 row left'); $tkfks->search ({}, { rows => 1 })->delete; is ($tkfks->count, $tkfk_cnt -= 1, 'Only one row deleted'); # check with sql-equality, as sqlite will accept most bad sql just fine { my $rs = $schema->resultset('CD')->search( { 'me.year' => { '!=' => 2010 } }, ); $schema->is_executed_sql_bind( sub { $rs->search({}, { join => 'liner_notes' })->delete; }, [[ 'DELETE FROM cd WHERE ( year != ? )', 2010, ]], 'Non-restricting multijoins properly thrown out' ); $schema->is_executed_sql_bind( sub { $rs->search({}, { prefetch => 'liner_notes' })->delete; }, [[ 'DELETE FROM cd WHERE ( year != ? )', 2010, ]], 'Non-restricting multiprefetch thrown out' ); $schema->is_executed_sql_bind( sub { $rs->search({}, { prefetch => 'artist' })->delete; }, [[ 'DELETE FROM cd WHERE ( cdid IN ( SELECT me.cdid FROM cd me JOIN artist artist ON artist.artistid = me.artist WHERE ( me.year != ? ) ) )', 2010, ]], 'Restricting prefetch left in, selector thrown out'); ### switch artist and cd to fully qualified table names ### make sure nothing is stripped out my $cd_rsrc = $schema->source('CD'); $cd_rsrc->name('main.cd'); $cd_rsrc->relationship_info($_)->{attrs}{cascade_delete} = 0 for $cd_rsrc->relationships; my $art_rsrc = $schema->source('Artist'); $art_rsrc->name(\'main.artist'); $art_rsrc->relationship_info($_)->{attrs}{cascade_delete} = 0 for $art_rsrc->relationships; $schema->is_executed_sql_bind( sub { $rs->delete }, [[ 'DELETE FROM main.cd WHERE year != ?', 2010, ]], 'delete with fully qualified table name' ); $rs->create({ title => 'foo', artist => 1, year => 2000 }); $schema->is_executed_sql_bind( sub { $rs->delete_all }, [ [ 'BEGIN' ], [ 'SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM main.cd me WHERE me.year != ?', 2010, ], [ 'DELETE FROM main.cd WHERE ( cdid = ? )', 1, ], [ 'COMMIT' ], ], 'delete_all with fully qualified table name' ); $rs->create({ cdid => 42, title => 'foo', artist => 2, year => 2000 }); my $cd42 = $rs->find(42); $schema->is_executed_sql_bind( sub { $cd42->delete }, [[ 'DELETE FROM main.cd WHERE cdid = ?', 42, ]], 'delete of object from table with fully qualified name' ); $schema->is_executed_sql_bind( sub { $cd42->related_resultset('artist')->delete }, [[ 'DELETE FROM main.artist WHERE ( artistid IN ( SELECT me.artistid FROM main.artist me WHERE ( me.artistid = ? ) ) )', 2, ]], 'delete of related object from scalarref fully qualified named table' ); my $art3 = $schema->resultset('Artist')->find(3); $schema->is_executed_sql_bind( sub { $art3->related_resultset('cds')->delete; }, [[ 'DELETE FROM main.cd WHERE ( artist = ? )', 3, ]], 'delete of related object from fully qualified named table' ); $schema->is_executed_sql_bind( sub { $art3->cds_unordered->delete; }, [[ 'DELETE FROM main.cd WHERE ( artist = ? )', 3, ]], 'delete of related object from fully qualified named table via relaccessor' ); $schema->is_executed_sql_bind( sub { $rs->search({}, { prefetch => 'artist' })->delete; }, [[ 'DELETE FROM main.cd WHERE ( cdid IN ( SELECT me.cdid FROM main.cd me JOIN main.artist artist ON artist.artistid = me.artist WHERE ( me.year != ? ) ) )', 2010, ]], 'delete with fully qualified table name and subquery correct' ); # check that as_subselect_rs works ok # inner query is untouched, then a selector # and an IN condition $schema->is_executed_sql_bind( sub { $schema->resultset('CD')->search({ 'me.cdid' => 1, 'artist.name' => 'partytimecity', }, { join => 'artist', })->as_subselect_rs->delete; }, [[ ' DELETE FROM main.cd WHERE ( cdid IN ( SELECT me.cdid FROM ( SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM main.cd me JOIN main.artist artist ON artist.artistid = me.artist WHERE artist.name = ? AND me.cdid = ? ) me ) ) ', 'partytimecity', 1, ]], 'Delete from as_subselect_rs works correctly' ); } done_testing; ����������������������DBIx-Class-0.082843/t/resultset/rowparser_internals.t�����������������������������������������������0000644�0001750�0001750�00000073622�14240132261�021675� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; use B::Deparse; use DBIx::Class::_Util 'perlstring'; # globally set for the rest of test # the rowparser maker does not order its hashes by default for the miniscule # speed gain. But it does not disable sorting either - for this test # everything will be ordered nicely, and the hash randomization of 5.18 # will not trip up anything use Data::Dumper; $Data::Dumper::Sortkeys = 1; my $schema = DBICTest->init_schema(no_deploy => 1); my $infmap = [qw/ single_track.cd.artist.name year /]; is_same_src ( ($schema->source ('CD')->_mk_row_parser({ inflate_map => $infmap, }))[0], '$_ = [ { year => $_->[1] }, { single_track => ( ! defined( $_->[0]) ) ? bless( [ undef, { cd => [ undef, { artist => [ { name => $_->[0] }, ] }, ] }, ], __NBC__ ) : [ undef, { cd => [ undef, { artist => [ { name => $_->[0] }, ] }, ] }, ] }, ] for @{$_[0]}', 'Simple 1:1 descending non-collapsing parser', ); $infmap = [qw/ single_track.cd.artist.cds.tracks.title single_track.cd.artist.artistid year single_track.cd.artist.cds.cdid title artist /]; is_same_src ( ($schema->source ('CD')->_mk_row_parser({ inflate_map => $infmap, }))[0], '$_ = [ { artist => $_->[5], title => $_->[4], year => $_->[2] }, { single_track => ( (! defined $_->[0] ) && (! defined $_->[1]) && (! defined $_->[3] ) ) ? bless( [ undef, { cd => [ undef, { artist => [ { artistid => $_->[1] }, { cds => ( (! defined $_->[0] ) && ( ! defined $_->[3] ) ) ? bless ([ { cdid => $_->[3] }, { tracks => ( ! defined $_->[0] ) ? bless ( [{ title => $_->[0] }], __NBC__ ) : [{ title => $_->[0] }] } ], __NBC__) : [ { cdid => $_->[3] }, { tracks => ( ! defined $_->[0] ) ? bless ( [{ title => $_->[0] }], __NBC__ ) : [{ title => $_->[0] }] } ] } ] } ] } ], __NBC__) : [ undef, { cd => [ undef, { artist => [ { artistid => $_->[1] }, { cds => ( (! defined $_->[0] ) && ( ! defined $_->[3] ) ) ? bless ([ { cdid => $_->[3] }, { tracks => ( ! defined $_->[0] ) ? bless ( [{ title => $_->[0] }], __NBC__ ) : [{ title => $_->[0] }] } ], __NBC__) : [ { cdid => $_->[3] }, { tracks => ( ! defined $_->[0] ) ? bless ( [{ title => $_->[0] }], __NBC__ ) : [{ title => $_->[0] }] } ] } ] } ] } ] } ] for @{$_[0]}', '1:1 descending non-collapsing parser terminating with chained 1:M:M', ); is_same_src ( ($schema->source ('CD')->_mk_row_parser({ prune_null_branches => 1, inflate_map => $infmap, }))[0], '$_ = [ { artist => $_->[5], title => $_->[4], year => $_->[2] }, { single_track => ( (! defined $_->[0] ) && (! defined $_->[1]) && (! defined $_->[3] ) ) ? undef : [ undef, { cd => [ undef, { artist => [ { artistid => $_->[1] }, { cds => ( (! defined $_->[0] ) && ( ! defined $_->[3] ) ) ? undef : [ { cdid => $_->[3] }, { tracks => ( ! defined $_->[0] ) ? undef : [ { title => $_->[0] }, ] } ] } ] } ] } ] } ] for @{$_[0]}', '1:1 descending non-collapsing pruning parser terminating with chained 1:M:M', ); is_same_src ( ($schema->source ('CD')->_mk_row_parser({ hri_style => 1, prune_null_branches => 1, inflate_map => $infmap, }))[0], '$_ = { artist => $_->[5], title => $_->[4], year => $_->[2], ( single_track => ( (! defined $_->[0] ) && (! defined $_->[1]) && (! defined $_->[3] ) ) ? undef : { cd => { artist => { artistid => $_->[1], ( cds => ( (! defined $_->[0] ) && ( ! defined $_->[3] ) ) ? undef : { cdid => $_->[3], ( tracks => ( ! defined $_->[0] ) ? undef : { title => $_->[0] } ) } ) } } } ) } for @{$_[0]}', '1:1 descending non-collapsing HRI-direct parser terminating with chained 1:M:M', ); is_deeply ( ($schema->source('CD')->_resolve_collapse({ as => {map { $infmap->[$_] => $_ } 0 .. $#$infmap} })), { -identifying_columns => [ 4, 5 ], single_track => { -identifying_columns => [ 1, 4, 5 ], -is_optional => 1, -is_single => 1, cd => { -identifying_columns => [ 1, 4, 5 ], -is_single => 1, artist => { -identifying_columns => [ 1, 4, 5 ], -is_single => 1, cds => { -identifying_columns => [ 1, 3, 4, 5 ], -is_optional => 1, tracks => { -identifying_columns => [ 0, 1, 3, 4, 5 ], -is_optional => 1, }, }, }, }, }, }, 'Correct collapse map for 1:1 descending chain terminating with chained 1:M:M' ); is_same_src ( ($schema->source ('CD')->_mk_row_parser({ inflate_map => $infmap, collapse => 1, }))[0], ' my $rows_pos = 0; my ($result_pos, @collapse_idx, $cur_row_data, %cur_row_ids); while ($cur_row_data = ( ( $rows_pos >= 0 and $_[0][$rows_pos++] ) || ( $_[1] and $rows_pos = -1 and $_[1]->() ) ) ) { $cur_row_ids{0} = $cur_row_data->[0] // "\0NULL\xFF$rows_pos\xFF0\0"; $cur_row_ids{1} = $cur_row_data->[1] // "\0NULL\xFF$rows_pos\xFF1\0"; $cur_row_ids{3} = $cur_row_data->[3] // "\0NULL\xFF$rows_pos\xFF3\0"; $cur_row_ids{4} = $cur_row_data->[4] // "\0NULL\xFF$rows_pos\xFF4\0"; $cur_row_ids{5} = $cur_row_data->[5] // "\0NULL\xFF$rows_pos\xFF5\0"; # a present cref in $_[1] implies lazy prefetch, implies a supplied stash in $_[2] $_[1] and $result_pos and ! $collapse_idx[0]{$cur_row_ids{4}}{$cur_row_ids{5}} and (unshift @{$_[2]}, $cur_row_data) and last; # the rowdata itself for root node $collapse_idx[0]{$cur_row_ids{4}}{$cur_row_ids{5}} //= $_[0][$result_pos++] = [{ artist => $cur_row_data->[5], title => $cur_row_data->[4], year => $cur_row_data->[2] }]; # prefetch data of single_track (placed in root) $collapse_idx[0]{$cur_row_ids{4}}{$cur_row_ids{5}}[1]{single_track} //= $collapse_idx[1]{$cur_row_ids{1}}{$cur_row_ids{4}}{$cur_row_ids{5}} = []; defined($cur_row_data->[1]) or bless( $collapse_idx[0]{$cur_row_ids{4}}{$cur_row_ids{5}}[1]{single_track}, __NBC__ ); # prefetch data of cd (placed in single_track) $collapse_idx[1]{$cur_row_ids{1}}{$cur_row_ids{4}}{$cur_row_ids{5}}[1]{cd} //= $collapse_idx[2]{$cur_row_ids{1}}{$cur_row_ids{4}}{$cur_row_ids{5}} = []; # prefetch data of artist ( placed in single_track->cd) $collapse_idx[2]{$cur_row_ids{1}}{$cur_row_ids{4}}{$cur_row_ids{5}}[1]{artist} //= $collapse_idx[3]{$cur_row_ids{1}}{$cur_row_ids{4}}{$cur_row_ids{5}} = [{ artistid => $cur_row_data->[1] }]; # prefetch data of cds (if available) (! $collapse_idx[4]{$cur_row_ids{1}}{$cur_row_ids{3}}{$cur_row_ids{4}}{$cur_row_ids{5}} ) and push @{$collapse_idx[3]{$cur_row_ids{1}}{$cur_row_ids{4}}{$cur_row_ids{5}}[1]{cds}}, ( $collapse_idx[4]{$cur_row_ids{1}}{$cur_row_ids{3}}{$cur_row_ids{4}}{$cur_row_ids{5}} = [{ cdid => $cur_row_data->[3] }] ); defined($cur_row_data->[3]) or bless( $collapse_idx[3]{$cur_row_ids{1}}{$cur_row_ids{4}}{$cur_row_ids{5}}[1]{cds}, __NBC__ ); # prefetch data of tracks (if available) (! $collapse_idx[5]{$cur_row_ids{0}}{$cur_row_ids{1}}{$cur_row_ids{3}}{$cur_row_ids{4}}{$cur_row_ids{5}} ) and push @{$collapse_idx[4]{$cur_row_ids{1}}{$cur_row_ids{3}}{$cur_row_ids{4}}{$cur_row_ids{5}}[1]{tracks}}, ( $collapse_idx[5]{$cur_row_ids{0}}{$cur_row_ids{1}}{$cur_row_ids{3}}{$cur_row_ids{4}}{$cur_row_ids{5}} = [{ title => $cur_row_data->[0] }] ); defined($cur_row_data->[0]) or bless( $collapse_idx[4]{$cur_row_ids{1}}{$cur_row_ids{3}}{$cur_row_ids{4}}{$cur_row_ids{5}}[1]{tracks}, __NBC__ ); } $#{$_[0]} = $result_pos - 1; ', 'Same 1:1 descending terminating with chained 1:M:M but with collapse', ); is_same_src ( ($schema->source ('CD')->_mk_row_parser({ inflate_map => $infmap, collapse => 1, hri_style => 1, prune_null_branches => 1, }))[0], ' my $rows_pos = 0; my ($result_pos, @collapse_idx, $cur_row_data); while ($cur_row_data = ( ( $rows_pos >= 0 and $_[0][$rows_pos++] ) || ( $_[1] and $rows_pos = -1 and $_[1]->() ) ) ) { # a present cref in $_[1] implies lazy prefetch, implies a supplied stash in $_[2] $_[1] and $result_pos and ! $collapse_idx[0]{$cur_row_data->[4]}{$cur_row_data->[5]} and (unshift @{$_[2]}, $cur_row_data) and last; # the rowdata itself for root node $collapse_idx[0]{$cur_row_data->[4]}{$cur_row_data->[5]} //= $_[0][$result_pos++] = { artist => $cur_row_data->[5], title => $cur_row_data->[4], year => $cur_row_data->[2] }; # prefetch data of single_track (placed in root) (! defined($cur_row_data->[1]) ) ? $collapse_idx[0]{$cur_row_data->[4]}{$cur_row_data->[5]}{single_track} = undef : do { $collapse_idx[0]{$cur_row_data->[4]}{$cur_row_data->[5]}{single_track} //= $collapse_idx[1]{$cur_row_data->[1]}{$cur_row_data->[4]}{$cur_row_data->[5]}; # prefetch data of cd (placed in single_track) $collapse_idx[1]{$cur_row_data->[1]}{$cur_row_data->[4]}{$cur_row_data->[5]}{cd} //= $collapse_idx[2]{$cur_row_data->[1]}{$cur_row_data->[4]}{$cur_row_data->[5]}; # prefetch data of artist ( placed in single_track->cd) $collapse_idx[2]{$cur_row_data->[1]}{$cur_row_data->[4]}{$cur_row_data->[5]}{artist} //= $collapse_idx[3]{$cur_row_data->[1]}{$cur_row_data->[4]}{$cur_row_data->[5]} = { artistid => $cur_row_data->[1] }; # prefetch data of cds (if available) (! defined $cur_row_data->[3] ) ? $collapse_idx[3]{$cur_row_data->[1]}{$cur_row_data->[4]}{$cur_row_data->[5]}{cds} = [] : do { (! $collapse_idx[4]{$cur_row_data->[1]}{$cur_row_data->[3]}{$cur_row_data->[4]}{$cur_row_data->[5]} ) and push @{$collapse_idx[3]{$cur_row_data->[1]}{$cur_row_data->[4]}{$cur_row_data->[5]}{cds}}, ( $collapse_idx[4]{$cur_row_data->[1]}{$cur_row_data->[3]}{$cur_row_data->[4]}{$cur_row_data->[5]} = { cdid => $cur_row_data->[3] } ); # prefetch data of tracks (if available) ( ! defined $cur_row_data->[0] ) ? $collapse_idx[4]{$cur_row_data->[1]}{$cur_row_data->[3]}{$cur_row_data->[4]}{$cur_row_data->[5]}{tracks} = [] : do { (! $collapse_idx[5]{$cur_row_data->[0]}{$cur_row_data->[1]}{$cur_row_data->[3]}{$cur_row_data->[4]}{$cur_row_data->[5]} ) and push @{$collapse_idx[4]{$cur_row_data->[1]}{$cur_row_data->[3]}{$cur_row_data->[4]}{$cur_row_data->[5]}{tracks}}, ( $collapse_idx[5]{$cur_row_data->[0]}{$cur_row_data->[1]}{$cur_row_data->[3]}{$cur_row_data->[4]}{$cur_row_data->[5]} = { title => $cur_row_data->[0] } ); }; }; }; } $#{$_[0]} = $result_pos - 1; ', 'Same 1:1 descending terminating with chained 1:M:M but with collapse, HRI-direct', ); $infmap = [qw/ tracks.lyrics.existing_lyric_versions.text existing_single_track.cd.artist.artistid existing_single_track.cd.artist.cds.year year genreid tracks.title existing_single_track.cd.artist.cds.cdid latest_cd existing_single_track.cd.artist.cds.tracks.title existing_single_track.cd.artist.cds.genreid tracks.lyrics.existing_lyric_versions.lyric_id /]; is_deeply ( $schema->source('CD')->_resolve_collapse({ as => {map { $infmap->[$_] => $_ } 0 .. $#$infmap} }), { -identifying_columns => [ 1 ], # existing_single_track.cd.artist.artistid existing_single_track => { -identifying_columns => [ 1 ], # existing_single_track.cd.artist.artistid -is_single => 1, cd => { -identifying_columns => [ 1 ], # existing_single_track.cd.artist.artistid -is_single => 1, artist => { -identifying_columns => [ 1 ], # existing_single_track.cd.artist.artistid -is_single => 1, cds => { -identifying_columns => [ 1, 6 ], # existing_single_track.cd.artist.cds.cdid -is_optional => 1, tracks => { -identifying_columns => [ 1, 6, 8 ], # existing_single_track.cd.artist.cds.cdid, existing_single_track.cd.artist.cds.tracks.title -is_optional => 1, } } } } }, tracks => { -identifying_columns => [ 1, 5 ], # existing_single_track.cd.artist.artistid, tracks.title -is_optional => 1, lyrics => { -identifying_columns => [ 1, 5, 10 ], # existing_single_track.cd.artist.artistid, tracks.title, tracks.lyrics.existing_lyric_versions.lyric_id -is_single => 1, -is_optional => 1, existing_lyric_versions => { -identifying_columns => [ 0, 1, 5, 10 ], # tracks.lyrics.existing_lyric_versions.text, existing_single_track.cd.artist.artistid, tracks.title, tracks.lyrics.existing_lyric_versions.lyric_id }, }, } }, 'Correct collapse map constructed', ); is_same_src ( ($schema->source ('CD')->_mk_row_parser({ inflate_map => $infmap, collapse => 1, }))[0], ' my $rows_pos = 0; my ($result_pos, @collapse_idx, $cur_row_data, %cur_row_ids); while ($cur_row_data = ( ( $rows_pos >= 0 and $_[0][$rows_pos++] ) || ( $_[1] and $rows_pos = -1 and $_[1]->() ) ) ) { $cur_row_ids{0} = $cur_row_data->[0] // "\0NULL\xFF$rows_pos\xFF0\0"; $cur_row_ids{1} = $cur_row_data->[1] // "\0NULL\xFF$rows_pos\xFF1\0"; $cur_row_ids{5} = $cur_row_data->[5] // "\0NULL\xFF$rows_pos\xFF5\0"; $cur_row_ids{6} = $cur_row_data->[6] // "\0NULL\xFF$rows_pos\xFF6\0"; $cur_row_ids{8} = $cur_row_data->[8] // "\0NULL\xFF$rows_pos\xFF8\0"; $cur_row_ids{10} = $cur_row_data->[10] // "\0NULL\xFF$rows_pos\xFF10\0"; # a present cref in $_[1] implies lazy prefetch, implies a supplied stash in $_[2] $_[1] and $result_pos and ! $collapse_idx[0]{$cur_row_ids{1}} and (unshift @{$_[2]}, $cur_row_data) and last; $collapse_idx[0]{$cur_row_ids{1}} //= $_[0][$result_pos++] = [{ genreid => $cur_row_data->[4], latest_cd => $cur_row_data->[7], year => $cur_row_data->[3] }]; $collapse_idx[0]{$cur_row_ids{1}}[1]{existing_single_track} //= $collapse_idx[1]{$cur_row_ids{1}} = []; $collapse_idx[1]{$cur_row_ids{1}}[1]{cd} //= $collapse_idx[2]{$cur_row_ids{1}} = []; $collapse_idx[2]{$cur_row_ids{1}}[1]{artist} //= $collapse_idx[3]{$cur_row_ids{1}} = [{ artistid => $cur_row_data->[1] }]; (! $collapse_idx[4]{$cur_row_ids{1}}{$cur_row_ids{6}} ) and push @{ $collapse_idx[3]{$cur_row_ids{1}}[1]{cds} }, ( $collapse_idx[4]{$cur_row_ids{1}}{$cur_row_ids{6}} = [{ cdid => $cur_row_data->[6], genreid => $cur_row_data->[9], year => $cur_row_data->[2] }] ); defined($cur_row_data->[6]) or bless( $collapse_idx[3]{$cur_row_ids{1}}[1]{cds}, __NBC__ ); (! $collapse_idx[5]{$cur_row_ids{1}}{$cur_row_ids{6}}{$cur_row_ids{8}} ) and push @{ $collapse_idx[4]{$cur_row_ids{1}}{$cur_row_ids{6}}[1]{tracks} }, ( $collapse_idx[5]{$cur_row_ids{1}}{$cur_row_ids{6}}{$cur_row_ids{8}} = [{ title => $cur_row_data->[8] }] ); defined($cur_row_data->[8]) or bless( $collapse_idx[4]{$cur_row_ids{1}}{$cur_row_ids{6}}[1]{tracks}, __NBC__ ); (! $collapse_idx[6]{$cur_row_ids{1}}{$cur_row_ids{5}} ) and push @{ $collapse_idx[0]{$cur_row_ids{1}}[1]{tracks} }, ( $collapse_idx[6]{$cur_row_ids{1}}{$cur_row_ids{5}} = [{ title => $cur_row_data->[5] }] ); defined($cur_row_data->[5]) or bless( $collapse_idx[0]{$cur_row_ids{1}}[1]{tracks}, __NBC__ ); $collapse_idx[6]{$cur_row_ids{1}}{$cur_row_ids{5}}[1]{lyrics} //= $collapse_idx[7]{$cur_row_ids{1}}{$cur_row_ids{5}}{$cur_row_ids{10}} = []; defined($cur_row_data->[10]) or bless( $collapse_idx[6]{$cur_row_ids{1}}{$cur_row_ids{5}}[1]{lyrics}, __NBC__ ); (! $collapse_idx[8]{$cur_row_ids{0}}{$cur_row_ids{1}}{$cur_row_ids{5}}{$cur_row_ids{10}} ) and push @{ $collapse_idx[7]{$cur_row_ids{1}}{$cur_row_ids{5}}{$cur_row_ids{10}}[1]{existing_lyric_versions} }, ( $collapse_idx[8]{$cur_row_ids{0}}{$cur_row_ids{1}}{$cur_row_ids{5}}{$cur_row_ids{10}} = [{ lyric_id => $cur_row_data->[10], text => $cur_row_data->[0] }] ); } $#{$_[0]} = $result_pos - 1; ', 'Multiple has_many on multiple branches torture test', ); is_same_src ( ($schema->source ('CD')->_mk_row_parser({ inflate_map => $infmap, collapse => 1, prune_null_branches => 1, }))[0], ' my $rows_pos = 0; my ($result_pos, @collapse_idx, $cur_row_data); while ($cur_row_data = ( ( $rows_pos >= 0 and $_[0][$rows_pos++] ) || ( $_[1] and $rows_pos = -1 and $_[1]->() ) ) ) { # a present cref in $_[1] implies lazy prefetch, implies a supplied stash in $_[2] $_[1] and $result_pos and ! $collapse_idx[0]{$cur_row_data->[1]} and (unshift @{$_[2]}, $cur_row_data) and last; $collapse_idx[0]{$cur_row_data->[1]} //= $_[0][$result_pos++] = [{ genreid => $cur_row_data->[4], latest_cd => $cur_row_data->[7], year => $cur_row_data->[3] }]; $collapse_idx[0]{$cur_row_data->[1]}[1]{existing_single_track} //= $collapse_idx[1]{$cur_row_data->[1]} = []; $collapse_idx[1]{$cur_row_data->[1]}[1]{cd} //= $collapse_idx[2]{$cur_row_data->[1]} = []; $collapse_idx[2]{$cur_row_data->[1]}[1]{artist} //= $collapse_idx[3]{$cur_row_data->[1]} = [{ artistid => $cur_row_data->[1] }]; (! defined($cur_row_data->[6])) ? $collapse_idx[3]{$cur_row_data->[1]}[1]{cds} = [] : do { (! $collapse_idx[4]{$cur_row_data->[1]}{$cur_row_data->[6]} ) and push @{ $collapse_idx[3]{$cur_row_data->[1]}[1]{cds} }, ( $collapse_idx[4]{$cur_row_data->[1]}{$cur_row_data->[6]} = [{ cdid => $cur_row_data->[6], genreid => $cur_row_data->[9], year => $cur_row_data->[2] }] ); (! defined($cur_row_data->[8]) ) ? $collapse_idx[4]{$cur_row_data->[1]}{$cur_row_data->[6]}[1]{tracks} = [] : do { (! $collapse_idx[5]{$cur_row_data->[1]}{$cur_row_data->[6]}{$cur_row_data->[8]} ) and push @{ $collapse_idx[4]{$cur_row_data->[1]}{$cur_row_data->[6]}[1]{tracks} }, ( $collapse_idx[5]{$cur_row_data->[1]}{$cur_row_data->[6]}{$cur_row_data->[8]} = [{ title => $cur_row_data->[8] }] ); }; }; (! defined($cur_row_data->[5]) ) ? $collapse_idx[0]{$cur_row_data->[1]}[1]{tracks} = [] : do { (! $collapse_idx[6]{$cur_row_data->[1]}{$cur_row_data->[5]} ) and push @{ $collapse_idx[0]{$cur_row_data->[1]}[1]{tracks} }, ( $collapse_idx[6]{$cur_row_data->[1]}{$cur_row_data->[5]} = [{ title => $cur_row_data->[5] }] ); (! defined($cur_row_data->[10]) ) ? $collapse_idx[6]{$cur_row_data->[1]}{$cur_row_data->[5]}[1]{lyrics} = [] : do { $collapse_idx[6]{$cur_row_data->[1]}{$cur_row_data->[5]}[1]{lyrics} //= $collapse_idx[7]{$cur_row_data->[1]}{$cur_row_data->[5]}{$cur_row_data->[10]} = []; (! $collapse_idx[8]{$cur_row_data->[0]}{$cur_row_data->[1]}{$cur_row_data->[5]}{$cur_row_data->[10]} ) and push @{ $collapse_idx[7]{$cur_row_data->[1]}{$cur_row_data->[5]}{$cur_row_data->[10]}[1]{existing_lyric_versions} }, ( $collapse_idx[8]{$cur_row_data->[0]}{$cur_row_data->[1]}{$cur_row_data->[5]}{$cur_row_data->[10]} = [{ lyric_id => $cur_row_data->[10], text => $cur_row_data->[0] }] ); }; }; } $#{$_[0]} = $result_pos - 1; ', 'Multiple has_many on multiple branches with branch pruning torture test', ); $infmap = [ 'single_track.trackid', # (0) definitive link to root from 1:1:1:1:M:M chain 'year', # (1) non-unique 'tracks.cd', # (2) \ together both uniqueness for second multirel 'tracks.title', # (3) / and definitive link back to root 'single_track.cd.artist.cds.cdid', # (4) to give uniquiness to ...tracks.title below 'single_track.cd.artist.cds.year', # (5) non-unique 'single_track.cd.artist.artistid', # (6) uniqufies entire parental chain 'single_track.cd.artist.cds.genreid', # (7) nullable 'single_track.cd.artist.cds.tracks.title',# (8) unique when combined with ...cds.cdid above ]; is_deeply ( $schema->source('CD')->_resolve_collapse({ as => {map { $infmap->[$_] => $_ } 0 .. $#$infmap} }), { -identifying_columns => [], -identifying_columns_variants => [ [ 0 ], [ 2 ], ], single_track => { -identifying_columns => [ 0 ], -is_optional => 1, -is_single => 1, cd => { -identifying_columns => [ 0 ], -is_single => 1, artist => { -identifying_columns => [ 0 ], -is_single => 1, cds => { -identifying_columns => [ 0, 4 ], -is_optional => 1, tracks => { -identifying_columns => [ 0, 4, 8 ], -is_optional => 1, } } } } }, tracks => { -identifying_columns => [ 2, 3 ], -is_optional => 1, } }, 'Correct underdefined root collapse map constructed' ); is_same_src ( ($schema->source ('CD')->_mk_row_parser({ inflate_map => $infmap, collapse => 1, }))[0], ' my $rows_pos = 0; my ($result_pos, @collapse_idx, $cur_row_data, %cur_row_ids); while ($cur_row_data = ( ( $rows_pos >= 0 and $_[0][$rows_pos++] ) || ( $_[1] and $rows_pos = -1 and $_[1]->() ) ) ) { $cur_row_ids{0} = $cur_row_data->[0] // "\0NULL\xFF$rows_pos\xFF0\0"; $cur_row_ids{2} = $cur_row_data->[2] // "\0NULL\xFF$rows_pos\xFF2\0"; $cur_row_ids{3} = $cur_row_data->[3] // "\0NULL\xFF$rows_pos\xFF3\0"; $cur_row_ids{4} = $cur_row_data->[4] // "\0NULL\xFF$rows_pos\xFF4\0"; $cur_row_ids{8} = $cur_row_data->[8] // "\0NULL\xFF$rows_pos\xFF8\0"; # cache expensive set of ops in a non-existent rowid slot $cur_row_ids{10} = ( ( ( defined $cur_row_data->[0] ) && (join "\xFF", q{}, $cur_row_data->[0], q{} )) or ( ( defined $cur_row_data->[2] ) && (join "\xFF", q{}, $cur_row_data->[2], q{} )) or "\0$rows_pos\0" ); # a present cref in $_[1] implies lazy prefetch, implies a supplied stash in $_[2] $_[1] and $result_pos and ! $collapse_idx[0]{$cur_row_ids{10}} and (unshift @{$_[2]}, $cur_row_data) and last; $collapse_idx[0]{$cur_row_ids{10}} //= $_[0][$result_pos++] = [{ year => $$cur_row_data[1] }]; $collapse_idx[0]{$cur_row_ids{10}}[1]{single_track} //= ($collapse_idx[1]{$cur_row_ids{0}} = [{ trackid => $cur_row_data->[0] }]); defined($cur_row_data->[0]) or bless ( $collapse_idx[0]{$cur_row_ids{10}}[1]{single_track}, __NBC__ ); $collapse_idx[1]{$cur_row_ids{0}}[1]{cd} //= $collapse_idx[2]{$cur_row_ids{0}} = []; $collapse_idx[2]{$cur_row_ids{0}}[1]{artist} //= ($collapse_idx[3]{$cur_row_ids{0}} = [{ artistid => $cur_row_data->[6] }]); (! $collapse_idx[4]{$cur_row_ids{0}}{$cur_row_ids{4}} ) and push @{$collapse_idx[3]{$cur_row_ids{0}}[1]{cds}}, ( $collapse_idx[4]{$cur_row_ids{0}}{$cur_row_ids{4}} = [{ cdid => $cur_row_data->[4], genreid => $cur_row_data->[7], year => $cur_row_data->[5] }] ); defined($cur_row_data->[4]) or bless ( $collapse_idx[3]{$cur_row_ids{0}}[1]{cds}, __NBC__ ); (! $collapse_idx[5]{$cur_row_ids{0}}{$cur_row_ids{4}}{$cur_row_ids{8}} ) and push @{$collapse_idx[4]{$cur_row_ids{0}}{$cur_row_ids{4}}[1]{tracks}}, ( $collapse_idx[5]{$cur_row_ids{0}}{$cur_row_ids{4}}{$cur_row_ids{8}} = [{ title => $cur_row_data->[8] }] ); defined($cur_row_data->[8]) or bless ( $collapse_idx[4]{$cur_row_ids{0}}{$cur_row_ids{4}}[1]{tracks}, __NBC__ ); (! $collapse_idx[6]{$cur_row_ids{2}}{$cur_row_ids{3}} ) and push @{$collapse_idx[0]{$cur_row_ids{10}}[1]{tracks}}, ( $collapse_idx[6]{$cur_row_ids{2}}{$cur_row_ids{3}} = [{ cd => $$cur_row_data[2], title => $cur_row_data->[3] }] ); defined($cur_row_data->[2]) or bless ( $collapse_idx[0]{$cur_row_ids{10}}[1]{tracks}, __NBC__ ); } $#{$_[0]} = $result_pos - 1; ', 'Multiple has_many on multiple branches with underdefined root torture test', ); is_same_src ( ($schema->source ('CD')->_mk_row_parser({ inflate_map => $infmap, collapse => 1, hri_style => 1, prune_null_branches => 1, }))[0], ' my $rows_pos = 0; my ($result_pos, @collapse_idx, $cur_row_data, %cur_row_ids); while ($cur_row_data = ( ( $rows_pos >= 0 and $_[0][$rows_pos++] ) || ( $_[1] and $rows_pos = -1 and $_[1]->() ) ) ) { # do not care about nullability here $cur_row_ids{0} = $cur_row_data->[0]; $cur_row_ids{2} = $cur_row_data->[2]; $cur_row_ids{3} = $cur_row_data->[3]; $cur_row_ids{4} = $cur_row_data->[4]; $cur_row_ids{8} = $cur_row_data->[8]; # cache expensive set of ops in a non-existent rowid slot $cur_row_ids{10} = ( ( ( defined $cur_row_data->[0] ) && (join "\xFF", q{}, $cur_row_data->[0], q{} )) or ( ( defined $cur_row_data->[2] ) && (join "\xFF", q{}, $cur_row_data->[2], q{} )) or "\0$rows_pos\0" ); # a present cref in $_[1] implies lazy prefetch, implies a supplied stash in $_[2] $_[1] and $result_pos and ! $collapse_idx[0]{$cur_row_ids{10}} and (unshift @{$_[2]}, $cur_row_data) and last; $collapse_idx[0]{$cur_row_ids{10}} //= $_[0][$result_pos++] = { year => $$cur_row_data[1] }; (! defined $cur_row_data->[0] ) ? $collapse_idx[0]{$cur_row_ids{10}}{single_track} = undef : do { $collapse_idx[0]{$cur_row_ids{10}}{single_track} //= ($collapse_idx[1]{$cur_row_ids{0}} = { trackid => $$cur_row_data[0] }); $collapse_idx[1]{$cur_row_ids{0}}{cd} //= $collapse_idx[2]{$cur_row_ids{0}}; $collapse_idx[2]{$cur_row_ids{0}}{artist} //= ($collapse_idx[3]{$cur_row_ids{0}} = { artistid => $$cur_row_data[6] }); (! defined $cur_row_data->[4] ) ? $collapse_idx[3]{$cur_row_ids{0}}{cds} = [] : do { (! $collapse_idx[4]{$cur_row_ids{0}}{$cur_row_ids{4}} ) and push @{$collapse_idx[3]{$cur_row_ids{0}}{cds}}, ( $collapse_idx[4]{$cur_row_ids{0}}{$cur_row_ids{4}} = { cdid => $$cur_row_data[4], genreid => $$cur_row_data[7], year => $$cur_row_data[5] } ); (! defined $cur_row_data->[8] ) ? $collapse_idx[4]{$cur_row_ids{0}}{$cur_row_ids{4}}{tracks} = [] : do { (! $collapse_idx[5]{$cur_row_ids{0}}{$cur_row_ids{4}}{$cur_row_ids{8}} ) and push @{$collapse_idx[4]{$cur_row_ids{0}}{$cur_row_ids{4}}{tracks}}, ( $collapse_idx[5]{$cur_row_ids{0}}{$cur_row_ids{4}}{$cur_row_ids{8}} = { title => $$cur_row_data[8] } ); }; }; }; (! defined $cur_row_data->[2] ) ? $collapse_idx[0]{$cur_row_ids{10}}{tracks} = [] : do { (! $collapse_idx[6]{$cur_row_ids{2}}{$cur_row_ids{3}} ) and push @{$collapse_idx[0]{$cur_row_ids{10}}{tracks}}, ( $collapse_idx[6]{$cur_row_ids{2}}{$cur_row_ids{3}} = { cd => $$cur_row_data[2], title => $$cur_row_data[3] } ); }; } $#{$_[0]} = $result_pos - 1; ', 'Multiple has_many on multiple branches with underdefined root, HRI-direct torture test', ); done_testing; my $deparser; sub is_same_src { SKIP: { skip "Skipping comparison of unicode-posioned source", 1 if DBIx::Class::_ENV_::STRESSTEST_UTF8_UPGRADE_GENERATED_COLLAPSER_SOURCE; $deparser ||= B::Deparse->new; local $Test::Builder::Level = $Test::Builder::Level + 1; my ($got, $expect) = @_; skip "Not testing equality of source containing defined-or operator on this perl $]", 1 if ($] < 5.010 and$expect =~ m!\Q//=!); $expect =~ s/__NBC__/perlstring($DBIx::Class::ResultSource::RowParser::Util::null_branch_class)/ge; $expect = " { use strict; use warnings FATAL => 'uninitialized';\n$expect\n }"; my @normalized = map { my $cref = eval "sub { $_ }" or do { fail "Coderef does not compile!\n\n$@\n\n$_"; return undef; }; $deparser->coderef2text($cref); } ($got, $expect); &is (@normalized, $_[2]||() ) or do { eval { require Test::Differences } ? &Test::Differences::eq_or_diff( @normalized, $_[2]||() ) : note ("Original sources:\n\n$got\n\n$expect\n") ; exit 1; }; } } ��������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/18insert_default.t������������������������������������������������������������0000644�0001750�0001750�00000001420�14240132261�016704� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); $schema->storage->sql_maker->quote_char('"'); my $rs = $schema->resultset ('Artist'); my $last_obj = $rs->search ({}, { order_by => { -desc => 'artistid' }, rows => 1})->single; my $last_id = $last_obj ? $last_obj->artistid : 0; my $obj; $schema->is_executed_sql_bind( sub { $obj = $rs->create ({}) }, [[ 'INSERT INTO "artist" DEFAULT VALUES' ]], 'Default-value insert correct SQL' ); ok ($obj, 'Insert defaults ( $rs->create ({}) )' ); # this should be picked up without calling the DB again is ($obj->artistid, $last_id + 1, 'Autoinc PK works'); # for this we need to refresh $obj->discard_changes; is ($obj->rank, 13, 'Default value works'); done_testing; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/debug/������������������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�014450� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/debug/bulk-insert.t�����������������������������������������������������������0000644�0001750�0001750�00000001074�14240132261�017055� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use DBIx::Class::Storage::Debug::PrettyTrace; my $cap; open my $fh, '>', \$cap; my $pp = DBIx::Class::Storage::Debug::PrettyTrace->new({ profile => 'none', fill_in_placeholders => 1, placeholder_surround => [qw(' ')], show_progress => 0, }); $pp->debugfh($fh); $pp->query_start('INSERT INTO self_ref_alias (alias, self_ref) VALUES ( ?, ? )', qw('__BULK_INSERT__' '1')); is( $cap, qq{INSERT INTO self_ref_alias( alias, self_ref ) VALUES( ?, ? ) : '__BULK_INSERT__', '1'\n}, 'SQL Logged' ); done_testing; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/debug/core.t������������������������������������������������������������������0000644�0001750�0001750�00000010577�14240132261�015556� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; no warnings 'once'; use Test::More; use Test::Exception; use Try::Tiny; use File::Spec; use lib qw(t/lib); use DBICTest; use Path::Class qw/file/; # something deep in Path::Class - mainline ditched it altogether plan skip_all => "Test is finicky under -T before 5.10" if "$]" < 5.010 and ${^TAINT}; BEGIN { delete @ENV{qw(DBIC_TRACE DBIC_TRACE_PROFILE DBICTEST_SQLITE_USE_FILE)} } my $schema = DBICTest->init_schema(); my $lfn = file("t/var/sql-$$.log"); unlink $lfn or die $! if -e $lfn; # make sure we are testing the vanilla debugger and not ::PrettyTrace require DBIx::Class::Storage::Statistics; $schema->storage->debugobj(DBIx::Class::Storage::Statistics->new); ok ( $schema->storage->debug(1), 'debug' ); $schema->storage->debugfh($lfn->openw); $schema->storage->debugfh->autoflush(1); $schema->resultset('CD')->count; my @loglines = $lfn->slurp; is (@loglines, 1, 'one line of log'); like($loglines[0], qr/^SELECT COUNT/, 'File log via debugfh success'); $schema->storage->debugfh(undef); { local $ENV{DBIC_TRACE} = "=$lfn"; unlink $lfn; $schema->resultset('CD')->count; my $schema2 = DBICTest->init_schema(no_deploy => 1); $schema2->storage->_do_query('SELECT 1'); # _do_query() logs via standard mechanisms my @loglines = $lfn->slurp; is(@loglines, 2, '2 lines of log'); like($loglines[0], qr/^SELECT COUNT/, 'Env log from schema1 success'); like($loglines[1], qr/^SELECT 1:/, 'Env log from schema2 success'); $schema->storage->debugobj->debugfh(undef) } END { unlink $lfn if $lfn; } open(STDERRCOPY, '>&STDERR'); my $exception_line_number; # STDERR will be closed, no T::B diag in blocks my $exception = try { close(STDERR); $exception_line_number = __LINE__ + 1; # important for test, do not reformat $schema->resultset('CD')->search({})->count; } catch { $_ } finally { # restore STDERR open(STDERR, '>&STDERRCOPY'); }; ok $exception =~ / \QDuplication of STDERR for debug output failed (perhaps your STDERR is closed?)\E .+ \Qat @{[__FILE__]} line $exception_line_number\E$ /xms or diag "Unexpected exception text:\n\n$exception\n"; my @warnings; $exception = try { local $SIG{__WARN__} = sub { push @warnings, @_ if $_[0] =~ /character/i }; close STDERR; open(STDERR, '>', File::Spec->devnull) or die $!; $schema->resultset('CD')->search({ title => "\x{1f4a9}" })->count; ''; } catch { $_; } finally { # restore STDERR close STDERR; open(STDERR, '>&STDERRCOPY'); }; die "How did that fail... $exception" if $exception; is_deeply(\@warnings, [], 'No warnings with unicode on STDERR'); # test debugcb and debugobj protocol { my $rs = $schema->resultset('CD')->search( { artist => 1, cdid => { -between => [ 1, 3 ] }, title => { '!=' => \[ '?', undef ] } }); my $sql_trace = 'SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE ( ( artist = ? AND ( cdid BETWEEN ? AND ? ) AND title != ? ) )'; my @bind_trace = qw( '1' '1' '3' NULL ); # quotes are in fact part of the trace </facepalm> my @args; $schema->storage->debugcb(sub { push @args, @_ } ); $rs->all; is_deeply( \@args, [ "SELECT", sprintf( "%s: %s\n", $sql_trace, join ', ', @bind_trace ), ]); { package DBICTest::DebugObj; our @ISA = 'DBIx::Class::Storage::Statistics'; sub query_start { my $self = shift; ( $self->{_traced_sql}, @{$self->{_traced_bind}} ) = @_; } } my $do = $schema->storage->debugobj(DBICTest::DebugObj->new); $rs->all; is( $do->{_traced_sql}, $sql_trace ); is_deeply ( $do->{_traced_bind}, \@bind_trace ); } # recreate test as seen in DBIx::Class::QueryLog # the rationale is that if someone uses a non-IO::Handle object # on CPAN, many are *bound* to use one on darkpan. Thus this # test to ensure there is no future silent breakage { my $output = ""; { package DBICTest::_Printable; sub print { my ($self, @args) = @_; $output .= join('', @args); } } $schema->storage->debugobj(undef); $schema->storage->debug(1); $schema->storage->debugfh( bless {}, "DBICTest::_Printable" ); $schema->storage->txn_do( sub { $schema->resultset('Artist')->count } ); like ( $output, qr/ \A ^ \QBEGIN WORK\E \s*? ^ \QSELECT COUNT( * ) FROM artist me:\E \s*? ^ \QCOMMIT\E \s*? \z /xm ); $schema->storage->debug(0); $schema->storage->debugfh(undef); } done_testing; ���������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/debug/show-progress.t���������������������������������������������������������0000644�0001750�0001750�00000001103�14240132261�017431� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use DBIx::Class::Storage::Debug::PrettyTrace; my $cap; open my $fh, '>', \$cap; my $pp = DBIx::Class::Storage::Debug::PrettyTrace->new({ show_progress => 1, clear_line => 'CLEAR', executing => 'GOGOGO', }); $pp->debugfh($fh); $pp->query_start('SELECT * FROM frew WHERE id = 1'); is( $cap, qq(SELECT * FROM frew WHERE id = 1 : \nGOGOGO), 'SQL Logged' ); $pp->query_end('SELECT * FROM frew WHERE id = 1'); is( $cap, qq(SELECT * FROM frew WHERE id = 1 : \nGOGOGOCLEAR), 'SQL Logged' ); done_testing; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/debug/no-repeats.t������������������������������������������������������������0000644�0001750�0001750�00000002354�14240132261�016675� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use DBIx::Class::Storage::Debug::PrettyTrace; my $cap; open my $fh, '>', \$cap; my $pp = DBIx::Class::Storage::Debug::PrettyTrace->new({ profile => 'none', squash_repeats => 1, fill_in_placeholders => 1, placeholder_surround => ['', ''], show_progress => 0, }); $pp->debugfh($fh); $pp->query_start('SELECT * FROM frew WHERE id = ?', q('1')); is( $cap, qq(SELECT * FROM frew WHERE id = '1'\n), 'SQL Logged' ); open $fh, '>', \$cap; $pp->query_start('SELECT * FROM frew WHERE id = ?', q('2')); is( $cap, qq(... : '2'\n), 'Repeated SQL ellided' ); open $fh, '>', \$cap; $pp->query_start('SELECT * FROM frew WHERE id = ?', q('3')); is( $cap, qq(... : '3'\n), 'Repeated SQL ellided' ); open $fh, '>', \$cap; $pp->query_start('SELECT * FROM frew WHERE id = ?', q('4')); is( $cap, qq(... : '4'\n), 'Repeated SQL ellided' ); open $fh, '>', \$cap; $pp->query_start('SELECT * FROM bar WHERE id = ?', q('4')); is( $cap, qq(SELECT * FROM bar WHERE id = '4'\n), 'New SQL Logged' ); open $fh, '>', \$cap; $pp->query_start('SELECT * FROM frew WHERE id = ?', q('1')); is( $cap, qq(SELECT * FROM frew WHERE id = '1'\n), 'New SQL Logged' ); done_testing; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/debug/pretty.t����������������������������������������������������������������0000644�0001750�0001750�00000002104�14240132261�016140� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use lib qw(t/lib); use DBICTest; use Test::More; BEGIN { require DBIx::Class; plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_prettydebug') unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_prettydebug'); } BEGIN { delete @ENV{qw(DBIC_TRACE_PROFILE)} } { my $schema = DBICTest->init_schema; isa_ok($schema->storage->debugobj, 'DBIx::Class::Storage::Statistics'); } { local $ENV{DBIC_TRACE_PROFILE} = 'console'; my $schema = DBICTest->init_schema; isa_ok($schema->storage->debugobj, 'DBIx::Class::Storage::Debug::PrettyTrace');; is($schema->storage->debugobj->_sqlat->indent_string, ' ', 'indent string set correctly from console profile'); } { local $ENV{DBIC_TRACE_PROFILE} = './t/lib/awesome.json'; my $schema = DBICTest->init_schema; isa_ok($schema->storage->debugobj, 'DBIx::Class::Storage::Debug::PrettyTrace');; is($schema->storage->debugobj->_sqlat->indent_string, 'frioux', 'indent string set correctly from file-based profile'); } done_testing; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/�������������������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�014263� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/24-meta_info.t�����������������������������������������������������������0000644�0001750�0001750�00000003437�14240132261�016622� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Warn; use lib 't/cdbi/testlib'; use DBIC::Test::SQLite (); # this will issue the necessary SKIPs on missing reqs eval { require Time::Piece } or plan skip_all => 'Time::Piece required for this test'; package Temp::DBI; use base qw(DBIx::Class::CDBICompat); Temp::DBI->columns(All => qw(id date)); my $strptime_inflate = sub { Time::Piece->strptime(shift, "%Y-%m-%d") }; Temp::DBI->has_a( date => 'Time::Piece', inflate => $strptime_inflate ); package Temp::Person; use base 'Temp::DBI'; Temp::Person->table('people'); Temp::Person->columns(Info => qw(name pet)); Temp::Person->has_a( pet => 'Temp::Pet' ); package Temp::Pet; use base 'Temp::DBI'; Temp::Pet->table('pets'); Temp::Pet->columns(Info => qw(name)); Temp::Pet->has_many(owners => 'Temp::Person'); package main; { my $pn_meta = Temp::Person->meta_info('has_a'); is_deeply [sort keys %$pn_meta], [qw/date pet/], "Person has Date and Pet"; } { my $pt_meta = Temp::Pet->meta_info; is_deeply [keys %{$pt_meta->{has_a}}], [qw/date/], "Pet has Date"; is_deeply [keys %{$pt_meta->{has_many}}], [qw/owners/], "And owners"; } { my $pet = Temp::Person->meta_info( has_a => 'pet' ); is $pet->class, 'Temp::Person'; is $pet->foreign_class, 'Temp::Pet'; is $pet->accessor, 'pet'; is $pet->name, 'has_a'; } { my $owners = Temp::Pet->meta_info( has_many => 'owners' ); is_deeply $owners->args, { foreign_key => 'pet', mapping => [], }; } { my $date = Temp::Pet->meta_info( has_a => 'date' ); is $date->class, 'Temp::DBI'; is $date->foreign_class, 'Time::Piece'; is $date->accessor, 'date'; is $date->args->{inflate}, $strptime_inflate; } done_testing; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/testlib/�����������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�015731� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/testlib/CDBase.pm��������������������������������������������������������0000644�0001750�0001750�00000000147�13555517102�017342� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE CDBase; use warnings; use strict; use base qw(DBIC::Test::SQLite); 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/testlib/MyStar.pm��������������������������������������������������������0000644�0001750�0001750�00000000601�14240132261�017462� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE MyStar; use warnings; use strict; use base 'MyBase'; __PACKAGE__->set_table(); __PACKAGE__->columns(All => qw/starid name/); __PACKAGE__->has_many(films => [ MyStarLink => 'film' ]); # sub films { map $_->film, shift->_films } sub create_sql { return qq{ starid TINYINT NOT NULL AUTO_INCREMENT PRIMARY KEY, name VARCHAR(255) }; } 1; �������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/testlib/Director.pm������������������������������������������������������0000644�0001750�0001750�00000000551�13555517102�020033� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE Director; use warnings; use strict; use base 'DBIC::Test::SQLite'; __PACKAGE__->set_table('Directors'); __PACKAGE__->columns('All' => qw/ Name Birthday IsInsane /); sub create_sql { return qq{ name VARCHAR(80), birthday INTEGER, isinsane INTEGER }; } 1; �������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/testlib/DBIC/������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�016432� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/testlib/DBIC/Test/�������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�017351� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/testlib/DBIC/Test/SQLite.pm����������������������������������������������0000644�0001750�0001750�00000004765�14240132261�021043� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE DBIC::Test::SQLite; =head1 NAME DBIx::Class::Test::SQLite - Base class for running Class::DBI tests against DBIx::Class compat layer, shamelessly ripped from Class::DBI::Test::SQLite =head1 SYNOPSIS use base 'DBIx::Class::Test::SQLite'; __PACKAGE__->set_table('test'); __PACKAGE__->columns(All => qw/id name film salary/); sub create_sql { return q{ id INTEGER PRIMARY KEY, name CHAR(40), film VARCHAR(255), salary INT } } =head1 DESCRIPTION This provides a simple base class for DBIx::Class::CDBICompat tests using SQLite. Each class for the test should inherit from this, provide a create_sql() method which returns a string representing the SQL used to create the table for the class, and then call set_table() to create the table, and tie it to the class. =cut use strict; use warnings; use Test::More; # adding implicit search criteria to the iterator will alter the test # mechanics - leave everything as-is instead, and hope SQLite won't # change too much BEGIN { $ENV{DBIC_SHUFFLE_UNORDERED_RESULTSETS} = 0 } use lib 't/lib'; use DBICTest; BEGIN { eval { require DBIx::Class::CDBICompat } or plan skip_all => 'Class::DBI required for this test'; } use base qw/DBIx::Class/; __PACKAGE__->load_components(qw/CDBICompat Core DB/); my $DB = DBICTest->_sqlite_dbfilename; my @DSN = ("dbi:SQLite:dbname=$DB", '', '', { AutoCommit => 1, RaiseError => 1 }); __PACKAGE__->connection(@DSN); __PACKAGE__->set_sql(_table_pragma => 'PRAGMA table_info(__TABLE__)'); __PACKAGE__->set_sql(_create_me => 'CREATE TABLE __TABLE__ (%s)'); __PACKAGE__->storage->dbh->do("PRAGMA synchronous = OFF"); =head1 METHODS =head2 set_table __PACKAGE__->set_table('test'); This combines creating the table with the normal DBIx::Class table() call. =cut sub set_table { my ($class, $table) = @_; $class->table($table); $class->_create_test_table; } sub _create_test_table { my $class = shift; my @vals = $class->sql__table_pragma->select_row; $class->sql__create_me($class->create_sql)->execute unless @vals; } =head2 create_sql This is an abstract method you must override. sub create_sql { return q{ id INTEGER PRIMARY KEY, name CHAR(40), film VARCHAR(255), salary INT } } This should return, as a text string, the schema for the table represented by this class. =cut sub create_sql { die "create_sql() not implemented by $_[0]\n" } 1; �����������DBIx-Class-0.082843/t/cdbi/testlib/Log.pm�����������������������������������������������������������0000644�0001750�0001750�00000001635�14240132261�016774� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE Log; use warnings; use strict; use base 'MyBase'; use Time::Piece::MySQL; use POSIX; __PACKAGE__->set_table(); __PACKAGE__->columns(All => qw/id message datetime_stamp/); __PACKAGE__->has_a( datetime_stamp => 'Time::Piece', inflate => 'from_mysql_datetime', deflate => 'mysql_datetime' ); # Disables the implicit autoinc-on-non-supplied-pk behavior # (and the warning that goes with it) # This is the same behavior as it was pre 0.082900 __PACKAGE__->column_info('id')->{is_auto_increment} = 0; __PACKAGE__->add_trigger(before_create => \&set_dts); __PACKAGE__->add_trigger(before_update => \&set_dts); sub set_dts { shift->datetime_stamp( POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime(time))); } sub create_sql { return qq{ id INT UNSIGNED AUTO_INCREMENT PRIMARY KEY, message VARCHAR(255), datetime_stamp DATETIME }; } 1; ���������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/testlib/Blurb.pm���������������������������������������������������������0000644�0001750�0001750�00000000560�13555517102�017326� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE Blurb; use warnings; use strict; use base 'DBIC::Test::SQLite'; __PACKAGE__->set_table('Blurbs'); __PACKAGE__->columns('Primary', 'Title'); __PACKAGE__->columns('Blurb', qw/ blurb/); sub create_sql { return qq{ title VARCHAR(255) PRIMARY KEY, blurb VARCHAR(255) NOT NULL } } 1; ������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/testlib/MyFilm.pm��������������������������������������������������������0000644�0001750�0001750�00000000701�14240132261�017441� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE MyFilm; use warnings; use strict; use base 'MyBase'; use MyStarLink; __PACKAGE__->set_table(); __PACKAGE__->columns(All => qw/filmid title/); __PACKAGE__->has_many(_stars => 'MyStarLink'); __PACKAGE__->columns(Stringify => 'title'); sub _carp { } sub stars { map $_->star, shift->_stars } sub create_sql { return qq{ filmid TINYINT NOT NULL AUTO_INCREMENT PRIMARY KEY, title VARCHAR(255) }; } 1; ���������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/testlib/ActorAlias.pm����������������������������������������������������0000644�0001750�0001750�00000001173�13560502346�020303� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE ActorAlias; use strict; use warnings; use base 'DBIC::Test::SQLite'; __PACKAGE__->set_table( 'ActorAlias' ); __PACKAGE__->columns( Primary => 'id' ); __PACKAGE__->columns( All => qw/ actor alias / ); __PACKAGE__->has_a( actor => 'Actor' ); __PACKAGE__->has_a( alias => 'Actor' ); # Disables the implicit autoinc-on-non-supplied-pk behavior # (and the warning that goes with it) # This is the same behavior as it was pre 0.082900 __PACKAGE__->column_info('id')->{is_auto_increment} = 0; sub create_sql { return qq{ id INTEGER PRIMARY KEY, actor INTEGER, alias INTEGER } } 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/testlib/Thing.pm���������������������������������������������������������0000644�0001750�0001750�00000000377�13555517102�017337� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package Thing; use warnings; use strict; use base 'DBIC::Test::SQLite'; Thing->set_table("thing"); Thing->columns(All => qw(id that_thing)); sub create_sql { return qq{ id INTEGER, that_thing INTEGER }; } 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/testlib/OtherFilm.pm�����������������������������������������������������0000644�0001750�0001750�00000000626�14240132261�020143� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE OtherFilm; use warnings; use strict; use base 'Film'; __PACKAGE__->set_table('Different_Film'); sub create_sql { return qq{ title VARCHAR(255), director VARCHAR(80), codirector VARCHAR(80), rating CHAR(5), numexplodingsheep INTEGER, hasvomit CHAR(1) }; } 1; ����������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/testlib/Actor.pm���������������������������������������������������������0000644�0001750�0001750�00000001344�13560502346�017331� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE Actor; use strict; use warnings; use base 'DBIC::Test::SQLite'; __PACKAGE__->set_table('Actor'); __PACKAGE__->columns(Primary => 'id'); __PACKAGE__->columns(All => qw/ Name Film Salary /); __PACKAGE__->columns(TEMP => qw/ nonpersistent /); __PACKAGE__->add_constructor(salary_between => 'salary >= ? AND salary <= ?'); # Disables the implicit autoinc-on-non-supplied-pk behavior # (and the warning that goes with it) # This is the same behavior as it was pre 0.082900 __PACKAGE__->column_info('id')->{is_auto_increment} = 0; sub mutator_name_for { "set_$_[1]" } sub create_sql { return qq{ id INTEGER PRIMARY KEY, name CHAR(40), film VARCHAR(255), salary INT } } 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/testlib/MyBase.pm��������������������������������������������������������0000644�0001750�0001750�00000002667�14240132261�017441� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE MyBase; use warnings; use strict; use DBI; use lib 't/lib'; use DBICTest; use base qw(DBIx::Class::CDBICompat); our $dbh; my $err; if (! $ENV{DBICTEST_MYSQL_DSN} ) { $err = 'Set $ENV{DBICTEST_MYSQL_DSN}, _USER and _PASS to run this test'; } elsif ( ! DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_mysql') ) { $err = 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_mysql') } if ($err) { my $t = eval { Test::Builder->new }; if ($t and ! $t->current_test) { $t->skip_all ($err); } else { die "$err\n"; } } my @connect = (@ENV{map { "DBICTEST_MYSQL_${_}" } qw/DSN USER PASS/}, { PrintError => 0}); # this is only so we grab a lock on mysql { my $x = DBICTest::Schema->connect(@connect); } $dbh = DBI->connect(@connect) or die DBI->errstr; my @table; END { $dbh->do("DROP TABLE $_") foreach @table } __PACKAGE__->connection(@connect); sub set_table { my $class = shift; $class->table($class->create_test_table); } sub create_test_table { my $self = shift; my $table = $self->next_available_table; my $create = sprintf "CREATE TABLE $table ( %s )", $self->create_sql; push @table, $table; $dbh->do($create); return $table; } sub next_available_table { my $self = shift; my @tables = sort @{ $dbh->selectcol_arrayref( qq{ SHOW TABLES } ) }; my $table = $tables[-1] || "aaa"; return "z$table"; } 1; �������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/testlib/MyStarLink.pm����������������������������������������������������0000644�0001750�0001750�00000000624�14240132261�020305� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE MyStarLink; use warnings; use strict; use base 'MyBase'; __PACKAGE__->set_table(); __PACKAGE__->columns(All => qw/linkid film star/); __PACKAGE__->has_a(film => 'MyFilm'); __PACKAGE__->has_a(star => 'MyStar'); sub create_sql { return qq{ linkid TINYINT NOT NULL AUTO_INCREMENT PRIMARY KEY, film TINYINT NOT NULL, star TINYINT NOT NULL }; } 1; ������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/testlib/Lazy.pm����������������������������������������������������������0000644�0001750�0001750�00000001003�13555517102�017170� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE Lazy; use warnings; use strict; use base 'DBIC::Test::SQLite'; __PACKAGE__->set_table("Lazy"); __PACKAGE__->columns('Primary', qw(this)); __PACKAGE__->columns('Essential', qw(opop)); __PACKAGE__->columns('things', qw(this that)); __PACKAGE__->columns('horizon', qw(eep orp)); __PACKAGE__->columns('vertical', qw(oop opop)); sub create_sql { return qq{ this INTEGER, that INTEGER, eep INTEGER, orp INTEGER, oop INTEGER, opop INTEGER }; } 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/testlib/OtherThing.pm����������������������������������������������������0000644�0001750�0001750�00000000344�13555517102�020333� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package OtherThing; use warnings; use strict; use base 'DBIC::Test::SQLite'; OtherThing->set_table("other_thing"); OtherThing->columns(All => qw(id)); sub create_sql { return qq{ id INTEGER }; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/testlib/ImplicitInflate.pm�����������������������������������������������0000644�0001750�0001750�00000001727�13560502346�021343� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # Hide from PAUSE ImplicitInflate; # Test class for the testing of Implicit inflation # in CDBI Classes using Compat layer # See t/cdbi/70-implicit_inflate.t use strict; use warnings; use base 'DBIC::Test::SQLite'; __PACKAGE__->set_table('Date'); __PACKAGE__->columns( Primary => 'id' ); __PACKAGE__->columns( All => qw/ update_datetime text/); __PACKAGE__->has_a( update_datetime => 'MyDateStamp', ); # Disables the implicit autoinc-on-non-supplied-pk behavior # (and the warning that goes with it) # This is the same behavior as it was pre 0.082900 __PACKAGE__->column_info('id')->{is_auto_increment} = 0; sub create_sql { # SQLite doesn't support Datetime datatypes. return qq{ id INTEGER PRIMARY KEY, update_datetime TEXT, text VARCHAR(20) } } { package MyDateStamp; use DateTime::Format::SQLite; sub new { my ($self, $value) = @_; return DateTime::Format::SQLite->parse_datetime($value); } } 1; �����������������������������������������DBIx-Class-0.082843/t/cdbi/testlib/Film.pm����������������������������������������������������������0000644�0001750�0001750�00000002130�13560502346�017142� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE Film; use warnings; use strict; use base 'DBIC::Test::SQLite'; __PACKAGE__->set_table('Movies'); __PACKAGE__->columns('Primary', 'Title'); __PACKAGE__->columns('Essential', qw( Title )); __PACKAGE__->columns('Directors', qw( Director CoDirector )); __PACKAGE__->columns('Other', qw( Rating NumExplodingSheep HasVomit )); # Disables the implicit autoinc-on-non-supplied-pk behavior # (and the warning that goes with it) # This is the same behavior as it was pre 0.082900 __PACKAGE__->column_info('title')->{is_auto_increment} = 0; sub create_sql { return qq{ title VARCHAR(255), director VARCHAR(80), codirector VARCHAR(80), rating CHAR(5), numexplodingsheep INTEGER, hasvomit CHAR(1) } } sub create_test_film { return shift->create({ Title => 'Bad Taste', Director => 'Peter Jackson', Rating => 'R', NumExplodingSheep => 1, }); } package DeletingFilm; use base 'Film'; sub DESTROY { shift->delete } 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/testlib/MyStarLinkMCPK.pm������������������������������������������������0000644�0001750�0001750�00000001113�14240132261�020752� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE MyStarLinkMCPK; use warnings; use strict; use base 'MyBase'; use MyStar; use MyFilm; # This is a many-to-many mapping table that uses the two foreign keys # as its own primary key - there's no extra 'auto-inc' column here __PACKAGE__->set_table(); __PACKAGE__->columns(Primary => qw/film star/); __PACKAGE__->columns(All => qw/film star/); __PACKAGE__->has_a(film => 'MyFilm'); __PACKAGE__->has_a(star => 'MyStar'); sub create_sql { return qq{ film INTEGER NOT NULL, star INTEGER NOT NULL, PRIMARY KEY (film, star) }; } 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/testlib/Order.pm���������������������������������������������������������0000644�0001750�0001750�00000000530�13555517102�017330� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE Order; use warnings; use strict; use base 'DBIC::Test::SQLite'; __PACKAGE__->set_table('orders'); __PACKAGE__->table_alias('orders'); __PACKAGE__->columns(Primary => 'film'); __PACKAGE__->columns(Others => qw/orders/); sub create_sql { return qq{ film VARCHAR(255), orders INTEGER }; } 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/testlib/MyFoo.pm���������������������������������������������������������0000644�0001750�0001750�00000001424�14240132261�017300� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # hide from PAUSE MyFoo; use warnings; use strict; use base 'MyBase'; use Date::Simple 3.03; __PACKAGE__->set_table(); __PACKAGE__->columns(All => qw/myid name val tdate/); __PACKAGE__->has_a( tdate => 'Date::Simple', inflate => sub { Date::Simple->new(shift) }, deflate => 'format', ); # Disables the implicit autoinc-on-non-supplied-pk behavior # (and the warning that goes with it) # This is the same behavior as it was pre 0.082900 __PACKAGE__->column_info('myid')->{is_auto_increment} = 0; #__PACKAGE__->find_column('tdate')->placeholder("IF(1, CURDATE(), ?)"); sub create_sql { return qq{ myid mediumint not null auto_increment primary key, name varchar(50) not null default '', val char(1) default 'A', tdate date not null }; } 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/testlib/ColumnObject.pm��������������������������������������������������0000644�0001750�0001750�00000001370�13560502346�020644� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package # Hide from PAUSE ColumnObject; use strict; use warnings; use base 'DBIC::Test::SQLite'; use Class::DBI::Column; __PACKAGE__->set_table('column_object'); __PACKAGE__->columns( Primary => 'id' ); __PACKAGE__->columns( All => ( 'id', 'columna', 'columnb', Class::DBI::Column->new('columna' => {accessor => 'columna_as_read'}), Class::DBI::Column->new('columnb' => {mutator => 'columnb_as_write'}), )); # Disables the implicit autoinc-on-non-supplied-pk behavior # (and the warning that goes with it) # This is the same behavior as it was pre 0.082900 __PACKAGE__->column_info('id')->{is_auto_increment} = 0; sub create_sql { return qq{ id INTEGER PRIMARY KEY, columna VARCHAR(20), columnb VARCHAR(20) } } 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/22-deflate_order.t�������������������������������������������������������0000644�0001750�0001750�00000001070�14240132261�017445� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������$| = 1; use warnings; use strict; use Test::More; use lib 't/cdbi/testlib'; use DBIC::Test::SQLite (); # this will issue the necessary SKIPs on missing reqs eval { require Time::Piece::MySQL } or plan skip_all => 'Time::Piece::MySQL required for this test'; use_ok ('Log'); package main; my $log = Log->insert( { message => 'initial message' } ); ok eval { $log->datetime_stamp }, "Have datetime"; diag $@ if $@; $log->message( 'a revised message' ); $log->update; ok eval { $log->datetime_stamp }, "Have datetime after update"; diag $@ if $@; done_testing; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/mk_group_accessors.t�����������������������������������������������������0000644�0001750�0001750�00000002215�14240132261�020317� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; INIT { use lib 't/cdbi/testlib'; require Film; } sub Film::get_test { my $self = shift; my $key = shift; $self->{get_test}++; return $self->{$key}; } sub Film::set_test { my($self, $key, $val) = @_; $self->{set_test}++; return $self->{$key} = $val; } my $film = Film->create({ Title => "No Wolf McQuade" }); # Test mk_group_accessors() with a list of fields. { Film->mk_group_accessors(test => qw(foo bar)); $film->foo(42); is $film->foo, 42; $film->bar(23); is $film->bar, 23; } # An explicit accessor passed to mk_group_accessors should # ignore accessor/mutator_name_for. sub Film::accessor_name_for { my($class, $col) = @_; return "hlaglagh" if $col eq "wibble"; return $col; } sub Film::mutator_name_for { my($class, $col) = @_; return "hlaglagh" if $col eq "wibble"; return $col; } # Test with a mix of fields and field specs { Film->mk_group_accessors(test => ("baz", [wibble_thing => "wibble"])); $film->baz(42); is $film->baz, 42; $film->wibble_thing(23); is $film->wibble_thing, 23; } done_testing; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/02-Film.t����������������������������������������������������������������0000644�0001750�0001750�00000030132�14240132261�015534� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Scalar::Util 'refaddr'; use namespace::clean; $| = 1; INIT { use lib 't/cdbi/testlib'; use Film; } ok(Film->can('db_Main'), 'set_db()'); is(Film->__driver, "SQLite", "Driver set correctly"); { my $nul = eval { Film->retrieve() }; is $nul, undef, "Can't retrieve nothing"; like $@, qr/./, "retrieve needs parameters"; # TODO fix this... } { eval { my $id = Film->id }; like $@, qr/class method/, "Can't get id with no object"; } { eval { my $id = Film->title }; #like $@, qr/class method/, "Can't get title with no object"; ok $@, "Can't get title with no object"; } eval { my $duh = Film->insert; }; like $@, qr/Result object instantiation requires a hashref as argument/, "needs a hashref"; ok +Film->create_test_film; my $btaste = Film->retrieve('Bad Taste'); isa_ok $btaste, 'Film'; is($btaste->Title, 'Bad Taste', 'Title() get'); is($btaste->Director, 'Peter Jackson', 'Director() get'); is($btaste->Rating, 'R', 'Rating() get'); is($btaste->NumExplodingSheep, 1, 'NumExplodingSheep() get'); { my $bt2 = Film->find_or_create(Title => 'Bad Taste'); is $bt2->Director, $btaste->Director, "find_or_create"; my @bt = Film->search(Title => 'Bad Taste'); is @bt, 1, " doesn't create a new one"; } ok my $gone = Film->find_or_create( { Title => 'Gone With The Wind', Director => 'Bob Baggadonuts', Rating => 'PG', NumExplodingSheep => 0 } ), "Add Gone With The Wind"; isa_ok $gone, 'Film'; ok $gone = Film->retrieve(Title => 'Gone With The Wind'), "Fetch it back again"; isa_ok $gone, 'Film'; # Shocking new footage found reveals bizarre Scarlet/sheep scene! is($gone->NumExplodingSheep, 0, 'NumExplodingSheep() get again'); $gone->NumExplodingSheep(5); is($gone->NumExplodingSheep, 5, 'NumExplodingSheep() set'); is($gone->numexplodingsheep, 5, 'numexplodingsheep() set'); is($gone->Rating, 'PG', 'Rating() get again'); $gone->Rating('NC-17'); is($gone->Rating, 'NC-17', 'Rating() set'); $gone->update; { my @films = eval { Film->retrieve_all }; cmp_ok(@films, '==', 2, "We have 2 films in total"); } # EXTRA TEST: added by mst to check a bug found by Numa cmp_ok(Film->count_all, '==', 2, "count_all confirms 2 films"); my $gone_copy = Film->retrieve('Gone With The Wind'); ok($gone->NumExplodingSheep == 5, 'update()'); ok($gone->Rating eq 'NC-17', 'update() again'); # Grab the 'Bladerunner' entry. Film->create( { Title => 'Bladerunner', Director => 'Bob Ridley Scott', Rating => 'R' } ); my $blrunner = Film->retrieve('Bladerunner'); is(ref $blrunner, 'Film', 'retrieve() again'); is $blrunner->Title, 'Bladerunner', "Correct title"; is $blrunner->Director, 'Bob Ridley Scott', " and Director"; is $blrunner->Rating, 'R', " and Rating"; is $blrunner->NumExplodingSheep, undef, " and sheep"; # Make a copy of 'Bladerunner' and create an entry of the directors cut my $blrunner_dc = $blrunner->copy( { title => "Bladerunner: Director's Cut", rating => "15", } ); is(ref $blrunner_dc, 'Film', "copy() produces a film"); is($blrunner_dc->Title, "Bladerunner: Director's Cut", 'Title correct'); is($blrunner_dc->Director, 'Bob Ridley Scott', 'Director correct'); is($blrunner_dc->Rating, '15', 'Rating correct'); is($blrunner_dc->NumExplodingSheep, undef, 'Sheep correct'); # Set up own SQL: { Film->add_constructor(title_asc => "title LIKE ? ORDER BY title"); Film->add_constructor(title_desc => "title LIKE ? ORDER BY title DESC"); Film->add_constructor(title_asc_nl => q{ title LIKE ? ORDER BY title LIMIT 1 }); { my @films = Film->title_asc("Bladerunner%"); is @films, 2, "We have 2 Bladerunners"; is $films[0]->Title, $blrunner->Title, "Ordered correctly"; } { my @films = Film->title_desc("Bladerunner%"); is @films, 2, "We have 2 Bladerunners"; is $films[0]->Title, $blrunner_dc->Title, "Ordered correctly"; } { my @films = Film->title_asc_nl("Bladerunner%"); is @films, 1, "We have 2 Bladerunners"; is $films[0]->Title, $blrunner->Title, "Ordered correctly"; } } # Multi-column search { my @films = $blrunner->search (title => { -like => "Bladerunner%"}, rating => '15'); is @films, 1, "Only one Bladerunner is a 15"; } # Inline SQL { my @films = Film->retrieve_from_sql("numexplodingsheep > 0 ORDER BY title"); is @films, 2, "Inline SQL"; is $films[0]->id, $btaste->id, "Correct film"; is $films[1]->id, $gone->id, "Correct film"; } # Inline SQL removes WHERE { my @films = Film->retrieve_from_sql(" WHErE numexplodingsheep > 0 ORDER BY title"); is @films, 2, "Inline SQL"; is $films[0]->id, $btaste->id, "Correct film"; is $films[1]->id, $gone->id, "Correct film"; } eval { my $ishtar = Film->insert({ Title => 'Ishtar', Director => 'Elaine May' }); my $mandn = Film->insert({ Title => 'Mikey and Nicky', Director => 'Elaine May' }); my $new_leaf = Film->insert({ Title => 'A New Leaf', Director => 'Elaine May' }); #use Data::Dumper; die Dumper(Film->search( Director => 'Elaine May' )); cmp_ok(Film->search(Director => 'Elaine May'), '==', 3, "3 Films by Elaine May"); ok(Film->retrieve('Ishtar')->delete, "Ishtar doesn't deserve an entry any more"); ok(!Film->retrieve('Ishtar'), 'Ishtar no longer there'); { my $deprecated = 0; local $SIG{__WARN__} = sub { $deprecated++ if $_[0] =~ /deprecated/ }; ok( Film->delete(Director => 'Elaine May'), "In fact, delete all films by Elaine May" ); cmp_ok(Film->search(Director => 'Elaine May'), '==', 0, "0 Films by Elaine May"); is $deprecated, 0, "No deprecated warnings from compat layer"; } }; is $@, '', "No problems with deletes"; # Find all films which have a rating of NC-17. my @films = Film->search('Rating', 'NC-17'); is(scalar @films, 1, ' search returns one film'); is($films[0]->id, $gone->id, ' ... the correct one'); # Find all films which were directed by Bob @films = Film->search ( { 'Director' => { -like => 'Bob %' } }); is(scalar @films, 3, ' search_like returns 3 films'); ok( eq_array( [ sort map { $_->id } @films ], [ sort map { $_->id } $blrunner_dc, $gone, $blrunner ] ), 'the correct ones' ); # Find Ridley Scott films which don't have vomit @films = Film->search(numExplodingSheep => undef, Director => 'Bob Ridley Scott'); is(scalar @films, 2, ' search where attribute is null returns 2 films'); ok( eq_array( [ sort map { $_->id } @films ], [ sort map { $_->id } $blrunner_dc, $blrunner ] ), 'the correct ones' ); # Test that a disconnect doesnt harm anything. { # SQLite is loud on disconnect/reconnect. # This is solved in DBIC but not in ContextualFetch local $SIG{__WARN__} = sub { warn @_ unless $_[0] =~ /active statement handles|inactive database handle/; }; Film->db_Main->disconnect; @films = Film->search({ Rating => 'NC-17' }); ok(@films == 1 && $films[0]->id eq $gone->id, 'auto reconnection'); # Test discard_changes(). my $orig_director = $btaste->Director; $btaste->Director('Lenny Bruce'); is($btaste->Director, 'Lenny Bruce', 'set new Director'); $btaste->discard_changes; is($btaste->Director, $orig_director, 'discard_changes()'); } SKIP: { skip "ActiveState perl produces additional warnings", 3 if ($^O eq 'MSWin32'); Film->autoupdate(1); my $btaste2 = Film->retrieve($btaste->id); $btaste->NumExplodingSheep(18); my @warnings; local $SIG{__WARN__} = sub { push(@warnings, @_); }; { # unhook from live object cache, so next one is not from cache $btaste2->remove_from_object_index; my $btaste3 = Film->retrieve($btaste->id); is $btaste3->NumExplodingSheep, 18, "Class based AutoCommit"; $btaste3->autoupdate(0); # obj a/c should override class a/c is @warnings, 0, "No warnings so far"; $btaste3->NumExplodingSheep(13); } is @warnings, 1, "DESTROY without update warns"; Film->autoupdate(0); } { # update unchanged object my $film = Film->retrieve($btaste->id); my $retval = $film->update; is $retval, -1, "Unchanged object"; } { # update deleted object my $rt = "Royal Tenenbaums"; my $ten = Film->insert({ title => $rt, Rating => "R" }); $ten->rating(18); Film->set_sql(drt => "DELETE FROM __TABLE__ WHERE title = ?"); Film->sql_drt->execute($rt); my @films = Film->search({ title => $rt }); is @films, 0, "RT gone"; my $retval = eval { $ten->update }; like $@, qr/row not found/, "Update deleted object throws error"; $ten->discard_changes; } { $btaste->autoupdate(1); $btaste->NumExplodingSheep(32); my $btaste2 = Film->retrieve($btaste->id); is $btaste2->NumExplodingSheep, 32, "Object based AutoCommit"; $btaste->autoupdate(0); } # Primary key of 0 { my $zero = Film->insert({ Title => 0, Rating => "U" }); ok defined $zero, "Create 0"; ok my $ret = Film->retrieve(0), "Retrieve 0"; is $ret->Title, 0, "Title OK"; is $ret->Rating, "U", "Rating OK"; } # Change after_update policy SKIP: { skip "DBIx::Class compat doesn't handle the exists stuff quite right yet", 4; my $bt = Film->retrieve($btaste->id); $bt->autoupdate(1); $bt->rating("17"); ok !$bt->_attribute_exists('rating'), "changed column needs reloaded"; ok $bt->_attribute_exists('title'), "but we still have the title"; # Don't re-load $bt->add_trigger( after_update => sub { my ($self, %args) = @_; my $discard_columns = $args{discard_columns}; @$discard_columns = qw/title/; } ); $bt->rating("19"); ok $bt->_attribute_exists('rating'), "changed column needs reloaded"; ok !$bt->_attribute_exists('title'), "but no longer have the title"; } # Make sure that we can have other accessors. (Bugfix in 0.28) if (0) { Film->mk_accessors(qw/temp1 temp2/); my $blrunner = Film->retrieve('Bladerunner'); $blrunner->temp1("Foo"); $blrunner->NumExplodingSheep(2); eval { $blrunner->update }; ok(!$@, "Other accessors"); } # overloading { is "$blrunner", "Bladerunner", "stringify"; ok(Film->columns(Stringify => 'rating'), "Can change stringify column"); is "$blrunner", "R", "And still stringifies correctly"; ok( Film->columns(Stringify => qw/title rating/), "Can have multiple stringify columns" ); is "$blrunner", "Bladerunner/R", "And still stringifies correctly"; no warnings 'once'; local *Film::stringify_self = sub { join ":", $_[0]->title, $_[0]->rating }; is "$blrunner", "Bladerunner:R", "Provide stringify_self()"; } { { ok my $byebye = DeletingFilm->insert( { Title => 'Goodbye Norma Jean', Rating => 'PG', } ), "Add a deleting Film"; isa_ok $byebye, 'DeletingFilm'; isa_ok $byebye, 'Film'; ok(Film->retrieve('Goodbye Norma Jean'), "Fetch it back again"); } my $film; eval { $film = Film->retrieve('Goodbye Norma Jean') }; ok !$film, "It destroys itself"; } SKIP: { skip "Caching has been removed", 5 if Film->isa("DBIx::Class::CDBICompat::NoObjectIndex"); # my bad taste is your bad taste my $btaste = Film->retrieve('Bad Taste'); my $btaste2 = Film->retrieve('Bad Taste'); is refaddr $btaste, refaddr $btaste2, "Retrieving twice gives ref to same object"; my ($btaste5) = Film->search(title=>'Bad Taste'); is refaddr $btaste, refaddr $btaste5, "Searching also gives ref to same object"; $btaste2->remove_from_object_index; my $btaste3 = Film->retrieve('Bad Taste'); isnt refaddr $btaste2, refaddr $btaste3, "Removing from object_index and retrieving again gives new object"; $btaste3->clear_object_index; my $btaste4 = Film->retrieve('Bad Taste'); isnt refaddr $btaste2, refaddr $btaste4, "Clearing cache and retrieving again gives new object"; $btaste=Film->insert({ Title => 'Bad Taste 2', Director => 'Peter Jackson', Rating => 'R', NumExplodingSheep => 2, }); $btaste2 = Film->retrieve('Bad Taste 2'); is refaddr $btaste, refaddr $btaste2, "Creating and retrieving gives ref to same object"; } done_testing; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/multi_column_set.t�������������������������������������������������������0000644�0001750�0001750�00000000706�14240132261�020014� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib 't/cdbi/testlib'; { package Thing; use base 'DBIC::Test::SQLite'; Thing->columns(TEMP => qw[foo bar baz]); Thing->columns(All => qw[some real stuff]); } my $thing = Thing->construct({ foo => 23, some => 42, baz => 99 }); $thing->set( foo => "wibble", some => "woosh" ); is $thing->foo, "wibble"; is $thing->some, "woosh"; is $thing->baz, 99; $thing->discard_changes; done_testing; ����������������������������������������������������������DBIx-Class-0.082843/t/cdbi/sweet/�������������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�015412� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/sweet/08pager.t����������������������������������������������������������0000644�0001750�0001750�00000002735�14240132261�017033� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib 't/cdbi/testlib'; use DBIC::Test::SQLite; DBICTest::Schema::CD->load_components(qw/CDBICompat CDBICompat::Pager/); my $schema = DBICTest->init_schema(compose_connection => 1); DBICTest::CD->result_source_instance->schema->storage($schema->storage); my ( $pager, $it ) = DBICTest::CD->page( {}, { order_by => 'title', rows => 3, page => 1 } ); cmp_ok( $pager->entries_on_this_page, '==', 3, "entries_on_this_page ok" ); cmp_ok( $pager->next_page, '==', 2, "next_page ok" ); is( $it->next->title, "Caterwaulin' Blues", "iterator->next ok" ); $it->next; $it->next; is( $it->next, undef, "next past end of page ok" ); ( $pager, $it ) = DBICTest::CD->page( {}, { rows => 2, page => 2, disable_sql_paging => 1 } ); cmp_ok( $pager->total_entries, '==', 5, "disable_sql_paging total_entries ok" ); cmp_ok( $pager->previous_page, '==', 1, "disable_sql_paging previous_page ok" ); is( $it->next->title, "Caterwaulin' Blues", "disable_sql_paging iterator->next ok" ); $it->next; is( $it->next, undef, "disable_sql_paging next past end of page ok" ); # based on a failing criteria submitted by waswas ( $pager, $it ) = DBICTest::CD->page( { title => [ -and => { -like => '%bees' }, { -not_like => 'Forkful%' } ] }, { rows => 5 } ); is( $it->count, 1, "complex abstract count ok" ); done_testing; �����������������������������������DBIx-Class-0.082843/t/cdbi/16-reserved.t������������������������������������������������������������0000644�0001750�0001750�00000001016�14240132261�016470� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib 't/cdbi/testlib'; use Film; use Order; Film->has_many(orders => 'Order'); Order->has_a(film => 'Film'); Film->create_test_film; my $film = Film->retrieve('Bad Taste'); isa_ok $film => 'Film'; $film->add_to_orders({ orders => 10 }); my $bto = (Order->search(film => 'Bad Taste'))[0]; isa_ok $bto => 'Order'; is $bto->orders, 10, "Correct number of orders"; my $infilm = $bto->film; isa_ok $infilm, "Film"; is $infilm->id, $film->id, "Orders hasa Film"; done_testing; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/12-filter.t��������������������������������������������������������������0000644�0001750�0001750�00000007211�14240132261�016135� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib 't/cdbi/testlib'; use Actor; use Film; Film->has_many(actors => 'Actor'); Actor->has_a('film' => 'Film'); Actor->add_constructor(double_search => 'name = ? AND salary = ?'); my $film = Film->create({ Title => 'MY Film' }); my $film2 = Film->create({ Title => 'Another Film' }); my @act = ( Actor->create( { name => 'Actor 1', film => $film, salary => 10, } ), Actor->create( { name => 'Actor 2', film => $film, salary => 20, } ), Actor->create( { name => 'Actor 3', film => $film, salary => 30, } ), Actor->create( { name => 'Actor 4', film => $film2, salary => 50, } ), ); eval { my @actors = $film->actors(name => 'Actor 1'); is @actors, 1, "Got one actor from restricted has_many"; is $actors[0]->name, "Actor 1", "Correct name"; }; is $@, '', "No errors"; { my @actors = Actor->double_search("Actor 1", 10); is @actors, 1, "Got one actor"; is $actors[0]->name, "Actor 1", "Correct name"; } { ok my @actors = Actor->salary_between(0, 100), "Range 0 - 100"; is @actors, 4, "Got all"; } { my @actors = Actor->salary_between(100, 200); is @actors, 0, "None in Range 100 - 200"; } { ok my @actors = Actor->salary_between(0, 10), "Range 0 - 10"; is @actors, 1, "Got 1"; is $actors[0]->name, $act[0]->name, "Actor 1"; } { ok my @actors = Actor->salary_between(20, 30), "Range 20 - 20"; @actors = sort { $a->salary <=> $b->salary } @actors; is @actors, 2, "Got 2"; is $actors[0]->name, $act[1]->name, "Actor 2"; is $actors[1]->name, $act[2]->name, "and Actor 3"; } { ok my @actors = Actor->search(Film => $film), "Search by object"; is @actors, 3, "3 actors in film 1"; } #---------------------------------------------------------------------- # Iterators #---------------------------------------------------------------------- my $it_class = 'DBIx::Class::ResultSet'; sub test_normal_iterator { my $it = $film->actors; isa_ok $it, $it_class; is $it->count, 3, " - with 3 elements"; my $i = 0; while (my $film = $it->next) { is $film->name, $act[ $i++ ]->name, "Get $i"; } ok !$it->next, "No more"; is $it->first->name, $act[0]->name, "Get first"; } test_normal_iterator; { Film->has_many(actor_ids => [ Actor => 'id' ]); my $it = $film->actor_ids; isa_ok $it, $it_class; is $it->count, 3, " - with 3 elements"; my $i = 0; while (my $film_id = $it->next) { is $film_id, $act[ $i++ ]->id, "Get id $i"; } ok !$it->next, "No more"; is $it->first, $act[0]->id, "Get first"; } # make sure nothing gets clobbered; test_normal_iterator; { my @acts = $film->actors->slice(1, 2); is @acts, 2, "Slice gives 2 actor"; is $acts[0]->name, "Actor 2", "Actor 2"; is $acts[1]->name, "Actor 3", "and actor 3"; } { my @acts = $film->actors->slice(1); is @acts, 1, "Slice of 1 actor"; is $acts[0]->name, "Actor 2", "Actor 2"; } { my @acts = $film->actors->slice(2, 8); is @acts, 1, "Slice off the end"; is $acts[0]->name, "Actor 3", "Gets last actor only"; } package Class::DBI::My::Iterator; our @ISA; @ISA = ($it_class); sub slice { qw/fred barney/ } package main; Actor->iterator_class('Class::DBI::My::Iterator'); delete $film->{related_resultsets}; { my @acts = $film->actors->slice(1, 2); is @acts, 2, "Slice gives 2 results"; ok eq_set(\@acts, [qw/fred barney/]), "Fred and Barney"; ok $film->actors->delete_all, "Can delete via iterator"; is $film->actors, 0, "no actors left"; eval { $film->actors->delete_all }; is $@, '', "Deleting again does no harm"; } done_testing; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/71_column_object.t�������������������������������������������������������0000644�0001750�0001750�00000002033�14240132261�017557� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib 't/cdbi/testlib'; # Columns in CDBI could be defined as Class::DBI::Column objects rather than # or as well as with __PACKAGE__->columns(); BEGIN { eval { require Class::DBI and Class::DBI->VERSION('3.0.5') } or plan skip_all => 'The tested functionality is only available in Class::DBI >= 3.0.5' } use ColumnObject; ok(ColumnObject->can('db_Main'), 'set_db()'); is(ColumnObject->__driver, 'SQLite', 'Driver set correctly'); ColumnObject->create({ columna => 'Test Data', columnb => 'Test Data 2', }); my $column_object = ColumnObject->retrieve(columna => 'Test Data'); $column_object->columnb_as_write('Test Data Written'); $column_object->update; $column_object = ColumnObject->retrieve(columna => 'Test Data'); is($column_object->columna_as_read => 'Test Data', 'Read column via accessor'); is($column_object->columna => 'Test Data', 'Real column returns right data'); is($column_object->columnb => 'Test Data Written', 'ColumnB wrote via mutator'); done_testing; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/23-cascade.t�������������������������������������������������������������0000644�0001750�0001750�00000003445�14240132261�016242� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Data::Dumper; INIT { use lib 't/cdbi/testlib'; use Film; use Director; } { # Cascade on delete Director->has_many(nasties => 'Film'); my $dir = Director->insert({ name => "Lewis Teague", }); my $kk = $dir->add_to_nasties({ Title => 'Alligator' }); is $kk->director, $dir, "Director set OK"; is $dir->nasties, 1, "We have one nasty"; ok $dir->delete; ok !Film->retrieve("Alligator"), "has_many cascade deletes by default"; } # Two ways of saying not to cascade for my $args ({ no_cascade_delete => 1 }, { cascade => "None" }) { Director->has_many(nasties => 'Film', $args); my $dir = Director->insert({ name => "Lewis Teague", }); my $kk = $dir->add_to_nasties({ Title => 'Alligator' }); is $kk->director, $dir, "Director set OK"; is $dir->nasties, 1, "We have one nasty"; ok $dir->delete; local $Data::Dumper::Terse = 1; ok +Film->retrieve("Alligator"), 'has_many with ' . Dumper ($args);; $kk->delete; } #{ # Fail on cascade # local $TODO = 'cascade => "Fail" unimplemented'; # # Director->has_many(nasties => Film => { cascade => 'Fail' }); # # my $dir = Director->insert({ name => "Nasty Noddy" }); # my $kk = $dir->add_to_nasties({ Title => 'Killer Killers' }); # is $kk->director, $dir, "Director set OK"; # is $dir->nasties, 1, "We have one nasty"; # # ok !eval { $dir->delete }; # like $@, qr/1/, "Can't delete while films exist"; # # my $rr = $dir->add_to_nasties({ Title => 'Revenge of the Revengers' }); # ok !eval { $dir->delete }; # like $@, qr/2/, "Still can't delete"; # # $dir->nasties->delete_all; # ok eval { $dir->delete }; # is $@, '', "Can delete once films are gone"; #} done_testing; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/DeepAbstractSearch/������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�017752� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/DeepAbstractSearch/01_search.t�������������������������������������������0000644�0001750�0001750�00000022751�14240132261�021672� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib 't/cdbi/testlib'; use DBIC::Test::SQLite (); # this will issue the necessary SKIPs on missing reqs BEGIN { eval { require Class::DBI::Plugin::DeepAbstractSearch } or plan skip_all => 'Class::DBI::Plugin::DeepAbstractSearch required for this test'; } my $DB = DBICTest->_sqlite_dbname(sqlite_use_file => 1);; # not usre why this test needs an AutoCommit => 0 and a commit further # down - EDONOTCARE $ENV{DBIC_UNSAFE_AUTOCOMMIT_OK} = 1; my @DSN = ("dbi:SQLite:dbname=$DB", '', '', { AutoCommit => 0 }); package Music::DBI; use base qw(DBIx::Class::CDBICompat); use Class::DBI::Plugin::DeepAbstractSearch; __PACKAGE__->connection(@DSN); my $sql = <<'SQL_END'; --------------------------------------- -- Artists --------------------------------------- CREATE TABLE artists ( id INTEGER NOT NULL PRIMARY KEY, name VARCHAR(32) ); INSERT INTO artists VALUES (1, "Willie Nelson"); INSERT INTO artists VALUES (2, "Patsy Cline"); --------------------------------------- -- Labels --------------------------------------- CREATE TABLE labels ( id INTEGER NOT NULL PRIMARY KEY, name VARCHAR(32) ); INSERT INTO labels VALUES (1, "Columbia"); INSERT INTO labels VALUES (2, "Sony"); INSERT INTO labels VALUES (3, "Supraphon"); --------------------------------------- -- CDs --------------------------------------- CREATE TABLE cds ( id INTEGER NOT NULL PRIMARY KEY, label INTEGER, artist INTEGER, title VARCHAR(32), year INTEGER ); INSERT INTO cds VALUES (1, 1, 1, "Songs", 2005); INSERT INTO cds VALUES (2, 2, 1, "Read Headed Stanger", 2000); INSERT INTO cds VALUES (3, 1, 1, "Wanted! The Outlaws", 2004); INSERT INTO cds VALUES (4, 2, 1, "The Very Best of Willie Nelson", 1999); INSERT INTO cds VALUES (5, 1, 2, "12 Greates Hits", 1999); INSERT INTO cds VALUES (6, 2, 2, "Sweet Dreams", 1995); INSERT INTO cds VALUES (7, 3, 2, "The Best of Patsy Cline", 1991); --------------------------------------- -- Tracks --------------------------------------- CREATE TABLE tracks ( id INTEGER NOT NULL PRIMARY KEY, cd INTEGER, position INTEGER, title VARCHAR(32) ); INSERT INTO tracks VALUES (1, 1, 1, "Songs: Track 1"); INSERT INTO tracks VALUES (2, 1, 2, "Songs: Track 2"); INSERT INTO tracks VALUES (3, 1, 3, "Songs: Track 3"); INSERT INTO tracks VALUES (4, 1, 4, "Songs: Track 4"); INSERT INTO tracks VALUES (5, 2, 1, "Read Headed Stanger: Track 1"); INSERT INTO tracks VALUES (6, 2, 2, "Read Headed Stanger: Track 2"); INSERT INTO tracks VALUES (7, 2, 3, "Read Headed Stanger: Track 3"); INSERT INTO tracks VALUES (8, 2, 4, "Read Headed Stanger: Track 4"); INSERT INTO tracks VALUES (9, 3, 1, "Wanted! The Outlaws: Track 1"); INSERT INTO tracks VALUES (10, 3, 2, "Wanted! The Outlaws: Track 2"); INSERT INTO tracks VALUES (11, 4, 1, "The Very Best of Willie Nelson: Track 1"); INSERT INTO tracks VALUES (12, 4, 2, "The Very Best of Willie Nelson: Track 2"); INSERT INTO tracks VALUES (13, 4, 3, "The Very Best of Willie Nelson: Track 3"); INSERT INTO tracks VALUES (14, 4, 4, "The Very Best of Willie Nelson: Track 4"); INSERT INTO tracks VALUES (15, 4, 5, "The Very Best of Willie Nelson: Track 5"); INSERT INTO tracks VALUES (16, 4, 6, "The Very Best of Willie Nelson: Track 6"); INSERT INTO tracks VALUES (17, 5, 1, "12 Greates Hits: Track 1"); INSERT INTO tracks VALUES (18, 5, 2, "12 Greates Hits: Track 2"); INSERT INTO tracks VALUES (19, 5, 3, "12 Greates Hits: Track 3"); INSERT INTO tracks VALUES (20, 5, 4, "12 Greates Hits: Track 4"); INSERT INTO tracks VALUES (21, 6, 1, "Sweet Dreams: Track 1"); INSERT INTO tracks VALUES (22, 6, 2, "Sweet Dreams: Track 2"); INSERT INTO tracks VALUES (23, 6, 3, "Sweet Dreams: Track 3"); INSERT INTO tracks VALUES (24, 6, 4, "Sweet Dreams: Track 4"); INSERT INTO tracks VALUES (25, 7, 1, "The Best of Patsy Cline: Track 1"); INSERT INTO tracks VALUES (26, 7, 2, "The Best of Patsy Cline: Track 2"); SQL_END foreach my $statement (split /;/, $sql) { $statement =~ s/^\s*//gs; $statement =~ s/\s*$//gs; next unless $statement; Music::DBI->db_Main->do($statement) or die "$@ $!"; } Music::DBI->dbi_commit; package Music::Artist; use base 'Music::DBI'; Music::Artist->table('artists'); Music::Artist->columns(All => qw/id name/); package Music::Label; use base 'Music::DBI'; Music::Label->table('labels'); Music::Label->columns(All => qw/id name/); package Music::CD; use base 'Music::DBI'; Music::CD->table('cds'); Music::CD->columns(All => qw/id label artist title year/); package Music::Track; use base 'Music::DBI'; Music::Track->table('tracks'); Music::Track->columns(All => qw/id cd position title/); Music::Artist->has_many(cds => 'Music::CD'); Music::Label->has_many(cds => 'Music::CD'); Music::CD->has_many(tracks => 'Music::Track'); Music::CD->has_a(artist => 'Music::Artist'); Music::CD->has_a(label => 'Music::Label'); Music::Track->has_a(cd => 'Music::CD'); package main; { my $where = { }; my $attr; my @artists = Music::Artist->deep_search_where($where, $attr); is_deeply [ sort @artists ], [ 1, 2 ], "all without order"; } { my $where = { }; my $attr = { order_by => 'name' }; my @artists = Music::Artist->deep_search_where($where, $attr); is_deeply \@artists, [ 2, 1 ], "all with ORDER BY name"; } { my $where = { }; my $attr = { order_by => 'name DESC' }; my @artists = Music::Artist->deep_search_where($where, $attr); is_deeply \@artists, [ 1, 2 ], "all with ORDER BY name DESC"; } { my $where = { name => { -like => 'Patsy Cline' }, }; my $attr; my @artists = Music::Artist->deep_search_where($where, $attr); is_deeply \@artists, [ 2 ], "simple search"; } { my $where = { 'artist.name' => 'Patsy Cline' }; my $attr = { } ; my @cds = Music::CD->deep_search_where($where, $attr); is_deeply [ sort @cds ], [ 5, 6, 7 ], "Patsy's CDs"; } { my $where = { 'artist.name' => 'Patsy Cline' }; my $attr = { order_by => "title" } ; my @cds = Music::CD->deep_search_where($where, $attr); is_deeply [ @cds ], [ 5, 6, 7 ], "Patsy's CDs by title"; my $count = Music::CD->count_deep_search_where($where); is_deeply $count, 3, "count Patsy's CDs by title"; } { my $where = { 'cd.title' => { -like => 'S%' }, }; my $attr = { order_by => "cd.title, title" } ; my @cds = Music::Track->deep_search_where($where, $attr); is_deeply [ @cds ], [1, 2, 3, 4, 21, 22, 23, 24 ], "Tracks from CDs whose name starts with 'S'"; } { my $where = { 'cd.artist.name' => { -like => 'W%' }, 'cd.year' => { '>' => 2000 }, 'position' => { '<' => 3 } }; my $attr = { order_by => "cd.title DESC, title" } ; my @cds = Music::Track->deep_search_where($where, $attr); is_deeply [ @cds ], [ 9, 10, 1, 2 ], "First 2 tracks from W's albums after 2000 "; my $count = Music::Track->count_deep_search_where($where); is_deeply $count, 4, "Count First 2 tracks from W's albums after 2000"; } { my $where = { 'cd.artist.name' => { -like => 'W%' }, 'cd.year' => { '>' => 2000 }, 'position' => { '<' => 3 } }; my $attr = { order_by => [ 'cd.title DESC' , 'title' ] } ; my @cds = Music::Track->deep_search_where($where, $attr); is_deeply [ @cds ], [ 9, 10, 1, 2 ], "First 2 tracks from W's albums after 2000, array ref order "; my $count = Music::Track->count_deep_search_where($where); is_deeply $count, 4, "Count First 2 tracks from W's albums after 2000, array ref order"; } { my $where = { 'cd.title' => [ -and => { -like => '%o%' }, { -like => '%W%' } ] }; my $attr = { order_by => [ 'cd.id' ] } ; my @tracks = Music::Track->deep_search_where($where, $attr); is_deeply [ @tracks ], [ 3, 3, 4, 4, 4, 4, 4, 4 ], "Tracks from CD titles containing 'o' AND 'W'"; } { my $where = { 'cd.year' => [ 1995, 1999 ] }; my $attr = { order_by => [ 'cd.id' ] } ; my @tracks = Music::Track->deep_search_where($where, $attr); is_deeply [ @tracks ], [ 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 6, 6, 6, 6 ], "Tracks from CDs from 1995, 1999"; } { my $where = { 'cd.year' => { -in => [ 1995, 1999 ] } }; my $attr = { order_by => [ 'cd.id' ] } ; my @tracks = Music::Track->deep_search_where($where, $attr); is_deeply [ @tracks ], [ 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 6, 6, 6, 6 ], "Tracks from CDs in 1995, 1999"; } { my $where = { -and => [ 'cd.year' => [ 1995, 1999 ], position => { '<=', 2 } ] }; my $attr = { order_by => [ 'cd.id' ] } ; my @tracks = Music::Track->deep_search_where($where, $attr); is_deeply [ @tracks ], [ 4, 4, 5, 5, 6, 6 ], "First 2 tracks Tracks from CDs from 1995, 1999"; } { my $where = { -and => [ 'cd.year' => { -in => [ 1995, 1999 ] }, position => { '<=', 2 } ] }; my $attr = { order_by => [ 'cd.id' ] } ; my @tracks = Music::Track->deep_search_where($where, $attr); is_deeply [ @tracks ], [ 4, 4, 5, 5, 6, 6 ], "First 2 tracks Tracks from CDs in 1995, 1999"; } { my $where = { 'label.name' => { -in => [ 'Sony', 'Supraphon', 'Bogus' ] } }; my $attr = { order_by => [ 'id' ] } ; my @cds = Music::CD->deep_search_where($where, $attr); is_deeply [ @cds ], [ 2, 4, 6, 7 ], "CDs from Sony or Supraphon"; } { my $where = { 'label.name' => [ 'Sony', 'Supraphon', 'Bogus' ] }; my $attr = { order_by => [ 'id' ] } ; my @cds = Music::CD->deep_search_where($where, $attr); is_deeply [ @cds ], [ 2, 4, 6, 7 ], "CDs from Sony or Supraphon"; } done_testing; �����������������������DBIx-Class-0.082843/t/cdbi/set_to_undef.t�����������������������������������������������������������0000644�0001750�0001750�00000001362�14240132261�017107� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib 't/cdbi/testlib'; use DBIC::Test::SQLite (); # this will issue the necessary SKIPs on missing reqs BEGIN { eval { require DateTime; DateTime->VERSION(0.55) } or plan skip_all => 'DateTime 0.55 required for this test'; } # Don't use Test::NoWarnings because of an unrelated DBD::SQLite warning. my @warnings; local $SIG{__WARN__} = sub { push @warnings, @_; }; { package Thing; use base 'DBIC::Test::SQLite'; Thing->columns(All => qw[thing_id this that date]); } my $thing = Thing->construct({ thing_id => 23, this => 42 }); $thing->set( this => undef ); is $thing->get( "this" ), undef, 'undef set'; $thing->discard_changes; is @warnings, 0, 'no warnings'; done_testing; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/construct.t��������������������������������������������������������������0000644�0001750�0001750�00000001441�14240132261�016453� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; INIT { use lib 't/cdbi/testlib'; use Film; } { Film->insert({ Title => "Breaking the Waves", Director => 'Lars von Trier', Rating => 'R' }); my $film = Film->construct({ Title => "Breaking the Waves", Director => 'Lars von Trier', }); isa_ok $film, "Film"; is $film->title, "Breaking the Waves"; is $film->director, "Lars von Trier"; is $film->rating, "R", "constructed objects can get missing data from the db"; } { package Foo; use base qw(Film); Foo->columns( TEMP => qw(temp_thing) ); my $film = Foo->construct({ temp_thing => 23 }); ::is $film->temp_thing, 23, "construct sets temp columns"; } done_testing; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/98-failure.t�������������������������������������������������������������0000644�0001750�0001750�00000002771�14240132261�016323� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; #---------------------------------------------------------------------- # Test database failures #---------------------------------------------------------------------- use lib 't/cdbi/testlib'; use Film; Film->create_test_film; { my $btaste = Film->retrieve('Bad Taste'); isa_ok $btaste, 'Film', "We have Bad Taste"; { no warnings 'redefine'; local *DBIx::ContextualFetch::st::execute = sub { die "Database died" }; eval { $btaste->delete }; ::like $@, qr/Database died/s, "We failed"; } my $still = Film->retrieve('Bad Taste'); isa_ok $btaste, 'Film', "We still have Bad Taste"; } { my $btaste = Film->retrieve('Bad Taste'); isa_ok $btaste, 'Film', "We have Bad Taste"; $btaste->numexplodingsheep(10); { no warnings 'redefine'; local *DBIx::ContextualFetch::st::execute = sub { die "Database died" }; eval { $btaste->update }; ::like $@, qr/Database died/s, "We failed"; } $btaste->discard_changes; my $still = Film->retrieve('Bad Taste'); isa_ok $btaste, 'Film', "We still have Bad Taste"; is $btaste->numexplodingsheep, 1, "with 1 sheep"; } if (0) { my $sheep = Film->maximum_value_of('numexplodingsheep'); is $sheep, 1, "1 exploding sheep"; { local *DBIx::ContextualFetch::st::execute = sub { die "Database died" }; my $sheep = eval { Film->maximum_value_of('numexplodingsheep') }; ::like $@, qr/select.*Database died/s, "Handle database death in single value select"; } } done_testing; �������DBIx-Class-0.082843/t/cdbi/04-lazy.t����������������������������������������������������������������0000644�0001750�0001750�00000010556�14240132261�015636� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Warn; #---------------------------------------------------------------------- # Test lazy loading #---------------------------------------------------------------------- INIT { use lib 't/cdbi/testlib'; use Lazy; } is_deeply [ Lazy->columns('Primary') ], [qw/this/], "Pri"; is_deeply [ sort Lazy->columns('Essential') ], [qw/opop this/], "Essential"; is_deeply [ sort Lazy->columns('things') ], [qw/that this/], "things"; is_deeply [ sort Lazy->columns('horizon') ], [qw/eep orp/], "horizon"; is_deeply [ sort Lazy->columns('vertical') ], [qw/oop opop/], "vertical"; is_deeply [ sort Lazy->columns('All') ], [qw/eep oop opop orp that this/], "All"; { my @groups = Lazy->__grouper->groups_for(Lazy->find_column('this')); is_deeply [ sort @groups ], [sort qw/things Essential Primary/], "this (@groups)"; } { my @groups = Lazy->__grouper->groups_for(Lazy->find_column('that')); is_deeply \@groups, [qw/things/], "that (@groups)"; } Lazy->create({ this => 1, that => 2, oop => 3, opop => 4, eep => 5 }); ok(my $obj = Lazy->retrieve(1), 'Retrieve by Primary'); ok($obj->_attribute_exists('this'), "Gets primary"); ok($obj->_attribute_exists('opop'), "Gets other essential"); ok(!$obj->_attribute_exists('that'), "But other things"); ok(!$obj->_attribute_exists('eep'), " nor eep"); ok(!$obj->_attribute_exists('orp'), " nor orp"); ok(!$obj->_attribute_exists('oop'), " nor oop"); ok(my $val = $obj->eep, 'Fetch eep'); ok($obj->_attribute_exists('orp'), 'Gets orp too'); ok(!$obj->_attribute_exists('oop'), 'But still not oop'); ok(!$obj->_attribute_exists('that'), 'nor that'); { Lazy->columns(All => qw/this that eep orp oop opop/); ok(my $obj = Lazy->retrieve(1), 'Retrieve by Primary'); ok !$obj->_attribute_exists('oop'), " Don't have oop"; my $null = $obj->eep; ok !$obj->_attribute_exists('oop'), " Don't have oop - even after getting eep"; } # Test contructor breaking. eval { # Need a hashref Lazy->create(this => 10, that => 20, oop => 30, opop => 40, eep => 50); }; ok($@, $@); eval { # False column Lazy->create({ this => 10, that => 20, theother => 30 }); }; ok($@, $@); eval { # Multiple false columns Lazy->create({ this => 10, that => 20, theother => 30, andanother => 40 }); }; ok($@, $@); warning_like { Lazy->columns( TEMP => qw(that) ); } qr/Declaring column that as TEMP but it already exists/; # Test that create() and update() throws out columns that changed { my $l = Lazy->create({ this => 99, that => 2, oop => 3, opop => 4, }); ok $l->db_Main->do(qq{ UPDATE @{[ $l->table ]} SET oop = ? WHERE this = ? }, undef, 87, $l->this); is $l->oop, 87; $l->oop(32); $l->update; ok $l->db_Main->do(qq{ UPDATE @{[ $l->table ]} SET oop = ? WHERE this = ? }, undef, 23, $l->this); is $l->oop, 23; $l->delete; } # Now again for inflated values SKIP: { skip "Requires Date::Simple 3.03", 5 unless eval "use Date::Simple 3.03; 1; "; Lazy->has_a( orp => 'Date::Simple', inflate => sub { Date::Simple->new($_[0] . '-01-01') }, deflate => 'format' ); my $l = Lazy->create({ this => 89, that => 2, orp => 1998, }); ok $l->db_Main->do(qq{ UPDATE @{[ $l->table ]} SET orp = ? WHERE this = ? }, undef, 1987, $l->this); is $l->orp, '1987-01-01'; $l->orp(2007); is $l->orp, '2007-01-01'; # make sure it's inflated $l->update; ok $l->db_Main->do(qq{ UPDATE @{[ $l->table ]} SET orp = ? WHERE this = ? }, undef, 1942, $l->this); is $l->orp, '1942-01-01'; $l->delete; } # Test that a deleted object works { Lazy->search()->delete_all; my $l = Lazy->create({ this => 99, that => 2, oop => 3, opop => 4, }); # Delete the object without it knowing. Lazy->db_Main->do(qq[ DELETE FROM @{[ Lazy->table ]} WHERE this = 99 ]); $l->eep; # The problem was when an object had an inflated object # loaded. _flesh() would set _column_data to undef and # get_column() would think nothing was there. # I'm too lazy to set up the proper inflation test. ok !exists $l->{_column_data}{orp}; } done_testing; ��������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/copy.t�������������������������������������������������������������������0000644�0001750�0001750�00000001652�14240132261�015405� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; INIT { use lib 't/cdbi/testlib'; } { package # hide from PAUSE MyFilm; use base 'DBIC::Test::SQLite'; use strict; __PACKAGE__->set_table('Movies'); __PACKAGE__->columns(All => qw(id title)); # Disables the implicit autoinc-on-non-supplied-pk behavior # (and the warning that goes with it) # This is the same behavior as it was pre 0.082900 __PACKAGE__->column_info('id')->{is_auto_increment} = 0; sub create_sql { return qq{ id INTEGER PRIMARY KEY AUTOINCREMENT, title VARCHAR(255) } } } my $film = MyFilm->create({ title => "For Your Eyes Only" }); ok $film->id; my $new_film = $film->copy; ok $new_film->id; isnt $new_film->id, $film->id, "copy() gets new primary key"; $new_film = $film->copy(42); is $new_film->id, 42, "copy() with new id"; done_testing; ��������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/08-inheritcols.t���������������������������������������������������������0000644�0001750�0001750�00000001060�14240132261�017174� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib 't/cdbi/testlib'; use DBIC::Test::SQLite; package A; @A::ISA = qw(DBIx::Class::CDBICompat); __PACKAGE__->columns(Primary => 'id'); package A::B; @A::B::ISA = 'A'; __PACKAGE__->columns(All => qw(id b1)); package A::C; @A::C::ISA = 'A'; __PACKAGE__->columns(All => qw(id c1 c2 c3)); package main; is join (' ', sort A->columns), 'id', "A columns"; is join (' ', sort A::B->columns), 'b1 id', "A::B columns"; is join (' ', sort A::C->columns), 'c1 c2 c3 id', "A::C columns"; done_testing; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/09-has_many.t������������������������������������������������������������0000644�0001750�0001750�00000006130�14240132261�016454� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib 't/cdbi/testlib'; use Film; use Actor; Actor->has_a(Film => 'Film'); Film->has_many(actors => 'Actor', { order_by => 'name' }); is(Actor->primary_column, 'id', "Actor primary OK"); ok(Actor->can('Salary'), "Actor table set-up OK"); ok(Film->can('actors'), " and have a suitable method in Film"); Film->create_test_film; ok(my $btaste = Film->retrieve('Bad Taste'), "We have Bad Taste"); ok( my $pvj = Actor->create( { Name => 'Peter Vere-Jones', Film => undef, Salary => '30_000', # For a voice! } ), 'create Actor' ); is $pvj->Name, "Peter Vere-Jones", "PVJ name ok"; is $pvj->Film, undef, "No film"; ok $pvj->set_Film($btaste), "Set film"; $pvj->update; is $pvj->Film->id, $btaste->id, "Now film"; { my @actors = $btaste->actors; is(@actors, 1, "Bad taste has one actor"); is($actors[0]->Name, $pvj->Name, " - the correct one"); } my %pj_data = ( Name => 'Peter Jackson', Salary => '0', # it's a labour of love ); eval { my $pj = Film->add_to_actors(\%pj_data) }; like $@, qr/class/, "add_to_actors must be object method"; eval { my $pj = $btaste->add_to_actors(%pj_data) }; like $@, qr/Result object instantiation requires a hashref as argument/, "add_to_actors takes hash"; ok( my $pj = $btaste->add_to_actors( { Name => 'Peter Jackson', Salary => '0', # it's a labour of love } ), 'add_to_actors' ); is $pj->Name, "Peter Jackson", "PJ ok"; is $pvj->Name, "Peter Vere-Jones", "PVJ still ok"; { my @actors = $btaste->actors; is @actors, 2, " - so now we have 2"; is $actors[0]->Name, $pj->Name, "PJ first"; is $actors[1]->Name, $pvj->Name, "PVJ first"; } eval { my @actors = $btaste->actors(Name => $pj->Name); is @actors, 1, "One actor from restricted (sorted) has_many"; is $actors[0]->Name, $pj->Name, "It's PJ"; }; is $@, '', "No errors"; my $as = Actor->create( { Name => 'Arnold Schwarzenegger', Film => 'Terminator 2', Salary => '15_000_000' } ); eval { $btaste->actors($pj, $pvj, $as) }; ok $@, $@; is($btaste->actors, 2, " - so we still only have 2 actors"); my @bta_before = Actor->search(Film => 'Bad Taste'); is(@bta_before, 2, "We have 2 actors in bad taste"); ok($btaste->delete, "Delete bad taste"); my @bta_after = Actor->search(Film => 'Bad Taste'); is(@bta_after, 0, " - after deleting there are no actors"); # While we're here, make sure Actors have unreadable mutators and # unwritable accessors eval { $as->Name("Paul Reubens") }; ok $@, $@; eval { my $name = $as->set_Name }; ok $@, $@; is($as->Name, 'Arnold Schwarzenegger', "Arnie's still Arnie"); # Test infering of the foreign key of a has_many from an existing has_a { use Thing; use OtherThing; Thing->has_a(that_thing => "OtherThing"); OtherThing->has_many(things => "Thing"); my $other_thing = OtherThing->create({ id => 1 }); Thing->create({ id => 1, that_thing => $other_thing }); Thing->create({ id => 2, that_thing => $other_thing }); is_deeply [sort map { $_->id } $other_thing->things], [1,2]; } done_testing; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/03-subclassing.t���������������������������������������������������������0000644�0001750�0001750�00000001273�14240132261�017167� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; #---------------------------------------------------------------------- # Make sure subclasses can be themselves subclassed #---------------------------------------------------------------------- use lib 't/cdbi/testlib'; use Film; INIT { @Film::Threat::ISA = qw/Film/; } ok(Film::Threat->db_Main->ping, 'subclass db_Main()'); is_deeply [ sort Film::Threat->columns ], [ sort Film->columns ], 'has the same columns'; my $bt = Film->create_test_film; ok my $btaste = Film::Threat->retrieve('Bad Taste'), "subclass retrieve"; isa_ok $btaste => "Film::Threat"; isa_ok $btaste => "Film"; is $btaste->Title, 'Bad Taste', 'subclass get()'; done_testing; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/30-pager.t���������������������������������������������������������������0000644�0001750�0001750�00000001545�14240132261�015752� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib 't/cdbi/testlib'; use Film; my @film = ( Film->create({ Title => 'Film 1' }), Film->create({ Title => 'Film 2' }), Film->create({ Title => 'Film 3' }), Film->create({ Title => 'Film 4' }), Film->create({ Title => 'Film 5' }), ); # first page my ( $pager, $it ) = Film->page( {}, { rows => 3, page => 1 } ); is( $pager->entries_on_this_page, 3, "entries_on_this_page ok" ); is( $pager->next_page, 2, "next_page ok" ); is( $it->next->title, "Film 1", "iterator->next ok" ); $it->next; $it->next; is( $it->next, undef, "next past end of page ok" ); # second page ( $pager, $it ) = Film->page( {}, { rows => 3, page => 2 } ); is( $pager->entries_on_this_page, 2, "entries on second page ok" ); is( $it->next->title, "Film 4", "second page first title ok" ); done_testing; �����������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/hasa_without_loading.t���������������������������������������������������0000644�0001750�0001750�00000000717�14240132261�020630� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib 't/cdbi/testlib'; use DBIC::Test::SQLite (); # this will issue the necessary SKIPs on missing reqs package Foo; use base qw(DBIx::Class::CDBICompat); eval { Foo->table("foo"); Foo->columns(Essential => qw(foo bar)); #Foo->has_a( bar => "This::Does::Not::Exist::Yet" ); }; #::is $@, ''; ::is(Foo->table, "foo"); ::is_deeply [sort map lc, Foo->columns], [sort map lc, qw(foo bar)]; ::done_testing; �������������������������������������������������DBIx-Class-0.082843/t/cdbi/early_column_heisenbug.t�������������������������������������������������0000644�0001750�0001750�00000001051�14240132261�021146� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib 't/cdbi/testlib'; use DBIC::Test::SQLite (); # this will issue the necessary SKIPs on missing reqs { package Thing; use base qw(DBIx::Class::CDBICompat); } { package Stuff; use base qw(DBIx::Class::CDBICompat); } # There was a bug where looking at a column group before any were # set would cause them to be shared across classes. is_deeply [Stuff->columns("Essential")], []; Thing->columns(Essential => qw(foo bar baz)); is_deeply [Stuff->columns("Essential")], []; done_testing; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/13-constraint.t����������������������������������������������������������0000644�0001750�0001750�00000006256�14240132261�017045� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib 't/cdbi/testlib'; use Film; sub valid_rating { my $value = shift; my $ok = grep $value eq $_, qw/U Uc PG 12 15 18/; return $ok; } Film->add_constraint('valid rating', Rating => \&valid_rating); my %info = ( Title => 'La Double Vie De Veronique', Director => 'Kryzstof Kieslowski', Rating => '18', ); { local $info{Title} = "nonsense"; local $info{Rating} = 19; eval { Film->create({%info}) }; ok $@, $@; ok !Film->retrieve($info{Title}), "No film created"; is(Film->retrieve_all, 0, "So no films"); } ok(my $ver = Film->create({%info}), "Can create with valid rating"); is $ver->Rating, 18, "Rating 18"; ok $ver->Rating(12), "Change to 12"; ok $ver->update, "And update"; is $ver->Rating, 12, "Rating now 12"; eval { $ver->Rating(13); $ver->update; }; ok $@, $@; is $ver->Rating, 12, "Rating still 12"; ok $ver->delete, "Delete"; # this threw an infinite loop in old versions Film->add_constraint('valid director', Director => sub { 1 }); my $fred = Film->create({ Rating => '12' }); # this test is a bit problematical because we don't supply a primary key # to the create() and the table doesn't use auto_increment or a sequence. ok $fred, "Got fred"; { ok +Film->constrain_column(rating => [qw/U PG 12 15 19/]), "constraint_column"; my $narrower = eval { Film->create({ Rating => 'Uc' }) }; like $@, qr/fails.*constraint/, "Fails listref constraint"; my $ok = eval { Film->create({ Rating => 'U' }) }; is $@, '', "Can create with rating U"; SKIP: { skip "No column objects", 2; ok +Film->find_column('rating')->is_constrained, "Rating is constrained"; ok +Film->find_column('director')->is_constrained, "Director is not"; } } { ok +Film->constrain_column(title => qr/The/), "constraint_column"; my $inferno = eval { Film->create({ Title => 'Towering Infero' }) }; like $@, qr/fails.*constraint/, "Can't create towering inferno"; my $the_inferno = eval { Film->create({ Title => 'The Towering Infero' }) }; is $@, '', "But can create THE towering inferno"; } { sub Film::_constrain_by_untaint { my ($class, $col, $string, $type) = @_; $class->add_constraint( untaint => $col => sub { my ($value, $self, $column_name, $changing) = @_; $value eq "today" ? $changing->{$column_name} = "2001-03-03" : 0; } ); } eval { Film->constrain_column(codirector => Untaint => 'date') }; is $@, '', 'Can constrain with untaint'; my $freeaa = eval { Film->create({ title => "The Freaa", codirector => 'today' }) }; is $@, '', "Can create codirector"; is $freeaa && $freeaa->codirector, '2001-03-03', "Set the codirector"; } done_testing; __DATA__ use CGI::Untaint; sub _constrain_by_untaint { my ($class, $col, $string, $type) = @_; $class->add_constraint(untaint => $col => sub { my ($value, $self, $column_name, $changing) = @_; my $h = CGI::Untaint->new({ %$changing }); return unless my $val = $h->extract("-as_$type" => $column_name); $changing->{$column_name} = $val; return 1; }); } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/19-set_sql.t�������������������������������������������������������������0000644�0001750�0001750�00000005654�14240132261�016342� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib 't/cdbi/testlib'; use Film; use Actor; { # Check __ESSENTIAL__ expansion (RT#13038) my @cols = Film->columns('Essential'); is_deeply \@cols, ['title'], "1 Column in essential"; is +Film->transform_sql('__ESSENTIAL__'), 'title', '__ESSENTIAL__ expansion'; # This provides a more interesting test Film->columns(Essential => qw(title rating)); is +Film->transform_sql('__ESSENTIAL__'), 'title, rating', 'multi-col __ESSENTIAL__ expansion'; } my $f1 = Film->create({ title => 'A', director => 'AA', rating => 'PG' }); my $f2 = Film->create({ title => 'B', director => 'BA', rating => 'PG' }); my $f3 = Film->create({ title => 'C', director => 'AA', rating => '15' }); my $f4 = Film->create({ title => 'D', director => 'BA', rating => '18' }); my $f5 = Film->create({ title => 'E', director => 'AA', rating => '18' }); Film->set_sql( pgs => qq{ SELECT __ESSENTIAL__ FROM __TABLE__ WHERE __TABLE__.rating = 'PG' ORDER BY title DESC } ); { (my $sth = Film->sql_pgs())->execute; my @pgs = Film->sth_to_objects($sth); is @pgs, 2, "Execute our own SQL"; is $pgs[0]->id, $f2->id, "get F2"; is $pgs[1]->id, $f1->id, "and F1"; } { my @pgs = Film->search_pgs; is @pgs, 2, "SQL creates search() method"; is $pgs[0]->id, $f2->id, "get F2"; is $pgs[1]->id, $f1->id, "and F1"; }; Film->set_sql( rating => qq{ SELECT __ESSENTIAL__ FROM __TABLE__ WHERE rating = ? ORDER BY title DESC } ); { my @pgs = Film->search_rating('18'); is @pgs, 2, "Can pass parameters to created search()"; is $pgs[0]->id, $f5->id, "F5"; is $pgs[1]->id, $f4->id, "and F4"; }; { Film->set_sql( by_id => qq{ SELECT __ESSENTIAL__ FROM __TABLE__ WHERE __IDENTIFIER__ } ); my $film = Film->retrieve_all->first; my @found = Film->search_by_id($film->id); is @found, 1; is $found[0]->id, $film->id; } { Actor->has_a(film => "Film"); Film->set_sql( namerate => qq{ SELECT __ESSENTIAL(f)__ FROM __TABLE(=f)__, __TABLE(Actor=a)__ WHERE __JOIN(a f)__ AND a.name LIKE ? AND f.rating = ? ORDER BY title } ); my $a1 = Actor->create({ name => "A1", film => $f1 }); my $a2 = Actor->create({ name => "A2", film => $f2 }); my $a3 = Actor->create({ name => "B1", film => $f1 }); my @apg = Film->search_namerate("A_", "PG"); is @apg, 2, "2 Films with A* that are PG"; is $apg[0]->title, "A", "A"; is $apg[1]->title, "B", "and B"; } { # join in reverse Actor->has_a(film => "Film"); Film->set_sql( ratename => qq{ SELECT __ESSENTIAL(f)__ FROM __TABLE(=f)__, __TABLE(Actor=a)__ WHERE __JOIN(f a)__ AND f.rating = ? AND a.name LIKE ? ORDER BY title } ); my @apg = Film->search_ratename(PG => "A_"); is @apg, 2, "2 Films with A* that are PG"; is $apg[0]->title, "A", "A"; is $apg[1]->title, "B", "and B"; } done_testing; ������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/70_implicit_inflate.t����������������������������������������������������0000644�0001750�0001750�00000002076�14240132261�020256� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; # Class::DBI in its infinate wisdom allows implicit inflation # and deflation of foriegn clas looups in has_a relationships. # for inflate it would call ->new on the foreign_class and for # deflate it would "" the column value and allow for overloading # of the "" operator. use Test::More; use DBIx::Class::Optional::Dependencies; BEGIN { plan skip_all => "Test needs ".DBIx::Class::Optional::Dependencies->req_missing_for('test_dt_sqlite') unless DBIx::Class::Optional::Dependencies->req_ok_for('test_dt_sqlite'); } use lib 't/cdbi/testlib'; use ImplicitInflate; ok(ImplicitInflate->can('db_Main'), 'set_db()'); is(ImplicitInflate->__driver, "SQLite", 'Driver set correctly'); my $now = DateTime->now; ImplicitInflate->create({ update_datetime => $now, text => "Test Data", }); my $implicit_inflate = ImplicitInflate->retrieve(text => 'Test Data'); ok($implicit_inflate->update_datetime->isa('DateTime'), 'Date column inflated correctly'); is($implicit_inflate->update_datetime => $now, 'Date has correct year'); done_testing; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/set_vs_DateTime.t��������������������������������������������������������0000644�0001750�0001750�00000001173�14240132261�017510� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use lib 't/cdbi/testlib'; use DBIC::Test::SQLite (); # this will issue the necessary SKIPs on missing reqs BEGIN { eval { require DateTime; DateTime->VERSION(0.55) } or plan skip_all => 'DateTime 0.55 required for this test'; } { package Thing; use base 'DBIC::Test::SQLite'; Thing->columns(All => qw[thing_id this that date]); } my $thing = Thing->construct({ thing_id => 23, date => "01-02-1994" }); my $date = DateTime->now; lives_ok { $thing->set( date => $date ); $thing->set( date => $date ); }; $thing->discard_changes; done_testing; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/68-inflate_has_a.t�������������������������������������������������������0000644�0001750�0001750�00000002733�14240132261�017444� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/cdbi/testlib); use DBIC::Test::SQLite (); # this will issue the necessary SKIPs on missing reqs BEGIN { eval { require DateTime; DateTime->VERSION(0.55) } or plan skip_all => 'DateTime 0.55 required for this test'; } my $schema = DBICTest->init_schema(); DBICTest::Schema::CD->load_components(qw/CDBICompat::Relationships/); DBICTest::Schema::CD->has_a( 'year', 'DateTime', inflate => sub { DateTime->new( year => shift ) }, deflate => sub { shift->year } ); Class::C3->reinitialize if DBIx::Class::_ENV_::OLD_MRO; # inflation test my $cd = $schema->resultset("CD")->find(3); is( ref($cd->year), 'DateTime', 'year is a DateTime, ok' ); is( $cd->year->month, 1, 'inflated month ok' ); # deflate test my $now = DateTime->now; $cd->year( $now ); $cd->update; ($cd) = $schema->resultset("CD")->search({ year => $now->year }); is( $cd->year->year, $now->year, 'deflate ok' ); # re-test using alternate deflate syntax $schema->class("CD")->has_a( 'year', 'DateTime', inflate => sub { DateTime->new( year => shift ) }, deflate => 'year' ); # inflation test $cd = $schema->resultset("CD")->find(3); is( ref($cd->year), 'DateTime', 'year is a DateTime, ok' ); is( $cd->year->month, 1, 'inflated month ok' ); # deflate test $now = DateTime->now; $cd->year( $now ); $cd->update; ($cd) = $schema->resultset("CD")->search({ year => $now->year }); is( $cd->year->year, $now->year, 'deflate ok' ); done_testing; �������������������������������������DBIx-Class-0.082843/t/cdbi/abstract/����������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�016066� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/abstract/search_where.t��������������������������������������������������0000644�0001750�0001750�00000003520�14240132261�020671� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use Test::More; use strict; use warnings; INIT { use lib 't/cdbi/testlib'; use Film; } Film->create({ Title => $_, Rating => "PG" }) for ("Superman", "Super Fuzz"); Film->create({ Title => "Batman", Rating => "PG13" }); my $superman = Film->search_where( Title => "Superman" ); is $superman->next->Title, "Superman", "search_where() as iterator"; is $superman->next, undef; { my @supers = Film->search_where({ title => { 'like' => 'Super%' } }); is_deeply [sort map $_->Title, @supers], [sort ("Super Fuzz", "Superman")], 'like'; } my @all = Film->search_where({}, { order_by => "Title ASC" }); is_deeply ["Batman", "Super Fuzz", "Superman"], [map $_->Title, @all], "order_by ASC"; @all = Film->search_where({}, { order_by => "Title DESC" }); is_deeply ["Superman", "Super Fuzz", "Batman"], [map $_->Title, @all], "order_by DESC"; @all = Film->search_where({ Rating => "PG" }, { limit => 1, order_by => "Title ASC" }); is_deeply ["Super Fuzz"], [map $_->Title, @all], "where, limit"; @all = Film->search_where({}, { limit => 2, order_by => "Title ASC" }); is_deeply ["Batman", "Super Fuzz"], [map $_->Title, @all], "limit"; @all = Film->search_where({}, { offset => 1, order_by => "Title ASC" }); is_deeply ["Super Fuzz", "Superman"], [map $_->Title, @all], "offset"; @all = Film->search_where({}, { limit => 1, offset => 1, order_by => "Title ASC" }); is_deeply ["Super Fuzz"], [map $_->Title, @all], "limit + offset"; @all = Film->search_where({}, { limit => 2, offset => 1, limit_dialect => "Top", order_by => "Title ASC" }); is_deeply ["Super Fuzz", "Superman"], [map $_->Title, @all], "limit_dialect ignored"; done_testing; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/columns_as_hashes.t������������������������������������������������������0000644�0001750�0001750�00000004443�14240132261�020132� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Warn; use lib 't/cdbi/testlib'; use Film; my $waves = Film->insert({ Title => "Breaking the Waves", Director => 'Lars von Trier', Rating => 'R' }); local $ENV{DBIC_CDBICOMPAT_HASH_WARN} = 0; { local $ENV{DBIC_CDBICOMPAT_HASH_WARN} = 1; warnings_like { my $rating = $waves->{rating}; $waves->Rating("PG"); is $rating, "R", 'evaluation of column value is not deferred'; } qr{^Column 'rating' of 'Film/$waves' was fetched as a hash at\b}; warnings_like { is $waves->{title}, $waves->Title, "columns can be accessed as hashes"; } qr{^Column 'title' of 'Film/$waves' was fetched as a hash at\b}; $waves->Rating("G"); warnings_like { is $waves->{rating}, "G", "updating via the accessor updates the hash"; } qr{^Column 'rating' of 'Film/$waves' was fetched as a hash at\b}; warnings_like { $waves->{rating} = "PG"; } qr{^Column 'rating' of 'Film/$waves' was stored as a hash at\b}; $waves->update; my @films = Film->search( Rating => "PG", Title => "Breaking the Waves" ); is @films, 1, "column updated as hash was saved"; } warning_is { $waves->{rating} } '', 'DBIC_CDBICOMPAT_HASH_WARN controls warnings'; { $waves->rating("R"); $waves->update; no warnings 'redefine'; local *Film::rating = sub { return "wibble"; }; is $waves->{rating}, "R"; } { no warnings 'redefine'; no warnings 'once'; local *Actor::accessor_name_for = sub { my($class, $col) = @_; return "movie" if lc $col eq "film"; return $col; }; require Actor; Actor->has_a( film => "Film" ); my $actor = Actor->insert({ name => 'Emily Watson', film => $waves, }); ok !eval { $actor->film }; is $actor->{film}->id, $waves->id, 'hash access still works despite lack of accessor'; } # Emulate that Class::DBI inflates immediately SKIP: { unless (eval { require MyFoo }) { my ($err) = $@ =~ /([^\n]+)/; skip $err, 3 } my $foo = MyFoo->insert({ name => 'Whatever', tdate => '1949-02-01', }); isa_ok $foo, 'MyFoo'; isa_ok $foo->{tdate}, 'Date::Simple'; is $foo->{tdate}->year, 1949; } done_testing; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/21-iterator.t������������������������������������������������������������0000644�0001750�0001750�00000005055�14240132261�016505� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib 't/cdbi/testlib'; use Film; my $it_class = "DBIx::Class::ResultSet"; my @film = ( Film->create({ Title => 'Film 1' }), Film->create({ Title => 'Film 2' }), Film->create({ Title => 'Film 3' }), Film->create({ Title => 'Film 4' }), Film->create({ Title => 'Film 5' }), Film->create({ Title => 'Film 6' }), ); { my $it1 = Film->retrieve_all; isa_ok $it1, $it_class; my $it2 = Film->retrieve_all; isa_ok $it2, $it_class; while (my $from1 = $it1->next) { my $from2 = $it2->next; is $from1->id, $from2->id, "Both iterators get $from1"; } } { my $it = Film->retrieve_all; is $it->first->title, "Film 1", "Film 1 first"; is $it->next->title, "Film 2", "Film 2 next"; is $it->first->title, "Film 1", "First goes back to 1"; is $it->next->title, "Film 2", "With 2 still next"; $it->reset; is $it->next->title, "Film 1", "Reset brings us to film 1 again"; is $it->next->title, "Film 2", "And 2 is still next"; } { my $it = Film->retrieve_all; my @slice = $it->slice(2,4); is @slice, 3, "correct slice size (array)"; is $slice[0]->title, "Film 3", "Film 3 first"; is $slice[2]->title, "Film 5", "Film 5 last"; } { my $it = Film->retrieve_all; my $slice = $it->slice(2,4); isa_ok $slice, $it_class, "slice as iterator"; is $slice->count, 3,"correct slice size (array)"; is $slice->first->title, "Film 3", "Film 3 first"; is $slice->next->title, "Film 4", "Film 4 next"; is $slice->first->title, "Film 3", "First goes back to 3"; is $slice->next->title, "Film 4", "With 4 still next"; $slice->reset; is $slice->next->title, "Film 3", "Reset brings us to film 3 again"; is $slice->next->title, "Film 4", "And 4 is still next"; # check if the original iterator still works is $it->count, 6, "back to the original iterator, is of right size"; is $it->first->title, "Film 1", "Film 1 first"; is $it->next->title, "Film 2", "Film 2 next"; is $it->first->title, "Film 1", "First goes back to 1"; is $it->next->title, "Film 2", "With 2 still next"; is $it->next->title, "Film 3", "Film 3 is still in original Iterator"; $it->reset; is $it->next->title, "Film 1", "Reset brings us to film 1 again"; is $it->next->title, "Film 2", "And 2 is still next"; } { my $it = Film->retrieve_all; is $it, $it->count, "iterator returns count as a scalar"; ok $it, "iterator returns true when there are results"; } { my $it = Film->search( Title => "something which does not exist" ); is $it, 0; ok !$it, "iterator returns false when no results"; } done_testing; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/object_cache.t�����������������������������������������������������������0000644�0001750�0001750�00000003012�14240132261�017014� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; $| = 1; INIT { use lib 't/cdbi/testlib'; use Film; } plan skip_all => "Object cache is turned off" if Film->isa("DBIx::Class::CDBICompat::NoObjectIndex"); plan tests => 5; ok +Film->create({ Title => 'This Is Spinal Tap', Director => 'Rob Reiner', Rating => 'R', }); { my $film1 = Film->retrieve( "This Is Spinal Tap" ); my $film2 = Film->retrieve( "This Is Spinal Tap" ); $film1->Director("Marty DiBergi"); is $film2->Director, "Marty DiBergi", 'retrieve returns the same object'; $film1->discard_changes; } { Film->nocache(1); my $film1 = Film->retrieve( "This Is Spinal Tap" ); my $film2 = Film->retrieve( "This Is Spinal Tap" ); $film1->Director("Marty DiBergi"); is $film2->Director, "Rob Reiner", 'caching turned off'; $film1->discard_changes; } { Film->nocache(0); my $film1 = Film->retrieve( "This Is Spinal Tap" ); my $film2 = Film->retrieve( "This Is Spinal Tap" ); $film1->Director("Marty DiBergi"); is $film2->Director, "Marty DiBergi", 'caching back on'; $film1->discard_changes; } { Film->nocache(1); local $Class::DBI::Weaken_Is_Available = 0; my $film1 = Film->retrieve( "This Is Spinal Tap" ); my $film2 = Film->retrieve( "This Is Spinal Tap" ); $film1->Director("Marty DiBergi"); is $film2->Director, "Rob Reiner", 'CDBI::Weaken_Is_Available turns off all caching'; $film1->discard_changes; } done_testing; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/has_many_loads_foreign_class.t�������������������������������������������0000644�0001750�0001750�00000001350�14240132261�022305� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Class::Inspector (); use lib 't/cdbi/testlib'; use Director; # Test that has_many() will load the foreign class. ok !Class::Inspector->loaded( 'Film' ); ok eval { Director->has_many( films => 'Film' ); 1; } || diag $@; my $shan_hua = Director->create({ Name => "Shan Hua", }); my $inframan = Film->create({ Title => "Inframan", Director => "Shan Hua", }); my $guillotine2 = Film->create({ Title => "Flying Guillotine 2", Director => "Shan Hua", }); my $guillotine = Film->create({ Title => "Master of the Flying Guillotine", Director => "Yu Wang", }); is_deeply [sort $shan_hua->films], [sort $inframan, $guillotine2]; done_testing; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/14-might_have.t����������������������������������������������������������0000644�0001750�0001750�00000003646�14240132261�016775� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib 't/cdbi/testlib'; use Film; use Blurb; is(Blurb->primary_column, "title", "Primary key of Blurb = title"); is_deeply [ Blurb->columns('Essential') ], [ Blurb->primary_column ], "Essential = Primary"; eval { Blurb->retrieve(10) }; is $@, "", "No problem retrieving non-existent Blurb"; Film->might_have(info => Blurb => qw/blurb/); Film->create_test_film; { ok my $bt = Film->retrieve('Bad Taste'), "Get Film"; isa_ok $bt, "Film"; is $bt->info, undef, "No blurb yet"; # bug where we couldn't write a class with a might_have that didn't_have $bt->rating(16); eval { $bt->update }; is $@, '', "No problems updating when don't have"; is $bt->rating, 16, "Updated OK"; is $bt->blurb, undef, "Bad taste has no blurb"; $bt->blurb("Wibble bar"); $bt->update; is $bt->blurb, "Wibble bar", "And we can write the info"; } { my $bt = Film->retrieve('Bad Taste'); my $info = $bt->info; isa_ok $info, 'Blurb'; is $bt->blurb, $info->blurb, "Blurb is the same as fetching the long way"; ok $bt->blurb("New blurb"), "We can set the blurb"; $bt->update; is $bt->blurb, $info->blurb, "Blurb has been set"; $bt->rating(18); eval { $bt->update }; is $@, '', "No problems updating when do have"; is $bt->rating, 18, "Updated OK"; # cascade delete? { my $blurb = Blurb->retrieve('Bad Taste'); isa_ok $blurb => "Blurb"; $bt->delete; $blurb = Blurb->retrieve('Bad Taste'); is $blurb, undef, "Blurb has gone"; } } { my $host = Film->create({ title => "Gwoemul" }); $host->blurb("Monsters are real."); my $info = $host->info; is $info->blurb, "Monsters are real."; $host->discard_changes; is $host->info->id, $info->id, 'relationships still valid after discard_changes'; ok $host->info->delete; $host->discard_changes; ok !$host->info, 'relationships rechecked after discard_changes'; } done_testing; ������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/26-mutator.t�������������������������������������������������������������0000644�0001750�0001750�00000001133�14240132261�016345� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib 't/cdbi/testlib'; require Film; sub Film::accessor_name_for { my ($class, $col) = @_; return "sheep" if lc $col eq "numexplodingsheep"; return $col; } my $data = { Title => 'Bad Taste', Director => 'Peter Jackson', Rating => 'R', }; my $bt; eval { my $data = $data; $data->{sheep} = 1; ok $bt = Film->insert($data), "Modified accessor - with accessor"; isa_ok $bt, "Film"; }; is $@, '', "No errors"; eval { ok $bt->sheep(2), 'Modified accessor, set'; ok $bt->update, 'Update'; }; is $@, '', "No errors"; done_testing; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/retrieve_from_sql_with_limit.t�������������������������������������������0000644�0001750�0001750�00000000767�14240132261�022421� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; INIT { use lib 't/cdbi/testlib'; use Film; } for my $title ("Bad Taste", "Braindead", "Forgotten Silver") { Film->insert({ Title => $title, Director => 'Peter Jackson' }); } Film->insert({ Title => "Transformers", Director => "Michael Bay"}); { my @films = Film->retrieve_from_sql(qq[director = "Peter Jackson" LIMIT 2]); is @films, 2, "retrieve_from_sql with LIMIT"; is( $_->director, "Peter Jackson" ) for @films; } done_testing; ���������DBIx-Class-0.082843/t/cdbi/22-self_referential.t����������������������������������������������������0000644�0001750�0001750�00000000734�14240132261�020165� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib 't/cdbi/testlib'; use Actor; use ActorAlias; Actor->has_many( aliases => [ 'ActorAlias' => 'alias' ] ); my $first = Actor->create( { Name => 'First' } ); my $second = Actor->create( { Name => 'Second' } ); ActorAlias->create( { actor => $first, alias => $second } ); my @aliases = $first->aliases; is( scalar @aliases, 1, 'proper number of aliases' ); is( $aliases[ 0 ]->name, 'Second', 'proper alias' ); done_testing; ������������������������������������DBIx-Class-0.082843/t/cdbi/columns_dont_override_custom_accessors.t���������������������������������0000644�0001750�0001750�00000001306�14240132261�024471� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib 't/cdbi/testlib'; { package Thing; use base 'DBIC::Test::SQLite'; Thing->columns(TEMP => qw[foo bar]); Thing->columns(All => qw[thing_id yarrow flower]); sub foo { 42 } sub yarrow { "hock" } } is_deeply( [sort Thing->columns("TEMP")], [sort qw(foo bar)], "TEMP columns set" ); my $thing = Thing->construct( { thing_id => 23, foo => "this", bar => "that" } ); is( $thing->id, 23 ); is( $thing->yarrow, "hock", 'custom accessor not overwritten by column' ); is( $thing->foo, 42, 'custom routine not overwritten by temp column' ); is( $thing->bar, "that", 'temp column accessor generated' ); done_testing; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/max_min_value_of.t�������������������������������������������������������0000644�0001750�0001750�00000001030�14240132261�017731� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; #---------------------------------------------------------------------- # Test database failures #---------------------------------------------------------------------- use lib 't/cdbi/testlib'; use Film; Film->create({ title => "Bad Taste", numexplodingsheep => 10, }); Film->create({ title => "Evil Alien Conquerers", numexplodingsheep => 2, }); is( Film->maximum_value_of("numexplodingsheep"), 10 ); is( Film->minimum_value_of("numexplodingsheep"), 2 ); done_testing; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/06-hasa.t����������������������������������������������������������������0000644�0001750�0001750�00000007604�14240132261�015575� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use DBIx::Class::_Util 'sigwarn_silencer'; @YA::Film::ISA = 'Film'; #local $SIG{__WARN__} = sub { }; INIT { use lib 't/cdbi/testlib'; use Film; use Director; } Film->create_test_film; ok(my $btaste = Film->retrieve('Bad Taste'), "We have Bad Taste"); ok(my $pj = $btaste->Director, "Bad taste has_a() director"); ok(!ref($pj), ' ... which is not an object'); ok(Film->has_a('Director' => 'Director'), "Link Director table"); ok( Director->create( { Name => 'Peter Jackson', Birthday => -300000000, IsInsane => 1 } ), 'create Director' ); $btaste = Film->retrieve('Bad Taste'); ok($pj = $btaste->Director, "Bad taste now has_a() director"); isa_ok($pj => 'Director'); is($pj->id, 'Peter Jackson', ' ... and is the correct director'); # Oh no! Its Peter Jacksons even twin, Skippy! Born one minute after him. my $sj = Director->create( { Name => 'Skippy Jackson', Birthday => (-300000000 + 60), IsInsane => 1, } ); is($sj->id, 'Skippy Jackson', 'We have a new director'); Film->has_a(CoDirector => 'Director'); $btaste->CoDirector($sj); $btaste->update; is($btaste->CoDirector->Name, 'Skippy Jackson', 'He co-directed'); is( $btaste->Director->Name, 'Peter Jackson', "Didnt interfere with each other" ); { # Ensure search can take an object my @films = Film->search(Director => $pj); is @films, 1, "1 Film directed by $pj"; is $films[0]->id, "Bad Taste", "Bad Taste"; } inheriting_hasa(); { # Skippy directs a film and Peter helps! $sj = Director->retrieve('Skippy Jackson'); $pj = Director->retrieve('Peter Jackson'); fail_with_bad_object($sj, $btaste); taste_bad($sj, $pj); } sub inheriting_hasa { my $btaste = YA::Film->retrieve('Bad Taste'); is(ref($btaste->Director), 'Director', 'inheriting has_a()'); is(ref($btaste->CoDirector), 'Director', 'inheriting has_a()'); is($btaste->CoDirector->Name, 'Skippy Jackson', ' ... correctly'); } sub taste_bad { my ($dir, $codir) = @_; my $tastes_bad = YA::Film->create( { Title => 'Tastes Bad', Director => $dir, CoDirector => $codir, Rating => 'R', NumExplodingSheep => 23 } ); is($tastes_bad->_Director_accessor, 'Skippy Jackson', 'Director_accessor'); is($tastes_bad->Director->Name, 'Skippy Jackson', 'Director'); is($tastes_bad->CoDirector->Name, 'Peter Jackson', 'CoDirector'); is( $tastes_bad->_CoDirector_accessor, 'Peter Jackson', 'CoDirector_accessor' ); } sub fail_with_bad_object { my ($dir, $codir) = @_; throws_ok { local $SIG{__WARN__} = sigwarn_silencer( qr/\Qusually should inherit from the related ResultClass ('Director')/ ); YA::Film->create( { Title => 'Tastes Bad', Director => $dir, CoDirector => $codir, Rating => 'R', NumExplodingSheep => 23 } ); } qr/isn't a Director/; } package Foo; use base 'CDBase'; __PACKAGE__->table('foo'); __PACKAGE__->columns('All' => qw/ id fav /); # fav is a film __PACKAGE__->db_Main->do( qq{ CREATE TABLE foo ( id INTEGER, fav VARCHAR(255) ) }); package Bar; use base 'CDBase'; __PACKAGE__->table('bar'); __PACKAGE__->columns('All' => qw/ id fav /); # fav is a foo __PACKAGE__->db_Main->do( qq{ CREATE TABLE bar ( id INTEGER, fav INTEGER ) }); package main; Foo->has_a("fav" => "Film"); Bar->has_a("fav" => "Foo"); my $foo = Foo->create({ id => 6, fav => 'Bad Taste' }); my $bar = Bar->create({ id => 2, fav => 6 }); isa_ok($bar->fav, "Foo"); isa_ok($foo->fav, "Film"); { my $foo; Foo->add_trigger(after_create => sub { $foo = shift->fav }); my $gwh = Foo->create({ id => 93, fav => 'Good Will Hunting' }); isa_ok $foo, "Film", "Object in after_create trigger"; } done_testing; ����������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/01-columns.t�������������������������������������������������������������0000644�0001750�0001750�00000010444�14240132261�016330� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib 't/cdbi/testlib'; #----------------------------------------------------------------------- # Make sure that we can set up columns properly #----------------------------------------------------------------------- package State; use base 'DBIC::Test::SQLite'; State->table('State'); State->columns(Essential => qw/Abbreviation Name/); State->columns(Primary => 'Name'); State->columns(Weather => qw/Rain Snowfall/); State->columns(Other => qw/Capital Population/); #State->has_many(cities => "City"); sub accessor_name_for { my ($class, $column) = @_; my $return = $column eq "Rain" ? "Rainfall" : $column; return $return; } sub mutator_name_for { my ($class, $column) = @_; my $return = $column eq "Rain" ? "set_Rainfall" : "set_$column"; return $return; } sub Snowfall { 1 } package City; use base 'DBIC::Test::SQLite'; City->table('City'); City->columns(All => qw/Name State Population/); { # Disable the `no such table' warning local $SIG{__WARN__} = sub { my $warning = shift; warn $warning unless ($warning =~ /\Qno such table: City(1)\E/); }; City->has_a(State => 'State'); } #------------------------------------------------------------------------- package CD; use base 'DBIC::Test::SQLite'; CD->table('CD'); CD->columns('All' => qw/artist title length/); #------------------------------------------------------------------------- package main; is(State->table, 'State', 'State table()'); is(State->primary_column, 'name', 'State primary()'); is_deeply [ State->columns('Primary') ] => [qw/name/], 'State Primary:' . join ", ", State->columns('Primary'); is_deeply [ sort State->columns('Essential') ] => [qw/abbreviation name/], 'State Essential:' . join ", ", State->columns('Essential'); is_deeply [ sort State->columns('All') ] => [ sort qw/name abbreviation rain snowfall capital population/ ], 'State All:' . join ", ", State->columns('All'); is(CD->primary_column, 'artist', 'CD primary()'); is_deeply [ CD->columns('Primary') ] => [qw/artist/], 'CD primary:' . join ", ", CD->columns('Primary'); is_deeply [ sort CD->columns('All') ] => [qw/artist length title/], 'CD all:' . join ", ", CD->columns('All'); is_deeply [ sort CD->columns('Essential') ] => [qw/artist/], 'CD essential:' . join ", ", CD->columns('Essential'); ok(State->find_column('Rain'), 'find_column Rain'); ok(State->find_column('rain'), 'find_column rain'); ok(!State->find_column('HGLAGAGlAG'), '!find_column HGLAGAGlAG'); { can_ok +State => qw/Rainfall _Rainfall_accessor set_Rainfall _set_Rainfall_accessor Snowfall _Snowfall_accessor set_Snowfall _set_Snowfall_accessor/; foreach my $method (qw/Rain _Rain_accessor rain snowfall/) { ok !State->can($method), "State can't $method"; } } { SKIP: { skip "No column objects", 1; eval { my @grps = State->__grouper->groups_for("Huh"); }; ok $@, "Huh not in groups"; } my @grps = sort State->__grouper->groups_for(State->_find_columns(qw/rain capital/)); is @grps, 2, "Rain and Capital = 2 groups"; @grps = sort @grps; # Because the underlying API is hash-based is $grps[0], 'Other', " - Other"; is $grps[1], 'Weather', " - Weather"; } #{ # # package DieTest; # @DieTest::ISA = qw(DBIx::Class); # DieTest->load_components(qw/CDBICompat::Retrieve Core/); # package main; # local $SIG{__WARN__} = sub { }; # eval { DieTest->retrieve(1) }; # like $@, qr/unless primary columns are defined/, "Need primary key for retrieve"; #} #----------------------------------------------------------------------- # Make sure that columns inherit properly #----------------------------------------------------------------------- package State; package A; @A::ISA = qw(DBIx::Class); __PACKAGE__->load_components(qw/CDBICompat Core/); __PACKAGE__->table('dummy'); __PACKAGE__->columns(Primary => 'id'); package A::B; @A::B::ISA = 'A'; __PACKAGE__->table('dummy2'); __PACKAGE__->columns(All => qw(id b1)); package A::C; @A::C::ISA = 'A'; __PACKAGE__->table('dummy3'); __PACKAGE__->columns(All => qw(id c1 c2 c3)); package main; is join (' ', sort A->columns), 'id', "A columns"; is join (' ', sort A::B->columns), 'b1 id', "A::B columns"; is join (' ', sort A::C->columns), 'c1 c2 c3 id', "A::C columns"; done_testing; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/11-triggers.t������������������������������������������������������������0000644�0001750�0001750�00000003121�14240132261�016471� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib 't/cdbi/testlib'; use Film; sub create_trigger2 { ::ok(1, "Running create trigger 2"); } sub delete_trigger { ::ok(1, "Deleting " . shift->Title) } sub pre_up_trigger { $_[0]->_attribute_set(numexplodingsheep => 1); ::ok(1, "Running pre-update trigger"); } sub pst_up_trigger { ::ok(1, "Running post-update trigger"); } sub default_rating { $_[0]->Rating(15); } Film->add_trigger(before_create => \&default_rating); Film->add_trigger(after_create => \&create_trigger2); Film->add_trigger(after_delete => \&delete_trigger); Film->add_trigger(before_update => \&pre_up_trigger); Film->add_trigger(after_update => \&pst_up_trigger); ok( my $ver = Film->create({ title => 'La Double Vie De Veronique', director => 'Kryzstof Kieslowski', # rating => '15', numexplodingsheep => 0, } ), "Create Veronique" ); is $ver->Rating, 15, "Default rating"; is $ver->NumExplodingSheep, 0, "Original sheep count"; ok $ver->Rating('12') && $ver->update, "Change the rating"; is $ver->NumExplodingSheep, 1, "Updated object's sheep count"; is + ( $ver->db_Main->selectall_arrayref( 'SELECT numexplodingsheep FROM ' . $ver->table . ' WHERE ' . $ver->primary_column . ' = ' . $ver->db_Main->quote($ver->id)) )->[0]->[0], 1, "Updated database's sheep count"; ok $ver->delete, "Delete"; { Film->add_trigger(before_create => sub { my $self = shift; ok !$self->_attribute_exists('title'), "PK doesn't auto-vivify"; }); Film->create({director => "Me"}); } done_testing; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/15-accessor.t������������������������������������������������������������0000644�0001750�0001750�00000016452�14240132261�016464� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; INIT { #local $SIG{__WARN__} = #sub { like $_[0], qr/clashes with built-in method/, $_[0] }; use lib 't/cdbi/testlib'; require Film; require Actor; require Director; Actor->has_a(film => 'Film'); Film->has_a(director => 'Director'); sub Class::DBI::sheep { ok 0; } } # Install the deprecation warning intercept here for the rest of the 08 dev cycle local $SIG{__WARN__} = sub { warn @_ unless (DBIx::Class->VERSION < 0.09 and $_[0] =~ /Query returned more than one row/); }; sub Film::mutator_name { my ($class, $col) = @_; return "set_sheep" if lc $col eq "numexplodingsheep"; return $col; } sub Film::accessor_name { my ($class, $col) = @_; return "sheep" if lc $col eq "numexplodingsheep"; return $col; } sub Actor::accessor_name_for { my ($class, $col) = @_; return "movie" if lc $col eq "film"; return $col; } # This is a class with accessor_name_for() but no corresponding mutator_name_for() sub Director::accessor_name_for { my($class, $col) = @_; return "nutty_as_a_fruitcake" if lc $col eq "isinsane"; return $col; } my $data = { Title => 'Bad Taste', Director => 'Peter Jackson', Rating => 'R', }; eval { my $data = { %$data }; $data->{NumExplodingSheep} = 1; ok my $bt = Film->create($data), "Modified accessor - with column name"; isa_ok $bt, "Film"; is $bt->sheep, 1, 'sheep bursting violently'; }; is $@, '', "No errors"; eval { my $data = { %$data }; $data->{sheep} = 2; ok my $bt = Film->create($data), "Modified accessor - with accessor"; isa_ok $bt, "Film"; is $bt->sheep, 2, 'sheep bursting violently'; }; is $@, '', "No errors"; eval { my $data = { %$data }; $data->{NumExplodingSheep} = 1; ok my $bt = Film->find_or_create($data), "find_or_create Modified accessor - find with column name"; isa_ok $bt, "Film"; is $bt->sheep, 1, 'sheep bursting violently'; }; is $@, '', "No errors"; eval { my $data = { %$data }; $data->{sheep} = 1; ok my $bt = Film->find_or_create($data), "find_or_create Modified accessor - find with accessor"; isa_ok $bt, "Film"; is $bt->sheep, 1, 'sheep bursting violently'; }; is $@, '', "No errors"; eval { my $data = { %$data }; $data->{NumExplodingSheep} = 3; ok my $bt = Film->find_or_create($data), "find_or_create Modified accessor - create with column name"; isa_ok $bt, "Film"; local $TODO = 'TODOifying failing tests, waiting for Schwern'; is $bt->sheep, 3, 'sheep bursting violently'; }; is $@, '', "No errors"; eval { my $data = { %$data }; $data->{sheep} = 4; ok my $bt = Film->find_or_create($data), "find_or_create Modified accessor - create with accessor"; isa_ok $bt, "Film"; local $TODO = 'TODOifying failing tests, waiting for Schwern'; is $bt->sheep, 4, 'sheep bursting violently'; }; is $@, '', "No errors"; eval { my @film = Film->search({ sheep => 1 }); is @film, 2, "Can search with modified accessor"; }; { local $TODO = 'TODOifying failing tests, waiting for Schwern'; is $@, '', "No errors"; } { eval { local $data->{set_sheep} = 1; ok my $bt = Film->create($data), "Modified mutator - with mutator"; isa_ok $bt, "Film"; }; is $@, '', "No errors"; eval { local $data->{NumExplodingSheep} = 1; ok my $bt = Film->create($data), "Modified mutator - with column name"; isa_ok $bt, "Film"; }; is $@, '', "No errors"; eval { local $data->{sheep} = 1; ok my $bt = Film->create($data), "Modified mutator - with accessor"; isa_ok $bt, "Film"; }; is $@, '', "No errors"; } { my $p_data = { name => 'Peter Jackson', film => 'Bad Taste', }; my $bt = Film->create($data); my $ac = Actor->create($p_data); ok !eval { my $f = $ac->film; 1 }; like $@, qr/film/, "no hasa film"; eval { ok my $f = $ac->movie, "hasa movie"; isa_ok $f, "Film"; is $f->id, $bt->id, " - Bad Taste"; }; is $@, '', "No errors"; { local $data->{Title} = "Another film"; my $film = Film->create($data); eval { $ac->film($film) }; ok $@, $@; eval { $ac->movie($film) }; ok $@, $@; eval { ok $ac->set_film($film), "Set movie through hasa"; $ac->update; ok my $f = $ac->movie, "hasa movie"; isa_ok $f, "Film"; is $f->id, $film->id, " - Another Film"; }; is $@, '', "No problem"; } } # Make sure a class with an accessor_name() method has a similar mutator. { my $aki = Director->create({ name => "Aki Kaurismaki", }); $aki->nutty_as_a_fruitcake(1); is $aki->nutty_as_a_fruitcake, 1, "a custom accessor without a custom mutator is setable"; $aki->update; } { Film->columns(TEMP => qw/nonpersistent/); ok(Film->find_column('nonpersistent'), "nonpersistent is a column"); ok(!Film->has_real_column('nonpersistent'), " - but it's not real"); { my $film = Film->create({ Title => "Veronique", nonpersistent => 42 }); is $film->title, "Veronique", "Title set OK"; is $film->nonpersistent, 42, "As is non persistent value"; $film->remove_from_object_index; ok $film = Film->retrieve('Veronique'), "Re-retrieve film"; is $film->title, "Veronique", "Title still OK"; is $film->nonpersistent, undef, "Non persistent value gone"; ok $film->nonpersistent(40), "Can set it"; is $film->nonpersistent, 40, "And it's there again"; ok $film->update, "Commit the film"; is $film->nonpersistent, 40, "And it's still there"; } } { is_deeply( [Actor->columns('Essential')], [Actor->columns('Primary')], "Actor has no specific essential columns" ); ok(Actor->find_column('nonpersistent'), "nonpersistent is a column"); ok(!Actor->has_real_column('nonpersistent'), " - but it's not real"); my $pj = eval { Actor->search(name => "Peter Jackson")->first }; is $@, '', "no problems retrieving actors"; isa_ok $pj => "Actor"; } { Film->autoupdate(1); my $naked = Film->create({ title => 'Naked' }); my $sandl = Film->create({ title => 'Secrets and Lies' }); my $rating = 1; my $update_failure = sub { my $obj = shift; eval { $obj->rating($rating++) }; return $@ =~ /read only/; }; ok !$update_failure->($naked), "Can update Naked"; ok $naked->make_read_only, "Make Naked read only"; ok $update_failure->($naked), "Can't update Naked any more"; ok !$update_failure->($sandl), "But can still update Secrets and Lies"; my $july4 = eval { Film->create({ title => "4 Days in July" }) }; isa_ok $july4 => "Film", "And can still create new films"; ok(Film->make_read_only, "Make all Films read only"); ok $update_failure->($naked), "Still can't update Naked"; ok $update_failure->($sandl), "And can't update S&L any more"; eval { $july4->delete }; like $@, qr/read only/, "And can't delete 4 Days in July"; my $abigail = eval { Film->create({ title => "Abigail's Party" }) }; like $@, qr/read only/, "Or create new films"; $_->discard_changes for ($naked, $sandl); } done_testing; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/cdbi/18-has_a.t���������������������������������������������������������������0000644�0001750�0001750�00000014305�14240132261�015733� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use DBIx::Class::_Util 'sigwarn_silencer'; use lib 't/cdbi/testlib'; use Film; use Director; @YA::Film::ISA = 'Film'; Film->create_test_film; ok my $btaste = Film->retrieve('Bad Taste'), "We have Bad Taste"; ok my $pj = $btaste->Director, "Bad taste has a director"; ok !ref($pj), ' ... which is not an object'; ok(Film->has_a('Director' => 'Director'), "Link Director table"); ok( Director->create({ Name => 'Peter Jackson', Birthday => -300000000, IsInsane => 1 } ), 'create Director' ); { ok $btaste = Film->retrieve('Bad Taste'), "Reretrieve Bad Taste"; ok $pj = $btaste->Director, "Bad taste now hasa() director"; isa_ok $pj => 'Director'; { no warnings qw(redefine once); local *Ima::DBI::st::execute = sub { ::fail("Shouldn't need to query db"); }; is $pj->id, 'Peter Jackson', 'ID already stored'; } ok $pj->IsInsane, "But we know he's insane"; } # Oh no! Its Peter Jacksons even twin, Skippy! Born one minute after him. my $sj = Director->create({ Name => 'Skippy Jackson', Birthday => (-300000000 + 60), IsInsane => 1, }); { throws_ok { $btaste->Director($btaste) } qr/isn't a Director/, "Can't set film as director"; is $btaste->Director->id, $pj->id, "PJ still the director"; # drop from cache so that next retrieve() is from db $btaste->remove_from_object_index; } { # Still inflated after update my $btaste = Film->retrieve('Bad Taste'); isa_ok $btaste->Director, "Director"; $btaste->numexplodingsheep(17); $btaste->update; isa_ok $btaste->Director, "Director"; $btaste->Director('Someone Else'); $btaste->update; isa_ok $btaste->Director, "Director"; is $btaste->Director->id, "Someone Else", "Can change director"; } is $sj->id, 'Skippy Jackson', 'Create new director - Skippy'; Film->has_a('CoDirector' => 'Director'); { lives_ok { $btaste->CoDirector("Skippy Jackson") }; isa_ok $btaste->CoDirector, "Director"; is $btaste->CoDirector->id, $sj->id, "To skippy"; } $btaste->CoDirector($sj); $btaste->update; is($btaste->CoDirector->Name, 'Skippy Jackson', 'He co-directed'); is( $btaste->Director->Name, 'Peter Jackson', "Didnt interfere with each other" ); { # Inheriting hasa my $btaste = YA::Film->retrieve('Bad Taste'); is(ref($btaste->Director), 'Director', 'inheriting hasa()'); is(ref($btaste->CoDirector), 'Director', 'inheriting hasa()'); is($btaste->CoDirector->Name, 'Skippy Jackson', ' ... correctly'); } { $sj = Director->retrieve('Skippy Jackson'); $pj = Director->retrieve('Peter Jackson'); my $fail; throws_ok { local $SIG{__WARN__} = sigwarn_silencer( qr/\Qusually should inherit from the related ResultClass ('Director')/ ); $fail = YA::Film->create({ Title => 'Tastes Bad', Director => $sj, codirector => $btaste, Rating => 'R', NumExplodingSheep => 23 }); } qr/isn't a Director/, "Can't have film as codirector"; is $fail, undef, "We didn't get anything"; my $tastes_bad = YA::Film->create({ Title => 'Tastes Bad', Director => $sj, codirector => $pj, Rating => 'R', NumExplodingSheep => 23 }); is($tastes_bad->Director->Name, 'Skippy Jackson', 'Director'); is( $tastes_bad->_director_accessor->Name, 'Skippy Jackson', 'director_accessor' ); is($tastes_bad->codirector->Name, 'Peter Jackson', 'codirector'); is( $tastes_bad->_codirector_accessor->Name, 'Peter Jackson', 'codirector_accessor' ); } SKIP: { skip "Non-standard CDBI relationships not supported by compat", 9; { YA::Film->add_relationship_type(has_a => "YA::HasA"); package YA::HasA; #use base 'Class::DBI::Relationship::HasA'; sub _inflator { my $self = shift; my $col = $self->accessor; my $super = $self->SUPER::_inflator($col); return $super unless $col eq $self->class->find_column('Director'); return sub { my $self = shift; $self->_attribute_store($col, 'Ghostly Peter') if $self->_attribute_exists($col) and not defined $self->_attrs($col); return &$super($self); }; } } { package Rating; sub new { my ($class, $mpaa, @details) = @_; bless { MPAA => $mpaa, WHY => "@details" }, $class; } sub mpaa { shift->{MPAA}; } sub why { shift->{WHY}; } } local *Director::mapme = sub { my ($class, $val) = @_; $val =~ s/Skippy/Peter/; $val; }; no warnings 'once'; local *Director::sanity_check = sub { $_[0]->IsInsane ? undef: $_[0] }; YA::Film->has_a( director => 'Director', inflate => 'mapme', deflate => 'sanity_check' ); YA::Film->has_a( rating => 'Rating', inflate => sub { my ($val, $parent) = @_; my $sheep = $parent->find_column('NumexplodingSheep'); if ($parent->_attrs($sheep) || 0 > 20) { return new Rating 'NC17', 'Graphic ovine violence'; } else { return new Rating $val, 'Just because'; } }, deflate => sub { shift->mpaa; }); my $tbad = YA::Film->retrieve('Tastes Bad'); isa_ok $tbad->Director, 'Director'; is $tbad->Director->Name, 'Peter Jackson', 'Director shuffle'; $tbad->Director('Skippy Jackson'); $tbad->update; is $tbad->Director, 'Ghostly Peter', 'Sanity checked'; isa_ok $tbad->Rating, 'Rating'; is $tbad->Rating->mpaa, 'NC17', 'Rating bumped'; $tbad->Rating(new Rating 'NS17', 'Shaken sheep'); no warnings 'redefine'; local *Director::mapme = sub { my ($class, $obj) = @_; $obj->isa('Film') ? $obj->Director : $obj; }; $pj->IsInsane(0); $pj->update; # Hush warnings ok $tbad->Director($btaste), 'Cross-class mapping'; is $tbad->Director, 'Peter Jackson', 'Yields PJ'; $tbad->update; $tbad = Film->retrieve('Tastes Bad'); ok !ref($tbad->Rating), 'Unmagical rating'; is $tbad->Rating, 'NS17', 'but prior change stuck'; } { # Broken has_a declaration throws_ok{ Film->has_a(driector => "Director") } qr/No such column driector/, "Sensible error from has_a with incorrect column" ; } done_testing; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/count/������������������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�014512� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/count/in_subquery.t�����������������������������������������������������������0000644�0001750�0001750�00000000755�14240132261�017232� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); { my $rs = $schema->resultset("CD")->search( { 'artist.name' => 'Caterwauler McCrae' }, { join => [qw/artist/]} ); my $squery = $rs->get_column('cdid')->as_query; my $subsel_rs = $schema->resultset("CD")->search( { cdid => { IN => $squery } } ); is($subsel_rs->count, $rs->count, 'Subselect on PK got the same row count'); } done_testing; �������������������DBIx-Class-0.082843/t/count/group_by_func.t���������������������������������������������������������0000644�0001750�0001750�00000001305�14240132261�017516� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); my $rs = $schema->resultset ('CD')->search ({}, { select => [ { substr => [ 'title', 1, 1 ], -as => 'initial' }, { count => '*' }, ], as => [qw/title_initial cnt/], group_by => ['initial'], order_by => { -desc => 'initial' }, result_class => 'DBIx::Class::ResultClass::HashRefInflator', }); is_deeply ( [$rs->all], [ { title_initial => 'S', cnt => '1' }, { title_initial => 'G', cnt => '1' }, { title_initial => 'F', cnt => '1' }, { title_initial => 'C', cnt => '2' }, ], 'Correct result', ); is ($rs->count, 4, 'Correct count'); done_testing; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/count/search_related.t��������������������������������������������������������0000644�0001750�0001750�00000002257�14240132261�017631� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); my $cd_rs = $schema->resultset('CD')->search ({}, { rows => 1, order_by => 'cdid' }); my $track_count = $cd_rs->first->tracks->count; cmp_ok ($track_count, '>', 1, 'First CD has several tracks'); is ($cd_rs->search_related ('tracks')->count, $track_count, 'related->count returns correct number chained off a limited rs'); is (scalar ($cd_rs->search_related ('tracks')->all), $track_count, 'related->all returns correct number of objects chained off a limited rs'); my $joined_cd_rs = $cd_rs->search ({}, { join => 'tracks', rows => 2, distinct => 1, having => \ 'count(tracks.trackid) > 2', }); my $multiple_track_count = $schema->resultset('Track')->search ({ cd => { -in => $joined_cd_rs->get_column ('cdid')->as_query } })->count; is ( $joined_cd_rs->search_related ('tracks')->count, $multiple_track_count, 'related->count returns correct number chained off a grouped rs', ); is ( scalar ($joined_cd_rs->search_related ('tracks')->all), $multiple_track_count, 'related->all returns correct number of objects chained off a grouped rs', ); done_testing; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/count/count_rs.t��������������������������������������������������������������0000644�0001750�0001750�00000011665�14240132261�016523� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use lib qw(t/lib); use Test::More; use DBICTest ':DiffSQL'; my ($ROWS, $OFFSET) = ( DBIx::Class::SQLMaker::ClassicExtensions->__rows_bindtype, DBIx::Class::SQLMaker::ClassicExtensions->__offset_bindtype, ); my $schema = DBICTest->init_schema(); # non-collapsing prefetch (no multi prefetches) { my $rs = $schema->resultset("CD") ->search_related('tracks', { position => [1,2] }, { prefetch => [qw/disc lyrics/], rows => 3, offset => 8 }, ); my @wherebind = ( [ { sqlt_datatype => 'int', dbic_colname => 'position' } => 1 ], [ { sqlt_datatype => 'int', dbic_colname => 'position' } => 2 ], ); is ($rs->all, 2, 'Correct number of objects'); $schema->is_executed_sql_bind( sub { is ($rs->count, 2, 'Correct count via count()'); }, [[ 'SELECT COUNT( * ) FROM cd me JOIN track tracks ON tracks.cd = me.cdid JOIN cd disc ON disc.cdid = tracks.cd WHERE ( ( position = ? OR position = ? ) ) ', @wherebind ]], 'count softlimit applied'); my $crs = $rs->count_rs; is ($crs->next, 2, 'Correct count via count_rs()'); is_same_sql_bind ( $crs->as_query, '(SELECT COUNT( * ) FROM ( SELECT tracks.trackid FROM cd me JOIN track tracks ON tracks.cd = me.cdid JOIN cd disc ON disc.cdid = tracks.cd WHERE ( ( position = ? OR position = ? ) ) LIMIT ? OFFSET ? ) tracks )', [ @wherebind, [$ROWS => 3], [$OFFSET => 8] ], 'count_rs db-side limit applied', ); } # has_many prefetch with limit { my $rs = $schema->resultset("Artist") ->search_related('cds', { 'tracks.position' => [1,2] }, { prefetch => [qw/tracks artist/], rows => 3, offset => 4 }, ); my @wherebind = ( [ { sqlt_datatype => 'int', dbic_colname => 'tracks.position' } => 1 ], [ { sqlt_datatype => 'int', dbic_colname => 'tracks.position' } => 2 ], ); is ($rs->all, 1, 'Correct number of objects'); $schema->is_executed_sql_bind( sub { is ($rs->count, 1, 'Correct count via count()'); }, [ [ 'SELECT COUNT( * ) FROM ( SELECT cds.cdid FROM artist me JOIN cd cds ON cds.artist = me.artistid LEFT JOIN track tracks ON tracks.cd = cds.cdid JOIN artist artist ON artist.artistid = cds.artist WHERE tracks.position = ? OR tracks.position = ? GROUP BY cds.cdid ) cds ', @wherebind ]], 'count softlimit applied' ); my $crs = $rs->count_rs; is ($crs->next, 1, 'Correct count via count_rs()'); is_same_sql_bind ( $crs->as_query, '(SELECT COUNT( * ) FROM ( SELECT cds.cdid FROM artist me JOIN cd cds ON cds.artist = me.artistid LEFT JOIN track tracks ON tracks.cd = cds.cdid JOIN artist artist ON artist.artistid = cds.artist WHERE tracks.position = ? OR tracks.position = ? GROUP BY cds.cdid LIMIT ? OFFSET ? ) cds )', [ @wherebind, [$ROWS => 3], [$OFFSET => 4], ], 'count_rs db-side limit applied', ); } # count with a having clause { my $rs = $schema->resultset("Artist")->search( {}, { join => 'cds', group_by => 'me.artistid', '+select' => [ { max => 'cds.year', -as => 'newest_cd_year' } ], '+as' => ['newest_cd_year'], having => { 'newest_cd_year' => '2001' } } ); my $crs = $rs->count_rs; is_same_sql_bind ( $crs->as_query, '(SELECT COUNT( * ) FROM ( SELECT me.artistid, MAX( cds.year ) AS newest_cd_year FROM artist me LEFT JOIN cd cds ON cds.artist = me.artistid GROUP BY me.artistid HAVING newest_cd_year = ? ) me )', [ [ { dbic_colname => 'newest_cd_year' } => '2001' ] ], 'count with having clause keeps sql as alias', ); is ($crs->next, 2, 'Correct artist count (each with one 2001 cd)'); } # count with two having clauses { my $rs = $schema->resultset("Artist")->search( {}, { join => 'cds', group_by => 'me.artistid', '+select' => [ { max => 'cds.year', -as => 'newest_cd_year' } ], '+as' => ['newest_cd_year'], having => { 'newest_cd_year' => [ '1998', '2001' ] } } ); my $crs = $rs->count_rs; is_same_sql_bind ( $crs->as_query, '(SELECT COUNT( * ) FROM ( SELECT me.artistid, MAX( cds.year ) AS newest_cd_year FROM artist me LEFT JOIN cd cds ON cds.artist = me.artistid GROUP BY me.artistid HAVING newest_cd_year = ? OR newest_cd_year = ? ) me )', [ [ { dbic_colname => 'newest_cd_year' } => '1998' ], [ { dbic_colname => 'newest_cd_year' } => '2001' ], ], 'count with having clause keeps sql as alias', ); is ($crs->next, 3, 'Correct artist count (each with one 1998 or 2001 cd)'); } done_testing; ���������������������������������������������������������������������������DBIx-Class-0.082843/t/count/grouped_pager.t���������������������������������������������������������0000644�0001750�0001750�00000001650�14240132261�017503� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; plan tests => 7; my $schema = DBICTest->init_schema(); # add 2 extra artists $schema->populate ('Artist', [ [qw/name/], [qw/ar_1/], [qw/ar_2/], ]); # add 3 extra cds to every artist for my $ar ($schema->resultset ('Artist')->all) { for my $cdnum (1 .. 3) { $ar->create_related ('cds', { title => "bogon $cdnum", year => 2000 + $cdnum, }); } } my $cds = $schema->resultset ('CD')->search ({}, { group_by => 'artist' } ); is ($cds->count, 5, 'Resultset collapses to 5 groups'); my ($pg1, $pg2, $pg3) = map { $cds->search_rs ({}, {rows => 2, page => $_}) } (1..3); for ($pg1, $pg2, $pg3) { is ($_->pager->total_entries, 5, 'Total count via pager correct'); } is ($pg1->count, 2, 'First page has 2 groups'); is ($pg2->count, 2, 'Second page has 2 groups'); is ($pg3->count, 1, 'Third page has one group remaining'); ����������������������������������������������������������������������������������������DBIx-Class-0.082843/t/count/distinct.t��������������������������������������������������������������0000644�0001750�0001750�00000014475�14240132261�016512� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use lib qw(t/lib); use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); # The tag Blue is assigned to cds 1 2 3 and 5 # The tag Cheesy is assigned to cds 2 4 and 5 # # This combination should make some interesting group_by's # my $rs; my $in_rs = $schema->resultset('Tag')->search({ tag => [ 'Blue', 'Cheesy' ] }); for my $get_count ( sub { shift->count }, sub { my $crs = shift->count_rs; isa_ok ($crs, 'DBIx::Class::ResultSetColumn'); $crs->next } ) { $rs = $schema->resultset('Tag')->search({ tag => 'Blue' }); is($get_count->($rs), 4, 'Count without DISTINCT'); $rs = $schema->resultset('Tag')->search({ tag => [ 'Blue', 'Cheesy' ] }, { group_by => 'tag' }); is($get_count->($rs), 2, 'Count with single column group_by'); $rs = $schema->resultset('Tag')->search({ tag => [ 'Blue', 'Cheesy' ] }, { group_by => 'cd' }); is($get_count->($rs), 5, 'Count with another single column group_by'); $rs = $schema->resultset('Tag')->search({ tag => 'Blue' }, { group_by => [ qw/tag cd/ ]}); is($get_count->($rs), 4, 'Count with multiple column group_by'); $rs = $schema->resultset('Tag')->search({ tag => 'Blue' }, { distinct => 1 }); is($get_count->($rs), 4, 'Count with single column distinct'); $rs = $schema->resultset('Tag')->search({ tag => { -in => $in_rs->get_column('tag')->as_query } }); is($get_count->($rs), 7, 'Count with IN subquery'); $rs = $schema->resultset('Tag')->search({ tag => { -in => $in_rs->get_column('tag')->as_query } }, { group_by => 'tag' }); is($get_count->($rs), 2, 'Count with IN subquery with outside group_by'); $rs = $schema->resultset('Tag')->search({ tag => { -in => $in_rs->get_column('tag')->as_query } }, { distinct => 1 }); is($get_count->($rs), 7, 'Count with IN subquery with outside distinct'); $rs = $schema->resultset('Tag')->search({ tag => { -in => $in_rs->get_column('tag')->as_query } }, { distinct => 1, select => 'tag' }), is($get_count->($rs), 2, 'Count with IN subquery with outside distinct on a single column'); $rs = $schema->resultset('Tag')->search({ tag => { -in => $in_rs->search({}, { group_by => 'tag' })->get_column('tag')->as_query } }); is($get_count->($rs), 7, 'Count with IN subquery with single group_by'); $rs = $schema->resultset('Tag')->search({ tag => { -in => $in_rs->search({}, { group_by => 'cd' })->get_column('tag')->as_query } }); is($get_count->($rs), 7, 'Count with IN subquery with another single group_by'); $rs = $schema->resultset('Tag')->search({ tag => { -in => $in_rs->search({}, { group_by => [ qw/tag cd/ ] })->get_column('tag')->as_query } }); is($get_count->($rs), 7, 'Count with IN subquery with multiple group_by'); $rs = $schema->resultset('Tag')->search({ tag => \"= 'Blue'" }); is($get_count->($rs), 4, 'Count without DISTINCT, using literal SQL'); $rs = $schema->resultset('Tag')->search({ tag => \" IN ('Blue', 'Cheesy')" }, { group_by => 'tag' }); is($get_count->($rs), 2, 'Count with literal SQL and single group_by'); $rs = $schema->resultset('Tag')->search({ tag => \" IN ('Blue', 'Cheesy')" }, { group_by => 'cd' }); is($get_count->($rs), 5, 'Count with literal SQL and another single group_by'); $rs = $schema->resultset('Tag')->search({ tag => \" IN ('Blue', 'Cheesy')" }, { group_by => [ qw/tag cd/ ] }); is($get_count->($rs), 7, 'Count with literal SQL and multiple group_by'); $rs = $schema->resultset('Tag')->search({ tag => 'Blue' }, { '+select' => { max => 'tagid' }, distinct => 1 }); is($get_count->($rs), 4, 'Count with +select aggreggate'); $rs = $schema->resultset('Tag')->search({}, { select => [\'length(me.tag)'], distinct => 1 }); is($get_count->($rs), 3, 'Count by distinct function result as select literal'); } throws_ok( sub { my $row = $schema->resultset('Tag')->search({}, { select => { distinct => [qw/tag cd/] } })->first }, qr/\Qselect => { distinct => ... } syntax is not supported for multiple columns/, 'throw on unsupported syntax' ); # make sure distinct+func works { my $rs = $schema->resultset('Artist')->search( {}, { join => 'cds', distinct => 1, '+select' => [ { count => 'cds.cdid', -as => 'amount_of_cds' } ], '+as' => [qw/num_cds/], order_by => { -desc => 'amount_of_cds' }, } ); is_same_sql_bind ( $rs->as_query, '( SELECT me.artistid, me.name, me.rank, me.charfield, COUNT( cds.cdid ) AS amount_of_cds FROM artist me LEFT JOIN cd cds ON cds.artist = me.artistid GROUP BY me.artistid, me.name, me.rank, me.charfield ORDER BY amount_of_cds DESC )', [], ); is ($rs->next->get_column ('num_cds'), 3, 'Function aliased correctly'); } # and check distinct has_many join count { my $rs = $schema->resultset('Artist')->search( { 'cds.title' => { '!=', 'fooooo' } }, { join => 'cds', distinct => 1, '+select' => [ { count => 'cds.cdid', -as => 'amount_of_cds' } ], '+as' => [qw/num_cds/], order_by => { -desc => 'amount_of_cds' }, } ); is_same_sql_bind ( $rs->as_query, '( SELECT me.artistid, me.name, me.rank, me.charfield, COUNT( cds.cdid ) AS amount_of_cds FROM artist me LEFT JOIN cd cds ON cds.artist = me.artistid WHERE cds.title != ? GROUP BY me.artistid, me.name, me.rank, me.charfield ORDER BY amount_of_cds DESC )', [ [{ sqlt_datatype => 'varchar', dbic_colname => 'cds.title', sqlt_size => 100, } => 'fooooo' ], ], ); is_same_sql_bind ( $rs->count_rs->as_query, '( SELECT COUNT( * ) FROM ( SELECT me.artistid, me.name, me.rank, me.charfield FROM artist me LEFT JOIN cd cds ON cds.artist = me.artistid WHERE cds.title != ? GROUP BY me.artistid, me.name, me.rank, me.charfield ) me )', [ [{ sqlt_datatype => 'varchar', dbic_colname => 'cds.title', sqlt_size => 100, } => 'fooooo' ], ], ); is ($rs->next->get_column ('num_cds'), 3, 'Function aliased correctly'); } # These two rely on the database to throw an exception. This might not be the case one day. Please revise. dies_ok(sub { my $count = $schema->resultset('Tag')->search({}, { '+select' => \'tagid AS tag_id', distinct => 1 })->count }, 'expecting to die'); done_testing; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/count/prefetch.t��������������������������������������������������������������0000644�0001750�0001750�00000005345�14240132261�016465� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use lib qw(t/lib); use Test::More; use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); # collapsing prefetch { my $rs = $schema->resultset("Artist") ->search_related('cds', { 'tracks.position' => [1,2] }, { prefetch => [qw/tracks artist/] }, ); is ($rs->all, 5, 'Correct number of objects'); is ($rs->count, 5, 'Correct count'); is_same_sql_bind ( $rs->count_rs->as_query, '( SELECT COUNT( * ) FROM ( SELECT cds.cdid FROM artist me JOIN cd cds ON cds.artist = me.artistid LEFT JOIN track tracks ON tracks.cd = cds.cdid JOIN artist artist ON artist.artistid = cds.artist WHERE tracks.position = ? OR tracks.position = ? GROUP BY cds.cdid ) cds )', [ map { [ { sqlt_datatype => 'int', dbic_colname => 'tracks.position' } => $_ ] } (1, 2) ], ); } # collapsing prefetch with distinct { my $rs = $schema->resultset("Artist")->search(undef, {distinct => 1}) ->search_related('cds')->search_related('genre', { 'genre.name' => 'emo' }, { prefetch => q(cds) }, ); is ($rs->all, 1, 'Correct number of objects'); is ($rs->count, 1, 'Correct count'); is_same_sql_bind ( $rs->count_rs->as_query, '( SELECT COUNT( * ) FROM ( SELECT genre.genreid FROM ( SELECT me.artistid, me.name, me.rank, me.charfield FROM artist me GROUP BY me.artistid, me.name, me.rank, me.charfield ) me JOIN cd cds ON cds.artist = me.artistid JOIN genre genre ON genre.genreid = cds.genreid WHERE ( genre.name = ? ) GROUP BY genre.genreid ) genre )', [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'genre.name' } => 'emo' ] ], ); } # non-collapsing prefetch (no multi prefetches) { my $rs = $schema->resultset("CD") ->search_related('tracks', { position => [1,2], 'lyrics.lyric_id' => undef }, { prefetch => [qw/disc lyrics/] }, ); is ($rs->all, 10, 'Correct number of objects'); is ($rs->count, 10, 'Correct count'); is_same_sql_bind ( $rs->count_rs->as_query, '( SELECT COUNT( * ) FROM cd me JOIN track tracks ON tracks.cd = me.cdid JOIN cd disc ON disc.cdid = tracks.cd LEFT JOIN lyrics lyrics ON lyrics.track_id = tracks.trackid WHERE lyrics.lyric_id IS NULL AND (position = ? OR position = ?) )', [ map { [ { sqlt_datatype => 'int', dbic_colname => 'position' } => $_ ] } (1, 2) ], ); } done_testing; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/count/joined.t����������������������������������������������������������������0000644�0001750�0001750�00000003173�14240132261�016132� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); my $cds = $schema->resultset("CD")->search({ cdid => 1 }, { join => { cd_to_producer => 'producer' } }); cmp_ok($cds->count, '>', 1, "extra joins explode entity count"); for my $arg ( [ 'prefetch-collapsed has_many' => { prefetch => 'cd_to_producer' } ], [ 'distict-collapsed result' => { distinct => 1 } ], [ 'explicit collapse request' => { collapse => 1 } ], ) { for my $hri (0,1) { my $diag = $arg->[0] . ($hri ? ' with HRI' : ''); my $rs = $cds->search({}, { %{$arg->[1]}, $hri ? ( result_class => 'DBIx::Class::ResultClass::HashRefInflator' ) : (), }); is $rs->count, 1, "Count correct on $diag", ; is scalar $rs->all, 1, "Amount of constructed objects matches count on $diag", ; } } # JOIN and LEFT JOIN issues mean that we've seen problems where counted rows and fetched rows are sometimes 1 higher than they should # be in the related resultset. my $artist=$schema->resultset('Artist')->create({name => 'xxx'}); is($artist->related_resultset('cds')->count(), 0, "No CDs found for a shiny new artist"); is(scalar($artist->related_resultset('cds')->all()), 0, "No CDs fetched for a shiny new artist"); my $artist_rs = $schema->resultset('Artist')->search({artistid => $artist->id}); is($artist_rs->related_resultset('cds')->count(), 0, "No CDs counted for a shiny new artist using a resultset search"); is(scalar($artist_rs->related_resultset('cds')->all), 0, "No CDs fetched for a shiny new artist using a resultset search"); done_testing; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/39load_namespaces_2.t���������������������������������������������������������0000644�0001750�0001750�00000001575�14240132261�017251� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; # do not remove even though it is not used plan tests => 6; my $warnings; eval { local $SIG{__WARN__} = sub { $warnings .= shift }; package DBICNSTest; use base qw/DBIx::Class::Schema/; __PACKAGE__->load_namespaces( result_namespace => 'Rslt', resultset_namespace => 'RSet', ); }; ok(!$@) or diag $@; like($warnings, qr/load_namespaces found ResultSet class 'DBICNSTest::RSet::C' with no corresponding Result class/); my $source_a = DBICNSTest->source('A'); isa_ok($source_a, 'DBIx::Class::ResultSource::Table'); my $rset_a = DBICNSTest->resultset('A'); isa_ok($rset_a, 'DBICNSTest::RSet::A'); my $source_b = DBICNSTest->source('B'); isa_ok($source_b, 'DBIx::Class::ResultSource::Table'); my $rset_b = DBICNSTest->resultset('B'); isa_ok($rset_b, 'DBIx::Class::ResultSet'); �����������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/77join_count.t����������������������������������������������������������������0000644�0001750�0001750�00000001555�14240132261�016061� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); cmp_ok($schema->resultset("CD")->count({ 'artist.name' => 'Caterwauler McCrae' }, { join => 'artist' }), '==', 3, 'Count by has_a ok'); cmp_ok($schema->resultset("CD")->count({ 'tags.tag' => 'Blue' }, { join => 'tags' }), '==', 4, 'Count by has_many ok'); cmp_ok($schema->resultset("CD")->count( { 'liner_notes.notes' => { '!=' => undef } }, { join => 'liner_notes' }), '==', 3, 'Count by might_have ok'); cmp_ok($schema->resultset("CD")->count( { 'year' => { '>', 1998 }, 'tags.tag' => 'Cheesy', 'liner_notes.notes' => { 'like' => 'Buy%' } }, { join => [ qw/tags liner_notes/ ] } ), '==', 2, "Mixed count ok"); done_testing; ���������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/69update.t��������������������������������������������������������������������0000644�0001750�0001750�00000001274�14240132261�015173� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); my $art = $schema->resultset("Artist")->find(1); isa_ok $art => 'DBICTest::Artist'; my $name = 'Caterwauler McCrae'; ok($art->name($name) eq $name, 'update'); { my @changed_keys = $art->is_changed; is( scalar (@changed_keys), 0, 'field changed but same value' ); } $art->discard_changes; ok($art->update({ artistid => 100 }), 'update allows pk mutation'); is($art->artistid, 100, 'pk mutation applied'); my $art_100 = $schema->resultset("Artist")->find(100); $art_100->artistid(101); ok($art_100->update(), 'update allows pk mutation via column accessor'); done_testing; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/26dumper.t��������������������������������������������������������������������0000644�0001750�0001750�00000001141�14240132261�015167� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Data::Dumper; $Data::Dumper::Sortkeys = 1; use lib qw(t/lib); use_ok('DBICTest'); my $schema = DBICTest->init_schema(); my $rs = $schema->resultset('CD')->search({ 'artist.name' => 'We Are Goth', 'liner_notes.notes' => 'Kill Yourself!', }, { join => [ qw/artist liner_notes/ ], }); Dumper($rs); $rs = $schema->resultset('CD')->search({ 'artist.name' => 'We Are Goth', 'liner_notes.notes' => 'Kill Yourself!', }, { join => [ qw/artist liner_notes/ ], }); cmp_ok( $rs->count(), '==', 1, "Single record in after death with dumper"); done_testing; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/40compose_connection.t��������������������������������������������������������0000644�0001750�0001750�00000000653�14240132261�017562� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Warn; use lib qw(t/lib); use DBICTest; warnings_exist { DBICTest->init_schema( compose_connection => 1, sqlite_use_file => 1 ) } [ qr/compose_connection deprecated as of 0\.08000/, qr/\QDBIx::Class::ResultSetProxy is DEPRECATED/, ], 'got expected deprecation warnings' ; cmp_ok(DBICTest->resultset('Artist')->count, '>', 0, 'count is valid'); done_testing; �������������������������������������������������������������������������������������DBIx-Class-0.082843/t/resultset_class.t�������������������������������������������������������������0000644�0001750�0001750�00000001624�14240132261�016750� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Class::Inspector (); unshift(@INC, './t/lib'); use lib 't/lib'; use DBICTest; is(DBICTest::Schema->source('Artist')->resultset_class, 'DBICTest::BaseResultSet', 'default resultset class'); ok(!Class::Inspector->loaded('DBICNSTest::ResultSet::A'), 'custom resultset class not loaded'); DBICTest::Schema->source('Artist')->resultset_class('DBICNSTest::ResultSet::A'); ok(!Class::Inspector->loaded('DBICNSTest::ResultSet::A'), 'custom resultset class not loaded on SET'); is(DBICTest::Schema->source('Artist')->resultset_class, 'DBICNSTest::ResultSet::A', 'custom resultset class set'); ok(Class::Inspector->loaded('DBICNSTest::ResultSet::A'), 'custom resultset class loaded on GET'); my $schema = DBICTest->init_schema; my $resultset = $schema->resultset('Artist')->search; isa_ok($resultset, 'DBICNSTest::ResultSet::A', 'resultset is custom class'); done_testing; ������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/63register_class.t������������������������������������������������������������0000644�0001750�0001750�00000000775�14240132261�016721� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More tests => 2; use lib qw(t/lib); use DBICTest; use DBICTest::Schema; use DBICTest::Schema::Artist; DBICTest::Schema::Artist->source_name('MyArtist'); DBICTest::Schema->register_class('FooA', 'DBICTest::Schema::Artist'); my $schema = DBICTest->init_schema(); my $a = $schema->resultset('FooA')->search; is($a->count, 3, 'have 3 artists'); is($schema->class('FooA'), 'DBICTest::FooA', 'Correct artist class'); # clean up DBICTest::Schema->_unregister_source('FooA'); ���DBIx-Class-0.082843/t/100populate.t�����������������������������������������������������������������0000644�0001750�0001750�00000031537�14240132261�015611� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use Test::Warn; use lib qw(t/lib); use DBICTest; use DBIx::Class::_Util 'sigwarn_silencer'; use Path::Class::File (); use Math::BigInt; use List::Util qw/shuffle/; use Storable qw/nfreeze dclone/; my $schema = DBICTest->init_schema(); # The map below generates stuff like: # [ qw/artistid name/ ], # [ 4, "b" ], # [ 5, "c" ], # ... # [ 9999, "ntm" ], # [ 10000, "ntn" ], my $start_id = 'populateXaaaaaa'; my $rows = 10_000; my $offset = 3; $schema->populate('Artist', [ [ qw/artistid name/ ], map { [ ($_ + $offset) => $start_id++ ] } shuffle ( 1 .. $rows ) ] ); is ( $schema->resultset ('Artist')->search ({ name => { -like => 'populateX%' } })->count, $rows, 'populate created correct number of rows with massive AoA bulk insert', ); my $artist = $schema->resultset ('Artist') ->search ({ 'cds.title' => { '!=', undef } }, { join => 'cds' }) ->first; my $ex_title = $artist->cds->first->title; throws_ok ( sub { my $i = 600; $schema->populate('CD', [ map { { artist => $artist->id, title => $_, year => 2009, } } ('Huey', 'Dewey', $ex_title, 'Louie') ]) }, qr/\Qexecute_for_fetch() aborted with '\E.+ at populate slice.+$ex_title/ms, 'Readable exception thrown for failed populate'); ## make sure populate honors fields/orders in list context ## schema order my @links = $schema->populate('Link', [ [ qw/id url title/ ], [ qw/2 burl btitle/ ] ]); is(scalar @links, 1); my $link2 = shift @links; is($link2->id, 2, 'Link 2 id'); is($link2->url, 'burl', 'Link 2 url'); is($link2->title, 'btitle', 'Link 2 title'); ## non-schema order @links = $schema->populate('Link', [ [ qw/id title url/ ], [ qw/3 ctitle curl/ ] ]); is(scalar @links, 1); my $link3 = shift @links; is($link3->id, 3, 'Link 3 id'); is($link3->url, 'curl', 'Link 3 url'); is($link3->title, 'ctitle', 'Link 3 title'); ## not all physical columns @links = $schema->populate('Link', [ [ qw/id title/ ], [ qw/4 dtitle/ ] ]); is(scalar @links, 1); my $link4 = shift @links; is($link4->id, 4, 'Link 4 id'); is($link4->url, undef, 'Link 4 url'); is($link4->title, 'dtitle', 'Link 4 title'); ## variable size dataset @links = $schema->populate('Link', [ [ qw/id title url/ ], [ 41 ], [ 42, undef, 'url42' ], ]); is(scalar @links, 2); is($links[0]->url, undef); is($links[1]->url, 'url42'); ## make sure populate -> _insert_bulk honors fields/orders in void context ## schema order $schema->populate('Link', [ [ qw/id url title/ ], [ qw/5 eurl etitle/ ] ]); my $link5 = $schema->resultset('Link')->find(5); is($link5->id, 5, 'Link 5 id'); is($link5->url, 'eurl', 'Link 5 url'); is($link5->title, 'etitle', 'Link 5 title'); ## non-schema order $schema->populate('Link', [ [ qw/id title url/ ], [ qw/6 ftitle furl/ ] ]); my $link6 = $schema->resultset('Link')->find(6); is($link6->id, 6, 'Link 6 id'); is($link6->url, 'furl', 'Link 6 url'); is($link6->title, 'ftitle', 'Link 6 title'); ## not all physical columns $schema->populate('Link', [ [ qw/id title/ ], [ qw/7 gtitle/ ] ]); my $link7 = $schema->resultset('Link')->find(7); is($link7->id, 7, 'Link 7 id'); is($link7->url, undef, 'Link 7 url'); is($link7->title, 'gtitle', 'Link 7 title'); ## variable size dataset in void ctx $schema->populate('Link', [ [ qw/id title url/ ], [ 71 ], [ 72, undef, 'url72' ], ]); @links = $schema->resultset('Link')->search({ id => [71, 72]}, { order_by => 'id' })->all; is(scalar @links, 2); is($links[0]->url, undef); is($links[1]->url, 'url72'); ## variable size dataset in void ctx, hash version $schema->populate('Link', [ { id => 73 }, { id => 74, title => 't74' }, { id => 75, url => 'u75' }, ]); @links = $schema->resultset('Link')->search({ id => [73..75]}, { order_by => 'id' })->all; is(scalar @links, 3); is($links[0]->url, undef); is($links[0]->title, undef); is($links[1]->url, undef); is($links[1]->title, 't74'); is($links[2]->url, 'u75'); is($links[2]->title, undef); ## Make sure the void ctx trace is sane { for ( [ [ qw/id title url/ ], [ 81 ], [ 82, 't82' ], [ 83, undef, 'url83' ], ], [ { id => 91 }, { id => 92, title => 't92' }, { id => 93, url => 'url93' }, ] ) { $schema->is_executed_sql_bind( sub { $schema->populate('Link', $_); }, [ [ 'BEGIN' ], [ 'INSERT INTO link( id, title, url ) VALUES( ?, ?, ? )', "__BULK_INSERT__" ], [ 'COMMIT' ], ] ); } } # populate with literals { my $rs = $schema->resultset('Link'); $rs->delete; # test populate with all literal sql (no binds) $rs->populate([ (+{ url => \"'cpan.org'", title => \"'The ''best of'' cpan'", }) x 5 ]); is((grep { $_->url eq 'cpan.org' && $_->title eq "The 'best of' cpan", } $rs->all), 5, 'populate with all literal SQL'); $rs->delete; # test mixed binds with literal sql $rs->populate([ (+{ url => \"'cpan.org'", title => "The 'best of' cpan", }) x 5 ]); is((grep { $_->url eq 'cpan.org' && $_->title eq "The 'best of' cpan", } $rs->all), 5, 'populate with all literal SQL'); $rs->delete; } # populate with literal+bind { my $rs = $schema->resultset('Link'); $rs->delete; # test populate with all literal/bind sql $rs->populate([ (+{ url => \['?', [ {} => 'cpan.org' ] ], title => \['?', [ {} => "The 'best of' cpan" ] ], }) x 5 ]); is((grep { $_->url eq 'cpan.org' && $_->title eq "The 'best of' cpan", } $rs->all), 5, 'populate with all literal/bind'); $rs->delete; # test populate with mix literal and literal/bind $rs->populate([ (+{ url => \"'cpan.org'", title => \['?', [ {} => "The 'best of' cpan" ] ], }) x 5 ]); is((grep { $_->url eq 'cpan.org' && $_->title eq "The 'best of' cpan", } $rs->all), 5, 'populate with all literal/bind SQL'); $rs->delete; # test mixed binds with literal sql/bind $rs->populate([ map { +{ url => \[ '? || ?', [ {} => 'cpan.org_' ], $_ ], title => "The 'best of' cpan", } } (1 .. 5) ]); for (1 .. 5) { ok($rs->find({ url => "cpan.org_$_" }), "Row $_ correctly created with dynamic literal/bind populate" ); } $rs->delete; } my $rs = $schema->resultset('Artist'); $rs->delete; throws_ok { # this warning is correct, but we are not testing it here # what we are after is the correct exception when an int # fails to coerce into a sqlite rownum local $SIG{__WARN__} = sigwarn_silencer( qr/datatype mismatch.+ foo as integer/ ); $rs->populate([ { artistid => 1, name => 'foo1', }, { artistid => 'foo', # this dies name => 'foo2', }, { artistid => 3, name => 'foo3', }, ]); } qr/\Qexecute_for_fetch() aborted with 'datatype mismatch\E\b/, 'bad slice fails PK insert'; is($rs->count, 0, 'populate is atomic'); # Trying to use a column marked as a bind in the first slice with literal sql in # a later slice should throw. throws_ok { $rs->populate([ { artistid => 1, name => \"'foo'", }, { artistid => \2, name => \"'foo'", } ]); } qr/Literal SQL found where a plain bind value is expected/, 'literal sql where bind expected throws'; # ... and vice-versa. throws_ok { $rs->populate([ { artistid => \1, name => \"'foo'", }, { artistid => 2, name => \"'foo'", } ]); } qr/\QIncorrect value (expecting SCALAR-ref/, 'bind where literal sql expected throws'; throws_ok { $rs->populate([ { artistid => 1, name => \"'foo'", }, { artistid => 2, name => \"'bar'", } ]); } qr/Inconsistent literal SQL value/, 'literal sql must be the same in all slices'; throws_ok { $rs->populate([ { artistid => 1, name => \['?', [ {} => 'foo' ] ], }, { artistid => 2, name => \"'bar'", } ]); } qr/\QIncorrect value (expecting ARRAYREF-ref/, 'literal where literal+bind expected throws'; throws_ok { $rs->populate([ { artistid => 1, name => \['?', [ { sqlt_datatype => 'foooo' } => 'foo' ] ], }, { artistid => 2, name => \['?', [ {} => 'foo' ] ], } ]); } qr/\QDiffering bind attributes on literal\/bind values not supported for column 'name'/, 'literal+bind with differing attrs throws'; lives_ok { $rs->populate([ { artistid => 1, name => \['?', [ undef, 'foo' ] ], }, { artistid => 2, name => \['?', [ {} => 'bar' ] ], } ]); } 'literal+bind with semantically identical attrs works after normalization'; # test all kinds of population with stringified objects # or with empty sets warnings_like { my $rs = $schema->resultset('Artist')->search({}, { columns => [qw(name rank)], order_by => 'artistid' }); # the stringification has nothing to do with the artist name # this is solely for testing consistency my $fn = Path::Class::File->new ('somedir/somefilename.tmp'); my $fn2 = Path::Class::File->new ('somedir/someotherfilename.tmp'); my $rank = Math::BigInt->new(42); my $args = { 'stringifying objects after regular values' => { AoA => [ [qw( name rank )], ( map { [ $_, $rank ] } ( 'supplied before stringifying objects', 'supplied before stringifying objects 2', $fn, $fn2, )), ]}, 'stringifying objects before regular values' => { AoA => [ [qw( rank name )], ( map { [ $rank, $_ ] } ( $fn, $fn2, 'supplied after stringifying objects', 'supplied after stringifying objects 2', )), ]}, 'stringifying objects between regular values' => { AoA => [ [qw( name rank )], ( map { [ $_, $rank ] } ( 'supplied before stringifying objects', $fn, $fn2, 'supplied after stringifying objects', )) ]}, 'stringifying objects around regular values' => { AoA => [ [qw( rank name )], ( map { [ $rank, $_ ] } ( $fn, 'supplied between stringifying objects', $fn2, )) ]}, 'single stringifying object' => { AoA => [ [qw( rank name )], [ $rank, $fn ], ]}, 'empty set' => { AoA => [ [qw( name rank )], ]}, }; # generate the AoH equivalent based on the AoAs above for my $bag (values %$args) { $bag->{AoH} = []; my @hdr = @{$bag->{AoA}[0]}; for my $v ( @{$bag->{AoA}}[1..$#{$bag->{AoA}}] ) { push @{$bag->{AoH}}, my $h = {}; @{$h}{@hdr} = @$v; } } local $Storable::canonical = 1; my $preimage = nfreeze($args); for my $tst (keys %$args) { for my $type (qw(AoA AoH)) { # test void ctx $rs->delete; $rs->populate($args->{$tst}{$type}); is_deeply( $rs->all_hri, $args->{$tst}{AoH}, "Populate() $tst in void context" ); # test scalar ctx $rs->delete; my $dummy = $rs->populate($args->{$tst}{$type}); is_deeply( $rs->all_hri, $args->{$tst}{AoH}, "Populate() $tst in non-void context" ); # test list ctx $rs->delete; my @dummy = $rs->populate($args->{$tst}{$type}); is_deeply( $rs->all_hri, $args->{$tst}{AoH}, "Populate() $tst in non-void context" ); } # test create() as we have everything set up already $rs->delete; $rs->create($_) for @{$args->{$tst}{AoH}}; is_deeply( $rs->all_hri, $args->{$tst}{AoH}, "Create() $tst" ); } ok ( ($preimage eq nfreeze($args)), 'Arguments fed to populate()/create() unchanged' ); $rs->delete; } [], 'Data integrity warnings gone as planned'; $schema->is_executed_sql_bind( sub { $schema->resultset('TwoKeys')->populate([{ artist => 1, cd => 5, fourkeys_to_twokeys => [{ f_foo => 1, f_bar => 1, f_hello => 1, f_goodbye => 1, autopilot => 'a', },{ f_foo => 2, f_bar => 2, f_hello => 2, f_goodbye => 2, autopilot => 'b', }] }]) }, [ [ 'BEGIN' ], [ 'INSERT INTO twokeys ( artist, cd) VALUES ( ?, ? )', '__BULK_INSERT__' ], [ 'INSERT INTO fourkeys_to_twokeys ( autopilot, f_bar, f_foo, f_goodbye, f_hello, t_artist, t_cd) VALUES ( ?, ?, ?, ?, ?, ( SELECT me.artist FROM twokeys me WHERE artist = ? AND cd = ? ), ( SELECT me.cd FROM twokeys me WHERE artist = ? AND cd = ? ) ) ', '__BULK_INSERT__' ], [ 'COMMIT' ], ], 'multicol-PK has_many populate expected trace' ); lives_ok ( sub { $schema->populate('CD', [ {cdid => 10001, artist => $artist->id, title => 'Pretty Much Empty', year => 2011, tracks => []}, ]) }, 'empty has_many relationship accepted by populate'); done_testing; �����������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/70auto.t����������������������������������������������������������������������0000644�0001750�0001750�00000001173�14240132261�014647� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); plan tests => 2; $schema->class("Artist")->load_components(qw/PK::Auto::SQLite/); # Should just be PK::Auto but this ensures the compat shim works # add an artist without primary key to test Auto my $artist = $schema->resultset("Artist")->create( { name => 'Auto' } ); $artist->name( 'Auto Change' ); ok($artist->update, 'update on object created without PK ok'); my $copied = $artist->copy({ name => 'Don\'t tell the RIAA', artistid => undef }); is($copied->name, 'Don\'t tell the RIAA', "Copied with PKs ok."); �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/pager/������������������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�014460� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/pager/data_page_compat/�������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�017730� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/pager/data_page_compat/simple.t�����������������������������������������������0000644�0001750�0001750�00000011106�14240132261�021364� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use DBIx::Class::ResultSet::Pager; my $name; foreach my $line (<DATA>) { chomp $line; next unless $line; if ( $line =~ /^# ?(.+)/ ) { $name = $1; next; } print "Line is: $line\n"; my @vals = map { /^undef$/ ? undef : /^''$/ ? '' : $_ } split /\s+/, $line; my $page = DBIx::Class::ResultSet::Pager->new( @vals[ 0, 1, 2 ] ); print "Old style\n"; check( $page, $name, @vals ); $page = DBIx::Class::ResultSet::Pager->new(); $page->total_entries( $vals[0] ); $page->entries_per_page( $vals[1] ); $page->current_page( $vals[2] ); print "New style\n"; check( $page, $name, @vals ); } my $page = DBIx::Class::ResultSet::Pager->new( 0, 10 ); isa_ok( $page, 'DBIx::Class::ResultSet::Pager' ); my @empty; my @spliced = $page->splice( \@empty ); is( scalar(@spliced), 0, "Splice on empty is empty" ); sub check { my ( $page, $name, @vals ) = @_; isa_ok( $page, 'DBIx::Class::ResultSet::Pager' ); is( $page->first_page, $vals[3], "$name: first page" ); is( $page->last_page, $vals[4], "$name: last page" ); is( $page->first, $vals[5], "$name: first" ); is( $page->last, $vals[6], "$name: last" ); is( $page->previous_page, $vals[7], "$name: previous_page" ); is( $page->current_page, $vals[8], "$name: current_page" ); is( $page->next_page, $vals[9], "$name: next_page" ); my @integers = ( 0 .. $vals[0] - 1 ); @integers = $page->splice( \@integers ); my $integers = join ',', @integers; is( $integers, $vals[10], "$name: splice" ); is( $page->entries_on_this_page, $vals[11], "$name: entries_on_this_page" ); my $skipped = $vals[5] - 1; $skipped = 0 if $skipped < 0; is( $page->skipped, $skipped, "$name: skipped" ); $page->change_entries_per_page( $vals[12] ); is( $page->current_page, $vals[13], "$name: change_entries_per_page" ); } done_testing; # Format of test data: 0=number of entries, 1=entries per page, 2=current page, # 3=first page, 4=last page, 5=first entry on page, 6=last entry on page, # 7=previous page, 8=current page, 9=next page, 10=current entries, # 11=current number of entries, 12=new entries per page, 13=new page __DATA__ # Initial test 50 10 1 1 5 1 10 undef 1 2 0,1,2,3,4,5,6,7,8,9 10 15 1 50 10 2 1 5 11 20 1 2 3 10,11,12,13,14,15,16,17,18,19 10 15 1 50 10 3 1 5 21 30 2 3 4 20,21,22,23,24,25,26,27,28,29 10 15 2 50 10 4 1 5 31 40 3 4 5 30,31,32,33,34,35,36,37,38,39 10 15 3 50 10 5 1 5 41 50 4 5 undef 40,41,42,43,44,45,46,47,48,49 10 15 3 # Under 10 1 10 1 1 1 1 1 undef 1 undef 0 1 15 1 2 10 1 1 1 1 2 undef 1 undef 0,1 2 15 1 3 10 1 1 1 1 3 undef 1 undef 0,1,2 3 15 1 4 10 1 1 1 1 4 undef 1 undef 0,1,2,3 4 15 1 5 10 1 1 1 1 5 undef 1 undef 0,1,2,3,4 5 15 1 6 10 1 1 1 1 6 undef 1 undef 0,1,2,3,4,5 6 15 1 7 10 1 1 1 1 7 undef 1 undef 0,1,2,3,4,5,6 7 15 1 8 10 1 1 1 1 8 undef 1 undef 0,1,2,3,4,5,6,7 8 15 1 9 10 1 1 1 1 9 undef 1 undef 0,1,2,3,4,5,6,7,8 9 15 1 10 10 1 1 1 1 10 undef 1 undef 0,1,2,3,4,5,6,7,8,9 10 15 1 # Over 10 11 10 1 1 2 1 10 undef 1 2 0,1,2,3,4,5,6,7,8,9 10 10 1 11 10 2 1 2 11 11 1 2 undef 10 1 10 2 12 10 1 1 2 1 10 undef 1 2 0,1,2,3,4,5,6,7,8,9 10 10 1 12 10 2 1 2 11 12 1 2 undef 10,11 2 10 2 13 10 1 1 2 1 10 undef 1 2 0,1,2,3,4,5,6,7,8,9 10 10 1 13 10 2 1 2 11 13 1 2 undef 10,11,12 3 10 2 # Under 20 19 10 1 1 2 1 10 undef 1 2 0,1,2,3,4,5,6,7,8,9 10 4 1 19 10 2 1 2 11 19 1 2 undef 10,11,12,13,14,15,16,17,18 9 4 3 20 10 1 1 2 1 10 undef 1 2 0,1,2,3,4,5,6,7,8,9 10 4 1 20 10 2 1 2 11 20 1 2 undef 10,11,12,13,14,15,16,17,18,19 10 4 3 # Over 20 21 10 1 1 3 1 10 undef 1 2 0,1,2,3,4,5,6,7,8,9 10 19 1 21 10 2 1 3 11 20 1 2 3 10,11,12,13,14,15,16,17,18,19 10 19 1 21 10 3 1 3 21 21 2 3 undef 20 1 19 2 22 10 1 1 3 1 10 undef 1 2 0,1,2,3,4,5,6,7,8,9 10 19 1 22 10 2 1 3 11 20 1 2 3 10,11,12,13,14,15,16,17,18,19 10 19 1 22 10 3 1 3 21 22 2 3 undef 20,21 2 19 2 23 10 1 1 3 1 10 undef 1 2 0,1,2,3,4,5,6,7,8,9 10 19 1 23 10 2 1 3 11 20 1 2 3 10,11,12,13,14,15,16,17,18,19 10 19 1 23 10 3 1 3 21 23 2 3 undef 20,21,22 3 19 2 # Zero test 0 10 1 1 1 0 0 undef 1 undef '' 0 5 1 ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/pager/data_page_compat/constructor.t������������������������������������������0000644�0001750�0001750�00000003353�14240132261�022465� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use warnings; use strict; use Test::More; use Test::Exception; use DBIx::Class::ResultSet::Pager; my $page = DBIx::Class::ResultSet::Pager->new(7, 10, 12); isa_ok($page, 'DBIx::Class::ResultSet::Pager'); is($page->first_page, 1, "Adjusted to first possible page"); $page = DBIx::Class::ResultSet::Pager->new(0, 10, -1); isa_ok($page, 'DBIx::Class::ResultSet::Pager'); is($page->first_page, 1, "Adjusted to first possible page"); throws_ok { my $page = DBIx::Class::ResultSet::Pager->new(12, -1, 1); } qr/one entry per page/, "Can't have entries-per-page less than 1"; # The new empty constructor means we might be empty, let's check for sensible defaults $page = DBIx::Class::ResultSet::Pager->new; is($page->entries_per_page, 10); is($page->total_entries, 0); is($page->entries_on_this_page, 0); is($page->first_page, 1); is($page->last_page, 1); is($page->first, 0); is($page->last, 0); is($page->previous_page, undef); is($page->current_page, 1); is($page->next_page, undef); is($page->skipped, 0); my @integers = (0 .. 100); @integers = $page->splice(\@integers); my $integers = join ',', @integers; is($integers, ''); $page->current_page(undef); is($page->current_page, 1); $page->current_page(-5); is($page->current_page, 1); $page->current_page(5); is($page->current_page, 1); is_deeply( $page->total_entries(100), $page, "Set-chaining works on total_entries", ); is_deeply( $page->entries_per_page(20), $page, "Set-chaining works on entries_per_page", ); is_deeply( $page->current_page(2), $page, "Set-chaining works on current_page", ); is($page->first, 21); $page->current_page(3); is($page->first, 41); done_testing; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/pager/dbic_core.t�������������������������������������������������������������0000644�0001750�0001750�00000013426�14240132261�016543� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; use Storable qw/dclone/; my $schema = DBICTest->init_schema(); is ($schema->resultset("CD")->count, 5, 'Initial count sanity check'); my $qcnt; $schema->storage->debugcb(sub { $qcnt++ }); $schema->storage->debug (1); my $rs = $schema->resultset("CD"); # first page $qcnt = 0; my $it = $rs->search( {}, { order_by => 'title', rows => 3, page => 1 } ); my $pager = $it->pager; is ($qcnt, 0, 'No queries on rs/pager creation'); is ($pager->entries_per_page, 3, 'Pager created with correct entries_per_page'); ok ($pager->current_page(-1), 'Set nonexistent page'); is ($pager->current_page, 1, 'Page set behaves correctly'); ok ($pager->current_page(2), 'Set 2nd page'); is ($qcnt, 0, 'No queries on total_count-independent methods'); is( $it->pager->entries_on_this_page, 2, "entries_on_this_page ok for page 2" ); is ($qcnt, 1, 'Count fired to get pager page entries'); $qcnt = 0; is ($pager->previous_page, 1, 'Correct previous_page'); is ($pager->next_page, undef, 'No more pages'); is ($qcnt, 0, 'No more counts - amount of entries cached in pager'); is( $it->count, 3, "count on paged rs ok" ); is ($qcnt, 1, 'An $rs->count still fires properly'); is( $it->next->title, "Caterwaulin' Blues", "iterator->next ok" ); $it->next; $it->next; is( $it->next, undef, "next past end of page ok" ); # second page, testing with array my @page2 = $rs->search( {}, { order_by => 'title', rows => 3, page => 2 } ); is( $page2[0]->title, "Generic Manufactured Singles", "second page first title ok" ); # page a standard resultset $it = $rs->search( {}, { order_by => 'title', rows => 3 } ); my $page = $it->page(2); is( $page->count, 2, "standard resultset paged rs count ok" ); is( $page->next->title, "Generic Manufactured Singles", "second page of standard resultset ok" ); # test software-based limit paging $it = $rs->search( {}, { order_by => 'title', rows => 3, page => 2, software_limit => 1 } ); is( $it->pager->entries_on_this_page, 2, "software entries_on_this_page ok" ); is( $it->pager->previous_page, 1, "software previous_page ok" ); is( $it->count, 2, "software count on paged rs ok" ); is( $it->next->title, "Generic Manufactured Singles", "software iterator->next ok" ); # test paging with chained searches $it = $rs->search( {}, { rows => 2, page => 2 } )->search( undef, { order_by => 'title' } ); is( $it->count, 2, "chained searches paging ok" ); # test page with offset $it = $rs->search({}, { rows => 2, page => 2, offset => 1, order_by => 'cdid' }); my $row = $rs->search({}, { order_by => 'cdid', offset => 3, rows => 1 })->single; is($row->cdid, $it->first->cdid, 'page with offset'); # test pager on non-title page behavior $qcnt = 0; $it = $rs->search({}, { rows => 3 })->page (2); ok ($it->pager); is ($qcnt, 0, 'No count on past-first-page pager instantiation'); is ($it->pager->current_page, 2, 'Page set properby by $rs'); is( $it->pager->total_entries, 5, 'total_entries correct' ); $rs->create ({ artist => 1, title => 'MOAR!', year => 2010 }); is( $it->count, 3, 'Dynamic count on filling up page' ); $rs->create ({ artist => 1, title => 'MOAR!!!', year => 2011 }); is( $it->count, 3, 'Count still correct (does not overflow' ); $qcnt = 0; is( $it->pager->total_entries, 5, 'total_entries properly cached at old value' ); is ($qcnt, 0, 'No queries'); # test fresh pager with explicit total count assignment $qcnt = 0; $pager = $rs->search({}, { rows => 4 })->page (2)->pager; $pager->total_entries (13); is ($pager->current_page, 2, 'Correct start page'); is ($pager->next_page, 3, 'One more page'); is ($pager->last_page, 4, 'And one more page'); is ($pager->previous_page, 1, 'One page in front'); is ($qcnt, 0, 'No queries with explicitly sey total count'); # test cached resultsets my $init_cnt = $rs->count; $it = $rs->search({}, { rows => 3, cache => 1 })->page(2); is ($it->count, 3, '3 rows'); is (scalar $it->all, 3, '3 objects'); isa_ok($it->pager,'DBIx::Class::ResultSet::Pager','Get a pager back ok'); is($it->pager->total_entries,7); is($it->pager->current_page,2); is($it->pager->entries_on_this_page,3); $it = $it->page(3); is ($it->count, 1, 'One row'); is (scalar $it->all, 1, 'One object'); isa_ok($it->pager,'DBIx::Class::ResultSet::Pager','Get a pager back ok'); is($it->pager->total_entries,7); is($it->pager->current_page,3); is($it->pager->entries_on_this_page,1); $it->delete; is ($rs->count, $init_cnt - 1, 'One row deleted as expected'); is ($it->count, 1, 'One row (cached)'); is (scalar $it->all, 1, 'One object (cached)'); # test fresh rs creation with modified defaults my $p = sub { $schema->resultset('CD')->page(1)->pager->entries_per_page; }; is($p->(), 10, 'default rows is 10'); $schema->default_resultset_attributes({ rows => 5 }); is($p->(), 5, 'default rows is 5'); # does serialization work (preserve laziness, while preserving state if exits) $qcnt = 0; $it = $rs->search( {}, { order_by => 'title', rows => 5, page => 2 } ); $pager = $it->pager; is ($qcnt, 0, 'No queries on rs/pager creation'); $it = do { local $DBIx::Class::ResultSourceHandle::thaw_schema = $schema; dclone ($it) }; is ($qcnt, 0, 'No queries on rs/pager freeze/thaw'); is( $it->pager->entries_on_this_page, 1, "entries_on_this_page ok for page 2" ); is ($qcnt, 1, 'Count fired to get pager page entries'); $rs->create({ title => 'bah', artist => 1, year => 2011 }); $qcnt = 0; $it = do { local $DBIx::Class::ResultSourceHandle::thaw_schema = $schema; dclone ($it) }; is ($qcnt, 0, 'No queries on rs/pager freeze/thaw'); is( $it->pager->entries_on_this_page, 1, "entries_on_this_page ok for page 2, even though underlying count changed" ); is ($qcnt, 0, 'No count fired on pre-existing total count'); done_testing; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/747mssql_ado.t����������������������������������������������������������������0000644�0001750�0001750�00000025453�14240132261�015763� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use Try::Tiny; use DBIx::Class::Optional::Dependencies (); use lib qw(t/lib); use DBICTest; plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_mssql_ado') unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_mssql_ado'); # Example DSN (from frew): # dbi:ADO:PROVIDER=sqlncli10;SERVER=tcp:172.24.2.10;MARS Connection=True;Initial Catalog=CIS;UID=cis_web;PWD=...;DataTypeCompatibility=80; my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSSQL_ADO_${_}" } qw/DSN USER PASS/}; plan skip_all => 'Set $ENV{DBICTEST_MSSQL_ADO_DSN}, _USER and _PASS to run this test' unless ($dsn && $user); DBICTest::Schema->load_classes(qw/VaryingMAX ArtistGUID/); my %binstr = ( 'small' => join('', map { chr($_) } ( 1 .. 127 )) ); $binstr{'large'} = $binstr{'small'} x 1024; my $maxloblen = length $binstr{'large'}; my $schema = DBICTest::Schema->connect($dsn, $user, $pass, { auto_savepoint => 1, LongReadLen => $maxloblen, }); $schema->storage->ensure_connected; isa_ok($schema->storage, 'DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server'); my $ver = $schema->storage->_server_info->{normalized_dbms_version}; ok $ver, 'can introspect DBMS version'; # 2005 and greater is $schema->storage->sql_limit_dialect, ($ver >= 9 ? 'RowNumberOver' : 'Top'), 'correct limit dialect detected'; $schema->storage->dbh_do (sub { my ($storage, $dbh) = @_; try { local $^W = 0; $dbh->do("DROP TABLE artist") }; $dbh->do(<<'SQL'); CREATE TABLE artist ( artistid INT IDENTITY NOT NULL, name VARCHAR(100), rank INT NOT NULL DEFAULT '13', charfield CHAR(10) NULL, primary key(artistid) ) SQL }); $schema->storage->dbh_do (sub { my ($storage, $dbh) = @_; try { local $^W = 0; $dbh->do("DROP TABLE artist_guid") }; $dbh->do(<<"SQL"); CREATE TABLE artist_guid ( artistid UNIQUEIDENTIFIER NOT NULL, name VARCHAR(100), rank INT NULL, charfield CHAR(10) NULL, a_guid UNIQUEIDENTIFIER, primary key(artistid) ) SQL }); my $have_max = $ver >= 9; # 2005 and greater $schema->storage->dbh_do (sub { my ($storage, $dbh) = @_; try { local $^W = 0; $dbh->do("DROP TABLE varying_max_test") }; $dbh->do(" CREATE TABLE varying_max_test ( id INT IDENTITY NOT NULL, " . ($have_max ? " varchar_max VARCHAR(MAX), nvarchar_max NVARCHAR(MAX), varbinary_max VARBINARY(MAX), " : " varchar_max TEXT, nvarchar_max NTEXT, varbinary_max IMAGE, ") . " primary key(id) )"); }); my $ars = $schema->resultset('Artist'); my $new = $ars->create({ name => 'foo' }); ok($new->artistid > 0, 'Auto-PK worked'); # make sure select works my $found = $schema->resultset('Artist')->search({ name => 'foo' })->first; is $found->artistid, $new->artistid, 'search works'; # test large column list in select $found = $schema->resultset('Artist')->search({ name => 'foo' }, { select => ['artistid', 'name', map \"'foo' foo_$_", 0..50], as => ['artistid', 'name', map "foo_$_", 0..50], })->first; is $found->artistid, $new->artistid, 'select with big column list'; is $found->get_column('foo_50'), 'foo', 'last item in big column list'; # create a few more rows for (1..12) { $schema->resultset('Artist')->create({ name => 'Artist ' . $_ }); } # test multiple active cursors my $rs1 = $schema->resultset('Artist')->search({}, { order_by => 'artistid' }); my $rs2 = $schema->resultset('Artist')->search({}, { order_by => 'name' }); while ($rs1->next) { ok try { $rs2->next }, 'multiple active cursors'; } # test bug where ADO blows up if the first bindparam is shorter than the second is $schema->resultset('Artist')->search({ artistid => 2 })->first->name, 'Artist 1', 'short bindparam'; is $schema->resultset('Artist')->search({ artistid => 13 })->first->name, 'Artist 12', 'longer bindparam'; # test explicit key spec $new = $ars->create ({ name => 'bar', artistid => 66 }); is($new->artistid, 66, 'Explicit PK worked'); $new->discard_changes; is($new->artistid, 66, 'Explicit PK assigned'); # test basic transactions $schema->txn_do(sub { $ars->create({ name => 'transaction_commit' }); }); ok($ars->search({ name => 'transaction_commit' })->first, 'transaction committed'); $ars->search({ name => 'transaction_commit' })->delete, throws_ok { $schema->txn_do(sub { $ars->create({ name => 'transaction_rollback' }); die 'rolling back'; }); } qr/rolling back/, 'rollback executed'; is $ars->search({ name => 'transaction_rollback' })->first, undef, 'transaction rolled back'; # test two-phase commit and inner transaction rollback from nested transactions $schema->txn_do(sub { $ars->create({ name => 'in_outer_transaction' }); $schema->txn_do(sub { $ars->create({ name => 'in_inner_transaction' }); }); ok($ars->search({ name => 'in_inner_transaction' })->first, 'commit from inner transaction visible in outer transaction'); throws_ok { $schema->txn_do(sub { $ars->create({ name => 'in_inner_transaction_rolling_back' }); die 'rolling back inner transaction'; }); } qr/rolling back inner transaction/, 'inner transaction rollback executed'; }); ok($ars->search({ name => 'in_outer_transaction' })->first, 'commit from outer transaction'); ok($ars->search({ name => 'in_inner_transaction' })->first, 'commit from inner transaction'); is $ars->search({ name => 'in_inner_transaction_rolling_back' })->first, undef, 'rollback from inner transaction'; $ars->search({ name => 'in_outer_transaction' })->delete; $ars->search({ name => 'in_inner_transaction' })->delete; # test populate lives_ok (sub { my @pop; for (1..2) { push @pop, { name => "Artist_$_" }; } $ars->populate (\@pop); }); # test populate with explicit key lives_ok (sub { my @pop; for (1..2) { push @pop, { name => "Artist_expkey_$_", artistid => 100 + $_ }; } $ars->populate (\@pop); }); # count what we did so far is ($ars->count, 18, 'Simple count works'); # test empty insert my $current_artistid = $ars->search({}, { select => [ { max => 'artistid' } ], as => ['artistid'] })->first->artistid; my $row; lives_ok { $row = $ars->create({}) } 'empty insert works'; $row->discard_changes; is $row->artistid, $current_artistid+1, 'empty insert generated correct PK'; # test that autoinc column still works after empty insert $row = $ars->create({ name => 'after_empty_insert' }); is $row->artistid, $current_artistid+2, 'autoincrement column functional aftear empty insert'; my $rs = $schema->resultset('VaryingMAX'); foreach my $size (qw/small large/) { local $schema->storage->{debug} = 0 if $size eq 'large'; my $str = $binstr{$size}; my $row; lives_ok { $row = $rs->create({ varchar_max => $str, nvarchar_max => $str, varbinary_max => $str }); } "created $size VARXXX(MAX) LOBs"; lives_ok { $row->discard_changes; } 're-selected just-inserted LOBs'; cmp_ok try { $row->varchar_max }, 'eq', $str, 'VARCHAR(MAX) matches'; cmp_ok try { $row->nvarchar_max }, 'eq', $str, 'NVARCHAR(MAX) matches'; cmp_ok try { $row->varbinary_max }, 'eq', $str, 'VARBINARY(MAX) matches'; } # test regular blobs try { local $^W = 0; $schema->storage->dbh->do('DROP TABLE bindtype_test') }; $schema->storage->dbh->do(qq[ CREATE TABLE bindtype_test ( id INT IDENTITY NOT NULL PRIMARY KEY, bytea INT NULL, blob IMAGE NULL, clob TEXT NULL, a_memo NTEXT NULL ) ],{ RaiseError => 1, PrintError => 1 }); $rs = $schema->resultset('BindType'); my $id = 0; foreach my $type (qw( blob clob a_memo )) { foreach my $size (qw( small large )) { $id++; lives_ok { $rs->create( { 'id' => $id, $type => $binstr{$size} } ) } "inserted $size $type without dying" or next; my $from_db = eval { $rs->find($id)->$type } || ''; diag $@ if $@; ok($from_db eq $binstr{$size}, "verified inserted $size $type" ) or do { my $hexdump = sub { join '', map sprintf('%02X', ord), split //, shift }; diag 'Got: ', "\n", substr($hexdump->($from_db),0,255), '...', substr($hexdump->($from_db),-255); diag 'Size: ', length($from_db); diag 'Expected Size: ', length($binstr{$size}); diag 'Expected: ', "\n", substr($hexdump->($binstr{$size}), 0, 255), "...", substr($hexdump->($binstr{$size}),-255); }; } } # test IMAGE update lives_ok { $rs->search({ id => 0 })->update({ blob => $binstr{small} }); } 'updated IMAGE to small binstr without dying'; lives_ok { $rs->search({ id => 0 })->update({ blob => $binstr{large} }); } 'updated IMAGE to large binstr without dying'; # test GUIDs lives_ok { $row = $schema->resultset('ArtistGUID')->create({ name => 'mtfnpy' }) } 'created a row with a GUID'; ok( eval { $row->artistid }, 'row has GUID PK col populated', ); diag $@ if $@; my $guid = try { $row->artistid }||''; ok(($guid !~ /^{.*?}\z/), 'GUID not enclosed in braces') or diag "GUID is: $guid"; ok( eval { $row->a_guid }, 'row has a GUID col with auto_nextval populated', ); diag $@ if $@; my $row_from_db = $schema->resultset('ArtistGUID') ->search({ name => 'mtfnpy' })->first; is try { $row_from_db->artistid }, try { $row->artistid }, 'PK GUID round trip (via ->search->next)'; is try { $row_from_db->a_guid }, try { $row->a_guid }, 'NON-PK GUID round trip (via ->search->next)'; $row_from_db = try { $schema->resultset('ArtistGUID') ->find($row->artistid) }; is try { $row_from_db->artistid }, try { $row->artistid }, 'PK GUID round trip (via ->find)'; is try { $row_from_db->a_guid }, try { $row->a_guid }, 'NON-PK GUID round trip (via ->find)'; ($row_from_db) = $schema->resultset('ArtistGUID') ->search({ name => 'mtfnpy' })->all; is try { $row_from_db->artistid }, try { $row->artistid }, 'PK GUID round trip (via ->search->all)'; is try { $row_from_db->a_guid }, try { $row->a_guid }, 'NON-PK GUID round trip (via ->search->all)'; lives_ok { $row = $schema->resultset('ArtistGUID')->create({ artistid => '70171270-4822-4450-81DF-921F99BA3C06', name => 'explicit_guid', }); } 'created a row with explicit PK GUID'; is try { $row->artistid }, '70171270-4822-4450-81DF-921F99BA3C06', 'row has correct PK GUID'; lives_ok { $row->update({ artistid => '70171270-4822-4450-81DF-921F99BA3C07' }); } "updated row's PK GUID"; is try { $row->artistid }, '70171270-4822-4450-81DF-921F99BA3C07', 'row has correct PK GUID'; lives_ok { $row->delete; } 'deleted the row'; lives_ok { $schema->resultset('ArtistGUID')->populate([{ artistid => '70171270-4822-4450-81DF-921F99BA3C06', name => 'explicit_guid', }]); } 'created a row with explicit PK GUID via ->populate in void context'; done_testing; # clean up our mess END { local $SIG{__WARN__} = sub {}; if (my $dbh = try { $schema->storage->_dbh }) { (try { $dbh->do("DROP TABLE $_") }) for qw/artist artist_guid varying_max_test bindtype_test/; } undef $schema; } # vim:sw=2 sts=2 ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/76joins.t���������������������������������������������������������������������0000644�0001750�0001750�00000007721�14240132261�015034� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); my $rs = $schema->resultset("CD")->search( { 'year' => 2001, 'artist.name' => 'Caterwauler McCrae' }, { from => [ { 'me' => 'cd' }, [ { artist => 'artist' }, { 'me.artist' => { -ident => 'artist.artistid' } }, ], ] } ); is( $rs + 0, 1, "Single record in resultset"); is($rs->first->title, 'Forkful of bees', 'Correct record returned'); $rs = $schema->resultset("CD")->search( { 'year' => 2001, 'artist.name' => 'Caterwauler McCrae' }, { join => 'artist' }); is( $rs + 0, 1, "Single record in resultset"); is($rs->first->title, 'Forkful of bees', 'Correct record returned'); $rs = $schema->resultset("CD")->search( { 'artist.name' => 'We Are Goth', 'liner_notes.notes' => 'Kill Yourself!' }, { join => [ qw/artist liner_notes/ ] }); is( $rs + 0, 1, "Single record in resultset"); is($rs->first->title, 'Come Be Depressed With Us', 'Correct record returned'); # when using join attribute, make sure slice()ing all objects has same count as all() $rs = $schema->resultset("CD")->search( { 'artist' => 1 }, { join => [qw/artist/], order_by => 'artist.name' } ); is( scalar $rs->all, scalar $rs->slice(0, $rs->count - 1), 'slice() with join has same count as all()' ); ok(!$rs->slice($rs->count+1000, $rs->count+1002)->count, 'Slicing beyond end of rs returns a zero count'); $rs = $schema->resultset("Artist")->search( { 'liner_notes.notes' => 'Kill Yourself!' }, { join => { 'cds' => 'liner_notes' } }); is( $rs->count, 1, "Single record in resultset"); is($rs->first->name, 'We Are Goth', 'Correct record returned'); { $schema->populate('Artist', [ [ qw/artistid name/ ], [ 4, 'Another Boy Band' ], ]); $schema->populate('CD', [ [ qw/cdid artist title year/ ], [ 6, 2, "Greatest Hits", 2001 ], [ 7, 4, "Greatest Hits", 2005 ], [ 8, 4, "BoyBandBlues", 2008 ], ]); $schema->populate('TwoKeys', [ [ qw/artist cd/ ], [ 2, 4 ], [ 2, 6 ], [ 4, 7 ], [ 4, 8 ], ]); my $cd_count = sub { $schema->resultset("CD")->count }; my $tk_count = sub { $schema->resultset("TwoKeys")->count }; is($cd_count->(), 8, '8 rows in table cd'); is($tk_count->(), 7, '7 rows in table twokeys'); my $artist1_rs = $schema->resultset("CD")->search( { 'artist.name' => 'Caterwauler McCrae' }, { join => [qw/artist/]} ); my $artist2_rs = $schema->resultset("CD")->search( { 'artist.name' => 'Random Boy Band' }, { join => [qw/artist/]} ); is( $artist1_rs->count, 3, '3 Caterwauler McCrae CDs' ); ok( $artist1_rs->delete, 'Successfully deleted 3 CDs' ); is( $artist1_rs->count, 0, '0 Caterwauler McCrae CDs' ); is( $artist2_rs->count, 2, '3 Random Boy Band CDs' ); ok( $artist2_rs->update( { 'artist' => 1 } ) ); is( $artist2_rs->count, 0, '0 Random Boy Band CDs' ); is( $artist1_rs->count, 2, '2 Caterwauler McCrae CDs' ); # test update on multi-column-pk my $tk1_rs = $schema->resultset("TwoKeys")->search( { 'artist.name' => { like => '%Boy Band' }, 'cd.title' => 'Greatest Hits', }, { join => [qw/artist cd/] } ); my $tk2_rs = $schema->resultset("TwoKeys")->search( { 'artist.name' => 'Caterwauler McCrae' }, { join => [qw/artist/]} ); is( $tk2_rs->count, 2, 'TwoKeys count == 2' ); is( $tk1_rs->count, 2, 'TwoKeys count == 2' ); ok( $tk1_rs->update( { artist => 1 } ) ); is( $tk1_rs->count, 0, 'TwoKeys count == 0' ); is( $tk2_rs->count, 4, '2 Caterwauler McCrae CDs' ); ok( $tk2_rs->delete, 'Successfully deleted 4 CDs' ); is($cd_count->(), 5, '5 rows in table cd'); is($tk_count->(), 3, '3 rows in table twokeys'); } done_testing; �����������������������������������������������DBIx-Class-0.082843/t/04_c3_mro.t�������������������������������������������������������������������0000644�0001750�0001750�00000004021�14240132261�015210� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use warnings; use strict; use Test::More; use lib qw(t/lib); use DBICTest; # do not remove even though it is not used (pulls in MRO::Compat if needed) { package AAA; use base "DBIx::Class::Core"; } { package BBB; use base 'AAA'; #Injecting a direct parent. __PACKAGE__->inject_base( __PACKAGE__, 'AAA' ); } { package CCC; use base 'AAA'; #Injecting an indirect parent. __PACKAGE__->inject_base( __PACKAGE__, 'DBIx::Class::Core' ); } eval { mro::get_linear_isa('BBB'); }; ok (! $@, "Correctly skipped injecting a direct parent of class BBB"); eval { mro::get_linear_isa('CCC'); }; ok (! $@, "Correctly skipped injecting an indirect parent of class BBB"); use DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server; is_deeply ( mro::get_linear_isa('DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server'), [qw/ DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server DBIx::Class::Storage::DBI::Sybase DBIx::Class::Storage::DBI::MSSQL DBIx::Class::Storage::DBI::UniqueIdentifier DBIx::Class::Storage::DBI::IdentityInsert DBIx::Class::Storage::DBI DBIx::Class::Storage::DBIHacks DBIx::Class::Storage DBIx::Class DBIx::Class::Componentised Class::C3::Componentised DBIx::Class::AccessorGroup Class::Accessor::Grouped /], 'Correctly ordered ISA of DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server' ); my $storage = DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server->new; $storage->connect_info(['dbi:SQLite::memory:']); # determine_driver's init() connects for this subclass $storage->_determine_driver; is ( $storage->can('sql_limit_dialect'), 'DBIx::Class::Storage::DBI::MSSQL'->can('sql_limit_dialect'), 'Correct method picked' ); if ($] >= 5.010) { ok (! $INC{'Class/C3.pm'}, 'No Class::C3 loaded on perl 5.10+'); # Class::C3::Componentised loads MRO::Compat unconditionally to satisfy # the assumption that once Class::C3::X is loaded, so is Class::C3 #ok (! $INC{'MRO/Compat.pm'}, 'No MRO::Compat loaded on perl 5.10+'); } done_testing; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/39load_namespaces_1.t���������������������������������������������������������0000644�0001750�0001750�00000002360�14240132261�017241� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; # do not remove even though it is not used my $warnings; eval { local $SIG{__WARN__} = sub { $warnings .= shift }; package DBICNSTest; use base qw/DBIx::Class::Schema/; __PACKAGE__->load_namespaces; }; ok(!$@, 'load_namespaces doesnt die') or diag $@; like($warnings, qr/load_namespaces found ResultSet class 'DBICNSTest::ResultSet::C' with no corresponding Result class/, 'Found warning about extra ResultSet classes'); like($warnings, qr/load_namespaces found ResultSet class 'DBICNSTest::ResultSet::D' that does not subclass DBIx::Class::ResultSet/, 'Found warning about ResultSets with incorrect subclass'); my $source_a = DBICNSTest->source('A'); isa_ok($source_a, 'DBIx::Class::ResultSource::Table'); my $rset_a = DBICNSTest->resultset('A'); isa_ok($rset_a, 'DBICNSTest::ResultSet::A'); my $source_b = DBICNSTest->source('B'); isa_ok($source_b, 'DBIx::Class::ResultSource::Table'); my $rset_b = DBICNSTest->resultset('B'); isa_ok($rset_b, 'DBIx::Class::ResultSet'); for my $moniker (qw/A B/) { my $class = "DBICNSTest::Result::$moniker"; ok(!defined($class->result_source_instance->source_name), "Source name of $moniker not defined"); } done_testing; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/73oracle_blob.t���������������������������������������������������������������0000644�0001750�0001750�00000014605�14240132261�016151� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::Exception; use Test::More; use Sub::Name; use Try::Tiny; use DBIx::Class::Optional::Dependencies (); use lib qw(t/lib); use DBICTest::Schema::BindType; BEGIN { DBICTest::Schema::BindType->add_columns( 'blb2' => { data_type => 'blob', is_nullable => 1, }, 'clb2' => { data_type => 'clob', is_nullable => 1, } ); } use DBICTest; my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_ORA_${_}" } qw/DSN USER PASS/}; plan skip_all => 'Set $ENV{DBICTEST_ORA_DSN}, _USER and _PASS to run this test.' unless ($dsn && $user && $pass); plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_oracle') unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_oracle'); $ENV{NLS_SORT} = "BINARY"; $ENV{NLS_COMP} = "BINARY"; $ENV{NLS_LANG} = "AMERICAN"; my $v = do { my $si = DBICTest::Schema->connect($dsn, $user, $pass)->storage->_server_info; $si->{normalized_dbms_version} or die "Unparseable Oracle server version: $si->{dbms_version}\n"; }; ########## # the recyclebin (new for 10g) sometimes comes in the way my $on_connect_sql = $v >= 10 ? ["ALTER SESSION SET recyclebin = OFF"] : []; # iterate all tests on following options my @tryopt = ( { on_connect_do => $on_connect_sql }, { quote_char => '"', on_connect_do => $on_connect_sql }, ); # keep a database handle open for cleanup my $dbh; my $schema; for my $opt (@tryopt) { my $schema = DBICTest::Schema->connect($dsn, $user, $pass, $opt); $dbh = $schema->storage->dbh; my $q = $schema->storage->sql_maker->quote_char || ''; do_creates($dbh, $q); _run_blob_tests($schema, $opt); } sub _run_blob_tests { SKIP: { my ($schema, $opt) = @_; my %binstr = ( 'small' => join('', map { chr($_) } ( 1 .. 127 )) ); $binstr{'large'} = $binstr{'small'} x 1024; my $maxloblen = (length $binstr{'large'}) + 5; note "Localizing LongReadLen to $maxloblen to avoid truncation of test data"; local $dbh->{'LongReadLen'} = $maxloblen; my $rs = $schema->resultset('BindType'); if ($DBD::Oracle::VERSION eq '1.23') { throws_ok { $rs->create({ id => 1, blob => $binstr{large} }) } qr/broken/, 'throws on blob insert with DBD::Oracle == 1.23'; skip 'buggy BLOB support in DBD::Oracle 1.23', 1; } my $q = $schema->storage->sql_maker->quote_char || ''; local $TODO = 'Something is confusing column bindtype assignment when quotes are active' . ': https://rt.cpan.org/Ticket/Display.html?id=64206' if $q; my $id; foreach my $size (qw( small large )) { $id++; local $schema->storage->{debug} = 0 if $size eq 'large'; my $str = $binstr{$size}; lives_ok { $rs->create( { 'id' => $id, blob => "blob:$str", clob => "clob:$str", blb2 => "blb2:$str", clb2 => "clb2:$str" } ) } "inserted $size without dying"; my %kids = %{$schema->storage->_dbh->{CachedKids}}; my @objs = $rs->search({ blob => "blob:$str", clob => "clob:$str" })->all; is_deeply ( $schema->storage->_dbh->{CachedKids}, \%kids, 'multi-part LOB equality query was not cached', ) if $size eq 'large'; is @objs, 1, 'One row found matching on both LOBs'; ok (try { $objs[0]->blob }||'' eq "blob:$str", 'blob inserted/retrieved correctly'); ok (try { $objs[0]->clob }||'' eq "clob:$str", 'clob inserted/retrieved correctly'); ok (try { $objs[0]->clb2 }||'' eq "clb2:$str", "clb2 inserted correctly"); ok (try { $objs[0]->blb2 }||'' eq "blb2:$str", "blb2 inserted correctly"); { local $TODO = '-like comparison on blobs not tested before ora 10 (fails on 8i)' if $schema->storage->_server_info->{normalized_dbms_version} < 10; lives_ok { @objs = $rs->search({ clob => { -like => 'clob:%' } })->all; ok (@objs, 'rows found matching CLOB with a LIKE query'); } 'Query with like on blob succeeds'; } ok(my $subq = $rs->search( { blob => "blob:$str", clob => "clob:$str" }, { from => \ "(SELECT * FROM ${q}bindtype_test${q} WHERE ${q}id${q} != ?) ${q}me${q}", bind => [ [ undef => 12345678 ] ], } )->get_column('id')->as_query); @objs = $rs->search({ id => { -in => $subq } })->all; is (@objs, 1, 'One row found matching on both LOBs as a subquery'); lives_ok { $rs->search({ id => $id, blob => "blob:$str", clob => "clob:$str" }) ->update({ blob => 'updated blob', clob => 'updated clob', clb2 => 'updated clb2', blb2 => 'updated blb2' }); } 'blob UPDATE with blobs in WHERE clause survived'; @objs = $rs->search({ blob => "updated blob", clob => 'updated clob' })->all; is @objs, 1, 'found updated row'; ok (try { $objs[0]->blob }||'' eq "updated blob", 'blob updated/retrieved correctly'); ok (try { $objs[0]->clob }||'' eq "updated clob", 'clob updated/retrieved correctly'); ok (try { $objs[0]->clb2 }||'' eq "updated clb2", "clb2 updated correctly"); ok (try { $objs[0]->blb2 }||'' eq "updated blb2", "blb2 updated correctly"); lives_ok { $rs->search({ id => $id }) ->update({ blob => 're-updated blob', clob => 're-updated clob' }); } 'blob UPDATE without blobs in WHERE clause survived'; @objs = $rs->search({ blob => 're-updated blob', clob => 're-updated clob' })->all; is @objs, 1, 'found updated row'; ok (try { $objs[0]->blob }||'' eq 're-updated blob', 'blob updated/retrieved correctly'); ok (try { $objs[0]->clob }||'' eq 're-updated clob', 'clob updated/retrieved correctly'); lives_ok { $rs->search({ blob => "re-updated blob", clob => "re-updated clob" }) ->delete; } 'blob DELETE with WHERE clause survived'; @objs = $rs->search({ blob => "re-updated blob", clob => 're-updated clob' })->all; is @objs, 0, 'row deleted successfully'; } } do_clean ($dbh); } done_testing; sub do_creates { my ($dbh, $q) = @_; do_clean($dbh); $dbh->do("CREATE TABLE ${q}bindtype_test${q} (${q}id${q} integer NOT NULL PRIMARY KEY, ${q}bytea${q} integer NULL, ${q}blob${q} blob NULL, ${q}blb2${q} blob NULL, ${q}clob${q} clob NULL, ${q}clb2${q} clob NULL, ${q}a_memo${q} integer NULL)"); } # clean up our mess sub do_clean { my $dbh = shift || return; for my $q ('', '"') { my @clean = ( "DROP TABLE ${q}bindtype_test${q}", ); eval { $dbh -> do ($_) } for @clean; } } END { if ($dbh) { local $SIG{__WARN__} = sub {}; do_clean($dbh); undef $dbh; } } ���������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/row/��������������������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�014171� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/row/inflate_result.t����������������������������������������������������������0000644�0001750�0001750�00000004620�14240132261�017357� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use warnings; use strict; use Test::More; use lib qw(t/lib); use DBICTest; package My::Schema::Result::User; use strict; use warnings; use base qw/DBIx::Class::Core/; ### Define what our admin class is, for ensure_class_loaded() my $admin_class = __PACKAGE__ . '::Admin'; __PACKAGE__->table('users'); __PACKAGE__->add_columns( user_id => { retrieve_on_insert => 1 }, qw( email password firstname lastname active admin ), ); __PACKAGE__->set_primary_key('user_id'); sub inflate_result { my $self = shift; my $ret = $self->next::method(@_); if ( $ret->admin ) { ### If this is an admin, rebless for extra functions $self->ensure_class_loaded($admin_class); bless $ret, $admin_class; } return $ret; } sub hello { return "I am a regular user."; } package My::Schema::Result::User::Admin; use strict; use warnings; use base qw/My::Schema::Result::User/; # This line is important __PACKAGE__->table('users'); sub hello { return "I am an admin."; } sub do_admin_stuff { return "I am doing admin stuff"; } package My::Schema; use base qw/DBIx::Class::Schema/; My::Schema->register_class( Admin => 'My::Schema::Result::User::Admin' ); My::Schema->register_class( User => 'My::Schema::Result::User' ); 1; package main; my $user_data = { email => 'someguy@place.com', password => 'pass1', admin => 0 }; my $admin_data = { email => 'someadmin@adminplace.com', password => 'pass2', admin => 1 }; ok( my $schema = My::Schema->connect(DBICTest->_database) ); ok( $schema->storage->dbh->do( "create table users (user_id, email, password, firstname, lastname, active, admin)" ) ); { my $user = $schema->resultset('User')->create($user_data); my $admin = $schema->resultset('User')->create($admin_data); is( ref $user, 'My::Schema::Result::User' ); local $TODO = 'New objects should also be inflated'; is( ref $admin, 'My::Schema::Result::User::Admin' ); } my $user = $schema->resultset('User')->single($user_data); my $admin = $schema->resultset('User')->single($admin_data); is( ref $user, 'My::Schema::Result::User' ); is( ref $admin, 'My::Schema::Result::User::Admin' ); is( $user->password, 'pass1' ); is( $admin->password, 'pass2' ); is( $user->hello, 'I am a regular user.' ); is( $admin->hello, 'I am an admin.' ); ok( !$user->can('do_admin_stuff') ); ok( $admin->can('do_admin_stuff') ); done_testing; ����������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/row/copy_with_extra_selection.t�����������������������������������������������0000644�0001750�0001750�00000000766�14240132261�021623� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); my $cd = $schema->resultset('CD')->search({}, { '+columns' => { avg_year => $schema->resultset('CD')->get_column('year')->func_rs('avg')->as_query }, order_by => 'cdid', })->next; my $ccd = $cd->copy({ cdid => 5_000_000, artist => 2 }); cmp_ok( $ccd->id, '!=', $cd->id, 'IDs differ' ); is( $ccd->title, $cd->title, 'Title same on copied object', ); done_testing; ����������DBIx-Class-0.082843/t/row/filter_column.t�����������������������������������������������������������0000644�0001750�0001750�00000030714�14240132261�017204� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use lib qw(t/lib); use DBICTest; my $from_storage_ran = 0; my $to_storage_ran = 0; my $schema = DBICTest->init_schema( no_populate => 1 ); DBICTest::Schema::Artist->load_components(qw(FilterColumn InflateColumn)); DBICTest::Schema::Artist->filter_column(charfield => { filter_from_storage => sub { $from_storage_ran++; defined $_[1] ? $_[1] * 2 : undef }, filter_to_storage => sub { $to_storage_ran++; defined $_[1] ? $_[1] / 2 : undef }, }); Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO; my $artist = $schema->resultset('Artist')->create( { charfield => 20 } ); # this should be using the cursor directly, no inflation/processing of any sort my ($raw_db_charfield) = $schema->resultset('Artist') ->search ($artist->ident_condition) ->get_column('charfield') ->_resultset ->cursor ->next; is ($raw_db_charfield, 10, 'INSERT: correctly unfiltered on insertion'); for my $reloaded (0, 1) { my $test = $reloaded ? 'reloaded' : 'stored'; $artist->discard_changes if $reloaded; is( $artist->charfield , 20, "got $test filtered charfield" ); } $artist->update; $artist->discard_changes; is( $artist->charfield , 20, "got filtered charfield" ); $artist->update ({ charfield => 40 }); ($raw_db_charfield) = $schema->resultset('Artist') ->search ($artist->ident_condition) ->get_column('charfield') ->_resultset ->cursor ->next; is ($raw_db_charfield, 20, 'UPDATE: correctly unflitered on update'); $artist->discard_changes; $artist->charfield(40); ok( !$artist->is_column_changed('charfield'), 'column is not dirty after setting the same value' ); MC: { my $cd = $schema->resultset('CD')->create({ artist => { charfield => 20 }, title => 'fun time city!', year => 'forevertime', }); ($raw_db_charfield) = $schema->resultset('Artist') ->search ($cd->artist->ident_condition) ->get_column('charfield') ->_resultset ->cursor ->next; is $raw_db_charfield, 10, 'artist charfield gets correctly unfiltered w/ MC'; is $cd->artist->charfield, 20, 'artist charfield gets correctly filtered w/ MC'; } CACHE_TEST: { my $expected_from = $from_storage_ran; my $expected_to = $to_storage_ran; # ensure we are creating a fresh obj $artist = $schema->resultset('Artist')->single($artist->ident_condition); is $from_storage_ran, $expected_from, 'from has not run yet'; is $to_storage_ran, $expected_to, 'to has not run yet'; $artist->charfield; cmp_ok ( $artist->get_filtered_column('charfield'), '!=', $artist->get_column('charfield'), 'filter/unfilter differ' ); is $from_storage_ran, ++$expected_from, 'from ran once, therefor caches'; is $to_storage_ran, $expected_to, 'to did not run'; $artist->charfield(6); is $from_storage_ran, $expected_from, 'from did not run'; is $to_storage_ran, ++$expected_to, 'to ran once'; ok ($artist->is_column_changed ('charfield'), 'Column marked as dirty'); $artist->charfield; is $from_storage_ran, $expected_from, 'from did not run'; is $to_storage_ran, $expected_to, 'to did not run'; $artist->update; $artist->set_column(charfield => 3); ok (! $artist->is_column_changed ('charfield'), 'Column not marked as dirty on same set_column value'); is ($artist->charfield, '6', 'Column set properly (cache blown)'); is $from_storage_ran, ++$expected_from, 'from ran once (set_column blew cache)'; is $to_storage_ran, $expected_to, 'to did not run'; $artist->charfield(6); ok (! $artist->is_column_changed ('charfield'), 'Column not marked as dirty on same accessor-set value'); is ($artist->charfield, '6', 'Column set properly'); is $from_storage_ran, $expected_from, 'from did not run'; is $to_storage_ran, ++$expected_to, 'to did run once (call in to set_column)'; $artist->store_column(charfield => 4); ok (! $artist->is_column_changed ('charfield'), 'Column not marked as dirty on differing store_column value'); is ($artist->charfield, '8', 'Cache properly blown'); is $from_storage_ran, ++$expected_from, 'from did not run'; is $to_storage_ran, $expected_to, 'to did not run'; $artist->update({ charfield => undef }); is $from_storage_ran, $expected_from, 'from did not run'; is $to_storage_ran, ++$expected_to, 'to did run'; $artist->discard_changes; is ( $artist->get_column('charfield'), undef, 'Got back null' ); is ( $artist->charfield, undef, 'Got back null through filter' ); is $from_storage_ran, ++$expected_from, 'from did run'; is $to_storage_ran, $expected_to, 'to did not run'; ok ! $artist->is_changed, 'object clean'; is_deeply { $artist->get_dirty_columns }, {}, 'dirty columns as expected', ; is $from_storage_ran, $expected_from, 'from did not run'; is $to_storage_ran, $expected_to, 'to did not run'; $artist->charfield(42); is $from_storage_ran, $expected_from, 'from did not run'; is $to_storage_ran, ++$expected_to, 'to ran once, determining dirtyness'; is $artist->charfield, 42, 'setting once works'; ok $artist->is_column_changed('charfield'), 'column changed'; ok $artist->is_changed, 'object changed'; is_deeply { $artist->get_dirty_columns }, { charfield => 21 }, 'dirty columns as expected', ; is $from_storage_ran, $expected_from, 'from did not run'; is $to_storage_ran, $expected_to, 'to did not run'; $artist->charfield(66); is $artist->charfield, 66, 'setting twice works'; ok $artist->is_column_changed('charfield'), 'column changed'; ok $artist->is_changed, 'object changed'; is $from_storage_ran, $expected_from, 'from did not run'; is $to_storage_ran, $expected_to, 'to did not run a second time on dirty column'; is_deeply { $artist->get_dirty_columns }, { charfield => 33 }, 'dirty columns as expected', ; is $from_storage_ran, $expected_from, 'from did not run'; is $to_storage_ran, ++$expected_to, 'to did run producing a new dirty_columns set'; is_deeply { $artist->get_dirty_columns }, { charfield => 33 }, 'dirty columns still as expected', ; is $from_storage_ran, $expected_from, 'from did not run'; is $to_storage_ran, $expected_to, 'to did not run on re-invoked get_dirty_columns'; $artist->update; is $artist->charfield, 66, 'value still there'; is $from_storage_ran, $expected_from, 'from did not run'; is $to_storage_ran, $expected_to, 'to did not run '; $artist->discard_changes; is $from_storage_ran, $expected_from, 'from did not run after discard_changes'; is $to_storage_ran, $expected_to, 'to did not run after discard_changes'; is $artist->charfield, 66, 'value still there post reload'; is $from_storage_ran, ++$expected_from, 'from did run'; is $to_storage_ran, $expected_to, 'to did not run'; } # test in-memory operations for my $artist_maker ( sub { $schema->resultset('Artist')->new({ charfield => 42 }) }, sub { my $art = $schema->resultset('Artist')->new({}); $art->charfield(42); $art }, ) { $schema->resultset('Artist')->delete; my $expected_from = $from_storage_ran; my $expected_to = $to_storage_ran; my $artist = $artist_maker->(); is $from_storage_ran, $expected_from, 'from has not run yet'; is $to_storage_ran, $expected_to, 'to has not run yet'; ok( ! $artist->has_column_loaded('artistid'), 'pk not loaded' ); ok( $artist->has_column_loaded('charfield'), 'Filtered column marked as loaded under new' ); is( $artist->charfield, 42, 'Proper unfiltered value' ); is( $artist->get_column('charfield'), 21, 'Proper filtered value' ); $artist->insert; ($raw_db_charfield) = $schema->resultset('Artist') ->search ($artist->ident_condition) ->get_column('charfield') ->next; is $raw_db_charfield, 21, 'Proper value in database'; } # test literals for my $v ( \ '16', \[ '?', '16' ] ) { my $rs = $schema->resultset('Artist'); $rs->delete; my $art = $rs->new({ charfield => 10 }); $art->charfield($v); is_deeply( $art->charfield, $v); is_deeply( $art->get_filtered_column("charfield"), $v); is_deeply( $art->get_column("charfield"), $v); $art->insert; $art->discard_changes; is ($art->get_column("charfield"), 16, "Literal inserted into database properly"); is ($art->charfield, 32, "filtering still works"); $art->update({ charfield => $v }); is_deeply( $art->charfield, $v); is_deeply( $art->get_filtered_column("charfield"), $v); is_deeply( $art->get_column("charfield"), $v); $art->discard_changes; is ($art->get_column("charfield"), 16, "Literal inserted into database properly"); is ($art->charfield, 32, "filtering still works"); } IC_DIE: { throws_ok { DBICTest::Schema::Artist->inflate_column(charfield => { inflate => sub {}, deflate => sub {} } ); } qr/InflateColumn can not be used on a column with a declared FilterColumn filter/, q(Can't inflate column after filter column); DBICTest::Schema::Artist->inflate_column(name => { inflate => sub {}, deflate => sub {} } ); throws_ok { DBICTest::Schema::Artist->filter_column(name => { filter_to_storage => sub {}, filter_from_storage => sub {} }); } qr/FilterColumn can not be used on a column with a declared InflateColumn inflator/, q(Can't filter column after inflate column); } # test when we do not set both filter_from_storage/filter_to_storage DBICTest::Schema::Artist->filter_column(charfield => { filter_to_storage => sub { $to_storage_ran++; $_[1] }, }); Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO; ASYMMETRIC_TO_TEST: { # initialise value $artist->charfield(20); $artist->update; my $expected_from = $from_storage_ran; my $expected_to = $to_storage_ran; $artist->charfield(10); ok ($artist->is_column_changed ('charfield'), 'Column marked as dirty on accessor-set value'); is ($artist->charfield, '10', 'Column set properly'); is $from_storage_ran, $expected_from, 'from did not run'; is $to_storage_ran, ++$expected_to, 'to did run'; $artist->discard_changes; is ($artist->charfield, '20', 'Column set properly'); is $from_storage_ran, $expected_from, 'from did not run'; is $to_storage_ran, $expected_to, 'to did not run'; } DBICTest::Schema::Artist->filter_column(charfield => { filter_from_storage => sub { $from_storage_ran++; $_[1] }, }); Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO; ASYMMETRIC_FROM_TEST: { # initialise value $artist->charfield(23); $artist->update; my $expected_from = $from_storage_ran; my $expected_to = $to_storage_ran; $artist->charfield(13); ok ($artist->is_column_changed ('charfield'), 'Column marked as dirty on accessor-set value'); is ($artist->charfield, '13', 'Column set properly'); is $from_storage_ran, $expected_from, 'from did not run'; is $to_storage_ran, $expected_to, 'to did not run'; $artist->discard_changes; is ($artist->charfield, '23', 'Column set properly'); is $from_storage_ran, ++$expected_from, 'from did run'; is $to_storage_ran, $expected_to, 'to did not run'; } throws_ok { DBICTest::Schema::Artist->filter_column( charfield => {} ) } qr/\QAn invocation of filter_column() must specify either a filter_from_storage or filter_to_storage/, 'Correctly throws exception for empty attributes' ; FC_ON_PK_TEST: { # there are cases in the wild that autovivify stuff deep in the # colinfo guts. While this is insane, there is no alternative # so at leats make sure it keeps working... $schema->source('Artist')->column_info('artistid')->{_filter_info} ||= {}; for my $key ('', 'primary') { lives_ok { $schema->resultset('Artist')->find_or_create({ artistid => 42 }, { $key ? ( key => $key ) : () }); }; } DBICTest::Schema::Artist->filter_column(artistid => { filter_to_storage => sub { $_[1] * 100 }, filter_from_storage => sub { $_[1] - 100 }, }); for my $key ('', 'primary') { throws_ok { $schema->resultset('Artist')->find_or_create({ artistid => 42 }, { $key ? ( key => $key ) : () }); } qr/\QUnable to satisfy requested constraint 'primary', FilterColumn values not usable for column(s): 'artistid'/; } } done_testing; ����������������������������������������������������DBIx-Class-0.082843/t/row/set_extra_column.t��������������������������������������������������������0000644�0001750�0001750�00000001317�14240132261�017712� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); my $rs_with_avg = $schema->resultset('CD')->search({}, { '+columns' => { avg_year => $schema->resultset('CD')->get_column('year')->func_rs('avg')->as_query }, order_by => 'cdid', }); for my $in_storage (1, 0) { my $cd = $rs_with_avg->first; ok ! $cd->is_column_changed('avg_year'), 'no changes'; $cd->in_storage($in_storage); ok ! $cd->is_column_changed('avg_year'), 'still no changes'; $cd->set_column( avg_year => 42 ); $cd->set_column( avg_year => 69 ); ok $cd->is_column_changed('avg_year'), 'changed'; is $cd->get_column('avg_year'), 69, 'correct value' } done_testing; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/row/find_one_has_many.t�������������������������������������������������������0000644�0001750�0001750�00000001713�14240132261�017777� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); $schema->resultset('Artist')->delete; $schema->resultset('CD')->delete; my $artist = $schema->resultset("Artist")->create({ artistid => 21, name => 'Michael Jackson', rank => 20 }); my $cd = $artist->create_related('cds', { year => 1975, title => 'Compilation from 1975' }); $schema->is_executed_sql_bind(sub { my $find_cd = $artist->find_related('cds',{title => 'Compilation from 1975'}); }, [ [ ' SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE me.artist = ? AND me.title = ? ORDER BY year ASC ', [ { dbic_colname => "me.artist", sqlt_datatype => "integer" } => 21 ], [ { dbic_colname => "me.title", sqlt_datatype => "varchar", sqlt_size => 100 } => "Compilation from 1975" ], ] ], 'find_related only uses foreign key condition once' ); done_testing; �����������������������������������������������������DBIx-Class-0.082843/t/row/pkless.t������������������������������������������������������������������0000644�0001750�0001750�00000001117�14240132261�015636� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); my $rs = $schema->resultset('NoPrimaryKey'); my $row = $rs->create ({ foo => 1, bar => 1, baz => 1 }); lives_ok (sub { $row->foo (2); }, 'Set on pkless object works'); is ($row->foo, 2, 'Column updated in-object'); dies_ok (sub { $row->update ({baz => 3}); }, 'update() fails on pk-less object'); is ($row->foo, 2, 'Column not updated by failed update()'); dies_ok (sub { $row->delete; }, 'delete() fails on pk-less object'); done_testing; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/746mssql.t��������������������������������������������������������������������0000644�0001750�0001750�00000042241�14240132261�015131� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use Try::Tiny; use DBIx::Class::Optional::Dependencies (); plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_mssql_odbc') unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_mssql_odbc'); use lib qw(t/lib); use DBICTest; my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSSQL_ODBC_${_}" } qw/DSN USER PASS/}; plan skip_all => 'Set $ENV{DBICTEST_MSSQL_ODBC_DSN}, _USER and _PASS to run this test' unless ($dsn && $user); { my $srv_ver = DBICTest::Schema->connect($dsn, $user, $pass)->storage->_server_info->{dbms_version}; ok ($srv_ver, 'Got a test server version on fresh schema: ' . ($srv_ver||'???') ); } DBICTest::Schema->load_classes('ArtistGUID'); my $schema = DBICTest::Schema->connect($dsn, $user, $pass); { no warnings 'redefine'; my $connect_count = 0; my $orig_connect = \&DBI::connect; local *DBI::connect = sub { $connect_count++; goto &$orig_connect }; $schema->storage->ensure_connected; is( $connect_count, 1, 'only one connection made'); } isa_ok( $schema->storage, 'DBIx::Class::Storage::DBI::ODBC::Microsoft_SQL_Server' ); { my $schema2 = $schema->connect (@{$schema->storage->connect_info}); ok (! $schema2->storage->connected, 'a re-connected cloned schema starts unconnected'); } $schema->storage->_dbh->disconnect; lives_ok { $schema->storage->dbh_do(sub { $_[1]->do('select 1') }) } '_ping works'; my %opts = ( use_mars => { opts => { on_connect_call => 'use_mars' } }, use_dynamic_cursors => { opts => { on_connect_call => 'use_dynamic_cursors' }, required => $schema->storage->_using_freetds ? 0 : 1, }, use_server_cursors => { opts => { on_connect_call => 'use_server_cursors' } }, plain => { opts => {}, required => 1 }, ); for my $opts_name (keys %opts) { SKIP: { my $opts = $opts{$opts_name}{opts}; $schema = DBICTest::Schema->connect($dsn, $user, $pass, $opts); try { $schema->storage->ensure_connected } catch { if ($opts{$opts_name}{required}) { die "on_connect_call option '$opts_name' is not functional: $_"; } else { skip "on_connect_call option '$opts_name' not functional in this configuration: $_", 1 ; } }; $schema->storage->dbh_do (sub { my ($storage, $dbh) = @_; eval { $dbh->do("DROP TABLE artist") }; $dbh->do(<<'SQL'); CREATE TABLE artist ( artistid INT IDENTITY NOT NULL, name VARCHAR(100), rank INT NOT NULL DEFAULT '13', charfield CHAR(10) NULL, primary key(artistid) ) SQL }); # test Auto-PK $schema->resultset('Artist')->search({ name => 'foo' })->delete; my $new = $schema->resultset('Artist')->create({ name => 'foo' }); ok(($new->artistid||0) > 0, "Auto-PK worked for $opts_name"); # Test multiple active statements SKIP: { skip 'not a multiple active statements configuration', 1 if $opts_name eq 'plain'; $schema->storage->ensure_connected; lives_ok { no warnings 'redefine'; local *DBI::connect = sub { die "NO RECONNECTS!!!" }; my $artist_rs = $schema->resultset('Artist'); $artist_rs->delete; $artist_rs->create({ name => "Artist$_" }) for (1..3); my $forward = $artist_rs->search({}, { order_by => { -asc => 'artistid' } }); my $backward = $artist_rs->search({}, { order_by => { -desc => 'artistid' } }); my @map = ( [qw/Artist1 Artist3/], [qw/Artist2 Artist2/], [qw/Artist3 Artist1/] ); my @result; while (my $forward_row = $forward->next) { my $backward_row = $backward->next; push @result, [$forward_row->name, $backward_row->name]; } is_deeply \@result, \@map, "multiple active statements in $opts_name"; $artist_rs->delete; is($artist_rs->count, 0, '$dbh still viable'); } "Multiple active statements survive $opts_name"; } # Test populate { $schema->storage->dbh_do (sub { my ($storage, $dbh) = @_; eval { $dbh->do("DROP TABLE owners") }; eval { $dbh->do("DROP TABLE books") }; $dbh->do(<<'SQL'); CREATE TABLE books ( id INT IDENTITY (1, 1) NOT NULL, source VARCHAR(100), owner INT, title VARCHAR(10), price INT NULL ) CREATE TABLE owners ( id INT IDENTITY (1, 1) NOT NULL, name VARCHAR(100), ) SQL }); lives_ok ( sub { # start a new connection, make sure rebless works my $schema = DBICTest::Schema->connect($dsn, $user, $pass, $opts); $schema->populate ('Owners', [ [qw/id name /], [qw/1 wiggle/], [qw/2 woggle/], [qw/3 boggle/], [qw/4 fRIOUX/], [qw/5 fRUE/], [qw/6 fREW/], [qw/7 fROOH/], [qw/8 fISMBoC/], [qw/9 station/], [qw/10 mirror/], [qw/11 dimly/], [qw/12 face_to_face/], [qw/13 icarus/], [qw/14 dream/], [qw/15 dyrstyggyr/], ]); }, 'populate with PKs supplied ok' ); lives_ok (sub { # start a new connection, make sure rebless works # test an insert with a supplied identity, followed by one without my $schema = DBICTest::Schema->connect($dsn, $user, $pass, $opts); for (2, 1) { my $id = $_ * 20 ; $schema->resultset ('Owners')->create ({ id => $id, name => "troglodoogle $id" }); $schema->resultset ('Owners')->create ({ name => "troglodoogle " . ($id + 1) }); } }, 'create with/without PKs ok' ); is ($schema->resultset ('Owners')->count, 19, 'owner rows really in db' ); lives_ok ( sub { # start a new connection, make sure rebless works my $schema = DBICTest::Schema->connect($dsn, $user, $pass, $opts); $schema->populate ('BooksInLibrary', [ [qw/source owner title /], [qw/Library 1 secrets0/], [qw/Library 1 secrets1/], [qw/Eatery 1 secrets2/], [qw/Library 2 secrets3/], [qw/Library 3 secrets4/], [qw/Eatery 3 secrets5/], [qw/Library 4 secrets6/], [qw/Library 5 secrets7/], [qw/Eatery 5 secrets8/], [qw/Library 6 secrets9/], [qw/Library 7 secrets10/], [qw/Eatery 7 secrets11/], [qw/Library 8 secrets12/], ]); }, 'populate without PKs supplied ok' ); } # test simple, complex LIMIT and limited prefetch support, with both dialects and quote combinations (if possible) for my $dialect ( 'Top', ($schema->storage->_server_info->{normalized_dbms_version} || 0 ) >= 9 ? ('RowNumberOver') : () , ) { for my $quoted (0, 1) { $schema = DBICTest::Schema->connect($dsn, $user, $pass, { limit_dialect => $dialect, %$opts, $quoted ? ( quote_char => [ qw/ [ ] / ], name_sep => '.' ) : () , }); my $test_type = "Dialect:$dialect Quoted:$quoted"; # basic limit support { my $art_rs = $schema->resultset ('Artist'); $art_rs->delete; $art_rs->create({ name => 'Artist ' . $_ }) for (1..6); my $it = $schema->resultset('Artist')->search( {}, { rows => 4, offset => 3, order_by => 'artistid', }); is( $it->count, 3, "$test_type: LIMIT count ok" ); local $TODO = "Top-limit does not work when your limit ends up past the resultset" if $dialect eq 'Top'; is( $it->next->name, 'Artist 4', "$test_type: iterator->next ok" ); $it->next; is( $it->next->name, 'Artist 6', "$test_type: iterator->next ok" ); is( $it->next, undef, "$test_type: next past end of resultset ok" ); } # plain ordered subqueries throw throws_ok (sub { $schema->resultset('Owners')->search ({}, { order_by => 'name' })->as_query }, qr/ordered subselect encountered/, "$test_type: Ordered Subselect detection throws ok"); # make sure ordered subselects *somewhat* work { my $owners = $schema->resultset ('Owners')->search ({}, { order_by => 'name', offset => 2, rows => 3, unsafe_subselect_ok => 1 }); my $sealed_owners = $owners->as_subselect_rs; is_deeply ( [ sort map { $_->name } ($sealed_owners->all) ], [ sort map { $_->name } ($owners->all) ], "$test_type: Sort preserved from within a subquery", ); } # still even with lost order of IN, we should be getting correct # sets { my $owners = $schema->resultset ('Owners')->search ({}, { order_by => 'name', offset => 2, rows => 3, unsafe_subselect_ok => 1 }); my $corelated_owners = $owners->result_source->resultset->search ( { id => { -in => $owners->get_column('id')->as_query }, }, { order_by => 'name' #reorder because of what is shown above }, ); is ( join ("\x00", map { $_->name } ($corelated_owners->all) ), join ("\x00", map { $_->name } ($owners->all) ), "$test_type: With an outer order_by, everything still matches", ); } # make sure right-join-side single-prefetch ordering limit works { my $rs = $schema->resultset ('BooksInLibrary')->search ( { 'owner.name' => { '!=', 'woggle' }, }, { prefetch => 'owner', order_by => 'owner.name', } ); # this is the order in which they should come from the above query my @owner_names = qw/boggle fISMBoC fREW fRIOUX fROOH fRUE wiggle wiggle/; is ($rs->all, 8, "$test_type: Correct amount of objects from right-sorted joined resultset"); is_deeply ( [map { $_->owner->name } ($rs->all) ], \@owner_names, "$test_type: Prefetched rows were properly ordered" ); my $limited_rs = $rs->search ({}, {rows => 6, offset => 2, unsafe_subselect_ok => 1}); is ($limited_rs->count, 6, "$test_type: Correct count of limited right-sorted joined resultset"); is ($limited_rs->count_rs->next, 6, "$test_type: Correct count_rs of limited right-sorted joined resultset"); $schema->is_executed_querycount( sub { is_deeply ( [map { $_->owner->name } ($limited_rs->all) ], [@owner_names[2 .. 7]], "$test_type: Prefetch-limited rows were properly ordered" ); }, 1, "$test_type: Only one query with prefetch" ); is_deeply ( [map { $_->name } ($limited_rs->search_related ('owner')->all) ], [@owner_names[2 .. 7]], "$test_type: Rows are still properly ordered after search_related", ); } # try a ->has_many direction with duplicates my $owners = $schema->resultset ('Owners')->search ( { 'books.id' => { '!=', undef }, 'me.name' => { '!=', 'somebogusstring' }, }, { prefetch => 'books', order_by => [ { -asc => \['name + ?', [ test => 'xxx' ]] }, 'me.id' ], # test bindvar propagation group_by => [ map { "me.$_" } $schema->source('Owners')->columns ], # the literal order_by requires an explicit group_by rows => 3, # 8 results total unsafe_subselect_ok => 1, }, ); is ($owners->page(1)->all, 3, "$test_type: has_many prefetch returns correct number of rows"); is ($owners->page(1)->count, 3, "$test_type: has-many prefetch returns correct count"); is ($owners->page(3)->count, 2, "$test_type: has-many prefetch returns correct count"); { local $TODO = "Top-limit does not work when your limit ends up past the resultset" if $dialect eq 'Top'; is ($owners->page(3)->all, 2, "$test_type: has_many prefetch returns correct number of rows"); is ($owners->page(3)->count_rs->next, 2, "$test_type: has-many prefetch returns correct count_rs"); } # try a ->belongs_to direction (no select collapse, group_by should work) my $books = $schema->resultset ('BooksInLibrary')->search ( { 'owner.name' => [qw/wiggle woggle/], }, { distinct => 1, having => \['1 = ?', [ test => 1 ] ], #test having propagation prefetch => 'owner', rows => 2, # 3 results total order_by => [{ -desc => 'me.owner' }, 'me.id'], unsafe_subselect_ok => 1, }, ); is ($books->page(1)->all, 2, "$test_type: Prefetched grouped search returns correct number of rows"); is ($books->page(1)->count, 2, "$test_type: Prefetched grouped search returns correct count"); is ($books->page(2)->count, 1, "$test_type: Prefetched grouped search returns correct count"); { local $TODO = "Top-limit does not work when your limit ends up past the resultset" if $dialect eq 'Top'; is ($books->page(2)->all, 1, "$test_type: Prefetched grouped search returns correct number of rows"); is ($books->page(2)->count_rs->next, 1, "$test_type: Prefetched grouped search returns correct count_rs"); } } } # test GUID columns { $schema->storage->dbh_do (sub { my ($storage, $dbh) = @_; eval { $dbh->do("DROP TABLE artist_guid") }; $dbh->do(<<'SQL'); CREATE TABLE artist_guid ( artistid UNIQUEIDENTIFIER NOT NULL, name VARCHAR(100), rank INT NOT NULL DEFAULT '13', charfield CHAR(10) NULL, a_guid UNIQUEIDENTIFIER, primary key(artistid) ) SQL }); # start disconnected to make sure insert works on an un-reblessed storage $schema = DBICTest::Schema->connect($dsn, $user, $pass, $opts); my $row; lives_ok { $row = $schema->resultset('ArtistGUID')->create({ name => 'mtfnpy' }) } 'created a row with a GUID'; ok( eval { $row->artistid }, 'row has GUID PK col populated', ); diag $@ if $@; ok( eval { $row->a_guid }, 'row has a GUID col with auto_nextval populated', ); diag $@ if $@; my $row_from_db = $schema->resultset('ArtistGUID') ->search({ name => 'mtfnpy' })->first; is $row_from_db->artistid, $row->artistid, 'PK GUID round trip'; is $row_from_db->a_guid, $row->a_guid, 'NON-PK GUID round trip'; } # test MONEY type { $schema->storage->dbh_do (sub { my ($storage, $dbh) = @_; eval { $dbh->do("DROP TABLE money_test") }; $dbh->do(<<'SQL'); CREATE TABLE money_test ( id INT IDENTITY PRIMARY KEY, amount MONEY NULL ) SQL }); { my $freetds_and_dynamic_cursors = 1 if $opts_name eq 'use_dynamic_cursors' && $schema->storage->_using_freetds; local $TODO = 'these tests fail on freetds with dynamic cursors for some reason' if $freetds_and_dynamic_cursors; local $ENV{DBIC_NULLABLE_KEY_NOWARN} = 1 if $freetds_and_dynamic_cursors; my $rs = $schema->resultset('Money'); my $row; lives_ok { $row = $rs->create({ amount => 100 }); } 'inserted a money value'; cmp_ok ((try { $rs->find($row->id)->amount })||0, '==', 100, 'money value round-trip'); lives_ok { $row->update({ amount => 200 }); } 'updated a money value'; cmp_ok ((try { $rs->find($row->id)->amount })||0, '==', 200, 'updated money value round-trip'); lives_ok { $row->update({ amount => undef }); } 'updated a money value to NULL'; is try { $rs->find($row->id)->amount }, undef, 'updated money value to NULL round-trip'; } } # Test leakage of PK on implicit retrieval { my $next_owner = $schema->resultset('Owners')->get_column('id')->max + 1; my $next_book = $schema->resultset('BooksInLibrary')->get_column('id')->max + 1; cmp_ok( $next_owner, '!=', $next_book, 'Preexisting auto-inc PKs staggered' ); my $yet_another_owner = $schema->resultset('Owners')->create({ name => 'YAO' }); my $yet_another_book; warnings_exist { $yet_another_book = $yet_another_owner->create_related( books => { title => 'YAB' }) } qr/Missing value for primary key column 'id' on BooksInLibrary - perhaps you forgot to set its 'is_auto_increment'/; is( $yet_another_owner->id, $next_owner, 'Expected Owner id' ); is( $yet_another_book->id, $next_book, 'Expected Book id' ); } } } done_testing; # clean up our mess END { if (my $dbh = eval { $schema->storage->_dbh }) { eval { $dbh->do("DROP TABLE $_") } for qw/artist artist_guid money_test books owners/; } undef $schema; } # vim:sw=2 sts=2 ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/relationship/�����������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�016063� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/relationship/custom_with_null_in_cond.t���������������������������������������0000644�0001750�0001750�00000001437�14240132261�023324� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib 't/lib'; use DBICTest; my $schema = DBICTest->init_schema(); my $artist_rs = $schema->resultset('Artist'); for my $rel_rs( $artist_rs->search_related_rs( cds_without_genre => { artist => 1 }, { order_by => 'cdid' } ), $artist_rs->find(1)->search_related_rs( cds_without_genre => {}, { order_by => 'cdid' } ), ) { is_deeply( $rel_rs->all_hri, [ { artist => 1, cdid => 2, genreid => undef, single_track => undef, title => "Forkful of bees", year => 2001 }, { artist => 1, cdid => 3, genreid => undef, single_track => undef, title => "Caterwaulin' Blues", year => 1997 }, ] ); } done_testing; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/relationship/custom_opaque.t��������������������������������������������������0000644�0001750�0001750�00000002173�14240132261�021116� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib 't/lib'; use DBICTest; my $schema = DBICTest->init_schema( no_populate => 1, quote_names => 1 ); $schema->resultset('CD')->create({ title => 'Equinoxe', year => 1978, artist => { name => 'JMJ' }, genre => { name => 'electro' }, tracks => [ { title => 'e1' }, { title => 'e2' }, { title => 'e3' }, ], single_track => { title => 'o1', cd => { title => 'Oxygene', year => 1976, artist => { name => 'JMJ' }, }, }, }); my $cd = $schema->resultset('CD')->search({ single_track => { '!=', undef } })->first; $schema->is_executed_sql_bind( sub { is( eval{$cd->single_track_opaque->title}, 'o1', 'Found correct single track' ) }, [ [ 'SELECT "me"."trackid", "me"."cd", "me"."position", "me"."title", "me"."last_updated_on", "me"."last_updated_at" FROM cd "cd__row" JOIN "track" "me" ON me.trackid = cd__row.single_track WHERE "cd__row"."cdid" = ? ', [ { dbic_colname => "cd__row.cdid", sqlt_datatype => "integer" } => 2 ] ], ], ); done_testing; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/relationship/unresolvable.t���������������������������������������������������0000644�0001750�0001750�00000000646�14240132261�020736� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); my $cd = $schema->resultset('CD')->search ({}, { columns => ['year'], rows => 1 })->single; throws_ok ( sub { $cd->tracks }, qr/Unable to resolve relationship .+ column .+ not loaded from storage/, 'Correct exception on nonresolvable object-based condition' ); done_testing; ������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/relationship/doesnt_exist.t���������������������������������������������������0000644�0001750�0001750�00000001253�14240132261�020740� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); plan tests => 3; my $bookmark = $schema->resultset("Bookmark")->find(1); my $link = $bookmark->link; my $link_id = $link->id; ok $link->id; $link->delete; is $schema->resultset("Link")->search({id => $link_id})->count, 0, "link $link_id was deleted"; # Get a fresh object with nothing cached $bookmark = $schema->resultset("Bookmark")->find($bookmark->id); # This would create a new link row if none existed $bookmark->link; is $schema->resultset("Link")->search({id => $link_id})->count, 0, 'accessor did not create a link object where there was none'; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/relationship/set_column_on_fk.t�����������������������������������������������0000644�0001750�0001750�00000004272�14240132261�021560� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); # test with relname == colname my $bookmark = $schema->resultset("Bookmark")->find(1); ok( $bookmark->has_column ('link'), 'Right column name' ); ok( $bookmark->has_relationship ('link'), 'Right rel name' ); my $link = $bookmark->link; my $new_link = $schema->resultset("Link")->create({ url => "http://bugsarereal.com", title => "bugsarereal.com", id => 9, }); is( $bookmark->link->id, 1, 'Initial relation id' ); $bookmark->set_column( 'link', 9 ); is( $bookmark->link->id, 9, 'Correct object re-selected after belongs_to set' ); $bookmark->discard_changes; is( $bookmark->link->id, 1, 'Pulled the correct old object after belongs_to reset' ); $bookmark->link($new_link); is( $bookmark->get_column('link'), 9, 'Correct column set from related' ); $bookmark->discard_changes; is( $bookmark->link->id, 1, 'Pulled the correct old object after belongs_to reset' ); $bookmark->link(9); is( $bookmark->link->id, 9, 'Correct object selected on deflated accessor set'); $bookmark->discard_changes; is( $bookmark->link->id, 1, 'Pulled the correct old object after belongs_to reset' ); $bookmark->update({ link => 9 }); is( $bookmark->link->id, 9, 'Correct relationship after update' ); is( $bookmark->get_from_storage->link->id, 9, 'Correct relationship after re-select' ); # test with relname != colname my $lyric = $schema->resultset('Lyrics')->create({ track_id => 5 }); is( $lyric->track->id, 5, 'Initial relation id'); $lyric->track_id(6); my $track6 = $lyric->track; is( $track6->trackid, 6, 'Correct object re-selected after belongs_to set'); $lyric->discard_changes; is( $lyric->track->trackid, 5, 'Pulled the correct old rel object after belongs_to reset'); $lyric->track($track6); is( $lyric->track_id, 6, 'Correct column set from related'); $lyric->discard_changes; is( $lyric->track->trackid, 5, 'Pulled the correct old rel object after belongs_to reset'); $lyric->update({ track => $track6 }); is( $lyric->track->trackid, 6, 'Correct relationship obj after update' ); is( $lyric->get_from_storage->track->trackid, 6, 'Correct relationship after re-select' ); done_testing; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/relationship/dynamic_foreign_columns.t����������������������������������������0000644�0001750�0001750�00000000523�14240132261�023124� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; require DBICTest::DynamicForeignCols::TestComputer; is_deeply ( [ DBICTest::DynamicForeignCols::TestComputer->columns ], [qw( test_id computer_id )], 'All columns properly defined from DBICTest::DynamicForeignCols::Computer parentclass' ); done_testing; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/relationship/core.t�����������������������������������������������������������0000644�0001750�0001750�00000031470�14240132261�017164� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use lib qw(t/lib); use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); # has_a test my $cd = $schema->resultset("CD")->find(4); my ($artist) = $cd->search_related('artist'); is($artist->name, 'Random Boy Band', 'has_a search_related ok'); # has_many test with an order_by clause defined $artist = $schema->resultset("Artist")->find(1); my @cds = $artist->search_related('cds'); is( $cds[1]->title, 'Spoonful of bees', 'has_many search_related with order_by ok' ); # search_related with additional abstract query @cds = $artist->search_related('cds', { title => { like => '%of%' } } ); is( $cds[1]->title, 'Forkful of bees', 'search_related with abstract query ok' ); # creating a related object $artist->create_related( 'cds', { title => 'Big Flop', year => 2005, } ); my $big_flop_cd = ($artist->search_related('cds'))[3]; is( $big_flop_cd->title, 'Big Flop', 'create_related ok' ); # make sure we are not making pointless select queries when a FK IS NULL $schema->is_executed_querycount( sub { $big_flop_cd->genre; #should not trigger a select query }, 0, 'No SELECT made for belongs_to if key IS NULL'); $schema->is_executed_querycount( sub { $big_flop_cd->genre_inefficient; #should trigger a select query }, 1, 'SELECT made for belongs_to if key IS NULL when undef_on_null_fk disabled'); my( $rs_from_list ) = $artist->search_related_rs('cds'); isa_ok( $rs_from_list, 'DBIx::Class::ResultSet', 'search_related_rs in list context returns rs' ); ( $rs_from_list ) = $artist->cds_rs(); isa_ok( $rs_from_list, 'DBIx::Class::ResultSet', 'relation_rs in list context returns rs' ); # count_related is( $artist->count_related('cds'), 4, 'count_related ok' ); # set_from_related my $track = $schema->resultset("Track")->create( { trackid => 1, cd => 3, position => 98, title => 'Hidden Track' } ); $track->set_from_related( cd => $cd ); # has_relationship ok(! $track->has_relationship( 'foo' ), 'Track has no relationship "foo"'); ok($track->has_relationship( 'disc' ), 'Track has relationship "disk"' ); is($track->disc->cdid, 4, 'set_from_related ok, including alternative accessor' ); $track->set_from_related( cd => undef ); ok( !defined($track->cd), 'set_from_related with undef ok'); $track = $schema->resultset("Track")->new( {} ); $track->cd; $track->set_from_related( cd => $cd ); ok ($track->cd, 'set_from_related ok after using the accessor' ); # update_from_related, the same as set_from_related, but it calls update afterwards $track = $schema->resultset("Track")->create( { trackid => 2, cd => 3, title => 'Hidden Track 2' } ); $track->update_from_related( cd => $cd ); my $t_cd = ($schema->resultset("Track")->search({ cd => 4, title => 'Hidden Track 2' }))[0]->cd; is( $t_cd->cdid, 4, 'update_from_related ok' ); # find_or_create_related with an existing record $cd = $artist->find_or_create_related( 'cds', { title => 'Big Flop' } ); is( $cd->year, 2005, 'find_or_create_related on existing record ok' ); # find_or_create_related creating a new record $cd = $artist->find_or_create_related( 'cds', { title => 'Greatest Hits', year => 2006, } ); is( $cd->title, 'Greatest Hits', 'find_or_create_related new record ok' ); @cds = $artist->search_related('cds'); is( ($artist->search_related('cds'))[4]->title, 'Greatest Hits', 'find_or_create_related new record search ok' ); $artist->delete_related( cds => { title => 'Greatest Hits' }); cmp_ok( $schema->resultset("CD")->search({ title => 'Greatest Hits' }), '==', 0, 'delete_related ok' ); # find_or_new_related with an existing record $cd = $artist->find_or_new_related( 'cds', { title => 'Big Flop' } ); is( $cd->year, 2005, 'find_or_new_related on existing record ok' ); ok( $cd->in_storage, 'find_or_new_related on existing record: is in_storage' ); # find_or_new_related instantiating a new record $cd = $artist->find_or_new_related( 'cds', { title => 'Greatest Hits 2: Louder Than Ever', year => 2007, } ); is( $cd->title, 'Greatest Hits 2: Louder Than Ever', 'find_or_new_related new record ok' ); is( $cd->in_storage, 0, 'find_or_new_related on a new record: not in_storage' ); $cd->artist(undef); my $newartist = $cd->find_or_new_related( 'artist', { name => 'Random Boy Band Two', artistid => 200, } ); is($newartist->name, 'Random Boy Band Two', 'find_or_new_related new artist record with id'); is($newartist->id, 200, 'find_or_new_related new artist id set'); lives_ok( sub { my $new_bookmark = $schema->resultset("Bookmark")->new_result( {} ); my $new_related_link = $new_bookmark->new_related( 'link', {} ); }, 'No back rel' ); throws_ok { my $new_bookmark = $schema->resultset("Bookmark")->new_result( {} ); $new_bookmark->new_related( no_such_rel => {} ); } qr/No such relationship 'no_such_rel'/, 'creating in uknown rel throws'; { local $TODO = "relationship checking needs fixing"; # try to add a bogus relationship using the wrong cols throws_ok { DBICTest::Schema::Artist->add_relationship( tracks => 'DBICTest::Schema::Track', { 'foreign.cd' => 'self.cdid' } ); } qr/Unknown column/, 'failed when creating a rel with invalid key, ok'; } # another bogus relationship using no join condition throws_ok { DBICTest::Schema::Artist->add_relationship( tracks => 'DBICTest::Track' ); } qr/join condition/, 'failed when creating a rel without join condition, ok'; # many_to_many helper tests $cd = $schema->resultset("CD")->find(1); my @producers = $cd->producers(undef, { order_by => 'producerid'} ); is( $producers[0]->name, 'Matt S Trout', 'many_to_many ok' ); is( $cd->producers_sorted->next->name, 'Bob The Builder', 'sorted many_to_many ok' ); is( $cd->producers_sorted({producerid => 3})->next->name, 'Fred The Phenotype', 'sorted many_to_many with search condition ok' ); $cd = $schema->resultset('CD')->find(2); my $prod_rs = $cd->producers(); my $prod_before_count = $schema->resultset('Producer')->count; is( $prod_rs->count, 0, "CD doesn't yet have any producers" ); my $prod = $schema->resultset('Producer')->find(1); $cd->add_to_producers($prod); is( $prod_rs->count(), 1, 'many_to_many add_to_$rel($obj) count ok' ); is( $prod_rs->first->name, 'Matt S Trout', 'many_to_many add_to_$rel($obj) ok' ); $cd->remove_from_producers($prod); $cd->add_to_producers($prod, {attribute => 1}); is( $prod_rs->count(), 1, 'many_to_many add_to_$rel($obj, $link_vals) count ok' ); is( $cd->cd_to_producer->first->attribute, 1, 'many_to_many $link_vals ok'); $cd->remove_from_producers($prod); $cd->set_producers([$prod], {attribute => 2}); is( $prod_rs->count(), 1, 'many_to_many set_$rel($obj, $link_vals) count ok' ); is( $cd->cd_to_producer->first->attribute, 2, 'many_to_many $link_vals ok'); $cd->remove_from_producers($prod); is( $schema->resultset('Producer')->find(1)->name, 'Matt S Trout', "producer object exists after remove of link" ); is( $prod_rs->count, 0, 'many_to_many remove_from_$rel($obj) ok' ); $cd->add_to_producers({ name => 'Testy McProducer' }); is( $schema->resultset('Producer')->count, $prod_before_count+1, 'add_to_$rel($hash) inserted a new producer' ); is( $prod_rs->count(), 1, 'many_to_many add_to_$rel($hash) count ok' ); is( $prod_rs->first->name, 'Testy McProducer', 'many_to_many add_to_$rel($hash) ok' ); $cd->add_to_producers({ name => 'Jack Black' }); is( $prod_rs->count(), 2, 'many_to_many add_to_$rel($hash) count ok' ); $cd->set_producers($schema->resultset('Producer')->all); is( $cd->producers->count(), $prod_before_count+2, 'many_to_many set_$rel(@objs) count ok' ); $cd->set_producers($schema->resultset('Producer')->find(1)); is( $cd->producers->count(), 1, 'many_to_many set_$rel($obj) count ok' ); $cd->set_producers([$schema->resultset('Producer')->all]); is( $cd->producers->count(), $prod_before_count+2, 'many_to_many set_$rel(\@objs) count ok' ); $cd->set_producers([$schema->resultset('Producer')->find(1)]); is( $cd->producers->count(), 1, 'many_to_many set_$rel([$obj]) count ok' ); throws_ok { $cd->remove_from_producers({ fake => 'hash' }) } qr/needs an object/, 'remove_from_$rel($hash) dies correctly'; throws_ok { $cd->add_to_producers() } qr/needs an object or hashref/, 'add_to_$rel(undef) dies correctly'; # many_to_many stresstest my $twokey = $schema->resultset('TwoKeys')->find(1,1); my $fourkey = $schema->resultset('FourKeys')->find(1,2,3,4); is( $twokey->fourkeys->count, 0, 'twokey has no fourkeys' ); $twokey->add_to_fourkeys($fourkey, { autopilot => 'engaged' }); my $got_fourkey = $twokey->fourkeys({ sensors => 'online' })->first; is( $twokey->fourkeys->count, 1, 'twokey has one fourkey' ); is( $got_fourkey->$_, $fourkey->$_, 'fourkeys row has the correct value for column '.$_ ) for (qw(foo bar hello goodbye sensors)); $twokey->remove_from_fourkeys($fourkey); is( $twokey->fourkeys->count, 0, 'twokey has no fourkeys' ); is( $twokey->fourkeys_to_twokeys->count, 0, 'twokey has no links to fourkey' ); my $undef_artist_cd = $schema->resultset("CD")->new_result({ 'title' => 'badgers', 'year' => 2007 }); ok(! $undef_artist_cd->has_column_loaded('artist'), 'FK not loaded'); is($undef_artist_cd->search_related('artist')->count, 0, '0=1 search when FK does not exist and object not yet in db'); lives_ok { $undef_artist_cd->related_resultset('artist')->new({name => 'foo'}); } 'Object created on a resultset related to not yet inserted object'; lives_ok{ $schema->resultset('Artwork')->new_result({})->cd; } 'undef_on_null_fk does not choke on empty conds'; my $def_artist_cd = $schema->resultset("CD")->new_result({ 'title' => 'badgers', 'year' => 2007, artist => undef }); is($def_artist_cd->has_column_loaded('artist'), 1, 'FK loaded'); is($def_artist_cd->search_related('artist')->count, 0, 'closed search on null FK'); # test undirected many-to-many relationship (e.g. "related artists") my $undir_maps = $schema->resultset("Artist") ->search ({artistid => 1}) ->search_related ('artist_undirected_maps'); is($undir_maps->count, 1, 'found 1 undirected map for artist 1'); is_same_sql_bind ( $undir_maps->as_query, '( SELECT artist_undirected_maps.id1, artist_undirected_maps.id2 FROM artist me JOIN artist_undirected_map artist_undirected_maps ON artist_undirected_maps.id1 = me.artistid OR artist_undirected_maps.id2 = me.artistid WHERE ( artistid = ? ) )', [[ { sqlt_datatype => 'integer', dbic_colname => 'artistid' } => 1 ]], 'expected join sql produced', ); $undir_maps = $schema->resultset("Artist")->find(2)->artist_undirected_maps; is($undir_maps->count, 1, 'found 1 undirected map for artist 2'); my $mapped_rs = $undir_maps->search_related('mapped_artists'); my @art = $mapped_rs->all; cmp_ok(@art, '==', 2, "Both artist returned from map"); my $searched = $mapped_rs->search({'mapped_artists.artistid' => {'!=', undef}}); cmp_ok($searched->count, '==', 2, "Both artist returned from map after adding another condition"); # check join through cascaded has_many relationships (also empty has_many rels) $artist = $schema->resultset("Artist")->find(1); my $trackset = $artist->cds->search_related('tracks'); is($trackset->count, 10, "Correct number of tracks for artist"); is($trackset->all, 10, "Correct number of track objects for artist"); # now see about updating eveything that belongs to artist 2 to artist 3 $artist = $schema->resultset("Artist")->find(2); my $nartist = $schema->resultset("Artist")->find(3); cmp_ok($artist->cds->count, '==', 1, "Correct orig #cds for artist"); cmp_ok($nartist->cds->count, '==', 1, "Correct orig #cds for artist"); $artist->cds->update({artist => $nartist->id}); cmp_ok($artist->cds->count, '==', 0, "Correct new #cds for artist"); cmp_ok($nartist->cds->count, '==', 2, "Correct new #cds for artist"); # check if is_foreign_key_constraint attr is set my $rs_normal = $schema->source('Track'); my $relinfo = $rs_normal->relationship_info ('cd'); cmp_ok($relinfo->{attrs}{is_foreign_key_constraint}, '==', 1, "is_foreign_key_constraint defined for belongs_to relationships."); my $rs_overridden = $schema->source('ForceForeign'); my $relinfo_with_attr = $rs_overridden->relationship_info ('cd_3'); cmp_ok($relinfo_with_attr->{attrs}{is_foreign_key_constraint}, '==', 0, "is_foreign_key_constraint defined for belongs_to relationships with attr."); # check that relationships below left join relationships are forced to left joins # when traversing multiple belongs_to my $cds = $schema->resultset("CD")->search({ 'me.cdid' => 5 }, { join => { single_track => 'cd' } }); is($cds->count, 1, "subjoins under left joins force_left (string)"); $cds = $schema->resultset("CD")->search({ 'me.cdid' => 5 }, { join => { single_track => ['cd'] } }); is($cds->count, 1, "subjoins under left joins force_left (arrayref)"); $cds = $schema->resultset("CD")->search({ 'me.cdid' => 5 }, { join => { single_track => { cd => {} } } }); is($cds->count, 1, "subjoins under left joins force_left (hashref)"); done_testing; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/relationship/after_update.t���������������������������������������������������0000644�0001750�0001750�00000001170�14240132261�020671� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); plan tests => 2; my $bookmark = $schema->resultset("Bookmark")->find(1); my $link = $bookmark->link; my $link_id = $link->id; my $new_link = $schema->resultset("Link")->new({ id => 42, url => "http://monstersarereal.com", title => "monstersarereal.com" }); # Changing a relationship by id rather than by object would cause # old related_resultsets to be used. $bookmark->link($new_link->id); is $bookmark->link->id, $new_link->id; $bookmark->update; is $bookmark->link->id, $new_link->id; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/relationship/malformed_declaration.t������������������������������������������0000644�0001750�0001750�00000001444�14240132261�022545� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use lib qw(t/lib); use DBICTest::Schema::Artist; my $pkg = 'DBICTest::Schema::Artist'; for my $call (qw(has_many might_have has_one belongs_to)) { { local $TODO = 'stupid stupid heuristic - needs to die' if $call eq 'belongs_to'; throws_ok { $pkg->$call( foos => 'nonexistent bars', { foo => 'self.artistid' } ); } qr/Malformed relationship condition key 'foo': must be prefixed with 'foreign.'/, "Correct exception on $call with malformed foreign."; } throws_ok { $pkg->has_many( foos => 'nonexistent bars', { 'foreign.foo' => 'name' } ); } qr/\QMalformed relationship condition value 'name': must be prefixed with 'self.'/, "Correct exception on $call with malformed self."; } done_testing; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/relationship/proxy.t����������������������������������������������������������0000644�0001750�0001750�00000003130�14240132261�017405� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); my $cd = $schema->resultset('CD')->find(2); is($cd->notes, $cd->liner_notes->notes, 'notes proxy ok'); is($cd->artist_name, $cd->artist->name, 'artist_name proxy ok'); my $track = $cd->tracks->first; is($track->cd_title, $track->cd->title, 'cd_title proxy ok'); is($track->cd_title, $cd->title, 'cd_title proxy II ok'); is($track->year, $cd->year, 'year proxy ok'); my $tag = $schema->resultset('Tag')->first; is($tag->year, $tag->cd->year, 'year proxy II ok'); is($tag->cd_title, $tag->cd->title, 'cd_title proxy III ok'); my $bookmark = $schema->resultset('Bookmark')->create ({ link => { url => 'http://cpan.org', title => 'CPAN' }, }); my $link = $bookmark->link; ok($bookmark->link_id == $link->id, 'link_id proxy ok'); is($bookmark->link_url, $link->url, 'link_url proxy ok'); is($bookmark->link_title, $link->title, 'link_title proxy ok'); my $cd_source_class = $schema->class('CD'); throws_ok { $cd_source_class->add_relationship('artist_regex', 'DBICTest::Schema::Artist', { 'foreign.artistid' => 'self.artist' }, { proxy => qr/\w+/ } ) } qr/unable \s to \s process \s the \s \'proxy\' \s argument/ix, 'proxy attr with a regex ok'; throws_ok { $cd_source_class->add_relationship('artist_sub', 'DBICTest::Schema::Artist', { 'foreign.artistid' => 'self.artist' }, { proxy => sub {} } ) } qr/unable \s to \s process \s the \s \'proxy\' \s argument/ix, 'proxy attr with a sub ok'; done_testing; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/relationship/update_or_create_multi.t�����������������������������������������0000644�0001750�0001750�00000005264�14240132261�022755� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use Test::Warn; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); my $artist = $schema->resultset ('Artist')->find(1); my $genre = $schema->resultset ('Genre') ->create ({ name => 'par excellence' }); my $genre_cds = $genre->cds; is ($genre_cds->count, 0, 'No cds yet'); # expect a create $genre->update_or_create_related ('cds', { artist => $artist, year => 2009, title => 'the best thing since sliced bread', }); # verify cd was inserted ok is ($genre_cds->count, 1, 'One cd'); my $cd = $genre_cds->first; is_deeply ( { map { $_, $cd->get_column ($_) } qw/artist year title/ }, { artist => $artist->id, year => 2009, title => 'the best thing since sliced bread', }, 'CD created correctly', ); # expect a year update on the only related row # (non-qunique column + unique column set as disambiguator) $genre->update_or_create_related ('cds', { year => 2010, title => 'the best thing since sliced bread', artist => 1, }); # re-fetch the cd, verify update is ($genre->search_related( 'cds' )->count, 1, 'Still one cd'); $cd = $genre_cds->first; is_deeply ( { map { $_, $cd->get_column ($_) } qw/artist year title/ }, { artist => $artist->id, year => 2010, title => 'the best thing since sliced bread', }, 'CD year column updated correctly', ); # expect a failing create: # the unique constraint is not complete, and there is nothing # in the database with such a year yet - insertion will fail due # to missing artist fk throws_ok { $genre->update_or_create_related ('cds', { year => 2020, title => 'the best thing since sliced bread', }) } qr/DBI Exception.+(?x: \QNOT NULL constraint failed: cd.artist\E | \Qcd.artist may not be NULL\E )/s, 'ambiguous find + create failed' ; # expect a create, after a failed search using *only* the # *current* relationship and the unique column constraints # (so no year) $schema->is_executed_sql_bind( sub { $genre->update_or_create_related ('cds', { title => 'the best thing since vertical toasters', artist => $artist, year => 2012, }); }, [ [ 'SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE ( me.artist = ? AND me.genreid = ? AND me.title = ? ) ', 1, 2, "the best thing since vertical toasters", ], [ 'INSERT INTO cd ( artist, genreid, title, year) VALUES ( ?, ?, ?, ? )', 1, 2, "the best thing since vertical toasters", 2012, ], ], 'expected select issued' ); # a has_many search without a unique constraint makes no sense # but I am not sure what to test for - leaving open done_testing; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/relationship/update_or_create_single.t����������������������������������������0000644�0001750�0001750�00000004740�14240132261�023102� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); plan tests => 9; my $artist = $schema->resultset ('Artist')->first; my $genre = $schema->resultset ('Genre') ->create ({ name => 'par excellence' }); is ($genre->search_related( 'model_cd' )->count, 0, 'No cds yet'); # expect a create $genre->update_or_create_related ('model_cd', { artist => $artist, year => 2009, title => 'the best thing since sliced bread', }); # verify cd was inserted ok is ($genre->search_related( 'model_cd' )->count, 1, 'One cd'); my $cd = $genre->find_related ('model_cd', {}); is_deeply ( { map { $_, $cd->get_column ($_) } qw/artist year title/ }, { artist => $artist->id, year => 2009, title => 'the best thing since sliced bread', }, 'CD created correctly', ); # expect a year update on the only related row # (non-qunique column + unique column as disambiguator) $genre->update_or_create_related ('model_cd', { year => 2010, title => 'the best thing since sliced bread', }); # re-fetch the cd, verify update is ($genre->search_related( 'model_cd' )->count, 1, 'Still one cd'); $cd = $genre->find_related ('model_cd', {}); is_deeply ( { map { $_, $cd->get_column ($_) } qw/artist year title/ }, { artist => $artist->id, year => 2010, title => 'the best thing since sliced bread', }, 'CD year column updated correctly', ); # expect an update of the only related row # (update a unique column) $genre->update_or_create_related ('model_cd', { title => 'the best thing since vertical toasters', }); # re-fetch the cd, verify update is ($genre->search_related( 'model_cd' )->count, 1, 'Still one cd'); $cd = $genre->find_related ('model_cd', {}); is_deeply ( { map { $_, $cd->get_column ($_) } qw/artist year title/ }, { artist => $artist->id, year => 2010, title => 'the best thing since vertical toasters', }, 'CD title column updated correctly', ); # expect a year update on the only related row # (non-unique column only) $genre->update_or_create_related ('model_cd', { year => 2011, }); # re-fetch the cd, verify update is ($genre->search_related( 'model_cd' )->count, 1, 'Still one cd'); $cd = $genre->find_related ('model_cd', {}); is_deeply ( { map { $_, $cd->get_column ($_) } qw/artist year title/ }, { artist => $artist->id, year => 2011, title => 'the best thing since vertical toasters', }, 'CD year column updated correctly without a disambiguator', ); ��������������������������������DBIx-Class-0.082843/t/relationship/custom.t���������������������������������������������������������0000644�0001750�0001750�00000026000�14240132261�017537� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use Test::Warn; use lib qw(t/lib); use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); $schema->resultset('Artist')->delete; $schema->resultset('CD')->delete; my $artist = $schema->resultset("Artist")->create({ artistid => 21, name => 'Michael Jackson', rank => 20 }); my $artist2 = $schema->resultset("Artist")->create({ artistid => 22, name => 'Chico Buarque', rank => 1 }) ; my $artist3 = $schema->resultset("Artist")->create({ artistid => 23, name => 'Ziraldo', rank => 1 }); my $artist4 = $schema->resultset("Artist")->create({ artistid => 24, name => 'Paulo Caruso', rank => 20 }); my @artworks; foreach my $year (1975..1985) { my $cd = $artist->create_related('cds', { year => $year, title => 'Compilation from ' . $year }); push @artworks, $cd->create_related('artwork', {}); } foreach my $year (1975..1995) { my $cd = $artist2->create_related('cds', { year => $year, title => 'Compilation from ' . $year }); push @artworks, $cd->create_related('artwork', {}); } foreach my $artwork (@artworks) { $artwork->create_related('artwork_to_artist', { artist => $_ }) for ($artist3, $artist4); } my $cds_80s_rs = $artist->cds_80s; is_same_sql_bind( $cds_80s_rs->as_query, '( SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE ( ( me.artist = ? AND ( me.year < ? AND me.year > ? ) ) ) )', [ [ {} => 21 ], [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'me.year' } => 1990 ], [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'me.year' } => 1979 ], ], ); my @cds_80s = $cds_80s_rs->all; is(@cds_80s, 6, '6 80s cds found (1980 - 1985)'); map { ok($_->year < 1990 && $_->year > 1979) } @cds_80s; my $cds_90s_rs = $artist2->cds_90s; is_same_sql_bind( $cds_90s_rs->as_query, '( SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM artist artist__row JOIN cd me ON ( me.artist = artist__row.artistid AND ( me.year < ? AND me.year > ? ) ) WHERE ( artist__row.artistid = ? ) )', [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'me.year' } => 2000 ], [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'me.year' } => 1989 ], [ { sqlt_datatype => 'integer', dbic_colname => 'artist__row.artistid' } => 22 ], ] ); # re-test with ::-containing moniker name # (we don't have any currently, so fudge it with lots of local() ) { local $schema->source('Artist')->{source_name} = 'Ar::Tist'; local $artist2->{related_resultsets}; is_same_sql_bind( $artist2->cds_90s->as_query, '( SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM artist ar_tist__row JOIN cd me ON ( me.artist = ar_tist__row.artistid AND ( me.year < ? AND me.year > ? ) ) WHERE ( ar_tist__row.artistid = ? ) )', [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'me.year' } => 2000 ], [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'me.year' } => 1989 ], [ { sqlt_datatype => 'integer', dbic_colname => 'ar_tist__row.artistid' } => 22 ], ] ); } my @cds_90s = $cds_90s_rs->all; is(@cds_90s, 6, '6 90s cds found (1990 - 1995) even with non-optimized search'); map { ok($_->year < 2000 && $_->year > 1989) } @cds_90s; lives_ok { my @cds_90s_95 = $artist2->cds_90s->search({ 'me.year' => 1995 }); is(@cds_90s_95, 1, '1 90s (95) cds found even with non-optimized search'); map { ok($_->year == 1995) } @cds_90s_95; } 'should preserve chain-head "me" alias (API-consistency)'; # search for all artists prefetching published cds in the 80s... my @all_artists_with_80_cds = $schema->resultset("Artist")->search ({ 'cds_80s.cdid' => { '!=' => undef } }, { join => 'cds_80s', distinct => 1 }); is_deeply( [ sort ( map { $_->year } map { $_->cds_80s->all } @all_artists_with_80_cds ) ], [ sort (1980..1989, 1980..1985) ], '16 correct cds found' ); lives_ok { my @all_artists_with_80_cds_pref = $schema->resultset("Artist")->search ({ 'cds_80s.cdid' => { '!=' => undef } }, { prefetch => 'cds_80s' }); is_deeply( [ sort ( map { $_->year } map { $_->cds_80s->all } @all_artists_with_80_cds_pref ) ], [ sort (1980..1989, 1980..1985) ], '16 correct cds found' ); } 'prefetchy-fetchy-fetch'; # create_related a plain cd via the equoivalent coderef cond, with no extra conditions lives_ok { $artist->create_related('cds_cref_cond', { title => 'related creation via coderef cond', year => '2010' } ); } 'created_related with simple condition works'; # try to create_related a 80s cd throws_ok { $artist->create_related('cds_80s', { title => 'related creation 1' }); } qr/\QUnable to complete value inferrence - custom relationship 'cds_80s' on source 'Artist' returns conditions instead of values for column(s): 'year'/, 'Create failed - complex cond'; # now supply an explicit arg overwriting the ambiguous cond my $cd_2020 = $artist->create_related('cds_80s', { title => 'related creation 2', year => '2020' }); my $id_2020 = $cd_2020->id; is( $schema->resultset('CD')->find($id_2020)->title, 'related creation 2', '2020 CD created correctly' ); # try a default year from a specific rel my $id_1984 = $artist->create_related('cds_84', { title => 'related creation 3' })->id; is( $schema->resultset('CD')->find($id_1984)->title, 'related creation 3', '1984 CD created correctly' ); # try a specific everything via a non-simplified rel throws_ok { $artist->create_related('cds_90s', { title => 'related_creation 4', year => '2038' }); } qr/\QRelationship 'cds_90s' on source 'Artist' does not resolve to a join-free condition fragment/, 'Create failed - non-simplified rel'; # Do a self-join last-entry search my @last_tracks; for my $cd ($schema->resultset('CD')->search ({}, { order_by => 'cdid'})->all) { push @last_tracks, $cd->tracks ->search ({}, { order_by => { -desc => 'position'} }) ->next || (); } my $last_tracks_rs = $schema->resultset('Track')->search ( {'next_tracks.trackid' => undef}, { join => 'next_tracks', order_by => 'me.cd' }, ); is_deeply ( [$last_tracks_rs->get_column ('trackid')->all], [ map { $_->trackid } @last_tracks ], 'last group-entry via self-join works', ); is_deeply ( [map { $_->last_track->id } grep { $_->last_track } $schema->resultset('CD')->search ({}, { order_by => 'cdid', prefetch => 'last_track'})->all], [ map { $_->trackid } @last_tracks ], 'last_track via insane subquery condition works', ); is_deeply ( [map { $_->last_track->id } grep { $_->last_track } $schema->resultset('CD')->search ({}, { order_by => 'cdid'})->all], [ map { $_->trackid } @last_tracks ], 'last_track via insane subquery condition works, even without prefetch', ); my $artwork = $schema->resultset('Artwork')->search({},{ order_by => 'cd_id' })->first; my @artists = $artwork->artists->all; is(scalar @artists, 2, 'the two artists are associated'); my @artwork_artists = $artwork->artwork_to_artist->all; foreach (@artwork_artists) { lives_ok { my $artista = $_->artist; my $artistb = $_->artist_test_m2m; ok($artista->rank < 10 ? $artistb : 1, 'belongs_to with custom rel works.'); my $artistc = $_->artist_test_m2m_noopt; ok($artista->rank < 10 ? $artistc : 1, 'belongs_to with custom rel works even in non-simplified.'); } 'belongs_to works with custom rels'; } @artists = (); lives_ok { @artists = $artwork->artists_test_m2m2->all; } 'manytomany with extended rels in the has many works'; is(scalar @artists, 2, 'two artists'); @artists = (); lives_ok { @artists = $artwork->artists_test_m2m->all; } 'can fetch many to many with optimized version'; is(scalar @artists, 1, 'only one artist is associated'); @artists = (); lives_ok { @artists = $artwork->artists_test_m2m_noopt->all; } 'can fetch many to many with non-optimized version'; is(scalar @artists, 1, 'only one artist is associated'); # Make a single for each last_track my @singles = map { $_->create_related('cd_single', { title => $_->title . ' (the single)', artist => $artist, year => 1999, }) } @last_tracks ; # See if chaining works is_deeply ( [ map { $_->title } $last_tracks_rs->search_related('cd_single')->all ], [ map { $_->title } @singles ], 'Retrieved singles in proper order' ); # See if prefetch works is_deeply ( [ map { $_->cd_single->title } $last_tracks_rs->search({}, { prefetch => 'cd_single' })->all ], [ map { $_->title } @singles ], 'Prefetched singles in proper order' ); # test set_from_related/find_related with a belongs_to custom condition my $preexisting_cd = $schema->resultset('CD')->find(1); my $cd_single_track = $schema->resultset('CD')->create({ artist => $artist, title => 'one one one', year => 2001, tracks => [{ title => 'uno uno uno' }] }); my $single_track = $cd_single_track->tracks->next; is( $single_track->cd_cref_cond->title, $cd_single_track->title, 'Got back the expected single-track cd title', ); is_deeply { $schema->resultset('Track')->find({ cd_cref_cond => { cdid => $cd_single_track->id } })->get_columns }, { $single_track->get_columns }, 'Proper find with related via coderef cond', ; warnings_exist { is_same_sql_bind( $single_track->deliberately_broken_all_cd_tracks->as_query, '( SELECT me.trackid, me.cd, me.position, me.title, me.last_updated_on, me.last_updated_at FROM track track__row JOIN track me ON me.cd = ? WHERE track__row.trackid = ? )', [ [{ dbic_colname => "me.cd", sqlt_datatype => "integer" } => "track__row.cd" ], [{ dbic_colname => "track__row.trackid", sqlt_datatype => "integer" } => 19 ], ], 'Expected nonsensical JOIN cond', ), } qr/\Qrelationship 'deliberately_broken_all_cd_tracks' on source 'Track' specifies equality of column 'cd' and the *VALUE* 'cd' (you did not use the { -ident => ... } operator)/, 'Warning on 99.9999% malformed custom cond' ; $single_track->set_from_related( cd_cref_cond => undef ); ok $single_track->is_column_changed('cd'); is $single_track->get_column('cd'), undef, 'UNset from related via coderef cond'; is $single_track->cd, undef, 'UNset related object via coderef cond'; $single_track->discard_changes; $single_track->set_from_related( cd_cref_cond => $preexisting_cd ); ok $single_track->is_column_changed('cd'); is $single_track->get_column('cd'), 1, 'set from related via coderef cond'; is_deeply { $single_track->cd->get_columns }, { $preexisting_cd->get_columns }, 'set from related via coderef cond inflates properly', ; throws_ok { local $schema->source('Track')->relationship_info('cd_cref_cond')->{cond} = sub { 1,2,3 }; $schema->resultset('Track')->find({ cd_cref_cond => {} }); } qr/\QA custom condition coderef can return at most 2 conditions, but relationship 'cd_cref_cond' on source 'Track' returned extra values: 3/; done_testing; DBIx-Class-0.082843/t/relationship/info.t�����������������������������������������������������������0000644�0001750�0001750�00000005070�14240132261�017164� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; # # The test must be performed on non-registered result classes # { package DBICTest::Thing; use warnings; use strict; use base qw/DBIx::Class::Core/; __PACKAGE__->table('thing'); __PACKAGE__->add_columns(qw/id ancestor_id/); __PACKAGE__->set_primary_key('id'); __PACKAGE__->has_many(children => __PACKAGE__, 'id'); __PACKAGE__->belongs_to(parent => __PACKAGE__, 'id', { join_type => 'left' } ); __PACKAGE__->has_many(subthings => 'DBICTest::SubThing', 'thing_id'); } { package DBICTest::SubThing; use warnings; use strict; use base qw/DBIx::Class::Core/; __PACKAGE__->table('subthing'); __PACKAGE__->add_columns(qw/thing_id/); __PACKAGE__->belongs_to(thing => 'DBICTest::Thing', 'thing_id'); __PACKAGE__->belongs_to(thing2 => 'DBICTest::Thing', 'thing_id', { join_type => 'left' } ); } my $schema = DBICTest->init_schema; for my $without_schema (1,0) { my ($t, $s) = $without_schema ? (qw/DBICTest::Thing DBICTest::SubThing/) : do { $schema->register_class(relinfo_thing => 'DBICTest::Thing'); $schema->register_class(relinfo_subthing => 'DBICTest::SubThing'); map { $schema->source ($_) } qw/relinfo_thing relinfo_subthing/; } ; is_deeply( [ sort $t->relationships ], [qw/ children parent subthings/], "Correct relationships on $t", ); is_deeply( [ sort $s->relationships ], [qw/ thing thing2 /], "Correct relationships on $s", ); is_deeply( _instance($s)->reverse_relationship_info('thing'), { subthings => $t->relationship_info('subthings') }, 'reverse_rel_info works cross-class belongs_to direction', ); is_deeply( _instance($s)->reverse_relationship_info('thing2'), { subthings => $t->relationship_info('subthings') }, 'reverse_rel_info works cross-class belongs_to direction 2', ); is_deeply( _instance($t)->reverse_relationship_info('subthings'), { map { $_ => $s->relationship_info($_) } qw/thing thing2/ }, 'reverse_rel_info works cross-class has_many direction', ); is_deeply( _instance($t)->reverse_relationship_info('parent'), { children => $t->relationship_info('children') }, 'reverse_rel_info works in-class belongs_to direction', ); is_deeply( _instance($t)->reverse_relationship_info('children'), { parent => $t->relationship_info('parent') }, 'reverse_rel_info works in-class has_many direction', ); } sub _instance { $_[0]->isa('DBIx::Class::ResultSource') ? $_[0] : $_[0]->result_source_instance } done_testing; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/88result_set_column.t���������������������������������������������������������0000644�0001750�0001750�00000023211�14240132261�017453� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Warn; use Test::Exception; # MASSIVE FIXME - there is a hole in ::RSC / as_subselect_rs # losing the order. Needs a rework/extract of the realiaser, # and that's a whole another bag of dicks BEGIN { $ENV{DBIC_SHUFFLE_UNORDERED_RESULTSETS} = 0 } use lib qw(t/lib); use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); my $rs = $schema->resultset("CD"); cmp_ok ( $rs->count, '>', $rs->search ({}, {columns => ['year'], distinct => 1})->count, 'At least one year is the same in rs' ); my $rs_title = $rs->get_column('title'); my $rs_year = $rs->get_column('year'); my $max_year = $rs->get_column(\'MAX (year)'); my @all_titles = $rs_title->all; cmp_ok(scalar @all_titles, '==', 5, "five titles returned"); my @nexted_titles; while (my $r = $rs_title->next) { push @nexted_titles, $r; } is_deeply (\@all_titles, \@nexted_titles, 'next works'); is_deeply( [ sort $rs_year->func('DISTINCT') ], [ 1997, 1998, 1999, 2001 ], "wantarray context okay"); ok ($max_year->next == $rs_year->max, q/get_column (\'FUNC') ok/); cmp_ok($rs_year->max, '==', 2001, "max okay for year"); is($rs_title->min, 'Caterwaulin\' Blues', "min okay for title"); cmp_ok($rs_year->sum, '==', 9996, "three artists returned"); my $rso_year = $rs->search({}, { order_by => 'cdid' })->get_column('year'); is($rso_year->next, 1999, "reset okay"); is($rso_year->first, 1999, "first okay"); warnings_exist (sub { is($rso_year->single, 1999, "single okay"); }, qr/Query returned more than one row/, 'single warned'); # test distinct propagation is_deeply ( [sort $rs->search ({}, { distinct => 1 })->get_column ('year')->all], [sort $rs_year->func('distinct')], 'distinct => 1 is passed through properly', ); # test illogical distinct my $dist_rs = $rs->search ({}, { columns => ['year'], distinct => 1, order_by => { -desc => [qw( cdid year )] }, }); is_same_sql_bind( $dist_rs->as_query, '( SELECT me.year FROM cd me GROUP BY me.year ORDER BY MAX(cdid) DESC, year DESC )', [], 'Correct SQL on external-ordered distinct', ); is_same_sql_bind( $dist_rs->count_rs->as_query, '( SELECT COUNT( * ) FROM ( SELECT me.year FROM cd me GROUP BY me.year ) me )', [], 'Correct SQL on count of external-orderdd distinct', ); is ( $dist_rs->count_rs->next, 4, 'Correct rs-count', ); is ( $dist_rs->count, 4, 'Correct direct count', ); # test +select/+as for single column my $psrs = $schema->resultset('CD')->search({}, { '+select' => \'MAX(year)', '+as' => 'last_year' } ); lives_ok(sub { $psrs->get_column('last_year')->next }, '+select/+as additional column "last_year" present (scalar)'); dies_ok(sub { $psrs->get_column('noSuchColumn')->next }, '+select/+as nonexistent column throws exception'); # test +select/+as for overriding a column $psrs = $schema->resultset('CD')->search({}, { 'select' => \"'The Final Countdown'", 'as' => 'title' } ); is($psrs->get_column('title')->next, 'The Final Countdown', '+select/+as overridden column "title"'); # test +select/+as for multiple columns $psrs = $schema->resultset('CD')->search({}, { '+select' => [ \'LENGTH(title) AS title_length', 'title' ], '+as' => [ 'tlength', 'addedtitle' ] } ); lives_ok(sub { $psrs->get_column('tlength')->next }, '+select/+as multiple additional columns, "tlength" column present'); lives_ok(sub { $psrs->get_column('addedtitle')->next }, '+select/+as multiple additional columns, "addedtitle" column present'); # test that +select/+as specs do not leak is_same_sql_bind ( $psrs->get_column('year')->as_query, '(SELECT me.year FROM cd me)', [], 'Correct SQL for get_column/as' ); is_same_sql_bind ( $psrs->get_column('addedtitle')->as_query, '(SELECT me.title FROM cd me)', [], 'Correct SQL for get_column/+as col' ); is_same_sql_bind ( $psrs->get_column('tlength')->as_query, '(SELECT LENGTH(title) AS title_length FROM cd me)', [], 'Correct SQL for get_column/+as func' ); # test that order_by over a function forces a subquery lives_ok ( sub { is_deeply ( [ $psrs->search ({}, { order_by => { -desc => 'title_length' } })->get_column ('title')->all ], [ "Generic Manufactured Singles", "Come Be Depressed With Us", "Caterwaulin' Blues", "Spoonful of bees", "Forkful of bees", ], 'Subquery count induced by aliased ordering function', ); }); # test for prefetch not leaking { my $rs = $schema->resultset("CD")->search({}, { prefetch => 'artist' }); my $rsc = $rs->get_column('year'); is( $rsc->{_parent_resultset}->{attrs}->{prefetch}, undef, 'prefetch wiped' ); } # test sum() is ($schema->resultset('BooksInLibrary')->get_column ('price')->sum, 125, 'Sum of a resultset works correctly'); # test sum over search_related my $owner = $schema->resultset('Owners')->find ({ name => 'Newton' }); ok ($owner->books->count > 1, 'Owner Newton has multiple books'); is ($owner->search_related ('books')->get_column ('price')->sum, 60, 'Correctly calculated price of all owned books'); # make sure joined/prefetched get_column of a PK dtrt $rs->reset; my $j_rs = $rs->search ({}, { join => 'tracks' })->get_column ('cdid'); is_deeply ( [ sort $j_rs->all ], [ sort map { my $c = $rs->next; ( ($c->id) x $c->tracks->count ) } (1 .. $rs->count) ], 'join properly explodes amount of rows from get_column', ); $rs->reset; my $p_rs = $rs->search ({}, { prefetch => 'tracks' })->get_column ('cdid'); is_deeply ( [ sort $p_rs->all ], [ sort $rs->get_column ('cdid')->all ], 'prefetch properly collapses amount of rows from get_column', ); $rs->reset; my $pob_rs = $rs->search({}, { select => ['me.title', 'tracks.title'], prefetch => 'tracks', order_by => [{-asc => ['position']}], group_by => ['me.title', 'tracks.title'], }); is_same_sql_bind ( $pob_rs->get_column("me.title")->as_query, '(SELECT me.title FROM (SELECT me.title, tracks.title FROM cd me LEFT JOIN track tracks ON tracks.cd = me.cdid GROUP BY me.title, tracks.title ORDER BY position ASC) me)', [], 'Correct SQL for prefetch/order_by/group_by' ); # test aggregate on a function (create an extra track on one cd) { my $tr_rs = $schema->resultset("Track"); $tr_rs->create({ cd => 2, title => 'dealbreaker' }); is( $tr_rs->get_column('cd')->max, 5, "Correct: Max cd in Track is 5" ); my $track_counts_per_cd_via_group_by = $tr_rs->search({}, { columns => [ 'cd', { cnt => { count => 'trackid', -as => 'cnt' } } ], group_by => 'cd', })->get_column('cnt'); is ($track_counts_per_cd_via_group_by->max, 4, 'Correct max tracks per cd'); is ($track_counts_per_cd_via_group_by->min, 3, 'Correct min tracks per cd'); is ( sprintf('%0.1f', $track_counts_per_cd_via_group_by->func('avg') ), '3.2', 'Correct avg tracks per cd' ); } # test exotic scenarious (create a track-less cd) # "How many CDs (not tracks) have been released per year where a given CD has at least one track and the artist isn't evancarroll?" { $schema->resultset('CD')->create({ artist => 1, title => 'dealbroker no tracks', year => 2001 }); my $yp1 = \[ 'year + ?', 1 ]; my $rs = $schema->resultset ('CD')->search ( { 'artist.name' => { '!=', 'evancarrol' }, 'tracks.trackid' => { '!=', undef } }, { order_by => 'me.year', join => [qw(artist tracks)], columns => [ 'year', { cnt => { count => 'me.cdid' } }, { year_plus_one => $yp1 }, ], }, ); my $rstypes = { 'explicitly grouped' => $rs->search_rs({}, { group_by => [ 'year', $yp1 ] } ), 'implicitly grouped' => $rs->search_rs({}, { distinct => 1 }), }; for my $type (keys %$rstypes) { is ($rstypes->{$type}->count, 4, "correct cd count with $type column"); is_deeply ( [ $rstypes->{$type}->get_column ('year')->all ], [qw(1997 1998 1999 2001)], "Getting $type column works", ); } # Why do we test this - we want to make sure that the selector *will* actually make # it to the group_by as per the distinct => 1 contract. Before 0.08251 this situation # would silently drop the group_by entirely, likely ending up with nonsensival results # With the current behavior the user will at least get a nice fat exception from the # RDBMS (or maybe the RDBMS will even decide to handle the situation sensibly...) for ( [ cnt => 'COUNT( me.cdid )' ], [ year_plus_one => 'year + ?' => [ {} => 1 ] ], ) { my ($col, $sel_grp_sql, @sel_grp_bind) = @$_; warnings_exist { is_same_sql_bind( $rstypes->{'implicitly grouped'}->get_column($col)->as_query, "( SELECT $sel_grp_sql FROM cd me JOIN artist artist ON artist.artistid = me.artist LEFT JOIN track tracks ON tracks.cd = me.cdid WHERE artist.name != ? AND tracks.trackid IS NOT NULL GROUP BY $sel_grp_sql ORDER BY MIN(me.year) )", [ @sel_grp_bind, [ { dbic_colname => 'artist.name', sqlt_datatype => 'varchar', sqlt_size => 100 } => 'evancarrol' ], @sel_grp_bind, ], 'Expected (though nonsensical) SQL generated on rscol-with-distinct-over-function', ) } qr/ \QUse of distinct => 1 while selecting anything other than a column \E \Qdeclared on the primary ResultSource is deprecated (you selected '$col')\E /x, 'deprecation warning'; } { local $TODO = 'multiplying join leaks through to the count aggregate... this may never actually work'; is_deeply ( [ $rstypes->{'explicitly grouped'}->get_column ('cnt')->all ], [qw(1 1 1 2)], "Get aggregate over group works", ); } } done_testing; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/101source.t�������������������������������������������������������������������0000644�0001750�0001750�00000000375�14240132261�015255� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use warnings; use strict; use Test::More; use Test::Exception; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema; throws_ok {$schema->source()} qr/\Qsource() expects a source name/, 'Empty args for source caught'; done_testing(); �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/resultsource/�����������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�016121� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/resultsource/bare_resultclass_exception.t�������������������������������������0000644�0001750�0001750�00000000356�14240132261�023704� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use lib 't/lib'; use DBICTest; { package DBICTest::Foo; use base "DBIx::Class::Core"; } throws_ok { DBICTest::Foo->new("urgh") } qr/must be a hashref/; done_testing; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/resultsource/set_primary_key.t������������������������������������������������0000644�0001750�0001750�00000001326�14240132261�021475� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use Test::Warn; use lib 't/lib'; use DBICTest; throws_ok { package Foo; use base 'DBIx::Class::Core'; __PACKAGE__->table('foo'); __PACKAGE__->set_primary_key('bar') } qr/No such column 'bar' on source 'foo' /, 'proper exception on non-existing column as PK'; warnings_exist { package Foo2; use base 'DBIx::Class::Core'; __PACKAGE__->table('foo'); __PACKAGE__->add_columns( foo => {}, bar => { is_nullable => 1 }, ); __PACKAGE__->set_primary_key(qw(foo bar)) } qr/Primary key of source 'foo' includes the column 'bar' which has its 'is_nullable' attribute set to true/, 'proper exception on is_nullable column as PK'; done_testing; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/107obj_result_class.t���������������������������������������������������������0000644�0001750�0001750�00000001605�14240132261�017315� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package ResultClassInflator; sub new { bless {}, __PACKAGE__ } 1; package main; use strict; use warnings; use Test::More tests => 6; use Test::Exception; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); my $source = $schema->source('CD'); lives_ok { $source->result_class('ResultClassInflator'); is($source->result_class => 'ResultClassInflator', "result_class gives us back class"); is($source->get_component_class('result_class') => 'ResultClassInflator', "and so does get_component_class"); } 'Result class still works with class'; lives_ok { my $obj = ResultClassInflator->new(); $source->result_class($obj); is($source->result_class => $obj, "result_class gives us back obj"); is($source->get_component_class('result_class') => $obj, "and so does get_component_class"); } 'Result class works with object'; done_testing; ���������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/74mssql.t���������������������������������������������������������������������0000644�0001750�0001750�00000022077�14240132261�015050� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use Scalar::Util 'weaken'; use DBIx::Class::Optional::Dependencies (); use lib qw(t/lib); use DBICTest; my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSSQL_${_}" } qw/DSN USER PASS/}; plan skip_all => 'Set $ENV{DBICTEST_MSSQL_DSN}, _USER and _PASS to run this test' unless ($dsn); plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_mssql_sybase') unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_mssql_sybase'); { my $srv_ver = DBICTest::Schema->connect($dsn, $user, $pass)->storage->_server_info->{dbms_version}; ok ($srv_ver, 'Got a test server version on fresh schema: ' . ($srv_ver||'???') ); } my $schema; my $testdb_supports_placeholders = DBICTest::Schema->connect($dsn, $user, $pass) ->storage ->_supports_typeless_placeholders; my @test_storages = ( $testdb_supports_placeholders ? 'DBI::Sybase::Microsoft_SQL_Server' : (), 'DBI::Sybase::Microsoft_SQL_Server::NoBindVars', ); for my $storage_type (@test_storages) { $schema = DBICTest::Schema->connect($dsn, $user, $pass); if ($storage_type =~ /NoBindVars\z/) { # since we want to use the nobindvar - disable the capability so the # rebless happens to the correct class $schema->storage->_use_typeless_placeholders (0); } local $ENV{DBIC_MSSQL_FREETDS_LOWVER_NOWARN} = 1; # disable nobindvars warning $schema->storage->ensure_connected; if ($storage_type =~ /NoBindVars\z/) { is $schema->storage->disable_sth_caching, 1, 'prepare_cached disabled for NoBindVars'; } isa_ok($schema->storage, "DBIx::Class::Storage::$storage_type"); SKIP: { skip 'This version of DBD::Sybase segfaults on disconnect', 1 if DBD::Sybase->VERSION < 1.08; # start disconnected to test _ping $schema->storage->_dbh->disconnect; lives_ok { $schema->storage->dbh_do(sub { $_[1]->do('select 1') }) } '_ping works'; } my $dbh = $schema->storage->dbh; $dbh->do("IF OBJECT_ID('artist', 'U') IS NOT NULL DROP TABLE artist"); $dbh->do("IF OBJECT_ID('cd', 'U') IS NOT NULL DROP TABLE cd"); $dbh->do("CREATE TABLE artist (artistid INT IDENTITY PRIMARY KEY, name VARCHAR(100), rank INT DEFAULT '13', charfield CHAR(10) NULL);"); $dbh->do("CREATE TABLE cd (cdid INT IDENTITY PRIMARY KEY, artist INT, title VARCHAR(100), year VARCHAR(100), genreid INT NULL, single_track INT NULL);"); # Just to test compat shim, Auto is in Core $schema->class('Artist')->load_components('PK::Auto::MSSQL'); # Test PK my $new = $schema->resultset('Artist')->create( { name => 'foo' } ); ok($new->artistid, "Auto-PK worked"); # Test LIMIT for (1..6) { $schema->resultset('Artist')->create( { name => 'Artist ' . $_, rank => $_ } ); } my $it = $schema->resultset('Artist')->search( { }, { rows => 3, offset => 2, order_by => 'artistid' } ); # Test ? in data don't get treated as placeholders my $cd = $schema->resultset('CD')->create( { artist => 1, title => 'Does this break things?', year => 2007, } ); ok($cd->id, 'Not treating ? in data as placeholders'); is( $it->count, 3, "LIMIT count ok" ); ok( $it->next->name, "iterator->next ok" ); $it->next; $it->next; is( $it->next, undef, "next past end of resultset ok" ); # test MONEY column support $schema->storage->dbh_do (sub { my ($storage, $dbh) = @_; eval { $dbh->do("DROP TABLE money_test") }; $dbh->do(<<'SQL'); CREATE TABLE money_test ( id INT IDENTITY PRIMARY KEY, amount MONEY NULL ) SQL }); my $rs = $schema->resultset('Money'); weaken(my $rs_cp = $rs); # nested closure refcounting is an utter mess in perl my $row; lives_ok { $row = $rs->create({ amount => 100 }); } 'inserted a money value'; cmp_ok $rs->find($row->id)->amount, '==', 100, 'money value round-trip'; lives_ok { $row->update({ amount => 200 }); } 'updated a money value'; cmp_ok $rs->find($row->id)->amount, '==', 200, 'updated money value round-trip'; lives_ok { $row->update({ amount => undef }); } 'updated a money value to NULL'; is $rs->find($row->id)->amount, undef, 'updated money value to NULL round-trip'; $rs->delete; # test simple transaction with commit lives_ok { $schema->txn_do(sub { $rs_cp->create({ amount => 300 }); }); } 'simple transaction'; cmp_ok $rs->first->amount, '==', 300, 'committed'; $rs->reset; $rs->delete; # test rollback throws_ok { $schema->txn_do(sub { $rs_cp->create({ amount => 700 }); die 'mtfnpy'; }); } qr/mtfnpy/, 'simple failed txn'; is $rs->first, undef, 'rolled back'; $rs->reset; $rs->delete; # test multiple active statements { $rs->create({ amount => 800 + $_ }) for 1..3; my @map = ( [ 'Artist 1', '801.00' ], [ 'Artist 2', '802.00' ], [ 'Artist 3', '803.00' ] ); my $artist_rs = $schema->resultset('Artist')->search({ name => { -like => 'Artist %' } });; my $i = 0; while (my $money_row = $rs->next) { my $artist_row = $artist_rs->next; is_deeply [ $artist_row->name, $money_row->amount ], $map[$i++], 'multiple active statements'; } $rs->reset; $rs->delete; } my $wrappers = { no_transaction => sub { shift->() }, txn_do => sub { my $code = shift; $schema->txn_do(sub { $code->() } ) }, txn_begin => sub { $schema->txn_begin; shift->(); $schema->txn_commit }, txn_guard => sub { my $g = $schema->txn_scope_guard; shift->(); $g->commit }, }; # test transaction handling on a disconnected handle for my $wrapper (keys %$wrappers) { $rs->delete; # a reconnect should trigger on next action $schema->storage->_get_dbh->disconnect; lives_and { $wrappers->{$wrapper}->( sub { $rs_cp->create({ amount => 900 + $_ }) for 1..3; }); is $rs->count, 3; } "transaction on disconnected handle with $wrapper wrapper"; } # test transaction handling on a disconnected handle with multiple active # statements for my $wrapper (keys %$wrappers) { $schema->storage->disconnect; $rs->delete; $rs->reset; $rs->create({ amount => 1000 + $_ }) for (1..3); my $artist_rs = $schema->resultset('Artist')->search({ name => { -like => 'Artist %' } });; $rs->next; my $map = [ ['Artist 1', '1002.00'], ['Artist 2', '1003.00'] ]; weaken(my $a_rs_cp = $artist_rs); local $TODO = 'Transaction handling with multiple active statements will ' .'need eager cursor support.' unless $wrapper eq 'no_transaction'; lives_and { my @results; $wrappers->{$wrapper}->( sub { while (my $money = $rs_cp->next) { my $artist = $a_rs_cp->next; push @results, [ $artist->name, $money->amount ]; }; }); is_deeply \@results, $map; } "transactions with multiple active statement with $wrapper wrapper"; } # test RNO detection when version detection fails SKIP: { my $storage = $schema->storage; my $version = $storage->_server_info->{normalized_dbms_version}; skip 'could not detect SQL Server version', 1 if not defined $version; my $have_rno = $version >= 9 ? 1 : 0; local $storage->{_dbh_details}{info} = {}; # delete cache my $rno_detected = ($storage->sql_limit_dialect eq 'RowNumberOver') ? 1 : 0; ok (($have_rno == $rno_detected), 'row_number() over support detected correctly'); } { my $schema = DBICTest::Schema->clone; $schema->connection($dsn, $user, $pass); like $schema->storage->sql_maker->{limit_dialect}, qr/^(?:Top|RowNumberOver)\z/, 'sql_maker is correct on unconnected schema'; } } # test op-induced autoconnect lives_ok (sub { my $schema = DBICTest::Schema->clone; $schema->connection($dsn, $user, $pass); my $artist = $schema->resultset ('Artist')->search ({}, { order_by => 'artistid' })->next; is ($artist->id, 1, 'Artist retrieved successfully'); }, 'Query-induced autoconnect works'); # test AutoCommit=0 { local $ENV{DBIC_UNSAFE_AUTOCOMMIT_OK} = 1; my $schema2 = DBICTest::Schema->connect($dsn, $user, $pass, { AutoCommit => 0 }); my $rs = $schema2->resultset('Money'); $rs->delete; $schema2->txn_commit; is $rs->count, 0, 'initially empty' || diag ('Found row with amount ' . $_->amount) for $rs->all; $rs->create({ amount => 3000 }); $schema2->txn_rollback; is $rs->count, 0, 'rolled back in AutoCommit=0' || diag ('Found row with amount ' . $_->amount) for $rs->all; $rs->create({ amount => 4000 }); $schema2->txn_commit; cmp_ok $rs->first->amount, '==', 4000, 'committed in AutoCommit=0'; } done_testing; # clean up our mess END { if (my $dbh = eval { $schema->storage->dbh }) { $dbh->do("IF OBJECT_ID('artist', 'U') IS NOT NULL DROP TABLE artist"); $dbh->do("IF OBJECT_ID('cd', 'U') IS NOT NULL DROP TABLE cd"); $dbh->do("IF OBJECT_ID('money_test', 'U') IS NOT NULL DROP TABLE money_test"); } undef $schema; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/40resultsetmanager.t����������������������������������������������������������0000644�0001750�0001750�00000001206�14240132261�017256� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Warn; use lib qw(t/lib); use DBICTest; warnings_exist { require DBICTest::ResultSetManager } [ qr/\QDBIx::Class::ResultSetManager never left experimental status/, ], 'found deprecation warning' ; my $schema = DBICTest::ResultSetManager->compose_namespace('DB'); my $rs = $schema->resultset('Foo'); ok( !DB::Foo->can('bar'), 'Foo class does not have bar method' ); ok( $rs->can('bar'), 'Foo resultset class has bar method' ); isa_ok( $rs, 'DBICTest::ResultSetManager::Foo::_resultset', 'Foo resultset class is correct' ); is( $rs->bar, 'good', 'bar method works' ); done_testing; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/90join_torture.t��������������������������������������������������������������0000644�0001750�0001750�00000017152�14240132261�016430� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use lib qw(t/lib); use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); lives_ok (sub { my $rs = $schema->resultset( 'CD' )->search( { 'producer.name' => 'blah', 'producer_2.name' => 'foo', }, { 'join' => [ { cd_to_producer => 'producer' }, { cd_to_producer => 'producer' }, ], 'prefetch' => [ 'artist', { cd_to_producer => { producer => 'producer_to_cd' } }, ], } ); my @executed = $rs->all(); is_same_sql_bind ( $rs->as_query, '( SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track, artist.artistid, artist.name, artist.rank, artist.charfield, cd_to_producer.cd, cd_to_producer.producer, cd_to_producer.attribute, producer.producerid, producer.name, producer_to_cd.cd, producer_to_cd.producer, producer_to_cd.attribute FROM cd me LEFT JOIN cd_to_producer cd_to_producer ON cd_to_producer.cd = me.cdid LEFT JOIN producer producer ON producer.producerid = cd_to_producer.producer LEFT JOIN cd_to_producer producer_to_cd ON producer_to_cd.producer = producer.producerid LEFT JOIN cd_to_producer cd_to_producer_2 ON cd_to_producer_2.cd = me.cdid LEFT JOIN producer producer_2 ON producer_2.producerid = cd_to_producer_2.producer JOIN artist artist ON artist.artistid = me.artist WHERE ( ( producer.name = ? AND producer_2.name = ? ) ) )', [ [ { sqlt_datatype => 'varchar', dbic_colname => 'producer.name', sqlt_size => 100 } => 'blah' ], [ { sqlt_datatype => 'varchar', dbic_colname => 'producer_2.name', sqlt_size => 100 } => 'foo' ], ], ); }, 'Complex join parsed/executed properly'); my @rs1a_results = $schema->resultset("Artist")->search_related('cds', {title => 'Forkful of bees'}, {order_by => 'title'}); is($rs1a_results[0]->title, 'Forkful of bees', "bare field conditions okay after search related"); my $rs1 = $schema->resultset("Artist")->search({ 'tags.tag' => 'Blue' }, { join => {'cds' => 'tracks'}, prefetch => {'cds' => 'tags'} }); my @artists = $rs1->all; cmp_ok(@artists, '==', 2, "Two artists returned"); my $rs2 = $rs1->search({ artistid => '1' }, { join => {'cds' => {'cd_to_producer' => 'producer'} } }); my @artists2 = $rs2->search({ 'producer.name' => 'Matt S Trout' }); my @cds = $artists2[0]->cds; cmp_ok(scalar @cds, '==', 1, "condition based on inherited join okay"); my $rs3 = $rs2->search_related('cds'); cmp_ok(scalar($rs3->all), '==', 15, "All cds for artist returned"); cmp_ok($rs3->count, '==', 15, "All cds for artist returned via count"); my $rs4 = $schema->resultset("CD")->search({ 'artist.artistid' => '1' }, { join => ['tracks', 'artist'], prefetch => 'artist', order_by => 'me.cdid' }); my @rs4_results = $rs4->all; is($rs4_results[0]->cdid, 1, "correct artist returned"); my $rs5 = $rs4->search({'tracks.title' => 'Sticky Honey'}); is($rs5->count, 1, "search without using previous joins okay"); my $record_rs = $schema->resultset("Artist")->search(undef, { join => 'cds' })->search(undef, { prefetch => { 'cds' => 'tracks' }}); my $record_jp = $record_rs->next; ok($record_jp, "prefetch on same rel okay"); my $artist = $schema->resultset("Artist")->find(1); my $cds = $artist->cds; is($cds->find(2)->title, 'Forkful of bees', "find on has many rs okay"); my $cd = $cds->search({'me.title' => 'Forkful of bees'}, { prefetch => 'tracks' })->first; my @tracks = $cd->tracks->all; is(scalar(@tracks), 3, 'right number of prefetched tracks after has many'); #causes ambig col error due to order_by #my $tracks_rs = $cds->search_related('tracks', { 'tracks.position' => '2', 'disc.title' => 'Forkful of bees' }); #my $first_tracks_rs = $tracks_rs->first; my $related_rs = $schema->resultset("Artist")->search({ name => 'Caterwauler McCrae' })->search_related('cds', { year => '2001'})->search_related('tracks', { 'position' => '2' }); is($related_rs->first->trackid, '5', 'search related on search related okay'); #causes ambig col error due to order_by #$related_rs->search({'cd.year' => '2001'}, {join => ['cd', 'cd']})->all; my $title = $schema->resultset("Artist")->search_related('twokeys')->search_related('cd')->search({'tracks.position' => '2'}, {join => 'tracks', order_by => 'tracks.trackid'})->next->title; is($title, 'Forkful of bees', 'search relateds with order by okay'); my $prod_rs = $schema->resultset("CD")->find(1)->producers_sorted; my $prod_rs2 = $prod_rs->search({ name => 'Matt S Trout' }); my $prod_first = $prod_rs2->first; is($prod_first->id, '1', 'somewhat pointless search on rel with order_by on it okay'); my $prod_map_rs = $schema->resultset("Artist")->find(1)->cds->search_related('cd_to_producer', {}, { join => 'producer', prefetch => 'producer' }); ok($prod_map_rs->next->producer, 'search related with prefetch okay'); my $stupid = $schema->resultset("Artist")->search_related('artist_undirected_maps', {}, { prefetch => 'artist1' })->search_related('mapped_artists')->search_related('cds', {'cds.cdid' => '2'}, { prefetch => 'tracks' }); my $cd_final = $schema->resultset("Artist")->search_related('artist_undirected_maps', {}, { prefetch => 'artist1' })->search_related('mapped_artists')->search_related('cds', {'cds.cdid' => '2'}, { prefetch => 'tracks' })->first; is($cd_final->cdid, '2', 'bonkers search_related-with-join-midway okay'); # should end up with cds and cds_2 joined my $merge_rs_1 = $schema->resultset("Artist")->search({ 'cds_2.cdid' => '2' }, { join => ['cds', 'cds'] }); is(scalar(@{$merge_rs_1->{attrs}->{join}}), 2, 'both joins kept'); ok($merge_rs_1->next, 'query on double joined rel runs okay'); # should only end up with cds joined my $merge_rs_2 = $schema->resultset("Artist")->search({ }, { join => 'cds' })->search({ 'cds.cdid' => '2' }, { join => 'cds' }); is(scalar(@{$merge_rs_2->{attrs}->{join}}), 1, 'only one join kept when inherited'); my $merge_rs_2_cd = $merge_rs_2->next; lives_ok (sub { my @rs_with_prefetch = $schema->resultset('TreeLike') ->search( {'me.id' => 1}, { prefetch => [ 'parent', { 'children' => 'parent' } ], }); }, 'pathological prefetch ok'); my $rs = $schema->resultset("Artist")->search({}, { join => 'twokeys' }); my $second_search_rs = $rs->search({ 'cds_2.cdid' => '2' }, { join => ['cds', 'cds'] }); is(scalar(@{$second_search_rs->{attrs}->{join}}), 3, 'both joins kept'); ok($second_search_rs->next, 'query on double joined rel runs okay'); # test joinmap pruner lives_ok ( sub { my $rs = $schema->resultset('Artwork')->search ( { }, { distinct => 1, join => [ { artwork_to_artist => 'artist' }, { cd => 'artist' }, ], }, ); is_same_sql_bind ( $rs->count_rs->as_query, '( SELECT COUNT( * ) FROM ( SELECT me.cd_id FROM cd_artwork me JOIN cd cd ON cd.cdid = me.cd_id JOIN artist artist_2 ON artist_2.artistid = cd.artist GROUP BY me.cd_id ) me )', [], ); ok (defined $rs->count); }); # make sure multiplying endpoints do not lose heir join-path lives_ok (sub { my $rs = $schema->resultset('CD')->search ( { }, { join => { artwork => 'images' } }, )->get_column('cdid'); is_same_sql_bind ( $rs->as_query, '( SELECT me.cdid FROM cd me LEFT JOIN cd_artwork artwork ON artwork.cd_id = me.cdid LEFT JOIN images images ON images.artwork_id = artwork.cd_id )', [], ); # execution $rs->next; }); done_testing; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/34exception_action.t����������������������������������������������������������0000644�0001750�0001750�00000004136�14240132261�017234� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use Test::Warn; use lib qw(t/lib); use DBICTest; # Set up the "usual" sqlite for DBICTest my $schema = DBICTest->init_schema; # This is how we're generating exceptions in the rest of these tests, # which might need updating at some future time to be some other # exception-generating statement: my $throw = sub { $schema->resultset("Artist")->search(1,1,1) }; my $ex_regex = qr/Odd number of arguments to search/; # Basic check, normal exception throws_ok \&$throw, $ex_regex; my $e = $@; # Re-throw the exception with rethrow() throws_ok { $e->rethrow } $ex_regex; isa_ok( $@, 'DBIx::Class::Exception' ); # Now lets rethrow via exception_action $schema->exception_action(sub { die @_ }); throws_ok \&$throw, $ex_regex; # # This should have never worked!!! # # Now lets suppress the error $schema->exception_action(sub { 1 }); throws_ok \&$throw, qr/exception_action handler .+ did \*not\* result in an exception.+original error: $ex_regex/; # Now lets fall through and let croak take back over $schema->exception_action(sub { return }); throws_ok { warnings_are \&$throw, qr/exception_action handler installed .+ returned false instead throwing an exception/; } $ex_regex; # again to see if no warning throws_ok { warnings_are \&$throw, []; } $ex_regex; # Whacky useless exception class { package DBICTest::Exception; use overload '""' => \&stringify, fallback => 1; sub new { my $class = shift; bless { msg => shift }, $class; } sub throw { my $self = shift; die $self if ref $self eq __PACKAGE__; die $self->new(shift); } sub stringify { "DBICTest::Exception is handling this: " . shift->{msg}; } } # Try the exception class $schema->exception_action(sub { DBICTest::Exception->throw(@_) }); throws_ok \&$throw, qr/DBICTest::Exception is handling this: $ex_regex/; # While we're at it, lets throw a custom exception through Storage::DBI throws_ok { $schema->storage->throw_exception('floob') } qr/DBICTest::Exception is handling this: floob/; done_testing; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/94pk_mutation.t���������������������������������������������������������������0000644�0001750�0001750�00000003066�14240132261�016242� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); plan tests => 10; my $old_artistid = 1; my $new_artistid = $schema->resultset("Artist")->get_column('artistid')->max + 1; # Update the PK { my $artist = $schema->resultset("Artist")->find($old_artistid); ok(defined $artist, 'found an artist with the new PK'); $artist->update({ artistid => $new_artistid }); is($artist->artistid, $new_artistid, 'artist ID matches'); } # Look for the old PK { my $artist = $schema->resultset("Artist")->find($old_artistid); ok(!defined $artist, 'no artist found with the old PK'); } # Look for the new PK { my $artist = $schema->resultset("Artist")->find($new_artistid); ok(defined $artist, 'found an artist with the new PK'); is($artist->artistid, $new_artistid, 'artist ID matches'); } # Do it all over again, using a different methodology: $old_artistid = $new_artistid; $new_artistid++; # Update the PK { my $artist = $schema->resultset("Artist")->find($old_artistid); ok(defined $artist, 'found an artist with the new PK'); $artist->artistid($new_artistid); $artist->update; is($artist->artistid, $new_artistid, 'artist ID matches'); } # Look for the old PK { my $artist = $schema->resultset("Artist")->find($old_artistid); ok(!defined $artist, 'no artist found with the old PK'); } # Look for the new PK { my $artist = $schema->resultset("Artist")->find($new_artistid); ok(defined $artist, 'found an artist with the new PK'); is($artist->artistid, $new_artistid, 'artist ID matches'); } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/745db2.t����������������������������������������������������������������������0000644�0001750�0001750�00000010107�14240132261�014434� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use Try::Tiny; use DBIx::Class::Optional::Dependencies (); use lib qw(t/lib); use DBICTest; plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_db2') unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_db2'); my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_DB2_${_}" } qw/DSN USER PASS/}; #warn "$dsn $user $pass"; plan skip_all => 'Set $ENV{DBICTEST_DB2_DSN}, _USER and _PASS to run this test' unless ($dsn && $user); my $schema = DBICTest::Schema->connect($dsn, $user, $pass); my $name_sep = $schema->storage->_dbh_get_info('SQL_QUALIFIER_NAME_SEPARATOR'); my $dbh = $schema->storage->dbh; # test RNO and name_sep detection is $schema->storage->sql_maker->name_sep, $name_sep, 'name_sep detection'; my $have_rno = try { $dbh->selectrow_array( "SELECT row_number() OVER (ORDER BY 1) FROM sysibm${name_sep}sysdummy1" ); 1; }; is $schema->storage->sql_maker->limit_dialect, ($have_rno ? 'RowNumberOver' : 'FetchFirst'), 'limit_dialect detection'; eval { $dbh->do("DROP TABLE artist") }; $dbh->do("CREATE TABLE artist (artistid INTEGER GENERATED BY DEFAULT AS IDENTITY (START WITH 1, INCREMENT BY 1), name VARCHAR(255), charfield CHAR(10), rank INTEGER DEFAULT 13);"); my $ars = $schema->resultset('Artist'); is ( $ars->count, 0, 'No rows at first' ); # test primary key handling my $new = $ars->create({ name => 'foo' }); ok($new->artistid, "Auto-PK worked"); # test explicit key spec $new = $ars->create ({ name => 'bar', artistid => 66 }); is($new->artistid, 66, 'Explicit PK worked'); $new->discard_changes; is($new->artistid, 66, 'Explicit PK assigned'); # test populate lives_ok (sub { my @pop; for (1..2) { push @pop, { name => "Artist_$_" }; } $ars->populate (\@pop); }); # test populate with explicit key lives_ok (sub { my @pop; for (1..2) { push @pop, { name => "Artist_expkey_$_", artistid => 100 + $_ }; } $ars->populate (\@pop); }); # count what we did so far is ($ars->count, 6, 'Simple count works'); # test LIMIT support my $lim = $ars->search( {}, { rows => 3, offset => 4, order_by => 'artistid' } ); is( $lim->count, 2, 'ROWS+OFFSET count ok' ); is( $lim->all, 2, 'Number of ->all objects matches count' ); # Limit with select-lock { local $TODO = "Seems we can't SELECT ... FOR ... on subqueries"; lives_ok { $schema->txn_do (sub { isa_ok ( $schema->resultset('Artist')->find({artistid => 1}, {for => 'update', rows => 1}), 'DBICTest::Schema::Artist', ); }); } 'Limited FOR UPDATE select works'; } # test iterator $lim->reset; is( $lim->next->artistid, 101, "iterator->next ok" ); is( $lim->next->artistid, 102, "iterator->next ok" ); is( $lim->next, undef, "next past end of resultset ok" ); # test FetchFirst limit dialect syntax { local $schema->storage->sql_maker->{limit_dialect} = 'FetchFirst'; my $lim = $ars->search({}, { rows => 3, offset => 2, order_by => 'artistid', }); is $lim->count, 3, 'fetch first limit count ok'; is $lim->all, 3, 'fetch first number of ->all objects matches count'; is $lim->next->artistid, 3, 'iterator->next ok'; is $lim->next->artistid, 66, 'iterator->next ok'; is $lim->next->artistid, 101, 'iterator->next ok'; is $lim->next, undef, 'iterator->next past end of resultset ok'; } my $test_type_info = { 'artistid' => { 'data_type' => 'INTEGER', 'is_nullable' => 0, 'size' => 10 }, 'name' => { 'data_type' => 'VARCHAR', 'is_nullable' => 1, 'size' => 255 }, 'charfield' => { 'data_type' => 'CHAR', 'is_nullable' => 1, 'size' => 10 }, 'rank' => { 'data_type' => 'INTEGER', 'is_nullable' => 1, 'size' => 10 }, }; my $type_info = $schema->storage->columns_info_for('artist'); is_deeply($type_info, $test_type_info, 'columns_info_for - column data types'); done_testing; # clean up our mess END { my $dbh = eval { $schema->storage->_dbh }; $dbh->do("DROP TABLE artist") if $dbh; undef $schema; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/zzzzzzz_perl_perf_bug.t�������������������������������������������������������0000644�0001750�0001750�00000010204�14240132261�020223� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); BEGIN { plan skip_all => 'Skipping RH perl performance bug tests as DBIC_NO_WARN_BAD_PERL set' if ( $ENV{DBIC_NO_WARN_BAD_PERL} ); require DBICTest::RunMode; plan skip_all => 'Skipping as system appears to be a smoker' if DBICTest::RunMode->is_smoker; } # globalllock so that the test runs alone use DBICTest ':GlobalLock'; use Benchmark; # This is a rather unusual test. # It does not test any aspect of DBIx::Class, but instead tests the # perl installation this is being run under to see if it is:- # 1. Potentially affected by a RH perl build bug # 2. If so we do a performance test for the effect of # that bug. # # You can skip these tests by setting the DBIC_NO_WARN_BAD_PERL env # variable # # If these tests fail then please read the section titled # Perl Performance Issues on Red Hat Systems in # L<DBIx::Class::Manual::Troubleshooting> # we do a benchmark test filling an array with blessed/overloaded references, # against an array filled with array refs. # On a sane system the ratio between these operation sets is 1 - 1.5, # whereas a bugged system gives a ratio of around 8 # we therefore consider there to be a problem if the ratio is >= $fail_ratio my $fail_ratio = 3; ok( $fail_ratio, "Testing for a blessed overload slowdown >= ${fail_ratio}x" ); my $results = timethese( -1, # run for 1 WALL second each { no_bless => sub { my %h; for ( my $i = 0 ; $i < 10000 ; $i++ ) { $h{$i} = []; } }, bless_overload => sub { use overload q(<) => sub { }; my %h; for ( my $i = 0 ; $i < 10000 ; $i++ ) { $h{$i} = bless [] => 'main'; } }, }, ); my $ratio = $results->{no_bless}->iters / $results->{bless_overload}->iters; cmp_ok( $ratio, '<', $fail_ratio, 'Overload/bless performance acceptable' ) || diag( "\n", "This perl has a substantial slow down when handling large numbers\n", "of blessed/overloaded objects. This can severely adversely affect\n", "the performance of DBIx::Class programs. Please read the section\n", "in the Troubleshooting POD documentation entitled\n", "'Perl Performance Issues on Red Hat Systems'\n", "As this is an extremely serious condition, the only way to skip\n", "over this test is to --force the installation, or to look in the test\n", "file " . __FILE__ . "\n", ); # We will only check for the difference in bless handling (whether the # bless applies to the reference or the referent) if we have seen a # performance issue... SKIP: { skip "Not checking for bless handling as performance is OK", 1 if Test::Builder->new->is_passing; { package # don't want this in PAUSE TestRHBug; use overload bool => sub { 0 } } sub _has_bug_34925 { my %thing; my $r1 = \%thing; my $r2 = \%thing; bless $r1 => 'TestRHBug'; return !!$r2; } sub _possibly_has_bad_overload_performance { return $] < 5.008009 && !_has_bug_34925(); } # If this next one fails then you almost certainly have a RH derived # perl with the performance bug # if this test fails, look at the section titled # "Perl Performance Issues on Red Hat Systems" in # L<DBIx::Class::Manual::Troubleshooting> # Basically you may suffer severe performance issues when running # DBIx::Class (and many other) modules. Look at getting a fixed # version of the perl interpreter for your system. # ok( !_possibly_has_bad_overload_performance(), 'Checking whether bless applies to reference not object' ) || diag( "\n", "This perl is probably derived from a buggy Red Hat perl build\n", "Please read the section in the Troubleshooting POD documentation\n", "entitled 'Perl Performance Issues on Red Hat Systems'\n", "As this is an extremely serious condition, the only way to skip\n", "over this test is to --force the installation, or to look in the test\n", "file " . __FILE__ . "\n", ); } done_testing; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/750firebird.t�����������������������������������������������������������������0000644�0001750�0001750�00000024113�14240132261�015551� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use DBIx::Class::Optional::Dependencies (); use Scope::Guard (); use List::Util 'shuffle'; use Try::Tiny; use lib qw(t/lib); use DBICTest; my $env2optdep = { DBICTEST_FIREBIRD => 'test_rdbms_firebird', DBICTEST_FIREBIRD_INTERBASE => 'test_rdbms_firebird_interbase', DBICTEST_FIREBIRD_ODBC => 'test_rdbms_firebird_odbc', }; plan skip_all => join (' ', 'Set $ENV{DBICTEST_FIREBIRD_DSN} and/or $ENV{DBICTEST_FIREBIRD_INTERBASE_DSN}', 'and/or $ENV{DBICTEST_FIREBIRD_ODBC_DSN},', '_USER and _PASS to run these tests.', 'WARNING: this test creates and drops the tables "artist", "bindtype_test" and', '"sequence_test"; the generators "gen_artist_artistid", "pkid1_seq", "pkid2_seq"', 'and "nonpkid_seq" and the trigger "artist_bi".', ) unless grep { $ENV{"${_}_DSN"} } keys %$env2optdep; # tests stolen from 749sybase_asa.t # Example DSNs: # dbi:Firebird:db=/var/lib/firebird/2.5/data/hlaghdb.fdb # dbi:InterBase:db=/var/lib/firebird/2.5/data/hlaghdb.fdb # Example ODBC DSN: # dbi:ODBC:Driver=Firebird;Dbname=/var/lib/firebird/2.5/data/hlaghdb.fdb my $schema; for my $prefix (shuffle keys %$env2optdep) { SKIP: { my ($dsn, $user, $pass) = map { $ENV{"${prefix}_$_"} } qw/DSN USER PASS/; next unless $dsn; # FIXME - work around https://github.com/google/sanitizers/issues/934 $prefix eq 'DBICTEST_FIREBIRD_ODBC' and $Config::Config{config_args} =~ m{fsanitize\=address} and skip( "ODBC Firebird driver doesn't yet work with ASAN: https://github.com/google/sanitizers/issues/934", 1 ); skip ("Testing with ${prefix}_DSN needs " . DBIx::Class::Optional::Dependencies->req_missing_for( $env2optdep->{$prefix} ), 1) unless DBIx::Class::Optional::Dependencies->req_ok_for($env2optdep->{$prefix}); note "Testing with ${prefix}_DSN"; $schema = DBICTest::Schema->connect($dsn, $user, $pass, { auto_savepoint => 1, quote_names => 1, ($dsn !~ /ODBC/ ? (on_connect_call => 'use_softcommit') : ()), }); my $dbh = $schema->storage->dbh; my $sg = Scope::Guard->new(sub { cleanup($schema) }); eval { $dbh->do(q[DROP TABLE "artist"]) }; $dbh->do(<<EOF); CREATE TABLE "artist" ( "artistid" INT PRIMARY KEY, "name" VARCHAR(255), "charfield" CHAR(10), "rank" INT DEFAULT 13 ) EOF eval { $dbh->do(q[DROP GENERATOR "gen_artist_artistid"]) }; $dbh->do('CREATE GENERATOR "gen_artist_artistid"'); eval { $dbh->do('DROP TRIGGER "artist_bi"') }; $dbh->do(<<EOF); CREATE TRIGGER "artist_bi" FOR "artist" ACTIVE BEFORE INSERT POSITION 0 AS BEGIN IF (NEW."artistid" IS NULL) THEN NEW."artistid" = GEN_ID("gen_artist_artistid",1); END EOF eval { $dbh->do('DROP TABLE "sequence_test"') }; $dbh->do(<<EOF); CREATE TABLE "sequence_test" ( "pkid1" INT NOT NULL, "pkid2" INT NOT NULL, "nonpkid" INT, "name" VARCHAR(255) ) EOF $dbh->do('ALTER TABLE "sequence_test" ADD CONSTRAINT "sequence_test_constraint" PRIMARY KEY ("pkid1", "pkid2")'); eval { $dbh->do('DROP GENERATOR "pkid1_seq"') }; eval { $dbh->do('DROP GENERATOR pkid2_seq') }; eval { $dbh->do('DROP GENERATOR "nonpkid_seq"') }; $dbh->do('CREATE GENERATOR "pkid1_seq"'); $dbh->do('CREATE GENERATOR pkid2_seq'); $dbh->do('SET GENERATOR pkid2_seq TO 9'); $dbh->do('CREATE GENERATOR "nonpkid_seq"'); $dbh->do('SET GENERATOR "nonpkid_seq" TO 19'); my $ars = $schema->resultset('Artist'); is ( $ars->count, 0, 'No rows at first' ); # test primary key handling my $new = $ars->create({ name => 'foo' }); ok($new->artistid, "Auto-PK worked"); # test auto increment using generators WITHOUT triggers for (1..5) { my $st = $schema->resultset('SequenceTest')->create({ name => 'foo' }); is($st->pkid1, $_, "Firebird Auto-PK without trigger: First primary key"); is($st->pkid2, $_ + 9, "Firebird Auto-PK without trigger: Second primary key"); is($st->nonpkid, $_ + 19, "Firebird Auto-PK without trigger: Non-primary key"); } my $st = $schema->resultset('SequenceTest')->create({ name => 'foo', pkid1 => 55 }); is($st->pkid1, 55, "Firebird Auto-PK without trigger: First primary key set manually"); # test transaction commit $schema->txn_do(sub { $ars->create({ name => 'in_transaction' }); }); ok (($ars->search({ name => 'in_transaction' })->first), 'transaction committed'); is $schema->storage->_dbh->{AutoCommit}, 1, '$dbh->{AutoCommit} is correct after transaction commit'; $ars->search({ name => 'in_transaction' })->delete; # test savepoints throws_ok { $schema->txn_do(sub { my ($schema, $ars) = @_; eval { $schema->txn_do(sub { $ars->create({ name => 'in_savepoint' }); die "rolling back savepoint"; }); }; ok ((not $ars->search({ name => 'in_savepoint' })->first), 'savepoint rolled back'); $ars->create({ name => 'in_outer_txn' }); die "rolling back outer txn"; }, $schema, $ars); } qr/rolling back outer txn/, 'correct exception for rollback'; is $schema->storage->_dbh->{AutoCommit}, 1, '$dbh->{AutoCommit} is correct after transaction rollback'; ok ((not $ars->search({ name => 'in_outer_txn' })->first), 'outer txn rolled back'); # test explicit key spec $new = $ars->create ({ name => 'bar', artistid => 66 }); is($new->artistid, 66, 'Explicit PK worked'); $new->discard_changes; is($new->artistid, 66, 'Explicit PK assigned'); # row update lives_ok { $new->update({ name => 'baz' }) } 'update survived'; $new->discard_changes; is $new->name, 'baz', 'row updated'; # test populate lives_ok (sub { my @pop; for (1..2) { push @pop, { name => "Artist_$_" }; } $ars->populate (\@pop); }); # test populate with explicit key lives_ok (sub { my @pop; for (1..2) { push @pop, { name => "Artist_expkey_$_", artistid => 100 + $_ }; } $ars->populate (\@pop); }); # count what we did so far is ($ars->count, 6, 'Simple count works'); # test ResultSet UPDATE lives_and { $ars->search({ name => 'foo' })->update({ rank => 4 }); is eval { $ars->search({ name => 'foo' })->first->rank }, 4; } 'Can update a column'; my ($updated) = $schema->resultset('Artist')->search({name => 'foo'}); is eval { $updated->rank }, 4, 'and the update made it to the database'; # test LIMIT support my $lim = $ars->search( {}, { rows => 3, offset => 4, order_by => 'artistid' } ); is( $lim->count, 2, 'ROWS+OFFSET count ok' ); is( $lim->all, 2, 'Number of ->all objects matches count' ); # test iterator $lim->reset; is( eval { $lim->next->artistid }, 101, "iterator->next ok" ); is( eval { $lim->next->artistid }, 102, "iterator->next ok" ); is( $lim->next, undef, "next past end of resultset ok" ); # test bug in paging my $paged = $ars->search({ name => { -like => 'Artist%' } }, { page => 1, rows => 2, order_by => 'artistid', }); my $row; lives_ok { $row = $paged->next; } 'paged query survived'; is try { $row->artistid }, 5, 'correct row from paged query'; # DBD bug - if any unfinished statements are present during # DDL manipulation (test blobs below)- a segfault will occur $paged->reset; # test nested cursors { my $rs1 = $ars->search({}, { order_by => { -asc => 'artistid' }}); my $rs2 = $ars->search({ artistid => $rs1->next->artistid }, { order_by => { -desc => 'artistid' } }); is $rs2->next->artistid, 1, 'nested cursors'; } # test empty insert lives_and { my $row = $ars->create({}); ok $row->artistid; } 'empty insert works'; # test inferring the generator from the trigger source and using it with # auto_nextval { local $ars->result_source->column_info('artistid')->{auto_nextval} = 1; lives_and { my $row = $ars->create({ name => 'introspecting generator' }); ok $row->artistid; } 'inferring generator from trigger source works'; } # at this point there should be no active statements # (finish() was called everywhere, either explicitly via # reset() or on DESTROY) for (keys %{$schema->storage->dbh->{CachedKids}}) { fail("Unreachable cached statement still active: $_") if $schema->storage->dbh->{CachedKids}{$_}->FETCH('Active'); } # test blobs (stolen from 73oracle.t) eval { $dbh->do('DROP TABLE "bindtype_test"') }; $dbh->do(q[ CREATE TABLE "bindtype_test" ( "id" INT PRIMARY KEY, "bytea" INT, "blob" BLOB, "clob" BLOB SUB_TYPE TEXT, "a_memo" INT ) ]); my %binstr = ( 'small' => join('', map { chr($_) } ( 1 .. 127 )) ); $binstr{'large'} = $binstr{'small'} x 1024; my $maxloblen = length $binstr{'large'}; local $dbh->{'LongReadLen'} = $maxloblen; my $rs = $schema->resultset('BindType'); my $id = 0; foreach my $type (qw( blob clob )) { foreach my $size (qw( small large )) { $id++; # turn off horrendous binary DBIC_TRACE output local $schema->storage->{debug} = 0; lives_ok { $rs->create( { 'id' => $id, $type => $binstr{$size} } ) } "inserted $size $type without dying"; my $got = $rs->find($id)->$type; my $hexdump = sub { join '', map sprintf('%02X', ord), split //, shift }; ok($got eq $binstr{$size}, "verified inserted $size $type" ) or do { diag "For " . (ref $schema->storage) . "\n"; diag "Got blob:\n"; diag $hexdump->(substr($got,0,50)); diag "Expecting blob:\n"; diag $hexdump->(substr($binstr{$size},0,50)); }; } } }} done_testing; # clean up our mess sub cleanup { my $schema = shift; my $dbh; eval { $schema->storage->disconnect; # to avoid object FOO is in use errors $dbh = $schema->storage->dbh; }; return unless $dbh; eval { $dbh->do('DROP TRIGGER "artist_bi"') }; diag $@ if $@; foreach my $generator (qw/ "gen_artist_artistid" "pkid1_seq" pkid2_seq "nonpkid_seq" /) { eval { $dbh->do(qq{DROP GENERATOR $generator}) }; diag $@ if $@; } foreach my $table (qw/artist sequence_test/) { eval { $dbh->do(qq[DROP TABLE "$table"]) }; diag $@ if $@; } eval { $dbh->do(q{DROP TABLE "bindtype_test"}) }; diag $@ if $@; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/delete/�����������������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�014624� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/delete/m2m.t������������������������������������������������������������������0000644�0001750�0001750�00000000746�14240132261�015472� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); my $cd = $schema->resultset("CD")->find(2); ok $cd->liner_notes; ok scalar(keys %{$cd->{_relationship_data}}), "_relationship_data populated"; $cd->discard_changes; ok $cd->liner_notes, 'relationships still valid after discarding changes'; ok $cd->liner_notes->delete; $cd->discard_changes; ok !$cd->liner_notes, 'discard_changes resets relationship'; done_testing; ��������������������������DBIx-Class-0.082843/t/delete/cascade_missing.t������������������������������������������������������0000644�0001750�0001750�00000001034�14240132261�020102� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Warn; use Test::Exception; use lib 't/lib'; use DBICTest; my $schema = DBICTest->init_schema(); $schema->_unregister_source('CD'); warnings_exist { my $s = $schema; lives_ok { $_->delete for $s->resultset('Artist')->all; } 'delete on rows with dangling rels lives'; } [ # 9 == 3 artists * failed cascades: # cds # cds_unordered # cds_very_very_very_long_relationship_name (qr/skipping cascad/i) x 9 ], 'got warnings about cascading deletes'; done_testing; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/delete/related.t��������������������������������������������������������������0000644�0001750�0001750�00000003730�14240132261�016413� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); my $ars = $schema->resultset('Artist'); my $cdrs = $schema->resultset('CD'); my $cd2pr_rs = $schema->resultset('CD_to_Producer'); # create some custom entries $ars->populate ([ [qw/artistid name/], [qw/71 a1/], [qw/72 a2/], [qw/73 a3/], ]); $cdrs->populate ([ [qw/cdid artist title year/], [qw/70 71 delete0 2005/], [qw/71 72 delete1 2005/], [qw/72 72 delete2 2005/], [qw/73 72 delete3 2006/], [qw/74 72 delete4 2007/], [qw/75 73 delete5 2008/], ]); my $prod = $schema->resultset('Producer')->create ({ name => 'deleter' }); my $prod_cd = $cdrs->find (70); my $cd2pr = $cd2pr_rs->create ({ producer => $prod, cd => $prod_cd, }); my $total_cds = $cdrs->count; # test that delete_related w/o conditions deletes all related records only $ars->search ({name => 'a3' })->search_related ('cds')->delete; is ($cdrs->count, $total_cds -= 1, 'related delete ok'); my $a2_cds = $ars->search ({ name => 'a2' })->search_related ('cds'); # test that related deletion w/conditions deletes just the matched related records only $a2_cds->search ({ year => 2005 })->delete; is ($cdrs->count, $total_cds -= 2, 'related + condition delete ok'); # test that related deletion with limit condition works $a2_cds->search ({}, { rows => 1})->delete; is ($cdrs->count, $total_cds -= 1, 'related + limit delete ok'); { local $TODO = 'delete_related is based on search_related which is based on search which does not understand object arguments'; local $SIG{__WARN__} = sub {}; # trap the non-numeric warning, remove when the TODO is removed my $cd2pr_count = $cd2pr_rs->count; $prod_cd->delete_related('cd_to_producer', { producer => $prod } ); is ($cd2pr_rs->count, $cd2pr_count -= 1, 'm2m link deleted succesfully'); # see 187ec69a for why this is neccessary $prod->result_source(undef); } done_testing; ����������������������������������������DBIx-Class-0.082843/t/delete/complex.t��������������������������������������������������������������0000644�0001750�0001750�00000001357�14240132261�016445� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); my $artist_rs = $schema->resultset ('Artist'); my $init_count = $artist_rs->count; ok ($init_count, 'Some artists is database'); foreach my $delete_arg ( [ { 'me.name' => 'foo' }, { 'me.name' => 'bar' } ], [ 'me.name' => 'foo', 'me.name' => 'bar' ], ) { $artist_rs->populate ([ { name => 'foo', }, { name => 'bar', } ]); is ($artist_rs->count, $init_count + 2, '2 Artists created'); $artist_rs->search ({ -and => [ { 'me.artistid' => { '!=', undef } }, $delete_arg, ], })->delete; is ($artist_rs->count, $init_count, 'Correct amount of artists deleted'); } done_testing; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/20setuperrors.t���������������������������������������������������������������0000644�0001750�0001750�00000000575�14240132261�016274� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use warnings; use strict; use Test::More; use Test::Exception; use lib 't/lib'; use DBICTest; throws_ok ( sub { package BuggyTable; use base 'DBIx::Class::Core'; __PACKAGE__->table('buggy_table'); __PACKAGE__->columns( qw/this doesnt work as expected/ ); }, qr/\bcolumns\(\) is a read-only/, 'columns() error when apparently misused', ); done_testing; �����������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/ordered/����������������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�015006� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/ordered/cascade_delete.t������������������������������������������������������0000644�0001750�0001750�00000001063�14240132261�020057� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); { my $artist = $schema->resultset ('Artist')->search ({}, { rows => 1})->single; # braindead sqlite my $cd = $schema->resultset ('CD')->create ({ artist => $artist, title => 'Get in order', year => 2009, tracks => [ { title => 'T1' }, { title => 'T2' }, { title => 'T3' }, ], }); lives_ok (sub { $cd->delete}, "Cascade delete on ordered has_many doesn't bomb"); } done_testing; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/ordered/unordered_movement.t��������������������������������������������������0000644�0001750�0001750�00000001171�14240132261�021053� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); my $cd = $schema->resultset('CD')->next; $cd->tracks->delete; $schema->resultset('CD')->related_resultset('tracks')->delete; is $cd->tracks->count, 0, 'No tracks'; $cd->create_related('tracks', { title => "t_$_", position => $_ }) for (4,2,3,1,5); is $cd->tracks->count, 5, 'Created 5 tracks'; # a txn should force the implicit pos reload, regardless of order $schema->txn_do(sub { $cd->tracks->delete_all }); is $cd->tracks->count, 0, 'Successfully deleted everything'; done_testing; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/schema/�����������������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�014622� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/schema/anon.t�����������������������������������������������������������������0000644�0001750�0001750�00000000422�14240132261�015717� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use lib qw(t/lib); use DBICTest; lives_ok (sub { DBICTest->init_schema()->resultset('Artist')->find({artistid => 1 })->update({name => 'anon test'}); }, 'Schema object not lost in chaining'); done_testing; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/schema/clone.t����������������������������������������������������������������0000644�0001750�0001750�00000001065�14240132261�016070� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); { my $clone = $schema->clone; cmp_ok ($clone->storage, 'eq', $schema->storage, 'Storage copied into new schema (not a new instance)'); } { is $schema->custom_attr, undef; my $clone = $schema->clone(custom_attr => 'moo'); is $clone->custom_attr, 'moo', 'cloning can change existing attrs'; } { my $clone = $schema->clone({ custom_attr => 'moo' }); is $clone->custom_attr, 'moo', 'cloning can change existing attrs'; } done_testing; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/39load_namespaces_4.t���������������������������������������������������������0000644�0001750�0001750�00000001530�14240132261�017242� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; # do not remove even though it is not used plan tests => 6; my $warnings; eval { local $SIG{__WARN__} = sub { $warnings .= shift }; package DBICNSTest; use base qw/DBIx::Class::Schema/; __PACKAGE__->load_namespaces( default_resultset_class => 'RSBase' ); }; ok(!$@) or diag $@; like($warnings, qr/load_namespaces found ResultSet class 'DBICNSTest::ResultSet::C' with no corresponding Result class/); my $source_a = DBICNSTest->source('A'); isa_ok($source_a, 'DBIx::Class::ResultSource::Table'); my $rset_a = DBICNSTest->resultset('A'); isa_ok($rset_a, 'DBICNSTest::ResultSet::A'); my $source_b = DBICNSTest->source('B'); isa_ok($source_b, 'DBIx::Class::ResultSource::Table'); my $rset_b = DBICNSTest->resultset('B'); isa_ok($rset_b, 'DBICNSTest::RSBase'); ������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/79aliasing.t������������������������������������������������������������������0000644�0001750�0001750�00000004471�14240132261�015503� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); plan tests => 11; # Check that you can leave off the alias { my $artist = $schema->resultset('Artist')->find(1); my $existing_cd = $artist->search_related('cds', undef, { prefetch => 'tracks' })->find_or_create({ title => 'Ted', year => 2006, }); ok(! $existing_cd->is_changed, 'find_or_create on prefetched has_many with same column names: row is clean'); is($existing_cd->title, 'Ted', 'find_or_create on prefetched has_many with same column names: name matches existing entry'); my $new_cd = $artist->search_related('cds', undef, { prefetch => 'tracks' })->find_or_create({ title => 'Something Else', year => 2006, }); ok(! $new_cd->is_changed, 'find_or_create on prefetched has_many with same column names: row is clean'); is($new_cd->title, 'Something Else', 'find_or_create on prefetched has_many with same column names: title matches'); } # Check that you can specify the alias { my $artist = $schema->resultset('Artist')->find(1); my $existing_cd = $artist->search_related('cds', undef, { prefetch => 'tracks' })->find_or_create({ 'me.title' => 'Something Else', 'me.year' => 2006, }); ok(! $existing_cd->is_changed, 'find_or_create on prefetched has_many with same column names: row is clean'); is($existing_cd->title, 'Something Else', 'find_or_create on prefetched has_many with same column names: can be disambiguated with "me." for existing entry'); my $new_cd = $artist->search_related('cds', undef, { prefetch => 'tracks' })->find_or_create({ 'me.title' => 'Some New Guy', 'me.year' => 2006, }); ok(! $new_cd->is_changed, 'find_or_create on prefetched has_many with same column names: row is clean'); is($new_cd->title, 'Some New Guy', 'find_or_create on prefetched has_many with same column names: can be disambiguated with "me." for new entry'); } # Don't pass column names with related alias to new_result { my $cd_rs = $schema->resultset('CD')->search({ 'artist.name' => 'Caterwauler McCrae' }, { join => 'artist' }); my $cd = $cd_rs->find_or_new({ title => 'Huh?', year => 2006 }); is($cd->in_storage, 0, 'new CD not in storage yet'); is($cd->title, 'Huh?', 'new CD title is correct'); is($cd->year, 2006, 'new CD year is correct'); } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/35exception_inaction.t��������������������������������������������������������0000644�0001750�0001750�00000004661�14240132261�017567� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use lib 't/lib'; use DBICTest::RunMode; BEGIN { if( DBICTest::RunMode->is_plain ) { print "1..0 # SKIP not running dangerous segfault-prone test on plain install\n"; exit 0; } } use File::Temp (); use DBIx::Class::_Util 'scope_guard'; use DBIx::Class::Schema; # Do not use T::B - the test is hard enough not to segfault as it is my $test_count = 0; # start with one failure, and decrement it at the end my $failed = 1; sub ok { printf STDOUT ("%s %u - %s\n", ( $_[0] ? 'ok' : 'not ok' ), ++$test_count, $_[1] || '', ); unless( $_[0] ) { $failed++; printf STDERR ("# Failed test #%d at %s line %d\n", $test_count, (caller(0))[1,2] ); } return !!$_[0]; } # yes, make it even dirtier my $schema = 'DBIx::Class::Schema'; $schema->connection('dbi:SQLite::memory:'); # this is incredibly horrible... # demonstrate utter breakage of the reconnection/retry logic # open(my $stderr_copy, '>&', *STDERR) or die "Unable to dup STDERR: $!"; my $tf = File::Temp->new( UNLINK => 1 ); my $output; ESCAPE: { my $guard = scope_guard { close STDERR; open(STDERR, '>&', $stderr_copy); $output = do { local (@ARGV, $/) = $tf; <> }; close $tf; unlink $tf; undef $tf; close $stderr_copy; }; close STDERR; open(STDERR, '>&', $tf) or die "Unable to reopen STDERR: $!"; $schema->storage->ensure_connected; $schema->storage->_dbh->disconnect; local $SIG{__WARN__} = sub {}; $schema->exception_action(sub { ok(1, 'exception_action invoked'); # essentially what Dancer2's redirect() does after https://github.com/PerlDancer/Dancer2/pull/485 # which "nicely" combines with: https://metacpan.org/source/MARKOV/Log-Report-1.12/lib/Dancer2/Plugin/LogReport.pm#L143 # as encouraged by: https://metacpan.org/pod/release/MARKOV/Log-Report-1.12/lib/Dancer2/Plugin/LogReport.pod#Logging-DBIC-database-queries-and-errors last ESCAPE; }); # this *DOES* throw, but the exception will *NEVER SHOW UP* $schema->storage->dbh_do(sub { $_[1]->selectall_arrayref("SELECT * FROM wfwqfdqefqef") } ); # NEITHER will this ok(0, "Nope"); } ok(1, "Post-escape reached"); ok( !!( $output =~ /DBIx::Class INTERNAL PANIC.+FIX YOUR ERROR HANDLING/s ), 'Proper warning emitted on STDERR' ) or print STDERR "Instead found:\n\n$output\n"; print "1..$test_count\n"; # this is our "done_testing" $failed--; # avoid tasty segfaults on 5.8.x exit( $failed ); �������������������������������������������������������������������������������DBIx-Class-0.082843/t/96_is_deteministic_value.t����������������������������������������������������0000644�0001750�0001750�00000002574�14240132261�020424� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use lib qw(t/lib); use DBICTest; BEGIN { require DBIx::Class; plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_dt') unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt'); } my $schema = DBICTest->init_schema(); my $artist_rs = $schema->resultset('Artist'); my $cd_rs = $schema->resultset('CD'); { my $cd; lives_ok { $cd = $cd_rs->search({ year => {'=' => 1999}})->create ({ artist => {name => 'Guillermo1'}, title => 'Guillermo 1', }); }; is($cd->year, 1999); } { my $formatter = DateTime::Format::Strptime->new(pattern => '%Y'); my $dt = DateTime->new(year => 2006, month => 06, day => 06, formatter => $formatter ); my $cd; lives_ok { $cd = $cd_rs->search({ year => $dt})->create ({ artist => {name => 'Guillermo2'}, title => 'Guillermo 2', }); }; is($cd->year, 2006); } { my $artist; lives_ok { $artist = $artist_rs->search({ name => {'!=' => 'Killer'}}) ->create({artistid => undef}); }; is($artist->name, undef); } { my $artist; lives_ok { $artist = $artist_rs->search({ name => [ qw(some stupid names here) ]}) ->create({artistid => undef}); }; is($artist->name, undef); } done_testing; ������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/55namespaces_cleaned.t��������������������������������������������������������0000644�0001750�0001750�00000014030�14240132261�017470� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BEGIN { if ($] < 5.010) { # Pre-5.10 perls pollute %INC on unsuccesfull module # require, making it appear as if the module is already # loaded on subsequent require()s # Can't seem to find the exact RT/perldelta entry # # The reason we can't just use a sane, clean loader, is because # if a Module require()s another module the %INC will still # get filled with crap and we are back to square one. A global # fix is really the only way for this test, as we try to load # each available module separately, and have no control (nor # knowledge) over their common dependencies. # # we want to do this here, in the very beginning, before even # warnings/strict are loaded unshift @INC, 't/lib'; require DBICTest::Util::OverrideRequire; DBICTest::Util::OverrideRequire::override_global_require( sub { my $res = eval { $_[0]->() }; if ($@ ne '') { delete $INC{$_[1]}; die $@; } return $res; } ); } } use strict; use warnings; # FIXME This is a crock of shit, needs to go away # currently here to work around https://rt.cpan.org/Ticket/Display.html?id=74151 # kill with fire when PS::XS / RT#74151 is *finally* fixed BEGIN { my $PS_provider; if ( "$]" < 5.010 ) { require Package::Stash::PP; $PS_provider = 'Package::Stash::PP'; } else { require Package::Stash; $PS_provider = 'Package::Stash'; } eval <<"EOS" or die $@; sub stash_for (\$) { $PS_provider->new(\$_[0]); } 1; EOS } use Test::More; use lib 't/lib'; BEGIN { require DBICTest::RunMode; plan( skip_all => "Skipping test on plain module install" ) if DBICTest::RunMode->is_plain; } use DBICTest; use File::Find; use File::Spec; use B qw/svref_2object/; # makes sure we can load at least something use DBIx::Class; use DBIx::Class::Carp; my @modules = grep { my ($mod) = $_ =~ /(.+)/; # not all modules are loadable at all times do { # trap deprecation warnings and whatnot local $SIG{__WARN__} = sub {}; eval "require $mod"; } ? $mod : do { SKIP: { skip "Failed require of $mod: " . ($@ =~ /^(.+?)$/m)[0], 1 }; (); # empty RV for @modules }; } find_modules(); # have an exception table for old and/or weird code we are not sure # we *want* to clean in the first place my $skip_idx = { map { $_ => 1 } ( (grep { /^DBIx::Class::CDBICompat/ } @modules), # too crufty to touch 'SQL::Translator::Producer::DBIx::Class::File', # ditto # not sure how to handle type libraries 'DBIx::Class::Storage::DBI::Replicated::Types', 'DBIx::Class::Admin::Types', # G::L::D is unclean, but we never inherit from it 'DBIx::Class::Admin::Descriptive', 'DBIx::Class::Admin::Usage', # utility classes, not part of the inheritance chain 'DBIx::Class::ResultSource::RowParser::Util', 'DBIx::Class::_Util', ) }; my $has_moose = eval { require Moose::Util }; # can't use Class::Inspector for the mundane parts as it does not # distinguish imports from anything else, what a crock of... # Moose is not always available either - hence just do it ourselves my $seen; #inheritance means we will see the same method multiple times for my $mod (@modules) { SKIP: { skip "$mod exempt from namespace checks",1 if $skip_idx->{$mod}; my %all_method_like = (map { %{stash_for($_)->get_all_symbols('CODE')} } (reverse @{mro::get_linear_isa($mod)}) ); my %parents = map { $_ => 1 } @{mro::get_linear_isa($mod)}; my %roles; if ($has_moose and my $mc = Moose::Util::find_meta($mod)) { if ($mc->can('calculate_all_roles_with_inheritance')) { $roles{$_->name} = 1 for ($mc->calculate_all_roles_with_inheritance); } } for my $name (keys %all_method_like) { # overload is a funky thing - it is not cleaned, and its imports are named funny next if $name =~ /^\(/; my $gv = svref_2object($all_method_like{$name})->GV; my $origin = $gv->STASH->NAME; is ($gv->NAME, $name, "Properly named $name method at $origin" . ($origin eq $mod ? '' : " (inherited by $mod)" )); next if $seen->{"${origin}:${name}"}++; if ($origin eq $mod) { pass ("$name is a native $mod method"); } elsif ($roles{$origin}) { pass ("${mod}::${name} came from consumption of role $origin"); } elsif ($parents{$origin}) { pass ("${mod}::${name} came from proper parent-class $origin"); } else { my $via; for (reverse @{mro::get_linear_isa($mod)} ) { if ( ($_->can($name)||'') eq $all_method_like{$name} ) { $via = $_; last; } } # exception time if ( ( $name eq 'import' and $via = 'Exporter' ) ) { pass("${mod}::${name} is a valid uncleaned import from ${name}"); } else { fail ("${mod}::${name} appears to have entered inheritance chain by import into " . ($via || 'UNKNOWN') ); } } } # some common import names (these should never ever be methods) for my $f (qw/carp carp_once carp_unique croak confess cluck try catch finally/) { if ($mod->can($f)) { my $via; for (reverse @{mro::get_linear_isa($mod)} ) { if ( ($_->can($f)||'') eq $all_method_like{$f} ) { $via = $_; last; } } fail ("Import $f leaked into method list of ${mod}, appears to have entered inheritance chain at " . ($via || 'UNKNOWN') ); } else { pass ("Import $f not leaked into method list of $mod"); } } } } sub find_modules { my @modules; find( { wanted => sub { -f $_ or return; s/\.pm$// or return; s/^ (?: lib | blib . (?:lib|arch) ) . //x; push @modules, join ('::', File::Spec->splitdir($_)); }, no_chdir => 1, }, ( # find them in both lib and blib, duplicates are fine, since # @INC is preadjusted for us by the harness 'lib', ( -e 'blib' ? 'blib' : () ), )); return sort @modules; } done_testing; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/84serialize.t�����������������������������������������������������������������0000644�0001750�0001750�00000012261�14240132261�015673� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use lib qw(t/lib); use DBICTest; use Storable qw(dclone freeze nfreeze thaw); use Scalar::Util qw/refaddr/; use Carp; sub ref_ne { my ($refa, $refb) = map { refaddr $_ or croak "$_ is not a reference!" } @_[0,1]; cmp_ok ( $refa, '!=', $refb, sprintf ('%s (0x%07x != 0x%07x)', $_[2], $refa, $refb, ), ); } my $schema = DBICTest->init_schema; my %stores = ( dclone_method => sub { return $schema->dclone($_[0]) }, dclone_func => sub { local $DBIx::Class::ResultSourceHandle::thaw_schema = $schema; return dclone($_[0]) }, "freeze/thaw_method" => sub { my $ice = $schema->freeze($_[0]); return $schema->thaw($ice); }, "nfreeze/thaw_func" => sub { my $ice = freeze($_[0]); local $DBIx::Class::ResultSourceHandle::thaw_schema = $schema; return thaw($ice); }, "freeze/thaw_func (cdbi legacy)" => sub { # this one is special-cased to leak the $schema all over # the same way as cdbi-compat does DBICTest::Artist->result_source_instance->schema($schema); DBICTest::CD->result_source_instance->schema($schema); my $fire = thaw(freeze($_[0])); # clean up the mess $_->result_source_instance->schema(undef) for map { $schema->class ($_) } $schema->sources; return $fire; }, ); if ($ENV{DBICTEST_MEMCACHED}) { if (DBIx::Class::Optional::Dependencies->req_ok_for ('test_memcached')) { my $memcached = Cache::Memcached->new( { servers => [ $ENV{DBICTEST_MEMCACHED} ] } ); my $key = 'tmp_dbic_84serialize_memcached_test'; $stores{memcached} = sub { $memcached->set( $key, $_[0], 60 ) or die "Unable to insert into $ENV{DBICTEST_MEMCACHED} - is server running?"; local $DBIx::Class::ResultSourceHandle::thaw_schema = $schema; return $memcached->get($key); }; } else { SKIP: { skip 'Memcached tests need ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_memcached'), 1; } } } else { SKIP: { skip 'Set $ENV{DBICTEST_MEMCACHED} to run the memcached serialization tests', 1; } } for my $name (keys %stores) { my $store = $stores{$name}; my $copy; my $artist = $schema->resultset('Artist')->find(1); lives_ok { $copy = $store->($artist) } "serialize row object lives: $name"; ref_ne($copy, $artist, 'Simple row cloned'); is_deeply($copy, $artist, "serialize row object works: $name"); my $cd_rs = $artist->search_related("cds"); # test that a live result source can be serialized as well is( $cd_rs->count, 3, '3 CDs in database'); ok( $cd_rs->next, 'Advance cursor' ); lives_ok { $copy = $store->($cd_rs); ref_ne($copy, $artist, 'Simple row cloned'); is_deeply ( [ $copy->all ], [ $cd_rs->all ], "serialize resultset works: $name", ); } "serialize resultset lives: $name"; # Test that an object with a related_resultset can be serialized. ok $artist->{related_resultsets}, 'has key: related_resultsets'; lives_ok { $copy = $store->($artist) } "serialize row object with related_resultset lives: $name"; for my $key (keys %$artist) { next if $key eq 'related_resultsets'; next if $key eq '_inflated_column'; ref_ne($copy->{$key}, $artist->{$key}, "Simple row internals cloned '$key'") if ref $artist->{$key}; is_deeply($copy->{$key}, $artist->{$key}, qq[serialize with related_resultset '$key']); } lives_ok( sub { $copy->discard_changes }, "Discard changes works: $name" ) or diag $@; is($copy->id, $artist->id, "IDs still match "); # Test resultsource with cached rows $schema->is_executed_querycount( sub { $cd_rs = $cd_rs->search ({}, { cache => 1 }); # this will hit the database once and prime the cache my @cds = $cd_rs->all; $copy = $store->($cd_rs); ref_ne($copy, $cd_rs, 'Cached resultset cloned'); is_deeply ( [ $copy->all ], [ $cd_rs->all ], "serialize cached resultset works: $name", ); is ($copy->count, $cd_rs->count, 'Cached count identical'); }, 1, 'Only one db query fired'); } # test schema-less detached thaw { my $artist = $schema->resultset('Artist')->find(1); $artist = dclone $artist; is( $artist->name, 'Caterwauler McCrae', 'getting column works' ); ok( $artist->update, 'Non-dirty update noop' ); ok( $artist->name( 'Beeeeeeees' ), 'setting works' ); ok( $artist->is_column_changed( 'name' ), 'Column dirtyness works' ); ok( $artist->is_changed, 'object dirtyness works' ); my $rs = $artist->result_source->resultset; $rs->set_cache([ $artist ]); is( $rs->count, 1, 'Synthetic resultset count works' ); my $exc = qr/Unable to perform storage-dependent operations with a detached result source.+use \$schema->thaw/; throws_ok { $artist->update } $exc, 'Correct exception on row op' ; throws_ok { $artist->discard_changes } $exc, 'Correct exception on row op' ; throws_ok { $rs->find(1) } $exc, 'Correct exception on rs op' ; } done_testing; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/94versioning.t����������������������������������������������������������������0000644�0001750�0001750�00000025145�14240132261�016075� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Warn; use Test::Exception; use Path::Class; use File::Copy; use Time::HiRes qw/time sleep/; use lib qw(t/lib); use DBICTest; use DBIx::Class::_Util 'sigwarn_silencer'; my ($dsn, $user, $pass); BEGIN { ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MYSQL_${_}" } qw/DSN USER PASS/}; plan skip_all => 'Set $ENV{DBICTEST_MYSQL_DSN}, _USER and _PASS to run this test' unless ($dsn); require DBIx::Class; plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('deploy') unless DBIx::Class::Optional::Dependencies->req_ok_for ('deploy'); plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_mysql') unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_mysql'); } # this is just to grab a lock { my $s = DBICTest::Schema->connect($dsn, $user, $pass); } # in case it came from the env $ENV{DBIC_NO_VERSION_CHECK} = 0; # FIXME - work around RT#113965 in combination with -T on older perls: # the non-deparsing XS portion of D::D gets confused by some of the IO # handles trapped in the debug object of DBIC. What a mess. $Data::Dumper::Deparse = 1; use_ok('DBICVersion_v1'); my $version_table_name = 'dbix_class_schema_versions'; my $old_table_name = 'SchemaVersions'; my $ddl_dir = dir(qw/t var/, "versioning_ddl-$$"); $ddl_dir->mkpath unless -d $ddl_dir; my $fn = { v1 => $ddl_dir->file ('DBICVersion-Schema-1.0-MySQL.sql'), v2 => $ddl_dir->file ('DBICVersion-Schema-2.0-MySQL.sql'), v3 => $ddl_dir->file ('DBICVersion-Schema-3.0-MySQL.sql'), trans_v12 => $ddl_dir->file ('DBICVersion-Schema-1.0-2.0-MySQL.sql'), trans_v23 => $ddl_dir->file ('DBICVersion-Schema-2.0-3.0-MySQL.sql'), }; my $schema_v1 = DBICVersion::Schema->connect($dsn, $user, $pass, { ignore_version => 1 }); eval { $schema_v1->storage->dbh->do('drop table ' . $version_table_name) }; eval { $schema_v1->storage->dbh->do('drop table ' . $old_table_name) }; is($schema_v1->ddl_filename('MySQL', '1.0', $ddl_dir), $fn->{v1}, 'Filename creation working'); unlink( $fn->{v1} ) if ( -e $fn->{v1} ); $schema_v1->create_ddl_dir('MySQL', undef, $ddl_dir); ok(-f $fn->{v1}, 'Created DDL file'); $schema_v1->deploy({ add_drop_table => 1 }); my $tvrs = $schema_v1->{vschema}->resultset('Table'); is($schema_v1->_source_exists($tvrs), 1, 'Created schema from DDL file'); # loading a new module defining a new version of the same table DBICVersion::Schema->_unregister_source ('Table'); use_ok('DBICVersion_v2'); my $schema_v2 = DBICVersion::Schema->connect($dsn, $user, $pass, { ignore_version => 1 }); { unlink($fn->{v2}); unlink($fn->{trans_v12}); is($schema_v2->get_db_version(), '1.0', 'get_db_version ok'); is($schema_v2->schema_version, '2.0', 'schema version ok'); $schema_v2->create_ddl_dir('MySQL', '2.0', $ddl_dir, '1.0'); ok(-f $fn->{trans_v12}, 'Created DDL file'); warnings_like ( sub { $schema_v2->upgrade() }, qr/DB version .+? is lower than the schema version/, 'Warn before upgrade', ); is($schema_v2->get_db_version(), '2.0', 'db version number upgraded'); lives_ok ( sub { $schema_v2->storage->dbh->do('select NewVersionName from TestVersion'); }, 'new column created' ); warnings_exist ( sub { $schema_v2->create_ddl_dir('MySQL', '2.0', $ddl_dir, '1.0') }, [ qr/Overwriting existing DDL file - \Q$fn->{v2}\E/, qr/Overwriting existing diff file - \Q$fn->{trans_v12}\E/, ], 'An overwrite warning generated for both the DDL and the diff', ); } { my $schema_version = DBICVersion::Schema->connect($dsn, $user, $pass); lives_ok (sub { $schema_version->storage->dbh->do('select * from ' . $version_table_name); }, 'version table exists'); lives_ok (sub { $schema_version->storage->dbh->do("DROP TABLE IF EXISTS $old_table_name"); $schema_version->storage->dbh->do("RENAME TABLE $version_table_name TO $old_table_name"); }, 'versions table renamed to old style table'); $schema_version = DBICVersion::Schema->connect($dsn, $user, $pass); is($schema_version->get_db_version, '2.0', 'transition from old table name to new okay'); dies_ok (sub { $schema_version->storage->dbh->do('select * from ' . $old_table_name); }, 'old version table gone'); } # repeat the v1->v2 process for v2->v3 before testing v1->v3 DBICVersion::Schema->_unregister_source ('Table'); use_ok('DBICVersion_v3'); my $schema_v3 = DBICVersion::Schema->connect($dsn, $user, $pass, { ignore_version => 1 }); { unlink($fn->{v3}); unlink($fn->{trans_v23}); is($schema_v3->get_db_version(), '2.0', 'get_db_version 2.0 ok'); is($schema_v3->schema_version, '3.0', 'schema version 3.0 ok'); $schema_v3->create_ddl_dir('MySQL', '3.0', $ddl_dir, '2.0'); ok(-f $fn->{trans_v23}, 'Created DDL 2.0 -> 3.0 file'); warnings_exist ( sub { $schema_v3->upgrade() }, qr/DB version .+? is lower than the schema version/, 'Warn before upgrade', ); is($schema_v3->get_db_version(), '3.0', 'db version number upgraded'); lives_ok ( sub { $schema_v3->storage->dbh->do('select ExtraColumn from TestVersion'); }, 'new column created'); } # now put the v1 schema back again { # drop all the tables... eval { $schema_v1->storage->dbh->do('drop table ' . $version_table_name) }; eval { $schema_v1->storage->dbh->do('drop table ' . $old_table_name) }; eval { $schema_v1->storage->dbh->do('drop table TestVersion') }; { local $DBICVersion::Schema::VERSION = '1.0'; $schema_v1->deploy; } is($schema_v1->get_db_version(), '1.0', 'get_db_version 1.0 ok'); } # attempt v1 -> v3 upgrade { local $SIG{__WARN__} = sigwarn_silencer( qr/Attempting upgrade\.$/ ); $schema_v3->upgrade(); is($schema_v3->get_db_version(), '3.0', 'db version number upgraded'); } # Now, try a v1 -> v3 upgrade with a file that has comments strategically placed in it. # First put the v1 schema back again... { # drop all the tables... eval { $schema_v1->storage->dbh->do('drop table ' . $version_table_name) }; eval { $schema_v1->storage->dbh->do('drop table ' . $old_table_name) }; eval { $schema_v1->storage->dbh->do('drop table TestVersion') }; { local $DBICVersion::Schema::VERSION = '1.0'; $schema_v1->deploy; } is($schema_v1->get_db_version(), '1.0', 'get_db_version 1.0 ok'); } # add a "harmless" comment before one of the statements. { my ($perl) = $^X =~ /(.+)/; local $ENV{PATH}; system( qq($perl -pi.bak -e "s/ALTER/-- this is a comment\nALTER/" $fn->{trans_v23}) ); } # Then attempt v1 -> v3 upgrade { local $SIG{__WARN__} = sigwarn_silencer( qr/Attempting upgrade\.$/ ); $schema_v3->upgrade(); is($schema_v3->get_db_version(), '3.0', 'db version number upgraded to 3.0'); # make sure that the column added after the comment is actually added. lives_ok ( sub { $schema_v3->storage->dbh->do('select ExtraColumn from TestVersion'); }, 'new column created'); } # check behaviour of DBIC_NO_VERSION_CHECK env var and ignore_version connect attr { my $schema_version = DBICVersion::Schema->connect($dsn, $user, $pass); eval { $schema_version->storage->dbh->do("DELETE from $version_table_name"); }; warnings_like ( sub { $schema_version = DBICVersion::Schema->connect($dsn, $user, $pass); }, qr/Your DB is currently unversioned/, 'warning detected without env var or attr' ); warnings_like ( sub { $schema_version = DBICVersion::Schema->connect($dsn, $user, $pass, { ignore_version => 1 }); }, [], 'warning not detected with attr set'); local $ENV{DBIC_NO_VERSION_CHECK} = 1; warnings_like ( sub { $schema_version = DBICVersion::Schema->connect($dsn, $user, $pass); }, [], 'warning not detected with env var set'); warnings_like ( sub { $schema_version = DBICVersion::Schema->connect($dsn, $user, $pass, { ignore_version => 0 }); }, qr/Your DB is currently unversioned/, 'warning detected without env var or attr'); } # attempt a deploy/upgrade cycle within one second { eval { $schema_v2->storage->dbh->do('drop table ' . $version_table_name) }; eval { $schema_v2->storage->dbh->do('drop table ' . $old_table_name) }; eval { $schema_v2->storage->dbh->do('drop table TestVersion') }; # this attempts to sleep until the turn of the second my $t = time(); sleep (int ($t) + 1 - $t); note ('Fast deploy/upgrade start: ', time() ); { local $DBICVersion::Schema::VERSION = '2.0'; $schema_v2->deploy; } local $SIG{__WARN__} = sigwarn_silencer( qr/Attempting upgrade\.$/ ); $schema_v2->upgrade(); is($schema_v2->get_db_version(), '3.0', 'Fast deploy/upgrade'); }; # Check that it Schema::Versioned deals with new/all forms of connect arguments. { my $get_db_version_run = 0; no warnings qw/once redefine/; local *DBIx::Class::Schema::Versioned::get_db_version = sub { $get_db_version_run = 1; return $_[0]->schema_version; }; # Make sure the env var isn't whats triggering it local $ENV{DBIC_NO_VERSION_CHECK} = 0; DBICVersion::Schema->connect({ dsn => $dsn, user => $user, pass => $pass, ignore_version => 1 }); ok($get_db_version_run == 0, "attributes pulled from hashref connect_info"); $get_db_version_run = 0; DBICVersion::Schema->connect( $dsn, $user, $pass, { ignore_version => 1 } ); ok($get_db_version_run == 0, "attributes pulled from list connect_info"); } # at this point we have v1, v2 and v3 still connected # make sure they are the only connections and everything else is gone is scalar( grep { defined $_ and $_->{Active} } map { @{$_->{ChildHandles}} } values %{ { DBI->installed_drivers } } ), 3, "Expected number of connections at end of script" ; # Test custom HandleError setting on an in-memory instance { my $custom_handler = sub { die $_[0] }; # try to setup a custom error handle without unsafe set -- should # fail, same behavior as regular Schema throws_ok { DBICVersion::Schema->connect( 'dbi:SQLite::memory:', undef, undef, { HandleError => $custom_handler, ignore_version => 1, })->deploy; } qr/Refusing clobbering of \{HandleError\} installed on externally supplied DBI handle/, 'HandleError with unsafe not set causes an exception' ; # now try it with unsafe set -- should work (see RT #113741) my $s = DBICVersion::Schema->connect( 'dbi:SQLite::memory:', undef, undef, { unsafe => 1, HandleError => $custom_handler, ignore_version => 1, }); $s->deploy; is $s->storage->dbh->{HandleError}, $custom_handler, 'Handler properly set on main schema'; is $s->{vschema}->storage->dbh->{HandleError}, $custom_handler, 'Handler properly set on version subschema'; } END { unless ($ENV{DBICTEST_KEEP_VERSIONING_DDL}) { $ddl_dir->rmtree; } } done_testing; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/82cascade_copy.t��������������������������������������������������������������0000644�0001750�0001750�00000002034�14240132261�016314� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); my $artist = $schema->resultset('Artist')->find(1); my $artist_cds = $artist->search_related('cds'); my $cover_band = $artist->copy ({name => $artist->name . '_cover' }); my $cover_cds = $cover_band->search_related('cds'); cmp_ok($cover_band->id, '!=', $artist->id, 'ok got new column id...'); is($cover_cds->count, $artist_cds->count, 'duplicated rows count ok'); #check multi-keyed is( $cover_band->search_related('twokeys')->count, $artist->search_related('twokeys')->count, 'duplicated multiPK ok' ); #and check copying a few relations away cmp_ok($cover_cds->search_related('tags')->count, '==', $artist_cds->search_related('tags')->count , 'duplicated count ok'); # check from the other side my $cd = $schema->resultset('CD')->find(1); my $dup_cd = $cd->copy ({ title => 'ha!' }); is( $dup_cd->search_related('twokeys')->count, $cd->search_related('twokeys')->count, 'duplicated multiPK ok' ); done_testing; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/53lean_startup.t��������������������������������������������������������������0000644�0001750�0001750�00000013575�14240133555�016421� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Use a require override instead of @INC munging (less common) # Do the override as early as possible so that CORE::require doesn't get compiled away my ($initial_inc_contents, $expected_dbic_deps, $require_sites); BEGIN { # these envvars *will* bring in more stuff than the baseline delete @ENV{qw( DBICTEST_SWAPOUT_SQLAC_WITH DBICTEST_SQLT_DEPLOY DBIC_TRACE )}; # make sure extras do not load even when this is set $ENV{PERL_STRICTURES_EXTRA} = 1; unshift @INC, 't/lib'; require DBICTest::Util::OverrideRequire; DBICTest::Util::OverrideRequire::override_global_require( sub { my $res = $_[0]->(); my $req = $_[1]; $req =~ s/\.pm$//; $req =~ s/\//::/g; my $up = 0; my @caller; do { @caller = caller($up++) } while ( @caller and ( # exclude our test suite, known "module require-rs" and eval frames $caller[1] =~ /^ t [\/\\] /x or $caller[0] =~ /^ (?: base | parent | Class::C3::Componentised | Module::Inspector | Module::Runtime ) $/x && $caller[3] !~ m/::BEGIN$/ or $caller[3] eq '(eval)', ) ); push @{$require_sites->{$req}}, "$caller[1] line $caller[2]" if @caller; return $res if $req =~ /^DBIx::Class|^DBICTest::/; # exclude everything where the current namespace does not match the called function # (this works around very weird XS-induced require callstack corruption) if ( !$initial_inc_contents->{$req} and !$expected_dbic_deps->{$req} and @caller and $caller[0] =~ /^DBIx::Class/ and (caller($up))[3] =~ /\Q$caller[0]/ ) { CORE::require('Test/More.pm'); Test::More::fail ("Unexpected require of '$req' by $caller[0] ($caller[1] line $caller[2])"); if ( $ENV{TEST_VERBOSE} or ! DBICTest::RunMode->is_plain ) { CORE::require('DBICTest/Util.pm'); Test::More::diag( 'Require invoked' . DBICTest::Util::stacktrace() ); } } return $res; }); } use strict; use warnings; use Test::More; BEGIN { plan skip_all => 'A defined PERL5OPT may inject extra deps crashing this test' if $ENV{PERL5OPT}; plan skip_all => 'Dependency load patterns are radically different before perl 5.10' if "$]" < 5.010; # these envvars *will* bring in more stuff than the baseline delete @ENV{qw( DBIC_TRACE DBIC_SHUFFLE_UNORDERED_RESULTSETS DBICTEST_SQLT_DEPLOY DBICTEST_SQLITE_REVERSE_DEFAULT_ORDER DBICTEST_VIA_REPLICATED DBICTEST_DEBUG_CONCURRENCY_LOCKS )}; $ENV{DBICTEST_ANFANG_DEFANG} = 1; # make sure extras do not load even when this is set $ENV{PERL_STRICTURES_EXTRA} = 1; # add what we loaded so far for (keys %INC) { my $mod = $_; $mod =~ s/\.pm$//; $mod =~ s!\/!::!g; $initial_inc_contents->{$mod} = 1; } } BEGIN { delete $ENV{$_} for qw( DBICTEST_DEBUG_CONCURRENCY_LOCKS ); } ####### ### This is where the test starts ####### # checking base schema load, no storage no connection { register_lazy_loadable_requires(qw( B constant overload base Devel::GlobalDestruction mro Carp namespace::clean Try::Tiny Sub::Name Sub::Defer Sub::Quote Hash::Merge Scalar::Util Storable Class::Accessor::Grouped Class::C3::Componentised SQL::Abstract::Util )); require DBICTest::Schema; assert_no_missing_expected_requires(); } # check schema/storage instantiation with no connect { register_lazy_loadable_requires(qw( Moo Moo::Object Method::Generate::Accessor Method::Generate::Constructor Context::Preserve )); my $s = DBICTest::Schema->connect('dbi:SQLite::memory:'); ok (! $s->storage->connected, 'no connection'); assert_no_missing_expected_requires(); } # do something (deploy, insert) { register_lazy_loadable_requires(qw( DBI SQL::Abstract::Classic )); my $s = DBICTest::Schema->connect('dbi:SQLite::memory:'); $s->storage->dbh_do(sub { $_[1]->do('CREATE TABLE artist ( "artistid" INTEGER PRIMARY KEY NOT NULL, "name" varchar(100), "rank" integer NOT NULL DEFAULT 13, "charfield" char(10) )'); }); my $art = $s->resultset('Artist')->create({ name => \[ '?' => 'foo'], rank => 42 }); $art->discard_changes; $art->update({ rank => 69, name => 'foo' }); $s->resultset('Artist')->all; assert_no_missing_expected_requires(); } # and do full populate() as well, just in case - shouldn't add new stuff { local $ENV{DBICTEST_SQLITE_REVERSE_DEFAULT_ORDER}; { # in general we do not want DBICTest to load before sqlac, but it is # ok to cheat here local $INC{'SQL/Abstract/Classic.pm'}; require DBICTest; } my $s = DBICTest->init_schema; is ($s->resultset('Artist')->find(1)->name, 'Caterwauler McCrae'); assert_no_missing_expected_requires(); } done_testing; sub register_lazy_loadable_requires { local $Test::Builder::Level = $Test::Builder::Level + 1; for my $mod (@_) { (my $modfn = "$mod.pm") =~ s!::!\/!g; fail(join "\n", "Module $mod already loaded by require site(s):", (map { "\t$_" } @{$require_sites->{$mod}}), '', ) if $INC{$modfn} and !$initial_inc_contents->{$mod}; $expected_dbic_deps->{$mod}++ } } # check if anything we were expecting didn't actually load sub assert_no_missing_expected_requires { my $nl; for my $mod (keys %$expected_dbic_deps) { (my $modfn = "$mod.pm") =~ s/::/\//g; unless ($INC{$modfn}) { my $err = sprintf "Expected DBIC core dependency '%s' never loaded - %s needs adjustment", $mod, __FILE__; if (DBICTest::RunMode->is_smoker or DBICTest::RunMode->is_author) { fail ($err) } else { diag "\n" unless $nl->{$mod}++; diag $err; } } } pass(sprintf 'All modules expected at %s line %s loaded by DBIC: %s', __FILE__, (caller(0))[2], join (', ', sort keys %$expected_dbic_deps ), ) unless $nl; } �����������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/39load_namespaces_3.t���������������������������������������������������������0000644�0001750�0001750�00000002052�14240132261�017241� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use Test::Warn; use lib qw(t/lib); use DBICTest; # do not remove even though it is not used lives_ok (sub { warnings_exist ( sub { package DBICNSTestOther; use base qw/DBIx::Class::Schema/; __PACKAGE__->load_namespaces( result_namespace => [ '+DBICNSTest::Rslt', '+DBICNSTest::OtherRslt' ], resultset_namespace => '+DBICNSTest::RSet', ); }, qr/load_namespaces found ResultSet class 'DBICNSTest::RSet::C' with no corresponding Result class/, ); }); my $source_a = DBICNSTestOther->source('A'); isa_ok($source_a, 'DBIx::Class::ResultSource::Table'); my $rset_a = DBICNSTestOther->resultset('A'); isa_ok($rset_a, 'DBICNSTest::RSet::A'); my $source_b = DBICNSTestOther->source('B'); isa_ok($source_b, 'DBIx::Class::ResultSource::Table'); my $rset_b = DBICNSTestOther->resultset('B'); isa_ok($rset_b, 'DBIx::Class::ResultSet'); my $source_d = DBICNSTestOther->source('D'); isa_ok($source_d, 'DBIx::Class::ResultSource::Table'); done_testing; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/103many_to_many_warning.t�����������������������������������������������������0000644�0001750�0001750�00000004320�14240132261�020170� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $exp_warn = qr/The many-to-many relationship 'bars' is trying to create/; { my @w; local $SIG{__WARN__} = sub { $_[0] =~ $exp_warn ? push @w, $_[0] : warn $_[0] }; my $code = gen_code ( suffix => 1 ); local $ENV{DBIC_OVERWRITE_HELPER_METHODS_OK}; eval "$code"; ok (! $@, 'Eval code without warnings suppression') || diag $@; ok (@w, "Warning triggered without DBIC_OVERWRITE_HELPER_METHODS_OK"); } { my @w; local $SIG{__WARN__} = sub { $_[0] =~ $exp_warn ? push @w, $_[0] : warn $_[0] }; my $code = gen_code ( suffix => 2 ); local $ENV{DBIC_OVERWRITE_HELPER_METHODS_OK} = 1; eval "$code"; ok (! $@, 'Eval code with warnings suppression') || diag $@; ok (! @w, "No warning triggered with DBIC_OVERWRITE_HELPER_METHODS_OK"); } sub gen_code { my $args = { @_ }; my $suffix = $args->{suffix}; return <<EOF; use strict; use warnings; { package # DBICTest::Schema::Foo${suffix}; use base 'DBIx::Class::Core'; __PACKAGE__->table('foo'); __PACKAGE__->add_columns( 'fooid' => { data_type => 'integer', is_auto_increment => 1, }, ); __PACKAGE__->set_primary_key('fooid'); __PACKAGE__->has_many('foo_to_bar' => 'DBICTest::Schema::FooToBar${suffix}' => 'bar'); __PACKAGE__->many_to_many( foos => foo_to_bar => 'bar' ); } { package # DBICTest::Schema::FooToBar${suffix}; use base 'DBIx::Class::Core'; __PACKAGE__->table('foo_to_bar'); __PACKAGE__->add_columns( 'foo' => { data_type => 'integer', }, 'bar' => { data_type => 'integer', }, ); __PACKAGE__->belongs_to('foo' => 'DBICTest::Schema::Foo${suffix}'); __PACKAGE__->belongs_to('bar' => 'DBICTest::Schema::Foo${suffix}'); } { package # DBICTest::Schema::Bar${suffix}; use base 'DBIx::Class::Core'; __PACKAGE__->table('bar'); __PACKAGE__->add_columns( 'barid' => { data_type => 'integer', is_auto_increment => 1, }, ); __PACKAGE__->set_primary_key('barid'); __PACKAGE__->has_many('foo_to_bar' => 'DBICTest::Schema::FooToBar${suffix}' => 'foo'); __PACKAGE__->many_to_many( bars => foo_to_bar => 'foo' ); sub add_to_bars {} } EOF } done_testing; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/61findnot.t�������������������������������������������������������������������0000644�0001750�0001750�00000007055�14240132261�015345� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Warn; use Test::Exception; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); my $art = $schema->resultset("Artist")->find(4); ok(!defined($art), 'Find on primary id: artist not found'); my @cd = $schema->resultset("CD")->find(6); cmp_ok(@cd, '==', 1, 'Return something even in array context'); ok(@cd && !defined($cd[0]), 'Array contains an undef as only element'); $art = $schema->resultset("Artist")->find({artistid => '4'}); ok(!defined($art), 'Find on unique constraint: artist not found'); @cd = $schema->resultset("CD")->find({artist => '2', title => 'Lada-Di Lada-Da'}); cmp_ok(@cd, '==', 1, 'Return something even in array context'); ok(@cd && !defined($cd[0]), 'Array contains an undef as only element'); $art = $schema->resultset("Artist")->search({name => 'The Jesus And Mary Chain'}); isa_ok($art, 'DBIx::Class::ResultSet', 'get a DBIx::Class::ResultSet object'); my $next = $art->next; ok(!defined($next), 'Nothing next in ResultSet'); my $cd = $schema->resultset("CD")->search({title => 'Rubbersoul'}); @cd = $cd->next; cmp_ok(@cd, '==', 1, 'Return something even in array context'); ok(@cd && !defined($cd[0]), 'Array contains an undef as only element'); $art = $schema->resultset("Artist")->single({name => 'Bikini Bottom Boys'}); ok(!defined($art), 'Find on primary id: artist not found'); @cd = $schema->resultset("CD")->single({title => 'The Singles 1962-2006'}); cmp_ok(@cd, '==', 1, 'Return something even in array context'); ok(@cd && !defined($cd[0]), 'Array contains an undef as only element'); $art = $schema->resultset("Artist")->search({name => 'Random Girl Band'}); isa_ok($art, 'DBIx::Class::ResultSet', 'get a DBIx::Class::ResultSet object'); $next = $art->single; ok(!defined($next), 'Nothing next in ResultSet'); $cd = $schema->resultset("CD")->search({title => 'Call of the West'}); @cd = $cd->single; cmp_ok(@cd, '==', 1, 'Return something even in array context'); ok(@cd && !defined($cd[0]), 'Array contains an undef as only element'); $cd = $schema->resultset("CD")->first; my $artist_rs = $schema->resultset("Artist")->search({ artistid => $cd->artist->artistid }); for my $key ('', 'primary') { my $art = $artist_rs->find({ name => 'some other name' }, { $key ? (key => $key) : () }); is($art->artistid, $cd->get_column('artist'), "Artist found through @{[ $key ? 'explicit' : 'implicit' ]} key locked in the resultset"); } # collapsing and non-collapsing are separate codepaths, thus the separate tests $artist_rs = $schema->resultset("Artist"); warnings_exist { $artist_rs->find({}) } qr/\QQuery returned more than one row. SQL that returns multiple rows is DEPRECATED for ->find and ->single/ => "Non-unique find generated a cursor inexhaustion warning"; throws_ok { $artist_rs->find({}, { key => 'primary' }) } qr/Unable to satisfy requested constraint 'primary'/; for (1, 0) { local $ENV{DBIC_NULLABLE_KEY_NOWARN}; warnings_like sub { $artist_rs->find({ artistid => undef }, { key => 'primary' }) }, $_ ? [ qr/undef values supplied for requested unique constraint.+almost certainly not what you wanted/, ] : [], 'One warning on NULL conditions for constraint' ; } $artist_rs = $schema->resultset("Artist")->search({}, { prefetch => 'cds' }); warnings_exist { $artist_rs->find({}) } qr/\QDBIx::Class::ResultSet::find(): Query returned more than one row/, "Non-unique find generated a cursor inexhaustion warning"; throws_ok { $artist_rs->find({}, { key => 'primary' }) } qr/Unable to satisfy requested constraint 'primary'/; done_testing; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/51threads.t�������������������������������������������������������������������0000644�0001750�0001750�00000010413�14240132261�015325� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use Config; BEGIN { unless ($Config{useithreads}) { print "1..0 # SKIP your perl does not support ithreads\n"; exit 0; } if ($INC{'Devel/Cover.pm'}) { print "1..0 # SKIP Devel::Cover does not work with threads yet\n"; exit 0; } } use threads; use strict; use warnings; use Test::More; use Test::Exception; plan skip_all => 'DBIC does not actively support threads before perl 5.8.5' if $] < '5.008005'; use DBIx::Class::Optional::Dependencies (); use lib qw(t/lib); use DBICTest; plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('rdbms_pg') unless DBIx::Class::Optional::Dependencies->req_ok_for ('rdbms_pg'); my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/}; plan skip_all => 'Set $ENV{DBICTEST_PG_DSN}, _USER and _PASS to run this test' . ' (note: creates and drops a table named artist!)' unless ($dsn && $user); # README: If you set the env var to a number greater than 10, # we will use that many children my $num_children = $ENV{DBICTEST_THREAD_STRESS} || 1; if($num_children !~ /^[0-9]+$/ || $num_children < 10) { $num_children = 10; } use_ok('DBICTest::Schema'); my $schema = DBICTest::Schema->connect($dsn, $user, $pass, { AutoCommit => 1, RaiseError => 1, PrintError => 0 }); my $parent_rs; lives_ok (sub { my $dbh = $schema->storage->dbh; { local $SIG{__WARN__} = sub {}; eval { $dbh->do("DROP TABLE cd") }; $dbh->do("CREATE TABLE cd (cdid serial PRIMARY KEY, artist INTEGER NOT NULL UNIQUE, title VARCHAR(100) NOT NULL UNIQUE, year VARCHAR(100) NOT NULL, genreid INTEGER, single_track INTEGER);"); } $schema->resultset('CD')->create({ title => 'vacation in antarctica', artist => 123, year => 1901 }); $schema->resultset('CD')->create({ title => 'vacation in antarctica part 2', artist => 456, year => 1901 }); $parent_rs = $schema->resultset('CD')->search({ year => 1901 }); is ($parent_rs->count, 2); }, 'populate successfull'); # basic tests { ok ($schema->storage->connected(), 'Parent is connected'); is ($parent_rs->next->id, 1, 'Cursor advanced'); my $ct_num = Test::More->builder->current_test; my $newthread = async { my $out = ''; #simulate a subtest to not confuse the parent TAP emission my $tb = Test::More->builder; $tb->reset; for (qw/output failure_output todo_output/) { close $tb->$_; open ($tb->$_, '>', \$out); } ok(!$schema->storage->connected, "storage->connected() false in child"); for (1,2) { throws_ok { $parent_rs->next } qr/\QMulti-thread access attempted while cursor in progress (position 1)/; } $parent_rs->reset; is($parent_rs->next->id, 1, 'Resetting cursor reprepares it within child environment'); done_testing; close $tb->$_ for (qw/output failure_output todo_output/); sleep(1); # tasty crashes without this $out; }; die "Thread creation failed: $! $@" if !defined $newthread; my $out = $newthread->join; $out =~ s/^/ /gm; print $out; # workaround for older Test::More confusing the plan under threads Test::More->builder->current_test($ct_num); is ($parent_rs->next->id, 2, 'Cursor still intact in parent'); is ($parent_rs->next, undef, 'Cursor exhausted'); } $parent_rs->reset; my @children; while(@children < $num_children) { my $newthread = async { my $tid = threads->tid; my $child_rs = $schema->resultset('CD')->search({ year => 1901 }); my $row = $parent_rs->next; if($row && $row->get_column('artist') =~ /^(?:123|456)$/) { $schema->resultset('CD')->create({ title => "test success $tid", artist => $tid, year => scalar(@children) }); } sleep(1); # tasty crashes without this }; die "Thread creation failed: $! $@" if !defined $newthread; push(@children, $newthread); } ok(1, "past spawning"); { $_->join for(@children); } ok(1, "past joining"); while(@children) { my $child = pop(@children); my $tid = $child->tid; my $rs = $schema->resultset('CD')->search({ title => "test success $tid", artist => $tid, year => scalar(@children) }); is($rs->next->get_column('artist'), $tid, "Child $tid successful"); } ok(1, "Made it to the end"); undef $parent_rs; $schema->storage->dbh->do("DROP TABLE cd"); done_testing; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/39load_namespaces_rt41083.t���������������������������������������������������0000644�0001750�0001750�00000003250�14240132261�020125� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use lib 't/lib'; use DBICTest; # do not remove even though it is not used use Test::More tests => 8; sub _chk_warning { defined $_[0]? $_[0] !~ qr/We found ResultSet class '([^']+)' for '([^']+)', but it seems that you had already set '([^']+)' to use '([^']+)' instead/ : 1 } sub _chk_extra_sources_warning { my $p = qr/already has a source, use register_extra_source for additional sources/; defined $_[0]? $_[0] !~ /$p/ : 1; } sub _verify_sources { my @monikers = @_; is_deeply ( [ sort DBICNSTest::RtBug41083->sources ], \@monikers, 'List of resultsource registrations', ); } { my $warnings; eval { local $SIG{__WARN__} = sub { $warnings .= shift }; package DBICNSTest::RtBug41083; use base 'DBIx::Class::Schema'; __PACKAGE__->load_namespaces( result_namespace => 'Result_A', resultset_namespace => 'ResultSet_A', default_resultset_class => 'ResultSet' ); }; ok(!$@) or diag $@; ok(_chk_warning($warnings), 'expected no resultset complaint'); ok(_chk_extra_sources_warning($warnings), 'expected no extra sources complaint') or diag($warnings); _verify_sources (qw/A A::Sub/); } { my $warnings; eval { local $SIG{__WARN__} = sub { $warnings .= shift }; package DBICNSTest::RtBug41083; use base 'DBIx::Class::Schema'; __PACKAGE__->load_namespaces( default_resultset_class => 'ResultSet' ); }; ok(!$@) or diag $@; ok(_chk_warning($warnings), 'expected no resultset complaint') or diag $warnings; ok(_chk_extra_sources_warning($warnings), 'expected no extra sources complaint') or diag($warnings); _verify_sources (qw/A A::Sub Foo Foo::Sub/); } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/91merge_joinpref_attr.t�������������������������������������������������������0000644�0001750�0001750�00000010430�14240132261�017723� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; use Test::More; my $schema = DBICTest->init_schema(); my $rs = $schema->resultset( 'CD' ); { my $a = 'artist'; my $b = 'cd'; my $expected = [ 'artist', 'cd' ]; my $result = $rs->_merge_joinpref_attr($a, $b); is_deeply( $result, $expected ); } { my $a = [ 'artist' ]; my $b = [ 'cd' ]; my $expected = [ 'artist', 'cd' ]; my $result = $rs->_merge_joinpref_attr($a, $b); is_deeply( $result, $expected ); } { my $a = [ 'artist', 'cd' ]; my $b = [ 'cd' ]; my $expected = [ 'artist', 'cd' ]; my $result = $rs->_merge_joinpref_attr($a, $b); is_deeply( $result, $expected ); } { my $a = [ 'artist', 'artist' ]; my $b = [ 'artist', 'cd' ]; my $expected = [ 'artist', 'artist', 'cd' ]; my $result = $rs->_merge_joinpref_attr($a, $b); is_deeply( $result, $expected ); } { my $a = [ 'artist', 'cd' ]; my $b = [ 'artist', 'artist' ]; my $expected = [ 'artist', 'cd', 'artist' ]; my $result = $rs->_merge_joinpref_attr($a, $b); is_deeply( $result, $expected ); } { my $a = [ 'twokeys' ]; my $b = [ 'cds', 'cds' ]; my $expected = [ 'twokeys', 'cds', 'cds' ]; my $result = $rs->_merge_joinpref_attr($a, $b); is_deeply( $result, $expected ); } { my $a = [ 'artist', 'cd', { 'artist' => 'manager' } ]; my $b = 'artist'; my $expected = [ 'artist', 'cd', { 'artist' => 'manager' } ]; my $result = $rs->_merge_joinpref_attr($a, $b); is_deeply( $result, $expected ); } { my $a = [ 'artist', 'cd', { 'artist' => 'manager' } ]; my $b = [ 'artist', 'cd' ]; my $expected = [ 'artist', 'cd', { 'artist' => 'manager' } ]; my $result = $rs->_merge_joinpref_attr($a, $b); is_deeply( $result, $expected ); } { my $a = [ 'artist', 'cd', { 'artist' => 'manager' } ]; my $b = { 'artist' => 'manager' }; my $expected = [ 'artist', 'cd', { 'artist' => [ 'manager' ] } ]; my $result = $rs->_merge_joinpref_attr($a, $b); is_deeply( $result, $expected ); } { my $a = [ 'artist', 'cd', { 'artist' => 'manager' } ]; my $b = { 'artist' => 'agent' }; my $expected = [ { 'artist' => 'agent' }, 'cd', { 'artist' => 'manager' } ]; my $result = $rs->_merge_joinpref_attr($a, $b); is_deeply( $result, $expected ); } { my $a = [ 'artist', 'cd', { 'artist' => 'manager' } ]; my $b = { 'artist' => { 'manager' => 'artist' } }; my $expected = [ 'artist', 'cd', { 'artist' => [ { 'manager' => 'artist' } ] } ]; my $result = $rs->_merge_joinpref_attr($a, $b); is_deeply( $result, $expected ); } { my $a = [ 'artist', 'cd', { 'artist' => 'manager' } ]; my $b = { 'artist' => { 'manager' => [ 'artist', 'label' ] } }; my $expected = [ 'artist', 'cd', { 'artist' => [ { 'manager' => [ 'artist', 'label' ] } ] } ]; my $result = $rs->_merge_joinpref_attr($a, $b); is_deeply( $result, $expected ); } { my $a = [ 'artist', 'cd', { 'artist' => 'manager' } ]; my $b = { 'artist' => { 'tour_manager' => [ 'venue', 'roadie' ] } }; my $expected = [ { 'artist' => { 'tour_manager' => [ 'venue', 'roadie' ] } }, 'cd', { 'artist' => 'manager' } ]; my $result = $rs->_merge_joinpref_attr($a, $b); is_deeply( $result, $expected ); } { my $a = [ 'artist', 'cd' ]; my $b = { 'artist' => { 'tour_manager' => [ 'venue', 'roadie' ] } }; my $expected = [ { 'artist' => { 'tour_manager' => [ 'venue', 'roadie' ] } }, 'cd' ]; my $result = $rs->_merge_joinpref_attr($a, $b); is_deeply( $result, $expected ); } { my $a = [ { 'artist' => 'manager' }, 'cd' ]; my $b = [ 'artist', { 'artist' => 'manager' } ]; my $expected = [ { 'artist' => 'manager' }, 'cd', { 'artist' => 'manager' } ]; my $result = $rs->_merge_joinpref_attr($a, $b); is_deeply( $result, $expected ); } { my $a = [ { 'artist' => { 'manager' => {} } }, 'cd' ]; my $b = [ 'artist', { 'artist' => { 'manager' => {} } } ]; my $expected = [ { 'artist' => { 'manager' => {} } }, 'cd', { 'artist' => { 'manager' => {} } } ]; my $result = $rs->_merge_joinpref_attr($a, $b); is_deeply( $result, $expected ); } { my $a = [ { 'artist' => { 'manager' => undef } }, 'cd' ]; my $b = [ 'artist', { 'artist' => { 'manager' => undef } } ]; my $expected = [ { 'artist' => { 'manager' => undef } }, 'cd', { 'artist' => { 'manager' => undef } } ]; my $result = $rs->_merge_joinpref_attr($a, $b); is_deeply( $result, $expected ); } done_testing; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/83cache.t���������������������������������������������������������������������0000644�0001750�0001750�00000010712�14240132261�014745� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); my $rs = $schema->resultset("Artist")->search( { artistid => 1 } ); my $artist = $rs->first; ok( !defined($rs->get_cache), 'cache is not populated without cache attribute' ); $rs = $schema->resultset('Artist')->search( undef, { cache => 1 } ); my $artists = [ $rs->all ]; is( scalar @{$rs->get_cache}, 3, 'all() populates cache for search with cache attribute' ); $rs->clear_cache; ok( !defined($rs->get_cache), 'clear_cache is functional' ); $rs->next; is( scalar @{$rs->get_cache}, 3, 'next() populates cache for search with cache attribute' ); pop( @$artists ); $rs->set_cache( $artists ); is( scalar @{$rs->get_cache}, 2, 'set_cache() is functional' ); my $cd = $schema->resultset('CD')->find(1); $rs->clear_cache; $schema->is_executed_querycount( sub { $rs = $schema->resultset('Artist')->search( undef, { cache => 1 } ); while( $artist = $rs->next ) {} $artist = $rs->first(); }, 1, 'revisiting a row does not issue a query when cache => 1' ); my @a = $schema->resultset("Artist")->search( { }, { join => [ qw/ cds /], prefetch => [qw/ cds /], } ); is(scalar @a, 3, 'artist with cds: count parent objects'); $rs = $schema->resultset("Artist")->search( { 'artistid' => 1 }, { join => [ qw/ cds /], prefetch => [qw/ cds /], } ); # prefetch SELECT count $schema->is_executed_querycount( sub { $artist = $rs->first; $rs->reset(); # make sure artist contains a related resultset for cds isa_ok( $artist->{related_resultsets}{cds}, 'DBIx::Class::ResultSet', 'artist has a related_resultset for cds' ); # check if $artist->cds->get_cache is populated is( scalar @{$artist->cds->get_cache}, 3, 'cache for artist->cds contains correct number of records'); # ensure that $artist->cds returns correct number of objects is( scalar ($artist->cds), 3, 'artist->cds returns correct number of objects' ); # ensure that $artist->cds->count returns correct value is( $artist->cds->count, 3, 'artist->cds->count returns correct value' ); # ensure that $artist->count_related('cds') returns correct value is( $artist->count_related('cds'), 3, 'artist->count_related returns correct value' ); }, 1, 'only one SQL statement executed'); # make sure related_resultset is deleted after object is updated $artist->set_column('name', 'New Name'); $artist->update(); is( scalar keys %{$artist->{related_resultsets}}, 0, 'related resultsets deleted after update' ); # todo: make sure caching works with nested prefetch e.g. $artist->cds->tracks $rs = $schema->resultset("Artist")->search( { artistid => 1 }, { join => { cds => 'tags' }, prefetch => { cds => 'tags' }, order_by => { -desc => 'cds.cdid' }, } ); { my $artist_count_before = $schema->resultset('Artist')->count; $schema->resultset("Artist")->create({artistid=>4,name=>qq{Humoungous Hamsters}}); is($schema->resultset('Artist')->count, $artist_count_before + 1, 'count() reflects new artist'); my $artist = $schema->resultset("Artist")->search( { artistid => 4 },{prefetch=>[qw/cds/]} )->first; is($artist->cds, 0, 'No cds for this artist'); } # SELECT count for nested has_many prefetch $schema->is_executed_querycount( sub { $artist = ($rs->all)[0]; }, 1, 'only one SQL statement executed'); $schema->is_executed_querycount( sub { my @objs; my $cds = $artist->cds; my $tags = $cds->next->tags; while( my $tag = $tags->next ) { push @objs, $tag->tagid; #warn "tag:", $tag->ID, " => ", $tag->tag; } is_deeply( \@objs, [ 3 ], 'first cd has correct tags' ); $tags = $cds->next->tags; @objs = (); while( my $tag = $tags->next ) { push @objs, $tag->id; #warn "tag: ", $tag->ID; } is_deeply( [ sort @objs] , [ 2, 5, 8 ], 'third cd has correct tags' ); $tags = $cds->next->tags; @objs = (); while( my $tag = $tags->next ) { push @objs, $tag->id; #warn "tag: ", $tag->ID; } is_deeply( \@objs, [ 1 ], 'second cd has correct tags' ); }, 0, 'no additional SQL statements while checking nested data' ); $schema->is_executed_querycount( sub { $artist = $schema->resultset('Artist')->find(1, { prefetch => [qw/cds/] }); }, 1, 'only one select statement on find with inline has_many prefetch' ); $schema->is_executed_querycount( sub { $rs = $schema->resultset('Artist')->search(undef, { prefetch => [qw/cds/] }); $artist = $rs->find(1); }, 1, 'only one select statement on find with has_many prefetch on resultset' ); done_testing; ������������������������������������������������������DBIx-Class-0.082843/t/85utf8.t����������������������������������������������������������������������0000644�0001750�0001750�00000014372�14240132261�014600� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Warn; use lib qw(t/lib); use DBICTest; { package A::Comp; use base 'DBIx::Class'; sub store_column { shift->next::method (@_) }; 1; } { package A::SubComp; use base 'A::Comp'; 1; } warnings_are ( sub { local $ENV{DBIC_UTF8COLUMNS_OK} = 1; package A::Test1; use base 'DBIx::Class::Core'; __PACKAGE__->load_components(qw(Core +A::Comp Ordered UTF8Columns)); __PACKAGE__->load_components(qw(Ordered +A::SubComp Row UTF8Columns Core)); sub store_column { shift->next::method (@_) }; 1; }, [], 'no spurious warnings issued', ); warnings_like ( sub { local $ENV{DBIC_UTF8COLUMNS_OK}; package A::Test1Loud; use base 'DBIx::Class::Core'; __PACKAGE__->load_components(qw(Core +A::Comp Ordered UTF8Columns)); __PACKAGE__->load_components(qw(Ordered +A::SubComp Row UTF8Columns Core)); sub store_column { shift->next::method (@_) }; 1; }, [qr/Use of DBIx::Class::UTF8Columns is strongly discouraged/], 'issued deprecation warning', ); my $test1_mro; my $idx = 0; for (@{mro::get_linear_isa ('A::Test1')} ) { $test1_mro->{$_} = $idx++; } cmp_ok ($test1_mro->{'A::SubComp'}, '<', $test1_mro->{'A::Comp'}, 'mro of Test1 correct (A::SubComp before A::Comp)' ); cmp_ok ($test1_mro->{'A::Comp'}, '<', $test1_mro->{'DBIx::Class::UTF8Columns'}, 'mro of Test1 correct (A::Comp before UTF8Col)' ); cmp_ok ($test1_mro->{'DBIx::Class::UTF8Columns'}, '<', $test1_mro->{'DBIx::Class::Core'}, 'mro of Test1 correct (UTF8Col before Core)' ); cmp_ok ($test1_mro->{'DBIx::Class::Core'}, '<', $test1_mro->{'DBIx::Class::Row'}, 'mro of Test1 correct (Core before Row)' ); warnings_like ( sub { package A::Test2; use base 'DBIx::Class::Core'; __PACKAGE__->load_components(qw(UTF8Columns +A::Comp)); sub store_column { shift->next::method (@_) }; 1; }, [qr/Incorrect loading order of DBIx::Class::UTF8Columns.+affect other components overriding 'store_column' \(A::Comp\)/], 'incorrect order warning issued (violator defines)', ); warnings_like ( sub { package A::Test3; use base 'DBIx::Class::Core'; __PACKAGE__->load_components(qw(UTF8Columns +A::SubComp)); sub store_column { shift->next::method (@_) }; 1; }, [qr/Incorrect loading order of DBIx::Class::UTF8Columns.+affect other components overriding 'store_column' \(A::SubComp \(via A::Comp\)\)/], 'incorrect order warning issued (violator inherits)', ); my $schema = DBICTest->init_schema(); DBICTest::Schema::CD->load_components('UTF8Columns'); DBICTest::Schema::CD->utf8_columns('title'); Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO; # as per http://search.cpan.org/dist/Test-Simple/lib/Test/More.pm#utf8 binmode (Test::More->builder->$_, ':utf8') for qw/output failure_output todo_output/; my $bytestream_title = my $utf8_title = "weird \x{466} stuff"; utf8::encode($bytestream_title); cmp_ok ($bytestream_title, 'ne', $utf8_title, 'unicode/raw differ (sanity check)'); my $cd; { local $TODO = "This has been broken since rev 1191, Mar 2006"; $schema->is_executed_sql_bind( sub { $cd = $schema->resultset('CD')->create( { artist => 1, title => $utf8_title, year => '2048' } ) }, [[ 'INSERT INTO cd ( artist, title, year) VALUES ( ?, ?, ? )', [ { dbic_colname => "artist", sqlt_datatype => "integer" } => 1 ], [ { dbic_colname => "title", sqlt_datatype => "varchar", sqlt_size => 100 } => $bytestream_title ], [ { dbic_colname => "year", sqlt_datatype => "varchar", sqlt_size => 100 } => 2048 ], ]], 'INSERT: raw bytes sent to the database' ); }; # this should be using the cursor directly, no inflation/processing of any sort my ($raw_db_title) = $schema->resultset('CD') ->search ($cd->ident_condition) ->get_column('title') ->_resultset ->cursor ->next; is ($raw_db_title, $bytestream_title, 'INSERT: raw bytes retrieved from database'); for my $reloaded (0, 1) { my $test = $reloaded ? 'reloaded' : 'stored'; $cd->discard_changes if $reloaded; ok( utf8::is_utf8( $cd->title ), "got $test title with utf8 flag" ); ok(! utf8::is_utf8( $cd->{_column_data}{title} ), "in-object $test title without utf8" ); ok(! utf8::is_utf8( $cd->year ), "got $test year without utf8 flag" ); ok(! utf8::is_utf8( $cd->{_column_data}{year} ), "in-object $test year without utf8" ); } $cd->title('nonunicode'); ok(! utf8::is_utf8( $cd->title ), 'update title without utf8 flag' ); ok(! utf8::is_utf8( $cd->{_column_data}{title} ), 'store utf8-less title' ); $cd->update; $cd->discard_changes; ok(! utf8::is_utf8( $cd->title ), 'reloaded title without utf8 flag' ); ok(! utf8::is_utf8( $cd->{_column_data}{title} ), 'reloaded utf8-less title' ); $bytestream_title = $utf8_title = "something \x{219} else"; utf8::encode($bytestream_title); $schema->is_executed_sql_bind( sub { $cd->update ({ title => $utf8_title }); }, [ [ 'BEGIN' ], [ 'UPDATE cd SET title = ? WHERE cdid = ?', [ { dbic_colname => "title", sqlt_datatype => "varchar", sqlt_size => 100 } => $bytestream_title ], [ { dbic_colname => "cdid", sqlt_datatype => "integer" } => 6 ], ], [ 'COMMIT' ], ], 'UPDATE: raw bytes sent to the database'); ($raw_db_title) = $schema->resultset('CD') ->search ($cd->ident_condition) ->get_column('title') ->_resultset ->cursor ->next; is ($raw_db_title, $bytestream_title, 'UPDATE: raw bytes retrieved from database'); $cd->discard_changes; $cd->title($utf8_title); ok( !$cd->is_column_changed('title'), 'column is not dirty after setting the same unicode value' ); $cd->update ({ title => $utf8_title }); $cd->title('something_else'); ok( $cd->is_column_changed('title'), 'column is dirty after setting to something completely different'); { local $TODO = 'There is currently no way to propagate aliases to inflate_result()'; $cd = $schema->resultset('CD')->find ({ title => $utf8_title }, { select => 'title', as => 'name' }); ok (utf8::is_utf8( $cd->get_column ('name') ), 'utf8 flag propagates via as'); } done_testing; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/749sqlanywhere.t��������������������������������������������������������������0000644�0001750�0001750�00000015574�14240132261�016350� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use Scope::Guard (); use Try::Tiny; use DBIx::Class::Optional::Dependencies (); use lib qw(t/lib); use DBICTest; my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_SQLANYWHERE_${_}" } qw/DSN USER PASS/}; my ($dsn2, $user2, $pass2) = @ENV{map { "DBICTEST_SQLANYWHERE_ODBC_${_}" } qw/DSN USER PASS/}; plan skip_all => 'Test needs ' . (join ' or ', map { $_ ? $_ : () } DBIx::Class::Optional::Dependencies->req_missing_for('test_rdbms_sqlanywhere'), DBIx::Class::Optional::Dependencies->req_missing_for('test_rdbms_sqlanywhere_odbc')) unless $dsn && DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_sqlanywhere') or $dsn2 && DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_sqlanywhere_odbc') or (not $dsn || $dsn2); DBICTest::Schema->load_classes('ArtistGUID'); # tests stolen from 748informix.t plan skip_all => <<'EOF' unless $dsn || $dsn2; Set $ENV{DBICTEST_SQLANYWHERE_DSN} and/or $ENV{DBICTEST_SQLANYWHERE_ODBC_DSN}, _USER and _PASS to run these tests EOF my @info = ( [ $dsn, $user, $pass ], [ $dsn2, $user2, $pass2 ], ); my $schema; foreach my $info (@info) { my ($dsn, $user, $pass) = @$info; next unless $dsn; $schema = DBICTest::Schema->connect($dsn, $user, $pass, { auto_savepoint => 1 }); my $guard = Scope::Guard->new(sub{ cleanup($schema) }); my $dbh = $schema->storage->dbh; eval { $dbh->do("DROP TABLE artist") }; $dbh->do(<<EOF); CREATE TABLE artist ( artistid INT IDENTITY PRIMARY KEY, name VARCHAR(255) NULL, charfield CHAR(10) NULL, rank INT DEFAULT 13 ) EOF my $ars = $schema->resultset('Artist'); is ( $ars->count, 0, 'No rows at first' ); # test primary key handling my $new = $ars->create({ name => 'foo' }); ok($new->artistid, "Auto-PK worked"); # test explicit key spec $new = $ars->create ({ name => 'bar', artistid => 66 }); is($new->artistid, 66, 'Explicit PK worked'); $new->discard_changes; is($new->artistid, 66, 'Explicit PK assigned'); # test savepoints throws_ok { $schema->txn_do(sub { eval { $schema->txn_do(sub { $ars->create({ name => 'in_savepoint' }); die "rolling back savepoint"; }); }; ok ((not $ars->search({ name => 'in_savepoint' })->first), 'savepoint rolled back'); $ars->create({ name => 'in_outer_txn' }); die "rolling back outer txn"; }); } qr/rolling back outer txn/, 'correct exception for rollback'; ok ((not $ars->search({ name => 'in_outer_txn' })->first), 'outer txn rolled back'); # test populate lives_ok (sub { my @pop; for (1..2) { push @pop, { name => "Artist_$_" }; } $ars->populate (\@pop); }); # test populate with explicit key lives_ok (sub { my @pop; for (1..2) { push @pop, { name => "Artist_expkey_$_", artistid => 100 + $_ }; } $ars->populate (\@pop); }); # count what we did so far is ($ars->count, 6, 'Simple count works'); # test LIMIT support my $lim = $ars->search( {}, { rows => 3, offset => 4, order_by => 'artistid' } ); is( $lim->count, 2, 'ROWS+OFFSET count ok' ); is( $lim->all, 2, 'Number of ->all objects matches count' ); # test iterator $lim->reset; is( $lim->next->artistid, 101, "iterator->next ok" ); is( $lim->next->artistid, 102, "iterator->next ok" ); is( $lim->next, undef, "next past end of resultset ok" ); # test empty insert { local $ars->result_source->column_info('artistid')->{is_auto_increment} = 0; lives_ok { $ars->create({}) } 'empty insert works'; } # test blobs (stolen from 73oracle.t) eval { $dbh->do('DROP TABLE bindtype_test') }; $dbh->do(qq[ CREATE TABLE bindtype_test ( id INT NOT NULL PRIMARY KEY, bytea INT NULL, blob LONG BINARY NULL, clob LONG VARCHAR NULL, a_memo INT NULL ) ],{ RaiseError => 1, PrintError => 1 }); my %binstr = ( 'small' => join('', map { chr($_) } ( 1 .. 127 )) ); $binstr{'large'} = $binstr{'small'} x 1024; my $maxloblen = length $binstr{'large'}; local $dbh->{'LongReadLen'} = $maxloblen; my $rs = $schema->resultset('BindType'); my $id = 0; foreach my $type (qw( blob clob )) { foreach my $size (qw( small large )) { $id++; # turn off horrendous binary DBIC_TRACE output local $schema->storage->{debug} = 0; lives_ok { $rs->create( { 'id' => $id, $type => $binstr{$size} } ) } "inserted $size $type without dying"; ok($rs->find($id)->$type eq $binstr{$size}, "verified inserted $size $type" ); } } my @uuid_types = qw/uniqueidentifier uniqueidentifierstr/; # test uniqueidentifiers (and the cursor_class). for my $uuid_type (@uuid_types) { local $schema->source('ArtistGUID')->column_info('artistid')->{data_type} = $uuid_type; local $schema->source('ArtistGUID')->column_info('a_guid')->{data_type} = $uuid_type; $schema->storage->dbh_do (sub { my ($storage, $dbh) = @_; eval { $dbh->do("DROP TABLE artist_guid") }; $dbh->do(<<"SQL"); CREATE TABLE artist_guid ( artistid $uuid_type NOT NULL, name VARCHAR(100), rank INT NOT NULL DEFAULT '13', charfield CHAR(10) NULL, a_guid $uuid_type, primary key(artistid) ) SQL }); local $TODO = 'something wrong with uniqueidentifierstr over ODBC' if $dsn =~ /:ODBC:/ && $uuid_type eq 'uniqueidentifierstr'; my $row; lives_ok { $row = $schema->resultset('ArtistGUID')->create({ name => 'mtfnpy' }) } 'created a row with a GUID'; ok( eval { $row->artistid }, 'row has GUID PK col populated', ); diag $@ if $@; ok( eval { $row->a_guid }, 'row has a GUID col with auto_nextval populated', ); diag $@ if $@; my $row_from_db = try { $schema->resultset('ArtistGUID') ->search({ name => 'mtfnpy' })->first } catch { diag $_ }; is try { $row_from_db->artistid }, $row->artistid, 'PK GUID round trip (via ->search->next)'; is try { $row_from_db->a_guid }, $row->a_guid, 'NON-PK GUID round trip (via ->search->next)'; $row_from_db = try { $schema->resultset('ArtistGUID') ->find($row->artistid) } catch { diag $_ }; is try { $row_from_db->artistid }, $row->artistid, 'PK GUID round trip (via ->find)'; is try { $row_from_db->a_guid }, $row->a_guid, 'NON-PK GUID round trip (via ->find)'; ($row_from_db) = try { $schema->resultset('ArtistGUID') ->search({ name => 'mtfnpy' })->all } catch { diag $_ }; is try { $row_from_db->artistid }, $row->artistid, 'PK GUID round trip (via ->search->all)'; is try { $row_from_db->a_guid }, $row->a_guid, 'NON-PK GUID round trip (via ->search->all)'; } } done_testing; sub cleanup { my $schema = shift; eval { $schema->storage->dbh->do("DROP TABLE $_") } for qw/artist artist_guid bindtype_test/; } ������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/86might_have.t����������������������������������������������������������������0000644�0001750�0001750�00000002410�14240132261�016014� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Warn; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); my $cd = $schema->resultset("CD")->find(1); $cd->title('test'); $schema->is_executed_querycount( sub { $cd->update; }, { BEGIN => 1, UPDATE => 1, COMMIT => 1, }, 'liner_notes (might_have) not prefetched - do not load liner_notes on update' ); my $cd2 = $schema->resultset("CD")->find(2, {prefetch => 'liner_notes'}); $cd2->title('test2'); $schema->is_executed_querycount( sub { $cd2->update; }, { BEGIN => 1, UPDATE => 1, COMMIT => 1, }, 'liner_notes (might_have) prefetched - do not load liner_notes on update'); warning_like { local $ENV{DBIC_DONT_VALIDATE_RELS}; DBICTest::Schema::Bookmark->might_have( linky => 'DBICTest::Schema::Link', { "foreign.id" => "self.link" }, ); } qr{"might_have/has_one" must not be on columns with is_nullable set to true}, 'might_have should warn if the self.id column is nullable'; { local $ENV{DBIC_DONT_VALIDATE_RELS} = 1; warning_is { DBICTest::Schema::Bookmark->might_have( slinky => 'DBICTest::Schema::Link', { "foreign.id" => "self.link" }, ); } undef, 'Setting DBIC_DONT_VALIDATE_RELS suppresses nullable relation warnings'; } done_testing(); ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/97result_class.t��������������������������������������������������������������0000644�0001750�0001750�00000006405�14240132261�016416� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Warn; use Test::Exception; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); { my $cd_rc = $schema->resultset("CD")->result_class; throws_ok { $schema->resultset("Artist") ->search_rs({}, {result_class => "IWillExplode"}) } qr/Can't locate IWillExplode/, 'nonexistant result_class exception'; # to make ensure_class_loaded happy, dies on inflate eval 'package IWillExplode; sub dummy {}'; my $artist_rs = $schema->resultset("Artist") ->search_rs({}, {result_class => "IWillExplode"}); is($artist_rs->result_class, 'IWillExplode', 'Correct artist result_class'); throws_ok { $artist_rs->result_class('mtfnpy') } qr/Can't locate mtfnpy/, 'nonexistant result_access exception (from accessor)'; throws_ok { $artist_rs->first } qr/\QInflator IWillExplode does not provide an inflate_result() method/, 'IWillExplode explodes on inflate'; my $cd_rs = $artist_rs->related_resultset('cds'); is($cd_rs->result_class, $cd_rc, 'Correct cd result_class'); my $cd_rs2 = $schema->resultset("Artist")->search_rs({})->related_resultset('cds'); is($cd_rs->result_class, $cd_rc, 'Correct cd2 result_class'); my $cd_rs3 = $schema->resultset("Artist")->search_rs({},{})->related_resultset('cds'); is($cd_rs->result_class, $cd_rc, 'Correct cd3 result_class'); isa_ok(eval{ $cd_rs->find(1) }, $cd_rc, 'Inflated into correct cd result_class'); } { my $cd_rc = $schema->resultset("CD")->result_class; my $artist_rs = $schema->resultset("Artist") ->search_rs({}, {result_class => "IWillExplode"})->search({artistid => 1}); is($artist_rs->result_class, 'IWillExplode', 'Correct artist result_class'); my $cd_rs = $artist_rs->related_resultset('cds'); is($cd_rs->result_class, $cd_rc, 'Correct cd result_class'); isa_ok(eval{ $cd_rs->find(1) }, $cd_rc, 'Inflated into correct cd result_class'); isa_ok(eval{ $cd_rs->search({ cdid => 1 })->first }, $cd_rc, 'Inflated into correct cd result_class'); } { my $rs = $schema->resultset('Artist')->search( { 'cds.title' => 'Spoonful of bees' }, { prefetch => 'cds', result_class => 'DBIx::Class::ResultClass::HashRefInflator' }, ); is ($rs->result_class, 'DBIx::Class::ResultClass::HashRefInflator', 'starting with correct resultclass'); $rs->result_class('DBICTest::Artist'); is ($rs->result_class, 'DBICTest::Artist', 'resultclass changed'); my $art = $rs->next; is (ref $art, 'DBICTest::Artist', 'Correcty blessed output'); throws_ok { $rs->result_class('IWillExplode') } qr/\QChanging the result_class of a ResultSet instance with an active cursor is not supported/, 'Throws on result class change in progress' ; my $cds = $art->cds; warnings_exist { $cds->result_class('IWillExplode') } qr/\QChanging the result_class of a ResultSet instance with cached results is a noop/, 'Warning on noop result_class change' ; is ($cds->result_class, 'IWillExplode', 'class changed anyway'); # even though the original was HRI (at $rs definition time above) # we lost the control over the *prefetched* object result class # when we handed the root object creation to ::Row::inflate_result is( ref $cds->next, 'DBICTest::CD', 'Correctly inflated prefetched result'); } done_testing; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/60core.t����������������������������������������������������������������������0000644�0001750�0001750�00000047523�14240140331�014634� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use Test::Warn; use Test::Deep; use lib qw(t/lib); use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); my @art = $schema->resultset("Artist")->search({ }, { order_by => 'name DESC'}); is(@art, 3, "Three artists returned"); my $art = $art[0]; is($art->name, 'We Are Goth', "Correct order too"); $art->name('We Are In Rehab'); is($art->name, 'We Are In Rehab', "Accessor update ok"); my %dirty = $art->get_dirty_columns(); is(scalar(keys(%dirty)), 1, '1 dirty column'); ok(grep($_ eq 'name', keys(%dirty)), 'name is dirty'); is($art->get_column("name"), 'We Are In Rehab', 'And via get_column'); ok($art->update, 'Update run'); my %not_dirty = $art->get_dirty_columns(); is(scalar(keys(%not_dirty)), 0, 'Nothing is dirty'); throws_ok ( sub { my $ret = $art->make_column_dirty('name2'); }, qr/No such column 'name2'/, 'Failed to make non-existent column dirty'); $art->make_column_dirty('name'); my %fake_dirty = $art->get_dirty_columns(); is(scalar(keys(%fake_dirty)), 1, '1 fake dirty column'); ok(grep($_ eq 'name', keys(%fake_dirty)), 'name is fake dirty'); ok($art->update, 'Update run'); my $record_jp = $schema->resultset("Artist")->search(undef, { join => 'cds' })->search(undef, { prefetch => 'cds' })->next; ok($record_jp, "prefetch on same rel okay"); my $record_fn = $schema->resultset("Artist")->search(undef, { join => 'cds' })->search({'cds.cdid' => '1'}, {join => 'artist_undirected_maps'})->next; ok($record_fn, "funny join is okay"); @art = $schema->resultset("Artist")->search({ name => 'We Are In Rehab' }); is(@art, 1, "Changed artist returned by search"); is($art[0]->artistid, 3,'Correct artist too'); lives_ok (sub { $art->delete }, 'Cascading delete on Ordered has_many works' ); # real test in ordered.t @art = $schema->resultset("Artist")->search({ }); is(@art, 2, 'And then there were two'); is($art->in_storage, 0, "It knows it's dead"); lives_ok { $art->update } 'No changes so update should be OK'; dies_ok ( sub { $art->delete }, "Can't delete twice"); is($art->name, 'We Are In Rehab', 'But the object is still live'); $art->insert; ok($art->in_storage, "Re-created"); @art = $schema->resultset("Artist")->search({ }); is(@art, 3, 'And now there are three again'); my $new = $schema->resultset("Artist")->create({ artistid => 4 }); is($new->artistid, 4, 'Create produced record ok'); @art = $schema->resultset("Artist")->search({ }); is(@art, 4, "Oh my god! There's four of them!"); $new->set_column('name' => 'Man With A Fork'); is($new->name, 'Man With A Fork', 'set_column ok'); $new->discard_changes; ok(!defined $new->name, 'Discard ok'); $new->name('Man With A Spoon'); $new->update; my $new_again = $schema->resultset("Artist")->find(4); is($new_again->name, 'Man With A Spoon', 'Retrieved correctly'); is($new_again->ID, 'DBICTest::Artist|artist|artistid=4', 'unique object id generated correctly'); # test that store_column is called once for create() for non sequence columns { ok(my $artist = $schema->resultset('Artist')->create({name => 'store_column test'})); is($artist->name, 'X store_column test'); # used to be 'X X store...' # call store_column even though the column doesn't seem to be dirty $artist->name($artist->name); is($artist->name, 'X X store_column test'); ok($artist->is_column_changed('name'), 'changed column marked as dirty'); $artist->delete; } # deprecation of rolled-out search warnings_exist { $schema->resultset('Artist')->search_rs(id => 4) } qr/\Qsearch( %condition ) is deprecated/, 'Deprecation warning on ->search( %condition )'; # this has been warning for 4 years, killing throws_ok { $schema->resultset('Artist')->find(artistid => 4); } qr|expects either a column/value hashref, or a list of values corresponding to the columns of the specified unique constraint|; is($schema->resultset("Artist")->count, 4, 'count ok'); # test find on an unresolvable condition is( $schema->resultset('Artist')->find({ artistid => [ -and => 1, 2 ]}), undef ); # test find_or_new { my $existing_obj = $schema->resultset('Artist')->find_or_new({ artistid => 4, }); is($existing_obj->name, 'Man With A Spoon', 'find_or_new: found existing artist'); ok($existing_obj->in_storage, 'existing artist is in storage'); my $new_obj = $schema->resultset('Artist')->find_or_new({ artistid => 5, name => 'find_or_new', }); is($new_obj->name, 'find_or_new', 'find_or_new: instantiated a new artist'); is($new_obj->in_storage, 0, 'new artist is not in storage'); } my $cd = $schema->resultset("CD")->find(1); my %cols = $cd->get_columns; is(keys %cols, 6, 'get_columns number of columns ok'); is($cols{title}, 'Spoonful of bees', 'get_columns values ok'); %cols = ( title => 'Forkful of bees', year => 2005); $cd->set_columns(\%cols); is($cd->title, 'Forkful of bees', 'set_columns ok'); is($cd->year, 2005, 'set_columns ok'); $cd->discard_changes; # check whether ResultSource->columns returns columns in order originally supplied my @cd = $schema->source("CD")->columns; is_deeply( \@cd, [qw/cdid artist title year genreid single_track/], 'column order'); $cd = $schema->resultset("CD")->search({ title => 'Spoonful of bees' }, { columns => ['title'] })->next; is($cd->title, 'Spoonful of bees', 'subset of columns returned correctly'); $cd = $schema->resultset("CD")->search(undef, { '+columns' => [ { name => 'artist.name' } ], join => [ 'artist' ] })->find(1); is($cd->title, 'Spoonful of bees', 'Correct CD returned with include'); is($cd->get_column('name'), 'Caterwauler McCrae', 'Additional column returned'); # check if new syntax +columns also works for this $cd = $schema->resultset("CD")->search(undef, { '+columns' => [ { name => 'artist.name' } ], join => [ 'artist' ] })->find(1); is($cd->title, 'Spoonful of bees', 'Correct CD returned with include'); is($cd->get_column('name'), 'Caterwauler McCrae', 'Additional column returned'); # check if new syntax for +columns select specifiers works for this $cd = $schema->resultset("CD")->search(undef, { '+columns' => [ {artist_name => 'artist.name'} ], join => [ 'artist' ] })->find(1); is($cd->title, 'Spoonful of bees', 'Correct CD returned with include'); is($cd->get_column('artist_name'), 'Caterwauler McCrae', 'Additional column returned'); # update_or_insert $new = $schema->resultset("Track")->new( { trackid => 100, cd => 1, title => 'Insert or Update', last_updated_on => '1973-07-19 12:01:02' } ); $new->update_or_insert; ok($new->in_storage, 'update_or_insert insert ok'); # test in update mode $new->title('Insert or Update - updated'); $new->update_or_insert; is( $schema->resultset("Track")->find(100)->title, 'Insert or Update - updated', 'update_or_insert update ok'); SKIP: { skip "Tests require " . DBIx::Class::Optional::Dependencies->req_missing_for ('test_dt_sqlite'), 13 unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt_sqlite'); # test get_inflated_columns with objects my $event = $schema->resultset('Event')->search->first; my %edata = $event->get_inflated_columns; is($edata{'id'}, $event->id, 'got id'); isa_ok($edata{'starts_at'}, 'DateTime', 'start_at is DateTime object'); isa_ok($edata{'created_on'}, 'DateTime', 'create_on DateTime object'); is($edata{'starts_at'}, $event->starts_at, 'got start date'); is($edata{'created_on'}, $event->created_on, 'got created date'); # get_inflated_columns w/relation and accessor alias isa_ok($new->updated_date, 'DateTime', 'have inflated object via accessor'); my %tdata = $new->get_inflated_columns; is($tdata{'trackid'}, 100, 'got id'); isa_ok($tdata{'cd'}, 'DBICTest::CD', 'cd is CD object'); is($tdata{'cd'}->id, 1, 'cd object is id 1'); is( $tdata{'position'}, $schema->resultset ('Track')->search ({cd => 1})->count, 'Ordered assigned proper position', ); is($tdata{'title'}, 'Insert or Update - updated'); is($tdata{'last_updated_on'}, '1973-07-19T12:01:02'); isa_ok($tdata{'last_updated_on'}, 'DateTime', 'inflated accessored column'); } throws_ok (sub { $schema->class("Track")->load_components('DoesNotExist'); }, qr!Can't locate DBIx/Class/DoesNotExist.pm!, 'exception on nonexisting component'); is($schema->class("Artist")->field_name_for->{name}, 'artist name', 'mk_classdata usage ok'); my $search = [ { 'tags.tag' => 'Cheesy' }, { 'tags.tag' => 'Blue' } ]; my $or_rs = $schema->resultset("CD")->search_rs($search, { join => 'tags', order_by => 'cdid' }); is($or_rs->all, 5, 'Joined search with OR returned correct number of rows'); is($or_rs->count, 5, 'Search count with OR ok'); my $collapsed_or_rs = $or_rs->search ({}, { distinct => 1 }); # induce collapse is ($collapsed_or_rs->all, 4, 'Collapsed joined search with OR returned correct number of rows'); is ($collapsed_or_rs->count, 4, 'Collapsed search count with OR ok'); # make sure sure distinct on a grouped rs is warned about { my $cd_rs = $schema->resultset ('CD') ->search ({}, { distinct => 1, group_by => 'title' }); warnings_exist (sub { $cd_rs->next; }, qr/Useless use of distinct/, 'UUoD warning'); } { my $tcount = $schema->resultset('Track')->search( {}, { select => [ qw/position title/ ], distinct => 1, } ); is($tcount->count, 13, 'multiple column COUNT DISTINCT ok'); $tcount = $schema->resultset('Track')->search( {}, { columns => [ qw/position title/ ], distinct => 1, } ); is($tcount->count, 13, 'multiple column COUNT DISTINCT ok'); $tcount = $schema->resultset('Track')->search( {}, { group_by => [ qw/position title/ ] } ); is($tcount->count, 13, 'multiple column COUNT DISTINCT using column syntax ok'); } my $tag_rs = $schema->resultset('Tag')->search( [ { 'me.tag' => 'Cheesy' }, { 'me.tag' => 'Blue' } ]); my $rel_rs = $tag_rs->search_related('cd', {}, { order_by => 'cd.cdid'} ); is($rel_rs->count, 5, 'Related search ok'); is($or_rs->next->cdid, $rel_rs->next->cdid, 'Related object ok'); $or_rs->reset; $rel_rs->reset; # at this point there should be no active statements # (finish() was called everywhere, either explicitly via # reset() or on DESTROY) for (keys %{$schema->storage->dbh->{CachedKids}}) { fail("Unreachable cached statement still active: $_") if $schema->storage->dbh->{CachedKids}{$_}->FETCH('Active'); } my $tag = $schema->resultset('Tag')->search( [ { 'me.tag' => 'Blue' } ], { columns => 'tagid' } )->next; ok($tag->has_column_loaded('tagid'), 'Has tagid loaded'); ok(!$tag->has_column_loaded('tag'), 'Has not tag loaded'); ok($schema->storage(), 'Storage available'); { my $rs = $schema->resultset("Artist")->search({ -and => [ artistid => { '>=', 1 }, artistid => { '<', 3 } ] }); $rs->update({ rank => 6134 }); my $art; $art = $schema->resultset("Artist")->find(1); is($art->rank, 6134, 'updated first artist rank'); $art = $schema->resultset("Artist")->find(2); is($art->rank, 6134, 'updated second artist rank'); } # test source_name { # source_name should be set for normal modules is($schema->source('CD')->source_name, 'CD', 'source_name is set to moniker'); # test the result source that sets source_name explictly ok($schema->source('SourceNameArtists'), 'SourceNameArtists result source exists'); my @artsn = $schema->resultset('SourceNameArtists')->search({}, { order_by => 'name DESC' }); is(@artsn, 4, "Four artists returned"); # make sure subclasses that don't set source_name are ok ok($schema->source('ArtistSubclass'), 'ArtistSubclass exists'); } my $newbook = $schema->resultset( 'Bookmark' )->find(1); lives_ok (sub { my $newlink = $newbook->link}, "stringify to false value doesn't cause error"); # test cascade_delete through many_to_many relations { my $art_del = $schema->resultset("Artist")->find({ artistid => 1 }); lives_ok (sub { $art_del->delete }, 'Cascading delete on Ordered has_many works' ); # real test in ordered.t is( $schema->resultset("CD")->search({artist => 1}), 0, 'Cascading through has_many top level.'); is( $schema->resultset("CD_to_Producer")->search({cd => 1}), 0, 'Cascading through has_many children.'); } # test column_info { $schema->source("Artist")->{_columns}{'artistid'} = {}; $schema->source("Artist")->column_info_from_storage(1); my $typeinfo = $schema->source("Artist")->column_info('artistid'); is($typeinfo->{data_type}, 'INTEGER', 'column_info ok'); $schema->source("Artist")->column_info('artistid'); ok($schema->source("Artist")->{_columns_info_loaded} == 1, 'Columns info loaded flag set'); } # test columns_info { $schema->source("Artist")->{_columns}{'artistid'} = {}; $schema->source("Artist")->column_info_from_storage(1); $schema->source("Artist")->{_columns_info_loaded} = 0; cmp_deeply ( $schema->source('Artist')->columns_info, { artistid => { data_type => "INTEGER", default_value => undef, is_nullable => 0, size => undef }, charfield => { data_type => "char", default_value => undef, is_nullable => 1, size => 10 }, name => { data_type => "varchar", default_value => undef, is_nullable => 1, is_numeric => 0, size => 100 }, rank => { data_type => re(qr/^integer$/i), default_value => 13, is_nullable => 0, size => undef }, }, 'columns_info works', ); ok($schema->source("Artist")->{_columns_info_loaded} == 1, 'Columns info loaded flag set'); cmp_deeply ( $schema->source('Artist')->columns_info([qw/artistid rank/]), { artistid => { data_type => "INTEGER", default_value => undef, is_nullable => 0, size => undef }, rank => { data_type => re(qr/^integer$/i), default_value => 13, is_nullable => 0, size => undef }, }, 'limited columns_info works', ); } # test source_info { my $expected = { "source_info_key_A" => "source_info_value_A", "source_info_key_B" => "source_info_value_B", "source_info_key_C" => "source_info_value_C", }; my $sinfo = $schema->source("Artist")->source_info; is_deeply($sinfo, $expected, 'source_info data works'); } # test remove_columns { is_deeply( [$schema->source('CD')->columns], [qw/cdid artist title year genreid single_track/], 'initial columns', ); $schema->source('CD')->remove_columns('coolyear'); #should not delete year is_deeply( [$schema->source('CD')->columns], [qw/cdid artist title year genreid single_track/], 'nothing removed when removing a non-existent column', ); $schema->source('CD')->remove_columns('genreid', 'year'); is_deeply( [$schema->source('CD')->columns], [qw/cdid artist title single_track/], 'removed two columns', ); my $priv_columns = $schema->source('CD')->_columns; ok(! exists $priv_columns->{'year'}, 'year purged from _columns'); ok(! exists $priv_columns->{'genreid'}, 'genreid purged from _columns'); } # test resultsource->table return value when setting { my $class = $schema->class('Event'); my $table = $class->table($class->table); is($table, $class->table, '->table($table) returns $table'); } #make sure insert doesn't use set_column { my $en_row = $schema->resultset('Encoded')->new_result({encoded => 'wilma'}); is($en_row->encoded, 'amliw', 'new encodes'); $en_row->insert; is($en_row->encoded, 'amliw', 'insert does not encode again'); } #make sure multicreate encoding still works { my $empl_rs = $schema->resultset('Employee'); my $empl = $empl_rs->create ({ name => 'Secret holder', secretkey => { encoded => 'CAN HAZ', }, }); is($empl->secretkey->encoded, 'ZAH NAC', 'correctly encoding on multicreate'); my $empl2 = $empl_rs->create ({ name => 'Same secret holder', secretkey => { encoded => 'CAN HAZ', }, }); is($empl2->secretkey->encoded, 'ZAH NAC', 'correctly encoding on preexisting multicreate'); $empl_rs->create ({ name => 'cat1', secretkey => { encoded => 'CHEEZBURGER', keyholders => [ { name => 'cat2', }, { name => 'cat3', }, ], }, }); is($empl_rs->find({name => 'cat1'})->secretkey->encoded, 'REGRUBZEEHC', 'correct secret in database for empl1'); is($empl_rs->find({name => 'cat2'})->secretkey->encoded, 'REGRUBZEEHC', 'correct secret in database for empl2'); is($empl_rs->find({name => 'cat3'})->secretkey->encoded, 'REGRUBZEEHC', 'correct secret in database for empl3'); } # make sure that obsolete handle-based source tracking continues to work for the time being { my $handle = $schema->source('Artist')->handle; my $rowdata = { $schema->resultset('Artist')->next->get_columns }; my $rs = DBIx::Class::ResultSet->new($handle); my $rs_result = $rs->next; isa_ok( $rs_result, 'DBICTest::Artist' ); is_deeply ( { $rs_result->get_columns }, $rowdata, 'Correct columns retrieved (rset/source link healthy)' ); my $row = DBICTest::Artist->new({ -source_handle => $handle }); is_deeply( { $row->get_columns }, {}, 'No columns yet' ); # store_column to fool the _orig_ident tracker $row->store_column('artistid', $rowdata->{artistid}); $row->in_storage(1); $row->discard_changes; is_deeply( { $row->get_columns }, $rowdata, 'Storage refetch successful' ); } # test to make sure that calling ->new() on a resultset object gives # us a row object { my $new_artist = $schema->resultset('Artist')->new({}); isa_ok( $new_artist, 'DBIx::Class::Row', '$rs->new gives a row object' ); } # make sure we got rid of the compat shims SKIP: { my $remove_version = 0.083; skip "Remove in $remove_version", 3 if $DBIx::Class::VERSION < $remove_version; for (qw/compare_relationship_keys pk_depends_on resolve_condition/) { ok (! DBIx::Class::ResultSource->can ($_), "$_ no longer provided by DBIx::Class::ResultSource, removed before $remove_version"); } } #------------------------------ # READ THIS BEFORE "FIXING" #------------------------------ # # make sure we got rid of discard_changes mess - this is a mess and a source # of great confusion. Here I simply die if the methods are available, which # is wrong on its own (we *have* to provide some sort of back-compat, even # if with warnings). Here is how I envision things should actually be. Also # note that a lot of the deprecation can be started today (i.e. the switch # from get_from_storage to copy_from_storage). So: # # $row->discard_changes => # warning, and delegation to reload_from_storage # # $row->reload_from_storage => # does what discard changes did in 0.08 - issues a query to the db # and repopulates all column slots, regardless of dirty states etc. # # $row->revert_changes => # does what discard_changes should have done initially (before it became # a dual-purpose call). In order to make this work we will have to # augment $row to carry its own initial-state, much like svn has a # copy of the current checkout in contrast to cvs. # # my $db_row = $row->get_from_storage => # warns and delegates to an improved name copy_from_storage, with the # same semantics # # my $db_row = $row->copy_from_storage => # a much better/descriptive name than get_from_storage # #------------------------------ # READ THIS BEFORE "FIXING" #------------------------------ # SKIP: { skip "Something needs to be done before 0.09", 2 if $DBIx::Class::VERSION < 0.09; my $row = $schema->resultset ('Artist')->next; for (qw/discard_changes get_from_storage/) { ok (! $row->can ($_), "$_ needs *some* sort of facelift before 0.09 ships - current state of affairs is unacceptable"); } } throws_ok { $schema->resultset} qr/resultset\(\) expects a source name/, 'resultset with no argument throws exception'; throws_ok { $schema->source('Artist')->result_class->new( 'bugger' ) } qr/must be a hashref/; done_testing; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/admin/������������������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�014452� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/admin/10script.t��������������������������������������������������������������0000644�0001750�0001750�00000007070�14240132261�016267� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# vim: filetype=perl use strict; use warnings; BEGIN { # just in case the user env has stuff in it delete $ENV{JSON_ANY_ORDER}; delete $ENV{DBICTEST_VERSION_WARNS_INDISCRIMINATELY}; } use Test::More; use Config; use File::Spec; use lib qw(t/lib); use DBICTest; BEGIN { require DBIx::Class; plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for('test_admin_script') unless DBIx::Class::Optional::Dependencies->req_ok_for('test_admin_script'); # just in case the user env has stuff in it delete $ENV{JSON_ANY_ORDER}; } $ENV{PATH} = ''; $ENV{PERL5LIB} = join ($Config{path_sep}, @INC); require JSON::Any; my @json_backends = qw(DWIW PP JSON CPANEL XS); # test the script is setting @INC properly test_exec (qw|-It/lib/testinclude --schema=DBICTestAdminInc --connect=[] --insert|); cmp_ok ( $? >> 8, '==', 70, 'Correct exit code from connecting a custom INC schema' ); # test that config works properly { no warnings 'qw'; test_exec(qw|-It/lib/testinclude --schema=DBICTestConfig --create --connect=["klaatu","barada","nikto"]|); cmp_ok( $? >> 8, '==', 71, 'Correct schema loaded via config' ) || exit; } # test that config-file works properly test_exec(qw|-It/lib/testinclude --schema=DBICTestConfig --config=t/lib/admincfgtest.json --config-stanza=Model::Gort --deploy|); cmp_ok ($? >> 8, '==', 71, 'Correct schema loaded via testconfig'); for my $js (@json_backends) { SKIP: { eval {JSON::Any->import ($js); 1 } or skip ("JSON backend $js is not available, skip testing", 1); local $ENV{JSON_ANY_ORDER} = $js; eval { test_dbicadmin () }; diag $@ if $@; } } done_testing(); sub test_dbicadmin { my $schema = DBICTest->init_schema( sqlite_use_file => 1 ); # reinit a fresh db for every run my $employees = $schema->resultset('Employee'); test_exec( default_args(), qw|--op=insert --set={"name":"Matt"}| ); ok( ($employees->count()==1), "$ENV{JSON_ANY_ORDER}: insert count" ); my $employee = $employees->find(1); ok( ($employee->name() eq 'Matt'), "$ENV{JSON_ANY_ORDER}: insert valid" ); test_exec( default_args(), qw|--op=update --set={"name":"Trout"}| ); $employee = $employees->find(1); ok( ($employee->name() eq 'Trout'), "$ENV{JSON_ANY_ORDER}: update" ); test_exec( default_args(), qw|--op=insert --set={"name":"Aran"}| ); SKIP: { skip ("MSWin32 doesn't support -|", 1) if $^O eq 'MSWin32'; my ($perl) = $^X =~ /(.*)/; open(my $fh, "-|", ( $perl, '-MDBICTest::RunMode', 'script/dbicadmin', default_args(), qw|--op=select --attrs={"order_by":"name"}| ) ) or die $!; my $data = do { local $/; <$fh> }; close($fh); if (!ok( ($data=~/Aran.*Trout/s), "$ENV{JSON_ANY_ORDER}: select with attrs" )) { diag ("data from select is $data") }; } test_exec( default_args(), qw|--op=delete --where={"name":"Trout"}| ); ok( ($employees->count()==1), "$ENV{JSON_ANY_ORDER}: delete" ); } sub default_args { my $dsn = JSON::Any->encode([ 'dbi:SQLite:dbname=' . DBICTest->_sqlite_dbfilename, '', '', { AutoCommit => 1 }, ]); return ( qw|--quiet --schema=DBICTest::Schema --class=Employee|, qq|--connect=$dsn|, qw|--force -I testincludenoniterference|, ); } sub test_exec { my ($perl) = $^X =~ /(.*)/; my @args = ($perl, '-MDBICTest::RunMode', File::Spec->catfile(qw(script dbicadmin)), @_); if ($^O eq 'MSWin32') { require Win32::ShellQuote; # included in test optdeps @args = Win32::ShellQuote::quote_system_list(@args); } system @args; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/admin/01load.t����������������������������������������������������������������0000644�0001750�0001750�00000000507�14240132261�015700� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib 't/lib'; use DBICTest; BEGIN { require DBIx::Class; plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for('admin') unless DBIx::Class::Optional::Dependencies->req_ok_for('admin'); } use_ok 'DBIx::Class::Admin'; done_testing; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/admin/02ddl.t�����������������������������������������������������������������0000644�0001750�0001750�00000007022�14240132261�015524� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use Test::Warn; use Path::Class; use lib qw(t/lib); use DBICTest; use DBIx::Class::_Util 'sigwarn_silencer'; BEGIN { require DBIx::Class; plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for('admin') unless DBIx::Class::Optional::Dependencies->req_ok_for('admin'); plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for('deploy') unless DBIx::Class::Optional::Dependencies->req_ok_for('deploy'); } use_ok 'DBIx::Class::Admin'; # lock early DBICTest->init_schema(no_deploy => 1, no_populate => 1); my $db_fn = DBICTest->_sqlite_dbfilename; my @connect_info = ( "dbi:SQLite:$db_fn", undef, undef, { on_connect_do => 'PRAGMA synchronous = OFF' }, ); my $ddl_dir = dir(qw/t var/, "admin_ddl-$$"); { # create the schema # make sure we are clean clean_dir($ddl_dir); my $admin = DBIx::Class::Admin->new( schema_class=> "DBICTest::Schema", sql_dir=> $ddl_dir, connect_info => \@connect_info, ); isa_ok ($admin, 'DBIx::Class::Admin', 'create the admin object'); lives_ok { $admin->create('MySQL'); } 'Can create MySQL sql'; lives_ok { $admin->create('SQLite'); } 'Can Create SQLite sql'; lives_ok { local $SIG{__WARN__} = sigwarn_silencer( qr/no such table.+DROP TABLE/s ); $admin->deploy() } 'Can Deploy schema'; } { # upgrade schema clean_dir($ddl_dir); require DBICVersion_v1; my $admin = DBIx::Class::Admin->new( schema_class => 'DBICVersion::Schema', sql_dir => $ddl_dir, connect_info => \@connect_info, ); my $schema = $admin->schema(); lives_ok { $admin->create($schema->storage->sqlt_type(), {add_drop_table=>0}); } 'Can create DBICVersionOrig sql in ' . $schema->storage->sqlt_type; lives_ok { $admin->deploy( ) } 'Can Deploy schema'; # connect to now deployed schema lives_ok { $schema = DBICVersion::Schema->connect(@{$schema->storage->connect_info()}); } 'Connect to deployed Database'; is($schema->get_db_version, $DBICVersion::Schema::VERSION, 'Schema deployed and versions match'); require DBICVersion_v2; DBICVersion::Schema->upgrade_directory (undef); # so that we can test use of $ddl_dir $admin = DBIx::Class::Admin->new( schema_class => 'DBICVersion::Schema', sql_dir => $ddl_dir, connect_info => \@connect_info ); lives_ok { $admin->create($schema->storage->sqlt_type(), {}, "1.0" ); } 'Can create diff for ' . $schema->storage->sqlt_type; { local $SIG{__WARN__} = sigwarn_silencer( qr/DB version .+? is lower than the schema version/ ); lives_ok { $admin->upgrade() } 'upgrade the schema'; dies_ok { $admin->deploy } 'cannot deploy installed schema, should upgrade instead'; } is($schema->get_db_version, $DBICVersion::Schema::VERSION, 'Schema and db versions match'); } { # install clean_dir($ddl_dir); my $admin = DBIx::Class::Admin->new( schema_class => 'DBICVersion::Schema', sql_dir => $ddl_dir, _confirm => 1, connect_info => \@connect_info, ); $admin->version("3.0"); $admin->install; is($admin->schema->get_db_version, "3.0", 'db thinks its version 3.0'); throws_ok { $admin->install("4.0") } qr/Schema already has a version. Try upgrade instead/, 'cannot install to allready existing version'; $admin->force(1); warnings_exist ( sub { $admin->install("4.0") }, qr/Forcing install may not be a good idea/, 'Force warning emitted' ); is($admin->schema->get_db_version, "4.0", 'db thinks its version 4.0'); } sub clean_dir { my ($dir) = @_; $dir->rmtree if -d $dir; unlink $db_fn; } END { clean_dir($ddl_dir); } done_testing; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/admin/03data.t����������������������������������������������������������������0000644�0001750�0001750�00000003330�14240132261�015671� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use lib 't/lib'; use DBICTest; BEGIN { require DBIx::Class; plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for('admin') unless DBIx::Class::Optional::Dependencies->req_ok_for('admin'); } use_ok 'DBIx::Class::Admin'; { # test data maniplulation functions # create a DBICTest so we can steal its connect info my $schema = DBICTest->init_schema( sqlite_use_file => 1, ); my $admin = DBIx::Class::Admin->new( schema_class=> "DBICTest::Schema", connect_info => $schema->storage->connect_info(), quiet => 1, _confirm=>1, ); isa_ok ($admin, 'DBIx::Class::Admin', 'create the admin object'); $admin->insert('Employee', { name => 'Matt' }); my $employees = $schema->resultset('Employee'); is ($employees->count(), 1, "insert okay" ); my $employee = $employees->find(1); is($employee->name(), 'Matt', "insert valid" ); $admin->update('Employee', {name => 'Trout'}, {name => 'Matt'}); $employee = $employees->find(1); is($employee->name(), 'Trout', "update Matt to Trout" ); $admin->insert('Employee', {name =>'Aran'}); my $expected_data = [ [$employee->result_source->columns() ], [1,1,undef,undef,undef,'Trout',undef], [2,2,undef,undef,undef,'Aran',undef] ]; my $data; lives_ok { $data = $admin->select('Employee', undef, { order_by => 'employee_id' })} 'can retrive data from database'; is_deeply($data, $expected_data, 'DB matches whats expected'); $admin->delete('Employee', {name=>'Trout'}); my $del_rs = $employees->search({name => 'Trout'}); is($del_rs->count(), 0, "delete Trout" ); is ($employees->count(), 1, "left Aran" ); } done_testing; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/resultset_overload.t����������������������������������������������������������0000644�0001750�0001750�00000001031�14240132261�017446� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); { my $rs = $schema->resultset("CD")->search({}); ok $rs->count; is $rs, $rs->count, "resultset as number with results"; ok $rs, "resultset as boolean always true"; } { my $rs = $schema->resultset("CD")->search({ title => "Does not exist" }); ok !$rs->count; is $rs, $rs->count, "resultset as number without results"; ok $rs, "resultset as boolean always true"; } done_testing; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/72pg_bytea.t������������������������������������������������������������������0000644�0001750�0001750�00000007672�14240132261�015505� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use DBIx::Class::Optional::Dependencies (); use Try::Tiny; use lib qw(t/lib); use DBICTest; plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('rdbms_pg') unless DBIx::Class::Optional::Dependencies->req_ok_for ('rdbms_pg'); my ($dsn, $dbuser, $dbpass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/}; plan skip_all => 'Set $ENV{DBICTEST_PG_DSN}, _USER and _PASS to run this test' unless ($dsn && $dbuser); my $schema = DBICTest::Schema->connect($dsn, $dbuser, $dbpass, { AutoCommit => 1 }); if ($schema->storage->_server_info->{normalized_dbms_version} >= 9.0) { if (not try { DBD::Pg->VERSION('2.17.2') }) { plan skip_all => 'DBD::Pg < 2.17.2 does not work with Pg >= 9.0 BYTEA columns'; } } elsif (not try { DBD::Pg->VERSION('2.9.2') }) { plan skip_all => 'DBD::Pg < 2.9.2 does not work with BYTEA columns'; } my $dbh = $schema->storage->dbh; { local $SIG{__WARN__} = sub {}; $dbh->do('DROP TABLE IF EXISTS bindtype_test'); # the blob/clob are for reference only, will be useful when we switch to SQLT and can test Oracle along the way $dbh->do(qq[ CREATE TABLE bindtype_test ( id serial NOT NULL PRIMARY KEY, bytea bytea NULL, blob bytea NULL, clob text NULL, a_memo text NULL ); ],{ RaiseError => 1, PrintError => 1 }); } $schema->storage->debug(0); # these tests spew up way too much stuff, disable trace my $big_long_string = "\x00\x01\x02 abcd" x 125000; my $new; # test inserting a row { $new = $schema->resultset('BindType')->create({ bytea => $big_long_string }); ok($new->id, "Created a bytea row"); ok($new->bytea eq $big_long_string, "Set the blob correctly."); } # test retrieval of the bytea column { my $row = $schema->resultset('BindType')->find({ id => $new->id }); ok($row->get_column('bytea') eq $big_long_string, "Created the blob correctly."); } { my $rs = $schema->resultset('BindType')->search({ bytea => $big_long_string }); # search on the bytea column (select) { my $row = $rs->first; is($row ? $row->id : undef, $new->id, "Found the row searching on the bytea column."); } # search on the bytea column (update) { my $new_big_long_string = $big_long_string . "2"; $schema->txn_do(sub { $rs->update({ bytea => $new_big_long_string }); my $row = $schema->resultset('BindType')->find({ id => $new->id }); ok( ($row ? $row->get_column('bytea') : '') eq $new_big_long_string, "Updated the row correctly (searching on the bytea column)." ); $schema->txn_rollback; }); } # search on the bytea column (delete) { $schema->txn_do(sub { $rs->delete; my $row = $schema->resultset('BindType')->find({ id => $new->id }); is($row, undef, "Deleted the row correctly (searching on the bytea column)."); $schema->txn_rollback; }); } # create with blob from $rs $new = $rs->create({}); ok($new->bytea eq $big_long_string, 'Object has bytea value from $rs'); $new->discard_changes; ok($new->bytea eq $big_long_string, 'bytea value made it to db'); } # test inserting a row via populate() (bindtype propagation through execute_for_fetch) # use a new $dbh to ensure no leakage due to prepare_cached { my $cnt = 4; $schema->storage->_dbh(undef); my $rs = $schema->resultset('BindType'); $rs->delete; $rs->populate([ [qw/id bytea/], map { [ \[ '?', [ {} => $_ ] ], "pop_${_}_" . $big_long_string, ]} (1 .. $cnt) ]); is($rs->count, $cnt, 'All rows were correctly inserted'); for (1..$cnt) { my $r = $rs->find({ bytea => "pop_${_}_" . $big_long_string }); is ($r->id, $_, "Row $_ found after find() on the blob"); } } done_testing; eval { $schema->storage->dbh_do(sub { $_[1]->do("DROP TABLE bindtype_test") } ) }; ����������������������������������������������������������������������DBIx-Class-0.082843/t/update/�����������������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�014644� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/update/all.t������������������������������������������������������������������0000644�0001750�0001750�00000001011�14240132261�015551� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); my $new_artist = $schema->resultset('Artist')->create({ name => 'new kid behind the block' }); # see how many cds do we have, and relink them all to the new guy my $cds = $schema->resultset('CD'); my $cds_count = $cds->count; cmp_ok($cds_count, '>', 0, 'have some cds'); $cds->update_all({ artist => $new_artist }); is( $new_artist->cds->count, $cds_count, 'All cds properly relinked'); done_testing; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/update/type_aware.t�����������������������������������������������������������0000644�0001750�0001750�00000001313�14240132261�017146� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); plan tests => 4; my $artist = $schema->resultset ('Artist')->first; ok (!$artist->get_dirty_columns, 'Artist is clean' ); $artist->rank (13); ok (!$artist->get_dirty_columns, 'Artist is clean after num value update' ); $artist->discard_changes; $artist->rank ('13.00'); ok (!$artist->get_dirty_columns, 'Artist is clean after string value update' ); $artist->discard_changes; # override column info $artist->result_source->column_info ('rank')->{is_numeric} = 0; $artist->rank ('13.00'); ok ($artist->get_dirty_columns, 'Artist is updated after is_numeric override' ); $artist->discard_changes; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/update/ident_cond.t�����������������������������������������������������������0000644�0001750�0001750�00000001466�14240132261�017125� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); my $artist = $schema->resultset('Artist')->find(1); is_deeply( [ $artist->id, $artist->ident_condition, $artist->_storage_ident_condition ], [ 1, { artistid => 1 }, { artistid => 1 } ], 'Correct identity state of freshly retrieved object', ); $artist->artistid(888); is_deeply( [ $artist->id, $artist->ident_condition, $artist->_storage_ident_condition ], [ 888, { artistid => 888 }, { artistid => 1 } ], 'Correct identity state of object with modified PK', ); $artist->update; is_deeply( [ $artist->id, $artist->ident_condition, $artist->_storage_ident_condition ], [ 888, { artistid => 888 }, { artistid => 888 } ], 'Correct identity state after storage update', ); done_testing; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/73oracle_hq.t�����������������������������������������������������������������0000644�0001750�0001750�00000025515�14240132261�015645� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::Exception; use Test::More; # I *strongly* suspect Oracle has an implicit stable output order when # dealing with HQs. So just punt on the entire shuffle thing. BEGIN { $ENV{DBIC_SHUFFLE_UNORDERED_RESULTSETS} = 0 } use DBIx::Class::Optional::Dependencies (); use lib qw(t/lib); $ENV{NLS_SORT} = "BINARY"; $ENV{NLS_COMP} = "BINARY"; $ENV{NLS_LANG} = "AMERICAN"; my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_ORA_${_}" } qw/DSN USER PASS/}; plan skip_all => 'Set $ENV{DBICTEST_ORA_DSN}, _USER and _PASS to run this test.' unless ($dsn && $user && $pass); plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('rdbms_oracle') unless DBIx::Class::Optional::Dependencies->req_ok_for ('rdbms_oracle'); use DBICTest::Schema::Artist; BEGIN { DBICTest::Schema::Artist->add_column('parentid'); DBICTest::Schema::Artist->has_many( children => 'DBICTest::Schema::Artist', { 'foreign.parentid' => 'self.artistid' } ); DBICTest::Schema::Artist->belongs_to( parent => 'DBICTest::Schema::Artist', { 'foreign.artistid' => 'self.parentid' } ); } use DBICTest; use DBICTest::Schema; my $schema = DBICTest::Schema->connect($dsn, $user, $pass); note "Oracle Version: " . $schema->storage->_server_info->{dbms_version}; my $dbh = $schema->storage->dbh; do_creates($dbh); ### test hierarchical queries { $schema->resultset('Artist')->create ({ name => 'root', rank => 1, cds => [], children => [ { name => 'child1', rank => 2, children => [ { name => 'grandchild', rank => 3, cds => [ { title => "grandchilds's cd" , year => '2008', tracks => [ { position => 1, title => 'Track 1 grandchild', } ], } ], children => [ { name => 'greatgrandchild', rank => 3, } ], } ], }, { name => 'child2', rank => 3, }, ], }); $schema->resultset('Artist')->create({ name => 'cycle-root', children => [ { name => 'cycle-child1', children => [ { name => 'cycle-grandchild' } ], }, { name => 'cycle-child2' }, ], }); $schema->resultset('Artist')->find({ name => 'cycle-root' }) ->update({ parentid => { -ident => 'artistid' } }); # select the whole tree { my $rs = $schema->resultset('Artist')->search({}, { start_with => { name => 'root' }, connect_by => { parentid => { -prior => { -ident => 'artistid' } } }, }); is_deeply ( [ $rs->get_column ('name')->all ], [ qw/root child1 grandchild greatgrandchild child2/ ], 'got artist tree', ); is( $rs->count, 5, 'Connect By count ok' ); } # use order siblings by statement SKIP: { # http://download.oracle.com/docs/cd/A87860_01/doc/server.817/a85397/state21b.htm#2066123 skip q{Oracle8i doesn't support ORDER SIBLINGS BY}, 1 if $schema->storage->_server_info->{normalized_dbms_version} < 9; my $rs = $schema->resultset('Artist')->search({}, { start_with => { name => 'root' }, connect_by => { parentid => { -prior => { -ident => 'artistid' } } }, order_siblings_by => { -desc => 'name' }, }); is_deeply ( [ $rs->get_column ('name')->all ], [ qw/root child2 child1 grandchild greatgrandchild/ ], 'Order Siblings By ok', ); } # get the root node { my $rs = $schema->resultset('Artist')->search({ parentid => undef }, { start_with => { name => 'root' }, connect_by => { parentid => { -prior => { -ident => 'artistid' } } }, }); is_deeply( [ $rs->get_column('name')->all ], [ 'root' ], 'found root node', ); } # combine a connect by with a join SKIP: { # http://download.oracle.com/docs/cd/A87860_01/doc/server.817/a85397/state21b.htm#2066123 skip q{Oracle8i doesn't support connect by with join}, 1 if $schema->storage->_server_info->{normalized_dbms_version} < 9; my $rs = $schema->resultset('Artist')->search( {'cds.title' => { -like => '%cd'} }, { join => 'cds', start_with => { 'me.name' => 'root' }, connect_by => { parentid => { -prior => { -ident => 'artistid' } } }, } ); is_deeply( [ $rs->get_column('name')->all ], [ 'grandchild' ], 'Connect By with a join result name ok' ); is( $rs->count, 1, 'Connect By with a join; count ok' ); } # combine a connect by with order_by { my $rs = $schema->resultset('Artist')->search({}, { start_with => { name => 'root' }, connect_by => { parentid => { -prior => { -ident => 'artistid' } } }, order_by => { -asc => [ 'LEVEL', 'name' ] }, }); # Don't use "$rs->get_column ('name')->all" they build a query arround the $rs. # If $rs has a order by, the order by is in the subquery and this doesn't work with Oracle 8i. # TODO: write extra test and fix order by handling on Oracle 8i is_deeply ( [ map { $_->[1] } $rs->cursor->all ], [ qw/root child1 child2 grandchild greatgrandchild/ ], 'Connect By with a order_by - result name ok (without get_column)' ); SKIP: { skip q{Connect By with a order_by - result name ok (with get_column), Oracle8i doesn't support order by in a subquery},1 if $schema->storage->_server_info->{normalized_dbms_version} < 9; is_deeply ( [ $rs->get_column ('name')->all ], [ qw/root child1 child2 grandchild greatgrandchild/ ], 'Connect By with a order_by - result name ok (with get_column)' ); } } # limit a connect by SKIP: { skip q{Oracle8i doesn't support order by in a subquery}, 1 if $schema->storage->_server_info->{normalized_dbms_version} < 9; my $rs = $schema->resultset('Artist')->search({}, { start_with => { name => 'root' }, connect_by => { parentid => { -prior => { -ident => 'artistid' } } }, order_by => [ { -asc => 'name' }, { -desc => 'artistid' } ], rows => 2, }); is_deeply ( [ $rs->get_column ('name')->all ], [qw/child1 child2/], 'LIMIT a Connect By query - correct names' ); is( $rs->count, 2, 'Connect By; LIMIT count ok' ); } # combine a connect_by with group_by and having # add some bindvals to make sure things still work { my $rs = $schema->resultset('Artist')->search({}, { select => \[ 'COUNT(rank) + ?', [ __cbind => 3 ] ], as => 'cnt', start_with => { name => 'root' }, connect_by => { parentid => { -prior => { -ident => 'artistid' } } }, group_by => \[ 'rank + ? ', [ __gbind => 1] ], having => \[ 'count(rank) < ?', [ cnt => 2 ] ], }); is_deeply ( [ $rs->get_column ('cnt')->all ], [4, 4], 'Group By a Connect By query - correct values' ); } # select the whole cycle tree without nocylce { my $rs = $schema->resultset('Artist')->search({}, { start_with => { name => 'cycle-root' }, connect_by => { parentid => { -prior => { -ident => 'artistid' } } }, }); # ORA-01436: CONNECT BY loop in user data throws_ok { $rs->get_column ('name')->all } qr/ORA-01436/, "connect by initify loop detection without nocycle"; } # select the whole cycle tree with nocylce SKIP: { # http://download.oracle.com/docs/cd/A87860_01/doc/server.817/a85397/expressi.htm#1023748 skip q{Oracle8i doesn't support connect by nocycle}, 1 if $schema->storage->_server_info->{normalized_dbms_version} < 9; my $rs = $schema->resultset('Artist')->search({}, { start_with => { name => 'cycle-root' }, '+select' => \ 'CONNECT_BY_ISCYCLE', '+as' => [ 'connector' ], connect_by_nocycle => { parentid => { -prior => { -ident => 'artistid' } } }, }); is_deeply ( [ $rs->get_column ('name')->all ], [ qw/cycle-root cycle-child1 cycle-grandchild cycle-child2/ ], 'got artist tree with nocycle (name)', ); is_deeply ( [ $rs->get_column ('connector')->all ], [ qw/1 0 0 0/ ], 'got artist tree with nocycle (CONNECT_BY_ISCYCLE)', ); is( $rs->count, 4, 'Connect By Nocycle count ok' ); } } done_testing; sub do_creates { my $dbh = shift; eval { $dbh->do("DROP SEQUENCE artist_autoinc_seq"); $dbh->do("DROP SEQUENCE artist_pk_seq"); $dbh->do("DROP SEQUENCE cd_seq"); $dbh->do("DROP SEQUENCE track_seq"); $dbh->do("DROP TABLE artist"); $dbh->do("DROP TABLE track"); $dbh->do("DROP TABLE cd"); }; $dbh->do("CREATE SEQUENCE artist_pk_seq START WITH 1 MAXVALUE 999999 MINVALUE 0"); $dbh->do("CREATE SEQUENCE cd_seq START WITH 1 MAXVALUE 999999 MINVALUE 0"); $dbh->do("CREATE SEQUENCE track_seq START WITH 1 MAXVALUE 999999 MINVALUE 0"); $dbh->do("CREATE TABLE artist (artistid NUMBER(12), parentid NUMBER(12), name VARCHAR(255), autoinc_col NUMBER(12), rank NUMBER(38), charfield VARCHAR2(10))"); $dbh->do("ALTER TABLE artist ADD (CONSTRAINT artist_pk PRIMARY KEY (artistid))"); $dbh->do("CREATE TABLE cd (cdid NUMBER(12), artist NUMBER(12), title VARCHAR(255), year VARCHAR(4), genreid NUMBER(12), single_track NUMBER(12))"); $dbh->do("ALTER TABLE cd ADD (CONSTRAINT cd_pk PRIMARY KEY (cdid))"); $dbh->do("CREATE TABLE track (trackid NUMBER(12), cd NUMBER(12) REFERENCES cd(cdid) DEFERRABLE, position NUMBER(12), title VARCHAR(255), last_updated_on DATE, last_updated_at DATE, small_dt DATE)"); $dbh->do("ALTER TABLE track ADD (CONSTRAINT track_pk PRIMARY KEY (trackid))"); $dbh->do(qq{ CREATE OR REPLACE TRIGGER artist_insert_trg_pk BEFORE INSERT ON artist FOR EACH ROW BEGIN IF :new.artistid IS NULL THEN SELECT artist_pk_seq.nextval INTO :new.artistid FROM DUAL; END IF; END; }); $dbh->do(qq{ CREATE OR REPLACE TRIGGER cd_insert_trg BEFORE INSERT OR UPDATE ON cd FOR EACH ROW DECLARE tmpVar NUMBER; BEGIN tmpVar := 0; IF :new.cdid IS NULL THEN SELECT cd_seq.nextval INTO tmpVar FROM dual; :new.cdid := tmpVar; END IF; END; }); $dbh->do(qq{ CREATE OR REPLACE TRIGGER track_insert_trg BEFORE INSERT ON track FOR EACH ROW BEGIN IF :new.trackid IS NULL THEN SELECT track_seq.nextval INTO :new.trackid FROM DUAL; END IF; END; }); } # clean up our mess END { if ($schema and my $dbh = $schema->storage->dbh) { eval { $dbh->do($_) } for ( 'DROP SEQUENCE artist_pk_seq', 'DROP SEQUENCE cd_seq', 'DROP SEQUENCE track_seq', 'DROP TABLE artist', 'DROP TABLE track', 'DROP TABLE cd', ); }; undef $schema; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/102load_classes.t�������������������������������������������������������������0000644�0001750�0001750�00000001324�14240132261�016405� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib 't/lib'; use DBICTest; my $warnings; eval { local $SIG{__WARN__} = sub { $warnings .= shift }; package DBICTest::Schema; use base qw/DBIx::Class::Schema/; __PACKAGE__->load_classes; }; ok(!$@, 'Loaded all loadable classes') or diag $@; like($warnings, qr/Failed to load DBICTest::Schema::NoSuchClass. Can't find source_name method. Is DBICTest::Schema::NoSuchClass really a full DBIC result class?/, 'Warned about broken result class'); my $source_a = DBICTest::Schema->source('Artist'); isa_ok($source_a, 'DBIx::Class::ResultSource::Table'); my $rset_a = DBICTest::Schema->resultset('Artist'); isa_ok($rset_a, 'DBIx::Class::ResultSet'); done_testing; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/65multipk.t�������������������������������������������������������������������0000644�0001750�0001750�00000001367�14240132261�015375� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); plan tests => 5; my $artist = $schema->resultset("Artist")->find(1); ok($artist->find_related('twokeys', {cd => 1}), "find multiple pks using relationships + args"); ok($schema->resultset("FourKeys")->search({ foo => 1, bar => 2 })->find({ hello => 3, goodbye => 4 }), "search on partial key followed by a find"); ok($schema->resultset("FourKeys")->find(1,2,3,4), "find multiple pks without hash"); ok($schema->resultset("FourKeys")->find(5,4,3,6), "find multiple pks without hash"); is($schema->resultset("FourKeys")->find(1,2,3,4)->ID, 'DBICTest::FourKeys|fourkeys|bar=2|foo=1|goodbye=4|hello=3', 'unique object id ok for multiple pks'); �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/93autocast.t������������������������������������������������������������������0000644�0001750�0001750�00000004210�14240132261�015522� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; { # Fake storage driver for sqlite with autocast package DBICTest::SQLite::AutoCast; use base qw/ DBIx::Class::Storage::DBI::AutoCast DBIx::Class::Storage::DBI::SQLite /; use mro 'c3'; my $type_map = { datetime => 'DateTime', integer => 'INT', int => undef, # no conversion }; sub _native_data_type { return $type_map->{$_[1]}; } } my $schema = DBICTest->init_schema (storage_type => 'DBICTest::SQLite::AutoCast'); # 'me.id' will be cast unlike the unqualified 'id' my $rs = $schema->resultset ('CD')->search ({ cdid => { '>', 5 }, 'tracks.last_updated_at' => { '!=', undef }, 'tracks.last_updated_on' => { '<', 2009 }, 'tracks.position' => 4, 'me.single_track' => \[ '= ?', [ single_track => 1 ] ], }, { join => 'tracks' }); my @bind = ( [ { dbic_colname => "cdid", sqlt_datatype => "integer" } => 5 ], [ { dbic_colname => "single_track", sqlt_datatype => "integer" } => 1 ], [ { dbic_colname => "tracks.last_updated_on", sqlt_datatype => "datetime" } => 2009 ], [ { dbic_colname => "tracks.position", sqlt_datatype => "int" } => 4 ], ); $schema->is_executed_sql_bind( sub { $rs->all }, [[ ' SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me LEFT JOIN track tracks ON tracks.cd = me.cdid WHERE cdid > ? AND me.single_track = ? AND tracks.last_updated_at IS NOT NULL AND tracks.last_updated_on < ? AND tracks.position = ? ', @bind, ]], 'expected sql with casting off' ); $schema->storage->auto_cast (1); $schema->is_executed_sql_bind( sub { $rs->all }, [[ ' SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me LEFT JOIN track tracks ON tracks.cd = me.cdid WHERE cdid > CAST(? AS INT) AND me.single_track = CAST(? AS INT) AND tracks.last_updated_at IS NOT NULL AND tracks.last_updated_on < CAST (? AS DateTime) AND tracks.position = ? ', @bind, ]], 'expected sql with casting on' ); done_testing; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/104view.t���������������������������������������������������������������������0000644�0001750�0001750�00000003643�14240132261�014733� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); ## Real view my $cds_rs_2000 = $schema->resultset('CD')->search( { year => 2000 }); my $year2kcds_rs = $schema->resultset('Year2000CDs'); is($cds_rs_2000->count, $year2kcds_rs->count, 'View Year2000CDs sees all CDs in year 2000'); ## Virtual view my $cds_rs_1999 = $schema->resultset('CD')->search( { year => 1999 }); my $year1999cds_rs = $schema->resultset('Year1999CDs'); is($cds_rs_1999->count, $year1999cds_rs->count, 'View Year1999CDs sees all CDs in year 1999'); # Test if relationships work correctly is_deeply ( [ $schema->resultset('Year1999CDs')->search ( {}, { result_class => 'DBIx::Class::ResultClass::HashRefInflator', prefetch => ['artist', { tracks => [qw/cd year1999cd year2000cd/] } ], order_by => 'tracks.trackid', }, )->all ], [ $schema->resultset('CD')->search ( { 'me.year' => '1999'}, { result_class => 'DBIx::Class::ResultClass::HashRefInflator', prefetch => ['artist', { tracks => [qw/cd year1999cd year2000cd/] } ], columns => [qw/cdid single_track title/], # to match the columns retrieved by the virtview order_by => 'tracks.trackid', }, )->all ], 'Prefetch over virtual view gives expected result', ); is_deeply ( [ $schema->resultset('Year2000CDs')->search ( {}, { result_class => 'DBIx::Class::ResultClass::HashRefInflator', prefetch => ['artist', { tracks => [qw/cd year1999cd year2000cd/] } ], }, )->all ], [ $schema->resultset('CD')->search ( { 'me.year' => '2000'}, { result_class => 'DBIx::Class::ResultClass::HashRefInflator', prefetch => ['artist', { tracks => [qw/cd year1999cd year2000cd/] } ], }, )->all ], 'Prefetch over regular view gives expected result', ); done_testing; ���������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/751msaccess.t�����������������������������������������������������������������0000644�0001750�0001750�00000027641�14240132261�015576� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use Scope::Guard (); use Try::Tiny; use DBIx::Class::Optional::Dependencies (); use lib qw(t/lib); use DBICTest; my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSACCESS_ODBC_${_}" } qw/DSN USER PASS/}; my ($dsn2, $user2, $pass2) = @ENV{map { "DBICTEST_MSACCESS_ADO_${_}" } qw/DSN USER PASS/}; plan skip_all => 'Test needs ' . (join ' or ', map { $_ ? $_ : () } DBIx::Class::Optional::Dependencies->req_missing_for('test_rdbms_msaccess_odbc'), DBIx::Class::Optional::Dependencies->req_missing_for('test_rdbms_msaccess_ado')) unless $dsn && DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_msaccess_odbc') or $dsn2 && DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_msaccess_ado') or (not $dsn || $dsn2); DBICTest::Schema->load_classes('ArtistGUID'); # Example DSNs (32bit only): # dbi:ODBC:driver={Microsoft Access Driver (*.mdb, *.accdb)};dbq=C:\Users\rkitover\Documents\access_sample.accdb # dbi:ADO:Microsoft.Jet.OLEDB.4.0;Data Source=C:\Users\rkitover\Documents\access_sample.accdb # dbi:ADO:Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\Users\rkitover\Documents\access_sample.accdb;Persist Security Info=False' plan skip_all => <<'EOF' unless $dsn || $dsn2; Set $ENV{DBICTEST_MSACCESS_ODBC_DSN} and/or $ENV{DBICTEST_MSACCESS_ADO_DSN} (and optionally _USER and _PASS) to run these tests. Warning: this test drops and creates the tables 'artist', 'cd', 'bindtype_test' and 'artist_guid'. EOF my @info = ( [ $dsn, $user || '', $pass || '' ], [ $dsn2, $user2 || '', $pass2 || '' ], ); foreach my $info (@info) { my ($dsn, $user, $pass) = @$info; next unless $dsn; # Check that we can connect without any options. my $schema = DBICTest::Schema->connect($dsn, $user, $pass); lives_ok { $schema->storage->ensure_connected; } 'connection without any options'; my %binstr = ( 'small' => join('', map { chr($_) } ( 1 .. 127 )) ); $binstr{'large'} = $binstr{'small'} x 1024; my $maxloblen = length $binstr{'large'}; $schema = DBICTest::Schema->connect($dsn, $user, $pass, { quote_names => 1, auto_savepoint => 1, LongReadLen => $maxloblen, }); my $guard = Scope::Guard->new(sub { cleanup($schema) }); my $dbh = $schema->storage->dbh; # turn off warnings for OLE exception from ADO about nonexistant table eval { local $^W = 0; $dbh->do("DROP TABLE artist") }; $dbh->do(<<EOF); CREATE TABLE artist ( artistid AUTOINCREMENT PRIMARY KEY, name VARCHAR(255) NULL, charfield CHAR(10) NULL, rank INT NULL ) EOF my $ars = $schema->resultset('Artist'); is ( $ars->count, 0, 'No rows at first' ); # test primary key handling my $new = $ars->create({ name => 'foo' }); ok($new->artistid, "Auto-PK worked"); my $first_artistid = $new->artistid; # test explicit key spec $new = $ars->create ({ name => 'bar', artistid => 66 }); is($new->artistid, 66, 'Explicit PK worked'); $new->discard_changes; is($new->artistid, 66, 'Explicit PK assigned'); # test joins eval { local $^W = 0; $dbh->do("DROP TABLE cd") }; $dbh->do(<<EOF); CREATE TABLE cd ( cdid AUTOINCREMENT PRIMARY KEY, artist INTEGER NULL, title VARCHAR(255) NULL, [year] CHAR(4) NULL, genreid INTEGER NULL, single_track INTEGER NULL ) EOF $dbh->do(<<EOF); CREATE TABLE track ( trackid AUTOINCREMENT PRIMARY KEY, cd INTEGER REFERENCES cd(cdid), [position] INTEGER, title VARCHAR(255), last_updated_on DATETIME, last_updated_at DATETIME ) EOF my $cd = $schema->resultset('CD')->create({ artist => $first_artistid, title => 'Some Album', }); # one-step join my $joined_artist = $schema->resultset('Artist')->search({ artistid => $first_artistid, }, { join => [ 'cds' ], '+select' => [ 'cds.title' ], '+as' => [ 'cd_title' ], })->next; is $joined_artist->get_column('cd_title'), 'Some Album', 'one-step join works'; # two-step join my $track = $schema->resultset('Track')->create({ cd => $cd->cdid, position => 1, title => 'my track', }); my $joined_track = try { $schema->resultset('Artist')->search({ artistid => $first_artistid, }, { join => [{ cds => 'tracks' }], '+select' => [ 'tracks.title' ], '+as' => [ 'track_title' ], })->next; } catch { diag "Could not execute two-step left join: $_"; }; is try { $joined_track->get_column('track_title') }, 'my track', 'two-step left join works'; $joined_artist = try { $schema->resultset('Track')->search({ trackid => $track->trackid, }, { join => [{ cd => 'artist' }], '+select' => [ 'artist.name' ], '+as' => [ 'artist_name' ], })->next; } catch { diag "Could not execute two-step inner join: $_"; }; is try { $joined_artist->get_column('artist_name') }, 'foo', 'two-step inner join works'; # test basic transactions $schema->txn_do(sub { $ars->create({ name => 'transaction_commit' }); }); ok($ars->search({ name => 'transaction_commit' })->first, 'transaction committed'); $ars->search({ name => 'transaction_commit' })->delete, throws_ok { $schema->txn_do(sub { $ars->create({ name => 'transaction_rollback' }); die 'rolling back'; }); } qr/rolling back/, 'rollback executed'; is $ars->search({ name => 'transaction_rollback' })->first, undef, 'transaction rolled back'; # test two-phase commit and inner transaction rollback from nested transactions $schema->txn_do(sub { $ars->create({ name => 'in_outer_transaction' }); $schema->txn_do(sub { $ars->create({ name => 'in_inner_transaction' }); }); ok($ars->search({ name => 'in_inner_transaction' })->first, 'commit from inner transaction visible in outer transaction'); throws_ok { $schema->txn_do(sub { $ars->create({ name => 'in_inner_transaction_rolling_back' }); die 'rolling back inner transaction'; }); } qr/rolling back inner transaction/, 'inner transaction rollback executed'; }); ok($ars->search({ name => 'in_outer_transaction' })->first, 'commit from outer transaction'); ok($ars->search({ name => 'in_inner_transaction' })->first, 'commit from inner transaction'); is $ars->search({ name => 'in_inner_transaction_rolling_back' })->first, undef, 'rollback from inner transaction'; $ars->search({ name => 'in_outer_transaction' })->delete; $ars->search({ name => 'in_inner_transaction' })->delete; # test populate lives_ok (sub { my @pop; for (1..2) { push @pop, { name => "Artist_$_" }; } $ars->populate (\@pop); }); # test populate with explicit key lives_ok (sub { my @pop; for (1..2) { push @pop, { name => "Artist_expkey_$_", artistid => 100 + $_ }; } $ars->populate (\@pop); }); # count what we did so far is ($ars->count, 6, 'Simple count works'); # test LIMIT support # not testing offset because access only supports TOP my $lim = $ars->search( {}, { rows => 2, offset => 0, order_by => 'artistid' } ); is( $lim->count, 2, 'ROWS+OFFSET count ok' ); is( $lim->all, 2, 'Number of ->all objects matches count' ); # test iterator $lim->reset; is( $lim->next->artistid, 1, "iterator->next ok" ); is( $lim->next->artistid, 66, "iterator->next ok" ); is( $lim->next, undef, "next past end of resultset ok" ); # test empty insert my $current_artistid = $ars->search({}, { select => [ { max => 'artistid' } ], as => ['artistid'] })->first->artistid; my $row; lives_ok { $row = $ars->create({}) } 'empty insert works'; $row->discard_changes; is $row->artistid, $current_artistid+1, 'empty insert generated correct PK'; # test that autoinc column still works after empty insert $row = $ars->create({ name => 'after_empty_insert' }); is $row->artistid, $current_artistid+2, 'autoincrement column functional aftear empty insert'; # test blobs (stolen from 73oracle.t) # turn off horrendous binary DBIC_TRACE output { local $schema->storage->{debug} = 0; eval { local $^W = 0; $dbh->do('DROP TABLE bindtype_test') }; $dbh->do(qq[ CREATE TABLE bindtype_test ( id INT NOT NULL PRIMARY KEY, bytea INT NULL, blob IMAGE NULL, clob TEXT NULL, a_memo MEMO NULL ) ],{ RaiseError => 1, PrintError => 1 }); my $rs = $schema->resultset('BindType'); my $id = 0; foreach my $type (qw( blob clob a_memo )) { foreach my $size (qw( small large )) { SKIP: { skip 'TEXT columns not cast to MEMO over ODBC', 2 if $type eq 'clob' && $size eq 'large' && $dsn =~ /:ODBC:/; $id++; lives_ok { $rs->create( { 'id' => $id, $type => $binstr{$size} } ) } "inserted $size $type without dying" or next; my $from_db = eval { $rs->find($id)->$type } || ''; diag $@ if $@; ok($from_db eq $binstr{$size}, "verified inserted $size $type" ) or do { my $hexdump = sub { join '', map sprintf('%02X', ord), split //, shift }; diag 'Got: ', "\n", substr($hexdump->($from_db),0,255), '...', substr($hexdump->($from_db),-255); diag 'Size: ', length($from_db); diag 'Expected Size: ', length($binstr{$size}); diag 'Expected: ', "\n", substr($hexdump->($binstr{$size}), 0, 255), "...", substr($hexdump->($binstr{$size}),-255); }; } } } # test IMAGE update lives_ok { $rs->search({ id => 0 })->update({ blob => $binstr{small} }); } 'updated IMAGE to small binstr without dying'; lives_ok { $rs->search({ id => 0 })->update({ blob => $binstr{large} }); } 'updated IMAGE to large binstr without dying'; } # test GUIDs (and the cursor GUID fixup stuff for ADO) require Data::GUID; $schema->storage->new_guid(sub { Data::GUID->new->as_string }); local $schema->source('ArtistGUID')->column_info('artistid')->{data_type} = 'guid'; local $schema->source('ArtistGUID')->column_info('a_guid')->{data_type} = 'guid'; $schema->storage->dbh_do (sub { my ($storage, $dbh) = @_; eval { local $^W = 0; $dbh->do("DROP TABLE artist_guid") }; $dbh->do(<<"SQL"); CREATE TABLE artist_guid ( artistid GUID NOT NULL, name VARCHAR(100), rank INT NULL, charfield CHAR(10) NULL, a_guid GUID, primary key(artistid) ) SQL }); lives_ok { $row = $schema->resultset('ArtistGUID')->create({ name => 'mtfnpy' }) } 'created a row with a GUID'; ok( eval { $row->artistid }, 'row has GUID PK col populated', ); diag $@ if $@; ok( eval { $row->a_guid }, 'row has a GUID col with auto_nextval populated', ); diag $@ if $@; my $row_from_db = $schema->resultset('ArtistGUID') ->search({ name => 'mtfnpy' })->first; is $row_from_db->artistid, $row->artistid, 'PK GUID round trip (via ->search->next)'; is $row_from_db->a_guid, $row->a_guid, 'NON-PK GUID round trip (via ->search->next)'; $row_from_db = $schema->resultset('ArtistGUID') ->find($row->artistid); is $row_from_db->artistid, $row->artistid, 'PK GUID round trip (via ->find)'; is $row_from_db->a_guid, $row->a_guid, 'NON-PK GUID round trip (via ->find)'; ($row_from_db) = $schema->resultset('ArtistGUID') ->search({ name => 'mtfnpy' })->all; is $row_from_db->artistid, $row->artistid, 'PK GUID round trip (via ->search->all)'; is $row_from_db->a_guid, $row->a_guid, 'NON-PK GUID round trip (via ->search->all)'; } done_testing; sub cleanup { my $schema = shift; if (my $storage = eval { $schema->storage }) { # cannot drop a table if it has been used, have to reconnect first $schema->storage->disconnect; local $^W = 0; # for ADO OLE exceptions $schema->storage->dbh->do("DROP TABLE $_") for qw/artist track cd bindtype_test artist_guid/; } } # vim:sts=2 sw=2: �����������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/52leaks.t���������������������������������������������������������������������0000644�0001750�0001750�00000047570�14240132261�015011� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# work around brain damage in PPerl (yes, it has to be a global) $SIG{__WARN__} = sub { warn @_ unless $_[0] =~ /\QUse of "goto" to jump into a construct is deprecated/ } if ($ENV{DBICTEST_IN_PERSISTENT_ENV}); # the persistent environments run with this flag first to see if # we will run at all (e.g. it will fail if $^X doesn't match) exit 0 if $ENV{DBICTEST_PERSISTENT_ENV_BAIL_EARLY}; # Do the override as early as possible so that CORE::bless doesn't get compiled away # We will replace $bless_override only if we are in author mode my $bless_override; BEGIN { $bless_override = sub { CORE::bless( $_[0], (@_ > 1) ? $_[1] : caller() ); }; *CORE::GLOBAL::bless = sub { goto $bless_override }; } use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest::RunMode; use DBICTest::Util::LeakTracer qw(populate_weakregistry assert_empty_weakregistry visit_refs); use Scalar::Util qw(weaken blessed reftype); use DBIx::Class::_Util qw(hrefaddr sigwarn_silencer modver_gt_or_eq modver_gt_or_eq_and_lt); BEGIN { plan skip_all => "Your perl version $] appears to leak like a sieve - skipping test" if DBIx::Class::_ENV_::PEEPEENESS; } my $TB = Test::More->builder; if ($ENV{DBICTEST_IN_PERSISTENT_ENV}) { # without this explicit close TB warns in END after a ->reset close ($TB->$_) for qw(output failure_output todo_output); # newer TB does not auto-reopen handles if ( modver_gt_or_eq( 'Test::More', '1.200' ) ) { open ($TB->$_, '>&', *STDERR) for qw( failure_output todo_output ); open ($TB->output, '>&', *STDOUT); } # so done_testing can work on every persistent pass $TB->reset; } # this is what holds all weakened refs to be checked for leakage my $weak_registry = {}; # whether or to invoke IC::DT my $has_dt; # Skip the heavy-duty leak tracing when just doing an install unless (DBICTest::RunMode->is_plain) { # redefine the bless override so that we can catch each and every object created no warnings qw/redefine once/; no strict qw/refs/; $bless_override = sub { my $obj = CORE::bless( $_[0], (@_ > 1) ? $_[1] : do { my ($class, $fn, $line) = caller(); fail ("bless() of $_[0] into $class without explicit class specification at $fn line $line") if $class =~ /^ (?: DBIx\:\:Class | DBICTest ) /x; $class; } ); # unicode is tricky, and now we happen to invoke it early via a # regex in connection() return $obj if (ref $obj) =~ /^utf8/; # Test Builder is now making a new object for every pass/fail (que bloat?) # and as such we can't really store any of its objects (since it will # re-populate the registry while checking it, ewwww!) return $obj if (ref $obj) =~ /^TB2::|^Test::Stream/; # populate immediately to avoid weird side effects return populate_weakregistry ($weak_registry, $obj ); }; require Try::Tiny; for my $func (qw/try catch finally/) { my $orig = \&{"Try::Tiny::$func"}; *{"Try::Tiny::$func"} = sub (&;@) { populate_weakregistry( $weak_registry, $_[0] ); goto $orig; } } # Some modules are known to install singletons on-load # Load them and empty the registry # this loads the DT armada $has_dt = DBIx::Class::Optional::Dependencies->req_ok_for('test_dt_sqlite'); require Errno; require DBI; require DBD::SQLite; require FileHandle; require Moo; %$weak_registry = (); } { use_ok ('DBICTest'); my $schema = DBICTest->init_schema; my $rs = $schema->resultset ('Artist'); my $storage = $schema->storage; ok ($storage->connected, 'we are connected'); my $row_obj = $rs->search({}, { rows => 1})->next; # so that commits/rollbacks work ok ($row_obj, 'row from db'); # txn_do to invoke more codepaths my ($mc_row_obj, $pager, $pager_explicit_count) = $schema->txn_do (sub { my $artist = $schema->resultset('Artist')->create ({ name => 'foo artist', cds => [{ title => 'foo cd', year => 1984, tracks => [ { title => 't1' }, { title => 't2' }, ], genre => { name => 'mauve' }, }], }); my $pg = $rs->search({}, { rows => 1})->page(2)->pager; my $pg_wcount = $rs->page(4)->pager->total_entries (66); return ($artist, $pg, $pg_wcount); }); # more codepaths - error handling in txn_do { eval { $schema->txn_do ( sub { $storage->_dbh->begin_work; fail ('how did we get so far?!'); } ) }; eval { $schema->txn_do ( sub { $schema->txn_do ( sub { die "It's called EXCEPTION"; fail ('how did we get so far?!'); } ); fail ('how did we get so far?!'); } ) }; like( $@, qr/It\'s called EXCEPTION/, 'Exception correctly propagated in nested txn_do' ); } # dbh_do codepath my ($rs_bind_circref, $cond_rowobj) = $schema->storage->dbh_do ( sub { my $row = $_[0]->schema->resultset('Artist')->new({}); my $rs = $_[0]->schema->resultset('Artist')->search({ name => $row, # this is deliberately bogus, see FIXME below! }); return ($rs, $row); }); is ($pager->next_page, 3, 'There is one more page available'); # based on 66 per 10 pages is ($pager_explicit_count->last_page, 7, 'Correct last page'); # do some population (invokes some extra codepaths) # also exercise the guard code and the manual txn control { my $guard = $schema->txn_scope_guard; # populate with bindvars $rs->populate([{ name => 'James Bound' }]); $guard->commit; $schema->txn_begin; # populate mixed $rs->populate([{ name => 'James Rebound', rank => \ '11' }]); $schema->txn_commit; $schema->txn_begin; # and without bindvars $rs->populate([{ name => \ '"James Unbound"' }]); $schema->txn_rollback; } # prefetching my $cds_rs = $schema->resultset('CD'); my $cds_with_artist = $cds_rs->search({}, { prefetch => 'artist' }); my $cds_with_tracks = $cds_rs->search({}, { prefetch => 'tracks' }); my $cds_with_stuff = $cds_rs->search({}, { prefetch => [ 'genre', { artist => { cds => { tracks => 'cd_single' } } } ] }); # implicit pref my $cds_with_impl_artist = $cds_rs->search({}, { columns => [qw/me.title artist.name/], join => 'artist' }); # get_column my $getcol_rs = $cds_rs->get_column('me.cdid'); my $pref_getcol_rs = $cds_with_stuff->get_column('me.cdid'); my $base_collection = { resultset => $rs, pref_precursor => $cds_rs, pref_rs_single => $cds_with_artist, pref_rs_multi => $cds_with_tracks, pref_rs_nested => $cds_with_stuff, pref_rs_implicit => $cds_with_impl_artist, pref_row_single => $cds_with_artist->next, pref_row_multi => $cds_with_tracks->next, pref_row_nested => $cds_with_stuff->next, # even though this does not leak Storable croaks on it :((( #pref_row_implicit => $cds_with_impl_artist->next, get_column_rs_plain => $getcol_rs, get_column_rs_pref => $pref_getcol_rs, # twice so that we make sure only one H::M object spawned chained_resultset => $rs->search_rs ({}, { '+columns' => { foo => 'artistid' } } ), chained_resultset2 => $rs->search_rs ({}, { '+columns' => { bar => 'artistid' } } ), row_object => $row_obj, mc_row_object => $mc_row_obj, result_source => $rs->result_source, result_source_handle => $rs->result_source->handle, pager_explicit_count => $pager_explicit_count, leaky_resultset => $rs_bind_circref, leaky_resultset_cond => $cond_rowobj, }; # fire all resultsets multiple times, once here, more below # some of these can't find anything (notably leaky_resultset) my @rsets = grep { blessed $_ and ( $_->isa('DBIx::Class::ResultSet') or $_->isa('DBIx::Class::ResultSetColumn') ) } values %$base_collection; my $fire_resultsets = sub { local $ENV{DBIC_COLUMNS_INCLUDE_FILTER_RELS} = 1; local $SIG{__WARN__} = sigwarn_silencer( qr/Unable to deflate 'filter'-type relationship 'artist'.+related object primary key not retrieved/ ); map { $_, (blessed($_) ? { $_->get_columns } : ()) } map { $_->all } @rsets ; }; push @{$base_collection->{random_results}}, $fire_resultsets->(); # FIXME - something throws a Storable for a spin if we keep # the results in-collection. The same problem is seen above, # swept under the rug back in 0a03206a, damned lazy ribantainer { local $base_collection->{random_results}; require Storable; %$base_collection = ( %$base_collection, refrozen => Storable::dclone( $base_collection ), rerefrozen => Storable::dclone( Storable::dclone( $base_collection ) ), pref_row_implicit => $cds_with_impl_artist->next, schema => $schema, storage => $storage, sql_maker => $storage->sql_maker, dbh => $storage->_dbh, fresh_pager => $rs->page(5)->pager, pager => $pager, ); } # FIXME - ideally this kind of collector ought to be global, but attempts # with an invasive debugger-based tracer did not quite work out... yet # Manually scan the innards of everything we have in the base collection # we assembled so far (skip the DT madness below) *recursively* # # Only do this when we do have the bits to look inside CVs properly, # without it we are liable to pick up object defaults that are locked # in method closures # # Some elaborate SQLAC-replacements leak, do not worry about it for now if ( DBICTest::Util::LeakTracer::CV_TRACING and ! $ENV{DBICTEST_SWAPOUT_SQLAC_WITH} ) { visit_refs( refs => [ $base_collection ], action => sub { populate_weakregistry ($weak_registry, $_[0]); 1; # true means "keep descending" }, ); # do a heavy-duty fire-and-compare loop on all resultsets # this is expensive - not running on install my $typecounts = {}; if ( ! DBICTest::RunMode->is_plain and ! $ENV{DBICTEST_IN_PERSISTENT_ENV} ) { # FIXME - ideally we should be able to just populate an alternative # registry, subtract everything from the main one, and arrive at # an "empty" resulting hash # However due to gross inefficiencies in the ::ResultSet code we # end up recalculating a new set of aliasmaps which could have very # well been cached if it wasn't for... anyhow # What we do here for the time being is similar to the lazy approach # of Devel::LeakTrace - we just make sure we do not end up with more # reftypes than when we started. At least we are not blanket-counting # SVs like D::LT does, but going by reftype... sigh... for (values %$weak_registry) { if ( my $r = reftype($_->{weakref}) ) { $typecounts->{$r}--; } } # For now we can only reuse the same registry, see FIXME above/below #for my $interim_wr ({}, {}) { for my $interim_wr ( ($weak_registry) x 4 ) { visit_refs( refs => [ $fire_resultsets->(), @rsets ], action => sub { populate_weakregistry ($interim_wr, $_[0]); 1; # true means "keep descending" }, ); # FIXME - this is what *should* be here # ## anything we have seen so far is cool #delete @{$interim_wr}{keys %$weak_registry}; # ## moment of truth - the rest ought to be gone #assert_empty_weakregistry($interim_wr); } for (values %$weak_registry) { if ( my $r = reftype($_->{weakref}) ) { $typecounts->{$r}++; } } } for (keys %$typecounts) { fail ("Amount of $_ refs changed by $typecounts->{$_} during resultset mass-execution") if ( abs ($typecounts->{$_}) > 1 ); # there is a pad caught somewhere, the +1/-1 can be ignored } } if ($has_dt) { my $rs = $base_collection->{icdt_rs} = $schema->resultset('Event'); my $now = DateTime->now; for (1..5) { $base_collection->{"icdt_row_$_"} = $rs->create({ created_on => DateTime->new(year => 2011, month => 1, day => $_, time_zone => "-0${_}00" ), starts_at => $now->clone->add(days => $_), }); } # re-search my @dummy = $rs->all; } # dbh's are created in XS space, so pull them separately for ( grep { defined } map { @{$_->{ChildHandles}} } values %{ {DBI->installed_drivers()} } ) { $base_collection->{"DBI handle $_"} = $_; } populate_weakregistry ($weak_registry, $base_collection->{$_}, "basic $_") for keys %$base_collection; } # check that "phantom-chaining" works - we never lose track of the original $schema # and have access to the entire tree without leaking anything { my $phantom; for ( sub { DBICTest->init_schema( sqlite_use_file => 0 ) }, sub { shift->source('Artist') }, sub { shift->resultset }, sub { shift->result_source }, sub { shift->schema }, sub { shift->resultset('Artist') }, sub { shift->find_or_create({ name => 'detachable' }) }, sub { shift->result_source }, sub { shift->schema }, sub { shift->clone }, sub { shift->resultset('CD') }, sub { shift->next }, sub { shift->artist }, sub { shift->search_related('cds') }, sub { shift->next }, sub { shift->search_related('artist') }, sub { shift->result_source }, sub { shift->resultset }, sub { shift->create({ name => 'detached' }) }, sub { shift->update({ name => 'reattached' }) }, sub { shift->discard_changes }, sub { shift->delete }, sub { shift->insert }, ) { $phantom = populate_weakregistry ( $weak_registry, scalar $_->($phantom) ); } ok( $phantom->in_storage, 'Properly deleted/reinserted' ); is( $phantom->name, 'reattached', 'Still correct name' ); } # Naturally we have some exceptions my $cleared; for my $addr (keys %$weak_registry) { my $names = join "\n", keys %{$weak_registry->{$addr}{slot_names}}; if ($names =~ /^Test::Builder/m) { # T::B 2.0 has result objects and other fancyness delete $weak_registry->{$addr}; } elsif ($names =~ /^Hash::Merge/m) { # only clear one object of a specific behavior - more would indicate trouble delete $weak_registry->{$addr} unless $cleared->{hash_merge_singleton}{$weak_registry->{$addr}{weakref}{behavior}}++; } elsif ($names =~ /^B::Hooks::EndOfScope::PP::_TieHintHashFieldHash/m) { # there is one tied lexical which stays alive until GC time # https://metacpan.org/source/ETHER/B-Hooks-EndOfScope-0.15/lib/B/Hooks/EndOfScope/PP/FieldHash.pm#L24 # simply ignore it here, instead of teaching the leaktracer to examine ties # the latter is possible yet terrible: https://metacpan.org/source/RIBASUSHI/DBIx-Class-0.082840/t/lib/DBICTest/Util/LeakTracer.pm#L113-117 delete $weak_registry->{$addr} unless $cleared->{bheos_pptiehinthashfieldhash}++; } elsif ($names =~ /^B::Hooks::EndOfScope::PP::HintHash::__GraveyardTransport/m) { # a workaround for perl-level double free: these "leak" by design delete $weak_registry->{$addr}; } elsif ($names =~ /^DateTime::TimeZone::UTC/m) { # DT is going through a refactor it seems - let it leak zones for now delete $weak_registry->{$addr}; } elsif ( # # if we can look at closed over pieces - we will register it as a global # !DBICTest::Util::LeakTracer::CV_TRACING # and $names =~ /^SQL::Translator::Generator::DDL::SQLite/m ) { # SQLT::Producer::SQLite keeps global generators around for quoted # and non-quoted DDL, allow one for each quoting style delete $weak_registry->{$addr} unless $cleared->{sqlt_ddl_sqlite}->{@{$weak_registry->{$addr}{weakref}->quote_chars}}++; } } # FIXME !!! # There is an actual strong circular reference taking place here, but because # half of it is in XS, so it is a bit harder to track down (it stumps D::FR) # (our tracker does not yet do it, but it'd be nice) # The problem is: # # $cond_object --> result_source --> schema --> storage --> $dbh --> {CachedKids} # ^ / # \-------- bound value on prepared/cached STH <-----------/ # { my @circreffed; for my $r (map { $_->{weakref} } grep { $_->{slot_names}{'basic leaky_resultset_cond'} } values %$weak_registry ) { local $TODO = 'Needs Data::Entangled or somesuch - see RT#82942'; ok(! defined $r, 'Self-referential RS conditions no longer leak!') or push @circreffed, $r; } if (@circreffed) { is (scalar @circreffed, 1, 'One resultset expected to leak'); # this is useless on its own, it is to showcase the circref-diag # and eventually test it when it is operational local $TODO = 'Needs Data::Entangled or somesuch - see RT#82942'; while (@circreffed) { weaken (my $r = shift @circreffed); populate_weakregistry( (my $mini_registry = {}), $r ); assert_empty_weakregistry( $mini_registry ); $r->result_source(undef); } } } assert_empty_weakregistry ($weak_registry); # we got so far without a failure - this is a good thing # now let's try to rerun this script under a "persistent" environment # this is ugly and dirty but we do not yet have a Test::Embedded or # similar my $persistence_tests; SKIP: { skip 'Test already in a persistent loop', 1 if $ENV{DBICTEST_IN_PERSISTENT_ENV}; skip 'Main test failed - skipping persistent env tests', 1 unless $TB->is_passing; skip "Test::Builder\@@{[ Test::Builder->VERSION ]} known to break persistence tests", 1 if modver_gt_or_eq_and_lt( 'Test::More', '1.200', '1.301001_099' ); local $ENV{DBICTEST_IN_PERSISTENT_ENV} = 1; $persistence_tests = { PPerl => { cmd => [qw/pperl --prefork=1/, __FILE__], }, 'CGI::SpeedyCGI' => { cmd => [qw/speedy -- -t5/, __FILE__], }, }; # scgi is smart and will auto-reap after -t amount of seconds # pperl needs an actual killer :( $persistence_tests->{PPerl}{termcmd} = [ $persistence_tests->{PPerl}{cmd}[0], '--kill', @{$persistence_tests->{PPerl}{cmd}}[ 1 .. $#{$persistence_tests->{PPerl}{cmd}} ], ]; # set up -I require Config; $ENV{PERL5LIB} = join ($Config::Config{path_sep}, @INC); # adjust PATH for -T if (length $ENV{PATH}) { ( $ENV{PATH} ) = join ( $Config::Config{path_sep}, map { length($_) ? File::Spec->rel2abs($_) : () } split /\Q$Config::Config{path_sep}/, $ENV{PATH} ) =~ /\A(.+)\z/; } for my $type (keys %$persistence_tests) { SKIP: { unless (eval "require $type") { # Don't terminate what we didn't start delete $persistence_tests->{$type}{termcmd}; skip "$type module not found", 1; } my @cmd = @{$persistence_tests->{$type}{cmd}}; # since PPerl is racy and sucks - just prime the "server" { local $ENV{DBICTEST_PERSISTENT_ENV_BAIL_EARLY} = 1; system(@cmd); sleep 1; # see if the thing actually runs, if not - might as well bail now skip "Something is wrong with $type ($!)", 1 if system(@cmd); } require IPC::Open2; for (1,2,3) { note ("Starting run in persistent env ($type pass $_)"); IPC::Open2::open2(my $out, undef, @cmd); my @out_lines; while (my $ln = <$out>) { next if $ln =~ /^\s*$/; push @out_lines, " $ln"; last if $ln =~ /^\d+\.\.\d+$/; # this is persistence, we need to terminate reading on our end } print $_ for @out_lines; close $out; wait; ok (!$?, "Run in persistent env ($type pass $_): exit $?"); ok (scalar @out_lines, "Run in persistent env ($type pass $_): got output"); } ok (! system (@{$persistence_tests->{$type}{termcmd}}), "killed $type server instance") if $persistence_tests->{$type}{termcmd}; }} } done_testing; # just an extra precaution in case we blew away from the SKIP - since there are no # PID files to go by (man does pperl really suck :( END { if ($persistence_tests->{PPerl}{termcmd}) { local $?; # otherwise test will inherit $? of the system() require IPC::Open3; open my $null, ">", File::Spec->devnull; waitpid( IPC::Open3::open3(undef, $null, $null, @{$persistence_tests->{PPerl}{termcmd}}), 0, ); } } ����������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/76select.t��������������������������������������������������������������������0000644�0001750�0001750�00000014226�14240132261�015167� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use lib qw(t/lib); use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); my $rs = $schema->resultset('CD')->search({}, { '+select' => \ 'COUNT(*)', '+as' => 'count' } ); lives_ok(sub { $rs->first->get_column('count') }, 'additional count rscolumn present'); dies_ok(sub { $rs->first->get_column('nonexistent_column') }, 'nonexistant column requests still throw exceptions'); $rs = $schema->resultset('CD')->search({}, { '+select' => [ \ 'COUNT(*)', 'title' ], '+as' => [ 'count', 'addedtitle' ] } ); lives_ok(sub { $rs->first->get_column('count') }, 'multiple +select/+as columns, 1st rscolumn present'); lives_ok(sub { $rs->first->get_column('addedtitle') }, 'multiple +select/+as columns, 2nd rscolumn present'); $rs = $schema->resultset('CD')->search({}, { '+select' => [ \ 'COUNT(*)', 'title' ], '+as' => [ 'count', 'addedtitle' ] } )->search({}, { '+select' => 'title', '+as' => 'addedtitle2' } ); lives_ok(sub { $rs->first->get_column('count') }, '+select/+as chained search 1st rscolumn present'); lives_ok(sub { $rs->first->get_column('addedtitle') }, '+select/+as chained search 1st rscolumn present'); lives_ok(sub { $rs->first->get_column('addedtitle2') }, '+select/+as chained search 3rd rscolumn present'); # test the from search attribute (gets between the FROM and WHERE keywords, allows arbitrary subselects) # also shows that outer select attributes are ok (i.e. order_by) # # from doesn't seem to be useful without using a scalarref - there were no initial tests >:( # my $cds = $schema->resultset ('CD')->search ({}, { order_by => 'me.cdid'}); # make sure order is consistent cmp_ok ($cds->count, '>', 2, 'Initially populated with more than 2 CDs'); my $table = $cds->result_source->name; $table = $$table if ref $table eq 'SCALAR'; my $subsel = $cds->search ({}, { columns => [qw/cdid title/], from => \ "(SELECT cdid, title FROM $table LIMIT 2) me", }); is ($subsel->count, 2, 'Subselect correctly limited the rs to 2 cds'); is ($subsel->next->title, $cds->next->title, 'First CD title match'); is ($subsel->next->title, $cds->next->title, 'Second CD title match'); is($schema->resultset('CD')->current_source_alias, "me", '$rs->current_source_alias returns "me"'); $rs = $schema->resultset('CD')->search({}, { 'join' => 'artist', 'columns' => ['cdid', 'title', 'artist.name'], } ); is_same_sql_bind ( $rs->as_query, '(SELECT me.cdid, me.title, artist.name FROM cd me JOIN artist artist ON artist.artistid = me.artist)', [], 'Use of columns attribute results in proper sql' ); lives_ok(sub { $rs->first->get_column('cdid') }, 'columns 1st rscolumn present'); lives_ok(sub { $rs->first->get_column('title') }, 'columns 2nd rscolumn present'); lives_ok(sub { $rs->first->artist->get_column('name') }, 'columns 3rd rscolumn present'); $rs = $schema->resultset('CD')->search({}, { 'join' => 'artist', '+columns' => ['cdid', 'title', 'artist.name'], } ); is_same_sql_bind ( $rs->as_query, '(SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track, artist.name FROM cd me JOIN artist artist ON artist.artistid = me.artist)', [], 'Use of columns attribute results in proper sql' ); lives_ok(sub { $rs->first->get_column('cdid') }, 'columns 1st rscolumn present'); lives_ok(sub { $rs->first->get_column('title') }, 'columns 2nd rscolumn present'); lives_ok(sub { $rs->first->artist->get_column('name') }, 'columns 3rd rscolumn present'); $rs = $schema->resultset('CD')->search({'tracks.position' => { -in => [2] } }, { join => 'tracks', columns => [qw/me.cdid me.title/], '+select' => ['tracks.position'], '+as' => ['track_position'], # get a hashref of CD1 only (the first with a second track) result_class => 'DBIx::Class::ResultClass::HashRefInflator', order_by => 'cdid', rows => 1, } ); is_deeply ( $rs->single, { cdid => 1, track_position => 2, title => 'Spoonful of bees', }, 'limited prefetch via column works on a multi-relationship', ); my $sub_rs = $rs->search ({}, { columns => [qw/artist tracks.trackid/], # columns should not be merged but override $rs columns '+select' => ['tracks.title'], '+as' => ['tracks.title'], } ); is_deeply( $sub_rs->single, { artist => 1, tracks => { title => 'Apiary', trackid => 17, }, }, 'columns/select/as fold properly on sub-searches', ); # *very* esoteric use-case, yet valid (the "empty" object should not be undef): $rs = $schema->resultset('Artist'); $rs->create({ artistid => 69, name => 'Ranetki' }); my $relations_or_1_count = $rs->search_related('cds')->count + $rs->search({ 'cds.cdid' => undef }, { join => 'cds' })->count ; my $weird_rs = $rs->search({}, { order_by => { -desc => [ 'me.artistid', 'cds.cdid' ] }, columns => [{ cd_title => 'cds.title', cd_year => 'cds.year' }], join => 'cds', }); my $weird_rs_hri = $weird_rs->search({}, { result_class => 'DBIx::Class::ResultClass::HashRefInflator' }); for my $rs ($weird_rs, $weird_rs_hri) { is ($rs->count, $relations_or_1_count, 'count on rhs data injection matches'); my @all; while (my $r = $rs->next) { push @all, $r; } is (scalar @all, $relations_or_1_count, 'object count on rhs data injection matches'); is_deeply ( ( $rs->result_class eq 'DBIx::Class::ResultClass::HashRefInflator' ? \@all : [ map { +{$_->get_columns} } @all ] ), [ { cd_title => undef, cd_year => undef, }, { cd_title => "Come Be Depressed With Us", cd_year => 1998, }, { cd_title => "Generic Manufactured Singles", cd_year => 2001, }, { cd_title => "Caterwaulin' Blues", cd_year => 1997, }, { cd_title => "Forkful of bees", cd_year => 2001, }, { cd_title => "Spoonful of bees", cd_year => 1999, }, ], 'Correct data retrieved' ); is_deeply( [ $rs->all ], \@all, '->all matches' ); } done_testing; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/100extra_source.t�������������������������������������������������������������0000644�0001750�0001750�00000004134�14240132261�016454� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Warn; use lib qw(t/lib); use DBICTest; { package DBICTest::ArtistRS; use strict; use warnings; use base qw/DBIx::Class::ResultSet/; } my $schema = DBICTest->init_schema(); my $artist_source = $schema->source('Artist'); my $new_source = DBIx::Class::ResultSource::Table->new({ %$artist_source, name => 'artist_preview', resultset_class => 'DBICTest::ArtistRS', _relationships => {}, # copying them as-is is bad taste }); $new_source->add_column('other_col' => { data_type => 'integer', default_value => 1 }); { $schema->register_extra_source( 'artist->extra' => $new_source ); my $primary_source = $schema->source('DBICTest::Artist'); is($primary_source->source_name, 'Artist', 'original source still primary source'); ok(! $primary_source->has_column('other_col'), 'column definition did not leak to original source'); isa_ok($schema->resultset ('artist->extra'), 'DBICTest::ArtistRS'); } warnings_are (sub { my $source = $schema->source('DBICTest::Artist'); $schema->register_source($source->source_name, $source); }, [], 're-registering an existing source under the same name causes no warnings' ); warnings_like ( sub { my $new_source_name = 'Artist->preview(artist_preview)'; $schema->register_source( $new_source_name => $new_source ); my $primary_source = $schema->source('DBICTest::Artist'); is($primary_source->source_name, $new_source_name, 'new source is primary source'); ok($primary_source->has_column('other_col'), 'column correctly defined on new source'); isa_ok ($schema->resultset ($new_source_name), 'DBICTest::ArtistRS'); my $original_source = $schema->source('Artist'); ok(! $original_source->has_column('other_col'), 'column definition did not leak to original source'); isa_ok ($original_source->resultset, 'DBIx::Class::ResultSet'); isa_ok ($schema->resultset('Artist'), 'DBIx::Class::ResultSet'); }, [ qr/DBICTest::Artist already had a registered source which was replaced by this call/ ], 'registering source to an existing result warns' ); done_testing; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/00describe_environment.t������������������������������������������������������0000644�0001750�0001750�00000042617�14240132261�020104� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������### ### This version is rather 5.8-centric, because DBIC itself is 5.8 ### It certainly can be rewritten to degrade well on 5.6 ### # Very important to grab the snapshot early, as we will be reporting # the INC indices from the POV of whoever ran the script, *NOT* from # the POV of the internals my @initial_INC; BEGIN { @initial_INC = @INC; } BEGIN { local @INC = ( 't/lib', @INC ); if ( "$]" < 5.010) { # Pre-5.10 perls pollute %INC on unsuccesfull module # require, making it appear as if the module is already # loaded on subsequent require()s # Can't seem to find the exact RT/perldelta entry # # The reason we can't just use a sane, clean loader, is because # if a Module require()s another module the %INC will still # get filled with crap and we are back to square one. A global # fix is really the only way for this test, as we try to load # each available module separately, and have no control (nor # knowledge) over their common dependencies. # # we want to do this here, in the very beginning, before even # warnings/strict are loaded require DBICTest::Util::OverrideRequire; DBICTest::Util::OverrideRequire::override_global_require( sub { my $res = eval { $_[0]->() }; if ($@ ne '') { delete $INC{$_[1]}; die $@; } return $res; } ); } require DBICTest::RunMode; require DBICTest::Util; } use strict; use warnings; use Test::More 'no_plan'; # Things happen... unfortunately $SIG{__DIE__} = sub { die $_[0] unless defined $^S and ! $^S; diag "Something horrible happened while assembling the diag data\n$_[0]"; exit 0; }; use Config; use File::Find 'find'; use Digest::MD5 (); use Cwd 'abs_path'; use File::Spec; use List::Util 'max'; use ExtUtils::MakeMaker; use DBIx::Class::Optional::Dependencies; my $known_paths = { SA => { config_key => 'sitearch', }, SL => { config_key => 'sitelib', }, SS => { config_key => 'sitelib_stem', match_order => 1, }, SP => { config_key => 'siteprefix', match_order => 2, }, VA => { config_key => 'vendorarch', }, VL => { config_key => 'vendorlib', }, VS => { config_key => 'vendorlib_stem', match_order => 3, }, VP => { config_key => 'vendorprefix', match_order => 4, }, PA => { config_key => 'archlib', }, PL => { config_key => 'privlib', }, PP => { config_key => 'prefix', match_order => 5, }, BLA => { rel_path => './blib/arch', skip_unversioned_modules => 1, }, BLL => { rel_path => './blib/lib', skip_unversioned_modules => 1, }, INC => { rel_path => './inc', }, LIB => { rel_path => './lib', skip_unversioned_modules => 1, }, T => { rel_path => './t', skip_unversioned_modules => 1, }, XT => { rel_path => './xt', skip_unversioned_modules => 1, }, CWD => { rel_path => '.', }, HOME => { rel_path => '~', abs_unix_path => abs_unix_path ( eval { require File::HomeDir and File::HomeDir->my_home } || $ENV{USERPROFILE} || $ENV{HOME} || glob('~') ), }, }; for my $k (keys %$known_paths) { my $v = $known_paths->{$k}; # never use home as a found-in-dir marker - it is too broad # HOME is only used by the shortener $v->{marker} = $k unless $k eq 'HOME'; unless ( $v->{abs_unix_path} ) { if ( $v->{rel_path} ) { $v->{abs_unix_path} = abs_unix_path( $v->{rel_path} ); } elsif ( $Config{ $v->{config_key} || '' } ) { $v->{abs_unix_path} = abs_unix_path ( $Config{"$v->{config_key}exp"} || $Config{$v->{config_key}} ); } } delete $known_paths->{$k} unless $v->{abs_unix_path} and -d $v->{abs_unix_path}; } my $seen_markers = {}; # first run through lib/ and *try* to load anything we can find # within our own project find({ wanted => sub { -f $_ or return; $_ =~ m|lib/DBIx/Class/_TempExtlib| and return; # can't just `require $fn`, as we need %INC to be # populated properly my ($mod) = $_ =~ /^ lib [\/\\] (.+) \.pm $/x or return; try_module_require(join ('::', File::Spec->splitdir($mod)) ) }, no_chdir => 1, }, 'lib' ); # now run through OptDeps and attempt loading everything else # # some things needs to be sorted before other things # positive - load first # negative - load last my $load_weights = { # Make sure oracle is tried last - some clients (e.g. 10.2) have symbol # clashes with libssl, and will segfault everything coming after them "DBD::Oracle" => -999, }; my @known_modules = sort { ($load_weights->{$b}||0) <=> ($load_weights->{$a}||0) } qw( Data::Dumper DBD::SQLite ), map { $_ => 1 } map { keys %{ DBIx::Class::Optional::Dependencies->req_list_for($_) } } grep # some DBDs are notoriously problematic to load # hence only show stuff based on test_rdbms which will # take into account necessary ENVs { $_ !~ /^ (?: rdbms | dist )_ /x } keys %{DBIx::Class::Optional::Dependencies->req_group_list} ; try_module_require($_) for @known_modules; my $has_versionpm = eval { require version }; # At this point we've loaded everything we ever could, but some modules # (understandably) crapped out. For an even more thorough report, note # everthing present in @INC we excplicitly know about (via OptDeps) # *even though* it didn't load my $known_failed_loads; for my $mod (@known_modules) { my $inc_key = module_notional_filename($mod); next if defined $INC{$inc_key}; if (defined( my $idx = module_found_at_inc_index( $mod, \@INC ) ) ) { $known_failed_loads->{$mod} = abs_unix_path( "$INC[$idx]/$inc_key" ); } } my $perl = 'perl'; # This is a cool idea, but the line is too long even with shortening :( # #for my $i ( 1 .. $Config{config_argc} ) { # my $conf_arg = $Config{"config_arg$i"}; # $conf_arg =~ s! # \= (.+) # ! # '=' . shorten_fn($1) # !ex; # # $perl .= " $conf_arg"; #} my $interesting_modules = { # pseudo module $perl => { version => $], abs_unix_path => abs_unix_path($^X), } }; # drill through the *ENTIRE* symtable and build a map of interesting modules DBICTest::Util::visit_namespaces( action => sub { no strict 'refs'; my $pkg = shift; # keep going, but nothing to see here return 1 if $pkg eq 'main'; # private - not interested, including no further descent return 0 if $pkg =~ / (?: ^ | :: ) _ /x; my $inc_key = module_notional_filename($pkg); my $abs_unix_path = ( $INC{$inc_key} and -f $INC{$inc_key} and -r $INC{$inc_key} and abs_unix_path($INC{$inc_key}) ); # handle versions first (not interested in synthetic classes) if ( defined ${"${pkg}::VERSION"} and ${"${pkg}::VERSION"} !~ /\Qset by base.pm/ ) { # make sure a version can be extracted, be noisy when it doesn't work # do this even if we are throwing away the result below in lieu of EUMM my $mod_ver = eval { $pkg->VERSION }; if (my $err = $@) { $err =~ s/^/ /mg; say_err ( "Calling `$pkg->VERSION` resulted in an exception, which should never " . "happen - please file a bug with the distribution containing $pkg. " . "Complete exception text below:\n\n$err" ); } elsif( ! defined $mod_ver or ! length $mod_ver ) { my $ret = defined $mod_ver ? "the empty string ''" : "'undef'" ; say_err ( "Calling `$pkg->VERSION` returned $ret, even though \$${pkg}::VERSION " . "is defined, which should never happen - please file a bug with the " . "distribution containing $pkg." ); undef $mod_ver; } if ( $abs_unix_path and defined ( my $eumm_ver = eval { MM->parse_version( $abs_unix_path ) } ) ) { # can only run the check reliably if v.pm is there if ( $has_versionpm and defined $mod_ver and $eumm_ver ne $mod_ver and ( ( eval { version->parse( do { (my $v = $eumm_ver) =~ s/_//g; $v } ) } || 0 ) != ( eval { version->parse( do { (my $v = $mod_ver) =~ s/_//g; $v } ) } || 0 ) ) ) { say_err ( "Mismatch of versions '$mod_ver' and '$eumm_ver', obtained respectively " . "via `$pkg->VERSION` and parsing the version out of @{[ shorten_fn( $abs_unix_path ) ]} " . "with ExtUtils::MakeMaker\@@{[ ExtUtils::MakeMaker->VERSION ]}. " . "This should never happen - please check whether this is still present " . "in the latest version, and then file a bug with the distribution " . "containing $pkg." ); } $interesting_modules->{$pkg}{version} = $eumm_ver; } elsif( defined $mod_ver ) { $interesting_modules->{$pkg}{version} = $mod_ver; } } elsif ( $known_failed_loads->{$pkg} ) { $abs_unix_path = $known_failed_loads->{$pkg}; $interesting_modules->{$pkg}{version} = '!! LOAD FAIL !!'; } if ($abs_unix_path) { my ($marker, $initial_inc_idx); my $current_inc_idx = module_found_at_inc_index($pkg, \@INC); my $p = subpath_of_known_path( $abs_unix_path ); if ( defined $current_inc_idx and $p->{marker} and abs_unix_path($INC[$current_inc_idx]) eq $p->{abs_unix_path} ) { $marker = $p->{marker}; } elsif (defined ( $initial_inc_idx = module_found_at_inc_index($pkg, \@initial_INC) ) ) { $marker = "\$INC[$initial_inc_idx]"; } # we are only interested if there was a declared version already above # OR if the module came from somewhere other than skip_unversioned_modules if ( $marker and ( $interesting_modules->{$pkg} or !$p->{skip_unversioned_modules} ) ) { $interesting_modules->{$pkg}{source_marker} = $marker; $seen_markers->{$marker} = 1; } # at this point only fill in the path (md5 calc) IFF it is interesting # in any respect $interesting_modules->{$pkg}{abs_unix_path} = $abs_unix_path if $interesting_modules->{$pkg}; } 1; }); # compress identical versions sourced from ./blib, ./lib, ./t and ./xt # as close to the root of a namespace as we can purge_identically_versioned_submodules_with_markers([ map { ( $_->{skip_unversioned_modules} && $_->{marker} ) || () } values %$known_paths ]); ok 1, (scalar keys %$interesting_modules) . " distinctly versioned modules found"; # do not announce anything under ci - we are watching for STDERR silence exit 0 if DBICTest::RunMode->is_ci; # diag the result out my $max_ver_len = max map { length "$_" } ( 'xxx.yyyzzz_bbb', map { $_->{version} || '' } values %$interesting_modules ) ; my $max_marker_len = max map { length $_ } ( '$INC[999]', keys %$seen_markers ); # Note - must be less than 76 chars wide to account for the diag() prefix my $discl = <<'EOD'; List of loadable modules within both *OPTIONAL* and core dependency chains present on this system (modules sourced from ./blib, ./lib, ./t, and ./xt with versions identical to their parent namespace were omitted for brevity) *** Note that *MANY* of these modules will *NEVER* be loaded *** *** during normal operation of DBIx::Class *** EOD # pre-assemble everything and print it in one shot # makes it less likely for parallel test execution to insert bogus lines my $final_out = "\n$discl\n"; $final_out .= "\@INC at startup (does not reflect manipulation at runtime):\n"; my $in_inc_skip; for (0.. $#initial_INC) { my $shortname = shorten_fn( $initial_INC[$_] ); # when *to* print a line of INC if ( ! $ENV{AUTOMATED_TESTING} or @initial_INC < 11 or $seen_markers->{"\$INC[$_]"} or ! -e $shortname or ! File::Spec->file_name_is_absolute($shortname) ) { $in_inc_skip = 0; $final_out .= sprintf ( "% 3s: %s\n", $_, $shortname ); } elsif(! $in_inc_skip++) { $final_out .= " ...\n"; } } $final_out .= "\n"; if (my @seen_known_paths = grep { $known_paths->{$_} } keys %$seen_markers) { $final_out .= join "\n", 'Sourcing markers:', (map { sprintf "%*s: %s", $max_marker_len => $_->{marker}, ($_->{config_key} ? "\$Config{$_->{config_key}}" : "$_->{rel_path}/" ) } sort { !!$b->{config_key} cmp !!$a->{config_key} or ( $a->{marker}||'') cmp ($b->{marker}||'') } @{$known_paths}{@seen_known_paths} ), '', ''; } $final_out .= "=============================\n"; $final_out .= join "\n", (map { sprintf ( "%*s %*s %*s%s", $max_marker_len => $interesting_modules->{$_}{source_marker} || '', $max_ver_len => ( defined $interesting_modules->{$_}{version} ? $interesting_modules->{$_}{version} : '' ), -78 => $_, ($interesting_modules->{$_}{abs_unix_path} ? " [ MD5: @{[ get_md5( $interesting_modules->{$_}{abs_unix_path} ) ]} ]" : "! -f \$INC{'@{[ module_notional_filename($_) ]}'}" ), ) } sort { lc($a) cmp lc($b) } keys %$interesting_modules ), ''; $final_out .= "=============================\n$discl\n\n"; diag $final_out; # *very* large printouts may not finish flushing before the test exits # injecting a <testname> ... ok in the middle of the diag # http://www.cpantesters.org/cpan/report/fbdac74c-35ca-11e6-ab41-c893a58a4b8c select( undef, undef, undef, 0.2 ); exit 0; sub say_err { print STDERR "\n", @_, "\n\n" }; # do !!!NOT!!! use Module::Runtime's require_module - it breaks CORE::require sub try_module_require { # trap deprecation warnings and whatnot local $SIG{__WARN__} = sub {}; local $@; eval "require $_[0]"; } sub abs_unix_path { return '' unless ( defined $_[0] and ( -e $_[0] or File::Spec->file_name_is_absolute($_[0]) ) ); # File::Spec's rel2abs does not resolve symlinks # we *need* to look at the filesystem to be sure # # But looking at the FS for non-existing basenames *may* # throw on some OSes so be extra paranoid: # http://www.cpantesters.org/cpan/report/26a6e42f-6c23-1014-b7dd-5cd275d8a230 # my $abs_fn = eval { abs_path($_[0]) } || ''; if ( $abs_fn and $^O eq 'MSWin32' ) { # sometimes we can get a short/longname mix, normalize everything to longnames $abs_fn = Win32::GetLongPathName($abs_fn) if -e $abs_fn; # Fixup (native) slashes in Config not matching (unixy) slashes in INC $abs_fn =~ s|\\|/|g; } $abs_fn; } sub shorten_fn { my $fn = shift; my $abs_fn = abs_unix_path($fn); if ($abs_fn and my $p = subpath_of_known_path( $fn ) ) { $abs_fn =~ s| (?<! / ) $|/|x if -d $abs_fn; if ($p->{rel_path}) { $abs_fn =~ s!\Q$p->{abs_unix_path}!$p->{rel_path}! and return $abs_fn; } elsif ($p->{config_key}) { $abs_fn =~ s!\Q$p->{abs_unix_path}!<<$p->{marker}>>! and $seen_markers->{$p->{marker}} = 1 and return $abs_fn; } } # we got so far - not a known path # return the unixified version it if was absolute, leave as-is otherwise my $rv = ( $abs_fn and File::Spec->file_name_is_absolute( $fn ) ) ? $abs_fn : $fn ; $rv = "( ! -e ) $rv" unless -e $rv; return $rv; } sub subpath_of_known_path { my $abs_fn = abs_unix_path( $_[0] ) or return ''; for my $p ( sort { length( $b->{abs_unix_path} ) <=> length( $a->{abs_unix_path} ) or ( $a->{match_order} || 0 ) <=> ( $b->{match_order} || 0 ) } values %$known_paths ) { # run through the matcher twice - first always append a / # then try without # important to avoid false positives for my $suff ( '/', '' ) { return { %$p } if 0 == index( $abs_fn, "$p->{abs_unix_path}$suff" ); } } } sub module_found_at_inc_index { my ($mod, $inc_dirs) = @_; return undef unless @$inc_dirs; my $fn = module_notional_filename($mod); # trust INC if it specifies an existing path if( -f ( my $existing_path = abs_unix_path( $INC{$fn} ) ) ) { for my $i ( 0 .. $#$inc_dirs ) { # searching from here on out won't mean anything # FIXME - there is actually a way to interrogate this safely, but # that's a fight for another day return undef if length ref $inc_dirs->[$i]; return $i if 0 == index( $existing_path, abs_unix_path( $inc_dirs->[$i] ) . '/' ); } } for my $i ( 0 .. $#$inc_dirs ) { if ( -d $inc_dirs->[$i] and -f "$inc_dirs->[$i]/$fn" and -r "$inc_dirs->[$i]/$fn" ) { return $i; } } return undef; } sub purge_identically_versioned_submodules_with_markers { my $markers = shift; return unless @$markers; for my $mod ( sort { length($b) <=> length($a) } keys %$interesting_modules ) { next unless defined $interesting_modules->{$mod}{version}; my $marker = $interesting_modules->{$mod}{source_marker} or next; next unless grep { $marker eq $_ } @$markers; my $parent = $mod; while ( $parent =~ s/ :: (?: . (?! :: ) )+ $ //x ) { $interesting_modules->{$parent} and ($interesting_modules->{$parent}{version}||'') eq $interesting_modules->{$mod}{version} and ($interesting_modules->{$parent}{source_marker}||'') eq $interesting_modules->{$mod}{source_marker} and delete $interesting_modules->{$mod} and last } } } sub module_notional_filename { (my $fn = $_[0] . '.pm') =~ s|::|/|g; $fn; } sub get_md5 { # we already checked for -r/-f, just bail if can't open open my $fh, '<:raw', $_[0] or return ''; Digest::MD5->new->addfile($fh)->hexdigest; } �����������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/39load_namespaces_stress.t����������������������������������������������������0000644�0001750�0001750�00000002163�14240132261�020425� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Time::HiRes qw/gettimeofday/; use lib qw(t/lib); use DBICTest; # do not remove even though it is not used our $src_count = 100; for (1 .. $src_count) { eval <<EOM or die $@; package DBICTest::NS::Stress::Schema::Result::T$_; use base qw/DBIx::Class::Core/; __PACKAGE__->table($_); __PACKAGE__->add_columns ( id => { data_type => 'integer', is_auto_increment => 1 }, data => { data_type => 'varchar', size => 255 }, ); __PACKAGE__->set_primary_key('id'); __PACKAGE__->add_unique_constraint(['data']); EOM } { package DBICTest::NS::Stress::Schema; use base qw/DBIx::Class::Schema/; sub _findallmod { return $_[1] eq ( __PACKAGE__ . '::Result' ) ? ( map { __PACKAGE__ . "::Result::T$_" } 1 .. $::src_count ) : () ; } } is (DBICTest::NS::Stress::Schema->sources, 0, 'Start with no sources'); note gettimeofday . ":\tload_namespaces start"; DBICTest::NS::Stress::Schema->load_namespaces; note gettimeofday . ":\tload_namespaces finished"; is (DBICTest::NS::Stress::Schema->sources, $src_count, 'All sources attached'); done_testing; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/46where_attribute.t�����������������������������������������������������������0000644�0001750�0001750�00000010466�14240132261�017104� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Warn; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); # select from a class with resultset_attributes my $resultset = $schema->resultset('BooksInLibrary'); is($resultset, 3, "select from a class with resultset_attributes okay"); # now test out selects through a resultset my $owner = $schema->resultset('Owners')->find({name => "Newton"}); my $programming_perl = $owner->books->find_or_create({ title => "Programming Perl" }); is($programming_perl->id, 1, 'select from a resultset with find_or_create for existing entry ok'); # and inserts? my $see_spot; $see_spot = eval { warnings_exist { $owner->books->find_or_create({ title => "See Spot Run" }) } qr/Missing value for primary key column 'id' on BooksInLibrary - perhaps you forgot to set its 'is_auto_increment'/; }; is ($@, '', 'find_or_create on resultset with attribute for non-existent entry did not throw'); ok(defined $see_spot, 'successfully did insert on resultset with attribute for non-existent entry'); my $see_spot_rs = $owner->books->search({ title => "See Spot Run" }); eval { $see_spot_rs->delete(); }; if ($@) { print $@ } ok(!$@, 'delete on resultset with attribute did not throw'); is($see_spot_rs->count(), 0, 'delete on resultset with attributes succeeded'); # many_to_many tests my $collection = $schema->resultset('Collection')->search({collectionid => 1}); my $pointy_objects = $collection->search_related('collection_object')->search_related('object', { type => "pointy"}); my $pointy_count = $pointy_objects->count(); is($pointy_count, 2, 'many_to_many explicit query through linking table with query starting from resultset count correct'); $collection = $schema->resultset('Collection')->find(1); $pointy_objects = $collection->search_related('collection_object')->search_related('object', { type => "pointy"}); $pointy_count = $pointy_objects->count(); is($pointy_count, 2, 'many_to_many explicit query through linking table with query starting from row count correct'); # use where on many_to_many query $collection = $schema->resultset('Collection')->find(1); $pointy_objects = $collection->search_related('collection_object')->search_related('object', {}, { where => { 'object.type' => 'pointy' } }); is($pointy_objects->count(), 2, 'many_to_many explicit query through linking table with where starting from row count correct'); $collection = $schema->resultset('Collection')->find(1); $pointy_objects = $collection->pointy_objects(); $pointy_count = $pointy_objects->count(); is($pointy_count, 2, 'many_to_many resultset with where in resultset attrs count correct'); # add_to_$rel on many_to_many with where containing a required field eval {$collection->add_to_pointy_objects({ value => "Nail" }) }; if ($@) { print $@ } ok( !$@, 'many_to_many add_to_$rel($hash) with where in relationship attrs did not throw'); is($pointy_objects->count, $pointy_count+1, 'many_to_many add_to_$rel($hash) with where in relationship attrs count correct'); $pointy_count = $pointy_objects->count(); my $pen = $schema->resultset('TypedObject')->create({ value => "Pen", type => "pointy"}); eval {$collection->add_to_pointy_objects($pen)}; if ($@) { print $@ } ok( !$@, 'many_to_many add_to_$rel($object) with where in relationship attrs did not throw'); is($pointy_objects->count, $pointy_count+1, 'many_to_many add_to_$rel($object) with where in relationship attrs count correct'); $pointy_count = $pointy_objects->count(); my $round_objects = $collection->round_objects(); my $round_count = $round_objects->count(); eval {$collection->add_to_objects({ value => "Wheel", type => "round" })}; if ($@) { print $@ } ok( !$@, 'many_to_many add_to_$rel($hash) did not throw'); is($round_objects->count, $round_count+1, 'many_to_many add_to_$rel($hash) count correct'); # test set_$rel $round_count = $round_objects->count(); $pointy_count = $pointy_objects->count(); my @all_pointy_objects = $pointy_objects->all; # doing a set on pointy objects with its current set should not change any counts eval {$collection->set_pointy_objects(\@all_pointy_objects)}; if ($@) { print $@ } ok( !$@, 'many_to_many set_$rel(\@objects) did not throw'); is($pointy_objects->count, $pointy_count, 'many_to_many set_$rel($hash) count correct'); is($round_objects->count, $round_count, 'many_to_many set_$rel($hash) other rel count correct'); done_testing; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/752sqlite.t�������������������������������������������������������������������0000644�0001750�0001750�00000023621�14240132261�015271� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use Test::Warn; use Time::HiRes 'time'; use Math::BigInt; use lib qw(t/lib); use DBICTest; use DBIx::Class::_Util qw( sigwarn_silencer modver_gt_or_eq modver_gt_or_eq_and_lt ); # make one deploy() round before we load anything else - need this in order # to prime SQLT if we are using it (deep depchain is deep) DBICTest->init_schema( no_populate => 1 ); # check that we work somewhat OK with braindead SQLite transaction handling # # As per https://metacpan.org/source/ADAMK/DBD-SQLite-1.37/lib/DBD/SQLite.pm#L921 # SQLite does *not* try to synchronize # # However DBD::SQLite 1.38_02 seems to fix this, with an accompanying test: # https://metacpan.org/source/ADAMK/DBD-SQLite-1.38_02/t/54_literal_txn.t my $lit_txn_todo = modver_gt_or_eq('DBD::SQLite', '1.38_02') ? undef : "DBD::SQLite before 1.38_02 is retarded wrt detecting literal BEGIN/COMMIT statements" ; for my $prefix_comment (qw/Begin_only Commit_only Begin_and_Commit/) { note "Testing with comment prefixes on $prefix_comment"; # FIXME warning won't help us for the time being # perhaps when (if ever) DBD::SQLite gets fixed, # we can do something extra here local $SIG{__WARN__} = sigwarn_silencer( qr/Internal transaction state .+? does not seem to match/ ) if ( $lit_txn_todo && !$ENV{TEST_VERBOSE} ); my ($c_begin, $c_commit) = map { $prefix_comment =~ $_ ? 1 : 0 } (qr/Begin/, qr/Commit/); my $schema = DBICTest->init_schema( no_deploy => 1 ); my $ars = $schema->resultset('Artist'); ok (! $schema->storage->connected, 'No connection yet'); $schema->storage->dbh->do(<<'DDL'); CREATE TABLE artist ( artistid INTEGER PRIMARY KEY NOT NULL, name varchar(100), rank integer DEFAULT 13, charfield char(10) NULL ); DDL my $artist = $ars->create({ name => 'Artist_' . time() }); is ($ars->count, 1, 'Inserted artist ' . $artist->name); ok ($schema->storage->connected, 'Connected'); ok ($schema->storage->_dbh->{AutoCommit}, 'DBD not in txn yet'); $schema->storage->dbh->do(join "\n", $c_begin ? '-- comment' : (), 'BEGIN TRANSACTION' ); ok ($schema->storage->connected, 'Still connected'); { local $TODO = $lit_txn_todo if $c_begin; ok (! $schema->storage->_dbh->{AutoCommit}, "DBD aware of txn begin with comments on $prefix_comment"); } $schema->storage->dbh->do(join "\n", $c_commit ? '-- comment' : (), 'COMMIT' ); ok ($schema->storage->connected, 'Still connected'); { local $TODO = $lit_txn_todo if $c_commit and ! $c_begin; ok ($schema->storage->_dbh->{AutoCommit}, "DBD aware txn ended with comments on $prefix_comment"); } is ($ars->count, 1, 'Inserted artists still there'); { # this never worked in the 1st place local $TODO = $lit_txn_todo if ! $c_begin and $c_commit; # odd argument passing, because such nested crefs leak on 5.8 lives_ok { $schema->storage->txn_do (sub { ok ($_[0]->find({ name => $_[1] }), "Artist still where we left it after cycle with comments on $prefix_comment"); }, $ars, $artist->name ); } "Succesfull transaction with comments on $prefix_comment"; } } # test blank begin/svp/commit/begin cycle # # need to prime this for exotic testing scenarios # before testing for lack of warnings modver_gt_or_eq('DBD::SQLite', '1.33'); warnings_are { my $schema = DBICTest->init_schema( no_populate => 1 ); my $rs = $schema->resultset('Artist'); is ($rs->count, 0, 'Start with empty table'); for my $do_commit (1, 0) { $schema->txn_begin; $schema->svp_begin; $schema->svp_rollback; $schema->svp_begin; $schema->svp_rollback; $schema->svp_release; $schema->svp_begin; $schema->txn_rollback; $schema->txn_begin; $schema->svp_begin; $schema->svp_rollback; $schema->svp_begin; $schema->svp_rollback; $schema->svp_release; $schema->svp_begin; $do_commit ? $schema->txn_commit : $schema->txn_rollback; is_deeply $schema->storage->savepoints, [], 'Savepoint names cleared away' } $schema->txn_do(sub { ok (1, 'all seems fine'); }); } [], 'No warnings emitted'; my $schema = DBICTest->init_schema(); # make sure the side-effects of RT#67581 do not result in data loss my $row; warnings_exist { $row = $schema->resultset('Artist')->create ({ name => 'alpha rank', rank => 'abc' }) } [qr/Non-integer value supplied for column 'rank' despite the integer datatype/], 'proper warning on string insertion into an numeric column' ; $row->discard_changes; is ($row->rank, 'abc', 'proper rank inserted into database'); # and make sure we do not lose actual bigints SKIP: { skip "Not testing bigint handling on known broken DBD::SQLite trial versions", 1 if( modver_gt_or_eq('DBD::SQLite', '1.45') and ! modver_gt_or_eq('DBD::SQLite', '1.45_03') ); { package DBICTest::BigIntArtist; use base 'DBICTest::Schema::Artist'; __PACKAGE__->table('artist'); __PACKAGE__->add_column(bigint => { data_type => 'bigint' }); } $schema->register_class(BigIntArtist => 'DBICTest::BigIntArtist'); $schema->storage->dbh_do(sub { $_[1]->do('ALTER TABLE artist ADD COLUMN bigint BIGINT'); }); my $sqlite_broken_bigint = modver_gt_or_eq_and_lt( 'DBD::SQLite', '1.34', '1.37' ); # 63 bit integer my $many_bits = (Math::BigInt->new(2) ** 62); # test upper/lower boundaries for sqlite and some values inbetween # range is -(2**63) .. 2**63 - 1 # # Not testing -0 - it seems to overflow to ~0 on some combinations, # thus not triggering the >32 bit guards # interesting read: https://en.wikipedia.org/wiki/Signed_zero#Representations for my $bi ( qw( -2 -1 0 +0 1 2 -9223372036854775807 -8694837494948124658 -6848440844435891639 -5664812265578554454 -5380388020020483213 -2564279463598428141 2442753333597784273 4790993557925631491 6773854980030157393 7627910776496326154 8297530189347439311 9223372036854775806 9223372036854775807 4294967295 4294967296 -4294967296 -4294967295 -4294967294 -2147483649 -2147483648 -2147483647 -2147483646 2147483646 2147483647 ), # these values cause exceptions even with all workarounds in place on these # fucked DBD::SQLite versions *regardless* of ivsize >.< $sqlite_broken_bigint ? () : ( '2147483648', '2147483649' ) , # with newer compilers ( gcc 4.9+ ) older DBD::SQLite does not # play well with the "Most Negative Number" modver_gt_or_eq( 'DBD::SQLite', '1.33' ) ? ( '-9223372036854775808' ) : () , ) { # unsigned 32 bit ints have a range of −2,147,483,648 to 2,147,483,647 # alternatively expressed as the hexadecimal numbers below # the comparison math will come out right regardless of ivsize, since # we are operating within 31 bits # P.S. 31 because one bit is lost for the sign my $v_bits = ($bi > 0x7fff_ffff || $bi < -0x8000_0000) ? 64 : 32; my $v_desc = sprintf '%s (%d bit signed int)', $bi, $v_bits; my @w; local $SIG{__WARN__} = sub { if ($_[0] =~ /datatype mismatch/) { push @w, @_; } elsif ($_[0] =~ /An integer value occupying more than 32 bits was supplied .+ can not bind properly so DBIC will treat it as a string instead/ ) { # do nothing, this warning will pop up here and there depending on # DBD/bitness combination # we don't want to test for it explicitly, we are just interested # in the results matching at the end } else { warn @_; } }; # some combinations of SQLite 1.35 and older 5.8 faimly is wonky # instead of a warning we get a full exception. Sod it eval { $row = $schema->resultset('BigIntArtist')->create({ bigint => $bi }); } or do { fail("Exception on inserting $v_desc: $@") unless $sqlite_broken_bigint; next; }; # explicitly using eq, to make sure we did not nummify the argument # which can be an issue on 32 bit ivsize cmp_ok ($row->bigint, 'eq', $bi, "value in object correct ($v_desc)"); $row->discard_changes; cmp_ok ( $row->bigint, # the test will not pass an == if we are running under 32 bit ivsize # use 'eq' on the numified (and possibly "scientificied") returned value (DBIx::Class::_ENV_::IV_SIZE < 8 and $v_bits > 32) ? 'eq' : '==', # in 1.37 DBD::SQLite switched to proper losless representation of bigints # regardless of ivize # before this use 'eq' (from above) on the numified (and possibly # "scientificied") returned value (DBIx::Class::_ENV_::IV_SIZE < 8 and ! modver_gt_or_eq('DBD::SQLite', '1.37')) ? $bi+0 : $bi, "value in database correct ($v_desc)" ); # FIXME - temporary smoke-only escape SKIP: { skip 'Potential for false negatives - investigation pending', 1 if DBICTest::RunMode->is_plain; # check if math works # start by adding/subtracting a 50 bit integer, and then divide by 2 for good measure my ($sqlop, $expect) = $bi < 0 ? ( '(bigint + ? )', ($bi + $many_bits) ) : ( '(bigint - ? )', ($bi - $many_bits) ) ; $expect = ($expect + ($expect % 2)) / 2; # read https://en.wikipedia.org/wiki/Modulo_operation#Common_pitfalls # and check the tables on the right side of the article for an # enlightening journey on why a mere bigint % 2 won't work $sqlop = "( $sqlop + ( ((bigint % 2)+2)%2 ) ) / 2"; for my $dtype (undef, \'int', \'bigint') { # FIXME - the double-load should not be needed # will fix in the future $row->update({ bigint => $bi }); $row->discard_changes; $row->update({ bigint => \[ $sqlop, [ $dtype => $many_bits ] ] }); $row->discard_changes; # can't use cmp_ok - will not engage the M::BI overload of $many_bits ok ( $row->bigint == (DBIx::Class::_ENV_::IV_SIZE < 8 and ! modver_gt_or_eq('DBD::SQLite', '1.37')) ? $expect->bstr + 0 : $expect , "simple integer math with@{[ $dtype ? '' : 'out' ]} bindtype in database correct (base $v_desc)") or diag sprintf '%s != %s', $row->bigint, $expect; } # end of fixme } is_deeply (\@w, [], "No mismatch warnings on bigint operations ($v_desc)" ); }} done_testing; # vim:sts=2 sw=2: ���������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/19retrieve_on_insert.t��������������������������������������������������������0000644�0001750�0001750�00000001161�14240132261�017604� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); $schema->storage->sql_maker->quote_char('"'); my $rs = $schema->resultset ('Artist'); my $obj; lives_ok { $obj = $rs->create ({ name => 'artistA' }) } 'Default insert successful'; is ($obj->rank, undef, 'Without retrieve_on_insert, check rank'); $rs->result_source->add_columns( '+rank' => { retrieve_on_insert => 1 } ); lives_ok { $obj = $rs->create ({ name => 'artistB' }) } 'Default insert successful'; is ($obj->rank, 13, 'With retrieve_on_insert, check rank'); done_testing; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/39load_namespaces_exception.t�������������������������������������������������0000644�0001750�0001750�00000000633�14240132261�021100� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; # do not remove even though it is not used plan tests => 1; eval { package DBICNSTest; use base qw/DBIx::Class::Schema/; __PACKAGE__->load_namespaces( result_namespace => 'Bogus', resultset_namespace => 'RSet', ); }; like ($@, qr/are you sure this is a real Result Class/, 'Clear exception thrown'); �����������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/93single_accessor_object.t����������������������������������������������������0000644�0001750�0001750�00000004235�14240132261�020377� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use lib qw(t/lib); use DBICTest; # Test various uses of passing an object to find, create, and update on a single # rel accessor { my $schema = DBICTest->init_schema(); my $artist = $schema->resultset("Artist")->find(1); my $cd = $schema->resultset("CD")->find_or_create({ artist => $artist, title => "Object on a might_have", year => 2006, }); ok(defined $cd, 'created a CD'); is($cd->get_column('artist'), $artist->id, 'artist matches CD'); my $liner_notes = $schema->resultset("LinerNotes")->find_or_create({ cd => $cd, notes => "Creating using an object on a might_have is helpful.", }); ok(defined $liner_notes, 'created liner notes'); is($liner_notes->liner_id, $cd->cdid, 'liner notes matches CD'); is($liner_notes->notes, "Creating using an object on a might_have is helpful.", 'liner notes are correct'); my $track = $cd->tracks->find_or_create({ position => 127, title => 'Single Accessor' }); is($track->get_column('cd'), $cd->cdid, 'track matches CD before update'); my $another_cd = $schema->resultset("CD")->find(5); $track->update({ disc => $another_cd }); is($track->get_column('cd'), $another_cd->cdid, 'track matches another CD after update'); } { my $schema = DBICTest->init_schema(); my $artist = $schema->resultset('Artist')->create({ artistid => 666, name => 'bad religion' }); my $cd = $schema->resultset('CD')->create({ cdid => 187, artist => 1, title => 'how could hell be any worse?', year => 1982, genreid => undef }); ok(!defined($cd->get_column('genreid')), 'genreid is NULL'); #no accessor was defined for this column ok(!defined($cd->genre), 'genre accessor returns undef'); } { my $schema = DBICTest->init_schema(); my $artist = $schema->resultset('Artist')->create({ artistid => 666, name => 'bad religion' }); my $genre = $schema->resultset('Genre')->create({ genreid => 88, name => 'disco' }); my $cd = $schema->resultset('CD')->create({ cdid => 187, artist => 1, title => 'how could hell be any worse?', year => 1982 }); dies_ok { $cd->genre } 'genre accessor throws without column'; } done_testing; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/106dbic_carp.t����������������������������������������������������������������0000644�0001750�0001750�00000003247�14240132261�015671� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; # without this the stacktrace of $schema will be activated BEGIN { $ENV{DBIC_TRACE} = 0 } use Test::More; use Test::Warn; use Test::Exception; use lib 't/lib'; use DBICTest; use DBIx::Class::Carp; { sub DBICTest::DBICCarp::frobnicate { DBICTest::DBICCarp::branch1(); DBICTest::DBICCarp::branch2(); } sub DBICTest::DBICCarp::branch1 { carp_once 'carp1' } sub DBICTest::DBICCarp::branch2 { carp_once 'carp2' } warnings_exist { DBICTest::DBICCarp::frobnicate(); } [ qr/carp1/, qr/carp2/, ], 'expected warnings from carp_once'; } { { package DBICTest::DBICCarp::Exempt; use DBIx::Class::Carp; sub _skip_namespace_frames { qr/^DBICTest::DBICCarp::Exempt/ } sub thrower { sub { DBICTest->init_schema(no_deploy => 1)->storage->dbh_do(sub { shift->throw_exception('time to die'); }) }->(); } sub dcaller { sub { thrower(); }->(); } sub warner { eval { sub { eval { carp ('time to warn') } }->() } } sub wcaller { warner(); } } # the __LINE__ relationship below is important - do not reformat throws_ok { DBICTest::DBICCarp::Exempt::dcaller() } qr/\QDBICTest::DBICCarp::Exempt::thrower(): time to die at @{[ __FILE__ ]} line @{[ __LINE__ - 1 ]}\E$/, 'Expected exception callsite and originator' ; # the __LINE__ relationship below is important - do not reformat warnings_like { DBICTest::DBICCarp::Exempt::wcaller() } qr/\QDBICTest::DBICCarp::Exempt::warner(): time to warn at @{[ __FILE__ ]} line @{[ __LINE__ - 1 ]}\E$/, ; } done_testing; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/33exception_wrap.t������������������������������������������������������������0000644�0001750�0001750�00000000717�14240132261�016730� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema; throws_ok (sub { $schema->txn_do (sub { die 'lol' } ); }, 'DBIx::Class::Exception', 'a DBIC::Exception object thrown'); throws_ok (sub { $schema->txn_do (sub { die [qw/lol wut/] }); }, qr/ARRAY\(0x/, 'An arrayref thrown'); is_deeply ( $@, [qw/ lol wut /], 'Exception-arrayref contents preserved', ); done_testing; �������������������������������������������������DBIx-Class-0.082843/t/99dbic_sqlt_parser.t����������������������������������������������������������0000644�0001750�0001750�00000020733�14240132261�017235� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Warn; use Test::Exception; use Scalar::Util (); use lib qw(t/lib); use DBICTest; use DBIx::Class::_Util 'sigwarn_silencer'; BEGIN { require DBIx::Class; plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('deploy') unless DBIx::Class::Optional::Dependencies->req_ok_for ('deploy') } # Test for SQLT-related leaks { my $s = DBICTest::Schema->clone; my @schemas = ( create_schema ({ schema => $s }), create_schema ({ args => { parser_args => { dbic_schema => $s } } }), ); for my $parser_args_key (qw( DBIx::Class::Schema DBIx::Schema package )) { warnings_exist { push @schemas, create_schema({ args => { parser_args => { $parser_args_key => $s } } }); } qr/\Qparser_args => {\E.+?is deprecated.+\Q@{[__FILE__]}/, "deprecated crazy parser_arg '$parser_args_key' warned"; } Scalar::Util::weaken ($s); ok (!$s, 'Schema not leaked'); isa_ok ($_, 'SQL::Translator::Schema', "SQLT schema object $_ produced") for @schemas; } # make sure classname-style works lives_ok { isa_ok (create_schema ({ schema => 'DBICTest::Schema' }), 'SQL::Translator::Schema', 'SQLT schema object produced') }; # make sure a connected instance passed via $args does not get the $dbh improperly serialized SKIP: { # YAML is a build_requires dep of SQLT - it may or may not be here eval { require YAML } or skip "Test requires YAML.pm", 1; lives_ok { my $s = DBICTest->init_schema(no_populate => 1); ok ($s->storage->connected, '$schema instance connected'); # roundtrip through YAML my $yaml_rt_schema = SQL::Translator->new( parser => 'SQL::Translator::Parser::YAML' )->translate( data => SQL::Translator->new( parser_args => { dbic_schema => $s }, parser => 'SQL::Translator::Parser::DBIx::Class', producer => 'SQL::Translator::Producer::YAML', )->translate ); isa_ok ( $yaml_rt_schema, 'SQL::Translator::Schema', 'SQLT schema object produced after YAML roundtrip'); ok ($s->storage->connected, '$schema instance still connected'); } eval <<'EOE' or die $@; END { # we are in END - everything remains global # $^W = 1; # important, otherwise DBI won't trip the next fail() $SIG{__WARN__} = sub { fail "Unexpected global destruction warning" if $_[0] =~ /is not a DBI/; warn @_; }; } EOE } my $schema = DBICTest->init_schema( no_deploy => 1 ); # Dummy was yanked out by the sqlt hook test # CustomSql tests the horrific/deprecated ->name(\$sql) hack # YearXXXXCDs are views # my @sources = grep { $_ !~ /^ (?: Dummy | CustomSql | Year\d{4}CDs ) $/x } $schema->sources ; my $idx_exceptions = { 'Artwork' => -1, 'ForceForeign' => -1, 'LinerNotes' => -1, 'TwoKeys' => -1, # TwoKeys has the index turned off on the rel def }; { my $sqlt_schema = create_schema({ schema => $schema, args => { parser_args => { } } }); foreach my $source_name (@sources) { my $table = get_table($sqlt_schema, $schema, $source_name); my $fk_count = scalar(grep { $_->type eq 'FOREIGN KEY' } $table->get_constraints); $fk_count += $idx_exceptions->{$source_name} || 0; my @indices = $table->get_indices; my $index_count = scalar(@indices); is($index_count, $fk_count, "correct number of indices for $source_name with no args"); for my $index (@indices) { my $source = $schema->source($source_name); my $pk_test = join("\x00", $source->primary_columns); my $idx_test = join("\x00", $index->fields); isnt ( $pk_test, $idx_test, "no additional index for the primary columns exists in $source_name"); } } } { my $sqlt_schema = create_schema({ schema => $schema, args => { parser_args => { add_fk_index => 1 } } }); foreach my $source_name (@sources) { my $table = get_table($sqlt_schema, $schema, $source_name); my $fk_count = scalar(grep { $_->type eq 'FOREIGN KEY' } $table->get_constraints); $fk_count += $idx_exceptions->{$source_name} || 0; my @indices = $table->get_indices; my $index_count = scalar(@indices); is($index_count, $fk_count, "correct number of indices for $source_name with add_fk_index => 1"); } } { my $sqlt_schema = create_schema({ schema => $schema, args => { parser_args => { add_fk_index => 0 } } }); foreach my $source (@sources) { my $table = get_table($sqlt_schema, $schema, $source); my @indices = $table->get_indices; my $index_count = scalar(@indices); is($index_count, 0, "correct number of indices for $source with add_fk_index => 0"); } } { { package # hide from PAUSE DBICTest::Schema::NoViewDefinition; use base qw/DBICTest::BaseResult/; __PACKAGE__->table_class('DBIx::Class::ResultSource::View'); __PACKAGE__->table('noviewdefinition'); 1; } my $schema_invalid_view = $schema->clone; $schema_invalid_view->register_class('NoViewDefinition', 'DBICTest::Schema::NoViewDefinition'); throws_ok { create_schema({ schema => $schema_invalid_view }) } qr/view noviewdefinition is missing a view_definition/, 'parser detects views with a view_definition'; } lives_ok (sub { my $sqlt_schema = create_schema ({ schema => $schema, args => { parser_args => { sources => ['CD'] }, }, }); is_deeply ( [$sqlt_schema->get_tables ], ['cd'], 'sources limitng with relationships works', ); }); { package DBICTest::PartialSchema; use base qw/DBIx::Class::Schema/; __PACKAGE__->load_classes( { 'DBICTest::Schema' => [qw/ CD Track Tag Producer CD_to_Producer /]} ); } { my $partial_schema = DBICTest::PartialSchema->connect(DBICTest->_database); lives_ok (sub { my $sqlt_schema = do { local $SIG{__WARN__} = sigwarn_silencer( qr/Ignoring relationship .+ related resultsource .+ is not registered with this schema/ ); create_schema({ schema => $partial_schema }); }; my @tables = $sqlt_schema->get_tables; is_deeply ( [sort map { $_->name } @tables], [qw/cd cd_to_producer producer tags track/], 'partial dbic schema parsing ok', ); # the primary key is currently unnamed in sqlt - adding below my %constraints_for_table = ( producer => [qw/prod_name /], tags => [qw/tagid_cd tagid_cd_tag tags_fk_cd tags_tagid_tag tags_tagid_tag_cd /], track => [qw/track_cd_position track_cd_title track_fk_cd /], cd => [qw/cd_artist_title cd_fk_single_track /], cd_to_producer => [qw/cd_to_producer_fk_cd cd_to_producer_fk_producer /], ); for my $table (@tables) { my $tablename = $table->name; my @constraints = $table->get_constraints; is_deeply ( [ sort map { $_->name } @constraints ], # the primary key (present on all loaded tables) is currently named '' in sqlt # subject to future changes [ '', @{$constraints_for_table{$tablename}} ], "constraints of table '$tablename' ok", ); } }, 'partial schema tests successful'); } { my $cd_rsrc = $schema->source('CD'); $cd_rsrc->name(\'main.cd'); my $sqlt_schema = create_schema( { schema => $schema }, args => { ignore_constraint_names => 0, ignore_index_names => 0 } ); foreach my $source_name (qw(CD)) { my $table = get_table($sqlt_schema, $schema, $source_name); ok( !(grep {$_->name =~ m/main\./} $table->get_indices), 'indices have periods stripped out' ); ok( !(grep {$_->name =~ m/main\./} $table->get_constraints), 'constraints have periods stripped out' ); } } done_testing; sub create_schema { my $args = shift; my $additional_sqltargs = $args->{args} || {}; my $sqltargs = { add_drop_table => 1, ignore_constraint_names => 1, ignore_index_names => 1, %{$additional_sqltargs} }; my $sqlt = SQL::Translator->new( $sqltargs ); $sqlt->parser('SQL::Translator::Parser::DBIx::Class'); return $sqlt->translate( $args->{schema} ? ( data => $args->{schema} ) : () ) || die $sqlt->error; } sub get_table { my ($sqlt_schema, $schema, $source) = @_; my $table_name = $schema->source($source)->from; $table_name = $$table_name if ref $table_name; return $sqlt_schema->get_table($table_name); } �������������������������������������DBIx-Class-0.082843/t/zzzzzzz_authors.t�������������������������������������������������������������0000644�0001750�0001750�00000001234�14240132261�017100� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use warnings; use strict; use Test::More 'no_plan'; use lib 't/lib'; use DBICTest::RunMode; my $authorcount = scalar do { open (my $fh, '<', 'AUTHORS') or die "Unable to open AUTHORS - can't happen: $!\n"; map { chomp; ( ( ! $_ or $_ =~ /^\s*\#/ ) ? () : $_ ) } <$fh>; } or die "Known AUTHORS file seems empty... can't happen..."; # do not announce anything under ci - we are watching for STDERR silence diag <<EOD unless DBICTest::RunMode->is_ci; $authorcount contributors made this library what it is today Distinguished patrons: * ( 2014 ~ 2015 ) Henry Van Styn, creator of http://p3rl.org/RapidApp EOD # looks funny if we do it before stuff ok 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/78self_referencial.t����������������������������������������������������������0000644�0001750�0001750�00000002027�14240132261�017176� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); # this test will check to see if you can have 2 columns # in the same class pointing at the same other class # # example: # # +---------+ +--------------+ # | SelfRef | | SelfRefAlias | # +---------+ 1-M +--------------+ # | id |-------| self_ref | --+ # | name | | alias | --+ # +---------+ +--------------+ | # /|\ | # | | # +--------------------------------+ # # see http://use.perl.org/~LTjake/journal/24876 for the # issue with CDBI plan tests => 4; my $item = $schema->resultset("SelfRef")->find( 1 ); is( $item->name, 'First', 'proper start item' ); my @aliases = $item->aliases; is( scalar @aliases, 1, 'proper number of aliases' ); my $orig = $aliases[ 0 ]->self_ref; my $alias = $aliases[ 0 ]->alias; is( $orig->name, 'First', 'proper original' ); is( $alias->name, 'Second', 'proper alias' ); ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/zzzzzzz_sqlite_deadlock.t�����������������������������������������������������0000644�0001750�0001750�00000002110�14240132261�020534� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib 't/lib'; BEGIN { require DBICTest::RunMode; plan( skip_all => "Skipping test on plain module install" ) if DBICTest::RunMode->is_plain; } use Test::Exception; use DBICTest; use File::Temp (); plan tests => 2; my $wait_for = 120; # how many seconds to wait # don't lock anything - this is a tempfile anyway $ENV{DBICTEST_LOCK_HOLDER} = -1; for my $close (0,1) { my $tmp = File::Temp->new( UNLINK => 1, DIR => 't/var', SUFFIX => '.db', TEMPLATE => 'DBIxClass-XXXXXX', EXLOCK => 0, # important for BSD and derivatives ); my $tmp_fn = $tmp->filename; close $tmp if $close; local $SIG{ALRM} = sub { die sprintf ( "Timeout of %d seconds reached (tempfile still open: %s)", $wait_for, $close ? 'No' : 'Yes' )}; alarm $wait_for; lives_ok (sub { my $schema = DBICTest::Schema->connect ("DBI:SQLite:$tmp_fn"); $schema->storage->dbh_do(sub { $_[1]->do('PRAGMA synchronous = OFF') }); DBICTest->deploy_schema ($schema); DBICTest->populate_schema ($schema); }); alarm 0; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/746db2_400.t������������������������������������������������������������������0000644�0001750�0001750�00000004617�14240132261�015031� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use DBIx::Class::Optional::Dependencies (); use lib qw(t/lib); use DBICTest; plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_db2_400') unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_db2_400'); my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_DB2_400_${_}" } qw/DSN USER PASS/}; #warn "$dsn $user $pass"; # Probably best to pass the DBQ option in the DSN to specify a specific # libray. Something like: # DBICTEST_DB2_400_DSN='dbi:ODBC:dsn=MyAS400;DBQ=MYLIB' plan skip_all => 'Set $ENV{DBICTEST_DB2_400_DSN}, _USER and _PASS to run this test' unless ($dsn && $user); plan tests => 6; my $schema = DBICTest::Schema->connect($dsn, $user, $pass); my $dbh = $schema->storage->dbh; eval { $dbh->do("DROP TABLE artist") }; $dbh->do(<<''); CREATE TABLE artist ( artistid INTEGER GENERATED BY DEFAULT AS IDENTITY (START WITH 1, INCREMENT BY 1), name VARCHAR(255), rank INTEGER default 13 not null, charfield CHAR(10) ) # Just to test loading, already in Core $schema->class('Artist')->load_components('PK::Auto'); # test primary key handling my $new = $schema->resultset('Artist')->create({ name => 'foo' }); ok($new->artistid, "Auto-PK worked"); # test LIMIT support for (1..6) { $schema->resultset('Artist')->create({ name => 'Artist ' . $_ }); } my $it = $schema->resultset('Artist')->search( {}, { rows => 3, order_by => 'artistid' } ); is( $it->count, 3, "LIMIT count ok" ); is( $it->next->name, "foo", "iterator->next ok" ); $it->next; is( $it->next->name, "Artist 2", "iterator->next ok" ); is( $it->next, undef, "next past end of resultset ok" ); my $test_type_info = { 'artistid' => { 'data_type' => 'INTEGER', 'is_nullable' => 0, 'size' => 10 }, 'name' => { 'data_type' => 'VARCHAR', 'is_nullable' => 1, 'size' => 255 }, 'rank' => { 'data_type' => 'INTEGER', 'is_nullable' => 0, 'size' => 10, }, 'charfield' => { 'data_type' => 'CHAR', 'is_nullable' => 1, 'size' => 10 }, }; my $type_info = $schema->storage->columns_info_for('artist'); is_deeply($type_info, $test_type_info, 'columns_info_for - column data types'); # clean up our mess END { my $dbh = eval { $schema->storage->_dbh }; $dbh->do("DROP TABLE artist") if $dbh; undef $schema; } �����������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/72pg.t������������������������������������������������������������������������0000644�0001750�0001750�00000071120�14240132261�014306� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use Test::Warn; use Sub::Name; use Config; use DBIx::Class::Optional::Dependencies (); use lib qw(t/lib); use DBICTest; use SQL::Abstract::Util 'is_literal_value'; use DBIx::Class::_Util qw( is_exception sigwarn_silencer ); plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_pg') unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_pg'); my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/}; plan skip_all => <<'EOM' unless $dsn && $user; Set $ENV{DBICTEST_PG_DSN}, _USER and _PASS to run this test ( NOTE: This test drops and creates tables called 'artist', 'cd', 'timestamp_primary_key_test', 'track', 'casecheck', 'array_test' and 'sequence_test' as well as following sequences: 'pkid1_seq', 'pkid2_seq' and 'nonpkid_seq'. as well as following schemas: 'dbic_t_schema', 'dbic_t_schema_2', 'dbic_t_schema_3', 'dbic_t_schema_4', and 'dbic_t_schema_5') EOM ### load any test classes that are defined further down in the file via BEGIN blocks our @test_classes; #< array that will be pushed into by test classes defined in this file DBICTest::Schema->load_classes( map {s/.+:://;$_} @test_classes ) if @test_classes; ### pre-connect tests (keep each test separate as to make sure rebless() runs) { my $s = DBICTest::Schema->connect($dsn, $user, $pass); ok (!$s->storage->_dbh, 'definitely not connected'); # Check that datetime_parser returns correctly before we explicitly connect. SKIP: { skip ( "Pg parser detection test needs " . DBIx::Class::Optional::Dependencies->req_missing_for ('test_dt_pg'), 2 ) unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt_pg'); my $store = ref $s->storage; is($store, 'DBIx::Class::Storage::DBI', 'Started with generic storage'); my $parser = $s->storage->datetime_parser; is( $parser, 'DateTime::Format::Pg', 'datetime_parser is as expected'); } ok (!$s->storage->_dbh, 'still not connected'); } { my $s = DBICTest::Schema->connect($dsn, $user, $pass); # make sure sqlt_type overrides work (::Storage::DBI::Pg does this) ok (!$s->storage->_dbh, 'definitely not connected'); is ($s->storage->sqlt_type, 'PostgreSQL', 'sqlt_type correct pre-connection'); ok (!$s->storage->_dbh, 'still not connected'); } # test LIMIT support { my $schema = DBICTest::Schema->connect($dsn, $user, $pass); drop_test_schema($schema); create_test_schema($schema); for (1..6) { $schema->resultset('Artist')->create({ name => 'Artist ' . $_ }); } my $it = $schema->resultset('Artist')->search( {}, { rows => 3, offset => 2, order_by => 'artistid' } ); is( $it->count, 3, "LIMIT count ok" ); # ask for 3 rows out of 6 artists is( $it->next->name, "Artist 3", "iterator->next ok" ); $it->next; $it->next; $it->next; is( $it->next, undef, "next past end of resultset ok" ); # Limit with select-lock lives_ok { $schema->txn_do (sub { isa_ok ( $schema->resultset('Artist')->find({artistid => 1}, {for => 'update', rows => 1}), 'DBICTest::Schema::Artist', ); }); } 'Limited FOR UPDATE select works'; } # check if we indeed do support stuff my $test_server_supports_insert_returning = do { my $si = DBICTest::Schema->connect($dsn, $user, $pass)->storage->_server_info; die "Unparseable Pg server version: $si->{dbms_version}\n" unless $si->{normalized_dbms_version}; $si->{normalized_dbms_version} < 8.002 ? 0 : 1; }; is ( DBICTest::Schema->connect($dsn, $user, $pass)->storage->_use_insert_returning, $test_server_supports_insert_returning, 'insert returning capability guessed correctly' ); my $schema; for my $use_insert_returning ($test_server_supports_insert_returning ? (0,1) : (0) ) { no warnings qw/once redefine/; my $old_connection = DBICTest::Schema->can('connection'); local *DBICTest::Schema::connection = subname 'DBICTest::Schema::connection' => sub { my $s = shift->$old_connection(@_); $s->storage->_use_insert_returning ($use_insert_returning); $s; }; ### test capability override { my $s = DBICTest::Schema->connect($dsn, $user, $pass); ok (!$s->storage->_dbh, 'definitely not connected'); ok ( ! ($s->storage->_use_insert_returning xor $use_insert_returning), 'insert returning capability set correctly', ); ok (!$s->storage->_dbh, 'still not connected (capability override works)'); } ### connect, create postgres-specific test schema $schema = DBICTest::Schema->connect($dsn, $user, $pass); $schema->storage->ensure_connected; drop_test_schema($schema); create_test_schema($schema); ### begin main tests # run a BIG bunch of tests for last-insert-id / Auto-PK / sequence # discovery run_apk_tests($schema); #< older set of auto-pk tests run_extended_apk_tests($schema); #< new extended set of auto-pk tests ### type_info tests my $test_type_info = { 'artistid' => { 'data_type' => 'integer', 'is_nullable' => 0, 'size' => 4, }, 'name' => { 'data_type' => 'character varying', 'is_nullable' => 1, 'size' => 100, 'default_value' => undef, }, 'rank' => { 'data_type' => 'integer', 'is_nullable' => 0, 'size' => 4, 'default_value' => 13, }, 'charfield' => { 'data_type' => 'character', 'is_nullable' => 1, 'size' => 10, 'default_value' => undef, }, 'arrayfield' => { 'data_type' => 'integer[]', 'is_nullable' => 1, 'size' => undef, 'default_value' => undef, }, }; my $type_info = $schema->storage->columns_info_for('dbic_t_schema.artist'); my $artistid_defval = delete $type_info->{artistid}->{default_value}; like($artistid_defval, qr/^nextval\('([^\.]*\.){0,1}artist_artistid_seq'::(?:text|regclass)\)/, 'columns_info_for - sequence matches Pg get_autoinc_seq expectations'); is_deeply($type_info, $test_type_info, 'columns_info_for - column data types'); ####### Array tests BEGIN { package DBICTest::Schema::ArrayTest; push @main::test_classes, __PACKAGE__; use strict; use warnings; use base 'DBICTest::BaseResult'; __PACKAGE__->table('dbic_t_schema.array_test'); __PACKAGE__->add_columns(qw/id arrayfield/); __PACKAGE__->column_info_from_storage(1); __PACKAGE__->set_primary_key('id'); # FIXME - for some reason column_info_from_storage does not properly find # the is_auto_increment setting... __PACKAGE__->column_info('id')->{is_auto_increment} = 1; } SKIP: { skip "Need DBD::Pg 2.9.2 or newer for array tests", 4 if $DBD::Pg::VERSION < 2.009002; my $arr_rs = $schema->resultset('ArrayTest'); lives_ok { $arr_rs->create({ arrayfield => [1, 2], }); } 'inserting arrayref as pg array data'; lives_ok { $arr_rs->update({ arrayfield => [3, 4], }); } 'updating arrayref as pg array data'; $arr_rs->create({ arrayfield => [5, 6], }); lives_ok { $schema->populate('ArrayTest', [ [ qw/arrayfield/ ], [ [0,0] ], ]); } 'inserting arrayref using void ctx populate'; # Search using arrays lives_ok { is_deeply ( $arr_rs->search({ arrayfield => { -value => [3,4] } })->first->arrayfield, [3,4], 'Array value matches' ); } 'searching by arrayref'; lives_ok { is_deeply ( $arr_rs->search({ arrayfield => { '=' => { -value => [3,4] }} })->first->arrayfield, [3,4], 'Array value matches explicit equal' ); } 'searching by arrayref (explicit equal sign)'; lives_ok { is_deeply ( $arr_rs->search({ arrayfield => { '>' => { -value => [3,1] }} })->first->arrayfield, [3,4], 'Array value matches greater than' ); } 'searching by arrayref (greater than)'; lives_ok { is ( $arr_rs->search({ arrayfield => { '>' => { -value => [3,7] }} })->count, 1, 'Greater than search found [5,6]', ); } 'searching by arrayref (greater than)'; # Find using arrays lives_ok { is_deeply ( $arr_rs->find({ arrayfield => { -value => [3,4] } })->arrayfield, [3,4], 'Array value matches implicit equal' ); } 'find by arrayref'; lives_ok { is_deeply ( $arr_rs->find({ arrayfield => { '=' => { -value => [3,4] }} })->arrayfield, [3,4], 'Array value matches explicit equal' ); } 'find by arrayref (equal)'; # test inferred condition for creation for my $cond ( { -value => [3,4] }, \[ '= ?' => [3, 4] ], ) { local $TODO = 'No introspection of complex literal conditions :(' if is_literal_value $cond; my $arr_rs_cond = $arr_rs->search({ arrayfield => $cond }); my $row = $arr_rs_cond->create({}); is_deeply ($row->arrayfield, [3,4], 'Array value taken from $rs condition'); $row->discard_changes; is_deeply ($row->arrayfield, [3,4], 'Array value made it to storage'); } } ########## Case check BEGIN { package DBICTest::Schema::Casecheck; push @main::test_classes, __PACKAGE__; use strict; use warnings; use base 'DBIx::Class::Core'; __PACKAGE__->table('dbic_t_schema.casecheck'); __PACKAGE__->add_columns(qw/id name NAME uc_name/); __PACKAGE__->column_info_from_storage(1); __PACKAGE__->set_primary_key('id'); } my $name_info = $schema->source('Casecheck')->column_info( 'name' ); is( $name_info->{size}, 1, "Case sensitive matching info for 'name'" ); my $NAME_info = $schema->source('Casecheck')->column_info( 'NAME' ); is( $NAME_info->{size}, 2, "Case sensitive matching info for 'NAME'" ); my $uc_name_info = $schema->source('Casecheck')->column_info( 'uc_name' ); is( $uc_name_info->{size}, 3, "Case insensitive matching info for 'uc_name'" ); ## Test ResultSet->update my $artist = $schema->resultset('Artist')->first; my $cds = $artist->cds_unordered->search({ year => { '!=' => 2010 } }, { prefetch => 'liner_notes' }); lives_ok { $cds->update({ year => '2010' }) } 'Update on prefetched rs'; ## Test SELECT ... FOR UPDATE SKIP: { skip "Your system does not support unsafe signals (d_sigaction) - unable to run deadlock test", 1 unless eval { $Config{d_sigaction} and require POSIX }; my ($timed_out, $artist2); for my $t ( { # Make sure that an error was raised, and that the update failed update_lock => 1, test_sub => sub { ok($timed_out, "update from second schema times out"); ok($artist2->is_column_changed('name'), "'name' column is still dirty from second schema"); }, }, { # Make sure that an error was NOT raised, and that the update succeeded update_lock => 0, test_sub => sub { ok(! $timed_out, "update from second schema DOES NOT timeout"); ok(! $artist2->is_column_changed('name'), "'name' column is NOT dirty from second schema"); }, }, ) { # create a new schema my $schema2 = DBICTest::Schema->connect($dsn, $user, $pass); $schema2->source("Artist")->name("dbic_t_schema.artist"); $schema->txn_do( sub { my $rs = $schema->resultset('Artist')->search( { artistid => 1 }, $t->{update_lock} ? { for => 'update' } : {} ); ok ($rs->count, 'Count works'); my $artist = $rs->next; is($artist->artistid, 1, "select returns artistid = 1"); $timed_out = 0; eval { # can not use %SIG assignment directly - we need sigaction below # localization to a block still works however local $SIG{ALRM}; POSIX::sigaction( POSIX::SIGALRM() => POSIX::SigAction->new( sub { die "DBICTestTimeout" }, )); $artist2 = $schema2->resultset('Artist')->find(1); $artist2->name('fooey'); # FIXME - this needs to go away in lieu of a non-retrying runner # ( i.e. after solving RT#47005 ) local *DBIx::Class::Storage::DBI::_ping = sub { 1 }, DBIx::Class::_ENV_::OLD_MRO && Class::C3->reinitialize() if DBIx::Class::_Util::modver_gt_or_eq( 'DBD::Pg' => '3.5.0' ); alarm(1); $artist2->update; }; alarm(0); if (is_exception($@)) { $timed_out = $@ =~ /DBICTestTimeout/ or die $@; } }); $t->{test_sub}->(); } } ######## other older Auto-pk tests $schema->source("SequenceTest")->name("dbic_t_schema.sequence_test"); for (1..5) { my $st = $schema->resultset('SequenceTest')->create({ name => 'foo' }); is($st->pkid1, $_, "Auto-PK for sequence without default: First primary key"); is($st->pkid2, $_ + 9, "Auto-PK for sequence without default: Second primary key"); is($st->nonpkid, $_ + 19, "Auto-PK for sequence without default: Non-primary key"); } my $st = $schema->resultset('SequenceTest')->create({ name => 'foo', pkid1 => 55 }); is($st->pkid1, 55, "Auto-PK for sequence without default: First primary key set manually"); ######## test non-serial auto-pk if ($schema->storage->_use_insert_returning) { $schema->source('TimestampPrimaryKey')->name('dbic_t_schema.timestamp_primary_key_test'); my $row = $schema->resultset('TimestampPrimaryKey')->create({}); ok $row->id; } ######## test with_deferred_fk_checks $schema->source('CD')->name('dbic_t_schema.cd'); $schema->source('Track')->name('dbic_t_schema.track'); lives_ok { # workaround for PG 9.5+, fix pending in mainline local $SIG{__WARN__} = sigwarn_silencer( qr/SET CONSTRAINTS can only be used in transaction blocks/ ); $schema->storage->with_deferred_fk_checks(sub { $schema->resultset('Track')->create({ trackid => 999, cd => 999, position => 1, title => 'deferred FK track' }); $schema->resultset('CD')->create({ artist => 1, cdid => 999, year => '2003', title => 'deferred FK cd' }); }); } 'with_deferred_fk_checks code survived'; is eval { $schema->resultset('Track')->find(999)->title }, 'deferred FK track', 'code in with_deferred_fk_checks worked'; throws_ok { $schema->resultset('Track')->create({ trackid => 1, cd => 9999, position => 1, title => 'Track1' }); } qr/violates foreign key constraint/i, 'with_deferred_fk_checks is off outside of TXN'; # rerun the same under with_deferred_fk_checks # it is expected to fail, hence the eval # but it also should not warn warnings_like { # workaround for PG 9.5+, fix pending in mainline local $SIG{__WARN__} = sigwarn_silencer( qr/SET CONSTRAINTS can only be used in transaction blocks/ ); eval { $schema->storage->with_deferred_fk_checks(sub { $schema->resultset('Track')->create({ trackid => 1, cd => 9999, position => 1, title => 'Track1' }); } ) }; like $@, qr/violates foreign key constraint/i, "Still expected exception on deferred failure at commit time"; } [], 'No warnings on deferred rollback'; } done_testing; END { return unless $schema; drop_test_schema($schema); eapk_drop_all($schema); undef $schema; }; ######### SUBROUTINES sub create_test_schema { my $schema = shift; $schema->storage->dbh_do(sub { my (undef,$dbh) = @_; local $dbh->{Warn} = 0; my $std_artist_table = <<EOS; ( artistid serial PRIMARY KEY , name VARCHAR(100) , rank INTEGER NOT NULL DEFAULT '13' , charfield CHAR(10) , arrayfield INTEGER[] ) EOS $dbh->do("CREATE SCHEMA dbic_t_schema"); $dbh->do("CREATE TABLE dbic_t_schema.artist $std_artist_table"); $dbh->do(<<EOS); CREATE TABLE dbic_t_schema.timestamp_primary_key_test ( id timestamp default current_timestamp ) EOS $dbh->do(<<EOS); CREATE TABLE dbic_t_schema.cd ( cdid int PRIMARY KEY, artist int, title varchar(255), year varchar(4), genreid int, single_track int ) EOS $dbh->do(<<EOS); CREATE TABLE dbic_t_schema.track ( trackid int, cd int REFERENCES dbic_t_schema.cd(cdid) DEFERRABLE, position int, title varchar(255), last_updated_on date, last_updated_at date ) EOS $dbh->do(<<EOS); CREATE TABLE dbic_t_schema.sequence_test ( pkid1 integer , pkid2 integer , nonpkid integer , name VARCHAR(100) , CONSTRAINT pk PRIMARY KEY(pkid1, pkid2) ) EOS $dbh->do("CREATE SEQUENCE pkid1_seq START 1 MAXVALUE 999999 MINVALUE 0"); $dbh->do("CREATE SEQUENCE pkid2_seq START 10 MAXVALUE 999999 MINVALUE 0"); $dbh->do("CREATE SEQUENCE nonpkid_seq START 20 MAXVALUE 999999 MINVALUE 0"); $dbh->do(<<EOS); CREATE TABLE dbic_t_schema.casecheck ( id serial PRIMARY KEY , "name" VARCHAR(1) , "NAME" VARCHAR(2) , "UC_NAME" VARCHAR(3) ) EOS $dbh->do(<<EOS); CREATE TABLE dbic_t_schema.array_test ( id serial PRIMARY KEY , arrayfield INTEGER[] ) EOS $dbh->do("CREATE SCHEMA dbic_t_schema_2"); $dbh->do("CREATE TABLE dbic_t_schema_2.artist $std_artist_table"); $dbh->do("CREATE SCHEMA dbic_t_schema_3"); $dbh->do("CREATE TABLE dbic_t_schema_3.artist $std_artist_table"); $dbh->do('set search_path=dbic_t_schema,public'); $dbh->do("CREATE SCHEMA dbic_t_schema_4"); $dbh->do("CREATE SCHEMA dbic_t_schema_5"); $dbh->do(<<EOS); CREATE TABLE dbic_t_schema_4.artist ( artistid integer not null default nextval('artist_artistid_seq'::regclass) PRIMARY KEY , name VARCHAR(100) , rank INTEGER NOT NULL DEFAULT '13' , charfield CHAR(10) , arrayfield INTEGER[] ); EOS $dbh->do('set search_path=public,dbic_t_schema,dbic_t_schema_3'); $dbh->do('create sequence public.artist_artistid_seq'); #< in the public schema $dbh->do(<<EOS); CREATE TABLE dbic_t_schema_5.artist ( artistid integer not null default nextval('public.artist_artistid_seq'::regclass) PRIMARY KEY , name VARCHAR(100) , rank INTEGER NOT NULL DEFAULT '13' , charfield CHAR(10) , arrayfield INTEGER[] ); EOS $dbh->do('set search_path=dbic_t_schema,public'); }); } sub drop_test_schema { my ( $schema, $warn_exceptions ) = @_; $schema->storage->dbh_do(sub { my (undef,$dbh) = @_; local $dbh->{Warn} = 0; for my $stat ( 'DROP SCHEMA dbic_t_schema_5 CASCADE', 'DROP SEQUENCE public.artist_artistid_seq CASCADE', 'DROP SCHEMA dbic_t_schema_4 CASCADE', 'DROP SCHEMA dbic_t_schema CASCADE', 'DROP SEQUENCE pkid1_seq CASCADE', 'DROP SEQUENCE pkid2_seq CASCADE', 'DROP SEQUENCE nonpkid_seq CASCADE', 'DROP SCHEMA dbic_t_schema_2 CASCADE', 'DROP SCHEMA dbic_t_schema_3 CASCADE', ) { eval { $dbh->do ($stat) }; diag $@ if $@ && $warn_exceptions; } }); } ### auto-pk / last_insert_id / sequence discovery sub run_apk_tests { my $schema = shift; # This is in Core now, but it's here just to test that it doesn't break $schema->class('Artist')->load_components('PK::Auto'); cmp_ok( $schema->resultset('Artist')->count, '==', 0, 'this should start with an empty artist table'); # test that auto-pk also works with the defined search path by # un-schema-qualifying the table name apk_t_set($schema,'artist'); my $unq_new; lives_ok { $unq_new = $schema->resultset('Artist')->create({ name => 'baz' }); } 'insert into unqualified, shadowed table succeeds'; is($unq_new && $unq_new->artistid, 1, "and got correct artistid"); my @test_schemas = ( [qw| dbic_t_schema_2 1 |], [qw| dbic_t_schema_3 1 |], [qw| dbic_t_schema_4 2 |], [qw| dbic_t_schema_5 1 |], ); foreach my $t ( @test_schemas ) { my ($sch_name, $start_num) = @$t; #test with dbic_t_schema_2 apk_t_set($schema,"$sch_name.artist"); my $another_new; lives_ok { $another_new = $schema->resultset('Artist')->create({ name => 'Tollbooth Willy'}); is( $another_new->artistid,$start_num, "got correct artistid for $sch_name") or diag "USED SEQUENCE: ".($schema->source('Artist')->column_info('artistid')->{sequence} || '<none>'); } "$sch_name liid 1 did not die" or diag "USED SEQUENCE: ".($schema->source('Artist')->column_info('artistid')->{sequence} || '<none>'); lives_ok { $another_new = $schema->resultset('Artist')->create({ name => 'Adam Sandler'}); is( $another_new->artistid,$start_num+1, "got correct artistid for $sch_name") or diag "USED SEQUENCE: ".($schema->source('Artist')->column_info('artistid')->{sequence} || '<none>'); } "$sch_name liid 2 did not die" or diag "USED SEQUENCE: ".($schema->source('Artist')->column_info('artistid')->{sequence} || '<none>'); } lives_ok { apk_t_set($schema,'dbic_t_schema.artist'); my $new = $schema->resultset('Artist')->create({ name => 'foo' }); is($new->artistid, 4, "Auto-PK worked"); $new = $schema->resultset('Artist')->create({ name => 'bar' }); is($new->artistid, 5, "Auto-PK worked"); } 'old auto-pk tests did not die either'; } # sets the artist table name and clears sequence name cache sub apk_t_set { my ( $s, $n ) = @_; $s->source("Artist")->name($n); $s->source('Artist')->column_info('artistid')->{sequence} = undef; #< clear sequence name cache } ######## EXTENDED AUTO-PK TESTS my @eapk_id_columns; BEGIN { package DBICTest::Schema::ExtAPK; push @main::test_classes, __PACKAGE__; use strict; use warnings; use base 'DBIx::Class::Core'; __PACKAGE__->table('apk'); @eapk_id_columns = qw( id1 id2 id3 id4 ); __PACKAGE__->add_columns( map { $_ => { data_type => 'integer', is_auto_increment => 1 } } @eapk_id_columns ); __PACKAGE__->set_primary_key('id2'); #< note the SECOND column is #the primary key } my @eapk_schemas; BEGIN{ @eapk_schemas = map "dbic_apk_$_", 0..5 } my %seqs; #< hash of schema.table.col => currval of its (DBIC) primary key sequence sub run_extended_apk_tests { my $schema = shift; #save the search path and reset it at the end my $search_path_save = eapk_get_search_path($schema); eapk_drop_all($schema); %seqs = (); # make the test schemas and sequences $schema->storage->dbh_do(sub { my ( undef, $dbh ) = @_; $dbh->do("CREATE SCHEMA $_") for @eapk_schemas; $dbh->do("CREATE SEQUENCE $eapk_schemas[5].fooseq"); $dbh->do("SELECT setval('$eapk_schemas[5].fooseq',400)"); $seqs{"$eapk_schemas[1].apk.id2"} = 400; $dbh->do("CREATE SEQUENCE $eapk_schemas[4].fooseq"); $dbh->do("SELECT setval('$eapk_schemas[4].fooseq',300)"); $seqs{"$eapk_schemas[3].apk.id2"} = 300; $dbh->do("CREATE SEQUENCE $eapk_schemas[3].fooseq"); $dbh->do("SELECT setval('$eapk_schemas[3].fooseq',200)"); $seqs{"$eapk_schemas[4].apk.id2"} = 200; $dbh->do("SET search_path = ".join ',', reverse @eapk_schemas ); }); # clear our search_path cache $schema->storage->{_pg_search_path} = undef; eapk_create( $schema, with_search_path => [0,1], ); eapk_create( $schema, with_search_path => [1,0,'public'], nextval => "$eapk_schemas[5].fooseq", ); eapk_create( $schema, with_search_path => ['public',0,1], qualify_table => 2, ); eapk_create( $schema, with_search_path => [3,1,0,'public'], nextval => "$eapk_schemas[4].fooseq", ); eapk_create( $schema, with_search_path => [3,1,0,'public'], nextval => "$eapk_schemas[3].fooseq", qualify_table => 4, ); eapk_poke( $schema ); eapk_poke( $schema, 0 ); eapk_poke( $schema, 2 ); eapk_poke( $schema, 4 ); eapk_poke( $schema, 1 ); eapk_poke( $schema, 0 ); eapk_poke( $schema, 1 ); eapk_poke( $schema ); eapk_poke( $schema, 4 ); eapk_poke( $schema, 3 ); eapk_poke( $schema, 1 ); eapk_poke( $schema, 2 ); eapk_poke( $schema, 0 ); # set our search path back eapk_set_search_path( $schema, @$search_path_save ); } # do a DBIC create on the apk table in the given schema number (which is an # index of @eapk_schemas) sub eapk_poke { my ($s, $schema_num) = @_; my $schema_name = defined $schema_num ? $eapk_schemas[$schema_num] : ''; my $schema_name_actual = $schema_name || eapk_find_visible_schema($s); $s->source('ExtAPK')->name($schema_name ? $schema_name.'.apk' : 'apk'); #< clear sequence name cache $s->source('ExtAPK')->column_info($_)->{sequence} = undef for @eapk_id_columns; no warnings 'uninitialized'; lives_ok { my $new; for my $inc (1,2,3) { $new = $schema->resultset('ExtAPK')->create({ id1 => 1}); my $proper_seqval = ++$seqs{"$schema_name_actual.apk.id2"}; is( $new->id2, $proper_seqval, "$schema_name_actual.apk.id2 correct inc $inc" ) or eapk_seq_diag($s,$schema_name); $new->discard_changes; is( $new->id1, 1 ); for my $id ('id3','id4') { my $proper_seqval = ++$seqs{"$schema_name_actual.apk.$id"}; is( $new->$id, $proper_seqval, "$schema_name_actual.apk.$id correct inc $inc" ) or eapk_seq_diag($s,$schema_name); } } } "create in schema '$schema_name' lives" or eapk_seq_diag($s,$schema_name); } # print diagnostic info on which sequences were found in the ExtAPK # class sub eapk_seq_diag { my $s = shift; my $schema = shift || eapk_find_visible_schema($s); diag "$schema.apk sequences: ", join(', ', map "$_:".($s->source('ExtAPK')->column_info($_)->{sequence} || '<none>'), @eapk_id_columns ); } # get the postgres search path as an arrayref sub eapk_get_search_path { my ( $s ) = @_; # cache the search path as ['schema','schema',...] in the storage # obj return $s->storage->dbh_do(sub { my (undef, $dbh) = @_; my @search_path; my ($sp_string) = $dbh->selectrow_array('SHOW search_path'); while ( $sp_string =~ s/("[^"]+"|[^,]+),?// ) { unless( defined $1 and length $1 ) { die "search path sanity check failed: '$1'"; } push @search_path, $1; } \@search_path }); } sub eapk_set_search_path { my ($s,@sp) = @_; my $sp = join ',',@sp; $s->storage->dbh_do( sub { $_[1]->do("SET search_path = $sp") } ); } # create the apk table in the given schema, can set whether the table name is qualified, what the nextval is for the second ID sub eapk_create { my ($schema, %a) = @_; $schema->storage->dbh_do(sub { my (undef,$dbh) = @_; my $searchpath_save; if ( $a{with_search_path} ) { ($searchpath_save) = $dbh->selectrow_array('SHOW search_path'); my $search_path = join ',',map {/\D/ ? $_ : $eapk_schemas[$_]} @{$a{with_search_path}}; $dbh->do("SET search_path = $search_path"); } my $table_name = $a{qualify_table} ? ($eapk_schemas[$a{qualify_table}] || die). ".apk" : 'apk'; local $_[1]->{Warn} = 0; my $id_def = $a{nextval} ? "integer not null default nextval('$a{nextval}'::regclass)" : 'serial'; $dbh->do(<<EOS); CREATE TABLE $table_name ( id1 serial , id2 $id_def , id3 serial primary key , id4 serial ) EOS if( $searchpath_save ) { $dbh->do("SET search_path = $searchpath_save"); } }); } sub eapk_drop_all { my ( $schema, $warn_exceptions ) = @_; $schema->storage->dbh_do(sub { my (undef,$dbh) = @_; local $dbh->{Warn} = 0; # drop the test schemas for (@eapk_schemas ) { eval{ $dbh->do("DROP SCHEMA $_ CASCADE") }; diag $@ if $@ && $warn_exceptions; } }); } sub eapk_find_visible_schema { my ($s) = @_; my ($schema) = $s->storage->dbh_do(sub { $_[1]->selectrow_array(<<EOS); SELECT n.nspname FROM pg_catalog.pg_namespace n JOIN pg_catalog.pg_class c ON c.relnamespace = n.oid WHERE c.relname = 'apk' AND pg_catalog.pg_table_is_visible(c.oid) EOS }); return $schema; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/80unique.t��������������������������������������������������������������������0000644�0001750�0001750�00000017551�14240132261�015215� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use Test::Warn; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); # Check the defined unique constraints is_deeply( [ sort $schema->source('CD')->unique_constraint_names ], [ qw/cd_artist_title primary/ ], 'CD source has an automatically named unique constraint' ); is_deeply( [ sort $schema->source('Producer')->unique_constraint_names ], [ qw/primary prod_name/ ], 'Producer source has a named unique constraint' ); is_deeply( [ sort $schema->source('Track')->unique_constraint_names ], [ qw/primary track_cd_position track_cd_title/ ], 'Track source has three unique constraints' ); is_deeply( [ sort $schema->source('Tag')->unique_constraint_names ], [ qw/primary tagid_cd tagid_cd_tag tags_tagid_tag tags_tagid_tag_cd/ ], 'Tag source has five unique constraints (from add_unique_constraings)' ); my $artistid = 1; my $title = 'UNIQUE Constraint'; my $cd1 = $schema->resultset('CD')->find_or_create({ artist => $artistid, title => $title, year => 2005, }); my $cd2 = $schema->resultset('CD')->find( { artist => $artistid, title => $title, }, { key => 'cd_artist_title' } ); is($cd2->get_column('artist'), $cd1->get_column('artist'), 'find by specific key: artist is correct'); is($cd2->title, $cd1->title, 'title is correct'); is($cd2->year, $cd1->year, 'year is correct'); my $cd3 = $schema->resultset('CD')->find($artistid, $title, { key => 'cd_artist_title' }); is($cd3->get_column('artist'), $cd1->get_column('artist'), 'find by specific key, ordered columns: artist is correct'); is($cd3->title, $cd1->title, 'title is correct'); is($cd3->year, $cd1->year, 'year is correct'); my $cd4 = $schema->resultset('CD')->update_or_create( { artist => $artistid, title => $title, year => 2007, }, ); ok(! $cd4->is_changed, 'update_or_create without key: row is clean'); is($cd4->cdid, $cd2->cdid, 'cdid is correct'); is($cd4->get_column('artist'), $cd2->get_column('artist'), 'artist is correct'); is($cd4->title, $cd2->title, 'title is correct'); is($cd4->year, 2007, 'updated year is correct'); my $cd5 = $schema->resultset('CD')->update_or_create( { artist => $artistid, title => $title, year => 2007, }, { key => 'cd_artist_title' } ); ok(! $cd5->is_changed, 'update_or_create by specific key: row is clean'); is($cd5->cdid, $cd2->cdid, 'cdid is correct'); is($cd5->get_column('artist'), $cd2->get_column('artist'), 'artist is correct'); is($cd5->title, $cd2->title, 'title is correct'); is($cd5->year, 2007, 'updated year is correct'); my $cd6 = $schema->resultset('CD')->update_or_create( { cdid => $cd2->cdid, artist => 1, title => $cd2->title, year => 2005, }, { key => 'primary' } ); ok(! $cd6->is_changed, 'update_or_create by PK: row is clean'); is($cd6->cdid, $cd2->cdid, 'cdid is correct'); is($cd6->get_column('artist'), $cd2->get_column('artist'), 'artist is correct'); is($cd6->title, $cd2->title, 'title is correct'); is($cd6->year, 2005, 'updated year is correct'); my $cd7 = $schema->resultset('CD')->find_or_create( { artist => $artistid, title => $title, year => 2010, }, { key => 'cd_artist_title' } ); is($cd7->cdid, $cd1->cdid, 'find_or_create by specific key: cdid is correct'); is($cd7->get_column('artist'), $cd1->get_column('artist'), 'artist is correct'); is($cd7->title, $cd1->title, 'title is correct'); is($cd7->year, $cd1->year, 'year is correct'); my $artist = $schema->resultset('Artist')->find($artistid); my $cd8 = $artist->find_or_create_related('cds', { title => $title, year => 2020, }, { key => 'cd_artist_title' } ); is($cd8->cdid, $cd1->cdid, 'find_or_create related by specific key: cdid is correct'); is($cd8->get_column('artist'), $cd1->get_column('artist'), 'artist is correct'); is($cd8->title, $cd1->title, 'title is correct'); is($cd8->year, $cd1->year, 'year is correct'); # Add an extra row to potentially confuse the query $schema->resultset('CD')->create ({ artist => 2, title => $title, year => 2022, }); my $cd9 = $artist->cds->update_or_create( { cdid => $cd1->cdid, title => $title, year => 2021, }, { key => 'cd_artist_title' } ); ok(! $cd9->is_changed, 'update_or_create by specific key: row is clean'); is($cd9->cdid, $cd1->cdid, 'cdid is correct'); is($cd9->get_column('artist'), $cd1->get_column('artist'), 'artist is correct'); is($cd9->title, $cd1->title, 'title is correct'); is($cd9->year, 2021, 'year is correct'); # Table with two unique constraints, and we're satisying one of them my $track = $schema->resultset('Track')->find( { cd => 1, position => 3, }, { order_by => 'position' } ); is($track->get_column('cd'), 1, 'track cd is correct'); is($track->get_column('position'), 3, 'track position is correct'); # Test a table with a unique constraint but no primary key my $row = $schema->resultset('NoPrimaryKey')->update_or_create( { foo => 1, bar => 2, baz => 3, }, { key => 'foo_bar' } ); ok(! $row->is_changed, 'update_or_create on table without primary key: row is clean'); is($row->foo, 1, 'foo is correct'); is($row->bar, 2, 'bar is correct'); is($row->baz, 3, 'baz is correct'); # Test a unique condition with extra information in the where attr { my $artist = $schema->resultset('Artist')->find({ artistid => 1 }); my $cd = $artist->cds->find_or_new( { cdid => 1, title => 'Not The Real Title', year => 3000, }, { key => 'primary' } ); ok($cd->in_storage, 'find correctly grepped the key across a relationship'); is($cd->cdid, 1, 'cdid is correct'); } # Test update_or_new { my $cd1 = $schema->resultset('CD')->update_or_new( { artist => $artistid, title => "SuperHits $$", year => 2007, }, { key => 'cd_artist_title' } ); is($cd1->in_storage, 0, 'CD is not in storage yet after update_or_new'); $cd1->insert; ok($cd1->in_storage, 'CD got added to strage after update_or_new && insert'); my $cd2 = $schema->resultset('CD')->update_or_new( { artist => $artistid, title => "SuperHits $$", year => 2008, }, { key => 'cd_artist_title' } ); ok($cd2->in_storage, 'Updating year using update_or_new was successful'); is($cd2->id, $cd1->id, 'Got the same CD using update_or_new'); } # make sure the ident condition is assembled sanely { my $artist = $schema->resultset('Artist')->find(1); $schema->is_executed_sql_bind( sub { $artist->discard_changes }, [ [ 'SELECT me.artistid, me.name, me.rank, me.charfield FROM artist me WHERE me.artistid = ?', [ { dbic_colname => "me.artistid", sqlt_datatype => "integer" } => 1 ], ] ], 'Expected query on discard_changes'); } { throws_ok { eval <<'MOD' or die $@; package # hide from PAUSE DBICTest::Schema::UniqueConstraintWarningTest; use base qw/DBIx::Class::Core/; __PACKAGE__->table('dummy'); __PACKAGE__->add_column(qw/ foo bar /); __PACKAGE__->add_unique_constraint( constraint1 => [qw/ foo /], constraint2 => [qw/ bar /], ); 1; MOD } qr/\Qadd_unique_constraint() does not accept multiple constraints, use add_unique_constraints() instead\E/, 'add_unique_constraint throws when more than one constraint specified'; } # make sure NULL is not considered condition-deterministic my $art_rs = $schema->resultset('Artist')->search({}, { order_by => 'artistid' }); $art_rs->create ({ artistid => $_ + 640, name => "Outranked $_" }) for (1..2); warnings_are { is( $art_rs->find ({ artistid => 642, rank => 13, charfield => undef })->name, 'Outranked 2', 'Correct artist retrieved with find' ); is ( $art_rs->search({ charfield => undef })->find ({ artistid => 642, rank => 13 })->name, 'Outranked 2', 'Correct artist retrieved with find' ); } [], 'no warnings'; done_testing; �������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/discard_changes_in_DESTROY.t��������������������������������������������������0000644�0001750�0001750�00000001221�14240132261�020522� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); { my @warnings; local $SIG{__WARN__} = sub { push @warnings, @_; }; { # Test that this doesn't cause infinite recursion. local *DBICTest::Artist::DESTROY; local *DBICTest::Artist::DESTROY = sub { $_[0]->discard_changes }; my $artist = $schema->resultset("Artist")->create( { artistid => 10, name => "artist number 10", }); $artist->name("Wibble"); print "# About to call DESTROY\n"; } is_deeply \@warnings, []; } done_testing; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/101populate_rs.t��������������������������������������������������������������0000644�0001750�0001750�00000055744�14240132261�016324� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������## ---------------------------------------------------------------------------- ## Tests for the $resultset->populate method. ## ## GOALS: We need to test the method for both void and array context for all ## the following relationship types: belongs_to, has_many. Additionally we ## need to test each of those for both specified PK's and autogenerated PK's ## ## Also need to test some stuff that should generate errors. ## ---------------------------------------------------------------------------- use strict; use warnings; use Test::More; use Test::Warn; use Test::Exception; use lib qw(t/lib); use DBICTest; ## ---------------------------------------------------------------------------- ## Get a Schema and some ResultSets we can play with. ## ---------------------------------------------------------------------------- my $schema = DBICTest->init_schema(); my $art_rs = $schema->resultset('Artist'); my $cd_rs = $schema->resultset('CD'); my $restricted_art_rs = $art_rs->search({ -and => [ rank => 42, charfield => { '=', \['(SELECT MAX(artistid) FROM artist) + ?', 6] } ] }); ok( $schema, 'Got a Schema object'); ok( $art_rs, 'Got Good Artist Resultset'); ok( $cd_rs, 'Got Good CD Resultset'); ## ---------------------------------------------------------------------------- ## Schema populate Tests ## ---------------------------------------------------------------------------- SCHEMA_POPULATE1: { # throw a monkey wrench my $post_jnap_monkeywrench = $schema->resultset('Artist')->find(1)->update({ name => undef }); warnings_exist { $schema->populate('Artist', [ [qw/name cds/], ["001First Artist", [ {title=>"001Title1", year=>2000}, {title=>"001Title2", year=>2001}, {title=>"001Title3", year=>2002}, ]], ["002Second Artist", []], ["003Third Artist", [ {title=>"003Title1", year=>2005}, ]], [undef, [ {title=>"004Title1", year=>2010} ]], ]) } qr/\QFast-path populate() of non-uniquely identifiable rows with related data is not possible/; isa_ok $schema, 'DBIx::Class::Schema'; my ( $preexisting_undef, $artist1, $artist2, $artist3, $undef ) = $schema->resultset('Artist')->search({ name=>["001First Artist","002Second Artist","003Third Artist", undef]}, {order_by => { -asc => 'artistid' }})->all; isa_ok $artist1, 'DBICTest::Artist'; isa_ok $artist2, 'DBICTest::Artist'; isa_ok $artist3, 'DBICTest::Artist'; isa_ok $undef, 'DBICTest::Artist'; ok $artist1->name eq '001First Artist', "Got Expected Artist Name for Artist001"; ok $artist2->name eq '002Second Artist', "Got Expected Artist Name for Artist002"; ok $artist3->name eq '003Third Artist', "Got Expected Artist Name for Artist003"; ok !defined $undef->name, "Got Expected Artist Name for Artist004"; ok $artist1->cds->count eq 3, "Got Right number of CDs for Artist1"; ok $artist2->cds->count eq 0, "Got Right number of CDs for Artist2"; ok $artist3->cds->count eq 1, "Got Right number of CDs for Artist3"; ok $undef->cds->count eq 1, "Got Right number of CDs for Artist4"; $post_jnap_monkeywrench->delete; ARTIST1CDS: { my ($cd1, $cd2, $cd3) = $artist1->cds->search(undef, {order_by=>'year ASC'}); isa_ok $cd1, 'DBICTest::CD'; isa_ok $cd2, 'DBICTest::CD'; isa_ok $cd3, 'DBICTest::CD'; ok $cd1->year == 2000; ok $cd2->year == 2001; ok $cd3->year == 2002; ok $cd1->title eq '001Title1'; ok $cd2->title eq '001Title2'; ok $cd3->title eq '001Title3'; } ARTIST3CDS: { my ($cd1) = $artist3->cds->search(undef, {order_by=>'year ASC'}); isa_ok $cd1, 'DBICTest::CD'; ok $cd1->year == 2005; ok $cd1->title eq '003Title1'; } ARTIST4CDS: { my ($cd1) = $undef->cds->search(undef, {order_by=>'year ASC'}); isa_ok $cd1, 'DBICTest::CD'; ok $cd1->year == 2010; ok $cd1->title eq '004Title1'; } ## Need to do some cleanup so that later tests don't get borked $undef->delete; } ## ---------------------------------------------------------------------------- ## Array context tests ## ---------------------------------------------------------------------------- ARRAY_CONTEXT: { ## These first set of tests are cake because array context just delegates ## all its processing to $resultset->create HAS_MANY_NO_PKS: { ## This first group of tests checks to make sure we can call populate ## with the parent having many children and let the keys be automatic my $artists = [ { name => 'Angsty-Whiny Girl', cds => [ { title => 'My First CD', year => 2006 }, { title => 'Yet More Tweeny-Pop crap', year => 2007 }, ], }, { name => 'Manufactured Crap', }, { name => 'Like I Give a Damn', cds => [ { title => 'My parents sold me to a record company' ,year => 2005 }, { title => 'Why Am I So Ugly?', year => 2006 }, { title => 'I Got Surgery and am now Popular', year => 2007 } ], }, { name => 'Formerly Named', cds => [ { title => 'One Hit Wonder', year => 2006 }, ], }, ]; ## Get the result row objects. my ($girl, $crap, $damn, $formerly) = $art_rs->populate($artists); ## Do we have the right object? isa_ok( $crap, 'DBICTest::Artist', "Got 'Artist'"); isa_ok( $girl, 'DBICTest::Artist', "Got 'Artist'"); isa_ok( $damn, 'DBICTest::Artist', "Got 'Artist'"); isa_ok( $formerly, 'DBICTest::Artist', "Got 'Artist'"); ## Find the expected information? ok( $crap->name eq 'Manufactured Crap', "Got Correct name for result object"); ok( $girl->name eq 'Angsty-Whiny Girl', "Got Correct name for result object"); ok( $damn->name eq 'Like I Give a Damn', "Got Correct name for result object"); ok( $formerly->name eq 'Formerly Named', "Got Correct name for result object"); ## Create the expected children sub objects? ok( $crap->cds->count == 0, "got Expected Number of Cds"); ok( $girl->cds->count == 2, "got Expected Number of Cds"); ok( $damn->cds->count == 3, "got Expected Number of Cds"); ok( $formerly->cds->count == 1, "got Expected Number of Cds"); ## Did the cds get expected information? my ($cd1, $cd2) = $girl->cds->search({},{order_by=>'year'}); ok( $cd1->title eq "My First CD", "Got Expected CD Title"); ok( $cd2->title eq "Yet More Tweeny-Pop crap", "Got Expected CD Title"); } HAS_MANY_WITH_PKS: { ## This group tests the ability to specify the PK in the parent and let ## DBIC transparently pass the PK down to the Child and also let's the ## child create any other needed PK's for itself. my $aid = $art_rs->get_column('artistid')->max || 0; my $first_aid = ++$aid; my $artists = [ { artistid => $first_aid, name => 'PK_Angsty-Whiny Girl', cds => [ { artist => $first_aid, title => 'PK_My First CD', year => 2006 }, { artist => $first_aid, title => 'PK_Yet More Tweeny-Pop crap', year => 2007 }, ], }, { artistid => ++$aid, name => 'PK_Manufactured Crap', }, { artistid => ++$aid, name => 'PK_Like I Give a Damn', cds => [ { title => 'PK_My parents sold me to a record company' ,year => 2005 }, { title => 'PK_Why Am I So Ugly?', year => 2006 }, { title => 'PK_I Got Surgery and am now Popular', year => 2007 } ], }, { artistid => ++$aid, name => 'PK_Formerly Named', cds => [ { title => 'PK_One Hit Wonder', year => 2006 }, ], }, ]; ## Get the result row objects. my ($girl, $crap, $damn, $formerly) = $art_rs->populate($artists); ## Do we have the right object? isa_ok( $crap, 'DBICTest::Artist', "Got 'Artist'"); isa_ok( $girl, 'DBICTest::Artist', "Got 'Artist'"); isa_ok( $damn, 'DBICTest::Artist', "Got 'Artist'"); isa_ok( $formerly, 'DBICTest::Artist', "Got 'Artist'"); ## Find the expected information? ok( $crap->name eq 'PK_Manufactured Crap', "Got Correct name for result object"); ok( $girl->name eq 'PK_Angsty-Whiny Girl', "Got Correct name for result object"); ok( $girl->artistid == $first_aid, "Got Correct artist PK for result object"); ok( $damn->name eq 'PK_Like I Give a Damn', "Got Correct name for result object"); ok( $formerly->name eq 'PK_Formerly Named', "Got Correct name for result object"); ## Create the expected children sub objects? ok( $crap->cds->count == 0, "got Expected Number of Cds"); ok( $girl->cds->count == 2, "got Expected Number of Cds"); ok( $damn->cds->count == 3, "got Expected Number of Cds"); ok( $formerly->cds->count == 1, "got Expected Number of Cds"); ## Did the cds get expected information? my ($cd1, $cd2) = $girl->cds->search({},{order_by=>'year ASC'}); ok( $cd1->title eq "PK_My First CD", "Got Expected CD Title"); ok( $cd2->title eq "PK_Yet More Tweeny-Pop crap", "Got Expected CD Title"); } BELONGS_TO_NO_PKs: { ## Test from a belongs_to perspective, should create artist first, ## then CD with artistid. This test we let the system automatically ## create the PK's. Chances are good you'll use it this way mostly. my $cds = [ { title => 'Some CD3', year => '1997', artist => { name => 'Fred BloggsC'}, }, { title => 'Some CD4', year => '1997', artist => { name => 'Fred BloggsD'}, }, ]; my ($cdA, $cdB) = $cd_rs->populate($cds); isa_ok($cdA, 'DBICTest::CD', 'Created CD'); isa_ok($cdA->artist, 'DBICTest::Artist', 'Set Artist'); is($cdA->artist->name, 'Fred BloggsC', 'Set Artist to FredC'); isa_ok($cdB, 'DBICTest::CD', 'Created CD'); isa_ok($cdB->artist, 'DBICTest::Artist', 'Set Artist'); is($cdB->artist->name, 'Fred BloggsD', 'Set Artist to FredD'); } BELONGS_TO_WITH_PKs: { ## Test from a belongs_to perspective, should create artist first, ## then CD with artistid. This time we try setting the PK's my $aid = $art_rs->get_column('artistid')->max || 0; my $cds = [ { title => 'Some CD3', year => '1997', artist => { artistid=> ++$aid, name => 'Fred BloggsE'}, }, { title => 'Some CD4', year => '1997', artist => { artistid=> ++$aid, name => 'Fred BloggsF'}, }, ]; my ($cdA, $cdB) = $cd_rs->populate($cds); isa_ok($cdA, 'DBICTest::CD', 'Created CD'); isa_ok($cdA->artist, 'DBICTest::Artist', 'Set Artist'); is($cdA->artist->name, 'Fred BloggsE', 'Set Artist to FredE'); isa_ok($cdB, 'DBICTest::CD', 'Created CD'); isa_ok($cdB->artist, 'DBICTest::Artist', 'Set Artist'); is($cdB->artist->name, 'Fred BloggsF', 'Set Artist to FredF'); ok($cdB->artist->artistid == $aid, "Got Expected Artist ID"); } WITH_COND_FROM_RS: { my ($more_crap) = $restricted_art_rs->populate([ { name => 'More Manufactured Crap', }, ]); ## Did it use the condition in the resultset? $more_crap->discard_changes; cmp_ok( $more_crap->rank, '==', 42, "Got Correct rank for result object"); cmp_ok( $more_crap->charfield, '==', $more_crap->id + 5, "Got Correct charfield for result object"); } } ## ---------------------------------------------------------------------------- ## Void context tests ## ---------------------------------------------------------------------------- VOID_CONTEXT: { ## All these tests check the ability to use populate without asking for ## any returned resultsets. This uses bulk_insert as much as possible ## in order to increase speed. HAS_MANY_WITH_PKS: { ## This first group of tests checks to make sure we can call populate ## with the parent having many children and the parent PK is set my $aid = $art_rs->get_column('artistid')->max || 0; my $first_aid = ++$aid; my $artists = [ { artistid => $first_aid, name => 'VOID_PK_Angsty-Whiny Girl', cds => [ { artist => $first_aid, title => 'VOID_PK_My First CD', year => 2006 }, { artist => $first_aid, title => 'VOID_PK_Yet More Tweeny-Pop crap', year => 2007 }, ], }, { artistid => ++$aid, name => 'VOID_PK_Manufactured Crap', }, { artistid => ++$aid, name => 'VOID_PK_Like I Give a Damn', cds => [ { title => 'VOID_PK_My parents sold me to a record company' ,year => 2005 }, { title => 'VOID_PK_Why Am I So Ugly?', year => 2006 }, { title => 'VOID_PK_I Got Surgery and am now Popular', year => 2007 } ], }, { artistid => ++$aid, name => 'VOID_PK_Formerly Named', cds => [ { title => 'VOID_PK_One Hit Wonder', year => 2006 }, ], }, { artistid => ++$aid, name => undef, cds => [ { title => 'VOID_PK_Zundef test', year => 2006 }, ], }, ]; ## Get the result row objects. $art_rs->populate($artists); my ($undef, $girl, $formerly, $damn, $crap) = $art_rs->search( {name=>[ map { $_->{name} } @$artists]}, {order_by=>'name ASC'}, ); ## Do we have the right object? isa_ok( $crap, 'DBICTest::Artist', "Got 'Artist'"); isa_ok( $girl, 'DBICTest::Artist', "Got 'Artist'"); isa_ok( $damn, 'DBICTest::Artist', "Got 'Artist'"); isa_ok( $formerly, 'DBICTest::Artist', "Got 'Artist'"); isa_ok( $undef, 'DBICTest::Artist', "Got 'Artist'"); ## Find the expected information? ok( $crap->name eq 'VOID_PK_Manufactured Crap', "Got Correct name 'VOID_PK_Manufactured Crap' for result object"); ok( $girl->name eq 'VOID_PK_Angsty-Whiny Girl', "Got Correct name for result object"); ok( $damn->name eq 'VOID_PK_Like I Give a Damn', "Got Correct name for result object"); ok( $formerly->name eq 'VOID_PK_Formerly Named', "Got Correct name for result object"); ok( !defined $undef->name, "Got Correct name 'is undef' for result object"); ## Create the expected children sub objects? ok( $crap->can('cds'), "Has cds relationship"); ok( $girl->can('cds'), "Has cds relationship"); ok( $damn->can('cds'), "Has cds relationship"); ok( $formerly->can('cds'), "Has cds relationship"); ok( $undef->can('cds'), "Has cds relationship"); ok( $crap->cds->count == 0, "got Expected Number of Cds"); ok( $girl->cds->count == 2, "got Expected Number of Cds"); ok( $damn->cds->count == 3, "got Expected Number of Cds"); ok( $formerly->cds->count == 1, "got Expected Number of Cds"); ok( $undef->cds->count == 1, "got Expected Number of Cds"); ## Did the cds get expected information? my ($cd1, $cd2) = $girl->cds->search({},{order_by=>'year ASC'}); ok( $cd1->title eq "VOID_PK_My First CD", "Got Expected CD Title"); ok( $cd2->title eq "VOID_PK_Yet More Tweeny-Pop crap", "Got Expected CD Title"); } BELONGS_TO_WITH_PKs: { ## Test from a belongs_to perspective, should create artist first, ## then CD with artistid. This time we try setting the PK's my $aid = $art_rs->get_column('artistid')->max || 0; my $cds = [ { title => 'Some CD3B', year => '1997', artist => { artistid=> ++$aid, name => 'Fred BloggsCB'}, }, { title => 'Some CD4B', year => '1997', artist => { artistid=> ++$aid, name => 'Fred BloggsDB'}, }, ]; warnings_exist { $cd_rs->populate($cds) } qr/\QFast-path populate() of belongs_to relationship data is not possible/; my ($cdA, $cdB) = $cd_rs->search( {title=>[sort map {$_->{title}} @$cds]}, {order_by=>'title ASC'}, ); isa_ok($cdA, 'DBICTest::CD', 'Created CD'); isa_ok($cdA->artist, 'DBICTest::Artist', 'Set Artist'); is($cdA->artist->name, 'Fred BloggsCB', 'Set Artist to FredCB'); isa_ok($cdB, 'DBICTest::CD', 'Created CD'); isa_ok($cdB->artist, 'DBICTest::Artist', 'Set Artist'); is($cdB->artist->name, 'Fred BloggsDB', 'Set Artist to FredDB'); ok($cdB->artist->artistid == $aid, "Got Expected Artist ID"); } BELONGS_TO_NO_PKs: { ## Test from a belongs_to perspective, should create artist first, ## then CD with artistid. my $cds = [ { title => 'Some CD3BB', year => '1997', artist => { name => 'Fred BloggsCBB'}, }, { title => 'Some CD4BB', year => '1997', artist => { name => 'Fred BloggsDBB'}, }, { title => 'Some CD5BB', year => '1997', artist => { name => undef}, }, ]; warnings_exist { $cd_rs->populate($cds); } qr/\QFast-path populate() of belongs_to relationship data is not possible/; my ($cdA, $cdB, $cdC) = $cd_rs->search( {title=>[sort map {$_->{title}} @$cds]}, {order_by=>'title ASC'}, ); isa_ok($cdA, 'DBICTest::CD', 'Created CD'); isa_ok($cdA->artist, 'DBICTest::Artist', 'Set Artist'); is($cdA->title, 'Some CD3BB', 'Found Expected title'); is($cdA->artist->name, 'Fred BloggsCBB', 'Set Artist to FredCBB'); isa_ok($cdB, 'DBICTest::CD', 'Created CD'); isa_ok($cdB->artist, 'DBICTest::Artist', 'Set Artist'); is($cdB->title, 'Some CD4BB', 'Found Expected title'); is($cdB->artist->name, 'Fred BloggsDBB', 'Set Artist to FredDBB'); isa_ok($cdC, 'DBICTest::CD', 'Created CD'); isa_ok($cdC->artist, 'DBICTest::Artist', 'Set Artist'); is($cdC->title, 'Some CD5BB', 'Found Expected title'); is( $cdC->artist->name, undef, 'Set Artist to something undefined'); } HAS_MANY_NO_PKS: { ## This first group of tests checks to make sure we can call populate ## with the parent having many children and let the keys be automatic my $artists = [ { name => 'VOID_Angsty-Whiny Girl', cds => [ { title => 'VOID_My First CD', year => 2006 }, { title => 'VOID_Yet More Tweeny-Pop crap', year => 2007 }, ], }, { name => 'VOID_Manufactured Crap', }, { name => 'VOID_Like I Give a Damn', cds => [ { title => 'VOID_My parents sold me to a record company' ,year => 2005 }, { title => 'VOID_Why Am I So Ugly?', year => 2006 }, { title => 'VOID_I Got Surgery and am now Popular', year => 2007 } ], }, { name => 'VOID_Formerly Named', cds => [ { title => 'VOID_One Hit Wonder', year => 2006 }, ], }, ]; ## Get the result row objects. $art_rs->populate($artists); my ($girl, $formerly, $damn, $crap) = $art_rs->search( {name=>[sort map {$_->{name}} @$artists]}, {order_by=>'name ASC'}, ); ## Do we have the right object? isa_ok( $crap, 'DBICTest::Artist', "Got 'Artist'"); isa_ok( $girl, 'DBICTest::Artist', "Got 'Artist'"); isa_ok( $damn, 'DBICTest::Artist', "Got 'Artist'"); isa_ok( $formerly, 'DBICTest::Artist', "Got 'Artist'"); ## Find the expected information? ok( $crap->name eq 'VOID_Manufactured Crap', "Got Correct name for result object"); ok( $girl->name eq 'VOID_Angsty-Whiny Girl', "Got Correct name for result object"); ok( $damn->name eq 'VOID_Like I Give a Damn', "Got Correct name for result object"); ok( $formerly->name eq 'VOID_Formerly Named', "Got Correct name for result object"); ## Create the expected children sub objects? ok( $crap->can('cds'), "Has cds relationship"); ok( $girl->can('cds'), "Has cds relationship"); ok( $damn->can('cds'), "Has cds relationship"); ok( $formerly->can('cds'), "Has cds relationship"); ok( $crap->cds->count == 0, "got Expected Number of Cds"); ok( $girl->cds->count == 2, "got Expected Number of Cds"); ok( $damn->cds->count == 3, "got Expected Number of Cds"); ok( $formerly->cds->count == 1, "got Expected Number of Cds"); ## Did the cds get expected information? my ($cd1, $cd2) = $girl->cds->search({},{order_by=>'year ASC'}); ok($cd1, "Got a got CD"); ok($cd2, "Got a got CD"); ok( $cd1->title eq "VOID_My First CD", "Got Expected CD Title"); ok( $cd2->title eq "VOID_Yet More Tweeny-Pop crap", "Got Expected CD Title"); } WITH_COND_FROM_RS: { $restricted_art_rs->populate([ { name => 'VOID More Manufactured Crap', }, ]); my $more_crap = $art_rs->search({ name => 'VOID More Manufactured Crap' })->first; ## Did it use the condition in the resultset? $more_crap->discard_changes; cmp_ok( $more_crap->rank, '==', 42, "Got Correct rank for result object"); cmp_ok( $more_crap->charfield, '==', $more_crap->id + 5, "Got Correct charfield for result object"); } } ARRAYREF_OF_ARRAYREF_STYLE: { $art_rs->populate([ [qw/artistid name/], [1000, 'A Formally Unknown Singer'], [1001, 'A singer that jumped the shark two albums ago'], [1002, 'An actually cool singer.'], ]); ok my $unknown = $art_rs->find(1000), "got Unknown"; ok my $jumped = $art_rs->find(1001), "got Jumped"; ok my $cool = $art_rs->find(1002), "got Cool"; is $unknown->name, 'A Formally Unknown Singer', 'Correct Name'; is $jumped->name, 'A singer that jumped the shark two albums ago', 'Correct Name'; is $cool->name, 'An actually cool singer.', 'Correct Name'; my ($cooler, $lamer) = $restricted_art_rs->populate([ [qw/artistid name/], [1003, 'Cooler'], [1004, 'Lamer'], ]); is $cooler->name, 'Cooler', 'Correct Name'; is $lamer->name, 'Lamer', 'Correct Name'; for ($cooler, $lamer) { $_->discard_changes; cmp_ok( $_->rank, '==', 42, "Got Correct rank for result object"); cmp_ok( $_->charfield, '==', $_->id + 5, "Got Correct charfield for result object"); } ARRAY_CONTEXT_WITH_COND_FROM_RS: { my ($mega_lamer) = $restricted_art_rs->populate([ { name => 'Mega Lamer', }, ]); ## Did it use the condition in the resultset? $mega_lamer->discard_changes; cmp_ok( $mega_lamer->rank, '==', 42, "Got Correct rank for result object"); cmp_ok( $mega_lamer->charfield, '==', $mega_lamer->id + 5, "Got Correct charfield for result object"); } VOID_CONTEXT_WITH_COND_FROM_RS: { $restricted_art_rs->populate([ { name => 'VOID Mega Lamer', }, ]); my $mega_lamer = $art_rs->search({ name => 'VOID Mega Lamer' })->first; ## Did it use the condition in the resultset? cmp_ok( $mega_lamer->rank, '==', 42, "Got Correct rank for result object"); cmp_ok( $mega_lamer->charfield, '==', $mega_lamer->id + 5, "Got Correct charfield for result object"); } } EMPTY_POPULATE: { foreach( [ empty => [] ], [ columns_only => [ [qw(name rank charfield)] ] ], ) { my ($desc, $arg) = @{$_}; $schema->is_executed_sql_bind( sub { my $rs = $art_rs; lives_ok { $rs->populate($arg); 1 } "$desc populate in void context lives"; my @r = $art_rs->populate($arg); is_deeply( \@r, [], "$desc populate in list context returns empty list" ); my $r = $art_rs->populate($arg); is( $r, undef, "$desc populate in scalar context returns undef" ); }, [], "$desc populate executed no statements" ); } } done_testing; ����������������������������DBIx-Class-0.082843/t/51threadnodb.t����������������������������������������������������������������0000644�0001750�0001750�00000003144�14240132261�016010� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use Config; BEGIN { unless ($Config{useithreads}) { print "1..0 # SKIP your perl does not support ithreads\n"; exit 0; } if ($INC{'Devel/Cover.pm'}) { print "1..0 # SKIP Devel::Cover does not work with threads yet\n"; exit 0; } } use threads; use strict; use warnings; use Test::More; use DBIx::Class::_Util 'sigwarn_silencer'; use lib qw(t/lib); use DBICTest; plan skip_all => 'DBIC does not actively support threads before perl 5.8.5' if $] < '5.008005'; plan skip_all => 'Potential problems on Win32 Perl < 5.14 and Variable::Magic - investigation pending' if $^O eq 'MSWin32' && $] < 5.014 && DBICTest::RunMode->is_plain; # README: If you set the env var to a number greater than 10, # we will use that many children my $num_children = $ENV{DBICTEST_THREAD_STRESS} || 1; if($num_children !~ /^[0-9]+$/ || $num_children < 10) { $num_children = 10; } my $schema = DBICTest->init_schema(no_deploy => 1); isa_ok ($schema, 'DBICTest::Schema'); my @threads; SKIP: { local $SIG{__WARN__} = sigwarn_silencer( qr/Thread creation failed/i ); for (1.. $num_children) { push @threads, threads->create(sub { my $rsrc = $schema->source('Artist'); undef $schema; isa_ok ($rsrc->schema, 'DBICTest::Schema'); my $s2 = $rsrc->schema->clone; sleep 1; # without this many tasty crashes }) || do { skip "EAGAIN encountered, your system is likely bogged down: skipping rest of test", 1 if $! == Errno::EAGAIN(); die "Unable to start thread: $!"; }; } } ok(1, "past spawning"); $_->join for @threads; ok(1, "past joining"); done_testing; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/64db.t������������������������������������������������������������������������0000644�0001750�0001750�00000004625�14240140331�014271� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Deep; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); plan tests => 4; # add some rows inside a transaction and commit it # XXX: Is storage->dbh the only way to get a dbh? $schema->storage->txn_begin; for (10..15) { $schema->resultset("Artist")->create( { artistid => $_, name => "artist number $_", } ); } $schema->storage->txn_commit; my ($artist) = $schema->resultset("Artist")->find(15); is($artist->name, 'artist number 15', "Commit ok"); # add some rows inside a transaction and roll it back $schema->storage->txn_begin; for (21..30) { $schema->resultset("Artist")->create( { artistid => $_, name => "artist number $_", } ); } $schema->storage->txn_rollback; ($artist) = $schema->resultset("Artist")->search({ artistid => 25 }); is($artist, undef, "Rollback ok"); is_deeply ( get_storage_column_info ($schema->storage, 'collection', qw/size is_nullable/), { collectionid => { data_type => 'INTEGER', }, name => { data_type => 'varchar', }, }, 'Correctly retrieve column info (no size or is_nullable)' ); { cmp_deeply ( get_storage_column_info ($schema->storage, 'artist', qw/size/), { 'artistid' => { 'data_type' => 'INTEGER', 'is_nullable' => 0, }, 'name' => { 'data_type' => 'varchar', 'is_nullable' => 1, }, 'rank' => { 'data_type' => re(qr/^integer$/i), 'is_nullable' => 0, 'default_value' => '13', }, 'charfield' => { 'data_type' => 'char', 'is_nullable' => 1, }, }, 'Correctly retrieve column info (mixed null and non-null columns)' ); }; # Depending on test we need to strip away certain column info. # - SQLite is known to report the size differently from release to release # - Current DBD::SQLite versions do not implement NULLABLE # - Some SQLite releases report stuff that isn't there as undef sub get_storage_column_info { my ($storage, $table, @ignore) = @_; my $type_info = $storage->columns_info_for($table); for my $col (keys %$type_info) { for my $type (keys %{$type_info->{$col}}) { if ( grep { $type eq $_ } (@ignore) or not defined $type_info->{$col}{$type} ) { delete $type_info->{$col}{$type}; } } } return $type_info; } �����������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/90ensure_class_loaded.t�������������������������������������������������������0000644�0001750�0001750�00000010713�14240132261�017677� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; use DBIx::Class::_Util 'sigwarn_silencer'; use Class::Inspector; BEGIN { package TestPackage::A; sub some_method {} } my $schema = DBICTest->init_schema(); plan tests => 28; # Test ensure_class_found ok( $schema->ensure_class_found('DBIx::Class::Schema'), 'loaded package DBIx::Class::Schema was found' ); ok( !Class::Inspector->loaded('DBICTest::FakeComponent'), 'DBICTest::FakeComponent not loaded yet' ); ok( $schema->ensure_class_found('DBICTest::FakeComponent'), 'package DBICTest::FakeComponent was found' ); ok( !Class::Inspector->loaded('DBICTest::FakeComponent'), 'DBICTest::FakeComponent not loaded by ensure_class_found()' ); ok( $schema->ensure_class_found('TestPackage::A'), 'anonymous package TestPackage::A found' ); ok( !$schema->ensure_class_found('FAKE::WONT::BE::FOUND'), 'fake package not found' ); # Test load_optional_class my $retval = eval { $schema->load_optional_class('ANOTHER::FAKE::PACKAGE') }; ok( !$@, 'load_optional_class on a nonexistent class did not throw' ); ok( !$retval, 'nonexistent package not loaded' ); $retval = eval { $schema->load_optional_class('DBICTest::OptionalComponent') }; ok( !$@, 'load_optional_class on an existing class did not throw' ); ok( $retval, 'DBICTest::OptionalComponent loaded' ); eval { $schema->load_optional_class('DBICTest::ErrorComponent') }; like( $@, qr/did not return a true value/, 'DBICTest::ErrorComponent threw ok' ); # Simulate a PAR environment { my @code; local @INC = @INC; unshift @INC, sub { if ($_[1] eq 'VIRTUAL/PAR/PACKAGE.pm') { return (sub { return 0 unless @code; $_ = shift @code; 1; } ); } else { return (); } }; $retval = eval { $schema->load_optional_class('FAKE::PAR::PACKAGE') }; ok( !$@, 'load_optional_class on a nonexistent PAR class did not throw' ); ok( !$retval, 'nonexistent PAR package not loaded' ); # simulate a class which does load but does not return true @code = ( q/package VIRTUAL::PAR::PACKAGE;/, q/0;/, ); $retval = eval { $schema->load_optional_class('VIRTUAL::PAR::PACKAGE') }; ok( $@, 'load_optional_class of a no-true-returning PAR module did throw' ); ok( !$retval, 'no-true-returning PAR package not loaded' ); # simulate a normal class (no one adjusted %INC so it will be tried again @code = ( q/package VIRTUAL::PAR::PACKAGE;/, q/1;/, ); $retval = eval { $schema->load_optional_class('VIRTUAL::PAR::PACKAGE') }; ok( !$@, 'load_optional_class of a PAR module did not throw' ); ok( $retval, 'PAR package "loaded"' ); # see if we can still load stuff with the coderef present $retval = eval { $schema->load_optional_class('DBIx::Class::ResultClass::HashRefInflator') }; ok( !$@, 'load_optional_class did not throw' ) || diag $@; ok( $retval, 'DBIx::Class::ResultClass::HashRefInflator loaded' ); } # Test ensure_class_loaded ok( Class::Inspector->loaded('TestPackage::A'), 'anonymous package exists' ); eval { $schema->ensure_class_loaded('TestPackage::A'); }; ok( !$@, 'ensure_class_loaded detected an anon. class' ); eval { $schema->ensure_class_loaded('FakePackage::B'); }; like( $@, qr/Can't locate/, 'ensure_class_loaded threw exception for nonexistent class' ); ok( !Class::Inspector->loaded('DBICTest::FakeComponent'), 'DBICTest::FakeComponent not loaded yet' ); eval { $schema->ensure_class_loaded('DBICTest::FakeComponent'); }; ok( !$@, 'ensure_class_loaded detected an existing but non-loaded class' ); ok( Class::Inspector->loaded('DBICTest::FakeComponent'), 'DBICTest::FakeComponent now loaded' ); { # Squash warnings about syntax errors in SytaxErrorComponent.pm local $SIG{__WARN__} = sigwarn_silencer( qr/String found where operator expected|Missing operator before/ ); eval { $schema->ensure_class_loaded('DBICTest::SyntaxErrorComponent1') }; like( $@, qr/syntax error/, 'ensure_class_loaded(DBICTest::SyntaxErrorComponent1) threw ok' ); eval { $schema->load_optional_class('DBICTest::SyntaxErrorComponent2') }; like( $@, qr/syntax error/, 'load_optional_class(DBICTest::SyntaxErrorComponent2) threw ok' ); } eval { package Fake::ResultSet; use base 'DBIx::Class::ResultSet'; __PACKAGE__->load_components('+DBICTest::SyntaxErrorComponent3'); }; # Make sure the errors in components of resultset classes are reported right. like($@, qr!\Qsyntax error at t/lib/DBICTest/SyntaxErrorComponent3.pm!, "Errors from RS components reported right"); 1; �����������������������������������������������������DBIx-Class-0.082843/t/50fork.t����������������������������������������������������������������������0000644�0001750�0001750�00000010051�14240132261�014631� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use lib qw(t/lib); use DBICTest; use DBIx::Class::Optional::Dependencies (); my $main_pid = $$; plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('rdbms_pg') unless DBIx::Class::Optional::Dependencies->req_ok_for ('rdbms_pg'); my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/}; plan skip_all => 'Set $ENV{DBICTEST_PG_DSN}, _USER and _PASS to run this test' . ' (note: creates and drops a table named artist!)' unless ($dsn && $user); # README: If you set the env var to a number greater than 10, # we will use that many children my $num_children = $ENV{DBICTEST_FORK_STRESS} || 1; if($num_children !~ /^[0-9]+$/ || $num_children < 10) { $num_children = 10; } my $schema = DBICTest::Schema->connect($dsn, $user, $pass, { AutoCommit => 1 }); my $parent_rs; eval { my $dbh = $schema->storage->dbh; { local $SIG{__WARN__} = sub {}; eval { $dbh->do("DROP TABLE cd") }; $dbh->do("CREATE TABLE cd (cdid serial PRIMARY KEY, artist INTEGER NOT NULL UNIQUE, title VARCHAR(100) NOT NULL UNIQUE, year VARCHAR(100) NOT NULL, genreid INTEGER, single_track INTEGER);"); } $schema->resultset('CD')->create({ title => 'vacation in antarctica', artist => 123, year => 1901 }); $schema->resultset('CD')->create({ title => 'vacation in antarctica part 2', artist => 456, year => 1901 }); $parent_rs = $schema->resultset('CD')->search({ year => 1901 }); is ($parent_rs->count, 2); }; ok(!$@) or diag "Creation eval failed: $@"; # basic tests { ok ($schema->storage->connected(), 'Parent is connected'); is ($parent_rs->next->id, 1, 'Cursor advanced'); my ($parent_in, $child_out); pipe( $parent_in, $child_out ) or die "Pipe open failed: $!"; my $pid = fork; if(!defined $pid) { die "fork failed: $!"; } if (!$pid) { close $parent_in; #simulate a subtest to not confuse the parent TAP emission my $tb = Test::More->builder; $tb->reset; for (qw/output failure_output todo_output/) { close $tb->$_; open ($tb->$_, '>&', $child_out); } ok(!$schema->storage->connected, "storage->connected() false in child"); for (1,2) { throws_ok { $parent_rs->next } qr/\QMulti-process access attempted while cursor in progress (position 1)/; } $parent_rs->reset; is($parent_rs->next->id, 1, 'Resetting cursor reprepares it within child environment'); done_testing; exit 0; } close $child_out; while (my $ln = <$parent_in>) { print " $ln"; } waitpid( $pid, 0 ); ok(!$?, 'Child subtests passed'); is ($parent_rs->next->id, 2, 'Cursor still intact in parent'); is ($parent_rs->next, undef, 'Cursor exhausted'); } $parent_rs->reset; my @pids; while(@pids < $num_children) { my $pid = fork; if(!defined $pid) { die "fork failed: $!"; } elsif($pid) { push(@pids, $pid); next; } $pid = $$; my $work = sub { my $child_rs = $schema->resultset('CD')->search({ year => 1901 }); my $row = $parent_rs->next; $schema->resultset('CD')->create({ title => "test success $pid", artist => $pid, year => scalar(@pids) }) if($row && $row->get_column('artist') =~ /^(?:123|456)$/); }; # try with and without transactions if ((@pids % 3) == 1) { my $guard = $schema->txn_scope_guard; $work->(); $guard->commit; } elsif ((@pids % 3) == 2) { $schema->txn_do ($work); } else { $work->(); } sleep(3); exit 0; } ok(1, "past forking"); for (@pids) { waitpid($_,0); ok (! $?, "Child $_ exitted cleanly"); }; ok(1, "past waiting"); while(@pids) { my $pid = pop(@pids); my $rs = $schema->resultset('CD')->search({ title => "test success $pid", artist => $pid, year => scalar(@pids) }); is($rs->next->get_column('artist'), $pid, "Child $pid successful"); } ok(1, "Made it to the end"); done_testing; END { $schema->storage->dbh->do("DROP TABLE cd") if ($schema and $main_pid == $$); undef $schema; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/748informix.t�����������������������������������������������������������������0000644�0001750�0001750�00000007360�14240132261�015632� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use DBIx::Class::Optional::Dependencies (); use lib qw(t/lib); use DBICTest; plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_informix') unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_informix'); my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_INFORMIX_${_}" } qw/DSN USER PASS/}; #warn "$dsn $user $pass"; plan skip_all => 'Set $ENV{DBICTEST_INFORMIX_DSN}, _USER and _PASS to run this test' unless $dsn; my $schema = DBICTest::Schema->connect($dsn, $user, $pass, { auto_savepoint => 1 }); my $dbh = $schema->storage->dbh; eval { $dbh->do("DROP TABLE artist") }; $dbh->do("CREATE TABLE artist (artistid SERIAL, name VARCHAR(255), charfield CHAR(10), rank INTEGER DEFAULT 13);"); eval { $dbh->do("DROP TABLE cd") }; $dbh->do(<<EOS); CREATE TABLE cd ( cdid int PRIMARY KEY, artist int, title varchar(255), year varchar(4), genreid int, single_track int ) EOS eval { $dbh->do("DROP TABLE track") }; $dbh->do(<<EOS); CREATE TABLE track ( trackid int, cd int REFERENCES cd(cdid), position int, title varchar(255), last_updated_on date, last_updated_at date, small_dt date ) EOS my $ars = $schema->resultset('Artist'); is ( $ars->count, 0, 'No rows at first' ); # test primary key handling my $new = $ars->create({ name => 'foo' }); ok($new->artistid, "Auto-PK worked"); # test explicit key spec $new = $ars->create ({ name => 'bar', artistid => 66 }); is($new->artistid, 66, 'Explicit PK worked'); $new->discard_changes; is($new->artistid, 66, 'Explicit PK assigned'); # test populate lives_ok (sub { my @pop; for (1..2) { push @pop, { name => "Artist_$_" }; } $ars->populate (\@pop); }); # test populate with explicit key lives_ok (sub { my @pop; for (1..2) { push @pop, { name => "Artist_expkey_$_", artistid => 100 + $_ }; } $ars->populate (\@pop); }); # count what we did so far is ($ars->count, 6, 'Simple count works'); # test LIMIT support my $lim = $ars->search( {}, { rows => 3, offset => 4, order_by => 'artistid' } ); is( $lim->count, 2, 'ROWS+OFFSET count ok' ); is( $lim->all, 2, 'Number of ->all objects matches count' ); # test iterator $lim->reset; is( $lim->next->artistid, 101, "iterator->next ok" ); is( $lim->next->artistid, 102, "iterator->next ok" ); is( $lim->next, undef, "next past end of resultset ok" ); # test savepoints throws_ok { $schema->txn_do(sub { eval { $schema->txn_do(sub { $ars->create({ name => 'in_savepoint' }); die "rolling back savepoint"; }); }; ok ((not $ars->search({ name => 'in_savepoint' })->first), 'savepoint rolled back'); $ars->create({ name => 'in_outer_txn' }); die "rolling back outer txn"; }); } qr/rolling back outer txn/, 'correct exception for rollback'; ok ((not $ars->search({ name => 'in_outer_txn' })->first), 'outer txn rolled back'); ######## test with_deferred_fk_checks lives_ok { $schema->storage->with_deferred_fk_checks(sub { $schema->resultset('Track')->create({ trackid => 999, cd => 999, position => 1, title => 'deferred FK track' }); $schema->resultset('CD')->create({ artist => 1, cdid => 999, year => '2003', title => 'deferred FK cd' }); }); } 'with_deferred_fk_checks code survived'; is eval { $schema->resultset('Track')->find(999)->title }, 'deferred FK track', 'code in with_deferred_fk_checks worked'; throws_ok { $schema->resultset('Track')->create({ trackid => 1, cd => 9999, position => 1, title => 'Track1' }); } qr/constraint/i, 'with_deferred_fk_checks is off'; done_testing; # clean up our mess END { my $dbh = eval { $schema->storage->_dbh }; $dbh->do("DROP TABLE artist") if $dbh; undef $schema; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/05components.t����������������������������������������������������������������0000644�0001750�0001750�00000002017�14240132261�016060� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; use DBICTest::ForeignComponent; # Tests if foreign component was loaded by calling foreign's method ok( DBICTest::ForeignComponent->foreign_test_method, 'foreign component' ); # Test for inject_base to filter out duplicates { package DBICTest::_InjectBaseTest; use base qw/ DBIx::Class /; package DBICTest::_InjectBaseTest::A; package DBICTest::_InjectBaseTest::B; package DBICTest::_InjectBaseTest::C; } DBICTest::_InjectBaseTest->inject_base( 'DBICTest::_InjectBaseTest', qw/ DBICTest::_InjectBaseTest::A DBICTest::_InjectBaseTest::B DBICTest::_InjectBaseTest::B DBICTest::_InjectBaseTest::C /); is_deeply( \@DBICTest::_InjectBaseTest::ISA, [qw/ DBICTest::_InjectBaseTest::A DBICTest::_InjectBaseTest::B DBICTest::_InjectBaseTest::C DBIx::Class /], 'inject_base filters duplicates' ); use_ok('DBIx::Class::AccessorGroup'); use_ok('DBIx::Class::Componentised'); done_testing; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/63register_source.t�����������������������������������������������������������0000644�0001750�0001750�00000000734�14240132261�017107� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::Exception tests => 1; use lib qw(t/lib); use DBICTest; use DBICTest::Schema; use DBIx::Class::ResultSource::Table; my $schema = DBICTest->init_schema(); my $foo = DBIx::Class::ResultSource::Table->new({ name => "foo" }); my $bar = DBIx::Class::ResultSource::Table->new({ name => "bar" }); lives_ok { $schema->register_source(foo => $foo); $schema->register_source(bar => $bar); } 'multiple classless sources can be registered'; ������������������������������������DBIx-Class-0.082843/t/71mysql.t���������������������������������������������������������������������0000644�0001750�0001750�00000032017�14240132261�015046� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use Test::Warn; use DBI::Const::GetInfoType; use Scalar::Util qw/weaken/; use DBIx::Class::Optional::Dependencies (); use lib qw(t/lib); use DBICTest; plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_mysql') unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_mysql'); my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MYSQL_${_}" } qw/DSN USER PASS/}; plan skip_all => 'Set $ENV{DBICTEST_MYSQL_DSN}, _USER and _PASS to run this test' unless ($dsn && $user); my $schema = DBICTest::Schema->connect($dsn, $user, $pass, { quote_names => 1 }); my $dbh = $schema->storage->dbh; $dbh->do("DROP TABLE IF EXISTS artist;"); $dbh->do("CREATE TABLE artist (artistid INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY, name VARCHAR(100), rank INTEGER NOT NULL DEFAULT '13', charfield CHAR(10));"); $dbh->do("DROP TABLE IF EXISTS cd;"); $dbh->do("CREATE TABLE cd (cdid INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY, artist INTEGER, title TEXT, year DATE, genreid INTEGER, single_track INTEGER);"); $dbh->do("DROP TABLE IF EXISTS producer;"); $dbh->do("CREATE TABLE producer (producerid INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY, name TEXT);"); $dbh->do("DROP TABLE IF EXISTS cd_to_producer;"); $dbh->do("CREATE TABLE cd_to_producer (cd INTEGER,producer INTEGER);"); $dbh->do("DROP TABLE IF EXISTS owners;"); $dbh->do("CREATE TABLE owners (id INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY, name VARCHAR(100) NOT NULL);"); $dbh->do("DROP TABLE IF EXISTS books;"); $dbh->do("CREATE TABLE books (id INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY, source VARCHAR(100) NOT NULL, owner integer NOT NULL, title varchar(100) NOT NULL, price integer);"); #'dbi:mysql:host=localhost;database=dbic_test', 'dbic_test', ''); # make sure sqlt_type overrides work (::Storage::DBI::mysql does this) { my $schema = DBICTest::Schema->connect($dsn, $user, $pass); ok (!$schema->storage->_dbh, 'definitely not connected'); is ($schema->storage->sqlt_type, 'MySQL', 'sqlt_type correct pre-connection'); } # This is in Core now, but it's here just to test that it doesn't break $schema->class('Artist')->load_components('PK::Auto'); # test primary key handling my $new = $schema->resultset('Artist')->create({ name => 'foo' }); ok($new->artistid, "Auto-PK worked"); # test LIMIT support for (1..6) { $schema->resultset('Artist')->create({ name => 'Artist ' . $_ }); } my $it = $schema->resultset('Artist')->search( {}, { rows => 3, offset => 2, order_by => 'artistid' } ); is( $it->count, 3, "LIMIT count ok" ); # ask for 3 rows out of 7 artists is( $it->next->name, "Artist 2", "iterator->next ok" ); $it->next; $it->next; is( $it->next, undef, "next past end of resultset ok" ); # Limit with select-lock lives_ok { $schema->txn_do (sub { isa_ok ( $schema->resultset('Artist')->find({artistid => 1}, {for => 'update', rows => 1}), 'DBICTest::Schema::Artist', ); }); } 'Limited FOR UPDATE select works'; # shared-lock lives_ok { $schema->txn_do (sub { isa_ok ( $schema->resultset('Artist')->find({artistid => 1}, {for => 'shared'}), 'DBICTest::Schema::Artist', ); }); } 'LOCK IN SHARE MODE select works'; my $test_type_info = { 'artistid' => { 'data_type' => 'INT', 'is_nullable' => 0, 'size' => 11, 'default_value' => undef, }, 'name' => { 'data_type' => 'VARCHAR', 'is_nullable' => 1, 'size' => 100, 'default_value' => undef, }, 'rank' => { 'data_type' => 'INT', 'is_nullable' => 0, 'size' => 11, 'default_value' => 13, }, 'charfield' => { 'data_type' => 'CHAR', 'is_nullable' => 1, 'size' => 10, 'default_value' => undef, }, }; $schema->populate ('Owners', [ [qw/id name /], [qw/1 wiggle/], [qw/2 woggle/], [qw/3 boggle/], ]); $schema->populate ('BooksInLibrary', [ [qw/source owner title /], [qw/Library 1 secrets1/], [qw/Eatery 1 secrets2/], [qw/Library 2 secrets3/], ]); # # try a distinct + prefetch on tables with identically named columns # (mysql doesn't seem to like subqueries with equally named columns) # { # try a ->has_many direction (due to a 'multi' accessor the select/group_by group is collapsed) my $owners = $schema->resultset ('Owners')->search ( { 'books.id' => { '!=', undef }}, { prefetch => 'books', distinct => 1 } ); my $owners2 = $schema->resultset ('Owners')->search ({ id => { -in => $owners->get_column ('me.id')->as_query }}); for ($owners, $owners2) { is ($_->all, 2, 'Prefetched grouped search returns correct number of rows'); is ($_->count, 2, 'Prefetched grouped search returns correct count'); } # try a ->belongs_to direction (no select collapse) my $books = $schema->resultset ('BooksInLibrary')->search ( { 'owner.name' => 'wiggle' }, { prefetch => 'owner', distinct => 1 } ); my $books2 = $schema->resultset ('BooksInLibrary')->search ({ id => { -in => $books->get_column ('me.id')->as_query }}); for ($books, $books2) { is ($_->all, 1, 'Prefetched grouped search returns correct number of rows'); is ($_->count, 1, 'Prefetched grouped search returns correct count'); } } SKIP: { my $norm_version = $schema->storage->_server_info->{normalized_dbms_version} or skip "Cannot determine MySQL server version", 1; if ($norm_version < 5.000003_01) { $test_type_info->{charfield}->{data_type} = 'VARCHAR'; } my $type_info = $schema->storage->columns_info_for('artist'); is_deeply($type_info, $test_type_info, 'columns_info_for - column data types'); } my $cd = $schema->resultset ('CD')->create ({}); my $producer = $schema->resultset ('Producer')->create ({}); lives_ok { $cd->set_producers ([ $producer ]) } 'set_relationship doesnt die'; { my $artist = $schema->resultset('Artist')->next; my $cd = $schema->resultset('CD')->next; $cd->set_from_related ('artist', $artist); $cd->update; my $rs = $schema->resultset('CD')->search ({}, { prefetch => 'artist' }); lives_ok sub { my $cd = $rs->next; is ($cd->artist->name, $artist->name, 'Prefetched artist'); }, 'join does not throw (mysql 3 test)'; } ## Can we properly deal with the null search problem? ## ## Only way is to do a SET SQL_AUTO_IS_NULL = 0; on connect ## But I'm not sure if we should do this or not (Ash, 2008/06/03) # # There is now a built-in function to do this, test that everything works # with it (ribasushi, 2009/07/03) NULLINSEARCH: { my $ansi_schema = DBICTest::Schema->connect ($dsn, $user, $pass, { on_connect_call => 'set_strict_mode' }); $ansi_schema->resultset('Artist')->create ({ name => 'last created artist' }); ok my $artist1_rs = $ansi_schema->resultset('Artist')->search({artistid=>6666}) => 'Created an artist resultset of 6666'; is $artist1_rs->count, 0 => 'Got no returned rows'; ok my $artist2_rs = $ansi_schema->resultset('Artist')->search({artistid=>undef}) => 'Created an artist resultset of undef'; is $artist2_rs->count, 0 => 'got no rows'; my $artist = $artist2_rs->single; is $artist => undef, => 'Nothing Found!'; } # check for proper grouped counts { my $ansi_schema = DBICTest::Schema->connect ($dsn, $user, $pass, { on_connect_call => 'set_strict_mode', quote_char => '`', }); my $rs = $ansi_schema->resultset('CD'); my $years; $years->{$_->year|| scalar keys %$years}++ for $rs->all; # NULL != NULL, thus the keys eval lives_ok ( sub { is ( $rs->search ({}, { group_by => 'year'})->count, scalar keys %$years, 'grouped count correct', ); }, 'Grouped count does not throw'); lives_ok( sub { $ansi_schema->resultset('Owners')->search({}, { join => 'books', group_by => [ 'me.id', 'books.id' ] })->count(); }, 'count on grouped columns with the same name does not throw'); } # a more contrived^Wcomplicated self-referential double-subquery test { my $rs = $schema->resultset('Artist')->search({ name => { -like => 'baby_%' } }); $rs->populate([map { [$_] } ('name', map { "baby_$_" } (1..10) ) ]); my ($count_sql, @count_bind) = @${$rs->count_rs->as_query}; my $complex_rs = $schema->resultset('Artist')->search( { artistid => { -in => $rs->get_column('artistid') ->as_query } }, ); $complex_rs->update({ name => \[ "CONCAT( `name`, '_bell_out_of_', $count_sql )", @count_bind ] }); for (1..10) { is ( $schema->resultset('Artist')->search({ name => "baby_${_}_bell_out_of_10" })->count, 1, "Correctly updated babybell $_", ); } is ($rs->count, 10, '10 artists present'); $schema->is_executed_querycount( sub { $complex_rs->delete; }, 1, 'One delete query fired' ); is ($rs->count, 0, '10 Artists correctly deleted'); $rs->create({ name => 'baby_with_cd', cds => [ { title => 'babeeeeee', year => 2013 } ], }); is ($rs->count, 1, 'Artist with cd created'); $schema->is_executed_querycount( sub { $schema->resultset('CD')->search_related('artist', { 'artist.name' => { -like => 'baby_with_%' } } )->delete; }, 1, 'And one more delete query fired'); is ($rs->count, 0, 'Artist with cd deleted'); } ZEROINSEARCH: { my $cds_per_year = { 2001 => 2, 2002 => 1, 2005 => 3, }; my $rs = $schema->resultset ('CD'); $rs->delete; for my $y (keys %$cds_per_year) { for my $c (1 .. $cds_per_year->{$y} ) { $rs->create ({ title => "CD $y-$c", artist => 1, year => "$y-01-01" }); } } is ($rs->count, 6, 'CDs created successfully'); $rs = $rs->search ({}, { select => [ \ 'YEAR(year)' ], as => ['y'], distinct => 1, }); my $y_rs = $rs->get_column ('y'); warnings_exist { is_deeply ( [ sort ($y_rs->all) ], [ sort keys %$cds_per_year ], 'Years group successfully', ) } qr/ \QUse of distinct => 1 while selecting anything other than a column \E \Qdeclared on the primary ResultSource is deprecated\E /x, 'deprecation warning'; $rs->create ({ artist => 1, year => '0-1-1', title => 'Jesus Rap' }); is_deeply ( [ sort $y_rs->all ], [ 0, sort keys %$cds_per_year ], 'Zero-year groups successfully', ); # convoluted search taken verbatim from list my $restrict_rs = $rs->search({ -and => [ year => { '!=', 0 }, year => { '!=', undef } ]}); warnings_exist { is_deeply ( [ sort $restrict_rs->get_column('y')->all ], [ sort $y_rs->all ], 'Zero year was correctly excluded from resultset', ) } qr/ \QUse of distinct => 1 while selecting anything other than a column \E \Qdeclared on the primary ResultSource is deprecated\E /x, 'deprecation warning'; } # make sure find hooks determine driver { my $schema = DBICTest::Schema->connect($dsn, $user, $pass); $schema->resultset("Artist")->find(4); isa_ok($schema->storage->sql_maker, 'DBIx::Class::SQLMaker::MySQL'); } # make sure the mysql_auto_reconnect buggery is avoided { local $ENV{MOD_PERL} = 'boogiewoogie'; my $schema = DBICTest::Schema->connect($dsn, $user, $pass); ok (! $schema->storage->_get_dbh->{mysql_auto_reconnect}, 'mysql_auto_reconnect unset regardless of ENV' ); # Make sure hardcore forking action still works even if mysql_auto_reconnect # is true (test inspired by ether) my $schema_autorecon = DBICTest::Schema->connect($dsn, $user, $pass, { mysql_auto_reconnect => 1 }); my $orig_dbh = $schema_autorecon->storage->_get_dbh; weaken $orig_dbh; ok ($orig_dbh, 'Got weak $dbh ref'); ok ($orig_dbh->{mysql_auto_reconnect}, 'mysql_auto_reconnect is properly set if explicitly requested' ); my $rs = $schema_autorecon->resultset('Artist'); my ($parent_in, $child_out); pipe( $parent_in, $child_out ) or die "Pipe open failed: $!"; my $pid = fork(); if (! defined $pid ) { die "fork() failed: $!" } elsif ($pid) { close $child_out; # sanity check $schema_autorecon->storage->dbh_do(sub { is ($_[1], $orig_dbh, 'Storage holds correct $dbh in parent'); }); # kill our $dbh $schema_autorecon->storage->_dbh(undef); { local $TODO = "Perl $] is known to leak like a sieve" if DBIx::Class::_ENV_::PEEPEENESS; ok (! defined $orig_dbh, 'Parent $dbh handle is gone'); } } else { close $parent_in; #simulate a subtest to not confuse the parent TAP emission my $tb = Test::More->builder; $tb->reset; for (qw/output failure_output todo_output/) { close $tb->$_; open ($tb->$_, '>&', $child_out); } # wait for parent to kill its $dbh sleep 1; # try to do something dbic-esque $rs->create({ name => "Hardcore Forker $$" }); { local $TODO = "Perl $] is known to leak like a sieve" if DBIx::Class::_ENV_::PEEPEENESS; ok (! defined $orig_dbh, 'DBIC operation triggered reconnect - old $dbh is gone'); } done_testing; exit 0; } while (my $ln = <$parent_in>) { print " $ln"; } wait; ok(!$?, 'Child subtests passed'); ok ($rs->find({ name => "Hardcore Forker $pid" }), 'Expected row created'); } done_testing; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/86sqlt.t����������������������������������������������������������������������0000644�0001750�0001750�00000042112�14240132261�014667� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Warn; use lib qw(t/lib); use DBICTest; use Scalar::Util 'blessed'; BEGIN { require DBIx::Class; plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('deploy') unless DBIx::Class::Optional::Dependencies->req_ok_for ('deploy') } my $custom_deployment_statements_called = 0; sub DBICTest::Schema::deployment_statements { $custom_deployment_statements_called = 1; my $self = shift; return $self->next::method(@_); } # Check deployment statements ctx sensitivity { my $schema = DBICTest->init_schema (no_deploy => 1, quote_names => 1); my $not_first_table_creation_re = qr/CREATE TABLE "fourkeys_to_twokeys"/; my $statements = $schema->deployment_statements; like ( $statements, $not_first_table_creation_re, 'All create statements returned in 1 string in scalar ctx' ); my @statements = $schema->deployment_statements; cmp_ok (scalar @statements, '>', 1, 'Multiple statement lines in array ctx'); my $i = 0; while ($i <= $#statements) { last if $statements[$i] =~ $not_first_table_creation_re; $i++; } ok ( ($i > 0) && ($i <= $#statements), "Creation statement was found somewherere within array ($i)" ); } { # use our own throw-away schema, since we'll be deploying twice my $schema = DBICTest->init_schema (no_deploy => 1); my $deploy_hook_called = 0; $custom_deployment_statements_called = 0; # add a temporary sqlt_deploy_hook to a source local $DBICTest::Schema::Track::hook_cb = sub { my ($class, $sqlt_table) = @_; $deploy_hook_called = 1; is ($class, 'DBICTest::Track', 'Result class passed to plain hook'); is ( $sqlt_table->schema->translator->producer_type, join ('::', 'SQL::Translator::Producer', $schema->storage->sqlt_type), 'Production type passed to translator object', ); }; my $component_deploy_hook_called = 0; local $DBICTest::DeployComponent::hook_cb = sub { $component_deploy_hook_called = 1; }; $schema->deploy; # do not remove, this fires the is() test in the callback above ok($deploy_hook_called, 'deploy hook got called'); ok($custom_deployment_statements_called, '->deploy used the schemas deploy_statements method'); ok($component_deploy_hook_called, 'component deploy hook got called'); } my $schema = DBICTest->init_schema (no_deploy => 1); { my $deploy_hook_called = 0; $custom_deployment_statements_called = 0; my $sqlt_type = $schema->storage->sqlt_type; # replace the sqlt calback with a custom version ading an index $schema->source('Track')->sqlt_deploy_callback(sub { my ($self, $sqlt_table) = @_; $deploy_hook_called = 1; is ( $sqlt_table->schema->translator->producer_type, join ('::', 'SQL::Translator::Producer', $sqlt_type), 'Production type passed to translator object', ); if ($sqlt_type eq 'SQLite' ) { $sqlt_table->add_index( name => 'track_title', fields => ['title'] ) or die $sqlt_table->error; } $self->default_sqlt_deploy_hook($sqlt_table); }); $schema->deploy; # do not remove, this fires the is() test in the callback above ok($deploy_hook_called, 'deploy hook got called'); ok($custom_deployment_statements_called, '->deploy used the schemas deploy_statements method'); } my $translator = SQL::Translator->new( parser_args => { dbic_schema => $schema, }, producer_args => {}, ); warnings_exist { my $relinfo = $schema->source('Artist')->relationship_info ('cds'); local $relinfo->{attrs}{on_delete} = 'restrict'; $translator->parser('SQL::Translator::Parser::DBIx::Class'); $translator->producer('SQLite'); my $output = $translator->translate(); ok($output, "SQLT produced someoutput") or diag($translator->error); } [ (qr/SQLT attribute .+? was supplied for relationship .+? which does not appear to be a foreign constraint/) x 2 ], 'Warn about dubious on_delete/on_update attributes'; # Note that the constraints listed here are the only ones that are tested -- if # more exist in the Schema than are listed here and all listed constraints are # correct, the test will still pass. If you add a class with UNIQUE or FOREIGN # KEY constraints to DBICTest::Schema, add tests here if you think the existing # test coverage is not sufficient my %fk_constraints = ( # TwoKeys twokeys => [ { 'display' => 'twokeys->cd', 'name' => 'twokeys_fk_cd', 'index_name' => 'twokeys_idx_cd', 'selftable' => 'twokeys', 'foreigntable' => 'cd', 'selfcols' => ['cd'], 'foreigncols' => ['cdid'], 'noindex' => 1, on_delete => '', on_update => '', deferrable => 0, }, { 'display' => 'twokeys->artist', 'name' => 'twokeys_fk_artist', 'index_name' => 'twokeys_idx_artist', 'selftable' => 'twokeys', 'foreigntable' => 'artist', 'selfcols' => ['artist'], 'foreigncols' => ['artistid'], on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1, }, ], # FourKeys_to_TwoKeys fourkeys_to_twokeys => [ { 'display' => 'fourkeys_to_twokeys->twokeys', 'name' => 'fourkeys_to_twokeys_fk_t_artist_t_cd', 'index_name' => 'fourkeys_to_twokeys_idx_t_artist_t_cd', 'selftable' => 'fourkeys_to_twokeys', 'foreigntable' => 'twokeys', 'selfcols' => ['t_artist', 't_cd'], 'foreigncols' => ['artist', 'cd'], on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1, }, { 'display' => 'fourkeys_to_twokeys->fourkeys', 'index_name' => 'fourkeys_to_twokeys_idx_f_foo_f_bar_f_hello_f_goodbye', 'name' => 'fourkeys_to_twokeys_fk_f_foo_f_bar_f_hello_f_goodbye', 'selftable' => 'fourkeys_to_twokeys', 'foreigntable' => 'fourkeys', 'selfcols' => [qw(f_foo f_bar f_hello f_goodbye)], 'foreigncols' => [qw(foo bar hello goodbye)], on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1, }, ], # CD_to_Producer cd_to_producer => [ { 'display' => 'cd_to_producer->cd', 'name' => 'cd_to_producer_fk_cd', 'index_name' => 'cd_to_producer_idx_cd', 'selftable' => 'cd_to_producer', 'foreigntable' => 'cd', 'selfcols' => ['cd'], 'foreigncols' => ['cdid'], on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1, }, { 'display' => 'cd_to_producer->producer', 'name' => 'cd_to_producer_fk_producer', 'index_name' => 'cd_to_producer_idx_producer', 'selftable' => 'cd_to_producer', 'foreigntable' => 'producer', 'selfcols' => ['producer'], 'foreigncols' => ['producerid'], on_delete => '', on_update => '', deferrable => 1, }, ], # Self_ref_alias self_ref_alias => [ { 'display' => 'self_ref_alias->self_ref for self_ref', 'name' => 'self_ref_alias_fk_self_ref', 'index_name' => 'self_ref_alias_idx_self_ref', 'selftable' => 'self_ref_alias', 'foreigntable' => 'self_ref', 'selfcols' => ['self_ref'], 'foreigncols' => ['id'], on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1, }, { 'display' => 'self_ref_alias->self_ref for alias', 'name' => 'self_ref_alias_fk_alias', 'index_name' => 'self_ref_alias_idx_alias', 'selftable' => 'self_ref_alias', 'foreigntable' => 'self_ref', 'selfcols' => ['alias'], 'foreigncols' => ['id'], on_delete => '', on_update => '', deferrable => 1, }, ], # CD cd => [ { 'display' => 'cd->artist', 'name' => 'cd_fk_artist', 'index_name' => 'cd_idx_artist', 'selftable' => 'cd', 'foreigntable' => 'artist', 'selfcols' => ['artist'], 'foreigncols' => ['artistid'], on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1, }, ], # Artist_undirected_map artist_undirected_map => [ { 'display' => 'artist_undirected_map->artist for id1', 'name' => 'artist_undirected_map_fk_id1', 'index_name' => 'artist_undirected_map_idx_id1', 'selftable' => 'artist_undirected_map', 'foreigntable' => 'artist', 'selfcols' => ['id1'], 'foreigncols' => ['artistid'], on_delete => 'RESTRICT', on_update => 'CASCADE', deferrable => 1, }, { 'display' => 'artist_undirected_map->artist for id2', 'name' => 'artist_undirected_map_fk_id2', 'index_name' => 'artist_undirected_map_idx_id2', 'selftable' => 'artist_undirected_map', 'foreigntable' => 'artist', 'selfcols' => ['id2'], 'foreigncols' => ['artistid'], on_delete => '', on_update => '', deferrable => 1, }, ], # Track track => [ { 'display' => 'track->cd', 'name' => 'track_fk_cd', 'index_name' => 'track_idx_cd', 'selftable' => 'track', 'foreigntable' => 'cd', 'selfcols' => ['cd'], 'foreigncols' => ['cdid'], on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1, }, ], # TreeLike treelike => [ { 'display' => 'treelike->treelike for parent', 'name' => 'treelike_fk_parent', 'index_name' => 'treelike_idx_parent', 'selftable' => 'treelike', 'foreigntable' => 'treelike', 'selfcols' => ['parent'], 'foreigncols' => ['id'], on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1, }, ], # TwoKeyTreeLike twokeytreelike => [ { 'display' => 'twokeytreelike->twokeytreelike for parent1,parent2', 'name' => 'twokeytreelike_fk_parent1_parent2', 'index_name' => 'twokeytreelike_idx_parent1_parent2', 'selftable' => 'twokeytreelike', 'foreigntable' => 'twokeytreelike', 'selfcols' => ['parent1', 'parent2'], 'foreigncols' => ['id1','id2'], on_delete => '', on_update => '', deferrable => 1, }, ], # Tags tags => [ { 'display' => 'tags->cd', 'name' => 'tags_fk_cd', 'index_name' => 'tags_idx_cd', 'selftable' => 'tags', 'foreigntable' => 'cd', 'selfcols' => ['cd'], 'foreigncols' => ['cdid'], on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1, }, ], # Bookmark bookmark => [ { 'display' => 'bookmark->link', 'name' => 'bookmark_fk_link', 'index_name' => 'bookmark_idx_link', 'selftable' => 'bookmark', 'foreigntable' => 'link', 'selfcols' => ['link'], 'foreigncols' => ['id'], on_delete => 'SET NULL', on_update => 'CASCADE', deferrable => 1, }, ], # ForceForeign forceforeign => [ { 'display' => 'forceforeign->artist', 'name' => 'forceforeign_fk_artist', 'index_name' => 'forceforeign_idx_artist', 'selftable' => 'forceforeign', 'foreigntable' => 'artist', 'selfcols' => ['artist'], 'foreigncols' => ['artistid'], 'noindex' => 1, on_delete => '', on_update => '', deferrable => 1, }, ], ); my %unique_constraints = ( # CD cd => [ { 'display' => 'cd artist and title unique', 'name' => 'cd_artist_title', 'table' => 'cd', 'cols' => ['artist', 'title'], }, ], # Producer producer => [ { 'display' => 'producer name unique', 'name' => 'prod_name', # explicit name 'table' => 'producer', 'cols' => ['name'], }, ], # TwoKeyTreeLike twokeytreelike => [ { 'display' => 'twokeytreelike name unique', 'name' => 'tktlnameunique', # explicit name 'table' => 'twokeytreelike', 'cols' => ['name'], }, ], # Employee # Constraint is commented out in DBICTest/Schema/Employee.pm # employee => [ # { # 'display' => 'employee position and group_id unique', # 'name' => 'position_group', # 'table' => 'employee', cols => ['position', 'group_id'], # }, # ], ); my %indexes = ( artist => [ { 'fields' => ['name'] }, ], track => [ { 'fields' => ['title'] } ], ); my $tschema = $translator->schema(); # Test that the $schema->sqlt_deploy_hook was called okay and that it removed # the 'dummy' table ok( !defined($tschema->get_table('dummy')), "Dummy table was removed by hook"); # Test that the Artist resultsource sqlt_deploy_hook was called okay and added # an index SKIP: { skip ('Artist sqlt_deploy_hook is only called with an SQLite backend', 1) if $schema->storage->sqlt_type ne 'SQLite'; ok( ( grep { $_->name eq 'artist_name_hookidx' } $tschema->get_table('artist')->get_indices ), 'sqlt_deploy_hook fired within a resultsource'); } # Test that nonexistent constraints are not found my $constraint = get_constraint('FOREIGN KEY', 'cd', ['title'], 'cd', ['year']); ok( !defined($constraint), 'nonexistent FOREIGN KEY constraint not found' ); $constraint = get_constraint('UNIQUE', 'cd', ['artist']); ok( !defined($constraint), 'nonexistent UNIQUE constraint not found' ); $constraint = get_constraint('FOREIGN KEY', 'forceforeign', ['cd'], 'cd', ['cdid']); ok( !defined($constraint), 'forced nonexistent FOREIGN KEY constraint not found' ); for my $expected_constraints (keys %fk_constraints) { for my $expected_constraint (@{ $fk_constraints{$expected_constraints} }) { my $desc = $expected_constraint->{display}; my $constraint = get_constraint( 'FOREIGN KEY', $expected_constraint->{selftable}, $expected_constraint->{selfcols}, $expected_constraint->{foreigntable}, $expected_constraint->{foreigncols}, ); ok( defined($constraint), "FOREIGN KEY constraint matching `$desc' found" ); test_fk($expected_constraint, $constraint); } } for my $expected_constraints (keys %unique_constraints) { for my $expected_constraint (@{ $unique_constraints{$expected_constraints} }) { my $desc = $expected_constraint->{display}; my $constraint = get_constraint( 'UNIQUE', $expected_constraint->{table}, $expected_constraint->{cols}, ); ok( defined($constraint), "UNIQUE constraint matching `$desc' found" ); test_unique($expected_constraint, $constraint); } } for my $table_index (keys %indexes) { for my $expected_index ( @{ $indexes{$table_index} } ) { ok ( get_index($table_index, $expected_index), "Got a matching index on $table_index table"); } } # Returns the Constraint object for the specified constraint type, table and # columns from the SQL::Translator schema, or undef if no matching constraint # is found. # # NB: $type is either 'FOREIGN KEY' or 'UNIQUE'. In UNIQUE constraints the last # two parameters are not used. sub get_constraint { my ($type, $table_name, $cols, $f_table, $f_cols) = @_; $f_table ||= ''; # For UNIQUE constraints, reference_table is '' $f_cols ||= []; my $table = $tschema->get_table($table_name); my %fields = map { $_ => 1 } @$cols; my %f_fields = map { $_ => 1 } @$f_cols; die "No $table_name" unless $table; CONSTRAINT: for my $constraint ( $table->get_constraints ) { next unless $constraint->type eq $type; next unless $constraint->reference_table eq $f_table; my %rev_fields = map { $_ => 1 } $constraint->fields; my %rev_f_fields = map { $_ => 1 } $constraint->reference_fields; # Check that the given fields are a subset of the constraint's fields for my $field ($constraint->fields) { next CONSTRAINT unless $fields{$field}; } if ($type eq 'FOREIGN KEY') { for my $f_field ($constraint->reference_fields) { next CONSTRAINT unless $f_fields{$f_field}; } } # Check that the constraint's fields are a subset of the given fields for my $field (@$cols) { next CONSTRAINT unless $rev_fields{$field}; } if ($type eq 'FOREIGN KEY') { for my $f_field (@$f_cols) { next CONSTRAINT unless $rev_f_fields{$f_field}; } } return $constraint; # everything passes, found the constraint } return undef; # didn't find a matching constraint } sub get_index { my ($table_name, $index) = @_; my $table = $tschema->get_table($table_name); CAND_INDEX: for my $cand_index ( $table->get_indices ) { next CAND_INDEX if $index->{name} && $cand_index->name ne $index->{name} || $index->{type} && $cand_index->type ne $index->{type}; my %idx_fields = map { $_ => 1 } $cand_index->fields; for my $field ( @{ $index->{fields} } ) { next CAND_INDEX unless $idx_fields{$field}; } %idx_fields = map { $_ => 1 } @{$index->{fields}}; for my $field ( $cand_index->fields) { next CAND_INDEX unless $idx_fields{$field}; } return $cand_index; } return undef; # No matching idx } # Test parameters in a FOREIGN KEY constraint other than columns sub test_fk { my ($expected, $got) = @_; my $desc = $expected->{display}; is( $got->name, $expected->{name}, "name parameter correct for '$desc'" ); is( $got->on_delete, $expected->{on_delete}, "on_delete parameter correct for '$desc'" ); is( $got->on_update, $expected->{on_update}, "on_update parameter correct for '$desc'" ); is( $got->deferrable, $expected->{deferrable}, "is_deferrable parameter correct for '$desc'" ); my $index = get_index( $got->table, { fields => $expected->{selfcols} } ); if ($expected->{noindex}) { ok( !defined $index, "index doesn't for '$desc'" ); } else { ok( defined $index, "index exists for '$desc'" ); is( $index->name, $expected->{index_name}, "index has correct name for '$desc'" ); } } sub test_unique { my ($expected, $got) = @_; my $desc = $expected->{display}; is( $got->name, $expected->{name}, "name parameter correct for '$desc'" ); } done_testing; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/63register_column.t�����������������������������������������������������������0000644�0001750�0001750�00000000336�14240132261�017102� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; use Test::Exception; use lib qw(t/lib); use DBICTest; lives_ok { DBICTest::Schema->load_classes('PunctuatedColumnName') } 'registered columns with weird names'; done_testing; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/746sybase.t�������������������������������������������������������������������0000644�0001750�0001750�00000042473�14240132261�015267� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; no warnings 'uninitialized'; use Test::More; use Test::Exception; use DBIx::Class::Optional::Dependencies (); use lib qw(t/lib); use DBICTest; my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_SYBASE_${_}" } qw/DSN USER PASS/}; if (not ($dsn && $user)) { plan skip_all => join ' ', 'Set $ENV{DBICTEST_SYBASE_DSN}, _USER and _PASS to run this test.', 'Warning: This test drops and creates the tables:', "'artist', 'money_test' and 'bindtype_test'", ; }; plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_ase') unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_ase'); my @storage_types = ( 'DBI::Sybase::ASE', 'DBI::Sybase::ASE::NoBindVars', ); eval "require DBIx::Class::Storage::$_;" for @storage_types; my $schema; my $storage_idx = -1; sub get_schema { DBICTest::Schema->connect($dsn, $user, $pass, { on_connect_call => [ [ blob_setup => log_on_update => 1 ], # this is a safer option ], }); } my $ping_count = 0; { my $ping = DBIx::Class::Storage::DBI::Sybase::ASE->can('_ping'); *DBIx::Class::Storage::DBI::Sybase::ASE::_ping = sub { $ping_count++; goto $ping; }; } for my $storage_type (@storage_types) { $storage_idx++; unless ($storage_type eq 'DBI::Sybase::ASE') { # autodetect DBICTest::Schema->storage_type("::$storage_type"); } $schema = get_schema(); $schema->storage->ensure_connected; if ($storage_idx == 0 && $schema->storage->isa('DBIx::Class::Storage::DBI::Sybase::ASE::NoBindVars')) { # no placeholders in this version of Sybase or DBD::Sybase (or using FreeTDS) skip "Skipping entire test for $storage_type - no placeholder support", 1; next; } isa_ok( $schema->storage, "DBIx::Class::Storage::$storage_type" ); $schema->storage->_dbh->disconnect; lives_ok (sub { $schema->storage->dbh }, 'reconnect works'); $schema->storage->dbh_do (sub { my ($storage, $dbh) = @_; eval { $dbh->do("DROP TABLE artist") }; $dbh->do(<<'SQL'); CREATE TABLE artist ( artistid INT IDENTITY PRIMARY KEY, name VARCHAR(100), rank INT DEFAULT 13 NOT NULL, charfield CHAR(10) NULL ) SQL }); my %seen_id; # so we start unconnected $schema->storage->disconnect; # test primary key handling my $new = $schema->resultset('Artist')->create({ name => 'foo' }); like $new->artistid, qr/^\d+\z/, 'Auto-PK returned a number'; ok($new->artistid > 0, "Auto-PK worked"); $seen_id{$new->artistid}++; # check redispatch to storage-specific insert when auto-detected storage if ($storage_type eq 'DBI::Sybase::ASE') { DBICTest::Schema->storage_type('::DBI'); $schema = get_schema(); } $new = $schema->resultset('Artist')->create({ name => 'Artist 1' }); is ( $seen_id{$new->artistid}, undef, 'id for Artist 1 is unique' ); $seen_id{$new->artistid}++; # inserts happen in a txn, so we make sure it still works inside a txn too $schema->txn_begin; for (2..6) { $new = $schema->resultset('Artist')->create({ name => 'Artist ' . $_ }); is ( $seen_id{$new->artistid}, undef, "id for Artist $_ is unique" ); $seen_id{$new->artistid}++; } $schema->txn_commit; # test simple count is ($schema->resultset('Artist')->count, 7, 'count(*) of whole table ok'); # test LIMIT support my $it = $schema->resultset('Artist')->search({ artistid => { '>' => 0 } }, { rows => 3, order_by => 'artistid', }); is( $it->count, 3, "LIMIT count ok" ); is( $it->next->name, "foo", "iterator->next ok" ); $it->next; is( $it->next->name, "Artist 2", "iterator->next ok" ); is( $it->next, undef, "next past end of resultset ok" ); # now try with offset $it = $schema->resultset('Artist')->search({}, { rows => 3, offset => 3, order_by => 'artistid', }); is( $it->count, 3, "LIMIT with offset count ok" ); is( $it->next->name, "Artist 3", "iterator->next ok" ); $it->next; is( $it->next->name, "Artist 5", "iterator->next ok" ); is( $it->next, undef, "next past end of resultset ok" ); # now try a grouped count $schema->resultset('Artist')->create({ name => 'Artist 6' }) for (1..6); $it = $schema->resultset('Artist')->search({}, { group_by => 'name' }); is( $it->count, 7, 'COUNT of GROUP_BY ok' ); # do an IDENTITY_INSERT { no warnings 'redefine'; my @debug_out; local $schema->storage->{debug} = 1; local $schema->storage->debugobj->{callback} = sub { push @debug_out, $_[1]; }; my $txn_used = 0; my $txn_commit = \&DBIx::Class::Storage::DBI::txn_commit; local *DBIx::Class::Storage::DBI::txn_commit = sub { $txn_used = 1; goto &$txn_commit; }; $schema->resultset('Artist') ->create({ artistid => 999, name => 'mtfnpy' }); ok((grep /IDENTITY_INSERT/i, @debug_out), 'IDENTITY_INSERT used'); SKIP: { skip 'not testing lack of txn on IDENTITY_INSERT with NoBindVars', 1 if $storage_type =~ /NoBindVars/i; is $txn_used, 0, 'no txn on insert with IDENTITY_INSERT'; } } # do an IDENTITY_UPDATE { my @debug_out; local $schema->storage->{debug} = 1; local $schema->storage->debugobj->{callback} = sub { push @debug_out, $_[1]; }; lives_and { $schema->resultset('Artist') ->find(999)->update({ artistid => 555 }); ok((grep /IDENTITY_UPDATE/i, @debug_out)); } 'IDENTITY_UPDATE used'; $ping_count-- if $@; } my $bulk_rs = $schema->resultset('Artist')->search({ name => { -like => 'bulk artist %' } }); # test _insert_bulk using populate. SKIP: { skip '_insert_bulk not supported', 4 unless $storage_type !~ /NoBindVars/i; lives_ok { $schema->resultset('Artist')->populate([ { name => 'bulk artist 1', charfield => 'foo', }, { name => 'bulk artist 2', charfield => 'foo', }, { name => 'bulk artist 3', charfield => 'foo', }, ]); } '_insert_bulk via populate'; is $bulk_rs->count, 3, 'correct number inserted via _insert_bulk'; is ((grep $_->charfield eq 'foo', $bulk_rs->all), 3, 'column set correctly via _insert_bulk'); my %bulk_ids; @bulk_ids{map $_->artistid, $bulk_rs->all} = (); is ((scalar keys %bulk_ids), 3, 'identities generated correctly in _insert_bulk'); $bulk_rs->delete; } # make sure _insert_bulk works a second time on the same connection SKIP: { skip '_insert_bulk not supported', 3 unless $storage_type !~ /NoBindVars/i; lives_ok { $schema->resultset('Artist')->populate([ { name => 'bulk artist 1', charfield => 'bar', }, { name => 'bulk artist 2', charfield => 'bar', }, { name => 'bulk artist 3', charfield => 'bar', }, ]); } '_insert_bulk via populate called a second time'; is $bulk_rs->count, 3, 'correct number inserted via _insert_bulk'; is ((grep $_->charfield eq 'bar', $bulk_rs->all), 3, 'column set correctly via _insert_bulk'); $bulk_rs->delete; } # test invalid _insert_bulk (missing required column) # throws_ok { $schema->resultset('Artist')->populate([ { charfield => 'foo', } ]); } # The second pattern is the error from fallback to regular array insert on # incompatible charset. # The third is for ::NoBindVars with no syb_has_blk. qr/ \Qno value or default\E | \Qdoes not allow null\E | \QUnable to invoke fast-path insert without storage placeholder support\E /xi, '_insert_bulk with missing required column throws error'; # now test _insert_bulk with IDENTITY_INSERT SKIP: { skip '_insert_bulk not supported', 3 unless $storage_type !~ /NoBindVars/i; lives_ok { $schema->resultset('Artist')->populate([ { artistid => 2001, name => 'bulk artist 1', charfield => 'foo', }, { artistid => 2002, name => 'bulk artist 2', charfield => 'foo', }, { artistid => 2003, name => 'bulk artist 3', charfield => 'foo', }, ]); } '_insert_bulk with IDENTITY_INSERT via populate'; is $bulk_rs->count, 3, 'correct number inserted via _insert_bulk with IDENTITY_INSERT'; is ((grep $_->charfield eq 'foo', $bulk_rs->all), 3, 'column set correctly via _insert_bulk with IDENTITY_INSERT'); $bulk_rs->delete; } # test correlated subquery my $subq = $schema->resultset('Artist')->search({ artistid => { '>' => 3 } }) ->get_column('artistid') ->as_query; my $subq_rs = $schema->resultset('Artist')->search({ artistid => { -in => $subq } }); is $subq_rs->count, 11, 'correlated subquery'; # mostly stolen from the blob stuff Nniuq wrote for t/73oracle.t SKIP: { skip 'TEXT/IMAGE support does not work with FreeTDS', 22 if $schema->storage->_using_freetds; my $dbh = $schema->storage->_dbh; { local $SIG{__WARN__} = sub {}; eval { $dbh->do('DROP TABLE bindtype_test') }; $dbh->do(qq[ CREATE TABLE bindtype_test ( id INT IDENTITY PRIMARY KEY, bytea IMAGE NULL, blob IMAGE NULL, clob TEXT NULL, a_memo IMAGE NULL ) ],{ RaiseError => 1, PrintError => 0 }); } my %binstr = ( 'small' => join('', map { chr($_) } ( 1 .. 127 )) ); $binstr{'large'} = $binstr{'small'} x 1024; my $maxloblen = length $binstr{'large'}; if (not $schema->storage->_using_freetds) { $dbh->{'LongReadLen'} = $maxloblen * 2; } else { $dbh->do("set textsize ".($maxloblen * 2)); } my $rs = $schema->resultset('BindType'); my $last_id; foreach my $type (qw(blob clob)) { foreach my $size (qw(small large)) { no warnings 'uninitialized'; my $created; lives_ok { $created = $rs->create( { $type => $binstr{$size} } ) } "inserted $size $type without dying"; $last_id = $created->id if $created; lives_and { ok($rs->find($last_id)->$type eq $binstr{$size}) } "verified inserted $size $type"; } } $rs->delete; # blob insert with explicit PK # also a good opportunity to test IDENTITY_INSERT lives_ok { $rs->create( { id => 1, blob => $binstr{large} } ) } 'inserted large blob without dying with manual PK'; lives_and { ok($rs->find(1)->blob eq $binstr{large}) } 'verified inserted large blob with manual PK'; # try a blob update my $new_str = $binstr{large} . 'mtfnpy'; # check redispatch to storage-specific update when auto-detected storage if ($storage_type eq 'DBI::Sybase::ASE') { DBICTest::Schema->storage_type('::DBI'); $schema = get_schema(); } lives_ok { $rs->search({ id => 1 })->update({ blob => $new_str }) } 'updated blob successfully'; lives_and { ok($rs->find(1)->blob eq $new_str) } 'verified updated blob'; # try a blob update with IDENTITY_UPDATE lives_and { $new_str = $binstr{large} . 'hlagh'; $rs->find(1)->update({ id => 999, blob => $new_str }); ok($rs->find(999)->blob eq $new_str); } 'verified updated blob with IDENTITY_UPDATE'; ## try multi-row blob update # first insert some blobs $new_str = $binstr{large} . 'foo'; lives_and { $rs->delete; $rs->create({ blob => $binstr{large} }) for (1..2); $rs->update({ blob => $new_str }); is((grep $_->blob eq $new_str, $rs->all), 2); } 'multi-row blob update'; $rs->delete; # now try _insert_bulk with blobs and only blobs $new_str = $binstr{large} . 'bar'; lives_ok { $rs->populate([ { blob => $binstr{large}, clob => $new_str, }, { blob => $binstr{large}, clob => $new_str, }, ]); } '_insert_bulk with blobs does not die'; is((grep $_->blob eq $binstr{large}, $rs->all), 2, 'IMAGE column set correctly via _insert_bulk'); is((grep $_->clob eq $new_str, $rs->all), 2, 'TEXT column set correctly via _insert_bulk'); # now try _insert_bulk with blobs and a non-blob which also happens to be an # identity column SKIP: { skip 'no _insert_bulk without placeholders', 4 if $storage_type =~ /NoBindVars/i; $rs->delete; $new_str = $binstr{large} . 'bar'; lives_ok { $rs->populate([ { id => 1, bytea => 1, blob => $binstr{large}, clob => $new_str, a_memo => 2, }, { id => 2, bytea => 1, blob => $binstr{large}, clob => $new_str, a_memo => 2, }, ]); } '_insert_bulk with blobs and explicit identity does NOT die'; is((grep $_->blob eq $binstr{large}, $rs->all), 2, 'IMAGE column set correctly via _insert_bulk with identity'); is((grep $_->clob eq $new_str, $rs->all), 2, 'TEXT column set correctly via _insert_bulk with identity'); is_deeply [ map $_->id, $rs->all ], [ 1,2 ], 'explicit identities set correctly via _insert_bulk with blobs'; } lives_and { $rs->delete; $rs->create({ blob => $binstr{large} }) for (1..2); $rs->update({ blob => undef }); is((grep !defined($_->blob), $rs->all), 2); } 'blob update to NULL'; lives_ok { $schema->txn_do(sub { my $created = $rs->create( { clob => "some text" } ); }); } 'insert blob field in transaction'; $ping_count-- if $@; # failure retry triggers a ping } # test MONEY column support (and some other misc. stuff) $schema->storage->dbh_do (sub { my ($storage, $dbh) = @_; eval { $dbh->do("DROP TABLE money_test") }; $dbh->do(<<'SQL'); CREATE TABLE money_test ( id INT IDENTITY PRIMARY KEY, amount MONEY DEFAULT $999.99 NULL ) SQL }); my $rs = $schema->resultset('Money'); # test insert with defaults lives_and { $rs->create({}); is((grep $_->amount == 999.99, $rs->all), 1); } 'insert with all defaults works'; $rs->delete; # test insert transaction when there's an active cursor { my $artist_rs = $schema->resultset('Artist'); $artist_rs->first; lives_ok { my $row = $schema->resultset('Money')->create({ amount => 100 }); $row->delete; } 'inserted a row with an active cursor'; $ping_count-- if $@; # dbh_do calls ->connected } # test insert in an outer transaction when there's an active cursor { local $TODO = 'this should work once we have eager cursors'; # clear state, or we get a deadlock on $row->delete # XXX figure out why this happens $schema->storage->disconnect; lives_ok { $schema->txn_do(sub { my $artist_rs = $schema->resultset('Artist'); $artist_rs->first; my $row = $schema->resultset('Money')->create({ amount => 100 }); $row->delete; }); } 'inserted a row with an active cursor in outer txn'; $ping_count-- if $@; # dbh_do calls ->connected } # Now test money values. my $row; lives_ok { $row = $rs->create({ amount => 100 }); } 'inserted a money value'; cmp_ok eval { $rs->find($row->id)->amount }, '==', 100, 'money value round-trip'; lives_ok { $row->update({ amount => 200 }); } 'updated a money value'; cmp_ok eval { $rs->find($row->id)->amount }, '==', 200, 'updated money value round-trip'; lives_ok { $row->update({ amount => undef }); } 'updated a money value to NULL'; lives_and { my $null_amount = $rs->find($row->id)->amount; is $null_amount, undef; } 'updated money value to NULL round-trip'; # Test computed columns and timestamps $schema->storage->dbh_do (sub { my ($storage, $dbh) = @_; eval { $dbh->do("DROP TABLE computed_column_test") }; $dbh->do(<<'SQL'); CREATE TABLE computed_column_test ( id INT IDENTITY PRIMARY KEY, a_computed_column AS getdate(), a_timestamp timestamp, charfield VARCHAR(20) DEFAULT 'foo' ) SQL }); require DBICTest::Schema::ComputedColumn; $schema->register_class( ComputedColumn => 'DBICTest::Schema::ComputedColumn' ); ok (($rs = $schema->resultset('ComputedColumn')), 'got rs for ComputedColumn'); lives_ok { $row = $rs->create({}) } 'empty insert for a table with computed columns survived'; lives_ok { $row->update({ charfield => 'bar' }) } 'update of a table with computed columns survived'; } is $ping_count, 0, 'no pings'; # if tests passed and did so under a non-C lang - let's rerun the test if (Test::Builder->new->is_passing and $ENV{LANG} and $ENV{LANG} ne 'C') { my $oldlang = $ENV{LANG}; local $ENV{LANG} = 'C'; pass ("Your lang is set to $oldlang - retesting with C"); local $ENV{PATH}; my @cmd = map { $_ =~ /(.+)/ } ($^X, __FILE__); # this is cheating, and may even hang here and there (testing on windows passed fine) # will be replaced with Test::SubExec::Noninteractive in due course require IPC::Open2; IPC::Open2::open2(my $out, undef, @cmd); while (my $ln = <$out>) { print " $ln"; } wait; ok (! $?, "Wstat $? from: @cmd"); } done_testing; # clean up our mess END { if (my $dbh = eval { $schema->storage->_dbh }) { eval { $dbh->do("DROP TABLE $_") } for qw/artist bindtype_test money_test computed_column_test/; } undef $schema; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/87ordered.t�������������������������������������������������������������������0000644�0001750�0001750�00000023432�14240132261�015335� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# vim: filetype=perl use strict; use warnings; use Test::More; use lib qw(t/lib); use DBICTest; use POSIX qw(ceil); my $schema = DBICTest->init_schema(); my $employees = $schema->resultset('Employee'); $employees->delete(); foreach (1..5) { $employees->create({ name=>'temp' }); } $employees = $employees->search(undef,{order_by=>'position'}); ok( check_rs($employees), "intial positions" ); hammer_rs( $employees ); DBICTest::Employee->grouping_column('group_id'); $employees->delete(); foreach my $group_id (1..4) { foreach (1..6) { $employees->create({ name=>'temp', group_id=>$group_id }); } } $employees = $employees->search(undef,{order_by=>'group_id,position'}); foreach my $group_id (1..4) { my $group_employees = $employees->search({group_id=>$group_id}); $group_employees->all(); ok( check_rs($group_employees), "group intial positions" ); hammer_rs( $group_employees ); } my $group_3 = $employees->search({group_id=>3}); my $to_group = 1; my $to_pos = undef; { my @empl = $group_3->all; while (my $employee = shift @empl) { $employee->move_to_group($to_group, $to_pos); $to_pos++; $to_group = $to_group==1 ? 2 : 1; } } foreach my $group_id (1..4) { my $group_employees = $employees->search({group_id=>$group_id}); ok( check_rs($group_employees), "group positions after move_to_group" ); } my $employee = $employees->search({group_id=>4})->first; $employee->position(2); $employee->update; ok( check_rs($employees->search_rs({group_id=>4})), "overloaded update 1" ); $employee = $employees->search({group_id=>4})->first; $employee->update({position=>3}); ok( check_rs($employees->search_rs({group_id=>4})), "overloaded update 2" ); $employee = $employees->search({group_id=>4})->first; $employee->group_id(1); $employee->update; ok( check_rs($employees->search_rs({group_id=>1})) && check_rs($employees->search_rs({group_id=>4})), "overloaded update 3" ); $employee = $employees->search({group_id=>4})->first; $employee->update({group_id=>2}); ok( check_rs($employees->search_rs({group_id=>2})) && check_rs($employees->search_rs({group_id=>4})), "overloaded update 4" ); $employee = $employees->search({group_id=>4})->first; $employee->group_id(1); $employee->position(3); $employee->update; ok( check_rs($employees->search_rs({group_id=>1})) && check_rs($employees->search_rs({group_id=>4})), "overloaded update 5" ); $employee = $employees->search({group_id=>4})->first; $employee->group_id(2); $employee->position(undef); $employee->update; ok( check_rs($employees->search_rs({group_id=>2})) && check_rs($employees->search_rs({group_id=>4})), "overloaded update 6" ); $employee = $employees->search({group_id=>4})->first; $employee->update({group_id=>1,position=>undef}); ok( check_rs($employees->search_rs({group_id=>1})) && check_rs($employees->search_rs({group_id=>4})), "overloaded update 7" ); $employee->group_id(2); $employee->name('E of the month'); $employee->update({ employee_id => 666, position => 2 }); is_deeply( { $employee->get_columns }, { employee_id => 666, encoded => undef, group_id => 2, group_id_2 => undef, group_id_3 => undef, name => "E of the month", position => 2 }, 'combined update() worked correctly' ); is_deeply( { $employee->get_columns }, { $employee->get_from_storage->get_columns }, 'object matches database state', ); ##### # multicol tests begin here ##### DBICTest::Employee->grouping_column(['group_id_2', 'group_id_3']); $employees->delete(); foreach my $group_id_2 (1..4) { foreach my $group_id_3 (1..4) { foreach (1..4) { $employees->create({ name=>'temp', group_id_2=>$group_id_2, group_id_3=>$group_id_3 }); } } } $employees = $employees->search(undef,{order_by=>[qw/group_id_2 group_id_3 position/]}); foreach my $group_id_2 (1..3) { foreach my $group_id_3 (1..3) { my $group_employees = $employees->search({group_id_2=>$group_id_2, group_id_3=>$group_id_3}); $group_employees->all(); ok( check_rs($group_employees), "group intial positions" ); hammer_rs( $group_employees ); } } # move_to_group, specifying group by hash my $group_4 = $employees->search({group_id_2=>4}); $to_group = 1; my $to_group_2_base = 7; my $to_group_2 = 1; $to_pos = undef; { my @empl = $group_3->all; while (my $employee = shift @empl) { $employee->move_to_group({group_id_2=>$to_group, group_id_3=>$to_group_2}, $to_pos); $to_pos++; $to_group = ($to_group % 3) + 1; $to_group_2_base++; $to_group_2 = (ceil($to_group_2_base/3.0) %3) +1 } } foreach my $group_id_2 (1..4) { foreach my $group_id_3 (1..4) { my $group_employees = $employees->search({group_id_2=>$group_id_2,group_id_3=>$group_id_3}); ok( check_rs($group_employees), "group positions after move_to_group" ); } } $employees->delete(); foreach my $group_id_2 (1..4) { foreach my $group_id_3 (1..4) { foreach (1..4) { $employees->create({ name=>'temp', group_id_2=>$group_id_2, group_id_3=>$group_id_3 }); } } } $employees = $employees->search(undef,{order_by=>[qw/group_id_2 group_id_3 position/]}); $employee = $employees->search({group_id_2=>4, group_id_3=>1})->first; $employee->group_id_2(1); $employee->update; ok( check_rs($employees->search_rs({group_id_2=>4, group_id_3=>1})) && check_rs($employees->search_rs({group_id_2=>1, group_id_3=>1})), "overloaded multicol update 1" ); $employee = $employees->search({group_id_2=>4, group_id_3=>1})->first; $employee->update({group_id_2=>2}); ok( check_rs($employees->search_rs({group_id_2=>4, group_id_3=>1})) && check_rs($employees->search_rs({group_id_2=>2, group_id_3=>1})), "overloaded multicol update 2" ); $employee = $employees->search({group_id_2=>3, group_id_3=>1})->first; $employee->group_id_2(1); $employee->group_id_3(3); $employee->update(); ok( check_rs($employees->search_rs({group_id_2=>3, group_id_3=>1})) && check_rs($employees->search_rs({group_id_2=>1, group_id_3=>3})), "overloaded multicol update 3" ); $employee = $employees->search({group_id_2=>3, group_id_3=>1})->first; $employee->update({group_id_2=>2, group_id_3=>3}); ok( check_rs($employees->search_rs({group_id_2=>3, group_id_3=>1})) && check_rs($employees->search_rs({group_id_2=>2, group_id_3=>3})), "overloaded multicol update 4" ); $employee = $employees->search({group_id_2=>3, group_id_3=>2})->first; $employee->update({group_id_2=>2, group_id_3=>4, position=>2}); ok( check_rs($employees->search_rs({group_id_2=>3, group_id_3=>2})) && check_rs($employees->search_rs({group_id_2=>2, group_id_3=>4})), "overloaded multicol update 5" ); sub hammer_rs { my $rs = shift; my $employee; my $count = $rs->count(); my $position_column = $rs->result_class->position_column(); my $row; foreach my $position (1..$count) { ($row) = $rs->search({ $position_column=>$position })->all(); $row->move_previous(); ok( check_rs($rs), "move_previous( $position )" ); ($row) = $rs->search({ $position_column=>$position })->all(); $row->move_next(); ok( check_rs($rs), "move_next( $position )" ); ($row) = $rs->search({ $position_column=>$position })->all(); $row->move_first(); ok( check_rs($rs), "move_first( $position )" ); ($row) = $rs->search({ $position_column=>$position })->all(); $row->move_last(); ok( check_rs($rs), "move_last( $position )" ); foreach my $to_position (1..$count) { ($row) = $rs->search({ $position_column=>$position })->all(); $row->move_to($to_position); ok( check_rs($rs), "move_to( $position => $to_position )" ); } $row = $rs->find({ position => $position }); if ($position==1) { ok( !$row->previous_sibling(), 'no previous sibling' ); ok( !$row->first_sibling(), 'no first sibling' ); ok( $row->next_sibling->position > $position, 'next sibling position > than us'); is( $row->next_sibling->previous_sibling->position, $position, 'next-prev sibling is us'); ok( $row->last_sibling->position > $position, 'last sibling position > than us'); } else { ok( $row->previous_sibling(), 'previous sibling' ); ok( $row->first_sibling(), 'first sibling' ); ok( $row->previous_sibling->position < $position, 'prev sibling position < than us'); is( $row->previous_sibling->next_sibling->position, $position, 'prev-next sibling is us'); ok( $row->first_sibling->position < $position, 'first sibling position < than us'); } if ($position==$count) { ok( !$row->next_sibling(), 'no next sibling' ); ok( !$row->last_sibling(), 'no last sibling' ); ok( $row->previous_sibling->position < $position, 'prev sibling position < than us'); is( $row->previous_sibling->next_sibling->position, $position, 'prev-next sibling is us'); ok( $row->first_sibling->position < $position, 'first sibling position < than us'); } else { ok( $row->next_sibling(), 'next sibling' ); ok( $row->last_sibling(), 'last sibling' ); ok( $row->next_sibling->position > $row->position, 'next sibling position > than us'); is( $row->next_sibling->previous_sibling->position, $position, 'next-prev sibling is us'); ok( $row->last_sibling->position > $row->position, 'last sibling position > than us'); } } } sub check_rs { my( $rs ) = @_; $rs->reset(); my $position_column = $rs->result_class->position_column(); my $expected_position = 0; while (my $row = $rs->next()) { $expected_position ++; if ($row->get_column($position_column)!=$expected_position) { return 0; } } return 1; } done_testing; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/t/var/��������������������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676464�014153� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/maint/��������������������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�014227� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/maint/Makefile.PL.inc/����������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�017026� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/maint/Makefile.PL.inc/56_autogen_schema_files.pl��������������������������������0000644�0001750�0001750�00000003400�14240132261�024015� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������require File::Spec; my $test_ddl_fn = File::Spec->catfile(qw( t lib sqlite.sql )); my @test_ddl_cmd = qw( -I lib -I t/lib -- maint/gen_sqlite_schema_files --schema-class DBICTest::Schema ); my $example_ddl_fn = File::Spec->catfile(qw( examples Schema db example.sql )); my $example_db_fn = File::Spec->catfile(qw( examples Schema db example.db )); my @example_ddl_cmd = qw( -I lib -I examples/Schema -- maint/gen_sqlite_schema_files --schema-class MyApp::Schema ); my @example_pop_cmd = qw( -I lib -I examples/Schema -- examples/Schema/insertdb.pl ); # If the author doesn't have the prereqs, still generate a Makefile # The EUMM build-stage generation will run unconditionally and # errors will not be ignored unlike here require DBIx::Class::Optional::Dependencies; if ( DBIx::Class::Optional::Dependencies->req_ok_for ('deploy') ) { print "Regenerating $test_ddl_fn\n"; system( $^X, @test_ddl_cmd, '--ddl-out' => $test_ddl_fn ); print "Regenerating $example_ddl_fn and $example_db_fn\n"; system( $^X, @example_ddl_cmd, '--ddl-out' => $example_ddl_fn, '--deploy-to' => $example_db_fn ); print "Populating $example_db_fn\n"; system( $^X, @example_pop_cmd ); # if we don't do it some git tools (e.g. gitk) get confused that the # ddl file is modified, when it clearly isn't system('git status --porcelain >' . File::Spec->devnull); } postamble <<"EOP"; clonedir_generate_files : dbic_clonedir_regen_test_ddl dbic_clonedir_regen_test_ddl : \t\$(ABSPERLRUN) @test_ddl_cmd --ddl-out @{[ $mm_proto->quote_literal($test_ddl_fn) ]} \t\$(ABSPERLRUN) @example_ddl_cmd --ddl-out @{[ $mm_proto->quote_literal($example_ddl_fn) ]} --deploy-to @{[ $mm_proto->quote_literal($example_db_fn) ]} \t\$(ABSPERLRUN) @example_pop_cmd EOP # keep the Makefile.PL eval happy 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/maint/Makefile.PL.inc/50_redefine_makefile_flow.pl������������������������������0000644�0001750�0001750�00000005132�14240132261�024314� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Split create_distdir into several subtargets, allowing us to generate # stuff, inject it into lib/, manifest it, and then clean all of it up { package MY; sub distdir { (my $snippet = shift->SUPER::distdir(@_)) =~ s/^create_distdir :/create_distdir_copy_manifested :/; return <<"EOM"; $snippet .NOTPARALLEL : create_distdir : check_create_distdir_prereqs clonedir_generate_files clonedir_post_generate_files fresh_manifest create_distdir_copy_manifested clonedir_cleanup_generated_files \t\$(NOECHO) \$(NOOP) clonedir_generate_files : \t\$(NOECHO) \$(NOOP) clonedir_post_generate_files : \t\$(NOECHO) \$(NOOP) clonedir_cleanup_generated_files : \t\$(NOECHO) \$(NOOP) check_create_distdir_prereqs : \t\$(NOECHO) @{[ $mm_proto->oneliner("DBIx::Class::Optional::Dependencies->die_unless_req_ok_for(q(dist_dir))", [qw/-Ilib -MDBIx::Class::Optional::Dependencies/]) ]} EOM } } # M::I inserts its own default postamble, so we can't easily override upload # but we can still hook postamble in EU::MM { package MY; sub postamble { my $snippet = shift->SUPER::postamble(@_); return <<"EOM"; $snippet upload :: check_create_distdir_prereqs check_upload_dist_prereqs check_upload_dist_prereqs : \t\$(NOECHO) @{[ $mm_proto->oneliner("DBIx::Class::Optional::Dependencies->die_unless_req_ok_for(q(dist_upload))", [qw/-Ilib -MDBIx::Class::Optional::Dependencies/]) ]} EOM } } # EU::MM BUG - workaround # somehow the init_PM of EUMM (in MM_Unix) interprets ResultClass.pod.proto # as a valid ResultClass.pod. While this has no effect on dist-building # it royally screws up the local Makefile.PL $TO_INST_PM and friends, # making it impossible to make/make test from a checkout # just rip it out here (remember - this is only executed under author mode) { package MY; sub init_PM { my $self = shift; my $rv = $self->SUPER::init_PM(@_); delete @{$self->{PM}}{qw(lib/DBIx/Class/Manual/ResultClass.pod lib/DBIx/Class/Manual/ResultClass.pod.proto)}; $rv } } # make the install (and friends) target a noop - instead of # doing a perl Makefile.PL && make && make install (which will leave pod # behind), one ought to assemble a distdir first { package MY; sub install { (my $snippet = shift->SUPER::install(@_)) =~ s/^( (?: install [^\:]+ | \w+_install \s) \:+ )/$1 block_install_from_checkout/mxg; return <<"EOM"; $snippet block_install_from_checkout : \t\$(NOECHO) \$(ECHO) Installation directly from a checkout is not possible. You need to prepare a distdir, enter it, and run the installation from within. \t\$(NOECHO) \$(FALSE) EOM } } # keep the Makefile.PL eval happy 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/maint/Makefile.PL.inc/21_set_meta.pl��������������������������������������������0000644�0001750�0001750�00000005241�14240132261�021447� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# principal author list is kinda mandated by spec, luckily is rather static author 'mst: Matt S Trout <mst@shadowcat.co.uk> (project founder - original idea, architecture and implementation)'; author 'castaway: Jess Robinson <castaway@desert-island.me.uk> (lions share of the reference documentation and manuals)'; author 'ribasushi: Peter Rabbitson <ribasushi@leporine.io> (present day maintenance and controlled evolution)'; # pause sanity Meta->{values}{x_authority} = 'cpan:RIBASUSHI'; # !!!experimental!!! # # <ribasushi> am wondering if an x_parallel_test => 1 and x_parallel_depchain_test => 1 would be of use in meta # <ribasushi> to signify "project keeps tabs on itself and depchain to be in good health wrt running tests in parallel" # <ribasushi> and having cpan(m) tack a -j6 automatically for that # <ribasushi> it basically allows you to first consider any "high level intermediate dist" advertising "all my stuff works" so that larger swaths of CPAN get installed first under parallel # <ribasushi> note - this is not "spur of the moment" - I first started testing my depchain in parallel 3 years ago # <ribasushi> and have had it stable ( religiously tested on travis on any commit ) for about 2 years now # Meta->{values}{x_parallel_test_certified} = 1; Meta->{values}{x_dependencies_parallel_test_certified} = 1; # populate x_contributors # a direct dump of the sort is ok - xt/authors.t guarantees source sanity Meta->{values}{x_contributors} = [ do { # according to #p5p this is how one safely reads random unicode # this set of boilerplate is insane... wasn't perl unicode-king...? no warnings 'once'; require Encode; require PerlIO::encoding; local $PerlIO::encoding::fallback = Encode::FB_CROAK(); open (my $fh, '<:encoding(UTF-8)', 'AUTHORS') or die "Unable to open AUTHORS - can't happen: $!\n"; map { chomp; ( (! $_ or $_ =~ /^\s*\#/) ? () : $_ ) } <$fh>; }]; # legalese license 'perl'; resources 'license' => 'http://dev.perl.org/licenses/'; # misc resources abstract_from 'lib/DBIx/Class.pm'; resources 'repository' => 'https://github.com/Perl5/DBIx-Class'; resources 'bugtracker' => 'https://rt.cpan.org/Public/Dist/Display.html?Name=DBIx-Class'; # nothing determined at runtime, except for possibly SQLT dep # (see the check around DBICTEST_SQLT_DEPLOY in Makefile.PL) dynamic_config 0; # Deprecated/internal modules need no exposure when building the meta no_index directory => $_ for (qw| lib/DBIx/Class/Admin lib/DBIx/Class/PK/Auto lib/DBIx/Class/CDBICompat maint |); no_index package => $_ for (qw/ DBIx::Class::Storage::DBIHacks DBIx::Class::Storage::BlockRunner DBIx::Class::Carp DBIx::Class::_Util /); # keep the Makefile.PL eval happy 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/maint/Makefile.PL.inc/29_handle_version.pl��������������������������������������0000644�0001750�0001750�00000002537�14240132261�022663� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� my $dbic_ver_re = qr/ 0 \. (\d{2}) (\d{2}) (\d{2}) (?: _ (\d{2}) )? /x; # not anchored!!! my $version_string = Meta->version; my $version_value = eval $version_string; my ($v_maj, $v_min, $v_point, $v_dev) = $version_string =~ /^$dbic_ver_re$/ or die sprintf ( "Invalid version %s (as specified in %s)\nCurrently valid version formats are 0.MMVVPP or 0.MMVVPP_DD\n", $version_string, Meta->{values}{version_from} || Meta->{values}{all_from} || 'Makefile.PL', ) ; if ($v_maj > 8) { die "Illegal version $version_string - we are still in the 0.08 cycle\n" } Meta->makemaker_args->{DISTVNAME} = Meta->name . "-$version_string-TRIAL" if ( # all odd releases *after* 0.089x generate a -TRIAL, no exceptions ( $v_point > 89 ) ); my $tags = { map { chomp $_; $_ => 1} `git tag` }; # git may not be available if (keys %$tags) { my $shipped_versions; my $shipped_dev_versions; my $legacy_re = qr/^ v 0 \. (\d{2}) (\d{2}) (\d) (?: _ (\d{2}) )? $/x; for (keys %$tags) { if ($_ =~ /^v$dbic_ver_re$/ or $_ =~ $legacy_re ) { if (defined $4) { $shipped_dev_versions->{"0.$1$2$3$4"} = 1; } else { $shipped_versions->{"0.$1$2$3"} = 1; } delete $tags->{$_}; } } die sprintf "Tags in unknown format found: %s\n", join ', ', keys %$tags if keys %$tags; } # keep the Makefile.PL eval happy 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/maint/Makefile.PL.inc/91_inc_sanity_check.pl������������������������������������0000644�0001750�0001750�00000001503�12757225440�023164� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������my @files_to_check = qw(AutoInstall.pm Can.pm WriteAll.pm Win32.pm); END { # shit already hit the fan return if $?; for my $f (@files_to_check) { if (! -f "inc/Module/Install/$f") { warn "Your inc/ does not contain a critical Module::Install component - \$_. Something went horrifically wrong... please ask the cabal for help\n"; unlink 'Makefile'; exit 1; } } } my $oneliner = <<"EOO"; -f qq(\$(DISTVNAME)/inc/Module/Install/\$_) or die "\\nYour \$(DISTVNAME)/inc/ does not contain a critical Module::Install component: \$_. Something went horrifically wrong... please ask the cabal for help\\n\\n" for (qw(@files_to_check)) EOO postamble <<"EOP"; create_distdir : sanity_check_inc sanity_check_inc : \t\$(NOECHO) @{[ $mm_proto->oneliner($oneliner) ]} EOP # keep the Makefile.PL eval happy 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/maint/Makefile.PL.inc/61_inject_dbicadmin_pod.pl��������������������������������0000644�0001750�0001750�00000001464�12757225440�024002� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# without having the pod in the file itself, perldoc may very # well show a *different* document, because perl and perldoc # search @INC differently (crazy right?) # # make sure we delete and re-create the file - just an append # will not do what one expects, because on unixy systems the # target is symlinked to the original postamble <<"EOP"; create_distdir : dbic_distdir_dbicadmin_pod_inject dbic_distdir_dbicadmin_pod_inject : \t\$(RM_F) \$(DISTVNAME)/script/dbicadmin \t@{[ $mm_proto->oneliner('cat', ['-MExtUtils::Command']) ]} script/dbicadmin maint/.Generated_Pod/dbicadmin.pod > \$(DISTVNAME)/script/dbicadmin # FIXME also on win32 EU::Command::cat() adds crlf even if the # source files do not contain any :( @{[ $crlf_fixup->('$(DISTVNAME)/script/dbicadmin') ]} EOP # keep the Makefile.PL eval happy 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/maint/Makefile.PL.inc/53_autogen_pod.pl�����������������������������������������0000644�0001750�0001750�00000011130�14240132261�022151� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use File::Path(); use File::Glob(); # leftovers in old checkouts unlink 'lib/DBIx/Class/Optional/Dependencies.pod' if -f 'lib/DBIx/Class/Optional/Dependencies.pod'; File::Path::rmtree( File::Glob::bsd_glob('.generated_pod'), { verbose => 0 } ) if -d '.generated_pod'; my $pod_dir = 'maint/.Generated_Pod'; my $ver = Meta->version; # cleanup the generated pod dir (again - kill leftovers from old checkouts) if (-d $pod_dir) { File::Path::rmtree( File::Glob::bsd_glob("$pod_dir/*"), { verbose => 0 } ); } else { mkdir $pod_dir or die "Unable to create $pod_dir: $!"; } # generate the OptDeps pod both in the clone-dir and during the makefile distdir { print "Regenerating Optional/Dependencies.pod\n"; # this should always succeed - hence no error checking # if someone breaks OptDeps - travis should catch it require DBIx::Class::Optional::Dependencies; DBIx::Class::Optional::Dependencies->_gen_pod ($ver, "$pod_dir/lib"); postamble <<"EOP"; clonedir_generate_files : dbic_clonedir_gen_optdeps_pod dbic_clonedir_gen_optdeps_pod : \t@{[ $mm_proto->oneliner("DBIx::Class::Optional::Dependencies->_gen_pod(q($ver), q($pod_dir/lib))", [qw/-Ilib -MDBIx::Class::Optional::Dependencies/]) ]} EOP } # generate the script/dbicadmin pod { print "Regenerating script/dbicadmin.pod\n"; # generating it in the root of $pod_dir # it will *not* be copied over due to not being listed at the top # of MANIFEST.SKIP - this is a *good* thing # we only want to ship a script/dbicadmin, with the POD appended # (see inject_dbicadmin_pod.pl), but still want to spellcheck and # whatnot the intermediate step my $pod_fn = "$pod_dir/dbicadmin.pod"; # if the author doesn't have the prereqs, don't fail the initial "perl Makefile.pl" step my $great_success; { local @ARGV = ('--documentation-as-pod', $pod_fn); local $0 = 'dbicadmin'; local *CORE::GLOBAL::exit = sub { $great_success++; die; }; do 'script/dbicadmin'; } if (!$great_success and ($@ || $!) ) { printf ("FAILED!!! Subsequent `make dist` will fail. %s\n", $ENV{DBICDIST_DEBUG} ? 'Full error: ' . ($@ || $!) : 'Re-run with $ENV{DBICDIST_DEBUG} set for more info' ); } postamble <<"EOP"; clonedir_generate_files : dbic_clonedir_gen_dbicadmin_pod dbic_clonedir_gen_dbicadmin_pod : \t\$(ABSPERLRUN) -Ilib -- script/dbicadmin --documentation-as-pod @{[ $mm_proto->quote_literal($pod_fn) ]} EOP } # generate the inherit pods only during distbuilding phase # it is too slow to do at regular Makefile.PL { postamble <<"EOP"; clonedir_generate_files : dbic_clonedir_gen_inherit_pods dbic_clonedir_gen_inherit_pods : \t\$(ABSPERLRUN) -Ilib maint/gen_pod_inherit EOP } # generate the DBIx/Class.pod only during distdir { my $dist_pod_fn = File::Spec->catfile($pod_dir, qw(lib DBIx Class.pod)); postamble <<"EOP"; clonedir_generate_files : dbic_distdir_gen_dbic_pod dbic_distdir_gen_dbic_pod : \tperldoc -u lib/DBIx/Class.pm > $dist_pod_fn \t@{[ $mm_proto->oneliner( "s!^.*?this line is replaced with the author list.*! qq{List of the awesome contributors who made DBIC v$ver possible\n\n} . qx(\$^X -Ilib maint/gen_pod_authors)!me", [qw( -0777 -p -i )] ) ]} $dist_pod_fn create_distdir : dbic_distdir_defang_authors # Remove the maintainer-only warning (be nice ;) dbic_distdir_defang_authors : \t@{[ $mm_proto->oneliner('s/ ^ \s* \# \s* \*\*\* .+ \n ( ^ \s* \# \s*? \n )? //xmg', [qw( -0777 -p -i )] ) ]} \$(DISTVNAME)/AUTHORS EOP } # on some OSes generated files may have an incorrect \n - fix it # so that the xt tests pass on a fresh checkout (also shipping a # dist with CRLFs is beyond obnoxious) if ($^O eq 'MSWin32' or $^O eq 'cygwin') { { local $ENV{PERLIO} = 'unix'; system( $^X, qw( -MExtUtils::Command -e dos2unix -- ), $pod_dir ); } postamble <<"EOP"; clonedir_post_generate_files : pod_crlf_fixup pod_crlf_fixup : @{[ $crlf_fixup->($pod_dir) ]} EOP } { postamble <<"EOP"; clonedir_post_generate_files : dbic_clonedir_copy_generated_pod dbic_clonedir_copy_generated_pod : \t\$(RM_F) $pod_dir.packlist \t@{[ $mm_proto->oneliner("install([ from_to => {q($pod_dir) => File::Spec->curdir(), write => q($pod_dir.packlist)}, verbose => 0, uninstall_shadows => 0, skip => [] ])", ['-MExtUtils::Install']) ]} EOP } # everything that came from $pod_dir, needs to be removed from the workdir { postamble <<"EOP"; clonedir_cleanup_generated_files : dbic_clonedir_cleanup_generated_pod_copies dbic_clonedir_cleanup_generated_pod_copies : \t@{[ $mm_proto->oneliner('chomp && unlink || die', ['-n']) ]} $pod_dir.packlist \t\$(RM_F) $pod_dir.packlist EOP } # keep the Makefile.PL eval happy 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/maint/Makefile.PL.inc/54_autogen_legalese_and_README.pl�������������������������0000644�0001750�0001750�00000002500�14240132261�025011� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# When a long-standing branch is updated a README may still linger around unlink 'README' if -f 'README'; # Makefile syntax allows adding extra dep-specs for already-existing targets, # and simply appends them on *LAST*-come *FIRST*-serve basis. # This allows us to inject extra depenencies for standard EUMM targets require File::Spec; my $dir = File::Spec->catdir(qw(maint .Generated_Pod)); my $r_fn = File::Spec->catfile($dir, 'README'); my $start_file = sub { my $fn = $mm_proto->quote_literal(shift); return join "\n", qq{\t\$(NOECHO) \$(RM_F) $fn}, ( map { qq(\t\$(NOECHO) \$(ECHO) "$_" >> $fn) } ( "DBIx::Class is Copyright (c) 2005-@{[ (gmtime)[5] + 1900 ]} by mst, castaway, ribasushi, and others.", "See AUTHORS and LICENSE included with this distribution. All rights reserved.", "", )), ; }; postamble <<"EOP"; clonedir_generate_files : dbic_clonedir_gen_readme dbic_clonedir_gen_readme : dbic_distdir_gen_dbic_pod @{[ $start_file->($r_fn) ]} \tpod2text $dir/lib/DBIx/Class.pod >> $r_fn create_distdir : dbic_distdir_regen_license dbic_distdir_regen_license : @{[ $start_file->( File::Spec->catfile( Meta->name . '-' . Meta->version, 'LICENSE') ) ]} \t@{[ $mm_proto->oneliner('cat', ['-MExtUtils::Command']) ]} LICENSE >> \$(DISTVNAME)/LICENSE EOP # keep the Makefile.PL eval happy 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/maint/Makefile.PL.inc/51_autohandle_MANIFEST.pl���������������������������������0000644�0001750�0001750�00000001052�14240132261�023257� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# make sure manifest is deleted and generated anew on distdir # preparation, and is deleted on realclean postamble <<"EOM"; fresh_manifest : remove_manifest manifest remove_manifest : \t\$(RM_F) MANIFEST realclean :: remove_manifest manifest : check_manifest_is_lone_target check_manifest_is_lone_target : \t\$(NOECHO) @{[ $mm_proto->oneliner('q($(MAKECMDGOALS)) =~ /(\S*manifest\b)/ and q($(MAKECMDGOALS)) ne $1 and die qq(The DBIC build chain does not support mixing the $1 target with others\n)') ]} EOM # keep the Makefile.PL eval happy 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/maint/Makefile.PL.inc/01_adjust_INC.pl������������������������������������������0000644�0001750�0001750�00000000571�12757225440�021645� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������die "Makefile.PL does not seem to have been executed from the root distdir\n" unless -d 'lib'; # $FindBin::Bin is the location of the inluding Makefile.PL, not this file require FindBin; unshift @INC, "$FindBin::Bin/lib"; # adjust ENV for $AUTHOR system() calls require Config; $ENV{PERL5LIB} = join ($Config::Config{path_sep}, @INC); # keep the Makefile.PL eval happy 1; ���������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/maint/Makefile.PL.inc/12_authordeps.pl������������������������������������������0000644�0001750�0001750�00000011334�14240132261�022024� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������my ($optdep_msg, $opt_testdeps); if ($args->{skip_author_deps}) { $optdep_msg = <<'EOW'; ****************************************************************************** ****************************************************************************** *** *** *** IGNORING AUTHOR MODE: no optional test dependencies will be forced. *** *** *** *** If you are using this checkout with the intention of submitting a DBIC *** *** patch, you are *STRONGLY ENCOURAGED* to install all dependencies, so *** *** that every possible unit-test will run. *** *** *** ****************************************************************************** ****************************************************************************** EOW } else { $optdep_msg = <<'EOW'; ****************************************************************************** ****************************************************************************** *** *** *** AUTHOR MODE: all optional test dependencies converted to hard requires *** *** ( to disable re-run Makefile.PL with --skip-author-deps ) *** *** *** ****************************************************************************** ****************************************************************************** EOW require DBIx::Class::Optional::Dependencies; my %reqs_for_group = %{DBIx::Class::Optional::Dependencies->req_group_list}; # exclude the rdbms_* groups which are for DBIC users $opt_testdeps = { map { %{$reqs_for_group{$_}} } grep { !/^rdbms_|^dist_/ } keys %reqs_for_group }; print "Including all optional deps\n"; $reqs->{test_requires} = { %{$reqs->{test_requires}}, %$opt_testdeps }; } # nasty hook into both M::AI init and the prompter, so that the optdep message # comes at the right places (on top and then right above the prompt) { require Module::AutoInstall; no warnings 'redefine'; no strict 'refs'; for (qw/_prompt import/) { my $meth = "Module::AutoInstall::$_"; my $orig = \&{$meth}; *{$meth} = sub { print $optdep_msg; goto $orig; }; } } # this will run after the Makefile is written and the main Makefile.PL terminates # END { # shit already hit the fan return if $?; # Re-write META.yml at the end to _exclude_ all forced build-requires (we do not # want to ship this) We are also not using M::I::AuthorRequires as this will be # an extra dep, and deps in Makefile.PL still suck # Also always test the result so we stop shipping borked dependency lists to CPAN # FIXME test_requires is not yet part of META my %original_build_requires = ( %$build_requires, %$test_requires ); my @all_build_requires = @{delete Meta->{values}{build_requires}||[]}; my %removed_build_requires; for (@all_build_requires) { if ($original_build_requires{$_->[0]}) { push @{Meta->{values}{build_requires}}, $_; } else { $removed_build_requires{$_->[0]} = $_->[1] unless $_->[0] eq 'ExtUtils::MakeMaker'; } } if (keys %removed_build_requires) { print "Regenerating META with author requires excluded\n"; # M::I understands unicode in meta but does not write with the right # layers - fhtagn!!! local $SIG{__WARN__} = sub { warn $_[0] unless $_[0] =~ /Wide character in print/ }; Meta->write; } # strip possible crlf from META if ($^O eq 'MSWin32' or $^O eq 'cygwin') { local $ENV{PERLIO} = 'unix'; system( $^X, qw( -MExtUtils::Command -e dos2unix -- META.yml), ); } # test that we really took things away (just in case, happened twice somehow) if (! -f 'META.yml') { warn "No META.yml generated?! aborting...\n"; unlink 'Makefile'; exit 1; } my $meta = do { local @ARGV = 'META.yml'; local $/; <> }; $meta =~ /^\Qname: DBIx-Class\E$/m or do { warn "Seemingly malformed META.yml...?\n"; unlink 'Makefile'; exit 1; }; # this is safe as there is a fatal check earlier in the main Makefile.PL # to make sure there are no duplicates (i.e. $opt_testdeps does not contain # any real dependencies) my @illegal_leftovers = grep { $meta =~ /^ \s+ \Q$_\E \: \s+ /mx } ( sort keys %$opt_testdeps ) ; if (@illegal_leftovers) { warn join ("\n", "\n\nFATAL FAIL! It looks like some author dependencies made it to the META.yml:\n", map { "\t$_" } @illegal_leftovers ) . "\n\n"; unlink 'Makefile'; exit 1; } } # keep the Makefile.PL eval happy 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/maint/Makefile.PL.inc/11_authortests.pl�����������������������������������������0000644�0001750�0001750�00000003456�14240132261�022240� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������require File::Spec; require File::Find; my $xt_dirs; File::Find::find(sub { return if $xt_dirs->{$File::Find::dir}; $xt_dirs->{$File::Find::dir} = 1 if ( $_ =~ /\.t$/ and -f $_ ); }, 'xt'); my @xt_tests = map { File::Spec->catfile($_, '*.t') } sort keys %$xt_dirs; # this will add the xt tests to the `make test` target among other things Meta->tests(join (' ', map { $_ || () } @xt_tests, Meta->tests ) ); # inject an explicit xt test run, mainly to check the contents of # lib and the generated POD's *before* anything is copied around # # at the end rerun the whitespace and footer tests in the distdir # to make sure everything is pristine postamble <<"EOP"; dbic_clonedir_copy_generated_pod : test_xt test_xt : pm_to_blib @{[ # When xt tests are explicitly requested, we want to run with RELEASE_TESTING=1 # so that all optdeps are turned into a hard failure # However portably modifying ENV for a single command is surprisingly hard # So instead we (ab)use perl's ability to stack -e options, and simply modify # the ENV from within perl itself $mm_proto->test_via_harness( # perl cmd join( ' ', '$(ABSPERLRUN)', map { $mm_proto->quote_literal($_) } qw(-e $ENV{RELEASE_TESTING}=1;$ENV{DBICTEST_NO_MAKEFILE_VERIFICATION}=1;) ), # test list join( ' ', map { $mm_proto->quote_literal($_) } @xt_tests ), ) ]} create_distdir : dbic_distdir_retest_ws_and_footers dbic_distdir_retest_ws_and_footers : \t@{[ $mm_proto->cd ( '$(DISTVNAME)', $mm_proto->test_via_harness( # perl cmd join( ' ', '$(ABSPERLRUN)', map { $mm_proto->quote_literal($_) } qw(-Ilib -e $ENV{RELEASE_TESTING}=1;$ENV{DBICTEST_NO_MAKEFILE_VERIFICATION}=1;) ), 'xt/whitespace.t xt/footers.t', ) ) ]} EOP # keep the Makefile.PL eval happy 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/maint/poisonsmoke.bash����������������������������������������������������������0000755�0001750�0001750�00000001705�13672214401�017426� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/bin/bash set -e [[ -e Makefile.PL ]] || ( echo "Not in the right dir" && exit 1 ) clear echo export TRAVIS=true export TRAVIS_REPO_SLUG="x/DBIx-Class" export DBI_DSN="dbi:ODBC:server=NonexistentServerAddress" export DBI_DRIVER="ADO" toggle_booleans=( \ $( grep -ohP '\bDBIC_[0-9_A-Z]+' -r lib/ --exclude-dir Optional | sort -u | grep -vP '^(DBIC_TRACE(_PROFILE)?|DBIC_.+_DEBUG)$' ) \ DBIC_SHUFFLE_UNORDERED_RESULTSETS \ DBICTEST_ASSERT_NO_SPURIOUS_EXCEPTION_ACTION \ DBICTEST_RUN_ALL_TESTS \ DBICTEST_SQLITE_REVERSE_DEFAULT_ORDER \ ) for var in "${toggle_booleans[@]}" do if [[ -z "${!var}" ]] ; then export $var=1 echo -n "$var " fi done echo -e "\n\n^^ variables above **automatically** set to '1'" provecmd="nice prove -QlrswTj10" echo -e " Executing \`$provecmd $@\` via $(which perl) within the following environment: $(env | grep -P 'TEST|HARNESS|MAKE|TRAVIS|PERL|DBIC|PATH|SHELL' | LC_ALL=C sort | cat -v) " $provecmd "$@" �����������������������������������������������������������DBIx-Class-0.082843/maint/gen_pod_index�������������������������������������������������������������0000755�0001750�0001750�00000002566�12757225440�016764� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/env perl # Originally by: Zbigniew Lukasiak, C<zz bb yy@gmail.com> # but refactored and modified to our nefarious purposes # XXX I'm not done refactoring this yet --blblack use strict; use warnings; use Pod::Coverage; use Data::Dumper; use File::Find::Rule; use File::Slurp; use Path::Class; use Template; # Convert filename to package name sub getpac { my $file = shift; my $filecont = read_file( $file ); $filecont =~ /package\s*(.*?);/s or return; my $pac = $1; $pac =~ /\s+(.*)$/; return $1; } my @files = File::Find::Rule->file()->name('*.pm', '*.pod')->in('lib'); my %docsyms; for my $file (@files){ my $package = getpac( $file ) or next; my $pc = Pod::Coverage->new(package => $package); my %allsyms = map {$_ => 1} $pc->_get_syms($package); my $podarr = $pc->_get_pods(); next if !$podarr; for my $sym (@{$podarr}){ $docsyms{$sym}{$package} = $file if $allsyms{$sym}; } } my @lines; for my $sym (sort keys %docsyms){ for my $pac (sort keys %{$docsyms{$sym}}){ push @lines, {symbol => $sym, package => $pac}; } } my $tt = Template->new({}) || die Template->error(), "\n"; $tt->process(\*DATA, { lines => \@lines }) || die $tt->error(), "\n"; __DATA__ =head1 NAME Method Index [% FOR line = lines %] L<[% line.symbol %] ([% line.package %])|[% line.package %]/[% line.symbol %]> [% END %] ������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/maint/gen_pod_inherit�����������������������������������������������������������0000755�0001750�0001750�00000005341�14240132261�017274� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/env perl use warnings; use strict; use DBIx::Class::_Util; # load early in case any shims are needed my $lib_dir = 'lib'; my $pod_dir = 'maint/.Generated_Pod'; my $result_metapod_fn = "$lib_dir/DBIx/Class/Manual/ResultClass.pod"; die "POD generator must be executed from the dist root\n" unless -d $lib_dir and -d $pod_dir; require File::Copy; File::Copy::copy( "$result_metapod_fn.proto", "$result_metapod_fn", ) or die "Copying ResultClass proto pod ($result_metapod_fn) failed: $!"; # cleanup END { local ($@, $!, $?); unlink $result_metapod_fn; } require Pod::Inherit; Pod::Inherit->new({ input_files => $lib_dir, out_dir => "$pod_dir/lib", force_permissions => 1, class_map => { "DBIx::Class::Relationship::HasMany" => "DBIx::Class::Relationship", "DBIx::Class::Relationship::HasOne" => "DBIx::Class::Relationship", "DBIx::Class::Relationship::BelongsTo" => "DBIx::Class::Relationship", "DBIx::Class::Relationship::ManyToMany" => "DBIx::Class::Relationship", "DBIx::Class::ResultSourceProxy" => "DBIx::Class::ResultSource", }, # skip the deprecated classes that give out *DEPRECATED* warnings skip_classes => [ qw( lib/DBIx/Class/Storage/DBI/Sybase/MSSQL.pm lib/DBIx/Class/Serialize/Storable.pm lib/DBIx/Class/ResultSetManager.pm lib/DBIx/Class/InflateColumn/File.pm lib/DBIx/Class/DB.pm lib/DBIx/Class/CDBICompat/ lib/DBIx/Class/CDBICompat.pm ), # skip the ::Storage:: family for now qw( lib/DBIx/Class/Storage/ lib/DBIx/Class/Storage.pm ), 'lib/DBIx/Class/Storage/DBI/Replicated/Pool.pm', # this one just errors out with: The 'add_attribute' method cannot be called on an immutable instance 'lib/DBIx/Class/Relationship.pm', # it already documents its own inheritors 'lib/DBIx/Class/Core.pm', # we actually don't want this populated in favor of redirecting users to the ResultClass docs 'lib/DBIx/Class/Optional/Dependencies.pm' # the POD is already auto-generated ], # these appear everywhere, and are typically lower-level methods not used by the general user skip_inherits => [ qw/ DBIx::Class DBIx::Class::Componentised Class::C3::Componentised DBIx::Class::AccessorGroup Class::Accessor::Grouped Moose::Object Exporter / ], force_inherits => { 'DBIx::Class::Manual::ResultClass' => 'DBIx::Class::Core', # this forces the contents of ::Core to be dumped into the POD doc for ::ResultClass }, dead_links => '', method_format => 'L<%m|%c/%m>', #debug => 1, })->write_pod; # important - write_pod returns undef >.< 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/maint/getstatus�����������������������������������������������������������������0000755�0001750�0001750�00000001707�13271562530�016175� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl use warnings; use strict; use Config; use Term::ANSIColor ':constants'; my $CRST = RESET; my $CCODE = BOLD; my $CSTAT = BOLD . GREEN; my $CCORE = BOLD . CYAN; my $CSIG = CYAN; if (@ARGV) { my $code = system (@ARGV); if ($code < 0) { exit 127; } elsif ($code > 0) { my $status = $code >> 8; my $signum = $code & 127; my $core = $code & 128; my %sig_idx; @sig_idx{split /\s+/, $Config{sig_num}} = split /\s/, $Config{sig_name}; printf STDERR ( <<EOF Results of execution: `%s` ---------------------- System exit code:$CCODE %d $CRST$CSIG %s $CRST ($CSTAT%08b$CRST$CCORE%b$CRST$CSIG%07b$CRST) Status: %3s ($CSTAT%08b$CRST) Signal: %3s ($CSIG%08b$CRST) Core: %3s ---------------------- EOF , (join ' ', @ARGV), $code, ($signum ? "(SIG-$sig_idx{$signum})" : ''), $status, $core, $signum, ($status) x 2, ($signum) x 2, ($core ? 'Yes': 'No') ); exit ($status); } } ���������������������������������������������������������DBIx-Class-0.082843/maint/travis_buildlog_downloader������������������������������������������������0000755�0001750�0001750�00000002253�14240132261�021545� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/env perl use warnings; use strict; use HTTP::Tiny; use JSON::PP; ( my $build_id = $ARGV[0]||'' ) =~ /^[0-9]+$/ or die "Expecting a numeric build id as argument\n"; my $base_url = "http://api.travis-ci.com/build/$build_id?include=build.jobs"; print "Retrieving $base_url\n"; my $resp = ( my $ua = HTTP::Tiny->new( default_headers => { 'Travis-API-Version' => 3 } ) )->get( $base_url ); die "Unable to retrieve $resp->{url}: $resp->{status}\n$resp->{content}\n\n" unless $resp->{success}; my @jobs = ( map { ( ($_->{id}||'') =~ /^([0-9]+)$/ ) ? [ $1 => $_->{number} ] : () } @{( eval { decode_json( $resp->{content} )->{jobs} } || [] )} ) or die "Unable to find any jobs:\n$resp->{content}\n\n"; my $dir = "TravisCI_build_$build_id"; mkdir $dir unless -d $dir; for my $job (@jobs) { my $log_url = "http://api.travis-ci.com/v3/job/$job->[0]/log.txt"; my $dest_fn = "$dir/job_$job->[1].$job->[0].log.gz"; print "Retrieving $log_url into $dest_fn\n"; $resp = $ua->mirror( $log_url, $dest_fn, { headers => { 'Accept-Encoding' => 'gzip' } }); warn "Error retrieving $resp->{url}: $resp->{status}\n$resp->{content}\n\n" unless $resp->{success}; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/maint/gen_sqlite_schema_files���������������������������������������������������0000755�0001750�0001750�00000002675�14240132261�021002� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/env perl use strict; use warnings; use SQL::Translator; use Path::Class 'file'; use Getopt::Long; my $getopt = Getopt::Long::Parser->new( config => [qw/gnu_getopt bundling_override no_ignore_case/] ); my $args = {}; $getopt->getoptions($args, qw/ ddl-out=s@ schema-class=s@ deploy-to=s@ /); die "You need to specify one DDL output filename via --ddl-out\n" if @{$args->{'ddl-out'}||[]} != 1; die "You need to specify one DBIC schema class via --schema-class\n" if @{$args->{'schema-class'}||[]} != 1; die "You may not specify more than one deploy path via --deploy-to\n" if @{$args->{'deploy-to'}||[]} > 1; local $ENV{DBI_DSN}; eval "require $args->{'schema-class'}[0]" || die $@; my $schema = $args->{'schema-class'}[0]->connect( $args->{'deploy-to'} ? ( "DBI:SQLite:$args->{'deploy-to'}[0]", undef, undef, { on_connect_do => "PRAGMA synchronous = OFF" } ) : () ); if ($args->{'deploy-to'}) { file($args->{'deploy-to'}[0])->dir->mkpath; $schema->deploy({ add_drop_table => 1 }); } my $ddl_fh; if ($args->{'ddl-out'}[0] eq '-') { $ddl_fh = *STDOUT; } else { my $fn = file($args->{'ddl-out'}[0]); $fn->dir->mkpath; open $ddl_fh, '>', $fn or die "Unable to open $fn: $!\n"; } binmode $ddl_fh; # avoid win32 \n crapfest print $ddl_fh scalar $schema->deployment_statements( 'SQLite', undef, undef, { producer_args => { no_transaction => 1 }, quote_identifiers => 1, no_comments => 1, }, ); �������������������������������������������������������������������DBIx-Class-0.082843/maint/gen_pod_authors�����������������������������������������������������������0000755�0001750�0001750�00000001165�13271562530�017330� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/env perl use warnings; use strict; # we will be outputting *ENCODED* utf8, hence the raw open below # the file is already sanity-checked by xt/authors.t my @known_authors = do { open (my $fh, '<:raw', 'AUTHORS') or die "Unable to open AUTHORS - can't happen: $!\n"; map { chomp; ( ( ! $_ or $_ =~ /^\s*\#/ ) ? () : $_ ) } <$fh>; } or die "Known AUTHORS file seems empty... can't happen..."; $_ =~ s!^ ( [^\:]+ ) : \s !B<$1>: !x for @known_authors; $_ =~ s!( \b https? :// [^\s\>]+ )!L<$1|$1>!x for @known_authors; print join "\n\n", '=encoding utf8', '=over', @known_authors, '=back', '', ; 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/inc/����������������������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�013670� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/inc/Module/���������������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�015115� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/inc/Module/Install/�������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�016523� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/inc/Module/Install/Makefile.pm��������������������������������������������������0000644�0001750�0001750�00000027437�14240676404�020606� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#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.19'; @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> }; $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-Class-0.082843/inc/Module/Install/Base.pm������������������������������������������������������0000644�0001750�0001750�00000002147�14240676404�017732� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.19'; } # 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-Class-0.082843/inc/Module/Install/Include.pm���������������������������������������������������0000644�0001750�0001750�00000001015�14240676407�020437� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#line 1 package Module::Install::Include; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.19'; @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-Class-0.082843/inc/Module/Install/Fetch.pm�����������������������������������������������������0000644�0001750�0001750�00000004627�14240676407�020121� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.19'; @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-Class-0.082843/inc/Module/Install/AutoInstall.pm�����������������������������������������������0000644�0001750�0001750�00000004162�14240676407�021321� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#line 1 package Module::Install::AutoInstall; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.19'; @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-Class-0.082843/inc/Module/Install/Scripts.pm���������������������������������������������������0000644�0001750�0001750�00000001011�14240676404�020474� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#line 1 package Module::Install::Scripts; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.19'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub install_script { my $self = shift; my $args = $self->makemaker_args; my $exe = $args->{EXE_FILES} ||= []; foreach ( @_ ) { if ( -f $_ ) { push @$exe, $_; } elsif ( -d 'script' and -f "script/$_" ) { push @$exe, "script/$_"; } else { die("Cannot find script '$_'"); } } } 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/inc/Module/Install/Metadata.pm��������������������������������������������������0000644�0001750�0001750�00000043302�14240676404�020576� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.19'; @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<lt>}{<}g; $author =~ s{E<gt>}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license 2\.0' => 'artistic_2', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashes delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/inc/Module/Install/Win32.pm�����������������������������������������������������0000644�0001750�0001750�00000003403�14240676407�017761� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.19'; @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-Class-0.082843/inc/Module/Install/WriteAll.pm��������������������������������������������������0000644�0001750�0001750�00000002376�14240676407�020612� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.19'; @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-Class-0.082843/inc/Module/Install/Can.pm�������������������������������������������������������0000644�0001750�0001750�00000006405�14240676407�017565� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#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.19'; @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-Class-0.082843/inc/Module/Install.pm�����������������������������������������������������������0000644�0001750�0001750�00000027145�14240676403�017064� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#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.19'; # 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 $/; <FH> }; 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-Class-0.082843/inc/Module/AutoInstall.pm�������������������������������������������������������0000644�0001750�0001750�00000062311�14240676407�017713� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#line 1 package Module::AutoInstall; use strict; use Cwd (); use File::Spec (); use ExtUtils::MakeMaker (); use vars qw{$VERSION}; BEGIN { $VERSION = '1.19'; } # 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() : <LOCK> == 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 (<FAILED>) { 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-Class-0.082843/xt/�����������������������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�013552� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/xt/whitespace.t�����������������������������������������������������������������0000644�0001750�0001750�00000003302�14240132261�016050� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use warnings; use strict; use Test::More; use File::Glob 'bsd_glob'; use lib 't/lib'; use DBICTest ':GlobalLock'; require DBIx::Class; unless ( DBIx::Class::Optional::Dependencies->req_ok_for ('test_whitespace') ) { my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('test_whitespace'); $ENV{RELEASE_TESTING} ? die ("Failed to load release-testing module requirements: $missing") : plan skip_all => "Test needs: $missing" } # FIXME - temporary workaround for RT#82032, RT#82033 # also add all scripts (no extension) and some extra extensions # we want to check { no warnings 'redefine'; my $is_pm = sub { $_[0] !~ /\./ || $_[0] =~ /\.(?:pm|pod|skip|bash|sql|json|proto)$/i || $_[0] =~ /::/; }; *Test::EOL::_is_perl_module = $is_pm; *Test::NoTabs::_is_perl_module = $is_pm; } my @pl_targets = qw/t xt lib script examples maint/; Test::EOL::all_perl_files_ok({ trailing_whitespace => 1 }, @pl_targets); Test::NoTabs::all_perl_files_ok(@pl_targets); # check some non-"perl files" in the root separately # use .gitignore as a guide of what to skip # (or do not test at all if no .gitignore is found) if (open(my $gi, '<', '.gitignore')) { my $skipnames; while (my $ln = <$gi>) { next if $ln =~ /^\s*$/; chomp $ln; $skipnames->{$_}++ for bsd_glob($ln); } # that we want to check anyway delete $skipnames->{'META.yml'}; for my $fn (bsd_glob('*')) { next if $skipnames->{$fn}; next unless -f $fn; Test::EOL::eol_unix_ok($fn, { trailing_whitespace => 1 }); Test::NoTabs::notabs_ok($fn); } } # FIXME - Test::NoTabs and Test::EOL declare 'no_plan' which conflicts with done_testing # https://github.com/schwern/test-more/issues/14 #done_testing; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/xt/pod.t������������������������������������������������������������������������0000644�0001750�0001750�00000001174�14240132261�014503� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use warnings; use strict; use Test::More; use lib qw(t/lib); use DBICTest; require DBIx::Class; unless ( DBIx::Class::Optional::Dependencies->req_ok_for ('test_pod') ) { my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('test_pod'); $ENV{RELEASE_TESTING} ? die ("Failed to load release-testing module requirements: $missing") : plan skip_all => "Test needs: $missing" } # this has already been required but leave it here for CPANTS static analysis require Test::Pod; my $generated_pod_dir = 'maint/.Generated_Pod'; Test::Pod::all_pod_files_ok( 'lib', -d $generated_pod_dir ? $generated_pod_dir : () ); ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/xt/optional_deps.t��������������������������������������������������������������0000644�0001750�0001750�00000006764�14240132261�016573� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; no warnings qw/once/; use Test::More; use Test::Exception; use lib qw(t/lib); use Scalar::Util; # load before we break require() use Carp (); # Carp is not used in the test, but we want to have it loaded for proper %INC comparison # a dummy test which lazy-loads more modules (so we can compare INC below) is_deeply([], []); # record contents of %INC - makes sure there are no extra deps slipping into # Opt::Dep. my $inc_before = [ keys %INC ]; ok ( (! grep { $_ =~ m|DBIx/Class| } @$inc_before ), 'Nothing DBIC related is yet loaded'); # DBIx::Class::Optional::Dependencies queries $ENV at compile time # to build the optional requirements BEGIN { $ENV{DBICTEST_PG_DSN} = '1'; delete $ENV{DBICTEST_ORA_DSN}; } use_ok 'DBIx::Class::Optional::Dependencies'; my $inc_after = [ keys %INC ]; is_deeply ( [ sort @$inc_after], [ sort (@$inc_before, 'DBIx/Class/Optional/Dependencies.pm') ], 'Nothing loaded other than DBIx::Class::OptDeps', ); my $sqlt_dep = DBIx::Class::Optional::Dependencies->req_list_for ('deploy'); is_deeply ( [ keys %$sqlt_dep ], [ 'SQL::Translator' ], 'Correct deploy() dependency list', ); # make module loading impossible, regardless of actual libpath contents { local @INC = (sub { die('Optional Dep Test') } ); ok ( ! DBIx::Class::Optional::Dependencies->req_ok_for ('deploy'), 'deploy() deps missing', ); like ( DBIx::Class::Optional::Dependencies->req_missing_for ('deploy'), qr/^SQL::Translator \>\= \d/, 'expected missing string contents', ); like ( DBIx::Class::Optional::Dependencies->req_errorlist_for ('deploy')->{'SQL::Translator'}, qr/Optional Dep Test/, 'custom exception found in errorlist', ); } #make it so module appears loaded $INC{'SQL/Translator.pm'} = 1; $SQL::Translator::VERSION = 999; ok ( ! DBIx::Class::Optional::Dependencies->req_ok_for ('deploy'), 'deploy() deps missing cached properly', ); #reset cache %DBIx::Class::Optional::Dependencies::req_availability_cache = (); ok ( DBIx::Class::Optional::Dependencies->req_ok_for ('deploy'), 'deploy() deps present', ); is ( DBIx::Class::Optional::Dependencies->req_missing_for ('deploy'), '', 'expected null missing string', ); is_deeply ( DBIx::Class::Optional::Dependencies->req_errorlist_for ('deploy'), {}, 'expected empty errorlist', ); # test multiple times to find autovivification bugs for (1..2) { throws_ok { DBIx::Class::Optional::Dependencies->req_list_for(); } qr/\Qreq_list_for() expects a requirement group name/, "req_list_for without groupname throws exception on run $_"; throws_ok { DBIx::Class::Optional::Dependencies->req_list_for(''); } qr/\Qreq_list_for() expects a requirement group name/, "req_list_for with empty groupname throws exception on run $_"; throws_ok { DBIx::Class::Optional::Dependencies->req_list_for('invalid_groupname'); } qr/Requirement group 'invalid_groupname' does not exist/, "req_list_for with invalid groupname throws exception on run $_"; } is_deeply( DBIx::Class::Optional::Dependencies->req_list_for('rdbms_pg'), { 'DBD::Pg' => '0', }, 'optional dependencies for deploying to Postgres ok'); is_deeply( DBIx::Class::Optional::Dependencies->req_list_for('test_rdbms_pg'), { 'DBD::Pg' => '2.009002', }, 'optional dependencies for testing Postgres with ENV var ok'); is_deeply( DBIx::Class::Optional::Dependencies->req_list_for('test_rdbms_oracle'), {}, 'optional dependencies for testing Oracle without ENV var ok'); done_testing; ������������DBIx-Class-0.082843/xt/podcoverage.t����������������������������������������������������������������0000644�0001750�0001750�00000013524�14240132261�016221� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use warnings; use strict; use Test::More; use lib qw(t/lib maint/.Generated_Pod/lib); use DBICTest; plan skip_all => "Skipping finicky test on older perl" if "$]" < 5.008005; require DBIx::Class; unless ( DBIx::Class::Optional::Dependencies->req_ok_for ('test_podcoverage') ) { my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('test_podcoverage'); $ENV{RELEASE_TESTING} ? die ("Failed to load release-testing module requirements: $missing") : plan skip_all => "Test needs: $missing" } # this has already been required but leave it here for CPANTS static analysis require Test::Pod::Coverage; # Since this is about checking documentation, a little documentation # of what this is doing might be in order. # The exceptions structure below is a hash keyed by the module # name. Any * in a name is treated like a wildcard and will behave # as expected. Modules are matched by longest string first, so # A::B::C will match even if there is A::B* # The value for each is a hash, which contains one or more # (although currently more than one makes no sense) of the following # things:- # skip => a true value means this module is not checked # ignore => array ref containing list of methods which # do not need to be documented. my $exceptions = { 'DBIx::Class' => { ignore => [qw/ MODIFY_CODE_ATTRIBUTES component_base_class mk_classdata mk_classaccessor /] }, 'DBIx::Class::Carp' => { ignore => [qw/ unimport /] }, 'DBIx::Class::Row' => { ignore => [qw/ MULTICREATE_DEBUG /], }, 'DBIx::Class::FilterColumn' => { ignore => [qw/ new update store_column get_column get_columns get_dirty_columns has_column_loaded /], }, 'DBIx::Class::ResultSource' => { ignore => [qw/ compare_relationship_keys pk_depends_on resolve_condition resolve_join resolve_prefetch STORABLE_freeze STORABLE_thaw /], }, 'DBIx::Class::ResultSet' => { ignore => [qw/ STORABLE_freeze STORABLE_thaw /], }, 'DBIx::Class::ResultSourceHandle' => { ignore => [qw/ schema source_moniker /], }, 'DBIx::Class::Storage' => { ignore => [qw/ schema cursor /] }, 'DBIx::Class::Schema' => { ignore => [qw/ setup_connection_class /] }, 'DBIx::Class::Schema::Versioned' => { ignore => [ qw/ connection /] }, 'DBIx::Class::Admin' => { ignore => [ qw/ BUILD /] }, 'DBIx::Class::Storage::DBI::Replicated*' => { ignore => [ qw/ connect_call_do_sql disconnect_call_do_sql /] }, 'DBIx::Class::Storage::Debug::PrettyTrace' => { ignore => [ qw/ print query_start query_end /] }, 'DBIx::Class::Admin::*' => { skip => 1 }, 'DBIx::Class::Optional::Dependencies' => { skip => 1 }, 'DBIx::Class::ClassResolver::PassThrough' => { skip => 1 }, 'DBIx::Class::Componentised' => { skip => 1 }, 'DBIx::Class::AccessorGroup' => { skip => 1 }, 'DBIx::Class::Relationship::*' => { skip => 1 }, 'DBIx::Class::ResultSetProxy' => { skip => 1 }, 'DBIx::Class::ResultSourceProxy' => { skip => 1 }, 'DBIx::Class::ResultSource::*' => { skip => 1 }, 'DBIx::Class::Storage::Statistics' => { skip => 1 }, 'DBIx::Class::Storage::DBI::Replicated::Types' => { skip => 1 }, 'DBIx::Class::GlobalDestruction' => { skip => 1 }, 'DBIx::Class::Storage::BlockRunner' => { skip => 1 }, # temporary # test some specific components whose parents are exempt below 'DBIx::Class::Relationship::Base' => {}, # internals 'DBIx::Class::_Util' => { skip => 1 }, 'DBIx::Class::SQLMaker*' => { skip => 1 }, 'DBIx::Class::SQLAHacks*' => { skip => 1 }, 'DBIx::Class::Storage::DBI*' => { skip => 1 }, 'SQL::Translator::*' => { skip => 1 }, # deprecated / backcompat stuff 'DBIx::Class::Serialize::Storable' => { skip => 1 }, 'DBIx::Class::CDBICompat*' => { skip => 1 }, 'DBIx::Class::ResultSetManager' => { skip => 1 }, 'DBIx::Class::DB' => { skip => 1 }, # skipped because the synopsis covers it clearly 'DBIx::Class::InflateColumn::File' => { skip => 1 }, }; my $ex_lookup = {}; for my $string (keys %$exceptions) { my $ex = $exceptions->{$string}; $string =~ s/\*/'.*?'/ge; my $re = qr/^$string$/; $ex_lookup->{$re} = $ex; } my @modules = sort { $a cmp $b } Test::Pod::Coverage::all_modules('lib'); foreach my $module (@modules) { SKIP: { my ($match) = grep { $module =~ $_ } (sort { length $b <=> length $a || $b cmp $a } (keys %$ex_lookup) ) ; my $ex = $ex_lookup->{$match} if $match; skip ("$module exempt", 1) if ($ex->{skip}); skip ("$module not loadable", 1) unless eval "require $module"; # build parms up from ignore list my $parms = {}; $parms->{trustme} = [ map { qr/^$_$/ } @{ $ex->{ignore} } ] if exists($ex->{ignore}); # run the test with the potentially modified parm set Test::Pod::Coverage::pod_coverage_ok($module, $parms, "$module POD coverage"); } } done_testing; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/xt/dbictest_unlink_guard.t������������������������������������������������������0000644�0001750�0001750�00000000725�14240132261�020265� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use warnings; use strict; use Test::More; use lib 't/lib'; use DBICTest; # Once upon a time there was a problem with a leaking $sth # which in turn delayed the $dbh destruction, which in turn # made the inode comaprison fire at the wrong time # This simulates the problem without doing much else for (1..2) { my $schema = DBICTest->init_schema( sqlite_use_file => 1 ); $schema->storage->ensure_connected; isa_ok ($schema, 'DBICTest::Schema'); } done_testing; �������������������������������������������DBIx-Class-0.082843/xt/old_envvars.t����������������������������������������������������������������0000644�0001750�0001750�00000001013�12757225440�016250� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use warnings; use strict; use Test::More; my @defined = grep { $ENV{$_} } qw/ DATA_DUMPER_TEST DBICTEST_STORAGE_STRESS DBICTEST_FORK_STRESS DBICTEST_THREAD_STRESS /; $SIG{ALRM} = sub { die "\n\nENVCHECK prompt timeout\n\n\n" }; if (@defined) { diag join "\n", 'The following ENV variables used to control the test suite, ' .'but no longer do so, please remove them from your environment', @defined, '', '(press Enter to continue)', ; alarm(10); <>; alarm(0); } ok(1); done_testing; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/xt/quote_sub.t������������������������������������������������������������������0000644�0001750�0001750�00000002050�14240132261�015721� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use warnings; use strict; use Test::More; use Test::Warn; use DBIx::Class::_Util 'quote_sub'; my $q = do { no strict 'vars'; quote_sub '$x = $x . "buh"; $x += 42'; }; warnings_exist { is $q->(), 42, 'Expected result after uninit and string/num conversion' } [ qr/Use of uninitialized value/i, qr/isn't numeric in addition/, ], 'Expected warnings, strict did not leak inside the qsub' or do { require B::Deparse; diag( B::Deparse->new->coderef2text( Sub::Quote::unquote_sub($q) ) ) } ; my $no_nothing_q = do { no strict; no warnings; quote_sub <<'EOC'; BEGIN { warn "-->${^WARNING_BITS}<--\n" }; my $n = "Test::Warn::warnings_exist"; warn "-->@{[ *{$n}{CODE} ]}<--\n"; EOC }; my $we_cref = Test::Warn->can('warnings_exist'); warnings_exist { $no_nothing_q->() } [ qr/^\-\-\>\0+\<\-\-$/m, qr/^\Q-->$we_cref<--\E$/m, ], 'Expected warnings, strict did not leak inside the qsub' or do { require B::Deparse; diag( B::Deparse->new->coderef2text( Sub::Quote::unquote_sub($no_nothing_q) ) ) } ; done_testing; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/xt/authors.t��������������������������������������������������������������������0000644�0001750�0001750�00000004065�14240132261�015410� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use warnings; use strict; use Test::More; use Config; use File::Spec; my @known_authors = do { # according to #p5p this is how one safely reads random unicode # this set of boilerplate is insane... wasn't perl unicode-king...? no warnings 'once'; require Encode; require PerlIO::encoding; local $PerlIO::encoding::fallback = Encode::FB_CROAK(); open (my $fh, '<:encoding(UTF-8)', 'AUTHORS') or die "Unable to open AUTHORS - can't happen: $!\n"; map { chomp; ( ( ! $_ or $_ =~ /^\s*\#/ ) ? () : $_ ) } <$fh>; } or die "Known AUTHORS file seems empty... can't happen..."; is_deeply ( [ grep { /^\s/ or /\s\s/ } @known_authors ], [], "No entries with leading or doubled space", ); is_deeply ( [ grep { / \:[^\s\/] /x or /^ [^:]*? \s+ \: /x } @known_authors ], [], "No entries with malformed nicks", ); is_deeply ( \@known_authors, [ sort { lc $a cmp lc $b } @known_authors ], 'Author list is case-insensitively sorted' ); my $email_re = qr/( \< [^\<\>]+ \> ) $/x; my %known_authors; for (@known_authors) { my ($name_email) = m/ ^ (?: [^\:]+ \: \s )? (.+) /x; my ($email) = $name_email =~ $email_re; fail "Duplicate found: $name_email" if ( $known_authors{$name_email}++ or ( $email and $known_authors{$email}++ ) ); } # augh taint mode if (length $ENV{PATH}) { ( $ENV{PATH} ) = join ( $Config{path_sep}, map { length($_) ? File::Spec->rel2abs($_) : () } split /\Q$Config{path_sep}/, $ENV{PATH} ) =~ /\A(.+)\z/; } # no git-check when smoking a PR if ( ( ! $ENV{TRAVIS_PULL_REQUEST} or $ENV{TRAVIS_PULL_REQUEST} eq "false" ) and -d '.git' ) { binmode (Test::More->builder->$_, ':utf8') for qw/output failure_output todo_output/; # this may fail - not every system has git for ( map { my ($gitname) = m/^ \s* \d+ \s* (.+?) \s* $/mx; utf8::decode($gitname); $gitname } qx( git shortlog -e -s ) ) { my ($eml) = $_ =~ $email_re; ok $known_authors{$eml}, "Commit author '$_' (from .mailmap-aware `git shortlog -e -s`) reflected in ./AUTHORS"; } } done_testing; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/xt/strictures.t�����������������������������������������������������������������0000644�0001750�0001750�00000003354�14240132261�016132� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use warnings; use strict; use Test::More; use File::Find; use File::Spec; use Config; use lib 't/lib'; use DBICTest; unless ( DBIx::Class::Optional::Dependencies->req_ok_for ('test_strictures') ) { my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('test_strictures'); $ENV{RELEASE_TESTING} ? die ("Failed to load release-testing module requirements: $missing") : plan skip_all => "Test needs: $missing" } use File::Find; # The rationale is - if we can load all our optdeps # that are related to lib/ - then we should be able to run # perl -c checks (via syntax_ok), and all should just work my $missing_groupdeps_present = grep { ! DBIx::Class::Optional::Dependencies->req_ok_for($_) } grep { $_ !~ /^ (?: test | rdbms | dist ) _ /x } keys %{DBIx::Class::Optional::Dependencies->req_group_list} ; # don't test syntax when RT#106935 is triggered (mainly CI) # FIXME - remove when RT is resolved my $tainted_relpath = ( length $ENV{PATH} and ${^TAINT} and grep { ! File::Spec->file_name_is_absolute($_) } split /\Q$Config{path_sep}/, $ENV{PATH} ) ? 1 : 0; find({ wanted => sub { -f $_ or return; m/\.(?: pm | pl | t )$ /ix or return; return if m{^(?: maint/Makefile.PL.inc/.+ # all the maint inc snippets are auto-strictured | t/lib/DBICTest/Util/OverrideRequire.pm # no stictures by design (load order sensitive) )$}x; my $f = $_; Test::Strict::strict_ok($f); Test::Strict::warnings_ok($f); Test::Strict::syntax_ok($f) if ( ! $tainted_relpath and ! $missing_groupdeps_present and $f =~ /^ (?: lib )/x ); }, no_chdir => 1, }, (qw(lib t examples maint)) ); done_testing; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/xt/footers.t��������������������������������������������������������������������0000644�0001750�0001750�00000002731�14240132261�015402� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use warnings; use strict; use Test::More; use File::Find; my $boilerplate_headings = q{ =head1 FURTHER QUESTIONS? Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>. =head1 COPYRIGHT AND LICENSE This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE> by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can redistribute it and/or modify it under the same terms as the L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>. }; find({ wanted => sub { my $fn = $_; return unless -f $fn; return unless $fn =~ / \. (?: pm | pod ) $ /ix; my $data = do { local (@ARGV, $/) = $fn; <> }; if ($data !~ /^=head1 NAME/m) { # the generator is full of false positives, .pod is where it's at return if $fn =~ qr{\Qlib/DBIx/Class/Optional/Dependencies.pm}; ok ( $data !~ /\bcopyright\b/i, "No copyright notices in $fn without apparent POD" ); } elsif ($fn =~ qr{\Qlib/DBIx/Class.}) { # nothing to check there - a static set of words } else { ok ( $data !~ / ^ =head1 \s $_ /xmi, "No standalone $_ headings in $fn" ) for qw(AUTHOR CONTRIBUTOR LICENSE LICENCE); ok ( $data !~ / ^ =head1 \s COPYRIGHT \s (?! AND \s LICENSE )/xmi, "No standalone COPYRIGHT headings in $fn" ); ok ($data =~ / \Q$boilerplate_headings\E (?! .*? ^ =head )/xms, "Expected headings found at the end of $fn"); } }, no_chdir => 1, }, (qw(lib examples)) ); done_testing; ���������������������������������������DBIx-Class-0.082843/xt/standalone_testschema_resultclasses.t����������������������������������������0000644�0001750�0001750�00000002750�14240132261�023246� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use warnings; use strict; BEGIN { delete $ENV{DBICTEST_VERSION_WARNS_INDISCRIMINATELY} } use DBIx::Class::_Util 'sigwarn_silencer'; use if DBIx::Class::_ENV_::BROKEN_FORK, 'threads'; use Test::More; use File::Find; use Time::HiRes 'sleep'; use lib 't/lib'; my $worker = sub { my $fn = shift; if (my @offenders = grep { $_ !~ m{DBIx/Class/(?:_Util|Carp)\.pm} } grep { $_ =~ /(^|\/)DBI/ } keys %INC) { die "Wtf - DBI* modules present in %INC: @offenders"; } local $SIG{__WARN__} = sigwarn_silencer( qr/\bdeprecated\b/i ); require( ( $fn =~ m| t/lib/ (.+) |x )[0] ); # untaint and strip lib-part (. is unavailable under -T) return 42; }; find({ wanted => sub { return unless ( -f $_ and $_ =~ /\.pm$/ ); if (DBIx::Class::_ENV_::BROKEN_FORK) { # older perls crash if threads are spawned way too quickly, sleep for 100 msecs my $t = threads->create(sub { $worker->($_) }); sleep 0.1; is ($t->join, 42, "Thread loading $_ did not finish successfully") || diag ($t->can('error') ? $t->error : 'threads.pm too old to retrieve the error :(' ); } else { my $pid = fork(); if (! defined $pid) { die "fork failed: $!" } elsif (!$pid) { $worker->($_); exit 0; } is ( waitpid($pid, 0), $pid, "Fork $pid terminated sucessfully"); my $ex = $? >> 8; is ( $ex, 0, "Loading $_ ($pid) exitted with $ex" ); } }, no_chdir => 1, }, 't/lib/DBICTest/Schema/'); done_testing; ������������������������DBIx-Class-0.082843/Makefile.PL���������������������������������������������������������������������0000644�0001750�0001750�00000021072�14240132261�015052� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use 5.008001; # Work around one of the most damaging "improvements" made # during the modern-perl-era BEGIN { push @INC, '.' unless grep { $_ eq '.' } @INC } # For the time being simply generate UNKNOWN cperl test reports # I would *LOVE* to be able to support it seamlessly, but with # rurban adamant that CPAN ought to be gentrified... pity. # https://irclog.perlgeek.de/perl11/2016-06-08#i_12624929 ( 06:57 ~ 09:34 ) BEGIN { die <<'EOE' if $^V =~ /c/; Currently DBIx::Class is not attempting to be compatible with CPerl For more info: https://irclog.perlgeek.de/perl11/2016-06-08#i_12624929 EOE } use inc::Module::Install 1.06; BEGIN { makemaker_args( NORECURS => 1 ) } # needs to happen early for old EUMM ## ## DO NOT USE THIS HACK IN YOUR DISTS!!! (it makes #toolchain sad) ## # get cpanX --installdeps . to behave in a checkout (most users do not expect # the deps for a full test suite run, and if they do - there's MI::AutoInstall # for that) BEGIN { $Module::Install::AUTHOR = 0 if (grep { $ENV{"PERL5_${_}_IS_RUNNING"} } (qw/CPANM CPANPLUS CPAN/) ); } name 'DBIx-Class'; version_from 'lib/DBIx/Class.pm'; perl_version '5.008001'; ### ### DO NOT ADD OPTIONAL DEPENDENCIES HERE, EVEN AS recommends() ### All of them *MUST* go to DBIx::Class::Optional::Dependencies ### my $runtime_requires = { # DBI itself should be capable of installation and execution in pure-perl # mode. However it has never been tested yet, so consider XS for the time # being ### ### IMPORTANT - do not raise this dependency ### even though many bugfixes are present in newer versions, the general DBIC ### rule is to bend over backwards for available DBI versions (given upgrading ### them is often *not* easy or even possible) ### 'DBI' => '1.57', # XS (or XS-dependent) libs 'Sub::Name' => '0.04', # pure-perl (FatPack-able) libs 'Class::Accessor::Grouped' => '0.10012', 'Class::C3::Componentised' => '1.0009', 'Class::Inspector' => '1.24', 'Config::Any' => '0.20', 'Context::Preserve' => '0.01', 'Data::Dumper::Concise' => '2.020', 'Devel::GlobalDestruction' => '0.09', 'Hash::Merge' => '0.12', 'Moo' => '2.000', 'MRO::Compat' => '0.12', 'Module::Find' => '0.07', 'namespace::clean' => '0.24', 'Path::Class' => '0.18', 'Scope::Guard' => '0.03', 'SQL::Abstract::Classic' => '1.91', 'Try::Tiny' => '0.07', # Technically this is not a core dependency - it is only required # by the MySQL codepath. However this particular version is bundled # since 5.10.0 and is a pure-perl module anyway - let it slide 'Text::Balanced' => '2.00', }; my $build_requires = { }; my $test_requires = { 'File::Temp' => '0.22', 'Test::Deep' => '0.101', 'Test::Exception' => '0.31', 'Test::Warn' => '0.21', 'Test::More' => '0.94', # needed for testing only, not for operation # we will move away from this dep eventually, perhaps to DBD::CSV or something ### ### IMPORTANT - do not raise this dependency ### even though many bugfixes are present in newer versions, the general DBIC ### rule is to bend over backwards for available DBDs (given upgrading them is ### often *not* easy or even possible) ### 'DBD::SQLite' => '1.29', # this is already a dep of n::c, but just in case - used by t/55namespaces_cleaned.t # remove and do a manual glob-collection if n::c is no longer a dep 'Package::Stash' => '0.28', }; # if the user has this env var set and no SQLT installed, tests will fail # Note - this is added as test_requires *directly*, so it gets properly # excluded on META.yml cleansing (even though no dist can be created from this) # we force this req regarless of author_deps, worst case scenario it will # be specified twice # # also note that we *do* set dynamic_config => 0, as this is the only thing # that we determine dynamically, and in all fairness if someone sets the # envvar *and* is not running a full Makefile/make/maketest cycle - they get # to keep the pieces if ($ENV{DBICTEST_SQLT_DEPLOY}) { local @INC = ('lib', @INC); require DBIx::Class::Optional::Dependencies; my $dep_req = DBIx::Class::Optional::Dependencies->req_list_for('deploy'); for (keys %$dep_req) { test_requires ($_ => $dep_req->{$_}) } } tests_recursive ('t'); tests_recursive ('xt') if ( $Module::Install::AUTHOR or $ENV{DBICTEST_RUN_ALL_TESTS} or ( ( $ENV{TRAVIS}||'' ) eq 'true' and ($ENV{TRAVIS_REPO_SLUG}||'') =~ m|\w+/DBIx-Class$| ) or ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL5_CPANM_IS_RUNNING} and ! $ENV{RELEASE_TESTING} ) ); install_script (qw| script/dbicadmin |); # this is so we can order requires alphabetically # copies are needed for potential author requires injection my $reqs = { build_requires => { %$build_requires }, requires => { %$runtime_requires }, test_requires => { %$test_requires }, }; # only do author-includes if not part of a `make` run if ($Module::Install::AUTHOR and ! $ENV{MAKELEVEL}) { invoke_author_mode() } else { # make sure this Makefile can not be used to make a dist # (without the author includes there are no meta cleanup, no sanity checks, etc) postamble <<EOP; create_distdir: nonauthor_stop_distdir_creation nonauthor_stop_distdir_creation: \t\$(NOECHO) \$(ECHO) Creation of dists in non-author mode is not allowed \t\$(NOECHO) \$(FALSE) EOP } # compose final req list, for alphabetical ordering my %final_req; for my $rtype (keys %$reqs) { for my $mod (keys %{$reqs->{$rtype}} ) { # sanity check req duplications die "$mod specified as both a '$rtype' and a '$final_req{$mod}[0]'\n" if $final_req{$mod}; $final_req{$mod} = [ $rtype, $reqs->{$rtype}{$mod}||0 ], } } # actual require for my $mod (sort keys %final_req) { my ($rtype, $ver) = @{$final_req{$mod}}; no strict 'refs'; $rtype->($mod, $ver); } # author-mode or not - this is where we show a list of missing deps # IFF we are running interactively auto_install(); { # M::I understands unicode in meta but does not write with the right # layers - fhtagn!!! local $SIG{__WARN__} = sub { warn $_[0] unless $_[0] =~ /Wide character in print/ }; WriteAll(); } exit 0; ### ### Nothing user-serviceable beyond this point ### (none of this executes on regular install) ### # needs to be here to keep 5.8 string eval happy # (the include of Makefile.PL.inc loop) my $mm_proto; sub invoke_author_mode { # get options here, make $args available to all snippets require Getopt::Long; my $getopt = Getopt::Long::Parser->new( config => [qw/gnu_getopt bundling_override no_ignore_case pass_through/] ); my $args = { skip_author_deps => undef, }; $getopt->getoptions($args, qw/ skip_author_deps|skip-author-deps /); if (@ARGV) { warn "\nIgnoring unrecognized option(s): @ARGV\n\n"; } # We need the MM facilities to generate the pieces for the final MM run. # Just instantiate a throaway object here # # Also EUMM and MI disagree on what is the format of Meta->name, just # punt here until a new M::I is shipped (if at all) my $name = Meta->name || die 'The Module::Install metadata must be available at this point but is not - did you rearrange the Makefile.PL...?'; $name =~ s/\-/::/g; $mm_proto = ExtUtils::MakeMaker->new({ NORECURS => 1, NAME => $name, }); # Crutch for DISTBUILDING_IN_HELL # Spits back a working dos2unix snippet to be used on the supplied path(s) # Ironically EUMM's dos2unix is broken on win32 itself - it does # not take into account the CRLF layer present on win32 my $crlf_fixup = sub { return '' unless ($^O eq 'MSWin32' or $^O eq 'cygwin'); my $targets = join ', ', map { "q($_)" } @_; "\t" . $mm_proto->oneliner( qq(\$ENV{PERLIO}='unix' and system( \$^X, qw( -MExtUtils::Command -e dos2unix -- ), $targets ) ) ); }; # we are in the process of (re)writing the makefile - some things we # call below very well may fail local $ENV{DBICTEST_NO_MAKEFILE_VERIFICATION} = 1; require File::Spec; # string-eval, not do(), because we need to provide the # $mm_proto, $reqs and $*_requires lexicals to the included file # (some includes *do* modify $reqs above) for my $inc (sort glob ( File::Spec->catfile('maint', 'Makefile.PL.inc', '*') ) ) { my $src = do { local (@ARGV, $/) = $inc; <> } or die $!; eval "use warnings; use strict; $src" or die sprintf "Failed execution of %s: %s\n", $inc, ($@ || $! || 'Unknown error'), ; } } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/examples/�����������������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�014735� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/examples/Schema/����������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�016135� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/examples/Schema/MyApp/����������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�017163� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/examples/Schema/MyApp/Schema/���������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�020363� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/examples/Schema/MyApp/Schema/Result/��������������������������������������������0000755�0001750�0001750�00000000000�14240676463�021641� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/examples/Schema/MyApp/Schema/Result/Artist.pm�����������������������������������0000644�0001750�0001750�00000000705�13271562527�023445� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package MyApp::Schema::Result::Artist; use warnings; use strict; use base qw( DBIx::Class::Core ); __PACKAGE__->table('artist'); __PACKAGE__->add_columns( artistid => { data_type => 'integer', is_auto_increment => 1 }, name => { data_type => 'text', }, ); __PACKAGE__->set_primary_key('artistid'); __PACKAGE__->add_unique_constraint([qw( name )]); __PACKAGE__->has_many('cds' => 'MyApp::Schema::Result::Cd', 'artistid'); 1; �����������������������������������������������������������DBIx-Class-0.082843/examples/Schema/MyApp/Schema/Result/Track.pm������������������������������������0000644�0001750�0001750�00000000761�13271562527�023245� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package MyApp::Schema::Result::Track; use warnings; use strict; use base qw( DBIx::Class::Core ); __PACKAGE__->table('track'); __PACKAGE__->add_columns( trackid => { data_type => 'integer', is_auto_increment => 1 }, cdid => { data_type => 'integer', }, title => { data_type => 'text', }, ); __PACKAGE__->set_primary_key('trackid'); __PACKAGE__->add_unique_constraint([qw( title cdid )]); __PACKAGE__->belongs_to('cd' => 'MyApp::Schema::Result::Cd', 'cdid'); 1; ���������������DBIx-Class-0.082843/examples/Schema/MyApp/Schema/Result/Cd.pm���������������������������������������0000644�0001750�0001750�00000001210�13271562527�022515� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package MyApp::Schema::Result::Cd; use warnings; use strict; use base qw( DBIx::Class::Core ); __PACKAGE__->table('cd'); __PACKAGE__->add_columns( cdid => { data_type => 'integer', is_auto_increment => 1 }, artistid => { data_type => 'integer', }, title => { data_type => 'text', }, year => { data_type => 'datetime', is_nullable => 1, }, ); __PACKAGE__->set_primary_key('cdid'); __PACKAGE__->add_unique_constraint([qw( title artistid )]); __PACKAGE__->belongs_to('artist' => 'MyApp::Schema::Result::Artist', 'artistid'); __PACKAGE__->has_many('tracks' => 'MyApp::Schema::Result::Track', 'cdid'); 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/examples/Schema/MyApp/Schema.pm�������������������������������������������������0000644�0001750�0001750�00000000167�14240132261�020704� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package MyApp::Schema; use warnings; use strict; use base qw/DBIx::Class::Schema/; __PACKAGE__->load_namespaces; 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/examples/Schema/testdb.pl�������������������������������������������������������0000755�0001750�0001750�00000005476�14240132261�017755� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/env perl use warnings; use strict; use lib '.'; use MyApp::Schema; use Path::Class 'file'; my $db_fn = file($INC{'MyApp/Schema.pm'})->dir->parent->file('db/example.db'); # for other DSNs, e.g. MySql, see the perldoc for the relevant dbd # driver, e.g perldoc L<DBD::mysql>. my $schema = MyApp::Schema->connect("dbi:SQLite:$db_fn"); get_tracks_by_cd('Bad'); get_tracks_by_artist('Michael Jackson'); get_cd_by_track('Stan'); get_cds_by_artist('Michael Jackson'); get_artist_by_track('Dirty Diana'); get_artist_by_cd('The Marshall Mathers LP'); sub get_tracks_by_cd { my $cdtitle = shift; print "get_tracks_by_cd($cdtitle):\n"; my $rs = $schema->resultset('Track')->search( { 'cd.title' => $cdtitle }, { join => [qw/ cd /], } ); while (my $track = $rs->next) { print $track->title . "\n"; } print "\n"; } sub get_tracks_by_artist { my $artistname = shift; print "get_tracks_by_artist($artistname):\n"; my $rs = $schema->resultset('Track')->search( { 'artist.name' => $artistname }, { join => { 'cd' => 'artist' }, } ); while (my $track = $rs->next) { print $track->title . " (from the CD '" . $track->cd->title . "')\n"; } print "\n"; } sub get_cd_by_track { my $tracktitle = shift; print "get_cd_by_track($tracktitle):\n"; my $rs = $schema->resultset('Cd')->search( { 'tracks.title' => $tracktitle }, { join => [qw/ tracks /], } ); my $cd = $rs->first; print $cd->title . " has the track '$tracktitle'.\n\n"; } sub get_cds_by_artist { my $artistname = shift; print "get_cds_by_artist($artistname):\n"; my $rs = $schema->resultset('Cd')->search( { 'artist.name' => $artistname }, { join => [qw/ artist /], } ); while (my $cd = $rs->next) { print $cd->title . "\n"; } print "\n"; } sub get_artist_by_track { my $tracktitle = shift; print "get_artist_by_track($tracktitle):\n"; my $rs = $schema->resultset('Artist')->search( { 'tracks.title' => $tracktitle }, { join => { 'cds' => 'tracks' } } ); my $artist = $rs->first; print $artist->name . " recorded the track '$tracktitle'.\n\n"; } sub get_artist_by_cd { my $cdtitle = shift; print "get_artist_by_cd($cdtitle):\n"; my $rs = $schema->resultset('Artist')->search( { 'cds.title' => $cdtitle }, { join => [qw/ cds /], } ); my $artist = $rs->first; print $artist->name . " recorded the CD '$cdtitle'.\n\n"; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/examples/Schema/db/�������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�016522� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/examples/Schema/db/example.sql��������������������������������������������������0000644�0001750�0001750�00000001503�14240676413�020670� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������CREATE TABLE "artist" ( "artistid" INTEGER PRIMARY KEY NOT NULL, "name" text NOT NULL ); CREATE UNIQUE INDEX "artist_name" ON "artist" ("name"); CREATE TABLE "cd" ( "cdid" INTEGER PRIMARY KEY NOT NULL, "artistid" integer NOT NULL, "title" text NOT NULL, "year" datetime, FOREIGN KEY ("artistid") REFERENCES "artist"("artistid") ON DELETE CASCADE ON UPDATE CASCADE ); CREATE INDEX "cd_idx_artistid" ON "cd" ("artistid"); CREATE UNIQUE INDEX "cd_title_artistid" ON "cd" ("title", "artistid"); CREATE TABLE "track" ( "trackid" INTEGER PRIMARY KEY NOT NULL, "cdid" integer NOT NULL, "title" text NOT NULL, FOREIGN KEY ("cdid") REFERENCES "cd"("cdid") ON DELETE CASCADE ON UPDATE CASCADE ); CREATE INDEX "track_idx_cdid" ON "track" ("cdid"); CREATE UNIQUE INDEX "track_title_cdid" ON "track" ("title", "cdid"); ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/examples/Schema/db/example.db���������������������������������������������������0000644�0001750�0001750�00000110000�14240676413�020447� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SQLite format 3���@ ������ �������������������������������������������������������������.8 ��� ,�AW ,����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������]h-indextrack_title_cdidtrack CREATE UNIQUE INDEX track_title_cdid ON track (title, cdid)Jg)cindextrack_idx_cdidtrackCREATE INDEX track_idx_cdid ON track (cdid)RftabletracktrackCREATE TABLE track ( trackid INTEGER PRIMARY KEY NOT NULL, cdid integer NOT NULL, title text NOT NULL, FOREIGN KEY (cdid) REFERENCES cd(cdid) ON DELETE CASCADE ON UPDATE CASCADE )]e/indexcd_title_artistidcdCREATE UNIQUE INDEX cd_title_artistid ON cd (title, artistid)Jd+gindexcd_idx_artistidcdCREATE INDEX cd_idx_artistid ON cd (artistid)gc9tablecdcdCREATE TABLE cd ( cdid INTEGER PRIMARY KEY NOT NULL, artistid integer NOT NULL, title text NOT NULL, year datetime, FOREIGN KEY (artistid) REFERENCES artist(artistid) ON DELETE CASCADE ON UPDATE CASCADE )Mb#mindexartist_nameartistCREATE UNIQUE INDEX artist_name ON artist (name)na7tableartistartistCREATE TABLE artist ( artistid INTEGER PRIMARY KEY NOT NULL, name text NOT NULL ) ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� �Eminem�+Michael Jackson �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� Eminem+ Michael Jackson �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������;�The Marshall Mathers LP� �Bad � �Thriller ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������  �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������;The Marshall Mathers LP Bad  Thriller ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#Dirty Diana � Beat It�+Smooth Criminal�)Leave Me Alone� #Billie Jean �Stan�%The Way I Am �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������    ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#Dirty Diana  Beat It+Smooth Criminal)Leave Me Alone# Billie Jean Stan% The Way I AmDBIx-Class-0.082843/examples/Schema/insertdb.pl�����������������������������������������������������0000755�0001750�0001750�00000002356�14240132261�020274� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/env perl use strict; use warnings; use lib '.'; use MyApp::Schema; use Path::Class 'file'; my $db_fn = file($INC{'MyApp/Schema.pm'})->dir->parent->file('db/example.db'); my $schema = MyApp::Schema->connect("dbi:SQLite:$db_fn"); my @artists = (['Michael Jackson'], ['Eminem']); $schema->populate('Artist', [ [qw/name/], @artists, ]); my %albums = ( 'Thriller' => 'Michael Jackson', 'Bad' => 'Michael Jackson', 'The Marshall Mathers LP' => 'Eminem', ); my @cds; foreach my $lp (keys %albums) { my $artist = $schema->resultset('Artist')->find({ name => $albums{$lp} }); push @cds, [$lp, $artist->id]; } $schema->populate('Cd', [ [qw/title artistid/], @cds, ]); my %tracks = ( 'Beat It' => 'Thriller', 'Billie Jean' => 'Thriller', 'Dirty Diana' => 'Bad', 'Smooth Criminal' => 'Bad', 'Leave Me Alone' => 'Bad', 'Stan' => 'The Marshall Mathers LP', 'The Way I Am' => 'The Marshall Mathers LP', ); my @tracks; foreach my $track (keys %tracks) { my $cd = $schema->resultset('Cd')->find({ title => $tracks{$track}, }); push @tracks, [$cd->id, $track]; } $schema->populate('Track',[ [qw/cdid title/], @tracks, ]); ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/examples/Benchmarks/������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�017012� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/examples/Benchmarks/benchmark_hashrefinflator.pl��������������������������������0000755�0001750�0001750�00000013435�12757225440�024545� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/env perl # # So you wrote a new mk_hash implementation which passed all tests # (particularly t/inflate/hri.t) and would like to see how it holds # up against older (and often buggy) versions of the same. Just run # this script and wait (no editing necessary) use warnings; use strict; use FindBin; use lib ("$FindBin::Bin/../../lib", "$FindBin::Bin/../../t/lib"); use Class::Unload '0.07'; use Benchmark (); use Dumbbench; use Benchmark::Dumb ':all'; use DBICTest; # for git reporting to work, and to use it as INC key directly chdir ("$FindBin::Bin/../../lib"); my $hri_fn = 'DBIx/Class/ResultClass/HashRefInflator.pm'; require Getopt::Long; my $getopt = Getopt::Long::Parser->new( config => [qw/gnu_getopt bundling_override no_ignore_case pass_through/] ); my $args = { 'bench-commits' => 2, 'no-cpufreq-checks' => undef, }; $getopt->getoptions($args, qw/ bench-commits no-cpufreq-checks /); if ( !$args->{'no-cpufreq-checks'} and $^O eq 'linux' and -r '/sys/devices/system/cpu/cpu0/cpufreq/scaling_cur_freq' ) { my ($min_freq, $max_freq, $governor) = map { local @ARGV = $_; my $s = <>; chomp $s; $s } qw| /sys/devices/system/cpu/cpu0/cpufreq/scaling_min_freq /sys/devices/system/cpu/cpu0/cpufreq/scaling_max_freq /sys/devices/system/cpu/cpu0/cpufreq/scaling_governor |; if ($min_freq != $max_freq) { die "Your OS seems to have an active CPU governor '$governor' -" . ' this will render benchmark results meaningless. Disable it' . ' by setting /sys/devices/system/cpu/cpu*/cpufreq/scaling_max_freq' . ' to the same value as /sys/devices/system/cpu/cpu*/cpufreq/scaling_min_freq' . " ($min_freq). Alternatively skip this check with --no-cpufreq-checks.\n"; } } my %skip_commits = map { $_ => 1 } qw/ e1540ee a5b2936 4613ee1 419ff18 /; my (@to_bench, $not_latest); for my $commit (`git log --format=%h HEAD ^8330454^ $hri_fn `) { chomp $commit; next if $skip_commits{$commit}; my $diff = `git show -w -U0 --format=%ar%n%b $commit $hri_fn`; if ($diff =~ /^ (?: \@\@ \s .+? | [+-] sub \s) \$? mk_hash /xm ) { my ($age) = $diff =~ /\A(.+?)\n/; push @to_bench, { commit => $commit, title => $not_latest ? $commit : 'LATEST', desc => sprintf ("commit %s (%smade %s)...\t\t", $commit, $not_latest ? '' : 'LATEST, ', $age, ), code => scalar `git show $commit:lib/DBIx/Class/ResultClass/HashRefInflator.pm`, }; last if @to_bench == $args->{'bench-commits'}; $not_latest = 1; } } die "Can't find any commits... something is wrong\n" unless @to_bench; unshift @to_bench, { desc => "the current uncommitted HRI...\t\t\t\t", title => 'CURRENT', code => do { local (@ARGV, $/) = ($hri_fn); <> }, } if `git status --porcelain $hri_fn`; printf "\nAbout to benchmark %d HRI variants (%s)\n", scalar @to_bench, (join ', ', map { $_->{title} } @to_bench), ; my $schema = DBICTest->init_schema(); # add some extra data for the complex test $schema->resultset ('Artist')->create({ name => 'largggge', cds => [ { genre => { name => 'massive' }, title => 'largesse', year => 2011, tracks => [ { title => 'larguitto', cd_single => { title => 'mongo', year => 2012, artist => 1, genre => { name => 'massive' }, tracks => [ { title => 'yo momma' }, { title => 'so much momma' }, ], }, }, ], }, ], }); # get what data to feed during benchmarks { package _BENCH_::DBIC::InflateResult::Trap; sub inflate_result { shift; return \@_ } } my %bench_dataset = ( simple => do { my $rs = $schema->resultset ('Artist')->search ({}, { prefetch => { cds => 'tracks' }, result_class => '_BENCH_::DBIC::InflateResult::Trap', }); [ $rs->all ]; }, complex => do { my $rs = $schema->resultset ('Artist')->search ({}, { prefetch => { cds => [ { tracks => { cd_single => [qw/artist genre tracks/] } }, 'genre' ] }, result_class => '_BENCH_::DBIC::InflateResult::Trap', }); [ $rs->all ]; }, ); # benchmark coderefs (num iters is set below) my %num_iters; my %bench = ( map { $_ => eval "sub { for (1 .. (\$num_iters{$_}||1) ) { DBIx::Class::ResultClass::HashRefInflator->inflate_result(\$bench_dataset{$_}) } }" } qw/simple complex/ ); $|++; print "\nPre-timing current HRI to determine iteration counts..."; # crude unreliable and quick test how many to run in the loop # designed to return a value so that there ~ 1/$div runs in a second # (based on the current @INC implementation) my $div = 1; require DBIx::Class::ResultClass::HashRefInflator; for (qw/simple complex/) { local $SIG{__WARN__} = sub {}; my $tst = Benchmark::timethis(-1, $bench{$_}, '', 'none'); $num_iters{$_} ||= int( $tst->[5] / $tst->[1] / $div ); $num_iters{$_} ||= 1; } print " done\n\nBenchmarking - this can taka a LOOOOOONG time\n\n"; my %results; for my $bch (@to_bench) { Class::Unload->unload('DBIx::Class::ResultClass::HashRefInflator'); eval $bch->{code} or die $@; $INC{'DBIx/Class/ResultClass/HashRefInflator.pm'} = $bch->{title}; for my $t (qw/simple complex/) { my $label = "Timing $num_iters{$t} $t iterations of $bch->{desc}"; my $bench = Dumbbench->new( initial_runs => 30, target_rel_precision => 0.0005, ); $bench->add_instances( Dumbbench::Instance::PerlSub->new ( name => $label, code => $bench{$t}, )); print $label; $bench->run; print( ($results{ (substr $t, 0, 1) . "_$bch->{title}" } = Benchmark::Dumb->_new( instance => ($bench->instances)[0] ) ) ->timestr('') ); print "\n"; } } for my $t (qw/s c/) { cmpthese ({ map { $_ =~ /^${t}_/ ? ( $_ => $results{$_}) : () } keys %results }, '', ''); } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/examples/Benchmarks/benchmark_datafetch.pl��������������������������������������0000755�0001750�0001750�00000002420�12773437412�023303� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/env perl use strict; use warnings; use Benchmark qw/cmpthese/; use FindBin; use lib "$FindBin::Bin/../../t/lib"; use lib "$FindBin::Bin/../../lib"; use DBICTest::Schema; use DBIx::Class::ResultClass::HashRefInflator; # older dbic didn't load it printf "Benchmarking DBIC version %s\n", DBIx::Class->VERSION; my $schema = DBICTest::Schema->connect ('dbi:SQLite::memory:'); $schema->deploy; my $rs = $schema->resultset ('Artist'); my $hri_rs = $rs->search ({}, { result_class => 'DBIx::Class::ResultClass::HashRefInflator' } ); #DB::enable_profile(); #my @foo = $hri_rs->all; #DB::disable_profile(); #exit; my $dbh = $schema->storage->dbh; my $sql = sprintf ('SELECT %s FROM %s %s', join (',', @{$rs->_resolved_attrs->{select}} ), $rs->result_source->name, $rs->_resolved_attrs->{alias}, ); for (1,10,20,50,200,2500,10000) { $rs->delete; $rs->populate ([ map { { name => "Art_$_"} } (1 .. $_) ]); print "\nRetrieval of $_ rows\n"; bench(); } sub bench { cmpthese(-3, { Cursor => sub { my @r = $rs->cursor->all }, HRI => sub { my @r = $hri_rs->all }, RowObj => sub { my @r = $rs->all }, DBI_AoH => sub { my @r = @{ $dbh->selectall_arrayref ($sql, { Slice => {} }) } }, DBI_AoA=> sub { my @r = @{ $dbh->selectall_arrayref ($sql) } }, }); } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/examples/MiscTools/�������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676463�016651� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/examples/MiscTools/determine_cpan_joint_deps.pl���������������������������������0000755�0001750�0001750�00000002731�12757225440�024403� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/env perl use warnings; use strict; use CPANDB; use DBIx::Class::Schema::Loader 0.05; use Data::Dumper::Concise; { package CPANDB::Schema; use base qw/DBIx::Class::Schema::Loader/; __PACKAGE__->loader_options ( naming => 'v5', ); } my $s = CPANDB::Schema->connect (sub { CPANDB->dbh } ); # reference names are unstable - just create rels manually my $distrsrc = $s->source('Distribution'); # the has_many helper is a class-only method (why?), thus # manual add_rel $distrsrc->add_relationship ( 'deps', $s->class('Dependency'), { 'foreign.distribution' => 'self.' . ($distrsrc->primary_columns)[0] }, { accessor => 'multi', join_type => 'left' }, ); # here is how one could use the helper currently: # #my $distresult = $s->class('Distribution'); #$distresult->has_many ( # 'deps', # $s->class('Dependency'), # 'distribution', #); #$s->unregister_source ('Distribution'); #$s->register_class ('Distribution', $distresult); # a proof of concept how to find out who uses us *AND* SQLT my $us_and_sqlt = $s->resultset('Distribution')->search ( { 'deps.dependency' => 'DBIx-Class', 'deps_2.dependency' => 'SQL-Translator', }, { join => [qw/deps deps/], order_by => 'me.author', select => [ 'me.distribution', 'me.author', map { "$_.phase" } (qw/deps deps_2/)], as => [qw/dist_name dist_author req_dbic_at req_sqlt_at/], result_class => 'DBIx::Class::ResultClass::HashRefInflator', }, ); print Dumper [$us_and_sqlt->all]; ���������������������������������������DBIx-Class-0.082843/MANIFEST������������������������������������������������������������������������0000644�0001750�0001750�00000052115�14240676463�014254� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������AUTHORS Changes examples/Benchmarks/benchmark_datafetch.pl examples/Benchmarks/benchmark_hashrefinflator.pl examples/MiscTools/determine_cpan_joint_deps.pl examples/Schema/db/example.db examples/Schema/db/example.sql examples/Schema/insertdb.pl examples/Schema/MyApp/Schema.pm examples/Schema/MyApp/Schema/Result/Artist.pm examples/Schema/MyApp/Schema/Result/Cd.pm examples/Schema/MyApp/Schema/Result/Track.pm examples/Schema/testdb.pl 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/Scripts.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/DBIx/Class.pm lib/DBIx/Class.pod lib/DBIx/Class/_Util.pm lib/DBIx/Class/AccessorGroup.pm lib/DBIx/Class/Admin.pm lib/DBIx/Class/Admin/Descriptive.pm lib/DBIx/Class/Admin/Types.pm lib/DBIx/Class/Admin/Usage.pm lib/DBIx/Class/Carp.pm lib/DBIx/Class/CDBICompat.pm lib/DBIx/Class/CDBICompat/AbstractSearch.pm lib/DBIx/Class/CDBICompat/AccessorMapping.pm lib/DBIx/Class/CDBICompat/AttributeAPI.pm lib/DBIx/Class/CDBICompat/AutoUpdate.pm lib/DBIx/Class/CDBICompat/ColumnCase.pm lib/DBIx/Class/CDBICompat/ColumnGroups.pm lib/DBIx/Class/CDBICompat/ColumnsAsHash.pm lib/DBIx/Class/CDBICompat/Constraints.pm lib/DBIx/Class/CDBICompat/Constructor.pm lib/DBIx/Class/CDBICompat/Copy.pm lib/DBIx/Class/CDBICompat/DestroyWarning.pm lib/DBIx/Class/CDBICompat/GetSet.pm lib/DBIx/Class/CDBICompat/ImaDBI.pm lib/DBIx/Class/CDBICompat/Iterator.pm lib/DBIx/Class/CDBICompat/LazyLoading.pm lib/DBIx/Class/CDBICompat/LiveObjectIndex.pm lib/DBIx/Class/CDBICompat/NoObjectIndex.pm lib/DBIx/Class/CDBICompat/Pager.pm lib/DBIx/Class/CDBICompat/ReadOnly.pm lib/DBIx/Class/CDBICompat/Relationship.pm lib/DBIx/Class/CDBICompat/Relationships.pm lib/DBIx/Class/CDBICompat/Retrieve.pm lib/DBIx/Class/CDBICompat/SQLTransformer.pm lib/DBIx/Class/CDBICompat/Stringify.pm lib/DBIx/Class/CDBICompat/TempColumns.pm lib/DBIx/Class/CDBICompat/Triggers.pm lib/DBIx/Class/ClassResolver/PassThrough.pm lib/DBIx/Class/Componentised.pm lib/DBIx/Class/Core.pm lib/DBIx/Class/Cursor.pm lib/DBIx/Class/DB.pm lib/DBIx/Class/Exception.pm lib/DBIx/Class/FilterColumn.pm lib/DBIx/Class/FilterColumn.pod lib/DBIx/Class/InflateColumn.pm lib/DBIx/Class/InflateColumn.pod lib/DBIx/Class/InflateColumn/DateTime.pm lib/DBIx/Class/InflateColumn/DateTime.pod lib/DBIx/Class/InflateColumn/File.pm lib/DBIx/Class/Manual.pod lib/DBIx/Class/Manual/Component.pod lib/DBIx/Class/Manual/Cookbook.pod lib/DBIx/Class/Manual/DocMap.pod lib/DBIx/Class/Manual/Example.pod lib/DBIx/Class/Manual/FAQ.pod lib/DBIx/Class/Manual/Features.pod lib/DBIx/Class/Manual/Glossary.pod lib/DBIx/Class/Manual/Intro.pod lib/DBIx/Class/Manual/Joining.pod lib/DBIx/Class/Manual/QuickStart.pod lib/DBIx/Class/Manual/Reading.pod lib/DBIx/Class/Manual/ResultClass.pod lib/DBIx/Class/Manual/Troubleshooting.pod lib/DBIx/Class/Optional/Dependencies.pm lib/DBIx/Class/Optional/Dependencies.pod lib/DBIx/Class/Ordered.pm lib/DBIx/Class/PK.pm lib/DBIx/Class/PK.pod lib/DBIx/Class/PK/Auto.pm lib/DBIx/Class/PK/Auto/DB2.pm lib/DBIx/Class/PK/Auto/MSSQL.pm lib/DBIx/Class/PK/Auto/MySQL.pm lib/DBIx/Class/PK/Auto/Oracle.pm lib/DBIx/Class/PK/Auto/Pg.pm lib/DBIx/Class/PK/Auto/SQLite.pm lib/DBIx/Class/Relationship.pm lib/DBIx/Class/Relationship/Accessor.pm lib/DBIx/Class/Relationship/Base.pm lib/DBIx/Class/Relationship/BelongsTo.pm lib/DBIx/Class/Relationship/CascadeActions.pm lib/DBIx/Class/Relationship/HasMany.pm lib/DBIx/Class/Relationship/HasOne.pm lib/DBIx/Class/Relationship/Helpers.pm lib/DBIx/Class/Relationship/ManyToMany.pm lib/DBIx/Class/Relationship/ProxyMethods.pm lib/DBIx/Class/ResultClass/HashRefInflator.pm lib/DBIx/Class/ResultSet.pm lib/DBIx/Class/ResultSet/Pager.pm lib/DBIx/Class/ResultSetColumn.pm lib/DBIx/Class/ResultSetManager.pm lib/DBIx/Class/ResultSetProxy.pm lib/DBIx/Class/ResultSource.pm lib/DBIx/Class/ResultSource/RowParser.pm lib/DBIx/Class/ResultSource/RowParser/Util.pm lib/DBIx/Class/ResultSource/Table.pm lib/DBIx/Class/ResultSource/Table.pod lib/DBIx/Class/ResultSource/View.pm lib/DBIx/Class/ResultSource/View.pod lib/DBIx/Class/ResultSourceHandle.pm lib/DBIx/Class/ResultSourceProxy.pm lib/DBIx/Class/ResultSourceProxy/Table.pm lib/DBIx/Class/ResultSourceProxy/Table.pod lib/DBIx/Class/Row.pm lib/DBIx/Class/Schema.pm lib/DBIx/Class/Schema/Versioned.pm lib/DBIx/Class/Serialize/Storable.pm lib/DBIx/Class/SQLAHacks.pm lib/DBIx/Class/SQLAHacks/MSSQL.pm lib/DBIx/Class/SQLAHacks/MySQL.pm lib/DBIx/Class/SQLAHacks/Oracle.pm lib/DBIx/Class/SQLAHacks/OracleJoins.pm lib/DBIx/Class/SQLAHacks/SQLite.pm lib/DBIx/Class/SQLMaker.pm lib/DBIx/Class/SQLMaker/ACCESS.pm lib/DBIx/Class/SQLMaker/ClassicExtensions.pm lib/DBIx/Class/SQLMaker/LimitDialects.pm lib/DBIx/Class/SQLMaker/MSSQL.pm lib/DBIx/Class/SQLMaker/MySQL.pm lib/DBIx/Class/SQLMaker/Oracle.pm lib/DBIx/Class/SQLMaker/OracleJoins.pm lib/DBIx/Class/SQLMaker/SQLite.pm lib/DBIx/Class/StartupCheck.pm lib/DBIx/Class/Storage.pm lib/DBIx/Class/Storage/BlockRunner.pm lib/DBIx/Class/Storage/DBI.pm lib/DBIx/Class/Storage/DBI/ACCESS.pm lib/DBIx/Class/Storage/DBI/ADO.pm lib/DBIx/Class/Storage/DBI/ADO/CursorUtils.pm lib/DBIx/Class/Storage/DBI/ADO/Microsoft_SQL_Server.pm lib/DBIx/Class/Storage/DBI/ADO/Microsoft_SQL_Server/Cursor.pm lib/DBIx/Class/Storage/DBI/ADO/MS_Jet.pm lib/DBIx/Class/Storage/DBI/ADO/MS_Jet/Cursor.pm lib/DBIx/Class/Storage/DBI/AutoCast.pm lib/DBIx/Class/Storage/DBI/Cursor.pm lib/DBIx/Class/Storage/DBI/DB2.pm lib/DBIx/Class/Storage/DBI/Firebird.pm lib/DBIx/Class/Storage/DBI/Firebird/Common.pm lib/DBIx/Class/Storage/DBI/IdentityInsert.pm lib/DBIx/Class/Storage/DBI/Informix.pm lib/DBIx/Class/Storage/DBI/InterBase.pm lib/DBIx/Class/Storage/DBI/MSSQL.pm lib/DBIx/Class/Storage/DBI/mysql.pm lib/DBIx/Class/Storage/DBI/NoBindVars.pm lib/DBIx/Class/Storage/DBI/ODBC.pm lib/DBIx/Class/Storage/DBI/ODBC/ACCESS.pm lib/DBIx/Class/Storage/DBI/ODBC/DB2_400_SQL.pm lib/DBIx/Class/Storage/DBI/ODBC/Firebird.pm lib/DBIx/Class/Storage/DBI/ODBC/Microsoft_SQL_Server.pm lib/DBIx/Class/Storage/DBI/ODBC/SQL_Anywhere.pm lib/DBIx/Class/Storage/DBI/Oracle.pm lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm lib/DBIx/Class/Storage/DBI/Oracle/WhereJoins.pm lib/DBIx/Class/Storage/DBI/Pg.pm lib/DBIx/Class/Storage/DBI/Replicated.pm lib/DBIx/Class/Storage/DBI/Replicated/Balancer.pm lib/DBIx/Class/Storage/DBI/Replicated/Balancer/First.pm lib/DBIx/Class/Storage/DBI/Replicated/Balancer/Random.pm lib/DBIx/Class/Storage/DBI/Replicated/Introduction.pod lib/DBIx/Class/Storage/DBI/Replicated/Pool.pm lib/DBIx/Class/Storage/DBI/Replicated/Replicant.pm lib/DBIx/Class/Storage/DBI/Replicated/Types.pm lib/DBIx/Class/Storage/DBI/Replicated/WithDSN.pm lib/DBIx/Class/Storage/DBI/SQLAnywhere.pm lib/DBIx/Class/Storage/DBI/SQLAnywhere/Cursor.pm lib/DBIx/Class/Storage/DBI/SQLite.pm lib/DBIx/Class/Storage/DBI/Sybase.pm lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm lib/DBIx/Class/Storage/DBI/Sybase/ASE/NoBindVars.pm lib/DBIx/Class/Storage/DBI/Sybase/FreeTDS.pm lib/DBIx/Class/Storage/DBI/Sybase/Microsoft_SQL_Server.pm lib/DBIx/Class/Storage/DBI/Sybase/Microsoft_SQL_Server/NoBindVars.pm lib/DBIx/Class/Storage/DBI/Sybase/MSSQL.pm lib/DBIx/Class/Storage/DBI/UniqueIdentifier.pm lib/DBIx/Class/Storage/DBIHacks.pm lib/DBIx/Class/Storage/Debug/PrettyTrace.pm lib/DBIx/Class/Storage/Statistics.pm lib/DBIx/Class/Storage/TxnScopeGuard.pm lib/DBIx/Class/UTF8Columns.pm lib/SQL/Translator/Parser/DBIx/Class.pm lib/SQL/Translator/Producer/DBIx/Class/File.pm LICENSE maint/gen_pod_authors maint/gen_pod_index maint/gen_pod_inherit maint/gen_sqlite_schema_files maint/getstatus maint/Makefile.PL.inc/01_adjust_INC.pl maint/Makefile.PL.inc/11_authortests.pl maint/Makefile.PL.inc/12_authordeps.pl maint/Makefile.PL.inc/21_set_meta.pl maint/Makefile.PL.inc/29_handle_version.pl maint/Makefile.PL.inc/50_redefine_makefile_flow.pl maint/Makefile.PL.inc/51_autohandle_MANIFEST.pl maint/Makefile.PL.inc/53_autogen_pod.pl maint/Makefile.PL.inc/54_autogen_legalese_and_README.pl maint/Makefile.PL.inc/56_autogen_schema_files.pl maint/Makefile.PL.inc/61_inject_dbicadmin_pod.pl maint/Makefile.PL.inc/91_inc_sanity_check.pl maint/poisonsmoke.bash maint/travis_buildlog_downloader Makefile.PL MANIFEST This list of files META.yml README script/dbicadmin t/00describe_environment.t t/04_c3_mro.t t/05components.t t/100extra_source.t t/100populate.t t/101populate_rs.t t/101source.t t/102load_classes.t t/103many_to_many_warning.t t/104view.t t/106dbic_carp.t t/107obj_result_class.t t/18insert_default.t t/19retrieve_on_insert.t t/20setuperrors.t t/26dumper.t t/33exception_wrap.t t/34exception_action.t t/35exception_inaction.t t/39load_namespaces_1.t t/39load_namespaces_2.t t/39load_namespaces_3.t t/39load_namespaces_4.t t/39load_namespaces_exception.t t/39load_namespaces_rt41083.t t/39load_namespaces_stress.t t/40compose_connection.t t/40resultsetmanager.t t/46where_attribute.t t/50fork.t t/51threadnodb.t t/51threads.t t/51threadtxn.t t/52leaks.t t/53lean_startup.t t/55namespaces_cleaned.t t/60core.t t/61findnot.t t/63register_class.t t/63register_column.t t/63register_source.t t/64db.t t/65multipk.t t/69update.t t/70auto.t t/71mysql.t t/72pg.t t/72pg_bytea.t t/73oracle.t t/73oracle_blob.t t/73oracle_hq.t t/745db2.t t/746db2_400.t t/746mssql.t t/746sybase.t t/747mssql_ado.t t/748informix.t t/749sqlanywhere.t t/74mssql.t t/750firebird.t t/751msaccess.t t/752sqlite.t t/76joins.t t/76select.t t/77join_count.t t/78self_referencial.t t/79aliasing.t t/80unique.t t/82cascade_copy.t t/83cache.t t/84serialize.t t/85utf8.t t/86might_have.t t/86sqlt.t t/87ordered.t t/88result_set_column.t t/90ensure_class_loaded.t t/90join_torture.t t/91merge_joinpref_attr.t t/93autocast.t t/93single_accessor_object.t t/94pk_mutation.t t/94versioning.t t/96_is_deteministic_value.t t/97result_class.t t/99dbic_sqlt_parser.t t/admin/01load.t t/admin/02ddl.t t/admin/03data.t t/admin/10script.t t/cdbi/01-columns.t t/cdbi/02-Film.t t/cdbi/03-subclassing.t t/cdbi/04-lazy.t t/cdbi/06-hasa.t t/cdbi/08-inheritcols.t t/cdbi/09-has_many.t t/cdbi/11-triggers.t t/cdbi/12-filter.t t/cdbi/13-constraint.t t/cdbi/14-might_have.t t/cdbi/15-accessor.t t/cdbi/16-reserved.t t/cdbi/18-has_a.t t/cdbi/19-set_sql.t t/cdbi/21-iterator.t t/cdbi/22-deflate_order.t t/cdbi/22-self_referential.t t/cdbi/23-cascade.t t/cdbi/24-meta_info.t t/cdbi/26-mutator.t t/cdbi/30-pager.t t/cdbi/68-inflate_has_a.t t/cdbi/70_implicit_inflate.t t/cdbi/71_column_object.t t/cdbi/98-failure.t t/cdbi/abstract/search_where.t t/cdbi/columns_as_hashes.t t/cdbi/columns_dont_override_custom_accessors.t t/cdbi/construct.t t/cdbi/copy.t t/cdbi/DeepAbstractSearch/01_search.t t/cdbi/early_column_heisenbug.t t/cdbi/has_many_loads_foreign_class.t t/cdbi/hasa_without_loading.t t/cdbi/max_min_value_of.t t/cdbi/mk_group_accessors.t t/cdbi/multi_column_set.t t/cdbi/object_cache.t t/cdbi/retrieve_from_sql_with_limit.t t/cdbi/set_to_undef.t t/cdbi/set_vs_DateTime.t t/cdbi/sweet/08pager.t t/cdbi/testlib/Actor.pm t/cdbi/testlib/ActorAlias.pm t/cdbi/testlib/Blurb.pm t/cdbi/testlib/CDBase.pm t/cdbi/testlib/ColumnObject.pm t/cdbi/testlib/DBIC/Test/SQLite.pm t/cdbi/testlib/Director.pm t/cdbi/testlib/Film.pm t/cdbi/testlib/ImplicitInflate.pm t/cdbi/testlib/Lazy.pm t/cdbi/testlib/Log.pm t/cdbi/testlib/MyBase.pm t/cdbi/testlib/MyFilm.pm t/cdbi/testlib/MyFoo.pm t/cdbi/testlib/MyStar.pm t/cdbi/testlib/MyStarLink.pm t/cdbi/testlib/MyStarLinkMCPK.pm t/cdbi/testlib/Order.pm t/cdbi/testlib/OtherFilm.pm t/cdbi/testlib/OtherThing.pm t/cdbi/testlib/Thing.pm t/count/count_rs.t t/count/distinct.t t/count/group_by_func.t t/count/grouped_pager.t t/count/in_subquery.t t/count/joined.t t/count/prefetch.t t/count/search_related.t t/debug/bulk-insert.t t/debug/core.t t/debug/no-repeats.t t/debug/pretty.t t/debug/show-progress.t t/delete/cascade_missing.t t/delete/complex.t t/delete/m2m.t t/delete/related.t t/discard_changes_in_DESTROY.t t/inflate/core.t t/inflate/datetime.t t/inflate/datetime_determine_parser.t t/inflate/datetime_firebird.t t/inflate/datetime_informix.t t/inflate/datetime_missing_deps.t t/inflate/datetime_msaccess.t t/inflate/datetime_mssql.t t/inflate/datetime_mysql.t t/inflate/datetime_oracle.t t/inflate/datetime_pg.t t/inflate/datetime_sqlanywhere.t t/inflate/datetime_sybase.t t/inflate/file_column.t t/inflate/hri.t t/inflate/hri_torture.t t/inflate/serialize.t t/lib/admincfgtest.json t/lib/awesome.json t/lib/DBICNSTest/Bogus/A.pm t/lib/DBICNSTest/Bogus/B.pm t/lib/DBICNSTest/Bogus/Bigos.pm t/lib/DBICNSTest/OtherRslt/D.pm t/lib/DBICNSTest/Result/A.pm t/lib/DBICNSTest/Result/B.pm t/lib/DBICNSTest/Result/D.pm t/lib/DBICNSTest/ResultSet/A.pm t/lib/DBICNSTest/ResultSet/C.pm t/lib/DBICNSTest/ResultSet/D.pm t/lib/DBICNSTest/RSBase.pm t/lib/DBICNSTest/RSet/A.pm t/lib/DBICNSTest/RSet/C.pm t/lib/DBICNSTest/Rslt/A.pm t/lib/DBICNSTest/Rslt/B.pm t/lib/DBICNSTest/RtBug41083/Result/Foo.pm t/lib/DBICNSTest/RtBug41083/Result/Foo/Sub.pm t/lib/DBICNSTest/RtBug41083/Result_A/A.pm t/lib/DBICNSTest/RtBug41083/Result_A/A/Sub.pm t/lib/DBICNSTest/RtBug41083/ResultSet.pm t/lib/DBICNSTest/RtBug41083/ResultSet/Foo.pm t/lib/DBICNSTest/RtBug41083/ResultSet_A/A.pm t/lib/DBICTest.pm t/lib/DBICTest/Base.pm t/lib/DBICTest/BaseResult.pm t/lib/DBICTest/BaseResultSet.pm t/lib/DBICTest/BaseSchema.pm t/lib/DBICTest/Cursor.pm t/lib/DBICTest/DeployComponent.pm t/lib/DBICTest/DynamicForeignCols/Computer.pm t/lib/DBICTest/DynamicForeignCols/TestComputer.pm t/lib/DBICTest/ErrorComponent.pm t/lib/DBICTest/FakeComponent.pm t/lib/DBICTest/ForeignComponent.pm t/lib/DBICTest/ForeignComponent/TestComp.pm t/lib/DBICTest/OptionalComponent.pm t/lib/DBICTest/ResultSetManager.pm t/lib/DBICTest/ResultSetManager/Foo.pm t/lib/DBICTest/RunMode.pm t/lib/DBICTest/Schema.pm t/lib/DBICTest/Schema/Artist.pm t/lib/DBICTest/Schema/ArtistGUID.pm t/lib/DBICTest/Schema/ArtistSourceName.pm t/lib/DBICTest/Schema/ArtistSubclass.pm t/lib/DBICTest/Schema/ArtistUndirectedMap.pm t/lib/DBICTest/Schema/Artwork.pm t/lib/DBICTest/Schema/Artwork_to_Artist.pm t/lib/DBICTest/Schema/BindType.pm t/lib/DBICTest/Schema/Bookmark.pm t/lib/DBICTest/Schema/BooksInLibrary.pm t/lib/DBICTest/Schema/CD.pm t/lib/DBICTest/Schema/CD_to_Producer.pm t/lib/DBICTest/Schema/Collection.pm t/lib/DBICTest/Schema/CollectionObject.pm t/lib/DBICTest/Schema/ComputedColumn.pm t/lib/DBICTest/Schema/CustomSql.pm t/lib/DBICTest/Schema/Dummy.pm t/lib/DBICTest/Schema/Employee.pm t/lib/DBICTest/Schema/Encoded.pm t/lib/DBICTest/Schema/Event.pm t/lib/DBICTest/Schema/EventSmallDT.pm t/lib/DBICTest/Schema/EventTZ.pm t/lib/DBICTest/Schema/EventTZDeprecated.pm t/lib/DBICTest/Schema/EventTZPg.pm t/lib/DBICTest/Schema/ForceForeign.pm t/lib/DBICTest/Schema/FourKeys.pm t/lib/DBICTest/Schema/FourKeys_to_TwoKeys.pm t/lib/DBICTest/Schema/Genre.pm t/lib/DBICTest/Schema/Image.pm t/lib/DBICTest/Schema/LinerNotes.pm t/lib/DBICTest/Schema/Link.pm t/lib/DBICTest/Schema/Lyrics.pm t/lib/DBICTest/Schema/LyricVersion.pm t/lib/DBICTest/Schema/Money.pm t/lib/DBICTest/Schema/NoPrimaryKey.pm t/lib/DBICTest/Schema/NoSuchClass.pm t/lib/DBICTest/Schema/OneKey.pm t/lib/DBICTest/Schema/Owners.pm t/lib/DBICTest/Schema/Producer.pm t/lib/DBICTest/Schema/PunctuatedColumnName.pm t/lib/DBICTest/Schema/SelfRef.pm t/lib/DBICTest/Schema/SelfRefAlias.pm t/lib/DBICTest/Schema/SequenceTest.pm t/lib/DBICTest/Schema/Serialized.pm t/lib/DBICTest/Schema/Tag.pm t/lib/DBICTest/Schema/TimestampPrimaryKey.pm t/lib/DBICTest/Schema/Track.pm t/lib/DBICTest/Schema/TreeLike.pm t/lib/DBICTest/Schema/TwoKeys.pm t/lib/DBICTest/Schema/TwoKeyTreeLike.pm t/lib/DBICTest/Schema/TypedObject.pm t/lib/DBICTest/Schema/VaryingMAX.pm t/lib/DBICTest/Schema/Year1999CDs.pm t/lib/DBICTest/Schema/Year2000CDs.pm t/lib/DBICTest/SQLMRebase.pm t/lib/DBICTest/SQLTracerObj.pm t/lib/DBICTest/SyntaxErrorComponent1.pm t/lib/DBICTest/SyntaxErrorComponent2.pm t/lib/DBICTest/SyntaxErrorComponent3.pm t/lib/DBICTest/Taint/Classes/Auto.pm t/lib/DBICTest/Taint/Classes/Manual.pm t/lib/DBICTest/Taint/Namespaces/Result/Test.pm t/lib/DBICTest/Util.pm t/lib/DBICTest/Util/LeakTracer.pm t/lib/DBICTest/Util/OverrideRequire.pm t/lib/DBICVersion_v1.pm t/lib/DBICVersion_v2.pm t/lib/DBICVersion_v3.pm t/lib/sqlite.sql t/lib/test_deploy/DBICTest-Schema-1.x-SQLite.sql t/lib/testinclude/DBICTestAdminInc.pm t/lib/testinclude/DBICTestConfig.pm t/lib/ViewDeps.pm t/lib/ViewDeps/Result/AbaNameArtists.pm t/lib/ViewDeps/Result/AbaNameArtistsAnd2010CDsWithManyTracks.pm t/lib/ViewDeps/Result/AbNameArtists.pm t/lib/ViewDeps/Result/ANameArtists.pm t/lib/ViewDeps/Result/Artist.pm t/lib/ViewDeps/Result/Artwork.pm t/lib/ViewDeps/Result/CD.pm t/lib/ViewDeps/Result/Track.pm t/lib/ViewDeps/Result/TrackNumberFives.pm t/lib/ViewDeps/Result/Year2010CDs.pm t/lib/ViewDeps/Result/Year2010CDsWithManyTracks.pm t/lib/ViewDepsBad.pm t/lib/ViewDepsBad/Result/AbaNameArtists.pm t/lib/ViewDepsBad/Result/AbaNameArtistsAnd2010CDsWithManyTracks.pm t/lib/ViewDepsBad/Result/AbNameArtists.pm t/lib/ViewDepsBad/Result/ANameArtists.pm t/lib/ViewDepsBad/Result/Artist.pm t/lib/ViewDepsBad/Result/Artwork.pm t/lib/ViewDepsBad/Result/CD.pm t/lib/ViewDepsBad/Result/Track.pm t/lib/ViewDepsBad/Result/TrackNumberFives.pm t/lib/ViewDepsBad/Result/Year2010CDs.pm t/lib/ViewDepsBad/Result/Year2010CDsWithManyTracks.pm t/multi_create/cd_single.t t/multi_create/diamond.t t/multi_create/existing_in_chain.t t/multi_create/find_or_multicreate.t t/multi_create/has_many.t t/multi_create/in_memory.t t/multi_create/insert_defaults.t t/multi_create/m2m.t t/multi_create/multilev_single_PKeqFK.t t/multi_create/reentrance_count.t t/multi_create/standard.t t/multi_create/torture.t t/ordered/cascade_delete.t t/ordered/unordered_movement.t t/pager/data_page_compat/constructor.t t/pager/data_page_compat/simple.t t/pager/dbic_core.t t/prefetch/attrs_untouched.t t/prefetch/correlated.t t/prefetch/count.t t/prefetch/diamond.t t/prefetch/double_prefetch.t t/prefetch/empty_cache.t t/prefetch/false_colvalues.t t/prefetch/grouped.t t/prefetch/incomplete.t t/prefetch/join_type.t t/prefetch/lazy_cursor.t t/prefetch/manual.t t/prefetch/multiple_hasmany.t t/prefetch/multiple_hasmany_torture.t t/prefetch/o2m_o2m_order_by_with_limit.t t/prefetch/one_to_many_to_one.t t/prefetch/refined_search_on_relation.t t/prefetch/restricted_children_set.t t/prefetch/standard.t t/prefetch/via_search_related.t t/prefetch/with_limit.t t/relationship/after_update.t t/relationship/core.t t/relationship/custom.t t/relationship/custom_opaque.t t/relationship/custom_with_null_in_cond.t t/relationship/doesnt_exist.t t/relationship/dynamic_foreign_columns.t t/relationship/info.t t/relationship/malformed_declaration.t t/relationship/proxy.t t/relationship/set_column_on_fk.t t/relationship/unresolvable.t t/relationship/update_or_create_multi.t t/relationship/update_or_create_single.t t/resultset/as_query.t t/resultset/as_subselect_rs.t t/resultset/bind_attr.t t/resultset/find_on_subquery_cond.t t/resultset/inflate_result_api.t t/resultset/inflatemap_abuse.t t/resultset/is_ordered.t t/resultset/is_paged.t t/resultset/nulls_only.t t/resultset/plus_select.t t/resultset/rowparser_internals.t t/resultset/update_delete.t t/resultset_class.t t/resultset_overload.t t/resultsource/bare_resultclass_exception.t t/resultsource/set_primary_key.t t/row/copy_with_extra_selection.t t/row/filter_column.t t/row/find_one_has_many.t t/row/inflate_result.t t/row/pkless.t t/row/set_extra_column.t t/schema/anon.t t/schema/clone.t t/search/deprecated_attributes.t t/search/distinct.t t/search/empty_attrs.t t/search/preserve_original_rs.t t/search/reentrancy.t t/search/related_has_many.t t/search/related_strip_prefetch.t t/search/select_chains.t t/search/select_chains_unbalanced.t t/search/stack_cond.t t/search/subquery.t t/search/void.t t/sqlmaker/bind_transport.t t/sqlmaker/core.t t/sqlmaker/core_quoted.t t/sqlmaker/dbihacks_internals.t t/sqlmaker/hierarchical/oracle.t t/sqlmaker/legacy_joins.t t/sqlmaker/limit_dialects/basic.t t/sqlmaker/limit_dialects/custom.t t/sqlmaker/limit_dialects/fetch_first.t t/sqlmaker/limit_dialects/first_skip.t t/sqlmaker/limit_dialects/generic_subq.t t/sqlmaker/limit_dialects/mssql_torture.t t/sqlmaker/limit_dialects/rno.t t/sqlmaker/limit_dialects/rownum.t t/sqlmaker/limit_dialects/skip_first.t t/sqlmaker/limit_dialects/toplimit.t t/sqlmaker/limit_dialects/torture.t t/sqlmaker/literal_with_bind.t t/sqlmaker/msaccess.t t/sqlmaker/mysql.t t/sqlmaker/nest_deprec.t t/sqlmaker/oracle.t t/sqlmaker/oraclejoin.t t/sqlmaker/order_by_bindtransport.t t/sqlmaker/order_by_func.t t/sqlmaker/pg.t t/sqlmaker/quotes.t t/sqlmaker/rebase.t t/sqlmaker/sqlite.t t/storage/base.t t/storage/cursor.t t/storage/dbh_do.t t/storage/dbi_coderef.t t/storage/dbi_env.t t/storage/deploy.t t/storage/deprecated_exception_source_bind_attrs.t t/storage/disable_sth_caching.t t/storage/error.t t/storage/exception.t t/storage/global_destruction.t t/storage/nobindvars.t t/storage/on_connect_call.t t/storage/on_connect_do.t t/storage/ping_count.t t/storage/prefer_stringification.t t/storage/quote_names.t t/storage/reconnect.t t/storage/replicated.t t/storage/savepoints.t t/storage/stats.t t/storage/txn.t t/storage/txn_scope_guard.t t/update/all.t t/update/ident_cond.t t/update/type_aware.t t/zzzzzzz_authors.t t/zzzzzzz_perl_perf_bug.t t/zzzzzzz_sqlite_deadlock.t xt/authors.t xt/dbictest_unlink_guard.t xt/footers.t xt/old_envvars.t xt/optional_deps.t xt/pod.t xt/podcoverage.t xt/quote_sub.t xt/standalone_testschema_resultclasses.t xt/strictures.t xt/whitespace.t ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/script/�������������������������������������������������������������������������0000755�0001750�0001750�00000000000�14240676465�014425� 5����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/script/dbicadmin����������������������������������������������������������������0000644�0001750�0001750�00000016022�14240676465�016263� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/env perl use strict; use warnings; BEGIN { use DBIx::Class; die ( 'The following modules are required for the dbicadmin utility: ' . DBIx::Class::Optional::Dependencies->req_missing_for ('admin_script') . "\n" ) unless DBIx::Class::Optional::Dependencies->req_ok_for ('admin_script'); } use DBIx::Class::Admin::Descriptive; #use Getopt::Long::Descriptive; use DBIx::Class::Admin; my $short_description = "utility for administrating DBIx::Class schemata"; my $synopsis_text =q| deploy a schema to a database %c --schema=MyApp::Schema \ --connect='["dbi:SQLite:my.db", "", ""]' \ --deploy update an existing record %c --schema=MyApp::Schema --class=Employee \ --connect='["dbi:SQLite:my.db", "", ""]' \ --op=update --set='{ "name": "New_Employee" }' |; my ($opts, $usage) = describe_options( "%c: %o", ( ['Actions'], ["action" => hidden => { one_of => [ ['create' => 'Create version diffs needs preversion'], ['upgrade' => 'Upgrade the database to the current schema'], ['install' => 'Install the schema version tables to an existing database'], ['deploy' => 'Deploy the schema to the database'], ['select' => 'Select data from the schema'], ['insert' => 'Insert data into the schema'], ['update' => 'Update data in the schema'], ['delete' => 'Delete data from the schema'], ['op:s' => 'compatibility option all of the above can be supplied as --op=<action>'], ['help' => 'display this help', { implies => { schema_class => '__dummy__' } } ], ['documentation-as-pod:s' => 'hidden', { implies => { schema_class => '__dummy__' } } ], ], required => 1 }], ['Arguments'], ["configuration" => hidden => { one_of => [ ['config-file|config:s' => 'Supply the config file for parsing by Config::Any', { depends => 'config_stanza'} ], ['connect-info:s%' => 'Supply the connect info as trailing options e.g. --connect-info dsn=<dsn> user=<user> password=<pass>' ], ['connect:s' => 'Supply the connect info as a JSON-encoded structure, e.g. an --connect=["dsn","user","pass"]'], ] }], ['schema-class:s' => 'The class of the schema to load', { required => 1 } ], ['config-stanza:s' => 'Where in the config to find the connection_info, supply in form MyApp::Model::DB',], ['resultset|resultset-class|class:s' => 'The resultset to operate on for data manipulation' ], ['sql-dir:s' => 'The directory where sql diffs will be created'], ['sql-type:s' => 'The RDBMs flavour you wish to use'], ['version:i' => 'Supply a version install'], ['preversion:s' => 'The previous version to diff against',], ['set:s' => 'JSON data used to perform data operations' ], ['attrs:s' => 'JSON string to be used for the second argument for search'], ['where:s' => 'JSON string to be used for the where clause of search'], ['force' => 'Be forceful with some operations'], ['trace' => 'Turn on DBIx::Class trace output'], ['quiet' => 'Be less verbose'], ['I:s@' => 'Same as perl\'s -I, prepended to current @INC'], ) ); if(defined (my $fn = $opts->{documentation_as_pod}) ) { $usage->synopsis($synopsis_text); $usage->short_description($short_description); if ($fn) { require File::Spec; require File::Path; my $dir = File::Spec->catpath( (File::Spec->splitpath($fn))[0,1] ); File::Path::mkpath([$dir]); } local *STDOUT if $fn; open (STDOUT, '>', $fn) or die "Unable to open $fn: $!\n" if $fn; print STDOUT "\n"; print STDOUT $usage->pod; print STDOUT "\n"; close STDOUT if $fn; exit 0; } # FIXME - lowercasing will eventually go away when Getopt::Long::Descriptive is fixed if($opts->{i}) { require lib; lib->import( @{delete $opts->{i}} ); } if($opts->{help}) { $usage->die(); } # option compatibility mangle # (can not be joined in the spec, one is s% the other is s) if($opts->{connect}) { $opts->{connect_info} = delete $opts->{connect}; } my $admin = DBIx::Class::Admin->new( %$opts ); my $action = $opts->{action}; $action = $opts->{op} if ($action eq 'op'); print "Performing action $action...\n"; my $res = $admin->$action(); if ($action eq 'select') { my $format = $opts->{format} || 'tsv'; die('Invalid format') if ($format!~/^tsv|csv$/s); require Text::CSV; my $csv = Text::CSV->new({ sep_char => ( $format eq 'tsv' ? "\t" : ',' ), }); foreach my $row (@$res) { $csv->combine( @$row ); print $csv->string()."\n"; } } 1; __END__ =head1 NAME dbicadmin - utility for administrating DBIx::Class schemata =head1 SYNOPSIS dbicadmin: [-I] [long options...] deploy a schema to a database dbicadmin --schema=MyApp::Schema \ --connect='["dbi:SQLite:my.db", "", ""]' \ --deploy update an existing record dbicadmin --schema=MyApp::Schema --class=Employee \ --connect='["dbi:SQLite:my.db", "", ""]' \ --op=update --set='{ "name": "New_Employee" }' =head1 OPTIONS =over =back =head2 Actions =cut =over =item B<--create> Create version diffs needs preversion =cut =item B<--upgrade> Upgrade the database to the current schema =cut =item B<--install> Install the schema version tables to an existing database =cut =item B<--deploy> Deploy the schema to the database =cut =item B<--select> Select data from the schema =cut =item B<--insert> Insert data into the schema =cut =item B<--update> Update data in the schema =cut =item B<--delete> Delete data from the schema =cut =item B<--op> compatibility option all of the above can be supplied as --op=<action> =cut =item B<--help> display this help =cut =back =head2 Arguments =cut =over =item B<--config-file> or B<--config> Supply the config file for parsing by Config::Any =cut =item B<--connect-info> Supply the connect info as trailing options e.g. --connect-info dsn=<dsn> user=<user> password=<pass> =cut =item B<--connect> Supply the connect info as a JSON-encoded structure, e.g. an --connect=["dsn","user","pass"] =cut =item B<--schema-class> The class of the schema to load =cut =item B<--config-stanza> Where in the config to find the connection_info, supply in form MyApp::Model::DB =cut =item B<--resultset> or B<--resultset-class> or B<--class> The resultset to operate on for data manipulation =cut =item B<--sql-dir> The directory where sql diffs will be created =cut =item B<--sql-type> The RDBMs flavour you wish to use =cut =item B<--version> Supply a version install =cut =item B<--preversion> The previous version to diff against =cut =item B<--set> JSON data used to perform data operations =cut =item B<--attrs> JSON string to be used for the second argument for search =cut =item B<--where> JSON string to be used for the where clause of search =cut =item B<--force> Be forceful with some operations =cut =item B<--trace> Turn on DBIx::Class trace output =cut =item B<--quiet> Be less verbose =cut =item B<-I> Same as perl's -I, prepended to current @INC =cut =back =head1 AUTHORS See L<DBIx::Class/AUTHORS> =head1 LICENSE You may distribute this code under the same terms as Perl itself =cut ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/Changes�������������������������������������������������������������������������0000644�0001750�0001750�00000330637�14240676325�014423� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Revision history for DBIx::Class 0.082843 2022-05-17 10:50 (UTC) * Fixes - Adjust tests to account for DBD::SQLite's column_info() no longer being case-preserving in recent versions - Fix t/storage/replicated.t relying on no-longer-available module - Adjust t/53lean_startup.t to work around spurious changes in Perl5 core (GH#143) 0.082842 2020-06-16 20:10 (UTC) * New Features - An on_connect rebase_sqlmaker call allowing experimentation with non-core SQL generators on a per-$schema-instance basis https://is.gd/DBIC_rebase_sqlmaker - Automatically detect and use multi-column IN on recent versions of libsqlite: ... WHERE ( foo, bar ) IN ( SELECT foo, bar FROM ... ) * Fixes - Fix silent failure to retrieve a primary key (RT#80283) or worse: returning an incorrect value (RT#115381) in case a rdbms-side autoinc column is declared as PK with the is_auto_increment attribute unset - Fix overly-aggressive condition unrolling, corrupting custom ops with array arguments (RT#132390) - Fix docs on how to properly use Moo(se) in ResultSet's, and fix a corner case of ->count not functioning properly when the old recipe was being used (GH#105) - Fix incorrect ::Storage->_ping() behavior under Sybase (RT#114214) - Work around breakage in Hash::Merge by soft-requiring Clone as part of the replicated subsystem (RT#124321) * Misc - DBIC_TRACE_PROFILE=... now uses a ::Storage::Statistics subclass DBIx::Class::Storage::Debug::PrettyTrace which properly ships as a part of this distrinbution - Switch out SQL::Abstract dependency with a slower moving dist - Remove Data::Page dependency by inlining its entirety into the core DBIx::Class::ResultSet::Pager (RT#130686) 0.082841 2018-01-29 08:10 (UTC) * Test-suite fixup changes only - no reason to upgrade, wait for 0.082850 * Misc - Unblock DBD::SQLite (RT#118395) - Fix missing ORDER BY leading to failures of t/prefetch/grouped.t under upcoming libsqlite (RT#117271) - Temporarily disable a non-critical portion of test failing on upcoming libsqlite, proper fix coming in 0.082850 (RT#119845) - Add test workaround for ( largely irrelevant ) RT#120129 - Add temporary test-workaround for a devrel of DBD::SQLite RT#124227 / https://twitter.com/dbix_class/status/957271153751527424 - Add workaround for one of the most damaging "improvements" made during the modern-perl-era (RT#120827) - Fix malformed README file encoding (RT#122028) 0.082840 2016-06-20 07:02 (UTC) * New Features - When using non-scalars (e.g. arrays) as literal bind values it is no longer necessary to explicitly specify a bindtype (this turned out to be a mostly useless overprotection) * Fixes - Ensure leaving an exception stack via Return::MultiLevel or something similar produces a large warning - Another relatively invasive set of ::FilterColumn changes, covering potential data loss (RT#111567). Please run your regression tests! - Ensure failing on_connect* / on_disconnect* are dealt with properly, notably on_connect* failures now properly abort the entire connect - Fix use of ::Schema::Versioned combined with a user-supplied $dbh->{HandleError} (GH#101) - Fix parsing of DSNs containing driver arguments (GH#99) - Fix silencing of exceptions thrown by custom inflate_result() methods - Fix complex prefetch when ordering over foreign boolean columns ( Pg can't MAX(boolcol) despite being able to ORDER BY boolcol ) - Fix infinite loop on ->svp_release("nonexistent_savepoint") (GH#97) - Fix spurious ROLLBACK statements when a TxnScopeGuard fails a commit of a transaction with deferred FK checks: a guard is now inactivated immediately before the commit is attempted (RT#107159) - Fix the Sybase ASE storage incorrectly attempting to retrieve an autoinc value when inserting rows containing blobs (GH#82) - Remove spurious exception warping in ::Replicated::execute_reliably (RT#113339) - Work around unreliable $sth->finish() on INSERT ... RETURNING within DBD::Firebird on some compiler/driver combinations (RT#110979) - Fix leaktest failures with upcoming version of Sub::Quote - Really fix savepoint rollbacks on older DBD::SQLite (fix in 0.082800 was not sufficient to cover up RT#67843) * Misc - Test suite is now officially certified to work under very high random parallelism: META x_parallel_test_certified set to true accordingly - Typo fixes from downstream debian packagers (RT#112007) 0.082821 2016-02-11 17:58 (UTC) * Fixes - Fix t/52leaks.t failures on compilerless systems (RT#104429) - Fix t/storage/quote_names.t failures on systems with specified Oracle test credentials while missing the optional Math::Base36 - Fix test failures when DBICTEST_SYBASE_DSN is set (unnoticed change in error message wording during 0.082800 and a bogus test) - Remove largely obsolete test of SQLite view deployment (RT#111916) * Misc - Work around rare test deadlock under heavy parallelism (RT#108390) 0.082820 2015-03-20 20:35 (UTC) * Fixes - Protect destructors from rare but possible double execution, and loudly warn the user whenever the problem is encountered (GH#63) - Relax the 'self_result_object' argument check in the relationship resolution codepath, restoring exotic uses of inflate_result http://lists.scsys.co.uk/pipermail/dbix-class/2015-January/011876.html - Fix updating multiple CLOB/BLOB columns on Oracle - Fix exception on complex update/delete under a replicated setup http://lists.scsys.co.uk/pipermail/dbix-class/2015-January/011903.html - Fix uninitialized warnings on empty hashes passed to join/prefetch https://github.com/vanstyn/RapidApp/commit/6f41f6e48 and http://lists.scsys.co.uk/pipermail/dbix-class/2015-February/011921.html - Fix hang in t/72pg.t when run against DBD::Pg 3.5.0. The ping() implementation changes due to RT#100648 made an alarm() based timeout lock-prone. * Misc - Remove warning about potential side effects of RT#79576 (scheduled) - Various doc improvements (GH#35, GH#62, GH#66, GH#70, GH#71, GH#72) - Depend on newer Moo, to benefit from a safer runtime (RT#93004) - Fix intermittent failures in the LeakTracer on 5.18+ - Fix failures of t/54taint.t on Windows with spaces in the $^X executable path (RT#101615) 0.082810 2014-10-25 13:58 (UTC) * Fixes - Fix incorrect collapsing-parser source being generated in the presence of unicode data among the collapse-points - Fix endless loop on BareSourcelessResultClass->throw_exception(...) * Misc - Depend on newer SQL::Abstract (fixing overly-aggressive parenthesis opener: RT#99503) - Depend on newer Moo, fixing some interoperability issues: http://lists.scsys.co.uk/pipermail/dbix-class/2014-October/011787.html 0.082801 2014-10-05 23:55 (UTC) * Known Issues - Passing large amounts of objects with stringification overload directly to DBIx::Class may result in strange action at a distance exceptions. More info (and a workaround description) can be found under "Note" at https://metacpan.org/pod/SQL::Abstract#is_plain_value - The relationship condition resolution fixes come with the side effect of returning more complete data, tripping up *some* users of an undocumented but widely used internal function. In particular https://rt.cpan.org/Ticket/Display.html?id=91375#txn-1407239 * Notable Changes and Deprecations - DBIC::FilterColumn now properly bypasses \'' and \[] literals, just like the rest of DBIC - DBIC::FilterColumn "from_storage" handler is now invoked on NULLs returned from storage - find() now throws an exception if some of the supplied values are managed by DBIC::FilterColumn (RT#95054) - Custom condition relationships are now invoked with a slightly different signature (existing coderefs will continue to work) - Add extra custom condition coderef attribute 'foreign_values' to allow for proper reverse-relationship-like behavior (i.e. $result->set_from_related($custom_rel, $foreign_result_object) - When in a transaction, DBIC::Ordered now seamlesly handles result objects that went out of sync with the storage (RT#96499) - CDBICompat::columns() now supports adding columns through supplied Class::DBI::Column instances (GH#52) - Deprecate { col1 => col2 } expressions in manual {from} structures (at some point of time manual {from} will be deprecated entirely) * Fixes - Fix Resultset delete/update affecting *THE ENTIRE TABLE* in cases of empty (due to conditions) resultsets with multi-column keys - Fix on_connect_* not always firing in some cases - a race condition existed between storage accessor setters and the determine_driver routines, triggering a connection before the set-cycle is finished - Fix collapse being ignored on single-origin selection (RT#95658) - Fix incorrect behavior on custom result_class inflators altering the amount of returned results - Fix failure to detect stable order criteria when in iterator mode of a has_many prefetch off a search_related chain - Prevent erroneous database hit when accessing prefetched related resultsets with no rows - Proper exceptions on malformed relationship conditions (RT#92234) - Fix incorrect handling of custom relationship conditions returning SQLA literal expressions - Fix long standing bug with populate() missing data from hashrefs with different keysets: http://is.gd/2011_dbic_populate_gotcha (RT#92723) - Fix multi-value literal populate not working with simplified bind specifications - Massively improve the implied resultset condition parsing - now all applicable conditions within a resultset should be properly picked up by create() and populate() - Ensure definitive condition extractor handles bizarre corner cases without bombing out (RT#93244) - Fix set_column on non-native (+columns) selections (RT#86685) - Fix set_inflated_column incorrectly handling \[] literals (GH#44) - Ensure that setting a column to a literal invariably marks it dirty - Fix copy() not working correctly with extra selections present - Work around exception objects with broken string overloading in one additional codepath (missed in 0.08260) - Fix more inconsistencies of the quote_names attribute propagating to SQL::Translator (partially RT#87731) - Fix SQLT constraint naming when DBIC table names are fully qualified (PR#48) - Ensure ::Schema::Versioned connects only once by reusing the main connection (GH#57) - Fix inability to handle multiple consecutive transactions with savepoints on DBD::SQLite < 1.39 - Fix CDBICompat to match Class::DBI behavior handling non-result blessed has_a (implicit deflate via stringification and inflate via blind new) (GH#51) * Misc - Ensure source metadata calls always take place on the result source instance registered with the caller - IFF DBIC_TRACE output defaults to STDERR we now silence the possible wide-char warnings if the trace happens to contain unicode 0.08270 2014-01-30 21:54 (PST) * Fixes - Fix 0.08260 regression in DBD::SQLite bound int handling. Inserted data was not affected, but any function <=> integer comparison would have failed (originally fixed way back in 0e773352) - Fix failure to load DateTime formatter when connecting to Firebird over ODBC * Misc - All drivers based on ::Storage::DBI::Firebird::Common now return the same sqlt_type value (affects ::DBI::Interbase, ::DBI::Firebird and ::DBI::ODBC::Firebird) 0.08260 2014-01-28 18:52 (UTC) * New Features - A new zero-to-DBIC style manual: DBIx::Class::Manual::QuickStart * Notable Changes and Deprecations - Explicitly deprecate combination of distinct and selecting a non-column via $rs->get_column() * Fixes - More robust handling of circular relationship declarations by loading foreign classes less frequently (should resolve issues like http://lists.scsys.co.uk/pipermail/dbix-class/2013-June/011374.html) Note that none of this is a manifestations of a DBIC bug, but rather unexpected (but correct) behavior of load-order-dependent (hence logically broken) Resultclass hierarchies. In order to deal with this DBIC is scaling back a large number of sanity checks, which are to be reintroduce pending a better framework for source registration - Fix multiple edge cases of complex prefetch combining incorrectly with correlated subquery selections - Fix multiple edge cases stemming from interaction of a non-selecting order_by specification and distinct and/or complex prefetch - Fix unbound growth of a resultset during repeated execute/exhaust cycles (GH#29) - Work around (and be very vocal about the fact) when DBIC encounters an exception object with broken string overloading - Clarify ambiguous behavior of distinct when used with ResultSetColumn i.e. $rs->search({}, { distinct => 1 })->get_column (...) - Setting quote_names propagates to SQL::Translator when producing SQLite DDL (it is one of the few producers *NOT* quoting by default) - Fix incorrect binding of large integers on old versions of DBD::SQLite (now DBIC simply always binds SQLite ints as BIGINT) - Silence (harmless) warnings on recent DBD::SQLite versions, when inserting/updating large integers on 32bit ivsize systems (RT#76395) - Back out self-cleaning from DBIx::Class::Carp for the time being (as a side effect fixes RT#86267) - Fix incorrect internal use of implicit list context in copy() - Fix 0.08250 regression in driver determination when DBI_DSN is used - Tests no longer fail if $ENV{DBI_DSN} is set - Throw clearer exception on ->new_related() with a non-existent relationship - Fix incorrect parethesis unroll with multicolumn in, (never noticed before fixing false positive in SQLA::Test 1.77) - Fix t/storage/replicated.t class loading problem - Stop using the deprecated Class::MOP::load_class() - Fix warning in t/54taint.t with explicitly unset PERL5LIB (RT#91972) - Fix t/54taint.t failing under a local::lib with installed earlier DBIC version (RT#92486) * Misc - Massive incompatible change of ::BlockRunner internals (was never documented as usable externally, this last set of changes settles the design for proper documentation and opening up) - Adjust exceptions in tests to accommodate changes in the upcoming DBD::SQLite based on libsqlite 3.8.2 - More robust lock file naming scheme - allow tests to work on exotic MSWin32 filesystems (habitual offender being http://is.gd/iy5XVP) - Better diagnostics when File::Spec->tmpdir gives us crap in testing - Replace $row with $result in all docs to be consistent and to clarify various return values 0.08250 2013-04-29 22:00 (UTC) * New Features / Changes - Rewrite from scratch the result constructor codepath - many bugfixes and performance improvements (the current codebase is now capable of outperforming both DBIx::DataModel and Rose::DB::Object on some workloads). Some notable benefits: - Multiple has_many prefetch - Partial prefetch - you now can select only columns you are interested in, while preserving the collapse functionality (collapse is now exposed as a first-class API attribute) - Prefetch of resultsets with arbitrary order (RT#54949, RT#74024, RT#74584) - Prefetch no longer inserts right-side table order_by clauses (massively helps the deficient MySQL optimizer) - Prefetch with limit on right-side ordered resultsets now works correctly (via aggregated grouping) - No longer order the insides of a complex prefetch subquery, unless required to satisfy a limit - Stop erroneously considering order_by criteria from a join under distinct => 1 (the distinct should apply to the main source only) - Massively optimize codepath around ->cursor(), over 10x speedup on some iterating workloads. - Support standalone \[ $sql, $value ] in literal SQL with bind specifications: \[ '? + ?', 42, 69 ] is now equivalent to \[ '? + ?', [ {} => 42 ], [ {} => 69 ] ] - Changing the result_class of a ResultSet in progress is now explicitly forbidden. The behavior was undefined before, and would result in wildly differing outcomes depending on $rs attributes. - Deprecate returning of prefetched 'filter' rels as part of get_columns() and get_inflated_columns() data - Invoking get_inflated_columns() no longer fires get_columns() but instead retrieves data from individual non-inflatable columns via get_column() - Emit a warning on incorrect use of nullable columns within a primary key - Limited checks are performed on whether columns without declared is_nullable => 1 metadata do in fact sometimes fetch NULLs from the database (the check is currently very limited and is performed only on resultset collapse when the alternative is rather worse) * Fixes - Fix _dbi_attrs_for_bind() being called befor DBI has been loaded (regression in 0.08210) - Fix update/delete operations on resultsets *joining* the updated table failing on MySQL. Resolves oversights in the fixes for RT#81378 and RT#81897 - Fix open cursors silently resetting when inherited across a fork or a thread - Properly support "MySQL-style" left-side group_by with prefetch - Fix $grouped_rs->get_column($col)->func($func) producing incorrect SQL (RT#81127) - Stop Sybase ASE storage from generating invalid SQL in subselects when a limit without offset is encountered - Even more robust behavior of GenericSubQuery limit dialect - Make sure deployment_statements() and cursor_class() are called on a resolved storage subclass * Misc - Fix tests failing due to unspecified resultset retrieval order (test suite now will pass with newest SQLite libs) 0.08210 2013-04-04 15:30 (UTC) * New Features / Changes - Officially deprecate the 'cols' and 'include_columns' resultset attributes - Remove ::Storage::DBI::sth() deprecated in 0.08191 * Fixes - Work around a *critical* bug with potential for data loss in DBD::SQLite - RT#79576 - Audit and correct potential bugs associated with braindead reuse of $1 on unsuccessful matches - Fix incorrect warning/exception originator reported by carp*() and throw_exception() 0.08209 2013-03-01 12:56 (UTC) * New Features / Changes - Debugging aid - warn on invalid result objects created by what seems like an invalid inheritance hierarchy * Fixes - Fix another embarrassing regression preventing correct refining of the search criteria on a prefetched relation (broken in 0.08205) - Fix incorrect callsite reporting by DBIC::Carp 0.08208 2013-02-20 09:56 (UTC) * New Features / Changes - A bunch of nonsensically named arguments to the SQL::Translator parser have been marked as deprecated (while still fully supported) * Fixes - Fix duplicated selected columns when calling 'count' when a same aggregate function is used more than once in a 'having' clause (RT#83305) - Prevent SQL::Translator::Producer::YAML from seeing the $dbh in a potentially connected $schema instance (RT#75394) * Misc - Fixup our distbuilding process to stop creating world-writable tarball contents (implicitly fixes RT#83084) - Added strict and warnings tests for all lib and test files 0.08206 2013-02-08 * Fixes - Fix dbh_do() failing to properly reconnect (regression in 0.08205) - Extra sanity check of a fresh DBI handle ($dbh). Fixes connection coderefs returning garbage (seen in the wild) * Misc - Only allow known globals in SQL::Translator leak allowance - General cleanup of error message texts - quote names/identifiers for easier reading - Stop t/52leaks.t from failing when AUTOMATED_TESTING=1 0.08205 2013-01-22 * New Features / Changes - The emulate_limit() arbitrary limit dialect emulation mechanism is now deprecated, and will be removed when DBIx::Class migrates to Data::Query - Support for the source_bind_attributes() storage method has been removed after a lengthy deprecation cycle * Fixes - When performing resultset update/delete only strip condition qualifiers - leave the source name alone (RT#80015, RT#78844) - Fix incorrect behavior on resultset update/delete invoked on composite resultsets (e.g. as_subselect_rs) - Fix update/delete operations referencing the updated table failing on MySQL, due to its refusal to modify a table being directly queried. As a workaround induce in-memory temp-table creation (RT#81378, RT#81897) - More robust behavior under heavily threaded environments - make sure we do not have refaddr reuse in the global storage registry - Fix failing test on 5.8 under Win32 (RT#81114) - Fix hash-randomization test issues (RT#81638) - Disallow erroneous calling of connect_info on a replicated storage (RT#78436) * Misc - Improve the populate docs in ::Schema and ::ResultSet - ::Storage::DBI::source_bind_attributes() removed as announced on Jan 2011 in 0e773352a 0.08204 2012-11-08 * New Features / Changes - SQLMaker now accepts \'literal' with the 'for' rs attribute as an override to the builtin FOR options * Fixes - Fix unique constraint violations in Ordered.pm blanket movement (RT#79773, rolls back short-sighted 5e6fde33e) - Fix API mismatch between new_result() and new_related() (originally broken by fea3d045) - Fix test failure on perl 5.8 * Misc - Much more extensive diagnostics when a new RDBMS/DSN combination is encountered (RT#80431) 0.08203 2012-10-18 * Fixes - Really fix inadequate $dbh->ping SQLite implementation (what shipped in 0.08201 tickled other deficiencies in DBD::SQLite itself) 0.08202 2012-10-06 * Fixes - Replace inadequate $dbh->ping SQLite implementation with our own, fixes RT#78420 0.08200 2012-08-24 (UTC) * Fixes - Change one of the new tests for the previous release to not require SQL::Translator 0.08199 2012-08-22 (UTC) * Fixes - Roll back incomplete (and broken) internal changes - restore prefetch functionality 0.08198 2012-07-11 03:43 (UTC) * Fixes - Fix a number of Win32 Test issues - Fix silent Oracle connection failures 0.08197 2012-07-10 10:32 (UTC) * New Features / Changes - Issue a warning when DateTime objects are passed to ->search - Fast populate() in void context is now even more efficient by going directly through execute_for_fetch bypassing execute_array - Fix update()/delete() on complex resultsets to no longer fall back to silly row-by-row deletion, construct a massive OR statement instead - Allow complex update/delete operations on sources without a primary key, as long as they have at least one non-nullable unique constraint - dbicadmin now better supports catalyst-style config files, by unrolling 'config_info' hashkeys - Multiple Improvements MSSQL over DBD::ADO - Transaction support - Support for VARCHAR(MAX)/VARBINARY(MAX)/NVARCHAR(MAX) datatypes - Nomalization of retrieved GUID values * Fixes - Fix complex has_many prefetch with resultsets not selecting identity columns from the root result source - Fix SkipFirst and FirstSkip limit dialects (Informix and Firebird) - Fix "Skimming limit" dialects (Top, FetchFirst) to properly check the order_by criteria for stability - Fix "Skimming limit" dialects (Top, FetchFirst) to propagate non-selected order criteria when part of a larger subquery - Fix RowNumberOver and all "skimming limits" to correctly assemble bind values when supplied for both select and order_by - Fix all subquery-based dialects to not lose a subquery fragment when we both select and order by the result of the same subquery - Fix the Sybase hubrid limit dialect (RowCountOrGenericSubQ) losing Group/Having/Order clauses when called without an offset (RT#73244) - No longer generate incorrect SQL on ->as_query called on resultsets with software_limit enabled - A number of corner case fixes of void context populate() with \[] - Fix corner case of forked children disconnecting the parents DBI handle - Improve identity/autoinc retrieval code in MSSQL and Sybase - should reduce weird side-effects especially with populate() - Explicitly disable DBD::ODBC batch operations (as of DBD::ODBC 1.35) for the following drivers too buggy to handle the optimized path: - FreeTDS ODBC driver (when used with MSSQL) - The Firebird ODBC driver - The MSAccess ODBC driver - Explicitly disable DBD::ODBC dynamic_cursors when using freetds 0.83 or later - they made enough ODBC incompatible changes making it impossible to support sanely - Explicitly disable SCOPE_IDENTITY queries and statement caching for MSSQL on DBD::Sybase compiled against freetds 0.83 or later - way too buggy - Disable statement caching when using Sybase ASE and DBD::Sybase compiled against freetds 0.83 or later - Fix leakage of $schema on in-memory new_related() calls - Fix more cases of $schema leakage in SQLT::Parser::DBIC - Fix leakage of $storage in ::Storage::DBI::Oracle - Fix pessimization of Oracle RowNum limit dialect query when no offset has been specified - Remove useless vestigial pessimization in Ordered.pm for cases when the position column is part of a unique constraint - Fix dbicadmin to no longer ignore the documented 'config' option - The schema-resultsource entanglement is now much more robust under threads - Fix ::Schema::ddl_filename() failing miserably on paths containing certain numeric sequences - t/53lean_startup.t adjusted for new 5.15.x base.pm behavior * Misc - Centralized leak-checks for all instances of DBICTest::Schema from within any test - Now passes all tests with Test::Builder 1.005 - Codebase is now trailing-whitespace-free - Cleanup of complex resultset update/delete oprations - storage specific code moved back to ResultSet and replaced by checks of storage capabilities - Fixed carp_once only emitting one single warning per package regardless of warning content - Test suite now can be safely executed in parallel (prove -jN or HARNESS_OPTIONS=jN) 0.08196 2011-11-29 05:35 (UTC) * Fixes - Fix tests for DBD::SQLite >= 1.34. - Fix test failures with DBICTEST_SQLITE_USE_FILE set - Fix the find() condition heuristics being invoked even when the call defaults to 'primary' (i.e. when invoked with bare values) - Throw much clearer error on incorrect inflation spec - Fix incorrect storage behavior when first call on a fresh schema is with_deferred_fk_checks - Fix incorrect dependency on Test::Simple/Builder (RT#72282) - Fix uninitialized warning in ::Storage::Sybase::ASE - Improve/cache DBD-specific datatype bind checks (also solves a nasty memleak with version.pm on multiple ->VERSION invocations) - The internal carp module now correctly skips CAG frames when reporting a callsite - Fix test failures on perl < 5.8.7 and new Package::Stash::XS - Fix TxnScopeGuard not behaving correctly when $@ is set at the time of $guard instantiation - Fix the join/prefetch resolver when dealing with ''/undef/() relation specifications * Misc - No longer depend on Variable::Magic now that a pure-perl namespace::clean is available - Drop Oracle's Math::BigInt req down to 1.80 - no fixes concerning us were made since 0.08195 2011-07-27 16:20 (UTC) * Fixes - Fix horrible oversight in the Oracle sqlmaker when dealing with queries updating blobs (RT#69829) 0.08194 2011-07-20 16:10 (UTC) * Fixes - Fix $rs->populate([]) to be a no-op rather than an exception - Overhaul t/53lean_startup.t to better dodge false positives - Stop Data::Compare from loading random plugins - Oracle: Recalculate LOB bind indices for UPDATE with LOBs in WHERE (RT#69548) 0.08193 2011-07-14 17:00 (UTC) * New Features / Changes - Allow schema cloning to mutate attributes - DBIC now attempts more aggressive de-duplication of where conditions on resultset chaining - The Ordered component is now smarter wrt reordering of dirty objects, and does its job with less storage queries - Logging via DBIC_TRACE=1=<filename> no longer overwrites the logfile on every program startup, appending loglines instead * Fixes - Fix issue where the query was becoming overly mangled when trying to use pagination with a query that has a sub-select in the WHERE clause - Fix possible incorrect pagination on Oracle, when a resultset is not ordered by a unique column - Revert "Fix incorrect signature of the default sqlt_deploy_hook" from 0.08191 - documentation was in fact incorrect, not the code - Fix Sybase ASE IC::DateTime support (::Storage going out of sync with new default format expected by DateTime::Format::Sybase) - Fix a bug in update_all() resulting in the first row receiving a different dataset than the subsequent ones - Accomodate MSAccess supporting only 'INNER JOIN' (not plain 'JOIN') - InflateColumn::DateTime option datetime_undef_if_invalid no longer masks missing dependency exceptions (RT#66823) - Fix bug in Schema::Versioned failing to insert a schema version row during upgrades at the turn of the second - Fix incorrect bind of integers >= 2^^32 (bigint columns) to SQL_INTEGER, resulting in silent conversion to '-1' - Fix pre 5.10 failures of t/55namespaces_cleaned.t due to buggy require() (RT#68814) - Oracle autoinc inserts no longer leave open cursors behind 0.08192 2011-05-10 04:20 (UTC) * Fixes - Fix serious regression on SQLite, corrupting data when an alphanum value does not correspond to a stale numeric datatype in colinfo 0.08191 2011-05-02 00:45 (UTC) (deleted from CPAN) * New Features / Changes - Add quote_names connection option. When set to true automatically sets quote_char and name_sep appropriate for your RDBMS - Add retrieve_on_insert column info flag, allowing to retrieve any column value instead of just autoinc primary keys - Bring back strict ordering of selectors in complex search chains (an ill-fated attempt was made in 0.08127 to order intelligently) - All limit dialects (except for the older Top and FetchFirst) are now using bind parameters for the limits/offsets, making DBI's prepare_cached useful across paged resutsets - Support for savepoints for SQLite - Support for MS Access databases via DBD::ODBC and DBD::ADO (only Win32 support currently tested) - Support for the Firebird RDBMS over the new DBD::Firebird driver - IC::DateTime support for MSSQL over DBD::ADO - Both the ::ODBC and ::ADO dispatchers now warn if a rdbms-specific driver is not found for this connection before falling back to plain ::Storage::DBI - ::Storage::DBI::sth was mistakenly marked/documented as public, privatize and warn on deprecated use - Massive overhaul of bind values/attributes handling - slightly changes the output of as_query (should not cause compat issues) - Support ancient DB2 versions (5.4 and older), with proper limit dialect - Support sub-second precision for TIMESTAMPs for Firebird over ODBC - Support BLOBs and CLOBs in WHERE clauses for Oracle, including LIKE queries for CLOBs. * Fixes - Fix ::Storage::DBI::* MRO problems on 5.8.x perls - Disable mysql_auto_reconnect for MySQL - depending on the ENV it sometimes defaults to on and causes major borkage on older DBD::mysql versions - Fix dropped bind values in select/group_by on Oracle (omission from 0542ec57 and 4c2b30d6) - Fix remaining errors with Oracle and identifiers longer than the Oracle-imposed maximum of 30 characters (RT#66390) - Fix older oracle-specific "WhereJoins" to work properly with name quoting - Fix problems with M.A.D. under CGI::SpeedyCGI (RT#65131) - Reenable paging of cached resultsets - breakage erroneously added in 0.08127 - Better error handling when prepare() fails silently - Fixes skipped lines when a comment is followed by a statement when deploying a schema via sql file - Fix reverse_relationship_info on prototypical result sources (sources not yet registered with a schema) - Warn and skip relationships missing from a partial schema during dbic cascade_delete - Automatically require the requested cursor class before use (RT#64795) - Work around a Firebird ODBC driver bug exposed by DBD::ODBC 1.29 - Fix (to the extent allowed by the driver) transaction support in DBD::Sybase compiled against FreeTDS - Fix exiting via next warnings in ResultSource::sequence() - Fix stripping of table qualifiers in update/delete in arrayref condition elements - Change SQLMaker carp-monkeypatch to be compatible with versions of SQL::Abstract >= 1.73 - Fix using \[] literals in the from resultset attribute - Fix populate() with \[], arrays (datatype) and other exotic values - Fix handling of rollbacks in nested transactions - Fix complex limits (RNO/RowNum/FetchFirst/Top/GenSubq) with sub-selects in the selectors list (correlated subqueries) - Fix inconsistency between $rs->next with and without HRI when all the "root" columns are in fact injected from the right rs side - Fix the join optimizer to correctly preserve the non-multi path to a multi relationship ( x -> might_have y -> has_many z ) - Fix object-derived custom-relationship resultsets to resultsources with multilevel monikers (e.g. $schema->source('Foo::Bar') ) - Fix incorrect signature of the default sqlt_deploy_hook - it now matches the documentation of passing in the result source object - Fix inadequate handling of internal storage methods within ::Storage::Replicated (RT#66295) * Misc - Rewire all warnings to a new Carp-like implementation internal to DBIx::Class, and remove the Carp::Clan dependency - Only load Class::C3 and friends if necessary ($] < 5.010) - Greatly reduced loading of non-essential modules to aid startup time (mainly benefiting CGI users) - Make sure all namespaces are clean of rogue imports - Dropped DBI req 2 years back - everything works with 1.57, no point requiring something newer 0.08190-TRIAL 2011-01-24 15:35 (UTC) * New Features / Changes - Support for completely arbitrary SQL::Abstract-based conditions in all types of relationships 0.08127 2011-01-19 16:40 (UTC) * New Features / Changes - Schema/resultsource instances are now crossreferenced via a new system guaranteeing leak-free mutually assured destruction - DBIx::Class now warns when the user erroneously supplies AutoCommit => 0 to connect() - A warning is also issued before forcing the RaiseError setting of externally supplied DBI handles - Switch to a warning when find() is invoked with both a 'key' argument and a NULL-containing condition to satisfy the named constraint. Previously (starting with 0.08124) an exception was thrown - Switch to a warning when a commit is attempted with an out-of-sync transaction_depth (someone issued a begin externally to DBIC). Previously (starting with 0.08124) an exception was thrown * Fixes - A number of improvements/diagnostics of multiple active resultset handling on MSSQL over DBD::ODBC - Revert default selection to being lazy again (eagerness introduced in 0.08125) - fixes DBIx::Class::Helper::ResultSet::RemoveColumns - Fix losing order of columns provided in select/as (regression from 0.08125) - Unaliased "dark" selectors no longer throw off prefetch - Fix proper composition of bind values across all possible SQL areas ( group_by => \[ ... ] now works properly ) - Allow populate to skip empty has_many relationships which makes it easier to pass HashRefInflator data directly to ->populate - Improve freeze/thaw semantics and error messages (RT#62546) - Fix inconsistency in Manual::Features (RT#64500) - Fix incorrect SQL when using for => 'shared' with MySQL (RT#64590) - Throw comprehensible exception on erroneous $schema->source() invocation - Fix sloppy refactor of ResultSource::sequence back from 89170201 (RT#64839) - Fix incorrect error detection during populate() on Oracle - Better handling of result_source-less row objects by auto-calling result_source_instance when necessary - Fix reverse_relationship_info and sqlt deploy on partially loaded schemas (relationships point to non-existent sources) * Misc - Fix test warning on win32 - at this point the test suite is warning-free on all known OSes - Require newest namespace::clean which in turn depends on new installable Package::Stash 0.08126 2010-12-28 18:10 (UTC) * Fixes - Bump forgotten Class::Accessor::Grouped core dependency - Promote forgotten Hash::Merge optdep to a hard requirement - Skip t/storage/error.t on smokers with leaking perls - Fix t/storage/txn.t deadlocks on slower machines - Do not run on smokers if a trial Package::Stash is found 0.08125 2010-12-27 04:30 (UTC) * New Features / Changes - New method ResultSource columns_info method, returning multiple pairs of column name/info at once - $rs->search now throws when called in void context, as it makes no sense (and is nearly always a sign of a bug/misdesign) - Restore long-lost ability to supply unbalanced select/as pairs e.g. +select => \'DISTINCT(foo, bar)', +as => ['foo', 'bar'] - +columns now behaves just like columns by not stripping a fully-qualified 'as' spec (i.e. foo.bar results in $obj->foo->bar) - Deprecate legacy $rs->search( %condition ) syntax (warn once per callsite) - NULL is now supplied unquoted to all debug-objects, in order to differentiate between a real NULL and the string 'NULL' - New search() condition operator -value used to pass complex bind values to DBI: search({ array_col => { -value => [1,2,3] }}) - Add full INSERT...RETURNING support for Oracle - Deprecate use of -nest in search conditions (warn once per callsite) - Deprecate the completely useless DBIx::Class::Serialize::Storable result component * Fixes - Fixed read-only attribute set attempt in ::Storage::Replicated (RT#62642) - Fix incomplete logic while detecting correct Oracle sequence on insert - Fix detection of Oracle sequences for tables without an explicitly specified schema (RT#63493) - Major overhaul of Storage::Oracle to handle enabled quoting - Fixed incorrect composition of select/as/columns attributes during chaining (RT#61235) - Proper serialization of resultsets with open cursors - Refactor handling of RDBMS-side values during insert() - fix regression of inserts into a Postgres / ::Replicated combination - Missing dependency check in t/60core.t (RT#62635) - Fix regressions in IC::DT registration logic - Fix regression in select-associated bind value handling (RT#61025) - Simplify SQL generated by some LIMITed prefetching queries - Throw an exception when a required group_by on a complex prefetch can not be auto-constructed, instead of continuing to eventually produce invalid SQL - Fix infinite loops on old perls with a recent Try::Tiny - Improve "fork()" on Win32 by reimplementing a more robust DBIC thread support (still problematic, pending a DBI fix) - Properly quote table name on INSERT with no values - Work around possible Storage destruction warnings - Fix count of grouped resultsets using HAVING with aliases - Setting belongs_to columns/relationships no longer leaves the FK value and related object out of sync - Stop stripping newlines from SQL statements in the limit emulators as it is possible that custom sql with comments was provided - Add forgotten attributes to Admin.pm - Fix incorrect 'having' attribute documentation (RT#64129) - Improve fallback-to-master/return-to-slave reporting in ::Replicated::Balancer - Adjust txn_scope_guard code/tests to changes in $@ handling on recent blead (RT#64251) * Misc - Add extra option groups to DBIC::Optional::Depencencies, to aid users in requesting the prerequisites for a particular RDBMS - Switch all serialization to use Storable::nfreeze for portable architecture independent ice - Fix the bogus META.yml dependency injection issue for good - Refactor DBIx::Class::Storage::Statistics::debugfh() to be lazy 0.08124 2010-10-28 14:23 (UTC) * New Features / Changes - Add new -ident "function" indicating rhs is a column name { col => { -ident => 'othercol' } } vs { col => \'othercol' } - Extend 'proxy' relationship attribute - Use DBIx::Class::Storage::Debug::PrettyPrint when the environment variable DBIC_TRACE_PROFILE is set, see DBIx::Class::Storage for more information - Implemented add_unique_constraints() which delegates to add_unique_constraint() as appropriate - add_unique_constraint() now poparly throws if called with multiple constraint definitions - No longer depend on SQL::Abstract::Limit - DBIC has been doing most of the heavy lifting for a while anyway - FilterColumn now passes data through when transformations are not specified rather than throwing an exception. - Optimized RowNum based Oracle limit-dialect (RT#61277) - Requesting a pager on a resultset with cached entries now throws an exception, instead of returning a 1-page object since the amount of rows is always equal to the "pagesize" - $rs->pager now uses a lazy count to determine the amount of total entries only when really needed, instead of doing it at instantiation time - New documentation map organized by features (DBIx::Class::Manual::Features) - find( { ... }, { key => $constraint } ) now throws an exception when the supplied data does not fully specify $constraint - find( col1 => $val1, col2 => $val2, ... ) is no longer supported (it has been in deprecated state for more than 4 years) - Make sure exception_action does not allow exception-hiding due to badly-written handlers (the mechanism was never meant to be able to suppress exceptions) * Fixes - Fix memory leak during populate() on 5.8.x perls - Temporarily fixed 5.13.x failures (RT#58225) (perl-core fix still pending) - Fix result_soutrce_instance leaks on compose_namespace - Fix $_ volatility on load_namespaces (a class changing $_ at compile time no longer causes a massive fail) - Fix find() without a key attr. choosing constraints even if some of the supplied values are NULL (RT#59219) - Fixed rels ending with me breaking subqueried limit realiasing - Fixed $rs->update/delete on resutsets constrained by an -or condition - Remove rogue GROUP BY on non-multiplying prefetch-induced subqueries - Fix incorrect order_by handling with prefetch on $ordered_rs->search_related ('has_many_rel') resultsets - Oracle sequence detection now *really* works across schemas (fixed some ommissions from 0.08123) - dbicadmin now uses a /usr/bin/env shebang to work better with perlbrew and other local perl builds - bulk-inserts via $dbh->bind_array (void $rs->populate) now display properly in DBIC_TRACE - Incomplete exception thrown on relationship auto-fk-inference failures - Fixed distinct with order_by to not double-specify the same column in the GROUP BY clause - Properly support column names with symbols (e.g. single quote) via custom accessors - Fixed ::Schema::Versioned to work properly with quoting on (RT#59619) - Fixed t/54taint fails under local-lib - Fixed SELECT ... FOR UPDATE with LIMIT regression (RT#58554) - Fixed CDBICompat to preserve order of column-group additions, so that test relying on the order of %{} will no longer fail - Fixed mysterious ::Storage::DBI goto-shim failures on older perl versions - Non-blessed reference exceptions are now correctly preserved when thrown from udner DBIC (e.g. from txn_do) - No longer disconnecting database handles supplied to connect via a coderef - Fixed t/inflate/datetime_pg.t failures due to a low dependency on DateTime::Format::Pg (RT#61503) - Fix dirtyness detection on source-less objects - Fix incorrect limit_dialect assignment on Replicated pool members - Fix invalid sql on relationship attr order_by with prefetch - Fix primary key sequence detection for Oracle (first trigger instead of trigger for column) - Add various missing things to Optional::Dependencies - Skip a test that breaks due to serious bugs in current DBD::SQLite - Fix tests related to leaks and leaky perls (5.13.5, 5.13.6) * Misc - Entire test suite now passes under DBIC_TRACE=1 - Makefile.PL no longer imports GetOptions() to interoperate better with Catalyst installers - Bumped minimum Module::Install for developers - Bumped DBD::SQLite dependency and removed some TODO markers from tests (RT#59565) - Do not execute t/zzzzzzz_sqlite_deadlock.t for regular module installs - test is prone to spontaneous blow up - DT-related tests now require a DateTime >= 0.55 (RT#60324) - Makefile.PL now provides a pre-parsed DBIC version to the Opt::Dep pod generator - t/52leaks.t now performs very aggressive leak detection in author/smoker mode 0.08123 2010-06-12 14:46 (UTC) * Fixes - Make sure Oracle identifier shortener applies to auto-generated column names, so we stay within the 30-char limit (RT#58271) - Oracle sequence detection now works across schemas - Fix a Storage/$dbh leak introduced by the migration to Try::Tiny (this is *not* a Try::Tiny bug) - Fix corner case of count with group-by over a 1:1 join column where the selector ends up with column name clashes - POD fixes (RT#58247) * Misc - Test suite default on-disk database now checks for Win32 fail-conditions even when running on other OSes 0.08122 2010-06-03 17:41 (UTC) * New Features - Add DBIx::Class::FilterColumn for non-ref filtering - ::Storage::DBI now correctly preserves a parent $dbh from terminating children, even during interpreter-global out-of-order destruction - dbicadmin supports an -I option with the same semantics as perl itself - InflateColumn::DateTime support for MSSQL via DBD::Sybase - Millisecond precision support for MSSQL datetimes for InflateColumn::DateTime - Oracle-specific hierarchical query syntax support: CONNECT BY (NOCYCLE) / START WITH / ORDER SIBLINGS BY - Support connecting using $ENV{DBI_DSN} and $ENV{DBI_DRIVER} - current_source_alias method on ResultSet objects to determine the alias to use in programatically assembled search()es (originally added in 0.08100 but unmentioned) - Rewrite/unification of all subselecting limit emulations (RNO, Top, RowNum) to be much more robust wrt complex joined resultsets - MSSQL limits now don't require nearly as many applications of the unsafe_subselect_ok attribute, due to optimized queries - Support for Generic Subquery limit "emulation" - awfully slow and inefficient but works on almost any db, and is preferred to software limit emulation - Sybase ASE driver now uses SET ROWCOUNT where possible, and Generic Subquery otherwise for limit support instead of always using software limit emulation - create_ddl_dir (and derivatives) now attempt to create the given $ddl_dir if it does not already exist - deployment_statements now automatically supplies the current RDBMS version to SQLT producer_args for MySQL, Pg, SQLite and Oracle * Fixes - Fix nasty potentially data-eating bug when deleting/updating a limited resultset - Fix find() to use result_class set on object - Fix result_class setter behaviour to not mistakenly stuff attrs. - Don't try and ensure_class_loaded an object. This doesn't work. - Fix as_subselect_rs to not inject resultset class-wide where conditions outside of the resulting subquery - Fix count() failing with {for} resultset attribute (RT#56257) - Fixed incorrect detection of Limit dialect on unconnected $schema - update() on row not in_storage no longer throws an exception if there are no dirty columns to update (fixes cascaded update annoyances) - update()/delete() on prefetching resultsets no longer results in malformed SQL (some $rs attributes were erroneously left in) - Fix dbicadmin to allow deploy() on non-versioned schema - Fix dbicadmin to respect sql_dir on upgrade() (RT#57732) - Update Schema::Versioned to respect hashref style of connection_info - Do not recreate the same related object twice during MultiCreate (solves the problem of orphaned IC::FS files) - Fully qualify xp_msver selector when using DBD::Sybase with MSSQL (RT#57467) - Fix ::DBI::Storage to always be able to present a full set of connect() attributes to e.g. Schema::Versioned - Fix Oracle auto-inc trigger detection of "INSERT OR UPDATE"-type triggers * Misc - Reformatted Changelog \o/ - DBIC goes git://git.shadowcat.co.uk/dbsrgits/DBIx-Class.git - Allow developers to skip optional dependency forcing when working from a checkout - Add a warning to load_namespaces if a class in ResultSet/ is not a subclass of DBIx::Class::ResultSet - All DBIC exception-handling switched to Try::Tiny - All DBIC modules are now free of imports via namespace::clean - Depend on optimized SQL::Abstract (faster SQL generation) - Depend on new Class::Accessor::Grouped reintroducing optional use of Class::XSAccessor (just install C::XSA and get lightning fast column accessors) 0.08121 2010-04-11 18:43:00 (UTC) - Support for Firebird RDBMS with DBD::InterBase and ODBC - Add core support for INSERT RETURNING (for storages that supports this syntax, currently PostgreSQL and Firebird) - Fix spurious warnings on multiple UTF8Columns component loads - DBIx::Class::UTF8Columns entered deprecated state - DBIx::Class::InflateColumn::File entered deprecated state - DBIx::Class::Optional::Dependencies left experimental state - Add req_group_list to Opt::Deps (RT#55211) - Add support for mysql-specific STRAIGHT_JOIN (RT#55579) - Cascading delete/update are now wrapped in a transaction for atomicity - Fix accidental autovivification of ENV vars - Fix update_all and delete_all to be wrapped in a transaction - Fix multiple deficiencies when using MultiCreate with data-encoder components (e.g. ::EncodedColumn) - Fix regression where SQL files with comments were not handled properly by ::Schema::Versioned. - Fix regression on not properly throwing when $obj->relationship is unresolvable - Fix the join-optimiser to consider unqualified column names whenever possible - Fix an issue with multiple same-table joins confusing the join optimizier - Add has_relationship method to row objects - Fix regression in set_column on PK-less objects - Better error text on malformed/missing relationships - Add POD about the significance of PK columns - Fix for SQLite to ignore the (unsupported) { for => ... } attribute - Fix ambiguity in default directory handling of create_ddl_dir (RT#54063) - Support add_columns('+colname' => { ... }) to augment column definitions. 0.08120 2010-02-24 08:58:00 (UTC) - Make sure possibly overwritten deployment_statements methods in schemas get called on $schema->deploy - Fix count() with group_by aliased-function resultsets - with_deferred_fk_checks() Oracle support - Massive refactor and cleanup of primary key handling - Fixed regression losing custom result_class (really this time) (RT#54697) - Fixed regression in DBIC SQLT::Parser failing with a classname (as opposed to a schema object) - Changes to Storage::DBI::Oracle to accomodate changes in latest SQL::Translator (quote handling) - Make sure deployment_statements is per-storage overridable - Fix dbicadmin's (lack of) POD 0.08119 2010-02-15 09:36:00 (UTC) - Add $rs->is_ordered to test for existing order_by on a resultset - Add as_subselect_rs to DBIC::ResultSet from DBIC::Helper::ResultSet::VirtualView::as_virtual_view - Refactor dbicadmin adding DDL manipulation capabilities - New optional dependency manager to aid extension writers - Depend on newest bugfixed Moose - Make resultset chaining consistent wrt selection specification - Storage::DBI::Replicated cleanup - Fix autoinc PKs without an autoinc flag on Sybase ASA 0.08118 2010-02-08 11:53:00 (UTC) - Fix a bug causing UTF8 columns not to be decoded (RT#54395) - Fix bug in One->Many->One prefetch-collapse handling (RT#54039) - Cleanup handling of relationship accessor types 0.08117 2010-02-05 17:10:00 (UTC) - Perl 5.8.1 is now the minimum supported version - Massive optimization of the join resolution code - now joins will be removed from the resulting SQL if DBIC can prove they are not referenced by anything - Subqueries no longer marked experimental - Support for Informix RDBMS (limit/offset and auto-inc columns) - Support for Sybase SQLAnywhere, both native and via ODBC - might_have/has_one now warn if applied calling class's column has is_nullable set to true. - Fixed regression in deploy() with a {sources} table limit applied (RT#52812) - Views without a view_definition will throw an exception when parsed by SQL::Translator::Parser::DBIx::Class - Stop the SQLT parser from auto-adding indexes identical to the Primary Key - InflateColumn::DateTime refactoring to allow fine grained method overloads - Fix ResultSetColumn improperly selecting more than the requested column when +columns/+select is present - Fix failure when update/delete of resultsets with complex WHERE SQLA structures - Fix regression in context sensitiveness of deployment_statements - Fix regression resulting in overcomplicated query on search_related from prefetching resultsets - Fix regression on all-null returning searches (properly switch LEFT JOIN to JOIN in order to distinguish between both cases) - Fix regression in groupedresultset count() used on strict-mode MySQL connections - Better isolation of RNO-limited queries from the rest of a prefetching resultset - New MSSQL specific resultset attribute to allow hacky ordered subquery support - Fix nasty schema/dbhandle leak due to SQL::Translator - Initial implementation of a mechanism for Schema::Version to apply multiple step upgrades - Fix regression on externally supplied $dbh with AutoCommit=0 - FAQ "Custom methods in Result classes" - Cookbook POD fix for add_drop_table instead of add_drop_tables - Schema POD improvement for dclone 0.08115 2009-12-10 09:02:00 (CST) - Real limit/offset support for MSSQL server (via Row_Number) - Fix distinct => 1 with non-selecting order_by (the columns in order_by also need to be aded to the resulting group_by) - Do not attempt to deploy FK constraints pointing to a View - Fix count/objects from search_related on limited resultset - Stop propagating distinct => 1 over search_related chains - Make sure populate() inherits the resultset conditions just like create() does - Make get_inflated_columns behave identically to get_columns wrt +select/+as (RT#46953) - Fix problems with scalarrefs under InflateColumn (RT#51559) - Throw exception on delete/update of PK-less resultsets - Refactored Sybase storage driver into a central ::DBI::Sybase dispatcher, and a sybase-specific ::DBI::Sybase::ASE - Fixed an atrocious DBD::ADO bind-value bug - Cookbook/Intro POD improvements 0.08114 2009-11-14 17:45:00 (UTC) - Preliminary support for MSSQL via DBD::ADO - Fix botched 0.08113 release (invalid tarball) 0.08113 2009-11-13 23:13:00 (UTC) - Fix populate with has_many bug (RT #50828) - Fix Oracle autoincrement broken for Resultsets with scalar refs (RT #50874) - Complete Sybase RDBMS support including: - Support for TEXT/IMAGE columns - Support for the 'money' datatype - Transaction savepoints support - DateTime inflation support - Support for bind variables when connecting to a newer Sybase with OpenClient libraries - Support for connections via FreeTDS with CASTs for bind variables when needed - Support for interpolated variables with proper quoting when connecting to an older Sybase and/or via FreeTDS - bulk API support for populate() - Transaction support for MSSQL via DBD::Sybase - Add is_paged method to DBIx::Class::ResultSet so that we can check that if we want a pager - Skip versioning test on really old perls lacking Time::HiRes (RT #50209) - Fixed on_connect_do/call regression when used with a coderef connector (RT #50003) - A couple of fixes to Ordered to remedy subclassing issues - Fixed another lingering problem with PostgreSQL auto-increment support and its interaction with multiple schemas - Remove some IN workarounds, and require a recent version of SQLA instead - Improvements to populate's handling of mixed scalarref values - Fixed regression losing result_class after $rs->find (introduced in 0.08108) - Fix in_storage() to return 1|0 as per existing documentation - Centralize handling of _determine_driver calls prior to certain ::Storage::DBI methods - Fix update/delete arbitrary condition handling (RT#51409) - POD improvements 0.08112 2009-09-21 10:57:00 (UTC) - Remove the recommends from Makefile.PL, DBIx::Class is not supposed to have optional dependencies. ever. - Mangle the DBIx/Class.pm POD to be more clear about copyright and license - Put back PG's multiple autoinc per table support, accidentally dropped during the serial-autodetection rewrite - Make sure ResultSetColumn does not depend on the (undefined) return value of ->cursor->reset() - Add single() to ResultSetColumn (same semantics as ResultSet) - Make sure to turn off IDENTITY_INSERT after insert() on MSSQL tables that needed it - More informative exception on failing _resolve_relationship - Allow undef/NULL as the sole grouping value in Ordered - Fix unreported rollback exceptions in TxnScopeGuard - Fix overly-eager left-join chain enforcing code - Warn about using distinct with an existing group_by - Warn about attempting to $rs->get_column a non-unique column when has_many joins are added to resultset - Refactor of the exception handling system (now everything is a DBIx::Class::Exception object) 0.08111 2009-09-06 21:58:00 (UTC) - The hashref to connection_info now accepts a 'dbh_maker' coderef, allowing better intergration with Catalyst - Fixed a complex prefetch + regular join regression introduced in 0.08108 - Fixed insert_bulk rebless handling - Fixed Storable roundtrip regression, and general serialization cleanup - SQLT related fixes: - sqlt_type is now called on the correct storage object - hooks can now see the correct producer_type (RT#47891) - optional SQLT requirements for e.g. deploy() bumped to 0.11002 - Really fixed (and greatly cleaned up) postgresql autoinc sequence autodetection - Automatically detect MySQL v3 and use INNER JOIN instead of JOIN - POD improvements (including RT#48769) - Test suite tweaks (including fixes for recent CPANTS fails) - Better support for MSSQL IDENTITY_INSERT ON 0.08109 2009-08-18 08:35:00 (UTC) - Replication updates: - Improved the replication tests so that they are more reliable and accurate, and hopefully solve some cross platform issues. - Bugfixes related to naming particular replicants in a 'force_pool' attribute. - Lots of documentation updates, including a new Introduction.pod file. - Fixed the way we detect transaction to make this more reliable and forward looking. - Fixed some trouble with the way Moose Types are used. - Made discard_chages/get_from_storage replication aware (they now read from the master storage by default) - Refactor of MSSQL storage drivers, with some new features: - Support for placeholders for MSSQL via DBD::Sybase with proper autodetection - 'uniqueidentifier' support with auto newid() - Dynamic cursor support and other MARS options for ODBC - savepoints with auto_savepoint => 1 - Support for MSSQL 'money' type - Support for 'smalldatetime' type used in MSSQL and Sybase for InflateColumn::DateTime - Support for Postgres 'timestamp without timezone' type in InflateColumn::DateTime (RT#48389) - Added new MySQL specific on_connect_call macro 'set_strict_mode' (also known as make_mysql_not_suck_as_much) - Multiple prefetch-related fixes: - Adjust overly agressive subquery join-chain pruning - Always preserve the outer join-chain - fixes numerous problems with search_related chaining - Deal with the distinct => 1 attribute properly when using prefetch - An extension of the select-hashref syntax, allowing labeling SQL-side aliasing: select => [ { max => 'foo', -as => 'bar' } ] - Massive optimization of the DBI storage layer - reduce the amount of connected() ping-calls - Some fixes of multi-create corner cases - Multiple POD improvements - Added exception when resultset is called without an argument - Improved support for non-schema-qualified tables under Postgres (fixed last_insert_id sequence name auto-detection) 0.08108 2009-07-05 23:15:00 (UTC) - Fixed the has_many prefetch with limit/group deficiency - it is now possible to select "top 5 commenters" while prefetching all their comments - New resultsed method count_rs, returns a ::ResultSetColumn which in turn returns a single count value - Even better support of count with limit - New on_connect_call/on_disconnect_call functionality (check POD of Storage::DBI) - Automatic datetime handling environment/session setup for Oracle via connect_call_datetime_setup() - count/all on related left-joined empty resultsets now correctly returns 0/() - Fixed regression when both page and offset are specified on a resultset - Fixed HRI returning too many empty results on multilevel nonexisting prefetch - make_column_dirty() now overwrites the deflated value with an inflated one if such exists - Fixed set_$rel with where restriction deleting rows outside the restriction - populate() returns the created objects or an arrayref of the created objects depending on scalar vs. list context - Fixed find_related on 'single' relationships - the former implementation would overspecify the WHERE condition, reporting no related objects when there in fact is one - SQL::Translator::Parser::DBIx::Class now attaches tables to the central schema object in relationship dependency order - Fixed regression in set_column() preventing sourceless object manipulations - Fixed a bug in search_related doubling a join if the original $rs already joins/prefetches the same relation - Storage::DBI::connected() improvements for Oracle and Sybase - Fixed prefetch+incomplete select regression introduced in 0.08100 - MSSQL limit (TOP emulation) fixes and improvements 0.08107 2009-06-14 08:21:00 (UTC) - Fix serialization regression introduced in 0.08103 (affects Cursor::Cached) - POD fixes - Fixed incomplete ::Replicated debug output 0.08106 2009-06-11 21:42:00 (UTC) - Switched SQLite storage driver to DateTime::Format::SQLite (proper timezone handling) - Fix more test problems 0.08105 2009-06-11 19:04:00 (UTC) - Update of numeric columns now properly uses != to determine dirtyness instead of the usual eq - Fixes to IC::DT tests - Fixed exception when undef_if_invalid and timezone are both set on an invalid datetime column 0.08104 2009-06-10 13:38:00 (UTC) - order_by now can take \[$sql, @bind] as in order_by => { -desc => \['colA LIKE ?', 'somestring'] } - SQL::Abstract errors are now properly croak()ed with the correct trace - populate() now properly reports the dataset slice in case of an exception - Fixed corner case when populate() erroneously falls back to create() - Work around braindead mysql when doing subquery counts on resultsets containing identically named columns from several tables - Fixed m2m add_to_$rel to invoke find_or_create on the far side of the relation, to avoid duplicates - DBIC now properly handles empty inserts (invoking all default values from the DB, normally via INSERT INTO tbl DEFAULT VALUES - Fix find_or_new/create to stop returning random rows when default value insert is requested (RT#28875) - Make IC::DT extra warning state the column name too - It is now possible to transparrently search() on columns requiring DBI bind (i.e. PostgreSQL BLOB) - as_query is now a Storage::DBI method, so custom cursors can be seamlessly used - Fix search_related regression introduced in 0.08103 0.08103 2009-05-26 19:50:00 (UTC) - Multiple $resultset -> count/update/delete fixes. Now any of these operations will succeed, regardless of the complexity of $resultset. distinct, group_by, join, prefetch are all supported with expected results - Return value of $rs->delete is now the storage return value and not 1 as it used to be - don't pass SQL functions into GROUP BY - Remove MultiDistinctEmulation.pm, effectively deprecating { select => { distinct => [ qw/col1 col2/ ] } } - Change ->count code to work correctly with DISTINCT (distinct => 1) via GROUP BY - Removed interpolation of bind vars for as_query - placeholders are preserved and nested query bind variables are properly merged in the correct order - Refactor DBIx::Class::Storage::DBI::Sybase to automatically load a subclass, namely Microsoft_SQL_Server.pm (similar to DBIx::Class::Storage::DBI::ODBC) - Refactor InflateColumn::DateTime to allow components to circumvent DateTime parsing - Support inflation of timestamp datatype - Support BLOB and CLOB datatypes on Oracle - Storage::DBI::Replicated::Balancer::Random: added master_read_weight - Storage::DBI::Replicated: storage opts from connect_info, connect_info merging to replicants, hashref connect_info support, improved trace output, other bug fixes/cleanups - distinct => 1 with prefetch now groups by all columns - on_connect_do accepts a single string equivalent to a one element arrayref (RT#45159) - DB2 limit + offset now works correctly - Sybase now supports autoinc PKs (RT#40265) - Prefetch on joins over duplicate relations now works correctly (RT#28451) - "timestamp with time zone" columns (for Pg) now get inflated with a time zone information preserved - MSSQL Top limit-emulation improvements (GROUP BY and subquery support) - ResultSetColumn will not lose the joins infered from a parent resultset prefetch 0.08102 2009-04-30 08:29:00 (UTC) - Fixed two subtle bugs when using columns or select/as paired with a join (limited prefetch) - Fixed breakage of cdbi tests (RT#45551) - Some POD improvements 0.08101 2009-04-27 09:45:00 (UTC) - Fix +select, +as, +columns and include_columns being stripped by $rs->get_column - move load_optional_class from DBIx::Class::Componentised to Class::C3::Componentised, bump dependency - register_extra_source() now *really* fixed wrt subclassing - Added missing POD descriptions (RT#45195) - Fix insert() to not store_column() every present object column - Multiple Makefile.PL fixes 0.08100 2009-04-19 11:39:35 (UTC) - Todo out the register_extra_source test until after shipping 0.08099_08 2009-03-30 00:00:00 (UTC) - Fixed taint mode with load_namespaces - Putting IC::DateTime locale, timezone or floating_tz_ok attributes into extra => {} has been deprecated. The new way is to put these things directly into the columns definition - Switched MI code to MRO::Compat - Document db-side default_value caveats - Search_like() now warns to indicate deprecation in 0.09. - TxnScopeGuard left experimental state 0.08099_07 2009-02-27 02:00:00 (UTC) - multi-create using find_or_create rather than _related for post-insert - fix get_inflated_columns to check has_column_loaded - Add DBIC_MULTICREATE_DEBUG env var (undocumented, quasi-internal) - Fix up multi-create to: - correctly propagate columns loaded during multi-insert of rels - not try and insert things tagged on via new_related unless required - Possible to set locale in IC::DateTime extra => {} config - Calling the accessor of a belongs_to when the foreign_key was NULL and the row was not stored would unexpectedly fail - Split sql statements for deploy only if SQLT::Producer returned a scalar containing all statements to be executed - Add as_query() for ResultSet and ResultSetColumn. This makes subqueries possible. See the Cookbook for details. - Massive rewrite of Ordered to properly handle position constraints and to make it more matpath-friendly - deploy_statements called ddl_filename with the $version and $dir arguments in the wrong order. - columns/+columns attributes now support { as => select } hahsrefs - support for views both in DBIC and via deploy() in SQLT 0.08099_06 2009-01-23 07:30:00 (UTC) - Allow a scalarref to be supplied to the 'from' resultset attribute - Classes submitted as result_class for a resultsource are now automatically loaded via ensure_loaded() - 'result_class' resultset attribute, identical to result_class() - add 'undef_on_null_fk' option for relationship accessors of type 'single'. This will prevent DBIC from querying the database if one or more of the key columns IS NULL - for 'belongs_to' rels, 'undef_on_null_fk' defaults to true. - fixed scope unaware last_insert_id fetching for MSSQL (http://msdn.microsoft.com/en-us/library/ms190315.aspx) - an sqlt_deploy_hook can now be shared between result sources using a configurable callback trigger - new order_by => { -desc => 'colname' } syntax supported - PG array datatype supported - insert should use store_column, not set_column to avoid marking clean just-stored values as dirty. New test for this - regression test for source_name 0.08099_05 2008-10-30 21:30:00 (UTC) - Rewrite of Storage::DBI::connect_info(), extended with an additional argument format type - InflateColumn::DateTime: add warning about floating timezone - InflateColumn::DateTime: possible to enforce/skip inflation - delete throws exception if passed arguments to prevent drunken mishaps. - Fix storage to copy scalar conds before regexping to avoid trying to modify a constant in odd edge cases - Related resultsets on uninserted objects are now empty - Fixed up related resultsets and multi-create - Fixed superfluous connection in ODBC::_rebless - Fixed undef PK for first insert in ODBC::Microsoft_SQL_Server - Added virtual method to Versioned so a user can create upgrade path across multiple versions (jgoulah) - Better (and marginally faster) implementation of the HashRefInflator hash construction algorithm - Allow explicit specification of ON DELETE/ON UPDATE constraints when using the SQLT parser 0.08099_04 2008-07-24 01:00:00 - Functionality to storage to enable a sub to be run without FK checks - Fixed $schema->clone bug which caused clone and source to share internal hash refs - Added register_extra_source methods for additional sources - Added datetime_undef_if_invalid for InflateColumn::DateTime to return undef on invalid date/time values - Added search_related_rs method to ResultSet - add a make_column_dirty method to Row to force updates - throw a clear exception when user tries multi-has_many prefetch - SQLT parser prefixes index names with ${table}_idx_ to avoid clashes - mark ResultSetManager as deprecated and undocument it - pod fix (RT #32988) - add Test::Exception to test requirements (RT #34256) - make ash's build_requires/META.yml fixes work better - is_deferable support on relations used by the SQL::Translator parser - Refactored DBIx::Class::Schema::Versioned - Syntax errors from resultset components are now reported correctly - sqltargs respected correctly in deploy et al. - Added support for savepoints, and using them automatically in nested transactions if auto_savepoint is set in connect_info. - Changed naming scheme for constraints and keys in the sqlt parser; names should now be consistent and collision-free. - Improve handling of explicit key attr in ResultSet::find - Add warnings for non-unique ResultSet::find queries - Changed Storage::DBI::Replication to Storage::DBI::Replicated and refactored support. - By default now deploy/diff et al. will ignore constraint and index names - Add ResultSet::_is_deterministic_value, make new_result filter the values passed to new to drop values that would generate invalid SQL. - Use Sub::Name to name closures before installing them. Fixes incompatibility with Moose method modifiers on generated methods. 0.08010 2008-03-01 10:30 - Fix t/94versioning.t so it passes with latest SQL::Translator 0.08009 2008-01-20 13:30 - Made search_rs smarter about when to preserve the cache to fix mm prefetch usage - Added Storage::DBI subclass for MSSQL over ODBC. - Added freeze, thaw and dclone methods to Schema so that thawed objects will get re-attached to the schema. - Moved dbicadmin to JSON::Any wrapped JSON.pm for a sane API (also fixes RT #32393) - introduced DBIx::Class::set_inflated_columns - DBIx::Class::Row::copy uses set_inflated_columns 0.08008 2007-11-16 14:30:00 - Fixed join merging bug (test from Zby) - When adding relationships, it will throw an exception if you get the foreign and self parts the wrong way round in the condition - ResultSetColumn::func() now returns all results if called in list context; this makes things like func('DISTINCT') work as expected - Many-to-many relationships now warn if the utility methods would clash - InflateColumn::DateTime now accepts an extra parameter of timezone to set timezone on the DT object (thanks Sergio Salvi) - Added sqlt_deploy_hook to result classes so that indexes can be added. - Added startup checks to warn loudly if we appear to be running on RedHat systems from perl-5.8.8-10 and up that have the bless/overload patch applied (badly) which causes 2x -> 100x performance penalty. (Jon Schutz) - ResultSource::reverse_relationship_info can distinguish between sources using the same table - Row::insert will now not fall over if passed duplicate related objects - Row::copy will not fall over if you have two relationships to the same source with a unique constraint on it 0.08007 2007-09-04 19:36:00 - patch for Oracle datetime inflation (abram@arin.net) - added on_disconnect_do - on_connect_do and on_disconnect_do take coderefs and arrayrefs 0.08006 2007-08-12 15:12:00 - Move to using Class::C3::Componentised - Remove warn statement from DBIx::Class::Row 0.08005 2007-08-06 - add timestamp fix re rt.cpan 26978 - no test yet but change clearly should cause no regressions - provide alias for related_resultset via local() so it's set correctly at resultset construction time (fixes RestrictWithObject) - fixes bind params in debug statements (original test from abraxxa) - fixed storage->connected fork bug (test and fix from Radu Greab) - add 1; to AccessorGroup.pm for stuff that still uses it - refactor Statistics to create debugging filehandle to fix bug with closed STDERR, update docs and modify Versioned to use Statistics (original fix from diz) 0.08004 2007-08-06 19:00:00 - fix storage connect code to not trigger bug via auto-viv (test from aherzog) - fixup cursor_class to be an 'inherited' attr for per-package defaults - add default_resultset_attributes entry to Schema - optimisation in DBI::Cursor to check software_limit before falling back to base Cursor->all - fix bug with create_multi not inserting non-storage objects (test and fix from davinchi) - DBIx::Class::AccessorGroup made empty subclass of Class::Accessor::Grouped - fixed an ugly bug regarding $dbh->{AutoCommit} and transactions - ensure_class_loaded handles non-classnames better. - non-destructive hashref handling for connect_info options - count no longer returns negative values after slice (report and test from JOHANL) - rebless before building datetime_parser (patch from mattlaw / Matt Lawrence) 0.08003 2007-07-14 18:01:00 - improved populate bulk_insert mode - fixed up multi_create to be more intelligent about PK<->PK rels - fix many-many rels to not use set_columns - Unmarked deploy as experimental since it isn't anymore - Removed Cwd dep since it's not required and causes problems with debian packaging - Patch to fix ? in data for NoBindVars (from Tom Hukins) - Restored mk_classaccessor method for compatibility - Fixed group_by problem with oracle limit syntax - Fixed attr merging problem - Fixed $rs->get_column w/prefetch problem 0.08002 2007-06-20 06:10:00 - add scope guard to Row::insert to ensure rollback gets called - more heuristics in Row::insert to try and get insert order right - eliminate vestigial code in PK::Auto - more expressive DBI errors - soften errors during deploy - ensure_connected before txn_begin to catch stomping on transaction depth - new method "rethrow" for our exception objects 0.08001 2007-06-17 21:21:02 - Cleaned up on_connect handling for versioned - removed DateTime use line from multi_create test - hid DBIx::ContextualFetch::st override in CDBICompat 0.08000 2007-06-17 18:06:12 - Fixed DBIC_TRACE debug filehandles to set ->autoflush(1) - Fixed circular dbh<->storage in HandleError with weakref 0.07999_06 2007-06-13 04:45:00 - tweaked Row.pm to make last_insert_id take multiple column names - Fixed DBIC::Storage::DBI::Cursor::DESTROY bug that was messing up exception handling - added exception objects to eliminate stacktrace/Carp::Clan output redundancy - setting $ENV{DBIC_TRACE} defaults stacktrace on. - added stacktrace option to Schema, makes throw_exception use "confess" - make database handles use throw_exception by default - make database handles supplied by a coderef use our standard HandleError/RaiseError/PrintError - add "unsafe" connect_info option to suppress our setting of HandleError/RaiseError/PrintError - removed several redundant evals whose sole purpose was to provide extra debugging info - fixed page-within-page bug (reported by nilsonsfj) - fixed rare bug when database is disconnected inbetween "$dbh->prepare_cached" and "$sth->execute" 0.07999_05 2007-06-07 23:00:00 - Made source_name rw in ResultSource - Fixed up SQL::Translator test/runtime dependencies - Fixed t/60core.t in the absence of DateTime::Format::MySQL - Test cleanup and doc note (ribasushi) 0.07999_04 2007-06-01 14:04:00 - pulled in Replication storage from branch and marked EXPERIMENTAL - fixup to ensure join always LEFT after first LEFT join depthwise - converted the vendor tests to use schema objects intead of schema classes, made cleaned more reliable with END blocks - versioning support via DBIx::Class::Schema::Versioned - find/next now return undef rather than () on fail from Bernhard Graf - rewritten collapse_result to fix prefetch - moved populate to resultset - added support for creation of related rows via insert and populate - transaction support more robust now in the face of varying AutoCommit and manual txn_begin usage - unbreak back-compat for Row/ResultSet->new_result - Added Oracle/WhereJoins.pm for Oracle >= 8 to support Oracle <= 9i, and provide Oracle with a better join method for later versions. (I use the term better loosely.) - The SQL::T parser class now respects a relationship attribute of is_foreign_key_constrain to allow explicit control over wether or not a foreign constraint is needed - resultset_class/result_class now (again) auto loads the specified class; requires Class::Accessor::Grouped 0.05002+ - added get_inflated_columns to Row - %colinfo accessor and inflate_column now work together - More documentation updates - Error messages from ->deploy made more informative - connect_info will now always return the arguments it was originally given - A few small efficiency improvements for load_classes and compose_namespace 0.07006 2007-04-17 23:18:00 - Lots of documentation updates - deploy now takes an optional 'source_names' parameter (dec) - Quoting for for columns_info_for - RT#25683 fixed (multiple open sths on DBD::Sybase) - CDBI compat infers has_many from has_a (Schwern) - Fix ddl_filename transformation (Carl Vincent) 0.07999_02 2007-01-25 20:11:00 - add support for binding BYTEA and similar parameters (w/Pg impl) - add support to Ordered for multiple ordering columns - mark DB.pm and compose_connection as deprecated - switch tests to compose_namespace - ResultClass::HashRefInflator added - Changed row and rs objects to not have direct handle to a source, instead a (schema,source_name) tuple of type ResultSourceHandle 0.07005 2007-01-10 18:36:00 - fixup changes file - remove erroneous .orig files - oops 0.07004 2007-01-09 21:52:00 - fix find_related-based queries to correctly grep the unique key - fix InflateColumn to inflate/deflate all refs but scalar refs 0.07003 2006-11-16 11:52:00 - fix for rt.cpan.org #22740 (use $^X instead of hardcoded "perl") - Tweaks to resultset to allow inflate_result to return an array - Fix UTF8Columns to work under Perl <= 5.8.0 - Fix up new_result in ResultSet to avoid alias-related bugs - Made new/update/find handle 'single' rel accessor correctly - Fix NoBindVars to be safer and handle non-true bind values - Don't blow up if columns_info_for returns useless results - Documentation updates 0.07999_01 2006-10-05 21:00:00 - add connect_info option "disable_statement_caching" - create insert_bulk using execute_array, populate uses it - added DBIx::Class::Schema::load_namespaces, alternative to load_classes - added source_info method for source-level metadata (kinda like column_info) - Some of ::Storage::DBI's code/docs moved to ::Storage - DBIx::Class::Schema::txn_do code moved to ::Storage - Storage::DBI now uses exceptions instead of ->ping/->{Active} checks - Storage exceptions are thrown via the schema class's throw_exception - DBIx::Class::Schema::throw_exception's behavior can be modified via ->exception_action - columns_info_for is deprecated, and no longer runs automatically. You can make it work like before via __PACKAGE__->column_info_from_storage(1) for now - Replaced DBIx::Class::AccessorGroup and Class::Data::Accessor with Class::Accessor::Grouped. Only user noticible change is to table_class on ResultSourceProxy::Table (i.e. table objects in schemas) and, resultset_class and result_class in ResultSource. These accessors no longer automatically require the classes when set. 0.07002 2006-09-14 21:17:32 - fix quote tests for recent versions of SQLite - added reference implementation of Manual::Example - backported column_info_from_storage accessor from -current, but - fixed inflate_datetime.t tests/stringify under older Test::More - minor fixes for many-to-many relationship helpers - cleared up Relationship docs, and fixed some typos - use ref instead of eval to check limit syntax (to avoid issues with Devel::StackTrace) - update ResultSet::_cond_for_update_delete to handle more complicated queries - bugfix to Oracle columns_info_for - remove_columns now deletes columns from _columns 0.07001 2006-08-18 19:55:00 - add directory argument to deploy() - support default aliases in many_to_many accessors. - support for relationship attributes in many_to_many accessors. - stop search_rs being destructive to attrs - better error reporting when loading components - UTF8Columns changed to use "utf8" instead of "Encode" - restore automatic aliasing in ResultSet::find() on nonunique queries - allow aliases in ResultSet::find() queries (in cases of relationships with prefetch) - pass $attrs to find from update_or_create so a specific key can be provided - remove anonymous blesses to avoid major speed hit on Fedora Core 5's Perl and possibly others; for more information see: https://bugzilla.redhat.com/bugzilla/show_bug.cgi?id=196836 - fix a pathological prefetch case - table case fix for Oracle in columns_info_for - stopped search_rs deleting attributes from passed hash 0.07000 2006-07-23 02:30:00 - supress warnings for possibly non-unique queries, since _is_unique_query doesn't infer properly in all cases - skip empty queries to eliminate spurious warnings on ->deploy - fixups to ORDER BY, tweaks to deepen some copies in ResultSet - fixup for RowNum limit syntax with functions 0.06999_07 2006-07-12 20:58:05 - fix issue with from attr copying introduced in last release 0.06999_06 2006-07-12 17:16:55 - documentation for new storage options, fix S::A::L hanging on to $dbh - substantial refactor of search_related code to fix alias numbering - don't generate partial unique keys in ResultSet::find() when a table has more than one unique constraint which share a column and only one is satisfied - cleanup UTF8Columns and make more efficient - rename DBIX_CLASS_STORAGE_DBI_DEBUG to DBIC_TRACE (with compat) - rename _parent_rs to _parent_source in ResultSet - new FAQ.pod! 0.06999_05 2006-07-04 14:40:01 - fix issue with incorrect $rs->{attrs}{alias} - fix subclassing issue with source_name - tweak quotes test to output text on failure - fix Schema->txn_do to not fail as a classmethod 0.06999_04 2006-06-29 20:18:47 - disable cdbi-t/02-Film.t warning tests under AS perl - fixups to MySQL tests (aka "work round mysql being retarded") - compat tweaks for Storage debug logging 0.06999_03 2006-06-26 21:04:44 - various documentation improvements - fixes to pass test suite on Windows - rewrote and cleaned up SQL::Translator tests - changed relationship helpers to only call ensure_class_loaded when the join condition is inferred - rewrote many_to_many implementation, now provides helpers for adding and deleting objects without dealing with the link table - reworked InflateColumn implementation to lazily deflate where possible; now handles passing an inflated object to new() - changed join merging to not create a rel_2 alias when adding a join that already exists in a parent resultset - Storage::DBI::deployment_statements now calls ensure_connected if it isn't passed a type - fixed Componentized::ensure_class_loaded - InflateColumn::DateTime supports date as well as datetime - split Storage::DBI::MSSQL into MSSQL and Sybase::MSSQL - fixed wrong debugging hook call in Storage::DBI - set connect_info properly before setting any ->sql_maker things 0.06999_02 2006-06-09 23:58:33 - Fixed up POD::Coverage tests, filled in some POD holes - Added a warning for incorrect component order in load_components - Fixed resultset bugs to do with related searches - added code and tests for Componentized::ensure_class_found and load_optional_class - NoBindVars + Sybase + MSSQL stuff - only rebless S::DBI if it is still S::DBI and not a subclass - Added `use' statement for DBD::Pg in Storage::DBI::Pg - stopped test relying on order of unordered search - bugfix for join-types in nested joins using the from attribute - obscure prefetch problem fixed - tightened up deep search_related - Fixed 'DBIx/Class/DB.pm did not return a true value' error - Revert change to test for deprecated find usage and swallow warnings - Slight wording change to new_related() POD - new specific test for connect_info coderefs - POD clarification and content bugfixing + a few code formatting fixes - POD::Coverage additions - fixed debugfh - Fix column_info stomping 0.06999_01 2006-05-28 17:19:30 - add automatic naming of unique constraints - marked DB.pm as deprecated and noted it will be removed by 1.0 - add ResultSetColumn - refactor ResultSet code to resolve attrs as late as possible - merge prefetch attrs into join attrs - add +select and +as attributes to ResultSet - added InflateColumn::DateTime component - refactor debugging to allow for profiling using Storage::Statistics - removed Data::UUID from deps, made other optionals required - modified SQLT parser to skip dupe table names - added remove_column(s) to ResultSource/ResultSourceProxy - added add_column alias to ResultSourceProxy - added source_name to ResultSource - load_classes now uses source_name and sets it if necessary - add update_or_create_related to Relationship::Base - add find_or_new to ResultSet/ResultSetProxy and find_or_new_related to Relationship::Base - add accessors for unique constraint names and coulums to ResultSource/ResultSourceProxy - rework ResultSet::find() to search unique constraints - CDBICompat: modify retrieve to fix column casing when ColumnCase is loaded - CDBICompat: override find_or_create to fix column casing when ColumnCase is loaded - reorganized and simplified tests - added Ordered - added the ability to set on_connect_do and the various sql_maker options as part of Storage::DBI's connect_info. 0.06003 2006-05-19 15:37:30 - make find_or_create_related check defined() instead of truth - don't unnecessarily fetch rels for cascade_update - don't set_columns explicitly in update_or_create; instead use update($hashref) so InflateColumn works - fix for has_many prefetch with 0 related rows - make limit error if rows => 0 - added memory cycle tests and a long-needed weaken call 0.06002 2006-04-20 00:42:41 - fix set_from_related to accept undef - fix to Dumper-induced hash iteration bug - fix to copy() with non-composed resultsource - fix to ->search without args to clone rs but maintain cache - grab $self->dbh once per function in Storage::DBI - nuke ResultSource caching of ->resultset for consistency reasons - fix for -and conditions when updating or deleting on a ResultSet 0.06001 - Added fix for quoting with single table - Substantial fixes and improvements to deploy - slice now uses search directly - fixes for update() on resultset - bugfix to Cursor to avoid error during DESTROY - transaction DBI operations now in debug trace output 0.06000 2006-03-25 18:03:46 - Lots of documentation improvements - Minor tweak to related_resultset to prevent it storing a searched rs - Fixup to columns_info_for when database returns type(size) - Made do_txn respect void context (on the off-chance somebody cares) - Fix exception text for nonexistent key in ResultSet::find() 0.05999_04 2006-03-18 19:20:49 - Fix for delete on full-table resultsets - Removed caching on count() and added _count for pager() - ->connection does nothing if ->storage defined and no args (and hence ->connect acts like ->clone under the same conditions) - Storage::DBI throws better exception if no connect info - columns_info_for made more robust / informative - ithreads compat added, fork compat improved - weaken result_source in all resultsets - Make pg seq extractor less sensitive. 0.05999_03 2006-03-14 01:58:10 - has_many prefetch fixes - deploy now adds drop statements before creates - deploy outputs debugging statements if DBIX_CLASS_STORAGE_DBI_DEBUG is set 0.05999_02 2006-03-10 13:31:37 - remove test dep on YAML - additional speed tweaks for C3 - allow scalarefs passed to order_by to go straight through to SQL - renamed insert_or_update to update_or_insert (with compat alias) - hidden lots of packages from the PAUSE Indexer 0.05999_01 2006-03-09 18:31:44 - renamed cols attribute to columns (cols still supported) - added has_column_loaded to Row - Storage::DBI connect_info supports coderef returning dbh as 1st arg - load_components() doesn't prepend base when comp. prefixed with + - $schema->deploy - HAVING support - prefetch for has_many - cache attr for resultsets - PK::Auto::* no longer required since Storage::DBI::* handle auto-inc - minor tweak to tests for join edge case - added cascade_copy relationship attribute (sponsored by Airspace Software, http://www.airspace.co.uk/) - clean up set_from_related - made copy() automatically null out auto-inc columns - added txn_do() method to Schema, which allows a coderef to be executed atomically 0.05007 2006-02-24 00:59:00 - tweak to Componentised for Class::C3 0.11 - fixes for auto-inc under MSSQL 0.05006 2006-02-17 15:32:40 - storage fix for fork() and workaround for Apache::DBI - made update(\%hash) work on row as well as rs - another fix for count with scalar group_by - remove dependency on Module::Find in 40resultsetmanager.t (RT #17598) 0.05005 2006-02-13 21:24:51 - remove build dependency on version.pm 0.05004 2006-02-13 20:59:00 - allow specification of related columns via cols attr when primary keys of the related table are not fetched - fix count for group_by as scalar - add horrific fix to make Oracle's retarded limit syntax work - remove Carp require - changed UUIDColumns to use new UUIDMaker classes for uuid creation using whatever module may be available 0.05003 2006-02-08 17:50:20 - add component_class accessors and use them for *_class - small fixes to Serialize and ResultSetManager - rollback on disconnect, and disconnect on DESTROY 0.05002 2006-02-06 12:12:03 - Added recommends for Class::Inspector - Added skip_all to t/40resultsetmanager.t if no Class::Inspector available 0.05001 2006-02-05 15:28:10 - debug output now prints NULL for undef params - multi-step prefetch along the same rel (e.g. for trees) now works - added multi-join (join => [ 'foo', 'foo' ]), aliases second to foo_2 - hack PK::Auto::Pg for "table" names referencing a schema - find() with attributes works - added experimental Serialize and ResultSetManager components - added code attribute recording to DBIx::Class - fix to find() for complex resultsets - added of $storage->debugcb(sub { ... }) - added $source->resultset_attributes accessor - added include_columns rs attr 0.05000 2006-02-01 16:48:30 - assorted doc fixes - remove ObjectCache, not yet working in 0.05 - let many_to_many rels have attrs - fix ID method in PK.pm to be saner for new internals - fix t/30dbicplain.t to use ::Schema instead of Catalyst::Model::DBIC::Plain 0.04999_06 2006-01-28 21:20:32 - fix Storage/DBI (tried to load deprecated ::Exception component) 0.04999_05 2006-01-28 20:13:52 - count will now work for grouped resultsets - added accessor => option to column_info to specify accessor name - added $schema->populate to load test data (similar to AR fixtures) - removed cdbi-t dependencies, only run tests if installed - Removed DBIx::Class::Exception - unified throw_exception stuff, using Carp::Clan - report query when sth generation fails. - multi-step prefetch! - inheritance fixes - test tweaks 0.04999_04 2006-01-24 21:48:21 - more documentation improvements - add columns_info_for for vendor-specific column info (Zbigniew Lukasiak) - add SQL::Translator::Producer for DBIx::Class table classes (Jess Robinson) - add unique constraint declaration (Daniel Westermann-Clark) - add new update_or_create method (Daniel Westermann-Clark) - rename ResultSetInstance class to ResultSetProxy, ResultSourceInstance to ResultSourceProxy, and TableInstance to ResultSourceProxy::Table - minor fixes to UUIDColumns - add debugfh method and ENV magic for tracing SQL (Nigel Metheringham) 0.04999_03 2006-01-20 06:05:27 - imported Jess Robinson's SQL::Translator::Parser::DBIx::Class - lots of internals cleanup to eliminate result_source_instance requirement - added register_column and register_relationship class APIs - made Storage::DBI use prepare_cached safely (thanks to Tim Bunce) - many documentation improvements (thanks guys!) - added ->connection, ->connect, ->register_source and ->clone schema methods - Use croak instead of die for user errors. 0.04999_02 2006-01-14 07:17:35 - Schema is now self-contained; no requirement for co-operation - add_relationship, relationships, relationship_info, has_relationship - relationship handling on ResultSource - all table handling now in Table.pm / ResultSource.pm - added GROUP BY and DISTINCT support - hacked around SQL::Abstract::Limit some more in DBIC::SQL::Abstract (this may have fixed complex quoting) - moved inflation to inflate_result in Row.pm - added $rs->search_related - split compose_namespace out of compose_connection in Schema - ResultSet now handles find - various *_related methods are now ->search_related->* - added new_result to ResultSet 0.04999_01 2005-12-27 03:33:42 - search and related methods moved to ResultSet - select and as added to ResultSet attrs - added DBIx::Class::Table and TableInstance for table-per-class - added DBIx::Class::ResultSetInstance which handles proxying search etc. as a superclass of DBIx::Class::DB - assorted test and code cleanup work 0.04001 2005-12-13 22:00:00 - Fix so set_inflated_column calls set_column - Syntax errors in relationship classes are now reported - Better error detection in set_primary_key and columns methods - Documentation improvements - Better transaction support with txn_* methods - belongs_to now works when $cond is a string - PK::Auto::Pg updated, only tries primary keys instead of all cols 0.04 2005-11-26 - Moved get_simple and set_simple into AccessorGroup - Made 'new' die if given invalid columns - Added has_column and column_info to Table.pm - Refactored away from direct use of _columns and _primaries - Switched from NEXT to Class::C3 0.03004 - Added an || '' to the CDBICompat stringify to avoid null warnings - Updated name section for manual pods 0.03003 2005-11-03 17:00:00 - POD fixes. - Changed use to require in Relationship/Base to avoid import. 0.03002 2005-10-20 22:35:00 - Minor bugfix to new (Row.pm) - Schema doesn't die if it can't load a class (Schema.pm) - New UUID columns plugin (UUIDColumns.pm) - Documentation improvements. 0.03001 2005-09-23 14:00:00 - Fixes to relationship helpers - IMPORTANT: prefetch/schema combination bug fix 0.03 2005-09-19 19:35:00 - Paging support - Join support on search - Prefetch support on search 0.02 2005-08-12 18:00:00 - Test fixes. - Performance improvements. - Oracle primary key support. - MS-SQL primary key support. - SQL::Abstract::Limit integration for database-agnostic limiting. 0.01 2005-08-08 17:10:00 - initial release �������������������������������������������������������������������������������������������������DBIx-Class-0.082843/README��������������������������������������������������������������������������0000444�0001750�0001750�00000046103�14240676412�013773� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx::Class is Copyright (c) 2005-2022 by mst, castaway, ribasushi, and others. See AUTHORS and LICENSE included with this distribution. All rights reserved. NAME DBIx::Class - Extensible and flexible object <-> relational mapper. WHERE TO START READING See DBIx::Class::Manual::DocMap for an overview of the exhaustive documentation. To get the most out of DBIx::Class with the least confusion it is strongly recommended to read (at the very least) the Manuals in the order presented there. GETTING HELP/SUPPORT Due to the sheer size of its problem domain, DBIx::Class is a relatively complex framework. After you start using DBIx::Class questions will inevitably arise. If you are stuck with a problem or have doubts about a particular approach do not hesitate to contact us via any of the following options (the list is sorted by "fastest response time"): * RT Bug Tracker: <https://rt.cpan.org/Public/Dist/Display.html?Name=DBIx-Class> * Email: <mailto:bug-DBIx-Class@rt.cpan.org> * Twitter: <https://twitter.com/intent/tweet?text=%40ribasushi%20%23DBIC> SYNOPSIS For the very impatient: DBIx::Class::Manual::QuickStart This code in the next step can be generated automatically from an existing database, see dbicdump from the distribution "DBIx-Class-Schema-Loader". Schema classes preparation Create a schema class called MyApp/Schema.pm: package MyApp::Schema; use base qw/DBIx::Class::Schema/; __PACKAGE__->load_namespaces(); 1; Create a result class to represent artists, who have many CDs, in MyApp/Schema/Result/Artist.pm: See DBIx::Class::ResultSource for docs on defining result classes. package MyApp::Schema::Result::Artist; use base qw/DBIx::Class::Core/; __PACKAGE__->table('artist'); __PACKAGE__->add_columns(qw/ artistid name /); __PACKAGE__->set_primary_key('artistid'); __PACKAGE__->has_many(cds => 'MyApp::Schema::Result::CD', 'artistid'); 1; A result class to represent a CD, which belongs to an artist, in MyApp/Schema/Result/CD.pm: package MyApp::Schema::Result::CD; use base qw/DBIx::Class::Core/; __PACKAGE__->load_components(qw/InflateColumn::DateTime/); __PACKAGE__->table('cd'); __PACKAGE__->add_columns(qw/ cdid artistid title year /); __PACKAGE__->set_primary_key('cdid'); __PACKAGE__->belongs_to(artist => 'MyApp::Schema::Result::Artist', 'artistid'); 1; API usage Then you can use these classes in your application's code: # Connect to your database. use MyApp::Schema; my $schema = MyApp::Schema->connect($dbi_dsn, $user, $pass, \%dbi_params); # Query for all artists and put them in an array, # or retrieve them as a result set object. # $schema->resultset returns a DBIx::Class::ResultSet my @all_artists = $schema->resultset('Artist')->all; my $all_artists_rs = $schema->resultset('Artist'); # Output all artists names # $artist here is a DBIx::Class::Row, which has accessors # for all its columns. Rows are also subclasses of your Result class. foreach $artist (@all_artists) { print $artist->name, "\n"; } # Create a result set to search for artists. # This does not query the DB. my $johns_rs = $schema->resultset('Artist')->search( # Build your WHERE using an SQL::Abstract::Classic-compatible structure: { name => { like => 'John%' } } ); # Execute a joined query to get the cds. my @all_john_cds = $johns_rs->search_related('cds')->all; # Fetch the next available row. my $first_john = $johns_rs->next; # Specify ORDER BY on the query. my $first_john_cds_by_title_rs = $first_john->cds( undef, { order_by => 'title' } ); # Create a result set that will fetch the artist data # at the same time as it fetches CDs, using only one query. my $millennium_cds_rs = $schema->resultset('CD')->search( { year => 2000 }, { prefetch => 'artist' } ); my $cd = $millennium_cds_rs->next; # SELECT ... FROM cds JOIN artists ... my $cd_artist_name = $cd->artist->name; # Already has the data so no 2nd query # new() makes a Result object but doesn't insert it into the DB. # create() is the same as new() then insert(). my $new_cd = $schema->resultset('CD')->new({ title => 'Spoon' }); $new_cd->artist($cd->artist); $new_cd->insert; # Auto-increment primary key filled in after INSERT $new_cd->title('Fork'); $schema->txn_do(sub { $new_cd->update }); # Runs the update in a transaction # change the year of all the millennium CDs at once $millennium_cds_rs->update({ year => 2002 }); DESCRIPTION This is an SQL to OO mapper with an object API inspired by Class::DBI (with a compatibility layer as a springboard for porting) and a resultset API that allows abstract encapsulation of database operations. It aims to make representing queries in your code as perl-ish as possible while still providing access to as many of the capabilities of the database as possible, including retrieving related records from multiple tables in a single query, "JOIN", "LEFT JOIN", "COUNT", "DISTINCT", "GROUP BY", "ORDER BY" and "HAVING" support. DBIx::Class can handle multi-column primary and foreign keys, complex queries and database-level paging, and does its best to only query the database in order to return something you've directly asked for. If a resultset is used as an iterator it only fetches rows off the statement handle as requested in order to minimise memory usage. It has auto-increment support for SQLite, MySQL, PostgreSQL, Oracle, SQL Server and DB2 and is known to be used in production on at least the first four, and is fork- and thread-safe out of the box (although your DBD may not be). This project is still under rapid development, so large new features may be marked experimental - such APIs are still usable but may have edge bugs. Failing test cases are *always* welcome and point releases are put out rapidly as bugs are found and fixed. We do our best to maintain full backwards compatibility for published APIs, since DBIx::Class is used in production in many organisations, and even backwards incompatible changes to non-published APIs will be fixed if they're reported and doing so doesn't cost the codebase anything. The test suite is quite substantial, and several developer releases are generally made to CPAN before the branch for the next release is merged back to trunk for a major release. HOW TO CONTRIBUTE Contributions are always welcome, in all usable forms (we especially welcome documentation improvements). The delivery methods include git- or unified-diff formatted patches, GitHub pull requests, or plain bug reports either via RT or the Mailing list. Do not hesitate to get in touch with any further questions you may have. This project is maintained in a git repository. The code and related tools are accessible at the following locations: * Current git repository: <https://github.com/Perl5/DBIx-Class> * Travis-CI log: <https://travis-ci.com/github/Perl5/DBIx-Class/branches> AUTHORS Even though a large portion of the source *appears* to be written by just a handful of people, this library continues to remain a collaborative effort - perhaps one of the most successful such projects on CPAN <http://cpan.org>. It is important to remember that ideas do not always result in a direct code contribution, but deserve acknowledgement just the same. Time and time again the seemingly most insignificant questions and suggestions have been shown to catalyze monumental improvements in consistency, accuracy and performance. List of the awesome contributors who made DBIC v0.082843 possible abraxxa: Alexander Hartmaier <abraxxa@cpan.org> acca: Alexander Kuznetsov <acca@cpan.org> acme: Leon Brocard <acme@astray.com> aherzog: Adam Herzog <adam@herzogdesigns.com> Alexander Keusch <cpan@keusch.at> alexrj: Alessandro Ranellucci <aar@cpan.org> alnewkirk: Al Newkirk <github@alnewkirk.com> Altreus: Alastair McGowan-Douglas <alastair.mcgowan@opusvl.com> amiri: Amiri Barksdale <amiribarksdale@gmail.com> amoore: Andrew Moore <amoore@cpan.org> Andrew Mehta <Andrew@unitedgames.co.uk> andrewalker: Andre Walker <andre@andrewalker.net> andyg: Andy Grundman <andy@hybridized.org> ank: Andres Kievsky <ank@ank.com.ar> arc: Aaron Crane <arc@cpan.org> arcanez: Justin Hunter <justin.d.hunter@gmail.com> ash: Ash Berlin <ash@cpan.org> bert: Norbert Csongrádi <bert@cpan.org> bfwg: Colin Newell <colin.newell@gmail.com> blblack: Brandon L. Black <blblack@gmail.com> bluefeet: Aran Deltac <bluefeet@cpan.org> boghead: Bryan Beeley <cpan@beeley.org> bphillips: Brian Phillips <bphillips@cpan.org> brd: Brad Davis <brd@FreeBSD.org> Brian Kirkbride <brian.kirkbride@deeperbydesign.com> bricas: Brian Cassidy <bricas@cpan.org> brunov: Bruno Vecchi <vecchi.b@gmail.com> caelum: Rafael Kitover <rkitover@cpan.org> caldrin: Maik Hentsche <maik.hentsche@amd.com> castaway: Jess Robinson <castaway@desert-island.me.uk> chorny: Alexandr Ciornii <alexchorny@gmail.com> cj: C.J. Adams-Collier <cjcollier@cpan.org> claco: Christopher H. Laco <claco@cpan.org> clkao: CL Kao <clkao@clkao.org> Ctrl-O <http://ctrlo.com/> da5id: David Jack Olrik <david@olrik.dk> dams: Damien Krotkine <dams@cpan.org> dandv: Dan Dascalescu <ddascalescu+github@gmail.com> dariusj: Darius Jokilehto <dariusjokilehto@yahoo.co.uk> davewood: David Schmidt <mail@davidschmidt.at> daxim: Lars Dɪᴇᴄᴋᴏᴡ 迪拉斯 <daxim@cpan.org> dduncan: Darren Duncan <darren@darrenduncan.net> debolaz: Anders Nor Berle <berle@cpan.org> dew: Dan Thomas <dan@godders.org> dim0xff: Dmitry Latin <dim0xff@gmail.com> dkubb: Dan Kubb <dan.kubb-cpan@onautopilot.com> dnm: Justin Wheeler <jwheeler@datademons.com> dpetrov: Dimitar Petrov <mitakaa@gmail.com> Dr^ZigMan: Robert Stone <drzigman@drzigman.com> dsteinbrunner: David Steinbrunner <dsteinbrunner@pobox.com> duncan_dmg: Duncan Garland <Duncan.Garland@motortrak.com> dwc: Daniel Westermann-Clark <danieltwc@cpan.org> dyfrgi: Michael Leuchtenburg <michael@slashhome.org> edenc: Eden Cardim <edencardim@gmail.com> Eligo <http://eligo.co.uk/> ether: Karen Etheridge <ether@cpan.org> evdb: Edmund von der Burg <evdb@ecclestoad.co.uk> faxm0dem: Fabien Wernli <cpan@faxm0dem.org> felliott: Fitz Elliott <fitz.elliott@gmail.com> fgabolde: Fabrice Gabolde <fgabolde@weborama.com> freetime: Bill Moseley <moseley@hank.org> frew: Arthur Axel "fREW" Schmidt <frioux@gmail.com> gbjk: Gareth Kirwan <gbjk@thermeon.com> geotheve: Georgina Thevenet <geotheve@gmail.com> Getty: Torsten Raudssus <torsten@raudss.us> goraxe: Gordon Irving <goraxe@cpan.org> gphat: Cory G Watson <gphat@cpan.org> Grant Street Group <http://www.grantstreet.com/> gregoa: Gregor Herrmann <gregoa@debian.org> groditi: Guillermo Roditi <groditi@cpan.org> gshank: Gerda Shank <gshank@cpan.org> guacamole: Fred Steinberg <fred.steinberg@gmail.com> Haarg: Graham Knop <haarg@haarg.org> hobbs: Andrew Rodland <andrew@cleverdomain.org> Ian Wells <ijw@cack.org.uk> idn: Ian Norton <i.norton@shadowcat.co.uk> ilmari: Dagfinn Ilmari Mannsåker <ilmari@ilmari.org> ingy: Ingy döt Net <ingy@ingy.net> initself: Mike Baas <mike@initselftech.com> ironcamel: Naveed Massjouni <naveedm9@gmail.com> jasonmay: Jason May <jason.a.may@gmail.com> jawnsy: Jonathan Yu <jawnsy@cpan.org> jegade: Jens Gassmann <jens.gassmann@atomix.de> jeneric: Eric A. Miller <emiller@cpan.org> jesper: Jesper Krogh <jesper@krogh.cc> Jesse Sheidlower <jester@panix.com> jgoulah: John Goulah <jgoulah@cpan.org> jguenther: Justin Guenther <jguenther@cpan.org> jhannah: Jay Hannah <jay@jays.net> jmac: Jason McIntosh <jmac@appleseed-sc.com> jmmills: Jason M. Mills <jmmills@cpan.org> jnapiorkowski: John Napiorkowski <jjn1056@yahoo.com> Joe Carlson <jwcarlson@lbl.gov> jon: Jon Schutz <jjschutz@cpan.org> Jordan Metzmeier <jmetzmeier@magazines.com> jshirley: J. Shirley <jshirley@gmail.com> kaare: Kaare Rasmussen kd: Kieren Diment <diment@gmail.com> kentnl: Kent Fredric <kentnl@cpan.org> kkane: Kevin L. Kane <kevin.kane@gmail.com> konobi: Scott McWhirter <konobi@cpan.org> lejeunerenard: Sean Zellmer <sean@lejeunerenard.com> leont: Leon Timmermans <fawaka@gmail.com> littlesavage: Alexey Illarionov <littlesavage@orionet.ru> lukes: Luke Saunders <luke.saunders@gmail.com> marcus: Marcus Ramberg <mramberg@cpan.org> mateu: Mateu X. Hunter <hunter@missoula.org> Matt LeBlanc <antirice@gmail.com> Matt Sickler <imMute@msk4.com> mattlaw: Matt Lawrence mattp: Matt Phillips <mattp@cpan.org> mdk: Mark Keating <m.keating@shadowcat.co.uk> melo: Pedro Melo <melo@simplicidade.org> metaperl: Terrence Brannon <metaperl@gmail.com> michaelr: Michael Reddick <michael.reddick@gmail.com> milki: Jonathan Chu <milki@rescomp.berkeley.edu> minty: Murray Walker <perl@minty.org> mithaldu: Christian Walde <walde.christian@gmail.com> mjemmeson: Michael Jemmeson <michael.jemmeson@gmail.com> mna: Maya mo: Moritz Onken <onken@netcubed.de> moltar: Roman Filippov <romanf@cpan.org> moritz: Moritz Lenz <moritz@faui2k3.org> mrf: Mike Francis <ungrim97@gmail.com> mst: Matt S. Trout <mst@shadowcat.co.uk> mstratman: Mark A. Stratman <stratman@gmail.com> ned: Neil de Carteret <n3dst4@gmail.com> nigel: Nigel Metheringham <nigelm@cpan.org> ningu: David Kamholz <dkamholz@cpan.org> Nniuq: Ron "Quinn" Straight" <quinnfazigu@gmail.org> norbi: Norbert Buchmuller <norbi@nix.hu> nothingmuch: Yuval Kogman <nothingmuch@woobling.org> nuba: Nuba Princigalli <nuba@cpan.org> Numa: Dan Sully <daniel@cpan.org> oalders: Olaf Alders <olaf@wundersolutions.com> Olly Betts <olly@survex.com> osfameron: Hakim Cassimally <osfameron@cpan.org> ovid: Curtis "Ovid" Poe <ovid@cpan.org> oyse: Øystein Torget <oystein.torget@dnv.com> paulm: Paul Makepeace <paulm+pause@paulm.com> penguin: K J Cheetham <jamie@shadowcatsystems.co.uk> perigrin: Chris Prather <chris@prather.org> Peter Siklósi <einon@einon.hu> Peter Valdemar Mørch <peter@morch.com> peter: Peter Collingbourne <peter@pcc.me.uk> phaylon: Robert Sedlacek <phaylon@dunkelheit.at> plu: Johannes Plunien <plu@cpan.org> pmooney: Paul Mooney <paul.mooney@net-a-porter.com> Possum: Daniel LeWarne <possum@cpan.org> pplu: Jose Luis Martinez <jlmartinez@capside.com> quicksilver: Jules Bean <jules@jellybean.co.uk> racke: Stefan Hornburg <racke@linuxia.de> rafl: Florian Ragwitz <rafl@debian.org> rainboxx: Matthias Dietrich <perl@rb.ly> rbo: Robert Bohne <rbo@cpan.org> rbuels: Robert Buels <rmb32@cornell.edu> rdj: Ryan D Johnson <ryan@innerfence.com> Relequestual: Ben Hutton <relequestual@gmail.com> renormalist: Steffen Schwigon <schwigon@cpan.org> ribasushi: Peter Rabbitson <ribasushi@leporine.io> rjbs: Ricardo Signes <rjbs@cpan.org> Robert Krimen <rkrimen@cpan.org> Robert Olson <bob@rdolson.org> robkinyon: Rob Kinyon <rkinyon@cpan.org> Roman Ardern-Corris <spam_in@3legs.com> ruoso: Daniel Ruoso <daniel@ruoso.com> Sadrak: Felix Antonius Wilhelm Ostmann <sadrak@cpan.org> sc_: Just Another Perl Hacker schwern: Michael G Schwern <mschwern@cpan.org> Scott R. Godin <webdragon.net@gmail.com> scotty: Scotty Allen <scotty@scottyallen.com> semifor: Marc Mims <marc@questright.com> Simon Elliott <cpan@browsing.co.uk> SineSwiper: Brendan Byrd <perl@resonatorsoft.org> skaufman: Samuel Kaufman <sam@socialflow.com> solomon: Jared Johnson <jaredj@nmgi.com> spb: Stephen Bennett <stephen@freenode.net> Squeeks <squeek@cpan.org> srezic: Slaven Rezic <slaven@rezic.de> sszabo: Stephan Szabo <sszabo@bigpanda.com> Stephen Peters <steve@stephenpeters.me> stonecolddevin: Devin Austin <dhoss@cpan.org> talexb: Alex Beamish <talexb@gmail.com> tamias: Ronald J Kimball <rjk@tamias.net> TBSliver: Tom Bloor <t.bloor@shadowcat.co.uk> teejay: Aaron Trevena <teejay@cpan.org> theorbtwo: James Mastros <james@mastros.biz> Thomas Kratz <tomk@cpan.org> timbunce: Tim Bunce <tim.bunce@pobox.com> tinita: Tina Mueller <cpan2@tinita.de> Todd Lipcon Tom Hukins <tom@eborcom.com> tommy: Tommy Butler <tbutler.cpan.org@internetalias.net> tonvoon: Ton Voon <ton.voon@opsview.com> triode: Pete Gamache <gamache@cpan.org> typester: Daisuke Murase <typester@cpan.org> uree: Oriol Soriano <oriol.soriano@capside.com> uwe: Uwe Voelker <uwe@uwevoelker.de> vanstyn: Henry Van Styn <vanstyn@cpan.org> victori: Victor Igumnov <victori@cpan.org> wdh: Will Hawes <wdhawes@gmail.com> wesm: Wes Malone <wes@mitsi.com> willert: Sebastian Willert <willert@cpan.org> wintermute: Toby Corkindale <tjc@cpan.org> wreis: Wallace Reis <wreis@cpan.org> x86-64 <x86mail@gmail.com> xenoterracide: Caleb Cushing <xenoterracide@gmail.com> xmikew: Mike Wisener <xmikew@32ths.com> yrlnry: Mark Jason Dominus <mjd@plover.com> zamolxes: Bogdan Lucaciu <bogdan@wiz.ro> Zefram: Andrew Main <zefram@fysh.org> The canonical source of authors and their details is the AUTHORS file at the root of this distribution (or repository). The canonical source of per-line authorship is the git repository history itself. COPYRIGHT AND LICENSE Copyright (c) 2005 by mst, castaway, ribasushi, and other DBIx::Class "AUTHORS" as listed above and in AUTHORS. This library is free software and may be distributed under the same terms as perl5 itself. See LICENSE for the complete licensing terms. �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/META.yml������������������������������������������������������������������������0000644�0001750�0001750�00000027624�14240676407�014401� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������--- abstract: 'Extensible and flexible object <-> relational mapper.' author: - 'mst: Matt S Trout <mst@shadowcat.co.uk> (project founder - original idea, architecture and implementation)' - 'castaway: Jess Robinson <castaway@desert-island.me.uk> (lions share of the reference documentation and manuals)' - 'ribasushi: Peter Rabbitson <ribasushi@leporine.io> (present day maintenance and controlled evolution)' build_requires: DBD::SQLite: 1.29 File::Temp: 0.22 Package::Stash: 0.28 Test::Deep: 0.101 Test::Exception: 0.31 Test::More: 0.94 Test::Warn: 0.21 configure_requires: ExtUtils::MakeMaker: 6.59 distribution_type: module dynamic_config: 0 generated_by: 'Module::Install version 1.19' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: DBIx-Class no_index: directory: - examples - inc - lib/DBIx/Class/Admin - lib/DBIx/Class/CDBICompat - lib/DBIx/Class/PK/Auto - maint - t - xt package: - DBIx::Class::Storage::DBIHacks - DBIx::Class::Storage::BlockRunner - DBIx::Class::Carp - DBIx::Class::_Util requires: Class::Accessor::Grouped: 0.10012 Class::C3::Componentised: 1.0009 Class::Inspector: 1.24 Config::Any: 0.20 Context::Preserve: 0.01 DBI: 1.57 Data::Dumper::Concise: 2.020 Devel::GlobalDestruction: 0.09 Hash::Merge: 0.12 MRO::Compat: 0.12 Module::Find: 0.07 Moo: 2.000 Path::Class: 0.18 SQL::Abstract::Classic: 1.91 Scope::Guard: 0.03 Sub::Name: 0.04 Text::Balanced: 2.00 Try::Tiny: 0.07 namespace::clean: 0.24 perl: 5.8.1 resources: bugtracker: https://rt.cpan.org/Public/Dist/Display.html?Name=DBIx-Class license: http://dev.perl.org/licenses/ repository: https://github.com/Perl5/DBIx-Class version: 0.082843 x_authority: cpan:RIBASUSHI x_contributors: - 'abraxxa: Alexander Hartmaier <abraxxa@cpan.org>' - 'acca: Alexander Kuznetsov <acca@cpan.org>' - 'acme: Leon Brocard <acme@astray.com>' - 'aherzog: Adam Herzog <adam@herzogdesigns.com>' - 'Alexander Keusch <cpan@keusch.at>' - 'alexrj: Alessandro Ranellucci <aar@cpan.org>' - 'alnewkirk: Al Newkirk <github@alnewkirk.com>' - 'Altreus: Alastair McGowan-Douglas <alastair.mcgowan@opusvl.com>' - 'amiri: Amiri Barksdale <amiribarksdale@gmail.com>' - 'amoore: Andrew Moore <amoore@cpan.org>' - 'Andrew Mehta <Andrew@unitedgames.co.uk>' - 'andrewalker: Andre Walker <andre@andrewalker.net>' - 'andyg: Andy Grundman <andy@hybridized.org>' - 'ank: Andres Kievsky <ank@ank.com.ar>' - 'arc: Aaron Crane <arc@cpan.org>' - 'arcanez: Justin Hunter <justin.d.hunter@gmail.com>' - 'ash: Ash Berlin <ash@cpan.org>' - 'bert: Norbert Csongrádi <bert@cpan.org>' - 'bfwg: Colin Newell <colin.newell@gmail.com>' - 'blblack: Brandon L. Black <blblack@gmail.com>' - 'bluefeet: Aran Deltac <bluefeet@cpan.org>' - 'boghead: Bryan Beeley <cpan@beeley.org>' - 'bphillips: Brian Phillips <bphillips@cpan.org>' - 'brd: Brad Davis <brd@FreeBSD.org>' - 'Brian Kirkbride <brian.kirkbride@deeperbydesign.com>' - 'bricas: Brian Cassidy <bricas@cpan.org>' - 'brunov: Bruno Vecchi <vecchi.b@gmail.com>' - 'caelum: Rafael Kitover <rkitover@cpan.org>' - 'caldrin: Maik Hentsche <maik.hentsche@amd.com>' - 'castaway: Jess Robinson <castaway@desert-island.me.uk>' - 'chorny: Alexandr Ciornii <alexchorny@gmail.com>' - 'cj: C.J. Adams-Collier <cjcollier@cpan.org>' - 'claco: Christopher H. Laco <claco@cpan.org>' - 'clkao: CL Kao <clkao@clkao.org>' - 'Ctrl-O http://ctrlo.com/' - 'da5id: David Jack Olrik <david@olrik.dk>' - 'dams: Damien Krotkine <dams@cpan.org>' - 'dandv: Dan Dascalescu <ddascalescu+github@gmail.com>' - 'dariusj: Darius Jokilehto <dariusjokilehto@yahoo.co.uk>' - 'davewood: David Schmidt <mail@davidschmidt.at>' - 'daxim: Lars Dɪᴇᴄᴋᴏᴡ 迪拉斯 <daxim@cpan.org>' - 'dduncan: Darren Duncan <darren@darrenduncan.net>' - 'debolaz: Anders Nor Berle <berle@cpan.org>' - 'dew: Dan Thomas <dan@godders.org>' - 'dim0xff: Dmitry Latin <dim0xff@gmail.com>' - 'dkubb: Dan Kubb <dan.kubb-cpan@onautopilot.com>' - 'dnm: Justin Wheeler <jwheeler@datademons.com>' - 'dpetrov: Dimitar Petrov <mitakaa@gmail.com>' - 'Dr^ZigMan: Robert Stone <drzigman@drzigman.com>' - 'dsteinbrunner: David Steinbrunner <dsteinbrunner@pobox.com>' - 'duncan_dmg: Duncan Garland <Duncan.Garland@motortrak.com>' - 'dwc: Daniel Westermann-Clark <danieltwc@cpan.org>' - 'dyfrgi: Michael Leuchtenburg <michael@slashhome.org>' - 'edenc: Eden Cardim <edencardim@gmail.com>' - 'Eligo http://eligo.co.uk/' - 'ether: Karen Etheridge <ether@cpan.org>' - 'evdb: Edmund von der Burg <evdb@ecclestoad.co.uk>' - 'faxm0dem: Fabien Wernli <cpan@faxm0dem.org>' - 'felliott: Fitz Elliott <fitz.elliott@gmail.com>' - 'fgabolde: Fabrice Gabolde <fgabolde@weborama.com>' - 'freetime: Bill Moseley <moseley@hank.org>' - "frew: Arthur Axel \"fREW\" Schmidt <frioux@gmail.com>" - 'gbjk: Gareth Kirwan <gbjk@thermeon.com>' - 'geotheve: Georgina Thevenet <geotheve@gmail.com>' - 'Getty: Torsten Raudssus <torsten@raudss.us>' - 'goraxe: Gordon Irving <goraxe@cpan.org>' - 'gphat: Cory G Watson <gphat@cpan.org>' - 'Grant Street Group http://www.grantstreet.com/' - 'gregoa: Gregor Herrmann <gregoa@debian.org>' - 'groditi: Guillermo Roditi <groditi@cpan.org>' - 'gshank: Gerda Shank <gshank@cpan.org>' - 'guacamole: Fred Steinberg <fred.steinberg@gmail.com>' - 'Haarg: Graham Knop <haarg@haarg.org>' - 'hobbs: Andrew Rodland <andrew@cleverdomain.org>' - 'Ian Wells <ijw@cack.org.uk>' - 'idn: Ian Norton <i.norton@shadowcat.co.uk>' - 'ilmari: Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>' - 'ingy: Ingy döt Net <ingy@ingy.net>' - 'initself: Mike Baas <mike@initselftech.com>' - 'ironcamel: Naveed Massjouni <naveedm9@gmail.com>' - 'jasonmay: Jason May <jason.a.may@gmail.com>' - 'jawnsy: Jonathan Yu <jawnsy@cpan.org>' - 'jegade: Jens Gassmann <jens.gassmann@atomix.de>' - 'jeneric: Eric A. Miller <emiller@cpan.org>' - 'jesper: Jesper Krogh <jesper@krogh.cc>' - 'Jesse Sheidlower <jester@panix.com>' - 'jgoulah: John Goulah <jgoulah@cpan.org>' - 'jguenther: Justin Guenther <jguenther@cpan.org>' - 'jhannah: Jay Hannah <jay@jays.net>' - 'jmac: Jason McIntosh <jmac@appleseed-sc.com>' - 'jmmills: Jason M. Mills <jmmills@cpan.org>' - 'jnapiorkowski: John Napiorkowski <jjn1056@yahoo.com>' - 'Joe Carlson <jwcarlson@lbl.gov>' - 'jon: Jon Schutz <jjschutz@cpan.org>' - 'Jordan Metzmeier <jmetzmeier@magazines.com>' - 'jshirley: J. Shirley <jshirley@gmail.com>' - 'kaare: Kaare Rasmussen' - 'kd: Kieren Diment <diment@gmail.com>' - 'kentnl: Kent Fredric <kentnl@cpan.org>' - 'kkane: Kevin L. Kane <kevin.kane@gmail.com>' - 'konobi: Scott McWhirter <konobi@cpan.org>' - 'lejeunerenard: Sean Zellmer <sean@lejeunerenard.com>' - 'leont: Leon Timmermans <fawaka@gmail.com>' - 'littlesavage: Alexey Illarionov <littlesavage@orionet.ru>' - 'lukes: Luke Saunders <luke.saunders@gmail.com>' - 'marcus: Marcus Ramberg <mramberg@cpan.org>' - 'mateu: Mateu X. Hunter <hunter@missoula.org>' - 'Matt LeBlanc <antirice@gmail.com>' - 'Matt Sickler <imMute@msk4.com>' - 'mattlaw: Matt Lawrence' - 'mattp: Matt Phillips <mattp@cpan.org>' - 'mdk: Mark Keating <m.keating@shadowcat.co.uk>' - 'melo: Pedro Melo <melo@simplicidade.org>' - 'metaperl: Terrence Brannon <metaperl@gmail.com>' - 'michaelr: Michael Reddick <michael.reddick@gmail.com>' - 'milki: Jonathan Chu <milki@rescomp.berkeley.edu>' - 'minty: Murray Walker <perl@minty.org>' - 'mithaldu: Christian Walde <walde.christian@gmail.com>' - 'mjemmeson: Michael Jemmeson <michael.jemmeson@gmail.com>' - 'mna: Maya' - 'mo: Moritz Onken <onken@netcubed.de>' - 'moltar: Roman Filippov <romanf@cpan.org>' - 'moritz: Moritz Lenz <moritz@faui2k3.org>' - 'mrf: Mike Francis <ungrim97@gmail.com>' - 'mst: Matt S. Trout <mst@shadowcat.co.uk>' - 'mstratman: Mark A. Stratman <stratman@gmail.com>' - 'ned: Neil de Carteret <n3dst4@gmail.com>' - 'nigel: Nigel Metheringham <nigelm@cpan.org>' - 'ningu: David Kamholz <dkamholz@cpan.org>' - "Nniuq: Ron \"Quinn\" Straight\" <quinnfazigu@gmail.org>" - 'norbi: Norbert Buchmuller <norbi@nix.hu>' - 'nothingmuch: Yuval Kogman <nothingmuch@woobling.org>' - 'nuba: Nuba Princigalli <nuba@cpan.org>' - 'Numa: Dan Sully <daniel@cpan.org>' - 'oalders: Olaf Alders <olaf@wundersolutions.com>' - 'Olly Betts <olly@survex.com>' - 'osfameron: Hakim Cassimally <osfameron@cpan.org>' - "ovid: Curtis \"Ovid\" Poe <ovid@cpan.org>" - 'oyse: Øystein Torget <oystein.torget@dnv.com>' - 'paulm: Paul Makepeace <paulm+pause@paulm.com>' - 'penguin: K J Cheetham <jamie@shadowcatsystems.co.uk>' - 'perigrin: Chris Prather <chris@prather.org>' - 'Peter Siklósi <einon@einon.hu>' - 'Peter Valdemar Mørch <peter@morch.com>' - 'peter: Peter Collingbourne <peter@pcc.me.uk>' - 'phaylon: Robert Sedlacek <phaylon@dunkelheit.at>' - 'plu: Johannes Plunien <plu@cpan.org>' - 'pmooney: Paul Mooney <paul.mooney@net-a-porter.com>' - 'Possum: Daniel LeWarne <possum@cpan.org>' - 'pplu: Jose Luis Martinez <jlmartinez@capside.com>' - 'quicksilver: Jules Bean <jules@jellybean.co.uk>' - 'racke: Stefan Hornburg <racke@linuxia.de>' - 'rafl: Florian Ragwitz <rafl@debian.org>' - 'rainboxx: Matthias Dietrich <perl@rb.ly>' - 'rbo: Robert Bohne <rbo@cpan.org>' - 'rbuels: Robert Buels <rmb32@cornell.edu>' - 'rdj: Ryan D Johnson <ryan@innerfence.com>' - 'Relequestual: Ben Hutton <relequestual@gmail.com>' - 'renormalist: Steffen Schwigon <schwigon@cpan.org>' - 'ribasushi: Peter Rabbitson <ribasushi@leporine.io>' - 'rjbs: Ricardo Signes <rjbs@cpan.org>' - 'Robert Krimen <rkrimen@cpan.org>' - 'Robert Olson <bob@rdolson.org>' - 'robkinyon: Rob Kinyon <rkinyon@cpan.org>' - 'Roman Ardern-Corris <spam_in@3legs.com>' - 'ruoso: Daniel Ruoso <daniel@ruoso.com>' - 'Sadrak: Felix Antonius Wilhelm Ostmann <sadrak@cpan.org>' - 'sc_: Just Another Perl Hacker' - 'schwern: Michael G Schwern <mschwern@cpan.org>' - 'Scott R. Godin <webdragon.net@gmail.com>' - 'scotty: Scotty Allen <scotty@scottyallen.com>' - 'semifor: Marc Mims <marc@questright.com>' - 'Simon Elliott <cpan@browsing.co.uk>' - 'SineSwiper: Brendan Byrd <perl@resonatorsoft.org>' - 'skaufman: Samuel Kaufman <sam@socialflow.com>' - 'solomon: Jared Johnson <jaredj@nmgi.com>' - 'spb: Stephen Bennett <stephen@freenode.net>' - 'Squeeks <squeek@cpan.org>' - 'srezic: Slaven Rezic <slaven@rezic.de>' - 'sszabo: Stephan Szabo <sszabo@bigpanda.com>' - 'Stephen Peters <steve@stephenpeters.me>' - 'stonecolddevin: Devin Austin <dhoss@cpan.org>' - 'talexb: Alex Beamish <talexb@gmail.com>' - 'tamias: Ronald J Kimball <rjk@tamias.net>' - 'TBSliver: Tom Bloor <t.bloor@shadowcat.co.uk>' - 'teejay: Aaron Trevena <teejay@cpan.org>' - 'theorbtwo: James Mastros <james@mastros.biz>' - 'Thomas Kratz <tomk@cpan.org>' - 'timbunce: Tim Bunce <tim.bunce@pobox.com>' - 'tinita: Tina Mueller <cpan2@tinita.de>' - 'Todd Lipcon' - 'Tom Hukins <tom@eborcom.com>' - 'tommy: Tommy Butler <tbutler.cpan.org@internetalias.net>' - 'tonvoon: Ton Voon <ton.voon@opsview.com>' - 'triode: Pete Gamache <gamache@cpan.org>' - 'typester: Daisuke Murase <typester@cpan.org>' - 'uree: Oriol Soriano <oriol.soriano@capside.com>' - 'uwe: Uwe Voelker <uwe@uwevoelker.de>' - 'vanstyn: Henry Van Styn <vanstyn@cpan.org>' - 'victori: Victor Igumnov <victori@cpan.org>' - 'wdh: Will Hawes <wdhawes@gmail.com>' - 'wesm: Wes Malone <wes@mitsi.com>' - 'willert: Sebastian Willert <willert@cpan.org>' - 'wintermute: Toby Corkindale <tjc@cpan.org>' - 'wreis: Wallace Reis <wreis@cpan.org>' - 'x86-64 <x86mail@gmail.com>' - 'xenoterracide: Caleb Cushing <xenoterracide@gmail.com>' - 'xmikew: Mike Wisener <xmikew@32ths.com>' - 'yrlnry: Mark Jason Dominus <mjd@plover.com>' - 'zamolxes: Bogdan Lucaciu <bogdan@wiz.ro>' - 'Zefram: Andrew Main <zefram@fysh.org>' x_dependencies_parallel_test_certified: 1 x_parallel_test_certified: 1 ������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/AUTHORS�������������������������������������������������������������������������0000644�0001750�0001750�00000022031�14240676465�014167� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # The list of the awesome folks behind DBIx::Class # # This utf8-encoded file lists every code author and idea contributor # in alphabetical order # # Entry format (all elements optional, order is mandatory): # (ircnick:) (name) (<email>) # # abraxxa: Alexander Hartmaier <abraxxa@cpan.org> acca: Alexander Kuznetsov <acca@cpan.org> acme: Leon Brocard <acme@astray.com> aherzog: Adam Herzog <adam@herzogdesigns.com> Alexander Keusch <cpan@keusch.at> alexrj: Alessandro Ranellucci <aar@cpan.org> alnewkirk: Al Newkirk <github@alnewkirk.com> Altreus: Alastair McGowan-Douglas <alastair.mcgowan@opusvl.com> amiri: Amiri Barksdale <amiribarksdale@gmail.com> amoore: Andrew Moore <amoore@cpan.org> Andrew Mehta <Andrew@unitedgames.co.uk> andrewalker: Andre Walker <andre@andrewalker.net> andyg: Andy Grundman <andy@hybridized.org> ank: Andres Kievsky <ank@ank.com.ar> arc: Aaron Crane <arc@cpan.org> arcanez: Justin Hunter <justin.d.hunter@gmail.com> ash: Ash Berlin <ash@cpan.org> bert: Norbert Csongrádi <bert@cpan.org> bfwg: Colin Newell <colin.newell@gmail.com> blblack: Brandon L. Black <blblack@gmail.com> bluefeet: Aran Deltac <bluefeet@cpan.org> boghead: Bryan Beeley <cpan@beeley.org> bphillips: Brian Phillips <bphillips@cpan.org> brd: Brad Davis <brd@FreeBSD.org> Brian Kirkbride <brian.kirkbride@deeperbydesign.com> bricas: Brian Cassidy <bricas@cpan.org> brunov: Bruno Vecchi <vecchi.b@gmail.com> caelum: Rafael Kitover <rkitover@cpan.org> caldrin: Maik Hentsche <maik.hentsche@amd.com> castaway: Jess Robinson <castaway@desert-island.me.uk> chorny: Alexandr Ciornii <alexchorny@gmail.com> cj: C.J. Adams-Collier <cjcollier@cpan.org> claco: Christopher H. Laco <claco@cpan.org> clkao: CL Kao <clkao@clkao.org> Ctrl-O http://ctrlo.com/ da5id: David Jack Olrik <david@olrik.dk> dams: Damien Krotkine <dams@cpan.org> dandv: Dan Dascalescu <ddascalescu+github@gmail.com> dariusj: Darius Jokilehto <dariusjokilehto@yahoo.co.uk> davewood: David Schmidt <mail@davidschmidt.at> daxim: Lars Dɪᴇᴄᴋᴏᴡ 迪拉斯 <daxim@cpan.org> dduncan: Darren Duncan <darren@darrenduncan.net> debolaz: Anders Nor Berle <berle@cpan.org> dew: Dan Thomas <dan@godders.org> dim0xff: Dmitry Latin <dim0xff@gmail.com> dkubb: Dan Kubb <dan.kubb-cpan@onautopilot.com> dnm: Justin Wheeler <jwheeler@datademons.com> dpetrov: Dimitar Petrov <mitakaa@gmail.com> Dr^ZigMan: Robert Stone <drzigman@drzigman.com> dsteinbrunner: David Steinbrunner <dsteinbrunner@pobox.com> duncan_dmg: Duncan Garland <Duncan.Garland@motortrak.com> dwc: Daniel Westermann-Clark <danieltwc@cpan.org> dyfrgi: Michael Leuchtenburg <michael@slashhome.org> edenc: Eden Cardim <edencardim@gmail.com> Eligo http://eligo.co.uk/ ether: Karen Etheridge <ether@cpan.org> evdb: Edmund von der Burg <evdb@ecclestoad.co.uk> faxm0dem: Fabien Wernli <cpan@faxm0dem.org> felliott: Fitz Elliott <fitz.elliott@gmail.com> fgabolde: Fabrice Gabolde <fgabolde@weborama.com> freetime: Bill Moseley <moseley@hank.org> frew: Arthur Axel "fREW" Schmidt <frioux@gmail.com> gbjk: Gareth Kirwan <gbjk@thermeon.com> geotheve: Georgina Thevenet <geotheve@gmail.com> Getty: Torsten Raudssus <torsten@raudss.us> goraxe: Gordon Irving <goraxe@cpan.org> gphat: Cory G Watson <gphat@cpan.org> Grant Street Group http://www.grantstreet.com/ gregoa: Gregor Herrmann <gregoa@debian.org> groditi: Guillermo Roditi <groditi@cpan.org> gshank: Gerda Shank <gshank@cpan.org> guacamole: Fred Steinberg <fred.steinberg@gmail.com> Haarg: Graham Knop <haarg@haarg.org> hobbs: Andrew Rodland <andrew@cleverdomain.org> Ian Wells <ijw@cack.org.uk> idn: Ian Norton <i.norton@shadowcat.co.uk> ilmari: Dagfinn Ilmari Mannsåker <ilmari@ilmari.org> ingy: Ingy döt Net <ingy@ingy.net> initself: Mike Baas <mike@initselftech.com> ironcamel: Naveed Massjouni <naveedm9@gmail.com> jasonmay: Jason May <jason.a.may@gmail.com> jawnsy: Jonathan Yu <jawnsy@cpan.org> jegade: Jens Gassmann <jens.gassmann@atomix.de> jeneric: Eric A. Miller <emiller@cpan.org> jesper: Jesper Krogh <jesper@krogh.cc> Jesse Sheidlower <jester@panix.com> jgoulah: John Goulah <jgoulah@cpan.org> jguenther: Justin Guenther <jguenther@cpan.org> jhannah: Jay Hannah <jay@jays.net> jmac: Jason McIntosh <jmac@appleseed-sc.com> jmmills: Jason M. Mills <jmmills@cpan.org> jnapiorkowski: John Napiorkowski <jjn1056@yahoo.com> Joe Carlson <jwcarlson@lbl.gov> jon: Jon Schutz <jjschutz@cpan.org> Jordan Metzmeier <jmetzmeier@magazines.com> jshirley: J. Shirley <jshirley@gmail.com> kaare: Kaare Rasmussen kd: Kieren Diment <diment@gmail.com> kentnl: Kent Fredric <kentnl@cpan.org> kkane: Kevin L. Kane <kevin.kane@gmail.com> konobi: Scott McWhirter <konobi@cpan.org> lejeunerenard: Sean Zellmer <sean@lejeunerenard.com> leont: Leon Timmermans <fawaka@gmail.com> littlesavage: Alexey Illarionov <littlesavage@orionet.ru> lukes: Luke Saunders <luke.saunders@gmail.com> marcus: Marcus Ramberg <mramberg@cpan.org> mateu: Mateu X. Hunter <hunter@missoula.org> Matt LeBlanc <antirice@gmail.com> Matt Sickler <imMute@msk4.com> mattlaw: Matt Lawrence mattp: Matt Phillips <mattp@cpan.org> mdk: Mark Keating <m.keating@shadowcat.co.uk> melo: Pedro Melo <melo@simplicidade.org> metaperl: Terrence Brannon <metaperl@gmail.com> michaelr: Michael Reddick <michael.reddick@gmail.com> milki: Jonathan Chu <milki@rescomp.berkeley.edu> minty: Murray Walker <perl@minty.org> mithaldu: Christian Walde <walde.christian@gmail.com> mjemmeson: Michael Jemmeson <michael.jemmeson@gmail.com> mna: Maya mo: Moritz Onken <onken@netcubed.de> moltar: Roman Filippov <romanf@cpan.org> moritz: Moritz Lenz <moritz@faui2k3.org> mrf: Mike Francis <ungrim97@gmail.com> mst: Matt S. Trout <mst@shadowcat.co.uk> mstratman: Mark A. Stratman <stratman@gmail.com> ned: Neil de Carteret <n3dst4@gmail.com> nigel: Nigel Metheringham <nigelm@cpan.org> ningu: David Kamholz <dkamholz@cpan.org> Nniuq: Ron "Quinn" Straight" <quinnfazigu@gmail.org> norbi: Norbert Buchmuller <norbi@nix.hu> nothingmuch: Yuval Kogman <nothingmuch@woobling.org> nuba: Nuba Princigalli <nuba@cpan.org> Numa: Dan Sully <daniel@cpan.org> oalders: Olaf Alders <olaf@wundersolutions.com> Olly Betts <olly@survex.com> osfameron: Hakim Cassimally <osfameron@cpan.org> ovid: Curtis "Ovid" Poe <ovid@cpan.org> oyse: Øystein Torget <oystein.torget@dnv.com> paulm: Paul Makepeace <paulm+pause@paulm.com> penguin: K J Cheetham <jamie@shadowcatsystems.co.uk> perigrin: Chris Prather <chris@prather.org> Peter Siklósi <einon@einon.hu> Peter Valdemar Mørch <peter@morch.com> peter: Peter Collingbourne <peter@pcc.me.uk> phaylon: Robert Sedlacek <phaylon@dunkelheit.at> plu: Johannes Plunien <plu@cpan.org> pmooney: Paul Mooney <paul.mooney@net-a-porter.com> Possum: Daniel LeWarne <possum@cpan.org> pplu: Jose Luis Martinez <jlmartinez@capside.com> quicksilver: Jules Bean <jules@jellybean.co.uk> racke: Stefan Hornburg <racke@linuxia.de> rafl: Florian Ragwitz <rafl@debian.org> rainboxx: Matthias Dietrich <perl@rb.ly> rbo: Robert Bohne <rbo@cpan.org> rbuels: Robert Buels <rmb32@cornell.edu> rdj: Ryan D Johnson <ryan@innerfence.com> Relequestual: Ben Hutton <relequestual@gmail.com> renormalist: Steffen Schwigon <schwigon@cpan.org> ribasushi: Peter Rabbitson <ribasushi@leporine.io> rjbs: Ricardo Signes <rjbs@cpan.org> Robert Krimen <rkrimen@cpan.org> Robert Olson <bob@rdolson.org> robkinyon: Rob Kinyon <rkinyon@cpan.org> Roman Ardern-Corris <spam_in@3legs.com> ruoso: Daniel Ruoso <daniel@ruoso.com> Sadrak: Felix Antonius Wilhelm Ostmann <sadrak@cpan.org> sc_: Just Another Perl Hacker schwern: Michael G Schwern <mschwern@cpan.org> Scott R. Godin <webdragon.net@gmail.com> scotty: Scotty Allen <scotty@scottyallen.com> semifor: Marc Mims <marc@questright.com> Simon Elliott <cpan@browsing.co.uk> SineSwiper: Brendan Byrd <perl@resonatorsoft.org> skaufman: Samuel Kaufman <sam@socialflow.com> solomon: Jared Johnson <jaredj@nmgi.com> spb: Stephen Bennett <stephen@freenode.net> Squeeks <squeek@cpan.org> srezic: Slaven Rezic <slaven@rezic.de> sszabo: Stephan Szabo <sszabo@bigpanda.com> Stephen Peters <steve@stephenpeters.me> stonecolddevin: Devin Austin <dhoss@cpan.org> talexb: Alex Beamish <talexb@gmail.com> tamias: Ronald J Kimball <rjk@tamias.net> TBSliver: Tom Bloor <t.bloor@shadowcat.co.uk> teejay: Aaron Trevena <teejay@cpan.org> theorbtwo: James Mastros <james@mastros.biz> Thomas Kratz <tomk@cpan.org> timbunce: Tim Bunce <tim.bunce@pobox.com> tinita: Tina Mueller <cpan2@tinita.de> Todd Lipcon Tom Hukins <tom@eborcom.com> tommy: Tommy Butler <tbutler.cpan.org@internetalias.net> tonvoon: Ton Voon <ton.voon@opsview.com> triode: Pete Gamache <gamache@cpan.org> typester: Daisuke Murase <typester@cpan.org> uree: Oriol Soriano <oriol.soriano@capside.com> uwe: Uwe Voelker <uwe@uwevoelker.de> vanstyn: Henry Van Styn <vanstyn@cpan.org> victori: Victor Igumnov <victori@cpan.org> wdh: Will Hawes <wdhawes@gmail.com> wesm: Wes Malone <wes@mitsi.com> willert: Sebastian Willert <willert@cpan.org> wintermute: Toby Corkindale <tjc@cpan.org> wreis: Wallace Reis <wreis@cpan.org> x86-64 <x86mail@gmail.com> xenoterracide: Caleb Cushing <xenoterracide@gmail.com> xmikew: Mike Wisener <xmikew@32ths.com> yrlnry: Mark Jason Dominus <mjd@plover.com> zamolxes: Bogdan Lucaciu <bogdan@wiz.ro> Zefram: Andrew Main <zefram@fysh.org> �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx-Class-0.082843/LICENSE�������������������������������������������������������������������������0000644�0001750�0001750�00000047125�14240676465�014137� 0����������������������������������������������������������������������������������������������������ustar �rabbit��������������������������rabbit�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������DBIx::Class is Copyright (c) 2005-2022 by mst, castaway, ribasushi, and others. See AUTHORS and LICENSE included with this distribution. All rights reserved. This is free software; you can redistribute it and/or modify it under the same terms as the Perl5 (v5.0.0 ~ v5.20.0) programming language system itself: under the terms of either: a) the "Artistic License 1.0" as published by The Perl Foundation http://www.perlfoundation.org/artistic_license_1_0 b) the GNU General Public License as published by the Free Software Foundation; either version 1 http://www.gnu.org/licenses/gpl-1.0.html or (at your option) any later version PLEASE NOTE: It is the current maintainers intention to keep the dual licensing intact. Until this notice is removed, releases will continue to be available under both the standard GPL and the less restrictive Artistic licenses. Verbatim copies of both licenses are included below: --- The Artistic License 1.0 --- The "Artistic License" Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder as specified below. "Copyright Holder" is whoever is named in the copyright or copyrights for the package. "You" is you, if you're thinking about copying or distributing this Package. "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as uunet.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) give non-standard executables non-standard names, and clearly document the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. You may embed this Package's interpreter within an executable of yours (by linking); this shall be construed as a mere form of aggregation, provided that the complete Standard Version of the interpreter is so embedded. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whoever generated them, and may be sold commercially, and may be aggregated with this Package. If such scripts or library files are aggregated with this Package via the so-called "undump" or "unexec" methods of producing a binary executable image, then distribution of such an image shall neither be construed as a distribution of this Package nor shall it fall under the restrictions of Paragraphs 3 and 4, provided that you do not represent such an executable image as a Standard Version of this Package. 7. C subroutines (or comparably compiled subroutines in other languages) supplied by you and linked into this Package in order to emulate subroutines and variables of the language defined by this Package shall not be considered part of this Package, but are the equivalent of input as in Paragraph 6, provided these subroutines do not change the language in any way that would cause it to fail the regression tests for the language. 8. Aggregation of this Package with a commercial distribution is always permitted provided that the use of this Package is embedded; that is, when no overt attempt is made to make this Package's interfaces visible to the end user of the commercial distribution. Such use shall not be construed as a distribution of this Package. 9. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. --- end of The Artistic License 1.0 --- --- The GNU General Public License, Version 1, February 1989 --- GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 2. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. d) You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 5. By copying, distributing or modifying the Program (or any work based on the Program) you indicate your acceptance of this license to do so, and all its terms and conditions. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. 7. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of the license which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the license, you may choose any version ever published by the Free Software Foundation. 8. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to humanity, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. <one line to give the program's name and a brief idea of what it does.> Copyright (C) 19yy <name of author> This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19xx name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. <signature of Ty Coon>, 1 April 1989 Ty Coon, President of Vice That's all there is to it! --- end of The GNU General Public License, Version 1, February 1989 --- �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������