lib/SQL/Translator.pm

   1 package SQL::Translator;
   2
   3 use Moo;
   4 our ( $DEFAULT_SUB, $DEBUG, $ERROR );
   5
   6 our $VERSION  = '0.11019';
   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 The constructor is called C<new>, and accepts a optional hash of options.
 771 Valid options are:
 772
 773 =over 4
 774
 775 =item *
 776
 777 parser / from
 778
 779 =item *
 780
 781 parser_args
 782
 783 =item *
 784
 785 producer / to
 786
 787 =item *
 788
 789 producer_args
 790
 791 =item *
 792
 793 filters
 794
 795 =item *
 796
 797 filename / file
 798
 799 =item *
 800
 801 data
 802
 803 =item *
 804
 805 debug
 806
 807 =item *
 808
 809 add_drop_table
 810
 811 =item *
 812
 813 quote_identifiers
 814
 815 =item *
 816
 817 quote_table_names (DEPRECATED)
 818
 819 =item *
 820
 821 quote_field_names (DEPRECATED)
 822
 823 =item *
 824
 825 no_comments
 826
 827 =item *
 828
 829 trace
 830
 831 =item *
 832
 833 validate
 834
 835 =back
 836
 837 All options are, well, optional; these attributes can be set via
 838 instance methods.  Internally, they are; no (non-syntactical)
 839 advantage is gained by passing options to the constructor.
 840
 841 =head1 METHODS
 842
 843 =head2 add_drop_table
 844
 845 Toggles whether or not to add "DROP TABLE" statements just before the
 846 create definitions.
 847
 848 =head2 quote_identifiers
 849
 850 Toggles whether or not to quote identifiers (table, column, constraint, etc.)
 851 with a quoting mechanism suitable for the chosen Producer. The default (true)
 852 is to quote them.
 853
 854 =head2 quote_table_names
 855
 856 DEPRECATED - A legacy proxy to L</quote_identifiers>
 857
 858 =head2 quote_field_names
 859
 860 DEPRECATED - A legacy proxy to L</quote_identifiers>
 861
 862 =head2 no_comments
 863
 864 Toggles whether to print comments in the output.  Accepts a true or false
 865 value, returns the current value.
 866
 867 =head2 producer
 868
 869 The C<producer> method is an accessor/mutator, used to retrieve or
 870 define what subroutine is called to produce the output.  A subroutine
 871 defined as a producer will be invoked as a function (I<not a method>)
 872 and passed its container C<SQL::Translator> instance, which it should
 873 call the C<schema> method on, to get the C<SQL::Translator::Schema>
 874 generated by the parser.  It is expected that the function transform the
 875 schema structure to a string.  The C<SQL::Translator> instance is also useful
 876 for informational purposes; for example, the type of the parser can be
 877 retrieved using the C<parser_type> method, and the C<error> and
 878 C<debug> methods can be called when needed.
 879
 880 When defining a producer, one of several things can be passed in:  A
 881 module name (e.g., C<My::Groovy::Producer>), a module name relative to
 882 the C<SQL::Translator::Producer> namespace (e.g., C<MySQL>), a module
 883 name and function combination (C<My::Groovy::Producer::transmogrify>),
 884 or a reference to an anonymous subroutine.  If a full module name is
 885 passed in (for the purposes of this method, a string containing "::"
 886 is considered to be a module name), it is treated as a package, and a
 887 function called "produce" will be invoked: C<$modulename::produce>.
 888 If $modulename cannot be loaded, the final portion is stripped off and
 889 treated as a function.  In other words, if there is no file named
 890 F<My/Groovy/Producer/transmogrify.pm>, C<SQL::Translator> will attempt
 891 to load F<My/Groovy/Producer.pm> and use C<transmogrify> as the name of
 892 the function, instead of the default C<produce>.
 893
 894   my $tr = SQL::Translator->new;
 895
 896   # This will invoke My::Groovy::Producer::produce($tr, $data)
 897   $tr->producer("My::Groovy::Producer");
 898
 899   # This will invoke SQL::Translator::Producer::Sybase::produce($tr, $data)
 900   $tr->producer("Sybase");
 901
 902   # This will invoke My::Groovy::Producer::transmogrify($tr, $data),
 903   # assuming that My::Groovy::Producer::transmogrify is not a module
 904   # on disk.
 905   $tr->producer("My::Groovy::Producer::transmogrify");
 906
 907   # This will invoke the referenced subroutine directly, as
 908   # $subref->($tr, $data);
 909   $tr->producer(\&my_producer);
 910
 911 There is also a method named C<producer_type>, which is a string
 912 containing the classname to which the above C<produce> function
 913 belongs.  In the case of anonymous subroutines, this method returns
 914 the string "CODE".
 915
 916 Finally, there is a method named C<producer_args>, which is both an
 917 accessor and a mutator.  Arbitrary data may be stored in name => value
 918 pairs for the producer subroutine to access:
 919
 920   sub My::Random::producer {
 921       my ($tr, $data) = @_;
 922       my $pr_args = $tr->producer_args();
 923
 924       # $pr_args is a hashref.
 925
 926 Extra data passed to the C<producer> method is passed to
 927 C<producer_args>:
 928
 929   $tr->producer("xSV", delimiter => ',\s*');
 930
 931   # In SQL::Translator::Producer::xSV:
 932   my $args = $tr->producer_args;
 933   my $delimiter = $args->{'delimiter'}; # value is ,\s*
 934
 935 =head2 parser
 936
 937 The C<parser> method defines or retrieves a subroutine that will be
 938 called to perform the parsing.  The basic idea is the same as that of
 939 C<producer> (see above), except the default subroutine name is
 940 "parse", and will be invoked as C<$module_name::parse($tr, $data)>.
 941 Also, the parser subroutine will be passed a string containing the
 942 entirety of the data to be parsed.
 943
 944   # Invokes SQL::Translator::Parser::MySQL::parse()
 945   $tr->parser("MySQL");
 946
 947   # Invokes My::Groovy::Parser::parse()
 948   $tr->parser("My::Groovy::Parser");
 949
 950   # Invoke an anonymous subroutine directly
 951   $tr->parser(sub {
 952     my $dumper = Data::Dumper->new([ $_[1] ], [ "SQL" ]);
 953     $dumper->Purity(1)->Terse(1)->Deepcopy(1);
 954     return $dumper->Dump;
 955   });
 956
 957 There is also C<parser_type> and C<parser_args>, which perform
 958 analogously to C<producer_type> and C<producer_args>
 959
 960 =head2 filters
 961
 962 Set or retrieve the filters to run over the schema during the
 963 translation, before the producer creates its output. Filters are sub
 964 routines called, in order, with the schema object to filter as the 1st
 965 arg and a hash of options (passed as a list) for the rest of the args.
 966 They are free to do whatever they want to the schema object, which will be
 967 handed to any following filters, then used by the producer.
 968
 969 Filters are set as an array, which gives the order they run in.
 970 Like parsers and producers, they can be defined by a module name, a
 971 module name relative to the SQL::Translator::Filter namespace, a module
 972 name and function name together or a reference to an anonymous subroutine.
 973 When using a module name a function called C<filter> will be invoked in
 974 that package to do the work.
 975
 976 To pass args to the filter set it as an array ref with the 1st value giving
 977 the filter (name or sub) and the rest its args. e.g.
 978
 979  $tr->filters(
 980      sub {
 981         my $schema = shift;
 982         # Do stuff to schema here!
 983      },
 984      DropFKeys,
 985      [ "Names", table => 'lc' ],
 986      [ "Foo",   foo => "bar", hello => "world" ],
 987      [ "Filter5" ],
 988  );
 989
 990 Although you normally set them in the constructor, which calls
 991 through to filters. i.e.
 992
 993   my $translator  = SQL::Translator->new(
 994       ...
 995       filters => [
 996           sub { ... },
 997           [ "Names", table => 'lc' ],
 998       ],
 999       ...
1000   );
1001
1002 See F<t/36-filters.t> for more examples.
1003
1004 Multiple set calls to filters are cumulative with new filters added to
1005 the end of the current list.
1006
1007 Returns the filters as a list of array refs, the 1st value being a
1008 reference to the filter sub and the rest its args.
1009
1010 =head2 show_warnings
1011
1012 Toggles whether to print warnings of name conflicts, identifier
1013 mutations, etc.  Probably only generated by producers to let the user
1014 know when something won't translate very smoothly (e.g., MySQL "enum"
1015 fields into Oracle).  Accepts a true or false value, returns the
1016 current value.
1017
1018 =head2 translate
1019
1020 The C<translate> method calls the subroutine referenced by the
1021 C<parser> data member, then calls any C<filters> and finally calls
1022 the C<producer> sub routine (these members are described above).
1023 It accepts as arguments a number of things, in key => value format,
1024 including (potentially) a parser and a producer (they are passed
1025 directly to the C<parser> and C<producer> methods).
1026
1027 Here is how the parameter list to C<translate> is parsed:
1028
1029 =over
1030
1031 =item *
1032
1033 1 argument means it's the data to be parsed; which could be a string
1034 (filename) or a reference to a scalar (a string stored in memory), or a
1035 reference to a hash, which is parsed as being more than one argument
1036 (see next section).
1037
1038   # Parse the file /path/to/datafile
1039   my $output = $tr->translate("/path/to/datafile");
1040
1041   # Parse the data contained in the string $data
1042   my $output = $tr->translate(\$data);
1043
1044 =item *
1045
1046 More than 1 argument means its a hash of things, and it might be
1047 setting a parser, producer, or datasource (this key is named
1048 "filename" or "file" if it's a file, or "data" for a SCALAR reference.
1049
1050   # As above, parse /path/to/datafile, but with different producers
1051   for my $prod ("MySQL", "XML", "Sybase") {
1052       print $tr->translate(
1053                 producer => $prod,
1054                 filename => "/path/to/datafile",
1055             );
1056   }
1057
1058   # The filename hash key could also be:
1059       datasource => \$data,
1060
1061 You get the idea.
1062
1063 =back
1064
1065 =head2 filename, data
1066
1067 Using the C<filename> method, the filename of the data to be parsed
1068 can be set. This method can be used in conjunction with the C<data>
1069 method, below.  If both the C<filename> and C<data> methods are
1070 invoked as mutators, the data set in the C<data> method is used.
1071
1072     $tr->filename("/my/data/files/create.sql");
1073
1074 or:
1075
1076     my $create_script = do {
1077         local $/;
1078         open CREATE, "/my/data/files/create.sql" or die $!;
1079         <CREATE>;
1080     };
1081     $tr->data(\$create_script);
1082
1083 C<filename> takes a string, which is interpreted as a filename.
1084 C<data> takes a reference to a string, which is used as the data to be
1085 parsed.  If a filename is set, then that file is opened and read when
1086 the C<translate> method is called, as long as the data instance
1087 variable is not set.
1088
1089 =head2 schema
1090
1091 Returns the SQL::Translator::Schema object.
1092
1093 =head2 trace
1094
1095 Turns on/off the tracing option of Parse::RecDescent.
1096
1097 =head2 validate
1098
1099 Whether or not to validate the schema object after parsing and before
1100 producing.
1101
1102 =head2 version
1103
1104 Returns the version of the SQL::Translator release.
1105
1106 =head1 AUTHORS
1107
1108 See the included AUTHORS file:
1109 L<http://search.cpan.org/dist/SQL-Translator/AUTHORS>
1110
1111 If you would like to contribute to the project, you can send patches
1112 to the developers mailing list:
1113
1114     sqlfairy-developers@lists.sourceforge.net
1115
1116 Or send us a message (with your Sourceforge username) asking to be
1117 added to the project and what you'd like to contribute.
1118
1119
1120 =head1 COPYRIGHT
1121
1122 Copyright 2012 the SQL::Translator authors, as listed in L</AUTHORS>.
1123
1124 =head1 LICENSE
1125
1126 This library is free software and may be distributed under the same terms as
1127 Perl 5 itself.
1128
1129 =head1 BUGS
1130
1131 Please use L<http://rt.cpan.org/> for reporting bugs.
1132
1133 =head1 PRAISE
1134
1135 If you find this module useful, please use
1136 L<http://cpanratings.perl.org/rate/?distribution=SQL-Translator> to rate it.
1137
1138 =head1 SEE ALSO
1139
1140 L<perl>,
1141 L<SQL::Translator::Parser>,
1142 L<SQL::Translator::Producer>,
1143 L<Parse::RecDescent>,
1144 L<GD>,
1145 L<GraphViz>,
1146 L<Text::RecordParser>,
1147 L<Class::DBI>,
1148 L<XML::Writer>.