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