package SQL::Translator;
-# ----------------------------------------------------------------------
-# $Id: Translator.pm,v 1.67 2005-06-08 15:32:51 mwz444 Exp $
-# ----------------------------------------------------------------------
-# 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
-# published by the Free Software Foundation; version 2.
-#
-# This program is distributed in the hope that it will be useful, but
-# WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-# General Public License for more details.
-#
-# You should have received a copy of the GNU General Public License
-# along with this program; if not, write to the Free Software
-# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-# 02111-1307 USA
-# -------------------------------------------------------------------
-
use strict;
-use vars qw( $VERSION $REVISION $DEFAULT_SUB $DEBUG $ERROR );
+use vars qw( $VERSION $DEFAULT_SUB $DEBUG $ERROR );
use base 'Class::Base';
-require 5.004;
+require 5.005;
-$VERSION = '0.07';
-$REVISION = sprintf "%d.%02d", q$Revision: 1.67 $ =~ /(\d+)\.(\d+)/;
+$VERSION = '0.11010';
$DEBUG = 0 unless defined $DEBUG;
$ERROR = "";
use Carp qw(carp);
use Data::Dumper;
-use Class::Base;
use File::Find;
use File::Spec::Functions qw(catfile);
use File::Basename qw(dirname);
use IO::Dir;
+use SQL::Translator::Producer;
use SQL::Translator::Schema;
-# ----------------------------------------------------------------------
-# The default behavior is to "pass through" values (note that the
-# SQL::Translator instance is the first value ($_[0]), and the stuff
-# to be parsed is the second value ($_[1])
-# ----------------------------------------------------------------------
$DEFAULT_SUB = sub { $_[0]->schema } unless defined $DEFAULT_SUB;
-# ----------------------------------------------------------------------
-# init([ARGS])
-# The constructor.
-#
-# new takes an optional hash of arguments. These arguments may
-# include a parser, specified with the keys "parser" or "from",
-# and a producer, specified with the keys "producer" or "to".
-#
-# The values that can be passed as the parser or producer are
-# given directly to the parser or producer methods, respectively.
-# See the appropriate method description below for details about
-# what each expects/accepts.
-# ----------------------------------------------------------------------
sub init {
my ( $self, $config ) = @_;
#
$self->validate( $config->{'validate'} );
+ $self->quote_table_names( (defined $config->{'quote_table_names'}
+ ? $config->{'quote_table_names'} : 1) );
+ $self->quote_field_names( (defined $config->{'quote_field_names'}
+ ? $config->{'quote_field_names'} : 1) );
+
return $self;
}
-# ----------------------------------------------------------------------
-# add_drop_table([$bool])
-# ----------------------------------------------------------------------
sub add_drop_table {
my $self = shift;
if ( defined (my $arg = shift) ) {
return $self->{'add_drop_table'} || 0;
}
-# ----------------------------------------------------------------------
-# no_comments([$bool])
-# ----------------------------------------------------------------------
sub no_comments {
my $self = shift;
my $arg = shift;
return $self->{'no_comments'} || 0;
}
+sub quote_table_names {
+ my $self = shift;
+ if ( defined (my $arg = shift) ) {
+ $self->{'quote_table_names'} = $arg ? 1 : 0;
+ }
+ return $self->{'quote_table_names'} || 0;
+}
+
+sub quote_field_names {
+ my $self = shift;
+ if ( defined (my $arg = shift) ) {
+ $self->{'quote_field_names'} = $arg ? 1 : 0;
+ }
+ return $self->{'quote_field_names'} || 0;
+}
-# ----------------------------------------------------------------------
-# producer([$producer_spec])
-#
-# Get or set the producer for the current translator.
-# ----------------------------------------------------------------------
sub producer {
shift->_tool({
name => 'producer',
}, @_);
}
-# ----------------------------------------------------------------------
-# producer_type()
-#
-# producer_type is an accessor that allows producer subs to get
-# information about their origin. This is poptentially important;
-# since all producer subs are called as subroutine references, there is
-# no way for a producer to find out which package the sub lives in
-# originally, for example.
-# ----------------------------------------------------------------------
sub producer_type { $_[0]->{'producer_type'} }
-# ----------------------------------------------------------------------
-# producer_args([\%args])
-#
-# Arbitrary name => value pairs of paramters can be passed to a
-# producer using this method.
-#
-# If the first argument passed in is undef, then the hash of arguments
-# is cleared; all subsequent elements are added to the hash of name,
-# value pairs stored as producer_args.
-# ----------------------------------------------------------------------
sub producer_args { shift->_args("producer", @_); }
-# ----------------------------------------------------------------------
-# parser([$parser_spec])
-# ----------------------------------------------------------------------
sub parser {
shift->_tool({
name => 'parser',
sub parser_args { shift->_args("parser", @_); }
-# ----------------------------------------------------------------------
-# e.g.
-# $sqlt->filters => [
-# sub { },
-# [ "NormalizeNames", field => "lc", tabel => "ucfirst" ],
-# [
-# "DataTypeMap",
-# "TEXT" => "BIGTEXT",
-# ],
-# ],
-# ----------------------------------------------------------------------
sub filters {
my $self = shift;
my $filters = $self->{filters} ||= [];
return @$filters unless @_;
- # Set. Convert args to list of [\&code,\%args]
+ # Set. Convert args to list of [\&code,@args]
foreach (@_) {
- $_ = [$_,{}] if not ref($_) eq "ARRAY";
- my ($name,$args) = @$_;
- if ( isa($name,"CODE") ) {
- push @$filters, $_;
+ my ($filt,@args) = ref($_) eq "ARRAY" ? @$_ : $_;
+ if ( isa($filt,"CODE") ) {
+ push @$filters, [$filt,@args];
next;
}
else {
- $self->debug("Adding $name filter. Args:".Dumper($args)."\n");
- my $code = _load_sub("$name\::filter", "SQL::Translator::Filter");
- return $self->error(__PACKAGE__->error) unless $code;
- push @$filters, [$code,$args];
+ $self->debug("Adding $filt filter. Args:".Dumper(\@args)."\n");
+ $filt = _load_sub("$filt\::filter", "SQL::Translator::Filter")
+ || return $self->error(__PACKAGE__->error);
+ push @$filters, [$filt,@args];
}
}
return @$filters;
}
-# ----------------------------------------------------------------------
sub show_warnings {
my $self = shift;
my $arg = shift;
}
-# filename - get or set the filename
sub filename {
my $self = shift;
if (@_) {
$self->{'filename'};
}
-# ----------------------------------------------------------------------
-# data([$data])
-#
-# if $self->{'data'} is not set, but $self->{'filename'} is, then
-# $self->{'filename'} is opened and read, with the results put into
-# $self->{'data'}.
-# ----------------------------------------------------------------------
sub data {
my $self = shift;
$data = join '', @$data;
}
elsif (isa($data, 'GLOB')) {
+ seek ($data, 0, 0) if eof ($data);
local $/;
$data = <$data>;
}
return $self->{'data'};
}
-# ----------------------------------------------------------------------
sub reset {
#
# Deletes the existing Schema object so that future calls to translate
return 1;
}
-# ----------------------------------------------------------------------
sub schema {
#
# Returns the SQL::Translator::Schema object
return $self->{'schema'};
}
-# ----------------------------------------------------------------------
sub trace {
my $self = shift;
my $arg = shift;
return $self->{'trace'} || 0;
}
-# ----------------------------------------------------------------------
-# translate([source], [\%args])
-#
-# translate does the actual translation. The main argument is the
-# source of the data to be translated, which can be a filename, scalar
-# reference, or glob reference.
-#
-# Alternatively, translate takes optional arguements, which are passed
-# to the appropriate places. Most notable of these arguments are
-# parser and producer, which can be used to set the parser and
-# producer, respectively. This is the applications last chance to set
-# these.
-#
-# translate returns a string.
-# ----------------------------------------------------------------------
sub translate {
my $self = shift;
my ($args, $parser, $parser_type, $producer, $producer_type);
- my ($parser_output, $producer_output);
+ my ($parser_output, $producer_output, @producer_output);
# Parse arguments
if (@_ == 1) {
my $filt_num = 0;
foreach ($self->filters) {
$filt_num++;
- my ($code,$args) = @$_;
- eval { $code->($self->schema, $args) };
+ my ($code,@args) = @$_;
+ eval { $code->($self->schema, @args) };
my $err = $@ || $self->error || 0;
return $self->error("Error with filter $filt_num : $err") if $err;
}
# Run producer
- eval { $producer_output = $producer->($self) };
- if ($@ || ! $producer_output) {
+ # Calling wantarray in the eval no work, wrong scope.
+ my $wantarray = wantarray ? 1 : 0;
+ eval {
+ if ($wantarray) {
+ @producer_output = $producer->($self);
+ } else {
+ $producer_output = $producer->($self);
+ }
+ };
+ if ($@ || !( $producer_output || @producer_output)) {
my $err = $@ || $self->error || "no results";
my $msg = "translate: Error with producer '$producer_type': $err";
return $self->error($msg);
}
- return $producer_output;
+ return wantarray ? @producer_output : $producer_output;
}
-# ----------------------------------------------------------------------
-# list_parsers()
-#
-# Hacky sort of method to list all available parsers. This has
-# several problems:
-#
-# - Only finds things in the SQL::Translator::Parser namespace
-#
-# - Only finds things that are located in the same directory
-# as SQL::Translator::Parser. Yeck.
-#
-# This method will fail in several very likely cases:
-#
-# - Parser modules in different namespaces
-#
-# - Parser modules in the SQL::Translator::Parser namespace that
-# have any XS componenets will be installed in
-# arch_lib/SQL/Translator.
-#
-# ----------------------------------------------------------------------
sub list_parsers {
return shift->_list("parser");
}
-# ----------------------------------------------------------------------
-# list_producers()
-#
-# See notes for list_parsers(), above; all the problems apply to
-# list_producers as well.
-# ----------------------------------------------------------------------
sub list_producers {
return shift->_list("producer");
}
# ----------------------------------------------------------------------
# Does the get/set work for parser and producer. e.g.
-# return $self->_tool({
-# name => 'producer',
+# return $self->_tool({
+# name => 'producer',
# path => "SQL::Translator::Producer",
# default_sub => "produce",
# }, @_);
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;
my $uctype = ucfirst lc $type;
#
- # First find all the directories where SQL::Translator
+ # First find all the directories where SQL::Translator
# parsers or producers (the "type") appear to live.
#
load("SQL::Translator::$uctype") or return ();
}
#
- # Now use File::File::find to look recursively in those
+ # Now use File::File::find to look recursively in those
# directories for all the *.pm files, then present them
# with the slashes turned into dashes.
#
my %found;
- find(
- sub {
+ find(
+ sub {
if ( -f && m/\.pm$/ ) {
my $mod = $_;
$mod =~ s/\.pm$//;
return $module if $INC{$file}; # Already loaded
eval { require $file };
- next if $@ =~ /Can't locate $file in \@INC/;
+ next if $@ =~ /Can't locate $file in \@INC/;
eval { $module->import() } unless $@;
return __PACKAGE__->error("Error loading $name as $module : $@")
if $@ && $@ !~ /"SQL::Translator::Producer" is not exported/;
return undef;
}
-# ----------------------------------------------------------------------
sub format_table_name {
return shift->_format_name('_format_table_name', @_);
}
-# ----------------------------------------------------------------------
sub format_package_name {
return shift->_format_name('_format_package_name', @_);
}
-# ----------------------------------------------------------------------
sub format_fk_name {
return shift->_format_name('_format_fk_name', @_);
}
-# ----------------------------------------------------------------------
sub format_pk_name {
return shift->_format_name('_format_pk_name', @_);
}
return @args ? $self->{$field}->(@args) : $self->{$field};
}
-# ----------------------------------------------------------------------
-# isa($ref, $type)
-#
-# Calls UNIVERSAL::isa($ref, $type). I think UNIVERSAL::isa is ugly,
-# but I like function overhead.
-# ----------------------------------------------------------------------
sub isa($$) {
my ($ref, $type) = @_;
return UNIVERSAL::isa($ref, $type);
}
-# ----------------------------------------------------------------------
-# 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 ) {
show_warnings => 0,
# Add "drop table" statements
add_drop_table => 1,
+ # to quote or not to quote, thats the question
+ quote_table_names => 1,
+ quote_field_names => 1,
# Validate schema object
validate => 1,
# Make all table names CAPS in producers which support this option
=item *
+quote_table_names
+
+=item *
+
+quote_field_names
+
+=item *
+
no_comments
=item *
=head2 add_drop_table
-Toggles whether or not to add "DROP TABLE" statements just before the
+Toggles whether or not to add "DROP TABLE" statements just before the
create definitions.
+=head2 quote_table_names
+
+Toggles whether or not to quote table names with " in DROP and CREATE
+statements. The default (true) is to quote them.
+
+=head2 quote_field_names
+
+Toggles whether or not to quote field names with " in most
+statements. The default (true), is to quote them.
+
=head2 no_comments
Toggles whether to print comments in the output. Accepts a true or false
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 its container C<SQL::Translator> instance, which it should
-call the C<schema> method on, to get the C<SQL::Translator::Schema>
+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
+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.
Set or retreive the filters to run over the schema during the
translation, before the producer creates its output. Filters are sub
routines called, in order, with the schema object to filter as the 1st
-arg and a hashref of options as the 2nd. They are free to do whatever
-they want to the schema object, which will be handed to any following
-filters, then used by the producer.
+arg and a hash of options (passed as a list) for the rest of the args.
+They are free to do whatever they want to the schema object, which will be
+handed to any following filters, then used by the producer.
Filters are set as an array, which gives the order they run in.
Like parsers and producers, they can be defined by a module name, a
module name relative to the SQL::Translator::Filter namespace, a module
name and function name together or a reference to an anonymous subroutine.
When using a module name a function called C<filter> will be invoked in
-that package to do the work. To pass args to the filter set it as an array
-ref with the 1st value giving the filter and the rest being a hash of
-args.
+that package to do the work.
+
+To pass args to the filter set it as an array ref with the 1st value giving
+the filter (name or sub) and the rest its args. e.g.
$tr->filters(
sub {
my $schema = shift;
# Do stuff to schema here!
},
- [ "Foo", foo => "bar", hello => "world" ],
- [ "Filter3" ],
+ DropFKeys,
+ [ "Names", table => 'lc' ],
+ [ "Foo", foo => "bar", hello => "world" ],
+ [ "Filter5" ],
);
-Although you would normally set them in the constructor, which calls
+Although you normally set them in the constructor, which calls
through to filters. i.e.
my $translator = SQL::Translator->new(
...
filters => [
sub { ... },
- [ Foo, foo => "bar" ],
+ [ "Names", table => 'lc' ],
],
...
);
the end of the current list.
Returns the filters as a list of array refs, the 1st value being a
-reference to the filter sub routine and the 2nd a hashref its args.
+reference to the filter sub and the rest its args.
=head2 show_warnings
=head1 AUTHORS
-The following people have contributed to the SQLFairy project:
-
-=over 4
-
-=item * Mark Addison <grommit@users.sourceforge.net>
-
-=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>
-
-=item * Allen Day <allenday@users.sourceforge.net>
-
-=item * Paul Harrington <phrrngtn@users.sourceforge.net>
-
-=item * Mikey Melillo <mmelillo@users.sourceforge.net>
-
-=item * Chris Mungall <cjm@fruitfly.org>
-
-=item * Ross Smith II <rossta@users.sf.net>
-
-=item * Gudmundur A. Thorisson <mummi@cshl.org>
-
-=item * Chris To <christot@users.sourceforge.net>
-
-=item * Jason Williams <smdwilliams@users.sourceforge.net>
-
-=item * Ying Zhang <zyolive@yahoo.com>
-
-=back
+See the included AUTHORS file:
+L<http://search.cpan.org/dist/SQL-Translator/AUTHORS>
If you would like to contribute to the project, you can send patches
to the developers mailing list:
=head1 PRAISE
-If you find this module useful, please use
+If you find this module useful, please use
L<http://cpanratings.perl.org/rate/?distribution=SQL-Translator> to rate it.
=head1 SEE ALSO
projects / dbsrgits/SQL-Translator.git / blobdiff