foreach my $first_comp (@comps) {
if ($to eq 'DBIx::Class::Core' &&
$target->isa("DBIx::Class::${first_comp}")) {
- warn "Possible incorrect order of components in ".
+ carp "Possible incorrect order of components in ".
"${target}::load_components($first_comp) call: Core loaded ".
"before $first_comp. See the documentation for ".
"DBIx::Class::$first_comp for more information";
use strict;
use warnings;
use base qw/DBIx::Class/;
+use Carp::Clan qw/^DBIx::Class/;
=head1 NAME
my $timezone;
if ( defined $info->{extra}{timezone} ) {
- warn "Putting timezone into extra => { timezone => '...' } has been deprecated, ".
+ carp "Putting timezone into extra => { timezone => '...' } has been deprecated, ".
"please put it directly into the columns definition.";
$timezone = $info->{extra}{timezone};
}
my $locale;
if ( defined $info->{extra}{locale} ) {
- warn "Putting locale into extra => { locale => '...' } has been deprecated, ".
+ carp "Putting locale into extra => { locale => '...' } has been deprecated, ".
"please put it directly into the columns definition.";
$locale = $info->{extra}{locale};
}
my %info = ( '_ic_dt_method' => $type , %{ $info } );
if (defined $info->{extra}{floating_tz_ok}) {
- warn "Putting floating_tz_ok into extra => { floating_tz_ok => 1 } has been deprecated, ".
+ carp "Putting floating_tz_ok into extra => { floating_tz_ok => 1 } has been deprecated, ".
"please put it directly into the columns definition.";
$info{floating_tz_ok} = $info->{extra}{floating_tz_ok};
}
inflate => sub {
my ($value, $obj) = @_;
my $dt = eval { $obj->_inflate_to_datetime( $value, \%info ) };
- die "Error while inflating ${value} for ${column} on ${self}: $@"
+ $self->throw_exception ("Error while inflating ${value} for ${column} on ${self}: $@")
if $@ and not $undef_if_invalid;
$dt->set_time_zone($timezone) if $timezone;
$dt->set_locale($locale) if $locale;
deflate => sub {
my ($value, $obj) = @_;
if ($timezone) {
- warn "You're using a floating timezone, please see the documentation of"
+ carp "You're using a floating timezone, please see the documentation of"
. " DBIx::Class::InflateColumn::DateTime for an explanation"
if ref( $value->time_zone ) eq 'DateTime::TimeZone::Floating'
and not $info{floating_tz_ok}
if($rs_set && $rs_set ne 'DBIx::Class::ResultSet') {
if($rs_class && $rs_class ne $rs_set) {
- warn "We found ResultSet class '$rs_class' for '$result', but it seems "
+ carp "We found ResultSet class '$rs_class' for '$result', but it seems "
. "that you had already set '$result' to use '$rs_set' instead";
}
}
}
foreach (sort keys %resultsets) {
- warn "load_namespaces found ResultSet class $_ with no "
+ carp "load_namespaces found ResultSet class $_ with no "
. 'corresponding Result class';
}
my $snsub = $comp_class->can('source_name');
if(! $snsub ) {
- warn "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.";
+ 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;
sub compose_connection {
my ($self, $target, @info) = @_;
- warn "compose_connection deprecated as of 0.08000"
+ carp "compose_connection deprecated as of 0.08000"
unless ($INC{"DBIx/Class/CDBICompat.pm"} || $warn++);
my $base = 'DBIx::Class::ResultSetProxy';
use strict;
use warnings;
use base 'DBIx::Class';
+
+use Carp::Clan qw/^DBIx::Class/;
use POSIX 'strftime';
__PACKAGE__->mk_classdata('_filedata');
# must be called on a fresh database
if ($self->get_db_version()) {
- warn 'Install not possible as versions table already exists in database';
+ carp 'Install not possible as versions table already exists in database';
}
# default to current version if none passed
# db unversioned
unless ($db_version) {
- warn 'Upgrade not possible as database is unversioned. Please call install first.';
+ 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) {
- print "Upgrade not necessary\n";
+ carp "Upgrade not necessary\n";
return;
}
$self->create_upgrade_path({ upgrade_file => $upgrade_file });
unless (-f $upgrade_file) {
- warn "Upgrade not possible, no upgrade file found ($upgrade_file), please create one\n";
+ carp "Upgrade not possible, no upgrade file found ($upgrade_file), please create one\n";
return;
}
- warn "\nDB version ($db_version) is lower than the schema version (".$self->schema_version."). Attempting upgrade.\n";
+ carp "\nDB 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));
sub apply_statement {
my ($self, $statement) = @_;
- $self->storage->dbh->do($_) or warn "SQL was:\n $_";
+ $self->storage->dbh->do($_) or carp "SQL was:\n $_";
}
=head2 get_db_version
if($pversion eq $self->schema_version)
{
-# warn "This version is already installed\n";
+# carp "This version is already installed\n";
return 1;
}
if(!$pversion)
{
- warn "Your DB is currently unversioned. Please call upgrade on your schema to sync the DB.\n";
+ carp "Your DB is currently unversioned. Please call upgrade on your schema to sync the DB.\n";
return 1;
}
- warn "Versions out of sync. This is " . $self->schema_version .
+ carp "Versions out of sync. This is " . $self->schema_version .
", your database contains version $pversion, please call upgrade on your Schema.\n";
}
print $file $diff;
close($file);
- print "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.\n";
+ 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.\n";
}
my $file = shift || return;
my $fh;
- open $fh, "<$file" or warn("Can't open upgrade file, $file ($!)");
+ open $fh, "<$file" or carp("Can't open upgrade file, $file ($!)");
my @data = split(/\n/, join('', <$fh>));
@data = grep(!/^--/, @data);
@data = split(/;/, join('', @data));
my ($self, $schema, $databases, $version, $dir, $preversion, $sqltargs) = @_;
if(!$dir || !-d $dir) {
- warn "No directory given, using ./\n";
+ carp "No directory given, using ./\n";
$dir = "./";
}
$databases ||= ['MySQL', 'SQLite', 'PostgreSQL'];
my $sqlt = SQL::Translator->new( $sqltargs );
$sqlt->parser('SQL::Translator::Parser::DBIx::Class');
- my $sqlt_schema = $sqlt->translate({ data => $schema }) or die $sqlt->error;
+ my $sqlt_schema = $sqlt->translate({ data => $schema })
+ or $self->throw_exception ($sqlt->error);
foreach my $db (@$databases) {
$sqlt->reset();
my $filename = $schema->ddl_filename($db, $version, $dir);
if (-e $filename && ($version eq $schema_version )) {
# if we are dumping the current version, overwrite the DDL
- warn "Overwriting existing DDL file - $filename";
+ carp "Overwriting existing DDL file - $filename";
unlink($filename);
}
my $output = $sqlt->translate;
if(!$output) {
- warn("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
+ carp("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
next;
}
if(!open($file, ">$filename")) {
my $prefilename = $schema->ddl_filename($db, $preversion, $dir);
if(!-e $prefilename) {
- warn("No previous schema file found ($prefilename)");
+ carp("No previous schema file found ($prefilename)");
next;
}
my $difffile = $schema->ddl_filename($db, $version, $dir, $preversion);
if(-e $difffile) {
- warn("Overwriting existing diff file - $difffile");
+ carp("Overwriting existing diff file - $difffile");
unlink($difffile);
}
my $t = SQL::Translator->new($sqltargs);
$t->debug( 0 );
$t->trace( 0 );
- $t->parser( $db ) or die $t->error;
- my $out = $t->translate( $prefilename ) or die $t->error;
+
+ $t->parser( $db )
+ or $self->throw_exception ($t->error);
+
+ my $out = $t->translate( $prefilename )
+ or $self->throw_exception ($t->error);
+
$source_schema = $t->schema;
- unless ( $source_schema->name ) {
- $source_schema->name( $prefilename );
- }
+
+ $source_schema->name( $prefilename )
+ unless ( $source_schema->name );
}
# The "new" style of producers have sane normalization and can support
# diffing a SQL file against a DBIC->SQLT schema. Old style ones don't
# And we have to diff parsed SQL against parsed SQL.
my $dest_schema = $sqlt_schema;
-
+
unless ( "SQL::Translator::Producer::$db"->can('preprocess_schema') ) {
my $t = SQL::Translator->new($sqltargs);
$t->debug( 0 );
$t->trace( 0 );
- $t->parser( $db ) or die $t->error;
- my $out = $t->translate( $filename ) or die $t->error;
+
+ $t->parser( $db )
+ or $self->throw_exception ($t->error);
+
+ my $out = $t->translate( $filename )
+ or $self->throw_exception ($t->error);
+
$dest_schema = $t->schema;
+
$dest_schema->name( $filename )
unless $dest_schema->name;
}
$self->dbh->do($line); # shouldn't be using ->dbh ?
};
if ($@) {
- warn qq{$@ (running "${line}")};
+ carp qq{$@ (running "${line}")};
}
$self->_query_end($line);
};
# should overwrite files and warn about it
my @w;
local $SIG{__WARN__} = sub {
- if ($_[0] =~ /^Overwriting/) {
+ if ($_[0] =~ /Overwriting existing/) {
push @w, $_[0];
}
else {
$schema_upgrade->create_ddl_dir('MySQL', '2.0', $ddl_dir, '1.0');
is (2, @w, 'A warning generated for both the DDL and the diff');
- like ($w[0], qr/^Overwriting existing DDL file - $fn->{v2}/, 'New version DDL overwrite warning');
- like ($w[1], qr/^Overwriting existing diff file - $fn->{trans}/, 'Upgrade diff overwrite warning');
+ like ($w[0], qr/Overwriting existing DDL file - $fn->{v2}/, 'New version DDL overwrite warning');
+ like ($w[1], qr/Overwriting existing diff file - $fn->{trans}/, 'Upgrade diff overwrite warning');
}
{
projects / dbsrgits/DBIx-Class.git / commitdiff