lib/SQL/Translator.pm

   1 package SQL::Translator;
   2
   3 use Moo;
   4 our ( $DEFAULT_SUB, $DEBUG, $ERROR );
   5
   6 our $VERSION  = '0.11020';
   7 $DEBUG    = 0 unless defined $DEBUG;
   8 $ERROR    = "";
   9
  10 use Carp qw(carp croak);
  11
  12 use Data::Dumper;
  13 use File::Find;
  14 use File::Spec::Functions qw(catfile);
  15 use File::Basename qw(dirname);
  16 use IO::Dir;
  17 use Sub::Quote qw(quote_sub);
  18 use SQL::Translator::Producer;
  19 use SQL::Translator::Schema;
  20 use SQL::Translator::Utils qw(throw ex2err carp_ro);
  21
  22 $DEFAULT_SUB = sub { $_[0]->schema } unless defined $DEFAULT_SUB;
  23
  24 with qw(
  25     SQL::Translator::Role::Debug
  26     SQL::Translator::Role::Error
  27     SQL::Translator::Role::BuildArgs
  28 );
  29
  30 around BUILDARGS => sub {
  31     my $orig = shift;
  32     my $self = shift;
  33     my $config = $self->$orig(@_);
  34
  35     # If a 'parser' or 'from' parameter is passed in, use that as the
  36     # parser; if a 'producer' or 'to' parameter is passed in, use that
  37     # as the producer; both default to $DEFAULT_SUB.
  38     $config->{parser} ||= $config->{from} if defined $config->{from};
  39     $config->{producer} ||= $config->{to} if defined $config->{to};
  40
  41     $config->{filename} ||= $config->{file} if defined $config->{file};
  42
  43     my $quote;
  44     if (defined $config->{quote_identifiers}) {
  45       $quote = $config->{quote_identifiers};
  46
  47       for (qw/quote_table_names quote_field_names/) {
  48         carp "Ignoring deprecated parameter '$_', since 'quote_identifiers' is supplied"
  49           if defined $config->{$_}
  50       }
  51     }
  52     # Legacy one set the other is not
  53     elsif (
  54       defined $config->{'quote_table_names'}
  55         xor
  56       defined $config->{'quote_field_names'}
  57     ) {
  58       if (defined $config->{'quote_table_names'}) {
  59         carp "Explicitly disabling the deprecated 'quote_table_names' implies disabling 'quote_identifiers' which in turn implies disabling 'quote_field_names'"
  60           unless $config->{'quote_table_names'};
  61         $quote = $config->{'quote_table_names'} ? 1 : 0;
  62       }
  63       else {
  64         carp "Explicitly disabling the deprecated 'quote_field_names' implies disabling 'quote_identifiers' which in turn implies disabling 'quote_table_names'"
  65           unless $config->{'quote_field_names'};
  66         $quote = $config->{'quote_field_names'} ? 1 : 0;
  67       }
  68     }
  69     # Legacy both are set
  70     elsif(defined $config->{'quote_table_names'}) {
  71       croak 'Setting quote_table_names and quote_field_names to conflicting values is no longer supported'
  72         if ($config->{'quote_table_names'} xor $config->{'quote_field_names'});
  73
  74       $quote = $config->{'quote_table_names'} ? 1 : 0;
  75     }
  76
  77     $config->{quote_identifiers} = $quote if defined $quote;
  78
  79     return $config;
  80 };
  81
  82 sub BUILD {
  83     my ($self) = @_;
  84     # Make sure all the tool-related stuff is set up
  85     foreach my $tool (qw(producer parser)) {
  86         $self->$tool($self->$tool);
  87     }
  88 }
  89
  90 has $_ => (
  91     is => 'rw',
  92     default => quote_sub(q{ 0 }),
  93     coerce => quote_sub(q{ $_[0] ? 1 : 0 }),
  94 ) foreach qw(add_drop_table no_comments show_warnings trace validate);
  95
  96 # quote_identifiers is on by default, use a 0-but-true as indicator
  97 # so we can allow individual producers to change the default
  98 has quote_identifiers => (
  99     is => 'rw',
 100     default => quote_sub(q{ '0E0' }),
 101     coerce => quote_sub(q{ $_[0] || 0 }),
 102 );
 103
 104 sub quote_table_names {
 105     (@_ > 1 and ($_[1] xor $_[0]->quote_identifiers) )
 106         ? croak 'Using quote_table_names as a setter is no longer supported'
 107         : $_[0]->quote_identifiers;
 108 }
 109
 110 sub quote_field_names {
 111     (@_ > 1 and ($_[1] xor $_[0]->quote_identifiers) )
 112         ? croak 'Using quote_field_names as a setter is no longer supported'
 113         : $_[0]->quote_identifiers;
 114 }
 115
 116 after quote_identifiers => sub {
 117     if (@_ > 1) {
 118         # synchronize for old code reaching directly into guts
 119         $_[0]->{quote_table_names}
 120             = $_[0]->{quote_field_names}
 121                 = $_[1] ? 1 : 0;
 122     }
 123 };
 124
 125 has producer => ( is => 'rw', default => sub { $DEFAULT_SUB } );
 126
 127 around producer => sub {
 128     my $orig = shift;
 129     shift->_tool({
 130         orig => $orig,
 131         name => 'producer',
 132         path => "SQL::Translator::Producer",
 133         default_sub => "produce",
 134     }, @_);
 135 };
 136
 137 has producer_type => ( is => 'rwp', init_arg => undef );
 138
 139 around producer_type => carp_ro('producer_type');
 140
 141 has producer_args => ( is => 'rw', default => quote_sub(q{ +{} }) );
 142
 143 around producer_args => sub {
 144     my $orig = shift;
 145     shift->_args($orig, @_);
 146 };
 147
 148 has parser => ( is => 'rw', default => sub { $DEFAULT_SUB }  );
 149
 150 around parser => sub {
 151     my $orig = shift;
 152     shift->_tool({
 153         orig => $orig,
 154         name => 'parser',
 155         path => "SQL::Translator::Parser",
 156         default_sub => "parse",
 157     }, @_);
 158 };
 159
 160 has parser_type => ( is => 'rwp', init_arg => undef );
 161
 162 around parser_type => carp_ro('parser_type');
 163
 164 has parser_args => ( is => 'rw', default => quote_sub(q{ +{} }) );
 165
 166 around parser_args => sub {
 167     my $orig = shift;
 168     shift->_args($orig, @_);
 169 };
 170
 171 has filters => (
 172     is => 'rw',
 173     default => quote_sub(q{ [] }),
 174     coerce => sub {
 175         my @filters;
 176         # Set. Convert args to list of [\&code,@args]
 177         foreach (@{$_[0]||[]}) {
 178             my ($filt,@args) = ref($_) eq "ARRAY" ? @$_ : $_;
 179             if ( isa($filt,"CODE") ) {
 180                 push @filters, [$filt,@args];
 181                 next;
 182             }
 183             else {
 184                 __PACKAGE__->debug("Adding $filt filter. Args:".Dumper(\@args)."\n");
 185                 $filt = _load_sub("$filt\::filter", "SQL::Translator::Filter")
 186                     || throw(__PACKAGE__->error);
 187                 push @filters, [$filt,@args];
 188             }
 189         }
 190         return \@filters;
 191     },
 192 );
 193
 194 around filters => sub {
 195     my $orig = shift;
 196     my $self = shift;
 197     return @{$self->$orig([@{$self->$orig}, @_])} if @_;
 198     return @{$self->$orig};
 199 };
 200
 201 has filename => (
 202     is => 'rw',
 203     isa => sub {
 204         foreach my $filename (ref($_[0]) eq 'ARRAY' ? @{$_[0]} : $_[0]) {
 205             if (-d $filename) {
 206                 throw("Cannot use directory '$filename' as input source");
 207             }
 208             elsif (not -f _ && -r _) {
 209                 throw("Cannot use '$filename' as input source: ".
 210                       "file does not exist or is not readable.");
 211             }
 212         }
 213     },
 214 );
 215
 216 around filename => \&ex2err;
 217
 218 has data => (
 219     is => 'rw',
 220     builder => 1,
 221     lazy => 1,
 222     coerce => sub {
 223         # Set $self->data based on what was passed in.  We will
 224         # accept a number of things; do our best to get it right.
 225         my $data = shift;
 226         if (isa($data, 'ARRAY')) {
 227             $data = join '', @$data;
 228         }
 229         elsif (isa($data, 'GLOB')) {
 230             seek ($data, 0, 0) if eof ($data);
 231             local $/;
 232             $data = <$data>;
 233         }
 234         return isa($data, 'SCALAR') ? $data : \$data;
 235     },
 236 );
 237
 238 around data => sub {
 239     my $orig = shift;
 240     my $self = shift;
 241
 242     if (@_ > 1 && !ref $_[0]) {
 243         return $self->$orig(\join('', @_));
 244     }
 245     elsif (@_) {
 246         return $self->$orig(@_);
 247     }
 248     return ex2err($orig, $self);
 249 };
 250
 251 sub _build_data {
 252     my $self = shift;
 253     # If we have a filename but no data yet, populate.
 254     if (my $filename = $self->filename) {
 255         $self->debug("Opening '$filename' to get contents.\n");
 256         local $/;
 257         my $data;
 258
 259         my @files = ref($filename) eq 'ARRAY' ? @$filename : ($filename);
 260
 261         foreach my $file (@files) {
 262             open my $fh, '<', $file
 263                or throw("Can't read file '$file': $!");
 264
 265             $data .= <$fh>;
 266
 267             close $fh or throw("Can't close file '$file': $!");
 268         }
 269
 270         return \$data;
 271     }
 272 }
 273
 274 has schema => (
 275     is => 'lazy',
 276     init_arg => undef,
 277     clearer => 'reset',
 278     predicate => '_has_schema',
 279 );
 280
 281 around schema => carp_ro('schema');
 282
 283 around reset => sub {
 284     my $orig = shift;
 285     my $self = shift;
 286     $self->$orig(@_);
 287     return 1
 288 };
 289
 290 sub _build_schema { SQL::Translator::Schema->new(translator => shift) }
 291
 292 sub translate {
 293     my $self = shift;
 294     my ($args, $parser, $parser_type, $producer, $producer_type);
 295     my ($parser_output, $producer_output, @producer_output);
 296
 297     # Parse arguments
 298     if (@_ == 1) {
 299         # Passed a reference to a hash?
 300         if (isa($_[0], 'HASH')) {
 301             # yep, a hashref
 302             $self->debug("translate: Got a hashref\n");
 303             $args = $_[0];
 304         }
 305
 306         # Passed a GLOB reference, i.e., filehandle
 307         elsif (isa($_[0], 'GLOB')) {
 308             $self->debug("translate: Got a GLOB reference\n");
 309             $self->data($_[0]);
 310         }
 311
 312         # Passed a reference to a string containing the data
 313         elsif (isa($_[0], 'SCALAR')) {
 314             # passed a ref to a string
 315             $self->debug("translate: Got a SCALAR reference (string)\n");
 316             $self->data($_[0]);
 317         }
 318
 319         # Not a reference; treat it as a filename
 320         elsif (! ref $_[0]) {
 321             # Not a ref, it's a filename
 322             $self->debug("translate: Got a filename\n");
 323             $self->filename($_[0]);
 324         }
 325
 326         # Passed something else entirely.
 327         else {
 328             # We're not impressed.  Take your empty string and leave.
 329             # return "";
 330
 331             # Actually, if data, parser, and producer are set, then we
 332             # can continue.  Too bad, because I like my comment
 333             # (above)...
 334             return "" unless ($self->data     &&
 335                               $self->producer &&
 336                               $self->parser);
 337         }
 338     }
 339     else {
 340         # You must pass in a hash, or you get nothing.
 341         return "" if @_ % 2;
 342         $args = { @_ };
 343     }
 344
 345     # ----------------------------------------------------------------------
 346     # Can specify the data to be transformed using "filename", "file",
 347     # "data", or "datasource".
 348     # ----------------------------------------------------------------------
 349     if (my $filename = ($args->{'filename'} || $args->{'file'})) {
 350         $self->filename($filename);
 351     }
 352
 353     if (my $data = ($args->{'data'} || $args->{'datasource'})) {
 354         $self->data($data);
 355     }
 356
 357     # ----------------------------------------------------------------
 358     # Get the data.
 359     # ----------------------------------------------------------------
 360     my $data = $self->data;
 361
 362     # ----------------------------------------------------------------
 363     # Local reference to the parser subroutine
 364     # ----------------------------------------------------------------
 365     if ($parser = ($args->{'parser'} || $args->{'from'})) {
 366         $self->parser($parser);
 367     }
 368     $parser      = $self->parser;
 369     $parser_type = $self->parser_type;
 370
 371     # ----------------------------------------------------------------
 372     # Local reference to the producer subroutine
 373     # ----------------------------------------------------------------
 374     if ($producer = ($args->{'producer'} || $args->{'to'})) {
 375         $self->producer($producer);
 376     }
 377     $producer      = $self->producer;
 378     $producer_type = $self->producer_type;
 379
 380     # ----------------------------------------------------------------
 381     # Execute the parser, the filters and then execute the producer.
 382     # Allowances are made for each piece to die, or fail to compile,
 383     # since the referenced subroutines could be almost anything.  In
 384     # the future, each of these might happen in a Safe environment,
 385     # depending on how paranoid we want to be.
 386     # ----------------------------------------------------------------
 387
 388     # Run parser
 389     unless ( $self->_has_schema ) {
 390         eval { $parser_output = $parser->($self, $$data) };
 391         if ($@ || ! $parser_output) {
 392             my $msg = sprintf "translate: Error with parser '%s': %s",
 393                 $parser_type, ($@) ? $@ : " no results";
 394             return $self->error($msg);
 395         }
 396     }
 397     $self->debug("Schema =\n", Dumper($self->schema), "\n");
 398
 399     # Validate the schema if asked to.
 400     if ($self->validate) {
 401         my $schema = $self->schema;
 402         return $self->error('Invalid schema') unless $schema->is_valid;
 403     }
 404
 405     # Run filters
 406     my $filt_num = 0;
 407     foreach ($self->filters) {
 408         $filt_num++;
 409         my ($code,@args) = @$_;
 410         eval { $code->($self->schema, @args) };
 411         my $err = $@ || $self->error || 0;
 412         return $self->error("Error with filter $filt_num : $err") if $err;
 413     }
 414
 415     # Run producer
 416     # Calling wantarray in the eval no work, wrong scope.
 417     my $wantarray = wantarray ? 1 : 0;
 418     eval {
 419         if ($wantarray) {
 420             @producer_output = $producer->($self);
 421         } else {
 422             $producer_output = $producer->($self);
 423         }
 424     };
 425     if ($@ || !( $producer_output || @producer_output)) {
 426         my $err = $@ || $self->error || "no results";
 427         my $msg = "translate: Error with producer '$producer_type': $err";
 428         return $self->error($msg);
 429     }
 430
 431     return wantarray ? @producer_output : $producer_output;
 432 }
 433
 434 sub list_parsers {
 435     return shift->_list("parser");
 436 }
 437
 438 sub list_producers {
 439     return shift->_list("producer");
 440 }
 441
 442
 443 # ======================================================================
 444 # Private Methods
 445 # ======================================================================
 446
 447 # ----------------------------------------------------------------------
 448 # _args($type, \%args);
 449 #
 450 # Gets or sets ${type}_args.  Called by parser_args and producer_args.
 451 # ----------------------------------------------------------------------
 452 sub _args {
 453     my $self = shift;
 454     my $orig = shift;
 455
 456     if (@_) {
 457         # If the first argument is an explicit undef (remember, we
 458         # don't get here unless there is stuff in @_), then we clear
 459         # out the producer_args hash.
 460         if (! defined $_[0]) {
 461             shift @_;
 462             $self->$orig({});
 463         }
 464
 465         my $args = isa($_[0], 'HASH') ? shift : { @_ };
 466         return $self->$orig({ %{$self->$orig}, %$args });
 467     }
 468
 469     return $self->$orig;
 470 }
 471
 472 # ----------------------------------------------------------------------
 473 # Does the get/set work for parser and producer. e.g.
 474 # return $self->_tool({
 475 #   name => 'producer',
 476 #   path => "SQL::Translator::Producer",
 477 #   default_sub => "produce",
 478 # }, @_);
 479 # ----------------------------------------------------------------------
 480 sub _tool {
 481     my ($self,$args) = (shift, shift);
 482     my $name = $args->{name};
 483     my $orig = $args->{orig};
 484     return $self->{$name} unless @_; # get accessor
 485
 486     my $path = $args->{path};
 487     my $default_sub = $args->{default_sub};
 488     my $tool = shift;
 489
 490     # passed an anonymous subroutine reference
 491     if (isa($tool, 'CODE')) {
 492         $self->$orig($tool);
 493         $self->${\"_set_${name}_type"}("CODE");
 494         $self->debug("Got $name: code ref\n");
 495     }
 496
 497     # Module name was passed directly
 498     # We try to load the name; if it doesn't load, there's a
 499     # possibility that it has a function name attached to it,
 500     # so we give it a go.
 501     else {
 502         $tool =~ s/-/::/g if $tool !~ /::/;
 503         my ($code,$sub);
 504         ($code,$sub) = _load_sub("$tool\::$default_sub", $path);
 505         unless ($code) {
 506             if ( __PACKAGE__->error =~ m/Can't find module/ ) {
 507                 # Mod not found so try sub
 508                 ($code,$sub) = _load_sub("$tool", $path) unless $code;
 509                 die "Can't load $name subroutine '$tool' : ".__PACKAGE__->error
 510                 unless $code;
 511             }
 512             else {
 513                 die "Can't load $name '$tool' : ".__PACKAGE__->error;
 514             }
 515         }
 516
 517         # get code reference and assign
 518         my (undef,$module,undef) = $sub =~ m/((.*)::)?(\w+)$/;
 519         $self->$orig($code);
 520         $self->${\"_set_$name\_type"}($sub eq "CODE" ? "CODE" : $module);
 521         $self->debug("Got $name: $sub\n");
 522     }
 523
 524     # At this point, $self->{$name} contains a subroutine
 525     # reference that is ready to run
 526
 527     # Anything left?  If so, it's args
 528     my $meth = "$name\_args";
 529     $self->$meth(@_) if (@_);
 530
 531     return $self->{$name};
 532 }
 533
 534 # ----------------------------------------------------------------------
 535 # _list($type)
 536 # ----------------------------------------------------------------------
 537 sub _list {
 538     my $self   = shift;
 539     my $type   = shift || return ();
 540     my $uctype = ucfirst lc $type;
 541
 542     #
 543     # First find all the directories where SQL::Translator
 544     # parsers or producers (the "type") appear to live.
 545     #
 546     load("SQL::Translator::$uctype") or return ();
 547     my $path = catfile "SQL", "Translator", $uctype;
 548     my @dirs;
 549     for (@INC) {
 550         my $dir = catfile $_, $path;
 551         $self->debug("_list_${type}s searching $dir\n");
 552         next unless -d $dir;
 553         push @dirs, $dir;
 554     }
 555
 556     #
 557     # Now use File::File::find to look recursively in those
 558     # directories for all the *.pm files, then present them
 559     # with the slashes turned into dashes.
 560     #
 561     my %found;
 562     find(
 563         sub {
 564             if ( -f && m/\.pm$/ ) {
 565                 my $mod      =  $_;
 566                    $mod      =~ s/\.pm$//;
 567                 my $cur_dir  = $File::Find::dir;
 568                 my $base_dir = quotemeta catfile 'SQL', 'Translator', $uctype;
 569
 570                 #
 571                 # See if the current directory is below the base directory.
 572                 #
 573                 if ( $cur_dir =~ m/$base_dir(.*)/ ) {
 574                     $cur_dir = $1;
 575                     $cur_dir =~ s!^/!!;  # kill leading slash
 576                     $cur_dir =~ s!/!-!g; # turn other slashes into dashes
 577                 }
 578                 else {
 579                     $cur_dir = '';
 580                 }
 581
 582                 $found{ join '-', map { $_ || () } $cur_dir, $mod } = 1;
 583             }
 584         },
 585         @dirs
 586     );
 587
 588     return sort { lc $a cmp lc $b } keys %found;
 589 }
 590
 591 # ----------------------------------------------------------------------
 592 # load(MODULE [,PATH[,PATH]...])
 593 #
 594 # Loads a Perl module.  Short circuits if a module is already loaded.
 595 #
 596 # MODULE - is the name of the module to load.
 597 #
 598 # PATH - optional list of 'package paths' to look for the module in. e.g
 599 # If you called load('Super::Foo' => 'My', 'Other') it will
 600 # try to load the mod Super::Foo then My::Super::Foo then Other::Super::Foo.
 601 #
 602 # Returns package name of the module actually loaded or false and sets error.
 603 #
 604 # Note, you can't load a name from the root namespace (ie one without '::' in
 605 # it), therefore a single word name without a path fails.
 606 # ----------------------------------------------------------------------
 607 sub load {
 608     my $name = shift;
 609     my @path;
 610     push @path, "" if $name =~ /::/; # Empty path to check name on its own first
 611     push @path, @_ if @_;
 612
 613     foreach (@path) {
 614         my $module = $_ ? "$_\::$name" : $name;
 615         my $file = $module; $file =~ s[::][/]g; $file .= ".pm";
 616         __PACKAGE__->debug("Loading $name as $file\n");
 617         return $module if $INC{$file}; # Already loaded
 618
 619         eval { require $file };
 620         next if $@ =~ /Can't locate $file in \@INC/;
 621         eval { $module->import() } unless $@;
 622         return __PACKAGE__->error("Error loading $name as $module : $@")
 623         if $@ && $@ !~ /"SQL::Translator::Producer" is not exported/;
 624
 625         return $module; # Module loaded ok
 626     }
 627
 628     return __PACKAGE__->error("Can't find module $name. Path:".join(",",@path));
 629 }
 630
 631 # ----------------------------------------------------------------------
 632 # Load the sub name given (including package), optionally using a base package
 633 # path. Returns code ref and name of sub loaded, including its package.
 634 # (\&code, $sub) = load_sub( 'MySQL::produce', "SQL::Translator::Producer" );
 635 # (\&code, $sub) = load_sub( 'MySQL::produce', @path );
 636 # ----------------------------------------------------------------------
 637 sub _load_sub {
 638     my ($tool, @path) = @_;
 639
 640     my (undef,$module,$func_name) = $tool =~ m/((.*)::)?(\w+)$/;
 641     if ( my $module = load($module => @path) ) {
 642         my $sub = "$module\::$func_name";
 643         return wantarray ? ( \&{ $sub }, $sub ) : \&$sub;
 644     }
 645     return undef;
 646 }
 647
 648 sub format_table_name {
 649     return shift->_format_name('_format_table_name', @_);
 650 }
 651
 652 sub format_package_name {
 653     return shift->_format_name('_format_package_name', @_);
 654 }
 655
 656 sub format_fk_name {
 657     return shift->_format_name('_format_fk_name', @_);
 658 }
 659
 660 sub format_pk_name {
 661     return shift->_format_name('_format_pk_name', @_);
 662 }
 663
 664 # ----------------------------------------------------------------------
 665 # The other format_*_name methods rely on this one.  It optionally
 666 # accepts a subroutine ref as the first argument (or uses an identity
 667 # sub if one isn't provided or it doesn't already exist), and applies
 668 # it to the rest of the arguments (if any).
 669 # ----------------------------------------------------------------------
 670 sub _format_name {
 671     my $self = shift;
 672     my $field = shift;
 673     my @args = @_;
 674
 675     if (ref($args[0]) eq 'CODE') {
 676         $self->{$field} = shift @args;
 677     }
 678     elsif (! exists $self->{$field}) {
 679         $self->{$field} = sub { return shift };
 680     }
 681
 682     return @args ? $self->{$field}->(@args) : $self->{$field};
 683 }
 684
 685 sub isa($$) {
 686     my ($ref, $type) = @_;
 687     return UNIVERSAL::isa($ref, $type);
 688 }
 689
 690 sub version {
 691     my $self = shift;
 692     return $VERSION;
 693 }
 694
 695 # Must come after all 'has' declarations
 696 around new => \&ex2err;
 697
 698 1;
 699
 700 # ----------------------------------------------------------------------
 701 # Who killed the pork chops?
 702 # What price bananas?
 703 # Are you my Angel?
 704 # Allen Ginsberg
 705 # ----------------------------------------------------------------------
 706
 707 =pod
 708
 709 =head1 NAME
 710
 711 SQL::Translator - manipulate structured data definitions (SQL and more)
 712
 713 =head1 SYNOPSIS
 714
 715   use SQL::Translator;
 716
 717   my $translator          = SQL::Translator->new(
 718       # Print debug info
 719       debug               => 1,
 720       # Print Parse::RecDescent trace
 721       trace               => 0,
 722       # Don't include comments in output
 723       no_comments         => 0,
 724       # Print name mutations, conflicts
 725       show_warnings       => 0,
 726       # Add "drop table" statements
 727       add_drop_table      => 1,
 728       # to quote or not to quote, thats the question
 729       quote_identifiers     => 1,
 730       # Validate schema object
 731       validate            => 1,
 732       # Make all table names CAPS in producers which support this option
 733       format_table_name   => sub {my $tablename = shift; return uc($tablename)},
 734       # Null-op formatting, only here for documentation's sake
 735       format_package_name => sub {return shift},
 736       format_fk_name      => sub {return shift},
 737       format_pk_name      => sub {return shift},
 738   );
 739
 740   my $output     = $translator->translate(
 741       from       => 'MySQL',
 742       to         => 'Oracle',
 743       # Or an arrayref of filenames, i.e. [ $file1, $file2, $file3 ]
 744       filename   => $file,
 745   ) or die $translator->error;
 746
 747   print $output;
 748
 749 =head1 DESCRIPTION
 750
 751 This documentation covers the API for SQL::Translator.  For a more general
 752 discussion of how to use the modules and scripts, please see
 753 L<SQL::Translator::Manual>.
 754
 755 SQL::Translator is a group of Perl modules that converts
 756 vendor-specific SQL table definitions into other formats, such as
 757 other vendor-specific SQL, ER diagrams, documentation (POD and HTML),
 758 XML, and Class::DBI classes.  The main focus of SQL::Translator is
 759 SQL, but parsers exist for other structured data formats, including
 760 Excel spreadsheets and arbitrarily delimited text files.  Through the
 761 separation of the code into parsers and producers with an object model
 762 in between, it's possible to combine any parser with any producer, to
 763 plug in custom parsers or producers, or to manipulate the parsed data
 764 via the built-in object model.  Presently only the definition parts of
 765 SQL are handled (CREATE, ALTER), not the manipulation of data (INSERT,
 766 UPDATE, DELETE).
 767
 768 =head1 CONSTRUCTOR
 769
 770 =head2 new
 771
 772 The constructor is called C<new>, and accepts a optional hash of options.
 773 Valid options are:
 774
 775 =over 4
 776
 777 =item *
 778
 779 parser / from
 780
 781 =item *
 782
 783 parser_args
 784
 785 =item *
 786
 787 producer / to
 788
 789 =item *
 790
 791 producer_args
 792
 793 =item *
 794
 795 filters
 796
 797 =item *
 798
 799 filename / file
 800
 801 =item *
 802
 803 data
 804
 805 =item *
 806
 807 debug
 808
 809 =item *
 810
 811 add_drop_table
 812
 813 =item *
 814
 815 quote_identifiers
 816
 817 =item *
 818
 819 quote_table_names (DEPRECATED)
 820
 821 =item *
 822
 823 quote_field_names (DEPRECATED)
 824
 825 =item *
 826
 827 no_comments
 828
 829 =item *
 830
 831 trace
 832
 833 =item *
 834
 835 validate
 836
 837 =back
 838
 839 All options are, well, optional; these attributes can be set via
 840 instance methods.  Internally, they are; no (non-syntactical)
 841 advantage is gained by passing options to the constructor.
 842
 843 =head1 METHODS
 844
 845 =head2 add_drop_table
 846
 847 Toggles whether or not to add "DROP TABLE" statements just before the
 848 create definitions.
 849
 850 =head2 quote_identifiers
 851
 852 Toggles whether or not to quote identifiers (table, column, constraint, etc.)
 853 with a quoting mechanism suitable for the chosen Producer. The default (true)
 854 is to quote them.
 855
 856 =head2 quote_table_names
 857
 858 DEPRECATED - A legacy proxy to L</quote_identifiers>
 859
 860 =head2 quote_field_names
 861
 862 DEPRECATED - A legacy proxy to L</quote_identifiers>
 863
 864 =head2 no_comments
 865
 866 Toggles whether to print comments in the output.  Accepts a true or false
 867 value, returns the current value.
 868
 869 =head2 producer
 870
 871 The C<producer> method is an accessor/mutator, used to retrieve or
 872 define what subroutine is called to produce the output.  A subroutine
 873 defined as a producer will be invoked as a function (I<not a method>)
 874 and passed its container C<SQL::Translator> instance, which it should
 875 call the C<schema> method on, to get the C<SQL::Translator::Schema>
 876 generated by the parser.  It is expected that the function transform the
 877 schema structure to a string.  The C<SQL::Translator> instance is also useful
 878 for informational purposes; for example, the type of the parser can be
 879 retrieved using the C<parser_type> method, and the C<error> and
 880 C<debug> methods can be called when needed.
 881
 882 When defining a producer, one of several things can be passed in:  A
 883 module name (e.g., C<My::Groovy::Producer>), a module name relative to
 884 the C<SQL::Translator::Producer> namespace (e.g., C<MySQL>), a module
 885 name and function combination (C<My::Groovy::Producer::transmogrify>),
 886 or a reference to an anonymous subroutine.  If a full module name is
 887 passed in (for the purposes of this method, a string containing "::"
 888 is considered to be a module name), it is treated as a package, and a
 889 function called "produce" will be invoked: C<$modulename::produce>.
 890 If $modulename cannot be loaded, the final portion is stripped off and
 891 treated as a function.  In other words, if there is no file named
 892 F<My/Groovy/Producer/transmogrify.pm>, C<SQL::Translator> will attempt
 893 to load F<My/Groovy/Producer.pm> and use C<transmogrify> as the name of
 894 the function, instead of the default C<produce>.
 895
 896   my $tr = SQL::Translator->new;
 897
 898   # This will invoke My::Groovy::Producer::produce($tr, $data)
 899   $tr->producer("My::Groovy::Producer");
 900
 901   # This will invoke SQL::Translator::Producer::Sybase::produce($tr, $data)
 902   $tr->producer("Sybase");
 903
 904   # This will invoke My::Groovy::Producer::transmogrify($tr, $data),
 905   # assuming that My::Groovy::Producer::transmogrify is not a module
 906   # on disk.
 907   $tr->producer("My::Groovy::Producer::transmogrify");
 908
 909   # This will invoke the referenced subroutine directly, as
 910   # $subref->($tr, $data);
 911   $tr->producer(\&my_producer);
 912
 913 There is also a method named C<producer_type>, which is a string
 914 containing the classname to which the above C<produce> function
 915 belongs.  In the case of anonymous subroutines, this method returns
 916 the string "CODE".
 917
 918 Finally, there is a method named C<producer_args>, which is both an
 919 accessor and a mutator.  Arbitrary data may be stored in name => value
 920 pairs for the producer subroutine to access:
 921
 922   sub My::Random::producer {
 923       my ($tr, $data) = @_;
 924       my $pr_args = $tr->producer_args();
 925
 926       # $pr_args is a hashref.
 927
 928 Extra data passed to the C<producer> method is passed to
 929 C<producer_args>:
 930
 931   $tr->producer("xSV", delimiter => ',\s*');
 932
 933   # In SQL::Translator::Producer::xSV:
 934   my $args = $tr->producer_args;
 935   my $delimiter = $args->{'delimiter'}; # value is ,\s*
 936
 937 =head2 parser
 938
 939 The C<parser> method defines or retrieves a subroutine that will be
 940 called to perform the parsing.  The basic idea is the same as that of
 941 C<producer> (see above), except the default subroutine name is
 942 "parse", and will be invoked as C<$module_name::parse($tr, $data)>.
 943 Also, the parser subroutine will be passed a string containing the
 944 entirety of the data to be parsed.
 945
 946   # Invokes SQL::Translator::Parser::MySQL::parse()
 947   $tr->parser("MySQL");
 948
 949   # Invokes My::Groovy::Parser::parse()
 950   $tr->parser("My::Groovy::Parser");
 951
 952   # Invoke an anonymous subroutine directly
 953   $tr->parser(sub {
 954     my $dumper = Data::Dumper->new([ $_[1] ], [ "SQL" ]);
 955     $dumper->Purity(1)->Terse(1)->Deepcopy(1);
 956     return $dumper->Dump;
 957   });
 958
 959 There is also C<parser_type> and C<parser_args>, which perform
 960 analogously to C<producer_type> and C<producer_args>
 961
 962 =head2 filters
 963
 964 Set or retrieve the filters to run over the schema during the
 965 translation, before the producer creates its output. Filters are sub
 966 routines called, in order, with the schema object to filter as the 1st
 967 arg and a hash of options (passed as a list) for the rest of the args.
 968 They are free to do whatever they want to the schema object, which will be
 969 handed to any following filters, then used by the producer.
 970
 971 Filters are set as an array, which gives the order they run in.
 972 Like parsers and producers, they can be defined by a module name, a
 973 module name relative to the SQL::Translator::Filter namespace, a module
 974 name and function name together or a reference to an anonymous subroutine.
 975 When using a module name a function called C<filter> will be invoked in
 976 that package to do the work.
 977
 978 To pass args to the filter set it as an array ref with the 1st value giving
 979 the filter (name or sub) and the rest its args. e.g.
 980
 981  $tr->filters(
 982      sub {
 983         my $schema = shift;
 984         # Do stuff to schema here!
 985      },
 986      DropFKeys,
 987      [ "Names", table => 'lc' ],
 988      [ "Foo",   foo => "bar", hello => "world" ],
 989      [ "Filter5" ],
 990  );
 991
 992 Although you normally set them in the constructor, which calls
 993 through to filters. i.e.
 994
 995   my $translator  = SQL::Translator->new(
 996       ...
 997       filters => [
 998           sub { ... },
 999           [ "Names", table => 'lc' ],
1000       ],
1001       ...
1002   );
1003
1004 See F<t/36-filters.t> for more examples.
1005
1006 Multiple set calls to filters are cumulative with new filters added to
1007 the end of the current list.
1008
1009 Returns the filters as a list of array refs, the 1st value being a
1010 reference to the filter sub and the rest its args.
1011
1012 =head2 show_warnings
1013
1014 Toggles whether to print warnings of name conflicts, identifier
1015 mutations, etc.  Probably only generated by producers to let the user
1016 know when something won't translate very smoothly (e.g., MySQL "enum"
1017 fields into Oracle).  Accepts a true or false value, returns the
1018 current value.
1019
1020 =head2 translate
1021
1022 The C<translate> method calls the subroutine referenced by the
1023 C<parser> data member, then calls any C<filters> and finally calls
1024 the C<producer> sub routine (these members are described above).
1025 It accepts as arguments a number of things, in key => value format,
1026 including (potentially) a parser and a producer (they are passed
1027 directly to the C<parser> and C<producer> methods).
1028
1029 Here is how the parameter list to C<translate> is parsed:
1030
1031 =over
1032
1033 =item *
1034
1035 1 argument means it's the data to be parsed; which could be a string
1036 (filename) or a reference to a scalar (a string stored in memory), or a
1037 reference to a hash, which is parsed as being more than one argument
1038 (see next section).
1039
1040   # Parse the file /path/to/datafile
1041   my $output = $tr->translate("/path/to/datafile");
1042
1043   # Parse the data contained in the string $data
1044   my $output = $tr->translate(\$data);
1045
1046 =item *
1047
1048 More than 1 argument means its a hash of things, and it might be
1049 setting a parser, producer, or datasource (this key is named
1050 "filename" or "file" if it's a file, or "data" for a SCALAR reference.
1051
1052   # As above, parse /path/to/datafile, but with different producers
1053   for my $prod ("MySQL", "XML", "Sybase") {
1054       print $tr->translate(
1055                 producer => $prod,
1056                 filename => "/path/to/datafile",
1057             );
1058   }
1059
1060   # The filename hash key could also be:
1061       datasource => \$data,
1062
1063 You get the idea.
1064
1065 =back
1066
1067 =head2 filename, data
1068
1069 Using the C<filename> method, the filename of the data to be parsed
1070 can be set. This method can be used in conjunction with the C<data>
1071 method, below.  If both the C<filename> and C<data> methods are
1072 invoked as mutators, the data set in the C<data> method is used.
1073
1074     $tr->filename("/my/data/files/create.sql");
1075
1076 or:
1077
1078     my $create_script = do {
1079         local $/;
1080         open CREATE, "/my/data/files/create.sql" or die $!;
1081         <CREATE>;
1082     };
1083     $tr->data(\$create_script);
1084
1085 C<filename> takes a string, which is interpreted as a filename.
1086 C<data> takes a reference to a string, which is used as the data to be
1087 parsed.  If a filename is set, then that file is opened and read when
1088 the C<translate> method is called, as long as the data instance
1089 variable is not set.
1090
1091 =head2 schema
1092
1093 Returns the SQL::Translator::Schema object.
1094
1095 =head2 trace
1096
1097 Turns on/off the tracing option of Parse::RecDescent.
1098
1099 =head2 validate
1100
1101 Whether or not to validate the schema object after parsing and before
1102 producing.
1103
1104 =head2 version
1105
1106 Returns the version of the SQL::Translator release.
1107
1108 =head1 AUTHORS
1109
1110 See the included AUTHORS file:
1111 L<http://search.cpan.org/dist/SQL-Translator/AUTHORS>
1112
1113 If you would like to contribute to the project, you can send patches
1114 to the developers mailing list:
1115
1116     sqlfairy-developers@lists.sourceforge.net
1117
1118 Or send us a message (with your Sourceforge username) asking to be
1119 added to the project and what you'd like to contribute.
1120
1121
1122 =head1 COPYRIGHT
1123
1124 Copyright 2012 the SQL::Translator authors, as listed in L</AUTHORS>.
1125
1126 =head1 LICENSE
1127
1128 This library is free software and may be distributed under the same terms as
1129 Perl 5 itself.
1130
1131 =head1 BUGS
1132
1133 Please use L<http://rt.cpan.org/> for reporting bugs.
1134
1135 =head1 PRAISE
1136
1137 If you find this module useful, please use
1138 L<http://cpanratings.perl.org/rate/?distribution=SQL-Translator> to rate it.
1139
1140 =head1 SEE ALSO
1141
1142 L<perl>,
1143 L<SQL::Translator::Parser>,
1144 L<SQL::Translator::Producer>,
1145 L<Parse::RecDescent>,
1146 L<GD>,
1147 L<GraphViz>,
1148 L<Text::RecordParser>,
1149 L<Class::DBI>,
1150 L<XML::Writer>.