From: Peter Rabbitson <ribasushi@cpan.org>
Date: Tue, 12 May 2009 08:20:08 +0000 (+0000)
Subject: Switch warn to carp and die to throw_exception where possible
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=341d5edefa34c7cdfee74be00eba9cd44ad2b7c4;p=dbsrgits%2FDBIx-Class-Historic.git

Switch warn to carp and die to throw_exception where possible
---

diff --git a/lib/DBIx/Class/Componentised.pm b/lib/DBIx/Class/Componentised.pm
index cc6c8c0..7b4cb1f 100644
--- a/lib/DBIx/Class/Componentised.pm
+++ b/lib/DBIx/Class/Componentised.pm
@@ -17,7 +17,7 @@ sub inject_base {
       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";
diff --git a/lib/DBIx/Class/InflateColumn/DateTime.pm b/lib/DBIx/Class/InflateColumn/DateTime.pm
index 02aec53..5b1b313 100644
--- a/lib/DBIx/Class/InflateColumn/DateTime.pm
+++ b/lib/DBIx/Class/InflateColumn/DateTime.pm
@@ -3,6 +3,7 @@ package DBIx::Class::InflateColumn::DateTime;
 use strict;
 use warnings;
 use base qw/DBIx::Class/;
+use Carp::Clan qw/^DBIx::Class/;
 
 =head1 NAME
 
@@ -110,14 +111,14 @@ sub register_column {
 
   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};
   }
@@ -133,7 +134,7 @@ sub register_column {
     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};
     }
@@ -144,7 +145,7 @@ sub register_column {
           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;
@@ -153,7 +154,7 @@ sub register_column {
           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}
diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm
index 71faab7..63bff46 100644
--- a/lib/DBIx/Class/Schema.pm
+++ b/lib/DBIx/Class/Schema.pm
@@ -235,7 +235,7 @@ sub load_namespaces {
       
       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";
         }
       }
@@ -251,7 +251,7 @@ sub load_namespaces {
   }
 
   foreach (sort keys %resultsets) {
-    warn "load_namespaces found ResultSet class $_ with no "
+    carp "load_namespaces found ResultSet class $_ with no "
       . 'corresponding Result class';
   }
 
@@ -344,7 +344,7 @@ sub load_classes {
 
         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;
@@ -1350,7 +1350,7 @@ more information.
   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';
diff --git a/lib/DBIx/Class/Schema/Versioned.pm b/lib/DBIx/Class/Schema/Versioned.pm
index 39ea774..4e92def 100644
--- a/lib/DBIx/Class/Schema/Versioned.pm
+++ b/lib/DBIx/Class/Schema/Versioned.pm
@@ -181,6 +181,8 @@ package DBIx::Class::Schema::Versioned;
 use strict;
 use warnings;
 use base 'DBIx::Class';
+
+use Carp::Clan qw/^DBIx::Class/;
 use POSIX 'strftime';
 
 __PACKAGE__->mk_classdata('_filedata');
@@ -225,7 +227,7 @@ sub install
 
   # 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
@@ -291,13 +293,13 @@ sub upgrade
 
   # 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;
   }
 
@@ -317,11 +319,11 @@ sub upgrade
   $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));
@@ -391,7 +393,7 @@ differently.
 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
@@ -490,17 +492,17 @@ sub _on_connect
 
   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";
 }
 
@@ -563,7 +565,7 @@ sub _create_db_to_schema_diff {
   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";
 }
 
 
@@ -585,7 +587,7 @@ sub _read_sql_file {
   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));
diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm
index 7cb026d..8df1894 100644
--- a/lib/DBIx/Class/Storage/DBI.pm
+++ b/lib/DBIx/Class/Storage/DBI.pm
@@ -1302,7 +1302,7 @@ sub create_ddl_dir {
   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'];
@@ -1325,7 +1325,8 @@ sub create_ddl_dir {
   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();
@@ -1336,13 +1337,13 @@ sub create_ddl_dir {
     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")) {
@@ -1358,13 +1359,13 @@ sub create_ddl_dir {
 
     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);
     }
     
@@ -1373,26 +1374,37 @@ sub create_ddl_dir {
       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;
     }
@@ -1484,7 +1496,7 @@ sub deploy {
       $self->dbh->do($line); # shouldn't be using ->dbh ?
     };
     if ($@) {
-      warn qq{$@ (running "${line}")};
+      carp qq{$@ (running "${line}")};
     }
     $self->_query_end($line);
   };
diff --git a/t/94versioning.t b/t/94versioning.t
index 298e0c8..d62f117 100644
--- a/t/94versioning.t
+++ b/t/94versioning.t
@@ -85,7 +85,7 @@ my $schema_upgrade = DBICVersion::Schema->connect($dsn, $user, $pass, { ignore_v
   # should overwrite files and warn about it
   my @w;
   local $SIG{__WARN__} = sub { 
-    if ($_[0] =~ /^Overwriting/) {
+    if ($_[0] =~ /Overwriting existing/) {
       push @w, $_[0];
     }
     else {
@@ -95,8 +95,8 @@ my $schema_upgrade = DBICVersion::Schema->connect($dsn, $user, $pass, { ignore_v
   $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');
 }
 
 {