lib/SQL/Translator.pm

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