lib/SQL/Translator.pm

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