lib/SQL/Translator.pm

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