lib/SQL/Translator.pm

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