lib/SQL/Translator.pm

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