package SQL::Translator;
-use strict;
-use warnings;
+use Moo;
our ( $DEFAULT_SUB, $DEBUG, $ERROR );
-use base 'Class::Base';
-require 5.005;
-
-our $VERSION = '0.11012';
+our $VERSION = '1.62';
+$VERSION =~ tr/_//d;
$DEBUG = 0 unless defined $DEBUG;
$ERROR = "";
use File::Spec::Functions qw(catfile);
use File::Basename qw(dirname);
use IO::Dir;
+use Sub::Quote qw(quote_sub);
use SQL::Translator::Producer;
use SQL::Translator::Schema;
+use SQL::Translator::Utils qw(throw ex2err carp_ro normalize_quote_options);
$DEFAULT_SUB = sub { $_[0]->schema } unless defined $DEFAULT_SUB;
-sub init {
- my ( $self, $config ) = @_;
- #
- # Set the parser and producer.
- #
+with qw(
+ SQL::Translator::Role::Debug
+ SQL::Translator::Role::Error
+ SQL::Translator::Role::BuildArgs
+);
+
+around BUILDARGS => sub {
+ my $orig = shift;
+ my $self = shift;
+ my $config = $self->$orig(@_);
+
# If a 'parser' or 'from' parameter is passed in, use that as the
# parser; if a 'producer' or 'to' parameter is passed in, use that
# as the producer; both default to $DEFAULT_SUB.
- #
- $self->parser ($config->{'parser'} || $config->{'from'} || $DEFAULT_SUB);
- $self->producer($config->{'producer'} || $config->{'to'} || $DEFAULT_SUB);
+ $config->{parser} ||= $config->{from} if defined $config->{from};
+ $config->{producer} ||= $config->{to} if defined $config->{to};
- #
- # 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'});
+ $config->{filename} ||= $config->{file} if defined $config->{file};
- #
- # Set the parser_args and producer_args
- #
- for my $pargs ( qw[ parser_args producer_args ] ) {
- $self->$pargs( $config->{$pargs} ) if defined $config->{ $pargs };
- }
+ my $quote = normalize_quote_options($config);
+ $config->{quote_identifiers} = $quote if defined $quote;
- #
- # Initialize the filters.
- #
- if ( $config->{filters} && ref $config->{filters} eq "ARRAY" ) {
- $self->filters( @{$config->{filters}} )
- || return $self->error('Error inititializing filters: '.$self->error);
- }
+ return $config;
+};
- #
- # Set the data source, if 'filename' or 'file' is provided.
- #
- $config->{'filename'} ||= $config->{'file'} || "";
- $self->filename( $config->{'filename'} ) if $config->{'filename'};
-
- #
- # Finally, if there is a 'data' parameter, use that in
- # preference to filename and file
- #
- if ( my $data = $config->{'data'} ) {
- $self->data( $data );
- }
-
- #
- # Set various other options.
- #
- $self->{'debug'} = defined $config->{'debug'} ? $config->{'debug'} : $DEBUG;
-
- $self->add_drop_table( $config->{'add_drop_table'} );
-
- $self->no_comments( $config->{'no_comments'} );
-
- $self->show_warnings( $config->{'show_warnings'} );
-
- $self->trace( $config->{'trace'} );
-
- $self->validate( $config->{'validate'} );
-
- my $quote;
- if (defined $config->{quote_identifiers}) {
- $quote = $config->{quote_identifiers};
-
- for (qw/quote_table_names quote_field_names/) {
- carp "Ignoring deprecated parameter '$_', since 'quote_identifiers' is supplied"
- if defined $config->{$_}
- }
+sub BUILD {
+ my ($self) = @_;
+ # Make sure all the tool-related stuff is set up
+ foreach my $tool (qw(producer parser)) {
+ $self->$tool($self->$tool);
}
- # Legacy one set the other is not
- elsif (
- defined $config->{'quote_table_names'}
- xor
- defined $config->{'quote_field_names'}
- ) {
- if (defined $config->{'quote_table_names'}) {
- carp "Explicitly disabling the deprecated 'quote_table_names' implies disabling 'quote_identifiers' which in turn implies disabling 'quote_field_names'"
- unless $config->{'quote_table_names'};
- $quote = $config->{'quote_table_names'} ? 1 : 0;
- }
- else {
- carp "Explicitly disabling the deprecated 'quote_field_names' implies disabling 'quote_identifiers' which in turn implies disabling 'quote_table_names'"
- unless $config->{'quote_field_names'};
- $quote = $config->{'quote_field_names'} ? 1 : 0;
- }
- }
- # Legacy both are set
- elsif(defined $config->{'quote_table_names'}) {
- croak 'Setting quote_table_names and quote_field_names to conflicting values is no longer supported'
- if ($config->{'quote_table_names'} xor $config->{'quote_field_names'});
-
- $quote = $config->{'quote_table_names'} ? 1 : 0;
- }
- # none are set - on by default, use a 0-but-true as indicator
- # so we can allow individual producers to change the default
- else {
- $quote = '0E0';
- }
-
- $self->quote_identifiers($quote);
-
- return $self;
}
-sub add_drop_table {
- my $self = shift;
- if ( defined (my $arg = shift) ) {
- $self->{'add_drop_table'} = $arg ? 1 : 0;
- }
- return $self->{'add_drop_table'} || 0;
-}
+has $_ => (
+ is => 'rw',
+ default => quote_sub(q{ 0 }),
+ coerce => quote_sub(q{ $_[0] ? 1 : 0 }),
+) foreach qw(add_drop_table no_comments show_warnings trace validate);
-sub no_comments {
- my $self = shift;
- my $arg = shift;
- if ( defined $arg ) {
- $self->{'no_comments'} = $arg ? 1 : 0;
- }
- return $self->{'no_comments'} || 0;
-}
+# quote_identifiers is on by default, use a 0-but-true as indicator
+# so we can allow individual producers to change the default
+has quote_identifiers => (
+ is => 'rw',
+ default => quote_sub(q{ '0E0' }),
+ coerce => quote_sub(q{ $_[0] || 0 }),
+);
sub quote_table_names {
- (@_ > 1 and ($_[1] xor $_[0]->{quote_identifiers}) )
+ (@_ > 1 and ($_[1] xor $_[0]->quote_identifiers) )
? croak 'Using quote_table_names as a setter is no longer supported'
- : $_[0]->{quote_identifiers} ? 1 : 0
+ : $_[0]->quote_identifiers;
}
sub quote_field_names {
- (@_ > 1 and ($_[1] xor $_[0]->{quote_identifiers}) )
+ (@_ > 1 and ($_[1] xor $_[0]->quote_identifiers) )
? croak 'Using quote_field_names as a setter is no longer supported'
- : $_[0]->{quote_identifiers} ? 1 : 0
+ : $_[0]->quote_identifiers;
}
-sub quote_identifiers {
- @_ > 1
- ? # synchronize for old code reaching directly into guts
- $_[0]->{quote_table_names}
- = $_[0]->{quote_field_names}
- = $_[0]->{quote_identifiers}
- = $_[1] ? $_[1] : 0
- : $_[0]->{quote_identifiers}
-}
+after quote_identifiers => sub {
+ if (@_ > 1) {
+ # synchronize for old code reaching directly into guts
+ $_[0]->{quote_table_names}
+ = $_[0]->{quote_field_names}
+ = $_[1] ? 1 : 0;
+ }
+};
+
+has producer => ( is => 'rw', default => sub { $DEFAULT_SUB } );
-sub producer {
+around producer => sub {
+ my $orig = shift;
shift->_tool({
- name => 'producer',
- path => "SQL::Translator::Producer",
- default_sub => "produce",
+ orig => $orig,
+ name => 'producer',
+ path => "SQL::Translator::Producer",
+ default_sub => "produce",
}, @_);
-}
+};
+
+has producer_type => ( is => 'rwp', init_arg => undef );
-sub producer_type { $_[0]->{'producer_type'} }
+around producer_type => carp_ro('producer_type');
-sub producer_args { shift->_args("producer", @_); }
+has producer_args => ( is => 'rw', default => quote_sub(q{ +{} }) );
-sub parser {
+around producer_args => sub {
+ my $orig = shift;
+ shift->_args($orig, @_);
+};
+
+has parser => ( is => 'rw', default => sub { $DEFAULT_SUB } );
+
+around parser => sub {
+ my $orig = shift;
shift->_tool({
+ orig => $orig,
name => 'parser',
path => "SQL::Translator::Parser",
default_sub => "parse",
}, @_);
-}
-
-sub parser_type { $_[0]->{'parser_type'}; }
-
-sub parser_args { shift->_args("parser", @_); }
+};
+
+has parser_type => ( is => 'rwp', init_arg => undef );
+
+around parser_type => carp_ro('parser_type');
+
+has parser_args => ( is => 'rw', default => quote_sub(q{ +{} }) );
+
+around parser_args => sub {
+ my $orig = shift;
+ shift->_args($orig, @_);
+};
+
+has filters => (
+ is => 'rw',
+ default => quote_sub(q{ [] }),
+ coerce => sub {
+ my @filters;
+ # Set. Convert args to list of [\&code,@args]
+ foreach (@{$_[0]||[]}) {
+ my ($filt,@args) = ref($_) eq "ARRAY" ? @$_ : $_;
+ if ( isa($filt,"CODE") ) {
+ push @filters, [$filt,@args];
+ next;
+ }
+ else {
+ __PACKAGE__->debug("Adding $filt filter. Args:".Dumper(\@args)."\n") if __PACKAGE__->debugging;
+ $filt = _load_sub("$filt\::filter", "SQL::Translator::Filter")
+ || throw(__PACKAGE__->error);
+ push @filters, [$filt,@args];
+ }
+ }
+ return \@filters;
+ },
+);
-sub filters {
+around filters => sub {
+ my $orig = shift;
my $self = shift;
- my $filters = $self->{filters} ||= [];
- return @$filters unless @_;
-
- # Set. Convert args to list of [\&code,@args]
- foreach (@_) {
- my ($filt,@args) = ref($_) eq "ARRAY" ? @$_ : $_;
- if ( isa($filt,"CODE") ) {
- push @$filters, [$filt,@args];
- next;
+ return @{$self->$orig([@{$self->$orig}, @_])} if @_;
+ return @{$self->$orig};
+};
+
+has filename => (
+ is => 'rw',
+ isa => sub {
+ foreach my $filename (ref($_[0]) eq 'ARRAY' ? @{$_[0]} : $_[0]) {
+ if (-d $filename) {
+ throw("Cannot use directory '$filename' as input source");
+ }
+ elsif (not -f _ && -r _) {
+ throw("Cannot use '$filename' as input source: ".
+ "file does not exist or is not readable.");
+ }
}
- else {
- $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];
+ },
+);
+
+around filename => \&ex2err;
+
+has data => (
+ is => 'rw',
+ builder => 1,
+ lazy => 1,
+ coerce => sub {
+ # Set $self->data based on what was passed in. We will
+ # accept a number of things; do our best to get it right.
+ my $data = shift;
+ if (isa($data, 'ARRAY')) {
+ $data = join '', @$data;
}
- }
- return @$filters;
-}
-
-sub show_warnings {
- my $self = shift;
- my $arg = shift;
- if ( defined $arg ) {
- $self->{'show_warnings'} = $arg ? 1 : 0;
- }
- return $self->{'show_warnings'} || 0;
-}
-
-
-sub filename {
- my $self = shift;
- if (@_) {
- my $filename = shift;
- if (-d $filename) {
- my $msg = "Cannot use directory '$filename' as input source";
- return $self->error($msg);
- } elsif (ref($filename) eq 'ARRAY') {
- $self->{'filename'} = $filename;
- $self->debug("Got array of files: ".join(', ',@$filename)."\n");
- } elsif (-f _ && -r _) {
- $self->{'filename'} = $filename;
- $self->debug("Got filename: '$self->{'filename'}'\n");
- } else {
- my $msg = "Cannot use '$filename' as input source: ".
- "file does not exist or is not readable.";
- return $self->error($msg);
+ elsif (isa($data, 'GLOB')) {
+ seek ($data, 0, 0) if eof ($data);
+ local $/;
+ $data = <$data>;
}
- }
-
- $self->{'filename'};
-}
+ return isa($data, 'SCALAR') ? $data : \$data;
+ },
+);
-sub data {
+around data => sub {
+ my $orig = shift;
my $self = shift;
- # Set $self->{'data'} based on what was passed in. We will
- # accept a number of things; do our best to get it right.
- if (@_) {
- my $data = shift;
- if (isa($data, "SCALAR")) {
- $self->{'data'} = $data;
- }
- else {
- if (isa($data, 'ARRAY')) {
- $data = join '', @$data;
- }
- elsif (isa($data, 'GLOB')) {
- seek ($data, 0, 0) if eof ($data);
- local $/;
- $data = <$data>;
- }
- elsif (! ref $data && @_) {
- $data = join '', $data, @_;
- }
- $self->{'data'} = \$data;
- }
+ if (@_ > 1 && !ref $_[0]) {
+ return $self->$orig(\join('', @_));
+ }
+ elsif (@_) {
+ return $self->$orig(@_);
}
+ return ex2err($orig, $self);
+};
+sub _build_data {
+ my $self = shift;
# If we have a filename but no data yet, populate.
- if (not $self->{'data'} and my $filename = $self->filename) {
+ if (my $filename = $self->filename) {
$self->debug("Opening '$filename' to get contents.\n");
- local *FH;
local $/;
my $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': $!");
- }
+ open my $fh, '<', $file
+ or throw("Can't read file '$file': $!");
- $data .= <FH>;
+ $data .= <$fh>;
- unless (close FH) {
- return $self->error("Can't close file '$file': $!");
- }
+ close $fh or throw("Can't close file '$file': $!");
}
- $self->{'data'} = \$data;
+ return \$data;
}
-
- return $self->{'data'};
-}
-
-sub reset {
-#
-# Deletes the existing Schema object so that future calls to translate
-# don't append to the existing.
-#
- my $self = shift;
- $self->{'schema'} = undef;
- return 1;
}
-sub schema {
-#
-# Returns the SQL::Translator::Schema object
-#
- my $self = shift;
-
- unless ( defined $self->{'schema'} ) {
- $self->{'schema'} = SQL::Translator::Schema->new(
- translator => $self,
- );
- }
+has schema => (
+ is => 'lazy',
+ init_arg => undef,
+ clearer => 'reset',
+ predicate => '_has_schema',
+);
- return $self->{'schema'};
-}
+around schema => carp_ro('schema');
-sub trace {
+around reset => sub {
+ my $orig = shift;
my $self = shift;
- my $arg = shift;
- if ( defined $arg ) {
- $self->{'trace'} = $arg ? 1 : 0;
- }
- return $self->{'trace'} || 0;
-}
+ $self->$orig(@_);
+ return 1
+};
+
+sub _build_schema { SQL::Translator::Schema->new(translator => shift) }
sub translate {
my $self = shift;
# ----------------------------------------------------------------
# Run parser
- unless ( defined $self->{'schema'} ) {
+ unless ( $self->_has_schema ) {
eval { $parser_output = $parser->($self, $$data) };
if ($@ || ! $parser_output) {
my $msg = sprintf "translate: Error with parser '%s': %s",
return $self->error($msg);
}
}
- $self->debug("Schema =\n", Dumper($self->schema), "\n");
+ $self->debug("Schema =\n", Dumper($self->schema), "\n") if $self->debugging;;
# Validate the schema if asked to.
if ($self->validate) {
# ----------------------------------------------------------------------
sub _args {
my $self = shift;
- my $type = shift;
- $type = "${type}_args" unless $type =~ /_args$/;
-
- unless (defined $self->{$type} && isa($self->{$type}, 'HASH')) {
- $self->{$type} = { };
- }
+ my $orig = shift;
if (@_) {
# If the first argument is an explicit undef (remember, we
# out the producer_args hash.
if (! defined $_[0]) {
shift @_;
- %{$self->{$type}} = ();
+ $self->$orig({});
}
my $args = isa($_[0], 'HASH') ? shift : { @_ };
- %{$self->{$type}} = (%{$self->{$type}}, %$args);
+ return $self->$orig({ %{$self->$orig}, %$args });
}
- $self->{$type};
+ return $self->$orig;
}
# ----------------------------------------------------------------------
sub _tool {
my ($self,$args) = (shift, shift);
my $name = $args->{name};
+ my $orig = $args->{orig};
return $self->{$name} unless @_; # get accessor
my $path = $args->{path};
# passed an anonymous subroutine reference
if (isa($tool, 'CODE')) {
- $self->{$name} = $tool;
- $self->{"$name\_type"} = "CODE";
+ $self->$orig($tool);
+ $self->${\"_set_${name}_type"}("CODE");
$self->debug("Got $name: code ref\n");
}
# get code reference and assign
my (undef,$module,undef) = $sub =~ m/((.*)::)?(\w+)$/;
- $self->{$name} = $code;
- $self->{"$name\_type"} = $sub eq "CODE" ? "CODE" : $module;
+ $self->$orig($code);
+ $self->${\"_set_$name\_type"}($sub eq "CODE" ? "CODE" : $module);
$self->debug("Got $name: $sub\n");
}
return $VERSION;
}
-sub validate {
- my ( $self, $arg ) = @_;
- if ( defined $arg ) {
- $self->{'validate'} = $arg ? 1 : 0;
- }
- return $self->{'validate'} || 0;
-}
+# Must come after all 'has' declarations
+around new => \&ex2err;
1;
=head1 CONSTRUCTOR
+=head2 new
+
The constructor is called C<new>, and accepts a optional hash of options.
Valid options are:
=head2 filters
-Set or retreive the filters to run over the schema during the
+Set or retrieve 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 hash of options (passed as a list) for the rest of the args.
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 GETTING HELP/SUPPORT
+
+If you are stuck with a problem or have doubts about a particular
+approach do not hesitate to contact us via any of the following
+options (the list is sorted by "fastest response time"):
- sqlfairy-developers@lists.sourceforge.net
+=over
-Or send us a message (with your Sourceforge username) asking to be
-added to the project and what you'd like to contribute.
+=item * IRC: irc.perl.org#sql-translator
+=for html
+<a href="https://chat.mibbit.com/#sql-translator@irc.perl.org">(click for instant chatroom login)</a>
-=head1 COPYRIGHT
+=item * Mailing list: L<http://lists.scsys.co.uk/mailman/listinfo/dbix-class>
-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.
+=item * RT Bug Tracker: L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=SQL-Translator>
-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.
+=back
+
+=head1 HOW TO CONTRIBUTE
+
+Contributions are always welcome, in all usable forms (we especially
+welcome documentation improvements). The delivery methods include git-
+or unified-diff formatted patches, GitHub pull requests, or plain bug
+reports either via RT or the Mailing list. Contributors are generally
+granted access to the official repository after their first several
+patches pass successful review. Don't hesitate to
+L<contact|/GETTING HELP/SUPPORT> us with any further questions you may
+have.
+
+This project is maintained in a git repository. The code and related tools are
+accessible at the following locations:
+
+=over
+
+=item * Official repo: L<git://git.shadowcat.co.uk/dbsrgits/SQL-Translator.git>
+
+=item * Official gitweb: L<http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits/SQL-Translator.git>
+
+=item * GitHub mirror: L<https://github.com/dbsrgits/SQL-Translator>
+
+=item * Authorized committers: L<ssh://dbsrgits@git.shadowcat.co.uk/sql-translator.git>
+
+=item * Travis-CI log: L<https://travis-ci.org/dbsrgits/sql-translator/builds>
+
+=for html
+↪ Stable branch CI status: <img src="https://secure.travis-ci.org/dbsrgits/sql-translator.png?branch=master"></img>
+
+=back
+
+=head1 COPYRIGHT
-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
+Copyright 2012 the SQL::Translator authors, as listed in L</AUTHORS>.
-=head1 BUGS
+=head1 LICENSE
-Please use L<http://rt.cpan.org/> for reporting bugs.
+This library is free software and may be distributed under the same terms as
+Perl 5 itself.
=head1 PRAISE
projects / dbsrgits/SQL-Translator.git / blobdiff