lib/SQL/Translator.pm

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