lib/SQL/Translator.pm

   1 package SQL::Translator;
   2
   3 # ----------------------------------------------------------------------
   4 # $Id: Translator.pm,v 1.22 2003-04-17 23:16:28 allenday Exp $
   5 # ----------------------------------------------------------------------
   6 # Copyright (C) 2003 Ken Y. Clark <kclark@cpan.org>,
   7 #                    darren chamberlain <darren@cpan.org>,
   8 #                    Chris Mungall <cjm@fruitfly.org>
   9 #
  10 # This program is free software; you can redistribute it and/or
  11 # modify it under the terms of the GNU General Public License as
  12 # published by the Free Software Foundation; version 2.
  13 #
  14 # This program is distributed in the hope that it will be useful, but
  15 # WITHOUT ANY WARRANTY; without even the implied warranty of
  16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17 # General Public License for more details.
  18 #
  19 # You should have received a copy of the GNU General Public License
  20 # along with this program; if not, write to the Free Software
  21 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
  22 # 02111-1307  USA
  23 # -------------------------------------------------------------------
  24
  25 use strict;
  26 use vars qw( $VERSION $REVISION $DEFAULT_SUB $DEBUG $ERROR );
  27 use base 'Class::Base';
  28
  29 $VERSION  = '0.01';
  30 $REVISION = sprintf "%d.%02d", q$Revision: 1.22 $ =~ /(\d+)\.(\d+)/;
  31 $DEBUG    = 0 unless defined $DEBUG;
  32 $ERROR    = "";
  33
  34 use Carp qw(carp);
  35
  36 use File::Spec::Functions qw(catfile);
  37 use File::Basename qw(dirname);
  38 use IO::Dir;
  39
  40 # ----------------------------------------------------------------------
  41 # The default behavior is to "pass through" values (note that the
  42 # SQL::Translator instance is the first value ($_[0]), and the stuff
  43 # to be parsed is the second value ($_[1])
  44 # ----------------------------------------------------------------------
  45 $DEFAULT_SUB = sub { $_[1] } unless defined $DEFAULT_SUB;
  46
  47 # ----------------------------------------------------------------------
  48 # init([ARGS])
  49 #   The constructor.
  50 #
  51 #   new takes an optional hash of arguments.  These arguments may
  52 #   include a parser, specified with the keys "parser" or "from",
  53 #   and a producer, specified with the keys "producer" or "to".
  54 #
  55 #   The values that can be passed as the parser or producer are
  56 #   given directly to the parser or producer methods, respectively.
  57 #   See the appropriate method description below for details about
  58 #   what each expects/accepts.
  59 # ----------------------------------------------------------------------
  60 sub init {
  61     my ( $self, $config ) = @_;
  62
  63     #
  64     # Set the parser and producer.
  65     #
  66     # If a 'parser' or 'from' parameter is passed in, use that as the
  67     # parser; if a 'producer' or 'to' parameter is passed in, use that
  68     # as the producer; both default to $DEFAULT_SUB.
  69     #
  70     $self->parser  ($config->{'parser'}   || $config->{'from'} || $DEFAULT_SUB);
  71     $self->producer($config->{'producer'} || $config->{'to'}   || $DEFAULT_SUB);
  72
  73         #
  74         # Set up callbacks for formatting of pk,fk,table,package names in producer
  75         #
  76         $self->format_table_name($config->{'format_table_name'});
  77         $self->format_package_name($config->{'format_package_name'});
  78         $self->format_fk_name($config->{'format_fk_name'});
  79         $self->format_pk_name($config->{'format_pk_name'});
  80
  81     #
  82     # Set the parser_args and producer_args
  83     #
  84     for my $pargs ( qw[ parser_args producer_args ] ) {
  85         $self->$pargs( $config->{$pargs} ) if defined $config->{ $pargs };
  86     }
  87
  88     #
  89     # Set the data source, if 'filename' or 'file' is provided.
  90     #
  91     $config->{'filename'} ||= $config->{'file'} || "";
  92     $self->filename( $config->{'filename'} ) if $config->{'filename'};
  93
  94     #
  95     # Finally, if there is a 'data' parameter, use that in
  96     # preference to filename and file
  97     #
  98     if ( my $data = $config->{'data'} ) {
  99         $self->data( $data );
 100     }
 101
 102     #
 103     # Set various other options.
 104     #
 105     $self->{'debug'} = defined $config->{'debug'} ? $config->{'debug'} : $DEBUG;
 106
 107
 108     $self->add_drop_table( $config->{'add_drop_table'} );
 109
 110     $self->custom_translate( $config->{'xlate'} );
 111
 112     $self->no_comments( $config->{'no_comments'} );
 113
 114     $self->show_warnings( $config->{'show_warnings'} );
 115
 116     $self->trace( $config->{'trace'} );
 117
 118     return $self;
 119 }
 120
 121 # ----------------------------------------------------------------------
 122 # add_drop_table([$bool])
 123 # ----------------------------------------------------------------------
 124 sub add_drop_table {
 125     my $self = shift;
 126     if ( defined (my $arg = shift) ) {
 127         $self->{'add_drop_table'} = $arg ? 1 : 0;
 128     }
 129     return $self->{'add_drop_table'} || 0;
 130 }
 131
 132
 133 # ----------------------------------------------------------------------
 134 # custom_translate([$bool])
 135 # ----------------------------------------------------------------------
 136 sub custom_translate {
 137     my $self = shift;
 138     $self->{'custom_translate'} = shift if @_;
 139     return $self->{'custom_translate'} || {};
 140 }
 141
 142 # ----------------------------------------------------------------------
 143 # no_comments([$bool])
 144 # ----------------------------------------------------------------------
 145 sub no_comments {
 146     my $self = shift;
 147     my $arg  = shift;
 148     if ( defined $arg ) {
 149         $self->{'no_comments'} = $arg ? 1 : 0;
 150     }
 151     return $self->{'no_comments'} || 0;
 152 }
 153
 154
 155 # ----------------------------------------------------------------------
 156 # producer([$producer_spec])
 157 #
 158 # Get or set the producer for the current translator.
 159 # ----------------------------------------------------------------------
 160 sub producer {
 161     my $self = shift;
 162
 163     # producer as a mutator
 164     if (@_) {
 165         my $producer = shift;
 166
 167         # Passed a module name (string containing "::")
 168         if ($producer =~ /::/) {
 169             my $func_name;
 170
 171             # Module name was passed directly
 172             # We try to load the name; if it doesn't load, there's
 173             # a possibility that it has a function name attached to
 174             # it.
 175             if (load($producer)) {
 176                 $func_name = "produce";
 177             }
 178
 179             # Module::function was passed
 180             else {
 181                 # Passed Module::Name::function; try to recover
 182                 my @func_parts = split /::/, $producer;
 183                 $func_name = pop @func_parts;
 184                 $producer = join "::", @func_parts;
 185
 186                 # If this doesn't work, then we have a legitimate
 187                 # problem.
 188                 load($producer) or die "Can't load $producer: $@";
 189             }
 190
 191             # get code reference and assign
 192             $self->{'producer'} = \&{ "$producer\::$func_name" };
 193             $self->{'producer_type'} = $producer;
 194             $self->debug("Got producer: $producer\::$func_name\n");
 195         }
 196
 197         # passed an anonymous subroutine reference
 198         elsif (isa($producer, 'CODE')) {
 199             $self->{'producer'} = $producer;
 200             $self->{'producer_type'} = "CODE";
 201             $self->debug("Got producer: code ref\n");
 202         }
 203
 204         # passed a string containing no "::"; relative package name
 205         else {
 206             my $Pp = sprintf "SQL::Translator::Producer::$producer";
 207             load($Pp) or die "Can't load $Pp: $@";
 208             $self->{'producer'} = \&{ "$Pp\::produce" };
 209             $self->{'producer_type'} = $Pp;
 210             $self->debug("Got producer: $Pp\n");
 211         }
 212
 213         # At this point, $self->{'producer'} contains a subroutine
 214         # reference that is ready to run
 215
 216         # Anything left?  If so, it's producer_args
 217         $self->producer_args(@_) if (@_);
 218     }
 219
 220     return $self->{'producer'};
 221 };
 222
 223 # ----------------------------------------------------------------------
 224 # producer_type()
 225 #
 226 # producer_type is an accessor that allows producer subs to get
 227 # information about their origin.  This is poptentially important;
 228 # since all producer subs are called as subroutine references, there is
 229 # no way for a producer to find out which package the sub lives in
 230 # originally, for example.
 231 # ----------------------------------------------------------------------
 232 sub producer_type { $_[0]->{'producer_type'} }
 233
 234 # ----------------------------------------------------------------------
 235 # producer_args([\%args])
 236 #
 237 # Arbitrary name => value pairs of paramters can be passed to a
 238 # producer using this method.
 239 #
 240 # If the first argument passed in is undef, then the hash of arguments
 241 # is cleared; all subsequent elements are added to the hash of name,
 242 # value pairs stored as producer_args.
 243 # ----------------------------------------------------------------------
 244 sub producer_args {
 245     my $self = shift;
 246     return $self->_args("producer", @_);
 247 }
 248
 249 # ----------------------------------------------------------------------
 250 # parser([$parser_spec])
 251 # ----------------------------------------------------------------------
 252 sub parser {
 253     my $self = shift;
 254
 255     # parser as a mutator
 256     if (@_) {
 257         my $parser = shift;
 258
 259         # Passed a module name (string containing "::")
 260         if ($parser =~ /::/) {
 261             my $func_name;
 262
 263             # Module name was passed directly
 264             # We try to load the name; if it doesn't load, there's
 265             # a possibility that it has a function name attached to
 266             # it.
 267             if (load($parser)) {
 268                 $func_name = "parse";
 269             }
 270
 271             # Module::function was passed
 272             else {
 273                 # Passed Module::Name::function; try to recover
 274                 my @func_parts = split /::/, $parser;
 275                 $func_name = pop @func_parts;
 276                 $parser = join "::", @func_parts;
 277
 278                 # If this doesn't work, then we have a legitimate
 279                 # problem.
 280                 load($parser) or die "Can't load $parser: $@";
 281             }
 282
 283             # get code reference and assign
 284             $self->{'parser'} = \&{ "$parser\::$func_name" };
 285             $self->{'parser_type'} = $parser;
 286             $self->debug("Got parser: $parser\::$func_name\n");
 287         }
 288
 289         # passed an anonymous subroutine reference
 290         elsif ( isa( $parser, 'CODE' ) ) {
 291             $self->{'parser'}      = $parser;
 292             $self->{'parser_type'} = "CODE";
 293             $self->debug("Got parser: code ref\n");
 294         }
 295
 296         # passed a string containing no "::"; relative package name
 297         else {
 298             my $Pp = "SQL::Translator::Parser::$parser";
 299             load( $Pp ) or die "Can't load $Pp: $@";
 300             $self->{'parser'}      = \&{ "$Pp\::parse" };
 301             $self->{'parser_type'} = $Pp;
 302             $self->debug("Got parser: $Pp\n");
 303         }
 304
 305         #
 306         # At this point, $self->{'parser'} contains a subroutine
 307         # reference that is ready to run
 308         #
 309         $self->parser_args( @_ ) if (@_);
 310     }
 311
 312     return $self->{'parser'};
 313 }
 314
 315 # ----------------------------------------------------------------------
 316 sub parser_type { $_[0]->{'parser_type'} }
 317
 318 sub parser_args {
 319     my $self = shift;
 320     return $self->_args("parser", @_);
 321 }
 322
 323 sub show_warnings {
 324     my $self = shift;
 325     my $arg  = shift;
 326     if ( defined $arg ) {
 327         $self->{'show_warnings'} = $arg ? 1 : 0;
 328     }
 329     return $self->{'show_warnings'} || 0;
 330 }
 331
 332
 333 # filename - get or set the filename
 334 sub filename {
 335     my $self = shift;
 336     if (@_) {
 337         my $filename = shift;
 338         if (-d $filename) {
 339             my $msg = "Cannot use directory '$filename' as input source";
 340             return $self->error($msg);
 341         } elsif (-f _ && -r _) {
 342             $self->{'filename'} = $filename;
 343             $self->debug("Got filename: '$self->{'filename'}'\n");
 344         } else {
 345             my $msg = "Cannot use '$filename' as input source: ".
 346                       "file does not exist or is not readable.";
 347             return $self->error($msg);
 348         }
 349     }
 350
 351     $self->{'filename'};
 352 }
 353
 354 # ----------------------------------------------------------------------
 355 # data([$data])
 356 #
 357 # if $self->{'data'} is not set, but $self->{'filename'} is, then
 358 # $self->{'filename'} is opened and read, with the results put into
 359 # $self->{'data'}.
 360 # ----------------------------------------------------------------------
 361 sub data {
 362     my $self = shift;
 363
 364     # Set $self->{'data'} based on what was passed in.  We will
 365     # accept a number of things; do our best to get it right.
 366     if (@_) {
 367         my $data = shift;
 368         if (isa($data, "SCALAR")) {
 369             $self->{'data'} =  $data;
 370         }
 371         else {
 372             if (isa($data, 'ARRAY')) {
 373                 $data = join '', @$data;
 374             }
 375             elsif (isa($data, 'GLOB')) {
 376                 local $/;
 377                 $data = <$data>;
 378             }
 379             elsif (! ref $data && @_) {
 380                 $data = join '', $data, @_;
 381             }
 382             $self->{'data'} = \$data;
 383         }
 384     }
 385
 386     # If we have a filename but no data yet, populate.
 387     if (not $self->{'data'} and my $filename = $self->filename) {
 388         $self->debug("Opening '$filename' to get contents.\n");
 389         local *FH;
 390         local $/;
 391         my $data;
 392
 393         unless (open FH, $filename) {
 394             return $self->error("Can't read file '$filename': $!");
 395         }
 396
 397         $data = <FH>;
 398         $self->{'data'} = \$data;
 399
 400         unless (close FH) {
 401             return $self->error("Can't close file '$filename': $!");
 402         }
 403     }
 404
 405     return $self->{'data'};
 406 }
 407
 408
 409 sub trace {
 410     my $self = shift;
 411     my $arg  = shift;
 412     if ( defined $arg ) {
 413         $self->{'trace'} = $arg ? 1 : 0;
 414     }
 415     return $self->{'trace'} || 0;
 416 }
 417
 418 # ----------------------------------------------------------------------
 419 # translate([source], [\%args])
 420 #
 421 # translate does the actual translation.  The main argument is the
 422 # source of the data to be translated, which can be a filename, scalar
 423 # reference, or glob reference.
 424 #
 425 # Alternatively, translate takes optional arguements, which are passed
 426 # to the appropriate places.  Most notable of these arguments are
 427 # parser and producer, which can be used to set the parser and
 428 # producer, respectively.  This is the applications last chance to set
 429 # these.
 430 #
 431 # translate returns a string.
 432 # ----------------------------------------------------------------------
 433 sub translate {
 434     my $self = shift;
 435     my ($args, $parser, $parser_type, $producer, $producer_type);
 436     my ($parser_output, $producer_output);
 437
 438     # Parse arguments
 439     if (@_ == 1) {
 440         # Passed a reference to a hash?
 441         if (isa($_[0], 'HASH')) {
 442             # yep, a hashref
 443             $self->debug("translate: Got a hashref\n");
 444             $args = $_[0];
 445         }
 446
 447         # Passed a GLOB reference, i.e., filehandle
 448         elsif (isa($_[0], 'GLOB')) {
 449             $self->debug("translate: Got a GLOB reference\n");
 450             $self->data($_[0]);
 451         }
 452
 453         # Passed a reference to a string containing the data
 454         elsif (isa($_[0], 'SCALAR')) {
 455             # passed a ref to a string
 456             $self->debug("translate: Got a SCALAR reference (string)\n");
 457             $self->data($_[0]);
 458         }
 459
 460         # Not a reference; treat it as a filename
 461         elsif (! ref $_[0]) {
 462             # Not a ref, it's a filename
 463             $self->debug("translate: Got a filename\n");
 464             $self->filename($_[0]);
 465         }
 466
 467         # Passed something else entirely.
 468         else {
 469             # We're not impressed.  Take your empty string and leave.
 470             # return "";
 471
 472             # Actually, if data, parser, and producer are set, then we
 473             # can continue.  Too bad, because I like my comment
 474             # (above)...
 475             return "" unless ($self->data     &&
 476                               $self->producer &&
 477                               $self->parser);
 478         }
 479     }
 480     else {
 481         # You must pass in a hash, or you get nothing.
 482         return "" if @_ % 2;
 483         $args = { @_ };
 484     }
 485
 486     # ----------------------------------------------------------------------
 487     # Can specify the data to be transformed using "filename", "file",
 488     # "data", or "datasource".
 489     # ----------------------------------------------------------------------
 490     if (my $filename = ($args->{'filename'} || $args->{'file'})) {
 491         $self->filename($filename);
 492     }
 493
 494     if (my $data = ($args->{'data'} || $args->{'datasource'})) {
 495         $self->data($data);
 496     }
 497
 498     # ----------------------------------------------------------------
 499     # Get the data.
 500     # ----------------------------------------------------------------
 501     my $data = $self->data;
 502     unless (ref($data) eq 'SCALAR' and length $$data) {
 503         return $self->error("Empty data file!");
 504     }
 505
 506     # ----------------------------------------------------------------
 507     # Local reference to the parser subroutine
 508     # ----------------------------------------------------------------
 509     if ($parser = ($args->{'parser'} || $args->{'from'})) {
 510         $self->parser($parser);
 511     }
 512     $parser      = $self->parser;
 513     $parser_type = $self->parser_type;
 514
 515     # ----------------------------------------------------------------
 516     # Local reference to the producer subroutine
 517     # ----------------------------------------------------------------
 518     if ($producer = ($args->{'producer'} || $args->{'to'})) {
 519         $self->producer($producer);
 520     }
 521     $producer      = $self->producer;
 522     $producer_type = $self->producer_type;
 523
 524     # ----------------------------------------------------------------
 525     # Execute the parser, then execute the producer with that output.
 526     # Allowances are made for each piece to die, or fail to compile,
 527     # since the referenced subroutines could be almost anything.  In
 528     # the future, each of these might happen in a Safe environment,
 529     # depending on how paranoid we want to be.
 530     # ----------------------------------------------------------------
 531     eval { $parser_output = $parser->($self, $$data) };
 532     if ($@ || ! $parser_output) {
 533         my $msg = sprintf "translate: Error with parser '%s': %s",
 534             $parser_type, ($@) ? $@ : " no results";
 535         return $self->error($msg);
 536     }
 537
 538     eval { $producer_output = $producer->($self, $parser_output) };
 539     if ($@ || ! $producer_output) {
 540         my $msg = sprintf "translate: Error with producer '%s': %s",
 541             $producer_type, ($@) ? $@ : " no results";
 542         return $self->error($msg);
 543     }
 544
 545     return $producer_output;
 546 }
 547
 548 # ----------------------------------------------------------------------
 549 # list_parsers()
 550 #
 551 # Hacky sort of method to list all available parsers.  This has
 552 # several problems:
 553 #
 554 #   - Only finds things in the SQL::Translator::Parser namespace
 555 #
 556 #   - Only finds things that are located in the same directory
 557 #     as SQL::Translator::Parser.  Yeck.
 558 #
 559 # This method will fail in several very likely cases:
 560 #
 561 #   - Parser modules in different namespaces
 562 #
 563 #   - Parser modules in the SQL::Translator::Parser namespace that
 564 #     have any XS componenets will be installed in
 565 #     arch_lib/SQL/Translator.
 566 #
 567 # ----------------------------------------------------------------------
 568 sub list_parsers {
 569     return shift->_list("parser");
 570 }
 571
 572 # ----------------------------------------------------------------------
 573 # list_producers()
 574 #
 575 # See notes for list_parsers(), above; all the problems apply to
 576 # list_producers as well.
 577 # ----------------------------------------------------------------------
 578 sub list_producers {
 579     return shift->_list("producer");
 580 }
 581
 582
 583 # ======================================================================
 584 # Private Methods
 585 # ======================================================================
 586
 587 # ----------------------------------------------------------------------
 588 # _args($type, \%args);
 589 #
 590 # Gets or sets ${type}_args.  Called by parser_args and producer_args.
 591 # ----------------------------------------------------------------------
 592 sub _args {
 593     my $self = shift;
 594     my $type = shift;
 595     $type = "${type}_args" unless $type =~ /_args$/;
 596
 597     unless (defined $self->{$type} && isa($self->{$type}, 'HASH')) {
 598         $self->{$type} = { };
 599     }
 600
 601     if (@_) {
 602         # If the first argument is an explicit undef (remember, we
 603         # don't get here unless there is stuff in @_), then we clear
 604         # out the producer_args hash.
 605         if (! defined $_[0]) {
 606             shift @_;
 607             %{$self->{$type}} = ();
 608         }
 609
 610         my $args = isa($_[0], 'HASH') ? shift : { @_ };
 611         %{$self->{$type}} = (%{$self->{$type}}, %$args);
 612     }
 613
 614     $self->{$type};
 615 }
 616
 617
 618 # ----------------------------------------------------------------------
 619 # _list($type)
 620 # ----------------------------------------------------------------------
 621 sub _list {
 622     my $self = shift;
 623     my $type = shift || return ();
 624     my $uctype = ucfirst lc $type;
 625     my %found;
 626
 627     load("SQL::Translator::$uctype") or return ();
 628     my $path = catfile "SQL", "Translator", $uctype;
 629     for (@INC) {
 630         my $dir = catfile $_, $path;
 631         $self->debug("_list_${type}s searching $dir");
 632         next unless -d $dir;
 633
 634         my $dh = IO::Dir->new($dir);
 635         for (grep /\.pm$/, $dh->read) {
 636             s/\.pm$//;
 637             $found{ join "::", "SQL::Translator::$uctype", $_ } = 1;
 638         }
 639     }
 640
 641     return keys %found;
 642 }
 643
 644 # ----------------------------------------------------------------------
 645 # load($module)
 646 #
 647 # Loads a Perl module.  Short circuits if a module is already loaded.
 648 # ----------------------------------------------------------------------
 649 sub load {
 650     my $module = do { my $m = shift; $m =~ s[::][/]g; "$m.pm" };
 651     return 1 if $INC{$module};
 652
 653     eval { require $module };
 654
 655     return __PACKAGE__->error($@) if ($@);
 656     return 1;
 657 }
 658
 659 sub format_table_name {
 660   my $self = shift;
 661   my $sub = shift;
 662   $self->{_format_table_name} = $sub if ref($sub) eq 'CODE';
 663   return $self->{_format_table_name}->($sub,@_) if defined($self->{_format_table_name});
 664   return($sub);
 665 }
 666
 667 sub format_package_name {
 668   my $self = shift;
 669   my $sub = shift;
 670   $self->{_format_package_name} = $sub if ref($sub) eq 'CODE';
 671   return $self->{_format_package_name}->($sub,@_) if defined($self->{_format_package_name});
 672   return($sub);
 673 }
 674
 675 sub format_fk_name {
 676   my $self = shift;
 677   my $sub = shift;
 678   $self->{_format_fk_name} = $sub if ref($sub) eq 'CODE';
 679   return $self->{_format_fk_name}->($sub,@_) if defined($self->{_format_fk_name});
 680   return($sub);
 681 }
 682
 683 sub format_pk_name {
 684   my $self = shift;
 685   my $sub = shift;
 686   $self->{_format_pk_name} = $sub if ref($sub) eq 'CODE';
 687   return $self->{_format_pk_name}->($sub,@_) if defined($self->{_format_pk_name});
 688   return($sub);
 689 }
 690
 691 # ----------------------------------------------------------------------
 692 # isa($ref, $type)
 693 #
 694 # Calls UNIVERSAL::isa($ref, $type).  I think UNIVERSAL::isa is ugly,
 695 # but I like function overhead.
 696 # ----------------------------------------------------------------------
 697 sub isa($$) {
 698     my ($ref, $type) = @_;
 699     return UNIVERSAL::isa($ref, $type);
 700 }
 701
 702 1;
 703 #-----------------------------------------------------
 704 # Rescue the drowning and tie your shoestrings.
 705 # Henry David Thoreau
 706 #-----------------------------------------------------
 707
 708 __END__
 709
 710 =head1 NAME
 711
 712 SQL::Translator - convert schema from one database to another
 713
 714 =head1 SYNOPSIS
 715
 716   use SQL::Translator;
 717
 718   my $translator     = SQL::Translator->new(
 719       debug          => 1, # Print debug info
 720       trace          => 0, # Print Parse::RecDescent trace
 721       no_comments    => 0, # Don't include comments in output
 722       show_warnings  => 0, # Print name mutations, conflicts
 723       add_drop_table => 1, # Add "drop table" statements
 724
 725       #make all table names CAPS in producers which support this option
 726       format_table_name => sub {my $tablename = shift; return uc($tablename)},
 727       #null-op formatting, only here for documentation's sake
 728       format_package_name => sub {return shift},
 729       format_fk_name      => sub {return shift},
 730       format_pk_name      => sub {return shift},
 731   );
 732
 733   my $output     = $translator->translate(
 734       from       => "MySQL",
 735       to         => "Oracle",
 736       filename   => $file,
 737   ) or die $translator->error;
 738
 739   print $output;
 740
 741 =head1 DESCRIPTION
 742
 743 This module attempts to simplify the task of converting one database
 744 create syntax to another through the use of Parsers (which understand
 745 the source format) and Producers (which understand the destination
 746 format).  The idea is that any Parser can be used with any Producer in
 747 the conversion process.  So, if you wanted Postgres-to-Oracle, you
 748 would use the Postgres parser and the Oracle producer.
 749
 750 =head1 CONSTRUCTOR
 751
 752 The constructor is called B<new>, and accepts a optional hash of options.
 753 Valid options are:
 754
 755 =over 4
 756
 757 =item *
 758
 759 parser / from
 760
 761 =item *
 762
 763 parser_args
 764
 765 =item *
 766
 767 producer / to
 768
 769 =item *
 770
 771 producer_args
 772
 773 =item *
 774
 775 filename / file
 776
 777 =item *
 778
 779 data
 780
 781 =item *
 782
 783 debug
 784
 785 =back
 786
 787 All options are, well, optional; these attributes can be set via
 788 instance methods.  Internally, they are; no (non-syntactical)
 789 advantage is gained by passing options to the constructor.
 790
 791 =head1 METHODS
 792
 793 =head2 B<add_drop_table>
 794
 795 Toggles whether or not to add "DROP TABLE" statements just before the
 796 create definitions.
 797
 798 =head2 B<custom_translate>
 799
 800 Allows the user to override default translation of fields.  For example,
 801 if a MySQL "text" field would normally be converted to a "long" for Oracle,
 802 the user could specify to change it to a "CLOB."  Accepts a hashref where
 803 keys are the "from" value and values are the "to," returns the current
 804 value of the field.
 805
 806 =head2 B<no_comments>
 807
 808 Toggles whether to print comments in the output.  Accepts a true or false
 809 value, returns the current value.
 810
 811 =head2 B<producer>
 812
 813 The B<producer> method is an accessor/mutator, used to retrieve or
 814 define what subroutine is called to produce the output.  A subroutine
 815 defined as a producer will be invoked as a function (I<not a method>)
 816 and passed 2 parameters: its container C<SQL::Translator> instance and a
 817 data structure.  It is expected that the function transform the data
 818 structure to a string.  The C<SQL::Transformer> instance is provided for
 819 informational purposes; for example, the type of the parser can be
 820 retrieved using the B<parser_type> method, and the B<error> and
 821 B<debug> methods can be called when needed.
 822
 823 When defining a producer, one of several things can be passed in:  A
 824 module name (e.g., C<My::Groovy::Producer>, a module name relative to
 825 the C<SQL::Translator::Producer> namespace (e.g., MySQL), a module
 826 name and function combination (C<My::Groovy::Producer::transmogrify>),
 827 or a reference to an anonymous subroutine.  If a full module name is
 828 passed in (for the purposes of this method, a string containing "::"
 829 is considered to be a module name), it is treated as a package, and a
 830 function called "produce" will be invoked: C<$modulename::produce>.
 831 If $modulename cannot be loaded, the final portion is stripped off and
 832 treated as a function.  In other words, if there is no file named
 833 F<My/Groovy/Producer/transmogrify.pm>, C<SQL::Translator> will attempt
 834 to load F<My/Groovy/Producer.pm> and use transmogrify as the name of
 835 the function, instead of the default "produce".
 836
 837   my $tr = SQL::Translator->new;
 838
 839   # This will invoke My::Groovy::Producer::produce($tr, $data)
 840   $tr->producer("My::Groovy::Producer");
 841
 842   # This will invoke SQL::Translator::Producer::Sybase::produce($tr, $data)
 843   $tr->producer("Sybase");
 844
 845   # This will invoke My::Groovy::Producer::transmogrify($tr, $data),
 846   # assuming that My::Groovy::Producer::transmogrify is not a module
 847   # on disk.
 848   $tr->producer("My::Groovy::Producer::transmogrify");
 849
 850   # This will invoke the referenced subroutine directly, as
 851   # $subref->($tr, $data);
 852   $tr->producer(\&my_producer);
 853
 854 There is also a method named B<producer_type>, which is a string
 855 containing the classname to which the above B<produce> function
 856 belongs.  In the case of anonymous subroutines, this method returns
 857 the string "CODE".
 858
 859 Finally, there is a method named B<producer_args>, which is both an
 860 accessor and a mutator.  Arbitrary data may be stored in name => value
 861 pairs for the producer subroutine to access:
 862
 863   sub My::Random::producer {
 864       my ($tr, $data) = @_;
 865       my $pr_args = $tr->producer_args();
 866
 867       # $pr_args is a hashref.
 868
 869 Extra data passed to the B<producer> method is passed to
 870 B<producer_args>:
 871
 872   $tr->producer("xSV", delimiter => ',\s*');
 873
 874   # In SQL::Translator::Producer::xSV:
 875   my $args = $tr->producer_args;
 876   my $delimiter = $args->{'delimiter'}; # value is ,\s*
 877
 878 =head2 B<parser>
 879
 880 The B<parser> method defines or retrieves a subroutine that will be
 881 called to perform the parsing.  The basic idea is the same as that of
 882 B<producer> (see above), except the default subroutine name is
 883 "parse", and will be invoked as C<$module_name::parse($tr, $data)>.
 884 Also, the parser subroutine will be passed a string containing the
 885 entirety of the data to be parsed.
 886
 887   # Invokes SQL::Translator::Parser::MySQL::parse()
 888   $tr->parser("MySQL");
 889
 890   # Invokes My::Groovy::Parser::parse()
 891   $tr->parser("My::Groovy::Parser");
 892
 893   # Invoke an anonymous subroutine directly
 894   $tr->parser(sub {
 895     my $dumper = Data::Dumper->new([ $_[1] ], [ "SQL" ]);
 896     $dumper->Purity(1)->Terse(1)->Deepcopy(1);
 897     return $dumper->Dump;
 898   });
 899
 900 There is also B<parser_type> and B<parser_args>, which perform
 901 analogously to B<producer_type> and B<producer_args>
 902
 903 =head2 B<show_warnings>
 904
 905 Toggles whether to print warnings of name conflicts, identifier
 906 mutations, etc.  Probably only generated by producers to let the user
 907 know when something won't translate very smoothly (e.g., MySQL "enum"
 908 fields into Oracle).  Accepts a true or false value, returns the
 909 current value.
 910
 911 =head2 B<translate>
 912
 913 The B<translate> method calls the subroutines referenced by the
 914 B<parser> and B<producer> data members (described above).  It accepts
 915 as arguments a number of things, in key => value format, including
 916 (potentially) a parser and a producer (they are passed directly to the
 917 B<parser> and B<producer> methods).
 918
 919 Here is how the parameter list to B<translate> is parsed:
 920
 921 =over
 922
 923 =item *
 924
 925 1 argument means it's the data to be parsed; which could be a string
 926 (filename) or a reference to a scalar (a string stored in memory), or a
 927 reference to a hash, which is parsed as being more than one argument
 928 (see next section).
 929
 930   # Parse the file /path/to/datafile
 931   my $output = $tr->translate("/path/to/datafile");
 932
 933   # Parse the data contained in the string $data
 934   my $output = $tr->translate(\$data);
 935
 936 =item *
 937
 938 More than 1 argument means its a hash of things, and it might be
 939 setting a parser, producer, or datasource (this key is named
 940 "filename" or "file" if it's a file, or "data" for a SCALAR reference.
 941
 942   # As above, parse /path/to/datafile, but with different producers
 943   for my $prod ("MySQL", "XML", "Sybase") {
 944       print $tr->translate(
 945                 producer => $prod,
 946                 filename => "/path/to/datafile",
 947             );
 948   }
 949
 950   # The filename hash key could also be:
 951       datasource => \$data,
 952
 953 You get the idea.
 954
 955 =back
 956
 957 =head2 B<filename>, B<data>
 958
 959 Using the B<filename> method, the filename of the data to be parsed
 960 can be set. This method can be used in conjunction with the B<data>
 961 method, below.  If both the B<filename> and B<data> methods are
 962 invoked as mutators, the data set in the B<data> method is used.
 963
 964     $tr->filename("/my/data/files/create.sql");
 965
 966 or:
 967
 968     my $create_script = do {
 969         local $/;
 970         open CREATE, "/my/data/files/create.sql" or die $!;
 971         <CREATE>;
 972     };
 973     $tr->data(\$create_script);
 974
 975 B<filename> takes a string, which is interpreted as a filename.
 976 B<data> takes a reference to a string, which is used as the data to be
 977 parsed.  If a filename is set, then that file is opened and read when
 978 the B<translate> method is called, as long as the data instance
 979 variable is not set.
 980
 981 =pod
 982
 983 =head2 B<trace>
 984
 985 Turns on/off the tracing option of Parse::RecDescent.
 986
 987 =pod
 988
 989 =head1 AUTHORS
 990
 991 Ken Y. Clark, E<lt>kclark@cpan.orgE<gt>,
 992 darren chamberlain E<lt>darren@cpan.orgE<gt>,
 993 Chris Mungall E<lt>cjm@fruitfly.orgE<gt>,
 994 Allen Day E<lt>allenday@users.sourceforge.netE<gt>
 995
 996 =head1 COPYRIGHT
 997
 998 This program is free software; you can redistribute it and/or modify
 999 it under the terms of the GNU General Public License as published by
1000 the Free Software Foundation; version 2.
1001
1002 This program is distributed in the hope that it will be useful, but
1003 WITHOUT ANY WARRANTY; without even the implied warranty of
1004 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
1005 General Public License for more details.
1006
1007 You should have received a copy of the GNU General Public License
1008 along with this program; if not, write to the Free Software
1009 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
1010 USA
1011
1012 =head1 BUGS
1013
1014 Please use http://rt.cpan.org/ for reporting bugs.
1015
1016 =head1 SEE ALSO
1017
1018 L<perl>,
1019 L<SQL::Translator::Parser>,
1020 L<SQL::Translator::Producer>,
1021 L<Parse::RecDescent>
1022