lib/SQL/Translator.pm

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