lib/SQL/Translator.pm

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