lib/SQL/Translator.pm

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