adding callbacks to Translator.pm to allow mangling of PK/FK/table names/package...

[dbsrgits/SQL-Translator.git] / lib / SQL / Translator.pm

diff --git a/lib/SQL/Translator.pm b/lib/SQL/Translator.pm
index c6ae9e2..04d4596 100644 (file)
--- a/lib/SQL/Translator.pm
+++ b/lib/SQL/Translator.pm
@@ -1,7 +1,7 @@
 package SQL::Translator;
 
 # ----------------------------------------------------------------------
-# $Id: Translator.pm,v 1.17 2003-02-26 13:08:59 dlc Exp $
+# $Id: Translator.pm,v 1.22 2003-04-17 23:16:28 allenday Exp $
 # ----------------------------------------------------------------------
 # Copyright (C) 2003 Ken Y. Clark <kclark@cpan.org>,
 #                    darren chamberlain <darren@cpan.org>,
@@ -27,7 +27,7 @@ use vars qw( $VERSION $REVISION $DEFAULT_SUB $DEBUG $ERROR );
 use base 'Class::Base';
 
 $VERSION  = '0.01';
-$REVISION = sprintf "%d.%02d", q$Revision: 1.17 $ =~ /(\d+)\.(\d+)/;
+$REVISION = sprintf "%d.%02d", q$Revision: 1.22 $ =~ /(\d+)\.(\d+)/;
 $DEBUG    = 0 unless defined $DEBUG;
 $ERROR    = "";
 
@@ -70,6 +70,14 @@ sub init {
     $self->parser  ($config->{'parser'}   || $config->{'from'} || $DEFAULT_SUB);
     $self->producer($config->{'producer'} || $config->{'to'}   || $DEFAULT_SUB);
 
+       #
+       # Set up callbacks for formatting of pk,fk,table,package names in producer
+       #
+       $self->format_table_name($config->{'format_table_name'});
+       $self->format_package_name($config->{'format_package_name'});
+       $self->format_fk_name($config->{'format_fk_name'});
+       $self->format_pk_name($config->{'format_pk_name'});
+
     #
     # Set the parser_args and producer_args
     #
@@ -238,8 +246,6 @@ sub producer_args {
     return $self->_args("producer", @_);
 }
 
-
-
 # ----------------------------------------------------------------------
 # parser([$parser_spec])
 # ----------------------------------------------------------------------
@@ -485,7 +491,7 @@ sub translate {
         $self->filename($filename);
     }
 
-    if (my $data = ($self->{'data'} || $self->{'datasource'})) {
+    if (my $data = ($args->{'data'} || $args->{'datasource'})) {
         $self->data($data);
     }
 
@@ -493,7 +499,7 @@ sub translate {
     # Get the data.
     # ----------------------------------------------------------------
     my $data = $self->data;
-    unless (length $$data) {
+    unless (ref($data) eq 'SCALAR' and length $$data) {
         return $self->error("Empty data file!");
     }
 
@@ -560,7 +566,7 @@ sub translate {
 #
 # ----------------------------------------------------------------------
 sub list_parsers {
-    return _list("parsers");
+    return shift->_list("parser");
 }
 
 # ----------------------------------------------------------------------
@@ -570,7 +576,7 @@ sub list_parsers {
 # list_producers as well.
 # ----------------------------------------------------------------------
 sub list_producers {
-    return _list("producers");
+    return shift->_list("producer");
 }
 
 
@@ -613,14 +619,26 @@ sub _args {
 # _list($type)
 # ----------------------------------------------------------------------
 sub _list {
-    my $type = ucfirst lc $_[0] || return ();
-
-    load("SQL::Translator::$type");
-    my $path = catfile(dirname($INC{'SQL/Translator/$type.pm'}), $type);
-    my $dh = IO::Dir->new($path);
+    my $self = shift;
+    my $type = shift || return ();
+    my $uctype = ucfirst lc $type;
+    my %found;
+
+    load("SQL::Translator::$uctype") or return ();
+    my $path = catfile "SQL", "Translator", $uctype;
+    for (@INC) {
+        my $dir = catfile $_, $path;
+        $self->debug("_list_${type}s searching $dir");
+        next unless -d $dir;
+
+        my $dh = IO::Dir->new($dir);
+        for (grep /\.pm$/, $dh->read) {
+            s/\.pm$//;
+            $found{ join "::", "SQL::Translator::$uctype", $_ } = 1;
+        }
+    }
 
-    return map { join "::", "SQL::Translator::$type", $_ }
-                 grep /\.pm$/, $dh->read;
+    return keys %found;
 }
 
 # ----------------------------------------------------------------------
@@ -631,13 +649,45 @@ sub _list {
 sub load {
     my $module = do { my $m = shift; $m =~ s[::][/]g; "$m.pm" };
     return 1 if $INC{$module};
-    
+
     eval { require $module };
-    
-    return if ($@);
+
+    return __PACKAGE__->error($@) if ($@);
     return 1;
 }
 
+sub format_table_name {
+  my $self = shift;
+  my $sub = shift;
+  $self->{_format_table_name} = $sub if ref($sub) eq 'CODE';
+  return $self->{_format_table_name}->($sub,@_) if defined($self->{_format_table_name});
+  return($sub);
+}
+
+sub format_package_name {
+  my $self = shift;
+  my $sub = shift;
+  $self->{_format_package_name} = $sub if ref($sub) eq 'CODE';
+  return $self->{_format_package_name}->($sub,@_) if defined($self->{_format_package_name});
+  return($sub);
+}
+
+sub format_fk_name {
+  my $self = shift;
+  my $sub = shift;
+  $self->{_format_fk_name} = $sub if ref($sub) eq 'CODE';
+  return $self->{_format_fk_name}->($sub,@_) if defined($self->{_format_fk_name});
+  return($sub);
+}
+
+sub format_pk_name {
+  my $self = shift;
+  my $sub = shift;
+  $self->{_format_pk_name} = $sub if ref($sub) eq 'CODE';
+  return $self->{_format_pk_name}->($sub,@_) if defined($self->{_format_pk_name});
+  return($sub);
+}
+
 # ----------------------------------------------------------------------
 # isa($ref, $type)
 #
@@ -666,12 +716,18 @@ SQL::Translator - convert schema from one database to another
   use SQL::Translator;
 
   my $translator     = SQL::Translator->new(
-      xlate          => $xlate || {},    # Overrides for field translation
-      debug          => $debug,          # Print debug info
-      trace          => $trace,          # Print Parse::RecDescent trace
-      no_comments    => $no_comments,    # Don't include comments in output
-      show_warnings  => $show_warnings,  # Print name mutations, conflicts
-      add_drop_table => $add_drop_table, # Add "drop table" statements
+      debug          => 1, # Print debug info
+      trace          => 0, # Print Parse::RecDescent trace
+      no_comments    => 0, # Don't include comments in output
+      show_warnings  => 0, # Print name mutations, conflicts
+      add_drop_table => 1, # Add "drop table" statements
+
+      #make all table names CAPS in producers which support this option
+      format_table_name => sub {my $tablename = shift; return uc($tablename)},
+      #null-op formatting, only here for documentation's sake
+      format_package_name => sub {return shift},
+      format_fk_name      => sub {return shift},
+      format_pk_name      => sub {return shift},
   );
 
   my $output     = $translator->translate(
@@ -953,6 +1009,10 @@ along with this program; if not, write to the Free Software
 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
 USA
 
+=head1 BUGS
+
+Please use http://rt.cpan.org/ for reporting bugs.
+
 =head1 SEE ALSO
 
 L<perl>,