lib/SQL/Translator.pm

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