lib/SQL/Translator.pm

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