Revision history for DBIx::Class
+ * Fixes
+ - Fixed rels ending with me breaking subqueried limit realiasing
+ - Oracle sequence detection now *really* works across schemas
+ (fixed some ommissions from 0.08123)
+ - add_unique_constraint() now throws if called with multiple constraint
+ definitions
+ - Implemented add_unique_constraints() which delegates to
+ add_unique_constraint() as appropriate
+ - dbicadmin now uses a /usr/bin/env shebang to work better with
+ perlbrew and other local perl builds
+
+ * Misc
+ - Makefile.PL no longer imports GetOptions() to interoperate better
+ with Catalyst installers
+ - Bumped minimum Module::Install for developers
+
0.08123 2010-06-12 14:46 (UTC)
* Fixes
- Make sure Oracle identifier shortener applies to auto-generated
-use inc::Module::Install 0.97;
+use inc::Module::Install 1.00;
use strict;
use warnings;
use POSIX ();
use Config;
$ENV{PERL5LIB} = join ($Config{path_sep}, @INC);
-use Getopt::Long qw/:config gnu_getopt bundling_override no_ignore_case pass_through/;
+use 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,
};
-GetOptions ($args, 'skip_author_deps');
+$getopt->getoptions($args, 'skip_author_deps');
if (@ARGV) {
warn "\nIgnoring unrecognized option(s): @ARGV\n\n";
}
******************************************************************************
*** ***
*** AUTHOR MODE: all optional test dependencies converted to hard requires ***
-*** ( to disabled re-run Makefile.PL with --skip_author_deps ) ***
+*** ( to disable re-run Makefile.PL with --skip_author_deps ) ***
*** ***
******************************************************************************
******************************************************************************
}
if (keys %removed_build_requires) {
- die join ("\n", "\n\nFATAL FAIL! It looks like some author dependencies made it to the META.yml:\n",
+ die join ("\n",
+ "\n\nFATAL FAIL! It looks like some author dependencies made it to the META.yml:",
+ "(most likely a broken Module::Install)\n",
map { "\t$_" } (keys %removed_build_requires)
) . "\n\n";
}
-#!/usr/bin/perl -w
+#!/usr/bin/env perl
-use MyDatabase::Main;
use strict;
+use warnings;
+
+use MyDatabase::Main;
my $schema = MyDatabase::Main->connect('dbi:SQLite:db/example.db');
-#!/usr/bin/perl -w
+#!/usr/bin/env perl
-use MyDatabase::Main;
+use warnings;
use strict;
+use MyDatabase::Main;
+
my $schema = MyDatabase::Main->connect('dbi:SQLite:db/example.db');
# for other DSNs, e.g. MySql, see the perldoc for the relevant dbd
# driver, e.g perldoc L<DBD::mysql>.
=item * IRC: irc.perl.org#dbix-class
=for html
-<a href="http://mibbit.com/chat/#dbix-class@irc.perl.org">(click for instant chatroom login)</a>
+<a href="http://chat.mibbit.com/#dbix-class@irc.perl.org">(click for instant chatroom login)</a>
=item * Mailing list: L<http://lists.scsys.co.uk/mailman/listinfo/dbix-class>
plu: Johannes Plunien <plu@cpan.org>
+Possum: Daniel LeWarne <possum@cpan.org>
+
quicksilver: Jules Bean
rafl: Florian Ragwitz <rafl@debian.org>
+rainboxx: Matthias Dietrich <perl@rb.ly>
+
rbo: Robert Bohne <rbo@cpan.org>
rbuels: Robert Buels <rmb32@cornell.edu>
zamolxes: Bogdan Lucaciu <bogdan@wiz.ro>
-Possum: Daniel LeWarne <possum@cpan.org>
-
=head1 COPYRIGHT
Copyright (c) 2005 - 2010 the DBIx::Class L</AUTHOR> and L</CONTRIBUTORS>
=head1 SYNOPSIS
- # In your result classes
+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',
1;
+
=head1 DESCRIPTION
This component is meant to be a more powerful, but less DWIM-y,
# 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
+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 Class::C3 inheritance stack.
print join ', ' => Class::C3::calculateMRO('YourClass::Name');
=head2 Extra
-These components provide extra functionality beyond
+These components provide extra functionality beyond
basic functionality that you can't live without.
L<DBIx::Class::Serialize::Storable> - Hooks for Storable freeze/thaw.
L<DBIx::Class::RandomStringColumns> - Declare virtual columns that return random strings.
-L<DBIx::Class::UTF8Columns> - Force UTF8 (Unicode) flag on columns.
-
L<DBIx::Class::UUIDColumns> - Implicit UUID columns.
L<DBIx::Class::WebForm> - CRUD methods.
=head2 Easy migration from class-based to schema-based setup
You want to start using the schema-based approach to L<DBIx::Class>
-(see L<SchemaIntro.pod>), 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:
+(see L<DBIx::Class::Manual::Intro/Setting it up manually>), 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;
$ENV{DBICTEST_ORA_DSN}
? (
'DateTime::Format::Oracle' => '0',
+ 'DBD::Oracle' => '1.24',
) : ()
},
},
=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 than a position
+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
Note: you normally do want to define a primary key on your sources
B<even if the underlying database table does not have a primary key>.
See
-L<DBIx::Class::Intro/The Significance and Importance of Primary Keys>
+L<DBIx::Class::Manual::Intro/The Significance and Importance of Primary Keys>
for more info.
=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 @_;
- my $name = shift;
+ 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);
$self->_unique_constraints(\%unique_constraints);
}
+=head2 add_unique_constraints
+
+=over 4
+
+=item Arguments: @constraints
+
+=item Return value: undefined
+
+=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<table_column1_column2> and
+C<table_column3_column4>, where C<table> 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</add_unique_constraint>.
+
+=cut
+
+sub add_unique_constraints {
+ my $self = shift;
+ my @constraints = @_;
+
+ if ( !(@constraints % 2) && first { 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 Arguments: \@colnames
=item Return value: Constraint name
=back
$source->table('mytable');
- $source->name_unique_constraint('col1', 'col2');
+ $source->name_unique_constraint(['col1', 'col2']);
# returns
'mytable_col1_col2'
If you modified the schema to include a placeholder
__PACKAGE__->result_source_instance->view_definition(
- "SELECT cdid, artist, title FROM cd WHERE year ='?'"
+ "SELECT cdid, artist, title FROM cd WHERE year = ?"
);
and ensuring you have is_virtual set to true:
shift->result_source_instance->add_unique_constraint(@_);
}
+sub add_unique_constraints {
+ shift->result_source_instance->add_unique_constraints(@_);
+}
+
sub unique_constraints {
shift->result_source_instance->unique_constraints(@_);
}
# for possible further chaining)
my (@in_sel, @out_sel, %renamed);
for my $node (@sel) {
- if (first { $_ =~ / (?<! $re_alias ) $re_sep /x } ($node->{as}, $node->{unquoted_sql}) ) {
+ if (first { $_ =~ / (?<! ^ $re_alias ) $re_sep /x } ($node->{as}, $node->{unquoted_sql}) ) {
$node->{as} = $self->_unqualify_colname($node->{as});
my $quoted_as = $self->_quote($node->{as});
push @in_sel, sprintf '%s AS %s', $node->{sql}, $quoted_as;
$sth->execute (@bind);
while (my ($insert_trigger, $schema) = $sth->fetchrow_array) {
- my ($seq_name) = $insert_trigger =~ m!("?[.\w"]+?"?)\.nextval!i;
+ my ($seq_name) = $insert_trigger =~ m!("?[.\w"]+"?)\.nextval!i;
next unless $seq_name;
if ($seq_name !~ /\./) {
- $seq_name = join '.' => map $self->sql_maker->_quote($_), $schema, $seq_name;
+ $seq_name = join '.' => $schema, $seq_name;
}
return $seq_name;
-#!/usr/bin/perl
+#!/usr/bin/env perl
use strict;
use warnings;
-#!/usr/bin/perl
+#!/usr/bin/env perl
#
# So you wrote a new mk_hash implementation which passed all tests (particularly
-#!/usr/bin/perl -w
+#!/usr/bin/env perl
# Originally by: Zbigniew Lukasiak, C<zz bb yy@gmail.com>
# but refactored and modified to our nefarious purposes
-#!/usr/bin/perl
+#!/usr/bin/env perl
use strict;
use warnings;
+++ /dev/null
-#!/usr/bin/perl
-
-die "must be run from DBIx::Class root dir" unless -d 't/run';
-
-gen_tests($_) for qw/BasicRels HelperRels/;
-
-sub gen_tests {
- my $variant = shift;
- my $dir = lc $variant;
- system("rm -f t/$dir/*.t");
-
- foreach my $test (map { m[^t/run/(.+)\.tl$]; $1 } split(/\n/, `ls t/run/*.tl`)) {
- open(my $fh, '>', "t/$dir/${test}.t") or die $!;
- print $fh <<"EOF";
-use Test::More;
-use lib qw(t/lib);
-use DBICTest;
-use DBICTest::$variant;
-
-require "t/run/${test}.tl";
-run_tests(DBICTest->schema);
-EOF
- close $fh;
- }
-}
+++ /dev/null
-#!/usr/bin/perl
-use strict;
-use warnings;
-use lib qw(lib t/lib);
-
-# USAGE:
-# maint/inheritance_pod.pl Some::Module
-
-my $module = $ARGV[0];
-eval(" require $module; ");
-
-my @modules = Class::C3::calculateMRO($module);
-shift( @modules );
-
-print "=head1 INHERITED METHODS\n\n";
-
-foreach my $module (@modules) {
- print "=head2 $module\n\n";
- print "=over 4\n\n";
- my $file = $module;
- $file =~ s/::/\//g;
- $file .= '.pm';
- foreach my $path (@INC){
- if (-e "$path/$file") {
- open(MODULE,"<$path/$file");
- while (my $line = <MODULE>) {
- if ($line=~/^\s*sub ([a-z][a-z_]+) \{/) {
- my $method = $1;
- print "=item *\n\n";
- print "L<$method|$module/$method>\n\n";
- }
- }
- close(MODULE);
- last;
- }
- }
- print "=back\n\n";
-}
-
-1;
-#!/usr/bin/perl
+#!/usr/bin/env perl
use warnings;
use strict;
+++ /dev/null
-#!/bin/sh
-
-cd maint;
-rm svn-log.perl;
-wget https://thirdlobe.com/svn/repo-tools/trunk/svn-log.perl;
+++ /dev/null
-#!/usr/bin/env perl
-# $Id$
-
-# This program is Copyright 2005 by Rocco Caputo. All rights are
-# reserved. This program is free software. It may be modified, used,
-# and redistributed under the same terms as Perl itself.
-
-# Generate a nice looking change log from the subversion logs for a
-# Perl project. The log is also easy for machines to parse.
-
-use warnings;
-use strict;
-
-use Getopt::Long;
-use Text::Wrap qw(wrap fill $columns $huge);
-use POSIX qw(strftime);
-use XML::Parser;
-
-my %month = qw(
- Jan 01 Feb 02 Mar 03 Apr 04 May 05 Jun 06
- Jul 07 Aug 08 Sep 09 Oct 10 Nov 11 Dec 12
-);
-
-$Text::Wrap::huge = "wrap";
-$Text::Wrap::columns = 74;
-
-my $days_back = 365; # Go back a year by default.
-my $send_help = 0; # Display help and exit.
-my $svn_repo; # Where to log from.
-
-use constant LOG_REV => 0;
-use constant LOG_DATE => 1;
-use constant LOG_WHO => 2;
-use constant LOG_MESSAGE => 3;
-use constant LOG_PATHS => 4;
-
-use constant PATH_PATH => 0;
-use constant PATH_ACTION => 1;
-use constant PATH_CPF_PATH => 2;
-use constant PATH_CPF_REV => 3;
-
-use constant TAG_REV => 0;
-use constant TAG_TAG => 1;
-use constant TAG_LOG => 2;
-
-use constant MAX_TIMESTAMP => "9999-99-99 99:99:99";
-
-GetOptions(
- "age=s" => \$days_back,
- "repo=s" => \$svn_repo,
- "help" => \$send_help,
-) or exit;
-
-# Find the trunk for the current repository if one isn't specified.
-unless (defined $svn_repo) {
- $svn_repo = `svn info . | grep '^URL: '`;
- if (length $svn_repo) {
- chomp $svn_repo;
- $svn_repo =~ s{^URL\:\s+(.+?)/trunk/?.*$}{$1};
- }
- else {
- $send_help = 1;
- }
-}
-
-die(
- "$0 usage:\n",
- " --repo REPOSITORY\n",
- " [--age DAYS]\n",
- "\n",
- "REPOSITORY must have a trunk subdirectory and a tags directory where\n",
- "release tags are kept.\n",
-) if $send_help;
-
-my $earliest_date = strftime "%F", gmtime(time() - $days_back * 86400);
-
-### 1. Gather a list of tags for the repository, their revisions and
-### dates.
-
-my %tag;
-
-open(TAG, "svn -v list $svn_repo/tags|") or die $!;
-while (<TAG>) {
- # The date is unused, however.
- next unless (
- my ($rev, $date, $tag) = m{
- (\d+).*?(\S\S\S\s+\d\d\s+(?:\d\d\d\d|\d\d:\d\d))\s+(v[0-9_.]+)
- }x
- );
-
- my @tag_log = gather_log("$svn_repo/tags/$tag", "--stop-on-copy");
- die "Tag $tag has changes after tagging!\n" if @tag_log > 1;
-
- my $timestamp = $tag_log[0][LOG_DATE];
- $tag{$timestamp} = [
- $rev, # TAG_REV
- $tag, # TAG_TAG
- [ ], # TAG_LOG
- ];
-}
-close TAG;
-
-# Fictitious "HEAD" tag for revisions that came after the last tag.
-
-$tag{+MAX_TIMESTAMP} = [
- "HEAD", # TAG_REV
- "(untagged)", # TAG_TAG
- undef, # TAG_LOG
-];
-
-### 2. Gather the log for the trunk. Place log entries under their
-### proper tags.
-
-my @tag_dates = sort keys %tag;
-while (my $date = pop(@tag_dates)) {
-
- # We're done if this date's before our earliest date.
- if ($date lt $earliest_date) {
- delete $tag{$date};
- next;
- }
-
- my $tag = $tag{$date}[TAG_TAG];
- #warn "Gathering information for tag $tag...\n";
-
- my $this_rev = $tag{$date}[TAG_REV];
- my $prev_rev;
- if (@tag_dates) {
- $prev_rev = $tag{$tag_dates[-1]}[TAG_REV];
- }
- else {
- $prev_rev = 0;
- }
-
- my @log = gather_log("$svn_repo/trunk", "-r", "$this_rev:$prev_rev");
-
- $tag{$date}[TAG_LOG] = \@log;
-}
-
-### 3. PROFIT! No, wait... generate the nice log file.
-
-foreach my $timestamp (sort { $b cmp $a } keys %tag) {
- my $tag_rec = $tag{$timestamp};
-
- # Skip this tag if there are no log entries.
- next unless @{$tag_rec->[TAG_LOG]};
-
- my $tag_line = "$timestamp $tag_rec->[TAG_TAG]";
- my $tag_bar = "=" x length($tag_line);
- print $tag_bar, "\n", $tag_line, "\n", $tag_bar, "\n\n";
-
- foreach my $log_rec (@{$tag_rec->[TAG_LOG]}) {
-
- my @paths = @{$log_rec->[LOG_PATHS]};
- if (@paths > 1) {
- @paths = grep {
- $_->[PATH_PATH] ne "/trunk" or $_->[PATH_ACTION] ne "M"
- } @paths;
- }
-
- my $time_line = wrap(
- " ", " ",
- join(
- "; ",
- "$log_rec->[LOG_DATE] (r$log_rec->[LOG_REV]) by $log_rec->[LOG_WHO]",
- map { "$_->[PATH_PATH] $_->[PATH_ACTION]" } @paths
- )
- );
-
- if ($time_line =~ /\n/) {
- $time_line = wrap(
- " ", " ",
- "$log_rec->[LOG_DATE] (r$log_rec->[LOG_REV]) by $log_rec->[LOG_WHO]\n"
- ) .
- wrap(
- " ", " ",
- join(
- "; ",
- map { "$_->[PATH_PATH] $_->[PATH_ACTION]" } @paths
- )
- );
- }
-
- print $time_line, "\n\n";
-
- # Blank lines should have the indent level of whitespace. This
- # makes it easier for other utilities to parse them.
-
- my @paragraphs = split /\n\s*\n/, $log_rec->[LOG_MESSAGE];
- foreach my $paragraph (@paragraphs) {
-
- # Trim off identical leading space from every line.
- my ($whitespace) = $paragraph =~ /^(\s*)/;
- if (length $whitespace) {
- $paragraph =~ s/^$whitespace//mg;
- }
-
- # Re-flow the paragraph if it isn't indented from the norm.
- # This should preserve indented quoted text, wiki-style.
- unless ($paragraph =~ /^\s/) {
- $paragraph = fill(" ", " ", $paragraph);
- }
- }
-
- print join("\n \n", @paragraphs), "\n\n";
- }
-}
-
-print(
- "==============\n",
- "End of Excerpt\n",
- "==============\n",
-);
-
-### Z. Helper functions.
-
-sub gather_log {
- my ($url, @flags) = @_;
-
- my (@log, @stack);
-
- my $parser = XML::Parser->new(
- Handlers => {
- Start => sub {
- my ($self, $tag, %att) = @_;
- push @stack, [ $tag, \%att ];
- if ($tag eq "logentry") {
- push @log, [ ];
- $log[-1][LOG_WHO] = "(nobody)";
- }
- },
- Char => sub {
- my ($self, $text) = @_;
- $stack[-1][1]{0} .= $text;
- },
- End => sub {
- my ($self, $tag) = @_;
- die "close $tag w/out open" unless @stack;
- my ($pop_tag, $att) = @{pop @stack};
-
- die "$tag ne $pop_tag" if $tag ne $pop_tag;
-
- if ($tag eq "date") {
- my $timestamp = $att->{0};
- my ($date, $time) = split /[T.]/, $timestamp;
- $log[-1][LOG_DATE] = "$date $time";
- return;
- }
-
- if ($tag eq "logentry") {
- $log[-1][LOG_REV] = $att->{revision};
- return;
- }
-
- if ($tag eq "msg") {
- $log[-1][LOG_MESSAGE] = $att->{0};
- return;
- }
-
- if ($tag eq "author") {
- $log[-1][LOG_WHO] = $att->{0};
- return;
- }
-
- if ($tag eq "path") {
- my $path = $att->{0};
- $path =~ s{^/trunk/}{};
- push(
- @{$log[-1][LOG_PATHS]}, [
- $path, # PATH_PATH
- $att->{action}, # PATH_ACTION
- ]
- );
-
- $log[-1][LOG_PATHS][-1][PATH_CPF_PATH] = $att->{"copyfrom-path"} if (
- exists $att->{"copyfrom-path"}
- );
-
- $log[-1][LOG_PATHS][-1][PATH_CPF_REV] = $att->{"copyfrom-rev"} if (
- exists $att->{"copyfrom-rev"}
- );
- return;
- }
-
- }
- }
- );
-
- my $cmd = "svn -v --xml @flags log $url";
- #warn "Command: $cmd\n";
-
- open(LOG, "$cmd|") or die $!;
- $parser->parse(*LOG);
- close LOG;
-
- return @log;
-}
-#!/usr/bin/perl
+#!/usr/bin/env perl
use strict;
use warnings;
-#!/usr/bin/perl
-
use strict;
use warnings;
use Test::More;
-#!/usr/bin/perl
-
use strict;
use warnings;
use Test::More;
-#!/usr/bin/perl
-
use strict;
use warnings;
use Test::More;
use strict;
-use warnings;
+use warnings;
use Test::More;
use lib qw(t/lib);
-#!/usr/bin/perl
-
use strict;
use warnings;
use Test::More;
-#!/usr/bin/perl
-
use strict;
use warnings;
use Test::More;
-#!/usr/bin/perl
-
use strict;
use warnings;
use Test::More;
-#!/usr/bin/perl
-
use strict;
use warnings;
use Test::More;
-#!/usr/bin/perl
-
use strict;
use warnings;
use Test::More;
-#!/usr/bin/perl
-
use strict;
use warnings;
-#!/usr/bin/perl
-
use strict;
use warnings;
use Test::More;
use warnings;
use Test::More;
-use Test::Exception;
use Config;
-
-# README: If you set the env var to a number greater than 10,
-# we will use that many children
-
BEGIN {
plan skip_all => 'Your perl does not support ithreads'
if !$Config{useithreads};
}
use threads;
+use Test::Exception;
+use lib qw(t/lib);
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};
plan skip_all => 'Set $ENV{DBICTEST_THREAD_STRESS} to run this test'
unless $num_children;
-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);
-
-diag 'It is normal to see a series of "Scalars leaked: ..." messages during this test';
-
if($num_children !~ /^[0-9]+$/ || $num_children < 10) {
$num_children = 10;
}
-plan tests => $num_children + 5;
-
-use lib qw(t/lib);
+diag 'It is normal to see a series of "Scalars leaked: ..." warnings during this test';
use_ok('DBICTest::Schema');
-
my $schema = DBICTest::Schema->connection($dsn, $user, $pass, { AutoCommit => 1, RaiseError => 1, PrintError => 0 });
my $parent_rs;
ok(1, "Made it to the end");
$schema->storage->dbh->do("DROP TABLE cd");
+
+done_testing;
}
use threads;
+use lib qw(t/lib);
my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/};
-my $num_children = $ENV{DBICTEST_THREAD_STRESS};
-
-plan skip_all => 'Set $ENV{DBICTEST_THREAD_STRESS} to run this test'
- unless $num_children;
-
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);
-diag 'It is normal to see a series of "Scalars leaked: ..." messages during this test';
+
+my $num_children = $ENV{DBICTEST_THREAD_STRESS};
+plan skip_all => 'Set $ENV{DBICTEST_THREAD_STRESS} to run this test'
+ unless $num_children;
if($num_children !~ /^[0-9]+$/ || $num_children < 10) {
$num_children = 10;
}
-plan tests => $num_children + 5;
-
-use lib qw(t/lib);
+diag 'It is normal to see a series of "Scalars leaked: ..." warnings during this test';
use_ok('DBICTest::Schema');
ok(1, "Made it to the end");
$schema->storage->dbh->do("DROP TABLE cd");
+
+done_testing;
-#!perl -T
+#!/usr/bin/env perl -T
# the above line forces Test::Harness into taint-mode
+# DO NOT REMOVE
use strict;
use warnings;
use Test::More;
-BEGIN { plan tests => 7 }
+use Test::Exception;
+use lib qw(t/lib);
-package DBICTest::Taint::Classes;
+throws_ok (
+ sub { $ENV{PATH} . (kill (0)) },
+ qr/Insecure dependency in kill/,
+ 'taint mode active'
+);
-use Test::More;
-use Test::Exception;
+{
+ package DBICTest::Taint::Classes;
-use lib qw(t/lib);
-use base qw/DBIx::Class::Schema/;
+ use Test::More;
+ use Test::Exception;
-lives_ok (sub {
- __PACKAGE__->load_classes(qw/Manual/);
- ok( __PACKAGE__->source('Manual'), 'The Classes::Manual source has been registered' );
- __PACKAGE__->_unregister_source (qw/Manual/);
-}, 'Loading classes with explicit load_classes worked in taint mode' );
+ use base qw/DBIx::Class::Schema/;
-lives_ok (sub {
- __PACKAGE__->load_classes();
- ok( __PACKAGE__->source('Auto'), 'The Classes::Auto source has been registered' );
- ok( __PACKAGE__->source('Auto'), 'The Classes::Manual source has been re-registered' );
-}, 'Loading classes with Module::Find/load_classes worked in taint mode' );
+ lives_ok (sub {
+ __PACKAGE__->load_classes(qw/Manual/);
+ ok( __PACKAGE__->source('Manual'), 'The Classes::Manual source has been registered' );
+ __PACKAGE__->_unregister_source (qw/Manual/);
+ }, 'Loading classes with explicit load_classes worked in taint mode' );
+ lives_ok (sub {
+ __PACKAGE__->load_classes();
+ ok( __PACKAGE__->source('Auto'), 'The Classes::Auto source has been registered' );
+ ok( __PACKAGE__->source('Auto'), 'The Classes::Manual source has been re-registered' );
+ }, 'Loading classes with Module::Find/load_classes worked in taint mode' );
+}
-package DBICTest::Taint::Namespaces;
+{
+ package DBICTest::Taint::Namespaces;
-use Test::More;
-use Test::Exception;
+ use Test::More;
+ use Test::Exception;
-use lib qw(t/lib);
-use base qw/DBIx::Class::Schema/;
+ use base qw/DBIx::Class::Schema/;
-lives_ok (sub {
- __PACKAGE__->load_namespaces();
- ok( __PACKAGE__->source('Test'), 'The Namespaces::Test source has been registered' );
-}, 'Loading classes with Module::Find/load_namespaces worked in taint mode' );
+ lives_ok (sub {
+ __PACKAGE__->load_namespaces();
+ ok( __PACKAGE__->source('Test'), 'The Namespaces::Test source has been registered' );
+ }, 'Loading classes with Module::Find/load_namespaces worked in taint mode' );
+}
-1;
+done_testing;
$schema1_dbh->do("GRANT INSERT ON artist TO $user2");
$schema1_dbh->do("GRANT SELECT ON artist_seq TO $user2");
- my $rs = $schema2->resultset('Artist');
+ my $rs = $schema2->resultset('ArtistFQN');
- # qualify table with schema
- local $rs->result_source->{name} = "${user}.artist";
+ # first test with unquoted (default) sequence name in trigger body
lives_and {
my $row = $rs->create({ name => 'From Different Schema' });
ok $row->artistid;
} 'used autoinc sequence across schemas';
+
+ # now quote the sequence name
+
+ $schema1_dbh->do(qq{
+ CREATE OR REPLACE TRIGGER artist_insert_trg
+ BEFORE INSERT ON artist
+ FOR EACH ROW
+ BEGIN
+ IF :new.artistid IS NULL THEN
+ SELECT "ARTIST_SEQ".nextval
+ INTO :new.artistid
+ FROM DUAL;
+ END IF;
+ END;
+ });
+
+ # sequence is cached in the rsrc
+ delete $rs->result_source->column_info('artistid')->{sequence};
+
+ lives_and {
+ my $row = $rs->create({ name => 'From Different Schema With Quoted Sequence' });
+ ok $row->artistid;
+ } 'used quoted autoinc sequence across schemas';
+
+ my $schema_name = uc $user;
+
+ is $rs->result_source->column_info('artistid')->{sequence},
+ qq[${schema_name}."ARTIST_SEQ"],
+ 'quoted sequence name correctly extracted';
}
done_testing;
use warnings;
use Test::More;
+use Test::Exception;
use lib qw(t/lib);
use DBICTest;
use DBIC::SqlMakerTest;
[ 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';
$schema->storage->debugobj(undef);
}
+{
+ 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';
+}
+
+
done_testing;
+
-#!/usr/bin/perl
-
use strict;
use warnings;
use Test::More;
eval {JSON::Any->import ($js) };
SKIP: {
- skip ("Json backend $js is not available, skip testing", $tests_per_run) if $@;
+ skip ("JSON backend $js is not available, skip testing", $tests_per_run) if $@;
$ENV{JSON_ANY_ORDER} = $js;
eval { test_dbicadmin () };
SKIP: {
skip ("MSWin32 doesn't support -| either", 1) if $^O eq 'MSWin32';
- open(my $fh, "-|", ( 'script/dbicadmin', default_args(), qw|--op=select --attrs={"order_by":"name"}| ) ) or die $!;
+ open(my $fh, "-|", ( $^X, '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" )) {
-#!/usr/bin/perl -w
-
use strict;
+use warnings;
use Test::More;
use Test::Warn;
-#!/usr/bin/perl
-
use strict;
use warnings;
use Test::More;
-plan ( tests => 1 );
-
use lib qw(t/lib);
use DBICTest;
use DBIC::SqlMakerTest;
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;
-#!/usr/bin/perl -w
-
use strict;
-use warnings;
+use warnings;
use Test::More;
use lib qw(t/lib);
my $schema = DBICTest->init_schema();
-plan tests => 5;
-
my $cd = $schema->resultset("CD")->find(2);
ok $cd->liner_notes;
ok keys %{$cd->{_relationship_data}}, "_relationship_data populated";
ok $cd->liner_notes->delete;
$cd->discard_changes;
-ok !$cd->liner_notes, 'discard_changes resets relationship';
\ No newline at end of file
+ok !$cd->liner_notes, 'discard_changes resets relationship';
+
+done_testing;
-#!/usr/bin/perl -w
-
use strict;
-use warnings;
+use warnings;
use Test::More;
use lib qw(t/lib);
my $schema = DBICTest->init_schema();
-plan tests => 1;
-
{
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, [];
-}
\ No newline at end of file
+}
+
+done_testing;
);
__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' );
1;
-#!/usr/bin/perl
-
use strict;
use warnings;
use Test::More;
unshift(@INC, './t/lib');
use lib 't/lib';
-plan tests => 5;
use DBICTest;
my $schema = DBICTest->init_schema;
my $resultset = $schema->resultset('Artist')->search;
isa_ok($resultset, 'DBICNSTest::ResultSet::A', 'resultset is custom class');
+
+done_testing;
use strict;
-use warnings;
+use warnings;
use Test::More;
use lib qw(t/lib);
my $schema = DBICTest->init_schema();
-plan tests => 6;
-
{
my $rs = $schema->resultset("CD")->search({});
{
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";
-}
\ No newline at end of file
+}
+
+done_testing;
-#!/usr/bin/perl
-
use strict;
use warnings;
'Rownum subsel aliasing works correctly'
);
+is_same_sql_bind (
+ $rs->search ({}, { rows => 1, offset => 3,columns => [
+ { id => 'foo.id' },
+ { 'ends_with_me.id' => 'ends_with_me.id' },
+ ]})->as_query,
+ '(SELECT id, ends_with_me__id
+ FROM (
+ SELECT id, ends_with_me__id, ROWNUM rownum__index
+ FROM (
+ SELECT foo.id AS id, ends_with_me.id AS ends_with_me__id
+ FROM cd me
+ ) me
+ ) me
+ WHERE rownum__index BETWEEN 4 AND 4
+ )',
+ [],
+ 'Rownum subsel aliasing works correctly'
+);
+
done_testing;
-#!/usr/bin/perl
-
use strict;
use warnings;
use strict;
-use warnings;
+use warnings;
use Test::More;
use lib qw(t/lib);
-#!/usr/bin/perl
use strict;
use warnings;
use lib qw(t/lib);
use strict;
-use warnings;
+use warnings;
use Test::More;
use lib qw(t/lib);
use strict;
-use warnings;
+use warnings;
use Test::More;
use lib qw(t/lib);
-#!/usr/bin/perl
-
use strict;
use warnings;
use strict;
-use warnings;
+use warnings;
use Test::More;
use lib qw(t/lib);
use strict;
-use warnings;
+use warnings;
use FindBin;
use File::Copy;
use Moose();
use MooseX::Types();
-diag "Using Moose version $Moose::VERSION and MooseX::Types version $MooseX::Types::VERSION";
+note "Using Moose version $Moose::VERSION and MooseX::Types version $MooseX::Types::VERSION";
=head1 HOW TO USE
-#!/usr/bin/perl
-
use strict;
use warnings;
use Test::More;
projects / dbsrgits/DBIx-Class.git / commitdiff