resources 'IRC' => 'irc://irc.perl.org/#dbix-class';
resources 'license' => 'http://dev.perl.org/licenses/';
-resources 'repository' => 'http://dev.catalyst.perl.org/svnweb/bast/browse/DBIx-Class/';
+resources 'repository' => 'http://dev.catalyst.perl.org/repos/bast/DBIx-Class/';
resources 'MailingList' => 'http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/dbix-class';
no_index 'DBIx::Class::Storage::DBI::Sybase::Common';
} else {
my ($first, @rest) = @$data;
+ require overload;
my @names = grep {
- (not ref $first->{$_}) || (ref $first->{$_} eq 'SCALAR')
+ (not ref $first->{$_}) || (ref $first->{$_} eq 'SCALAR') ||
+ (overload::Method($first->{$_}, '""'))
} keys %$first;
my @rels = grep { $self->result_source->has_relationship($_) } keys %$first;
my $self = shift;
$self->throw_exception(
"columns() is a read-only accessor, did you mean add_columns()?"
- ) if (@_ > 1);
+ ) if @_;
return @{$self->{_ordered_columns}||[]};
}
next unless ref $first_val eq 'SCALAR';
$colvalues{ $cols->[$i] } = $first_val;
-## This is probably unnecessary since $rs->populate only looks at the first
-## slice anyway.
-# if (grep {
-# ref $_ eq 'SCALAR' && $$_ eq $$first_val
-# } map $data->[$_][$i], (1..$#$data)) == (@$data - 1);
}
- # check for bad data
+ # check for bad data and stringify stringifiable objects
my $bad_slice = sub {
- my ($msg, $slice_idx) = @_;
- $self->throw_exception(sprintf "%s for populate slice:\n%s",
+ my ($msg, $col_idx, $slice_idx) = @_;
+ $self->throw_exception(sprintf "%s for column '%s' in populate slice:\n%s",
$msg,
- Data::Dumper::Concise::Dumper({
- map { $cols->[$_] => $data->[$slice_idx][$_] } (0 .. $#$cols)
- }),
+ $cols->[$col_idx],
+ do {
+ local $Data::Dumper::Maxdepth = 1; # don't dump objects, if any
+ Data::Dumper::Concise::Dumper({
+ map { $cols->[$_] => $data->[$slice_idx][$_] } (0 .. $#$cols)
+ }),
+ }
);
};
if ($is_literal_sql) {
if (not ref $val) {
- $bad_slice->('bind found where literal SQL expected', $datum_idx);
+ $bad_slice->('bind found where literal SQL expected', $col_idx, $datum_idx);
}
elsif ((my $reftype = ref $val) ne 'SCALAR') {
$bad_slice->("$reftype reference found where literal SQL expected",
- $datum_idx);
+ $col_idx, $datum_idx);
}
elsif ($$val ne $$sqla_bind){
$bad_slice->("inconsistent literal SQL value, expecting: '$$sqla_bind'",
- $datum_idx);
+ $col_idx, $datum_idx);
}
}
elsif (my $reftype = ref $val) {
- $bad_slice->("$reftype reference found where bind expected",
- $datum_idx);
+ require overload;
+ if (overload::Method($val, '""')) {
+ $datum->[$col_idx] = "".$val;
+ }
+ else {
+ $bad_slice->("$reftype reference found where bind expected",
+ $col_idx, $datum_idx);
+ }
}
}
}
);
}
- $self->_query_start( $sql, @bind );
+ $self->_query_start( $sql, ['__BULK__'] );
my $sth = $self->sth($sql);
my $rv = do {
}
};
- $self->_query_end( $sql, @bind );
+ $self->_query_end( $sql, ['__BULK__'] );
return (wantarray ? ($rv, $sth, @bind) : $rv);
}
parser => 'SQL::Translator::Parser::DBIx::Class',
data => $schema,
);
- return $tr->translate;
+
+ my $ret = $tr->translate
+ or $self->throw_exception( 'Unable to produce deployment statements: ' . $tr->error);
+
+ return $ret;
}
sub deploy {
# if no default value is set on the column, or if we can't parse the
# default value as a sequence, throw.
- unless ( defined $seq_expr and $seq_expr =~ /^nextval\(+'([^']+)'::(?:text|regclass)\)/i ){
+ unless ( defined $seq_expr and $seq_expr =~ /^nextval\(+'([^']+)'::(?:text|regclass)\)/i ) {
$seq_expr = '' unless defined $seq_expr;
$schema = "$schema." if defined $schema && length $schema;
$self->throw_exception( "no sequence found for $schema$table.$col, check table definition, "
return $backupfile;
}
+sub deployment_statements {
+ my $self = shift;;
+ my ($schema, $type, $version, $dir, $sqltargs, @rest) = @_;
+
+ $sqltargs ||= {};
+
+ my $sqlite_version = $self->_get_dbh->{sqlite_version};
+
+ # numify, SQLT does a numeric comparison
+ $sqlite_version =~ s/^(\d+) \. (\d+) (?: \. (\d+))? .*/${1}.${2}/x;
+
+ $sqltargs->{producer_args}{sqlite_version} = $sqlite_version;
+
+ $self->next::method($schema, $type, $version, $dir, $sqltargs, @rest);
+}
+
sub datetime_parser_type { return "DateTime::Format::SQLite"; }
1;
if ($fk_constraint) {
$cascade->{$c} = $rel_info->{attrs}{"on_$c"};
}
- else {
+ 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";
}
use Test::Exception;
use lib qw(t/lib);
use DBICTest;
+use Path::Class::File ();
my $schema = DBICTest->init_schema();
is($link7->url, undef, 'Link 7 url');
is($link7->title, 'gtitle', 'Link 7 title');
-# test _execute_array_empty (insert_bulk with all literal sql)
my $rs = $schema->resultset('Artist');
$rs->delete;
+
+# test _execute_array_empty (insert_bulk with all literal sql)
+
$rs->populate([
(+{
name => \"'DT'",
$rs->delete;
+# test mixed binds with literal sql
+
+$rs->populate([
+ (+{
+ name => \"'DT'",
+ rank => 500,
+ charfield => \"'mtfnpy'",
+ }) x 5
+]);
+
+is((grep {
+ $_->name eq 'DT' &&
+ $_->rank == 500 &&
+ $_->charfield eq 'mtfnpy'
+} $rs->all), 5, 'populate with all literal SQL');
+
+$rs->delete;
+
+###
+
throws_ok {
$rs->populate([
{
]);
} qr/inconsistent/, 'literal sql must be the same in all slices';
+# 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');
+
+lives_ok {
+ $rs->populate([
+ {
+ name => 'supplied before stringifying object',
+ },
+ {
+ name => $fn,
+ }
+ ]);
+} 'stringifying objects pass through';
+
+# ... and vice-versa.
+
+lives_ok {
+ $rs->populate([
+ {
+ name => $fn2,
+ },
+ {
+ name => 'supplied after stringifying object',
+ },
+ ]);
+} 'stringifying objects pass through';
+
+for (
+ $fn,
+ $fn2,
+ 'supplied after stringifying object',
+ 'supplied before stringifying object'
+) {
+ my $row = $rs->find ({name => $_});
+ ok ($row, "Stringification test row '$_' properly inserted");
+}
+
+$rs->delete;
+
+# test stringification with ->create rather than Storage::insert_bulk as well
+
+lives_ok {
+ my @dummy = $rs->populate([
+ {
+ name => 'supplied before stringifying object',
+ },
+ {
+ name => $fn,
+ }
+ ]);
+} 'stringifying objects pass through';
+
+# ... and vice-versa.
+
+lives_ok {
+ my @dummy = $rs->populate([
+ {
+ name => $fn2,
+ },
+ {
+ name => 'supplied after stringifying object',
+ },
+ ]);
+} 'stringifying objects pass through';
+
+for (
+ $fn,
+ $fn2,
+ 'supplied after stringifying object',
+ 'supplied before stringifying object'
+) {
+ my $row = $rs->find ({name => $_});
+ ok ($row, "Stringification test row '$_' properly inserted");
+}
+
done_testing;
sub init_schema {
# current SQLT SQLite producer does not handle DROP TABLE IF EXISTS, trap warnings here
- local $SIG{__WARN__} = sub { warn @_ unless $_[0] =~ /no such table.+DROP TABLE/ };
+ local $SIG{__WARN__} = sub { warn @_ unless $_[0] =~ /no such table.+DROP TABLE/s };
my ($class, $schema_method) = @_;
use DBICTest::Schema;
plan tests => 2;
-my $wait_for = 10; # how many seconds to wait
+my $wait_for = 30; # how many seconds to wait
for my $close (0,1) {