Fixed rt.cpan.org #22425 (use File::Spec where appropriate)

[dbsrgits/DBIx-Class-Schema-Loader.git] / lib / DBIx / Class / Schema / Loader / Base.pm

diff --git a/lib/DBIx/Class/Schema/Loader/Base.pm b/lib/DBIx/Class/Schema/Loader/Base.pm
index d4a7918..6b89a29 100644 (file)
--- a/lib/DBIx/Class/Schema/Loader/Base.pm
+++ b/lib/DBIx/Class/Schema/Loader/Base.pm
@@ -9,6 +9,7 @@ use UNIVERSAL::require;
 use DBIx::Class::Schema::Loader::RelBuilder;
 use Data::Dump qw/ dump /;
 use POSIX qw//;
+use File::Spec qw//;
 require DBIx::Class;
 
 __PACKAGE__->mk_ro_accessors(qw/
@@ -176,8 +177,8 @@ recommended way to access this functionality.
 =head2 dump_overwrite
 
 If set to a true value, the dumping code will overwrite existing files.
-The default is false, which means the dumping code will die if it encounters
-an existing file.
+The default is false, which means the dumping code will skip the already
+existing files.
 
 =head1 DEPRECATED CONSTRUCTOR OPTIONS
 
@@ -263,6 +264,11 @@ sub new {
 sub _load_external {
     my $self = shift;
 
+    my $abs_dump_dir;
+
+    $abs_dump_dir = File::Spec->rel2abs($self->dump_directory)
+        if $self->dump_directory;
+
     foreach my $table_class (values %{$self->classes}) {
         $table_class->require;
         if($@ && $@ !~ /^Can't locate /) {
@@ -275,14 +281,15 @@ sub _load_external {
         warn qq/# Loaded external class definition for '$table_class'\n/
             if $self->debug;
 
-        if($self->dump_directory) {
+        if($abs_dump_dir) {
             my $class_path = $table_class;
             $class_path =~ s{::}{/}g;
             $class_path .= '.pm';
-            my $filename = $INC{$class_path};
+            my $filename = File::Spec->rel2abs($INC{$class_path});
             croak 'Failed to locate actual external module file for '
                   . "'$table_class'"
                       if !$filename;
+            next if($filename =~ /^$abs_dump_dir/);
             open(my $fh, '<', $filename)
                 or croak "Failed to open $filename for reading: $!";
             $self->_raw_stmt($table_class,
@@ -332,10 +339,12 @@ sub _ensure_dump_subdirs {
     my ($self, $class) = (@_);
 
     my @name_parts = split(/::/, $class);
-    pop @name_parts;
+    pop @name_parts; # we don't care about the very last element,
+                     # which is a filename
+
     my $dir = $self->dump_directory;
     foreach (@name_parts) {
-        $dir .= q{/} . $_;
+        $dir = File::Spec->catdir($dir,$_);
         if(! -d $dir) {
             mkdir($dir) or croak "mkdir('$dir') failed: $!";
         }
@@ -364,23 +373,28 @@ sub _dump_to_dir {
     $self->_ensure_dump_subdirs($schema_class);
 
     my $schema_fn = $self->_get_dump_filename($schema_class);
-    croak "$schema_fn exists, will not overwrite"
-        if -f $schema_fn && !$self->dump_overwrite;
-    open(my $schema_fh, '>', $schema_fn)
-        or croak "Cannot open $schema_fn for writing: $!";
-    print $schema_fh qq|package $schema_class;\n\n$tagline\n\n|;
-    print $schema_fh qq|use strict;\nuse warnings;\n\n|;
-    print $schema_fh qq|use base 'DBIx::Class::Schema';\n\n|;
-    print $schema_fh qq|__PACKAGE__->load_classes;\n|;
-    print $schema_fh qq|\n1;\n\n|;
-    close($schema_fh)
-        or croak "Cannot close $schema_fn: $!";
+    if (-f $schema_fn && !$self->dump_overwrite) {
+        warn "$schema_fn exists, will not overwrite\n";
+    }
+    else {
+        open(my $schema_fh, '>', $schema_fn)
+            or croak "Cannot open $schema_fn for writing: $!";
+        print $schema_fh qq|package $schema_class;\n\n$tagline\n\n|;
+        print $schema_fh qq|use strict;\nuse warnings;\n\n|;
+        print $schema_fh qq|use base 'DBIx::Class::Schema';\n\n|;
+        print $schema_fh qq|__PACKAGE__->load_classes;\n|;
+        print $schema_fh qq|\n1;\n\n|;
+        close($schema_fh)
+            or croak "Cannot close $schema_fn: $!";
+    }
 
     foreach my $src_class (sort keys %{$self->{_dump_storage}}) {
         $self->_ensure_dump_subdirs($src_class);
         my $src_fn = $self->_get_dump_filename($src_class);
-        croak "$src_fn exists, will not overwrite"
-            if -f $src_fn && !$self->dump_overwrite;
+        if (-f $src_fn && !$self->dump_overwrite) {
+            warn "$src_fn exists, will not overwrite\n";
+            next;
+        }    
         open(my $src_fh, '>', $src_fn)
             or croak "Cannot open $src_fn for writing: $!";
         print $src_fh qq|package $src_class;\n\n$tagline\n\n|;
@@ -488,11 +502,12 @@ sub _load_classes {
             $self->_dbic_stmt($table_class,'add_columns',@$cols);
         }
         else {
-            my %cols_hash;
-            foreach my $col (@$cols) {
-                $cols_hash{$col} = \%{($col_info->{$col})};
-            }
-            $self->_dbic_stmt($table_class,'add_columns',%cols_hash);
+            my %col_info_lc = map { lc($_), $col_info->{$_} } keys %$col_info;
+            $self->_dbic_stmt(
+                $table_class,
+                'add_columns',
+                map { $_, ($col_info_lc{$_}||{}) } @$cols
+            );
         }
 
         my $pks = $self->_table_pk_info($table) || [];