Clean up
[dbsrgits/SQL-Translator.git] / lib / SQL / Translator.pm
index fc25a90..82855be 100644 (file)
@@ -1,11 +1,9 @@
 package SQL::Translator;
 
 # ----------------------------------------------------------------------
-# $Id: Translator.pm,v 1.47 2003-10-17 19:49:16 dlc Exp $
+# $Id: Translator.pm,v 1.61 2004-11-09 05:27:45 grommit Exp $
 # ----------------------------------------------------------------------
-# Copyright (C) 2003 Ken Y. Clark <kclark@cpan.org>,
-#                    darren chamberlain <darren@cpan.org>,
-#                    Chris Mungall <cjm@fruitfly.org>
+# Copyright (C) 2002-4 The SQLFairy Authors
 #
 # This program is free software; you can redistribute it and/or
 # modify it under the terms of the GNU General Public License as
@@ -28,8 +26,8 @@ use base 'Class::Base';
 
 require 5.004;
 
-$VERSION  = '0.03';
-$REVISION = sprintf "%d.%02d", q$Revision: 1.47 $ =~ /(\d+)\.(\d+)/;
+$VERSION  = '0.06';
+$REVISION = sprintf "%d.%02d", q$Revision: 1.61 $ =~ /(\d+)\.(\d+)/;
 $DEBUG    = 0 unless defined $DEBUG;
 $ERROR    = "";
 
@@ -75,13 +73,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 up callbacks for formatting of pk,fk,table,package names in producer
+    # MOVED TO PRODUCER ARGS
+    #
+    #$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
@@ -152,68 +151,12 @@ sub no_comments {
 # Get or set the producer for the current translator.
 # ----------------------------------------------------------------------
 sub producer {
-    my $self = shift;
-
-    # producer as a mutator
-    if (@_) {
-        my $producer = shift;
-
-        # Passed a module name (string containing "::")
-        if ($producer =~ /::/) {
-            my $func_name;
-
-            # Module name was passed directly
-            # We try to load the name; if it doesn't load, there's
-            # a possibility that it has a function name attached to
-            # it.
-            if (load($producer)) {
-                $func_name = "produce";
-            } 
-
-            # Module::function was passed
-            else {
-                # Passed Module::Name::function; try to recover
-                my @func_parts = split /::/, $producer;
-                $func_name = pop @func_parts;
-                $producer = join "::", @func_parts;
-
-                # If this doesn't work, then we have a legitimate
-                # problem.
-                load($producer) or die "Can't load $producer: $@";
-            }
-
-            # get code reference and assign
-            $self->{'producer'} = \&{ "$producer\::$func_name" };
-            $self->{'producer_type'} = $producer;
-            $self->debug("Got producer: $producer\::$func_name\n");
-        } 
-
-        # passed an anonymous subroutine reference
-        elsif (isa($producer, 'CODE')) {
-            $self->{'producer'} = $producer;
-            $self->{'producer_type'} = "CODE";
-            $self->debug("Got producer: code ref\n");
-        } 
-
-        # passed a string containing no "::"; relative package name
-        else {
-            $producer =~ s/-/::/g;
-            my $Pp = sprintf "SQL::Translator::Producer::$producer";
-            load($Pp) or die "Can't load $Pp: $@";
-            $self->{'producer'} = \&{ "$Pp\::produce" };
-            $self->{'producer_type'} = $Pp;
-            $self->debug("Got producer: $Pp\n");
-        }
-
-        # At this point, $self->{'producer'} contains a subroutine
-        # reference that is ready to run
-
-        # Anything left?  If so, it's producer_args
-        $self->producer_args(@_) if (@_);
-    }
-
-    return $self->{'producer'};
-};
+    shift->_tool({
+            name => 'producer', 
+            path => "SQL::Translator::Producer",
+            default_sub => "produce" 
+    }, @_);
+}
 
 # ----------------------------------------------------------------------
 # producer_type()
@@ -236,86 +179,24 @@ sub producer_type { $_[0]->{'producer_type'} }
 # is cleared; all subsequent elements are added to the hash of name,
 # value pairs stored as producer_args.
 # ----------------------------------------------------------------------
-sub producer_args {
-    my $self = shift;
-    return $self->_args("producer", @_);
-}
+sub producer_args { shift->_args("producer", @_); }
 
 # ----------------------------------------------------------------------
 # parser([$parser_spec])
 # ----------------------------------------------------------------------
 sub parser {
-    my $self = shift;
-
-    # parser as a mutator
-    if (@_) {
-        my $parser = shift;
-
-        # Passed a module name (string containing "::")
-        if ($parser =~ /::/) {
-            my $func_name;
-
-            # Module name was passed directly
-            # We try to load the name; if it doesn't load, there's
-            # a possibility that it has a function name attached to
-            # it.
-            if (load($parser)) {
-                $func_name = "parse";
-            }
-
-            # Module::function was passed
-            else {
-                # Passed Module::Name::function; try to recover
-                my @func_parts = split /::/, $parser;
-                $func_name = pop @func_parts;
-                $parser = join "::", @func_parts;
-
-                # If this doesn't work, then we have a legitimate
-                # problem.
-                load($parser) or die "Can't load $parser: $@";
-            } 
-
-            # get code reference and assign
-            $self->{'parser'} = \&{ "$parser\::$func_name" };
-            $self->{'parser_type'} = $parser;
-            $self->debug("Got parser: $parser\::$func_name\n");
-        }
-
-        # passed an anonymous subroutine reference
-        elsif ( isa( $parser, 'CODE' ) ) {
-            $self->{'parser'}      = $parser;
-            $self->{'parser_type'} = "CODE";
-            $self->debug("Got parser: code ref\n");
-        } 
-
-        # passed a string containing no "::"; relative package name
-        else {
-            $parser =~ s/-/::/g;
-            my $Pp = "SQL::Translator::Parser::$parser";
-            load( $Pp ) or die "Can't load $Pp: $@";
-            $self->{'parser'}      = \&{ "$Pp\::parse" };
-            $self->{'parser_type'} = $Pp;
-            $self->debug("Got parser: $Pp\n");
-        } 
-
-        #
-        # At this point, $self->{'parser'} contains a subroutine
-        # reference that is ready to run
-        #
-        $self->parser_args( @_ ) if (@_);
-    }
-
-    return $self->{'parser'};
+    shift->_tool({
+        name => 'parser', 
+        path => "SQL::Translator::Parser",
+        default_sub => "parse" 
+    }, @_);
 }
 
-# ----------------------------------------------------------------------
-sub parser_type { $_[0]->{'parser_type'} }
+sub parser_type { $_[0]->{'parser_type'}; }
 
-sub parser_args {
-    my $self = shift;
-    return $self->_args("parser", @_);
-}
+sub parser_args { shift->_args("parser", @_); }
 
+# ----------------------------------------------------------------------
 sub show_warnings {
     my $self = shift;
     my $arg  = shift;
@@ -392,15 +273,15 @@ sub data {
         my @files = ref($filename) eq 'ARRAY' ? @$filename : ($filename);
 
         foreach my $file (@files) {
-                unless (open FH, $file) {
-                    return $self->error("Can't read file '$file': $!");
-                }
+            unless (open FH, $file) {
+                return $self->error("Can't read file '$file': $!");
+            }
 
-                $data .= <FH>;
+            $data .= <FH>;
 
-                unless (close FH) {
-                    return $self->error("Can't close file '$file': $!");
-                }
+            unless (close FH) {
+                return $self->error("Can't close file '$file': $!");
+            }
         }
 
         $self->{'data'} = \$data;
@@ -428,7 +309,9 @@ sub schema {
     my $self = shift;
 
     unless ( defined $self->{'schema'} ) {
-        $self->{'schema'} = SQL::Translator::Schema->new;
+        $self->{'schema'} = SQL::Translator::Schema->new(
+            translator      => $self,
+        );
     }
 
     return $self->{'schema'};
@@ -650,6 +533,57 @@ sub _args {
 }
 
 # ----------------------------------------------------------------------
+# Does the get/set work for parser and producer. e.g.
+# return $self->_tool({ 
+#   name => 'producer', 
+#   path => "SQL::Translator::Producer",
+#   default_sub => "produce",
+# }, @_);
+# ----------------------------------------------------------------------
+sub _tool {
+    my ($self,$args) = (shift, shift);
+    my $name = $args->{name};
+    return $self->{$name} unless @_; # get accessor
+
+    my $path = $args->{path};
+    my $default_sub = $args->{default_sub};
+    my $tool = shift;
+   
+    # passed an anonymous subroutine reference
+    if (isa($tool, 'CODE')) {
+        $self->{$name} = $tool;
+        $self->{"$name\_type"} = "CODE";
+        $self->debug("Got $name: code ref\n");
+    }
+
+    # Module name was passed directly
+    # We try to load the name; if it doesn't load, there's a
+    # possibility that it has a function name attached to it,
+    # so we give it a go.
+    else {
+        $tool =~ s/-/::/g if $tool !~ /::/;
+        my ($code,$sub);
+        ($code,$sub) = _load_sub("$tool\::$default_sub", $path);
+        ($code,$sub) = _load_sub("$tool", $path) unless $code;
+        
+        # get code reference and assign
+        my (undef,$module,undef) = $sub =~ m/((.*)::)?(\w+)$/;
+        $self->{$name} = $code;
+        $self->{"$name\_type"} = $sub eq "CODE" ? "CODE" : $module;
+        $self->debug("Got $name: $sub\n");
+    }
+
+    # At this point, $self->{$name} contains a subroutine
+    # reference that is ready to run
+
+    # Anything left?  If so, it's args
+    my $meth = "$name\_args";
+    $self->$meth(@_) if (@_);
+
+    return $self->{$name};
+}
+
+# ----------------------------------------------------------------------
 # _list($type)
 # ----------------------------------------------------------------------
 sub _list {
@@ -683,7 +617,7 @@ sub _list {
                 my $mod      =  $_;
                    $mod      =~ s/\.pm$//;
                 my $cur_dir  = $File::Find::dir;
-                my $base_dir = catfile 'SQL', 'Translator', $uctype;
+                my $base_dir = quotemeta catfile 'SQL', 'Translator', $uctype;
 
                 #
                 # See if the current directory is below the base directory.
@@ -707,21 +641,60 @@ sub _list {
 }
 
 # ----------------------------------------------------------------------
-# load($module)
+# load(MODULE [,PATH[,PATH]...])
 #
 # Loads a Perl module.  Short circuits if a module is already loaded.
+#
+# MODULE - is the name of the module to load.
+#
+# PATH - optional list of 'package paths' to look for the module in. e.g
+# If you called load(Bar => 'Foo', 'My::Modules') it will try to load the mod
+# Bar then Foo::Bar then My::Modules::Bar.
+#
+# Returns package name of the module actually loaded or false and sets error.
+#
+# Note, you can't load a name from the root namespace (ie one without '::' in 
+# it), therefore a single word name without a path fails.
 # ----------------------------------------------------------------------
 sub load {
-    my $module = do { my $m = shift; $m =~ s[::][/]g; "$m.pm" };
-    return 1 if $INC{$module};
+    my $name = shift;
+    my @path;
+    push @path, "" if $name =~ /::/; # Empty path to check name on its own first
+    push @path, @_ if @_;
+
+    foreach (@path) {
+        my $module = $_ ? "$_\::$name" : $name;
+        my $file = $module; $file =~ s[::][/]g; $file .= ".pm";
+        __PACKAGE__->debug("Loading $name as $file\n");
+        return $module if $INC{$file}; # Already loaded
+        
+        eval { require $file };
+        next if $@ =~ /Can't locate $file in \@INC/; 
+        eval { $file->import(@_) } unless $@;
+        return __PACKAGE__->error("Error loading $name as $module : $@") if $@;
+
+        return $module; # Module loaded ok
+    }
 
-    eval {
-        require $module;
-        $module->import(@_);
-    };
+    return __PACKAGE__->error("Can't find $name. Path:".join(",",@path));
+}
 
-    return __PACKAGE__->error($@) if ($@);
-    return 1;
+# ----------------------------------------------------------------------
+# Load the sub name given (including package), optionally using a base package
+# path. Returns code ref and name of sub loaded, including its package.
+# (\&code, $sub) = load_sub( 'MySQL::produce', "SQL::Translator::Producer" );
+# (\&code, $sub) = load_sub( 'MySQL::produce', @path );
+# ----------------------------------------------------------------------
+sub _load_sub {
+    my ($tool, @path) = @_;
+    
+    # Passed a module name or module and sub name 
+    my (undef,$module,$func_name) = $tool =~ m/((.*)::)?(\w+)$/;
+    if ( my $module = load($module => @path) ) {
+        my $sub = "$module\::$func_name";
+        return ( \&{ $sub }, $sub );
+    } 
+    return undef;
 }
 
 # ----------------------------------------------------------------------
@@ -777,6 +750,16 @@ sub isa($$) {
 }
 
 # ----------------------------------------------------------------------
+# version
+#
+# Returns the $VERSION of the main SQL::Translator package.
+# ----------------------------------------------------------------------
+sub version {
+    my $self = shift;
+    return $VERSION;
+}
+
+# ----------------------------------------------------------------------
 sub validate {
     my ( $self, $arg ) = @_;
     if ( defined $arg ) {
@@ -836,6 +819,10 @@ SQL::Translator - manipulate structured data definitions (SQL and more)
 
 =head1 DESCRIPTION
 
+This documentation covers the API for SQL::Translator.  For a more general
+discussion of how to use the modules and scripts, please see
+L<SQL::Translator::Manual>.
+
 SQL::Translator is a group of Perl modules that converts
 vendor-specific SQL table definitions into other formats, such as
 other vendor-specific SQL, ER diagrams, documentation (POD and HTML),
@@ -923,10 +910,11 @@ value, returns the current value.
 The C<producer> method is an accessor/mutator, used to retrieve or
 define what subroutine is called to produce the output.  A subroutine
 defined as a producer will be invoked as a function (I<not a method>)
-and passed 2 parameters: its container C<SQL::Translator> instance and a
-data structure.  It is expected that the function transform the data
-structure to a string.  The C<SQL::Transformer> instance is provided for
-informational purposes; for example, the type of the parser can be
+and passed its container C<SQL::Translator> instance, which it should
+call the C<schema> method on, to get the C<SQL::Translator::Schema> 
+generated by the parser.  It is expected that the function transform the
+schema structure to a string.  The C<SQL::Translator> instance is also useful 
+for informational purposes; for example, the type of the parser can be
 retrieved using the C<parser_type> method, and the C<error> and
 C<debug> methods can be called when needed.
 
@@ -1101,6 +1089,10 @@ Turns on/off the tracing option of Parse::RecDescent.
 Whether or not to validate the schema object after parsing and before
 producing.
 
+=head2 version
+
+Returns the version of the SQL::Translator release.
+
 =head1 AUTHORS
 
 The following people have contributed to the SQLFairy project:
@@ -1111,6 +1103,8 @@ The following people have contributed to the SQLFairy project:
 
 =item * Sam Angiuoli <angiuoli@users.sourceforge.net>
 
+=item * Dave Cash <dave@gnofn.org>
+
 =item * Darren Chamberlain <dlc@users.sourceforge.net>
 
 =item * Ken Y. Clark <kclark@cpan.org>