lib/SQL/Translator.pm

   1 package SQL::Translator;
   2
   3 # ----------------------------------------------------------------------
   4 # $Id: Translator.pm,v 1.23 2003-04-19 23:32:34 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.23 $ =~ /(\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 (ref($filename) eq 'ARRAY') {
 342             $self->{'filename'} = $filename;
 343             $self->debug("Got array of files: ".join(', ',@$filename)."\n");
 344         } elsif (-f _ && -r _) {
 345             $self->{'filename'} = $filename;
 346             $self->debug("Got filename: '$self->{'filename'}'\n");
 347         } else {
 348             my $msg = "Cannot use '$filename' as input source: ".
 349                       "file does not exist or is not readable.";
 350             return $self->error($msg);
 351         }
 352     }
 353
 354     $self->{'filename'};
 355 }
 356
 357 # ----------------------------------------------------------------------
 358 # data([$data])
 359 #
 360 # if $self->{'data'} is not set, but $self->{'filename'} is, then
 361 # $self->{'filename'} is opened and read, with the results put into
 362 # $self->{'data'}.
 363 # ----------------------------------------------------------------------
 364 sub data {
 365     my $self = shift;
 366
 367     # Set $self->{'data'} based on what was passed in.  We will
 368     # accept a number of things; do our best to get it right.
 369     if (@_) {
 370         my $data = shift;
 371         if (isa($data, "SCALAR")) {
 372             $self->{'data'} =  $data;
 373         }
 374         else {
 375             if (isa($data, 'ARRAY')) {
 376                 $data = join '', @$data;
 377             }
 378             elsif (isa($data, 'GLOB')) {
 379                 local $/;
 380                 $data = <$data>;
 381             }
 382             elsif (! ref $data && @_) {
 383                 $data = join '', $data, @_;
 384             }
 385             $self->{'data'} = \$data;
 386         }
 387     }
 388
 389     # If we have a filename but no data yet, populate.
 390     if (not $self->{'data'} and my $filename = $self->filename) {
 391         $self->debug("Opening '$filename' to get contents.\n");
 392         local *FH;
 393         local $/;
 394         my $data;
 395
 396         my @files = ref($filename) eq 'ARRAY' ? @$filename : ($filename);
 397
 398         foreach my $file (@files) {
 399                 unless (open FH, $file) {
 400                     return $self->error("Can't read file '$file': $!");
 401                 }
 402
 403                 $data .= <FH>;
 404
 405                 unless (close FH) {
 406                     return $self->error("Can't close file '$file': $!");
 407                 }
 408         }
 409
 410         $self->{'data'} = \$data;
 411     }
 412
 413     return $self->{'data'};
 414 }
 415
 416
 417 sub trace {
 418     my $self = shift;
 419     my $arg  = shift;
 420     if ( defined $arg ) {
 421         $self->{'trace'} = $arg ? 1 : 0;
 422     }
 423     return $self->{'trace'} || 0;
 424 }
 425
 426 # ----------------------------------------------------------------------
 427 # translate([source], [\%args])
 428 #
 429 # translate does the actual translation.  The main argument is the
 430 # source of the data to be translated, which can be a filename, scalar
 431 # reference, or glob reference.
 432 #
 433 # Alternatively, translate takes optional arguements, which are passed
 434 # to the appropriate places.  Most notable of these arguments are
 435 # parser and producer, which can be used to set the parser and
 436 # producer, respectively.  This is the applications last chance to set
 437 # these.
 438 #
 439 # translate returns a string.
 440 # ----------------------------------------------------------------------
 441 sub translate {
 442     my $self = shift;
 443     my ($args, $parser, $parser_type, $producer, $producer_type);
 444     my ($parser_output, $producer_output);
 445
 446     # Parse arguments
 447     if (@_ == 1) {
 448         # Passed a reference to a hash?
 449         if (isa($_[0], 'HASH')) {
 450             # yep, a hashref
 451             $self->debug("translate: Got a hashref\n");
 452             $args = $_[0];
 453         }
 454
 455         # Passed a GLOB reference, i.e., filehandle
 456         elsif (isa($_[0], 'GLOB')) {
 457             $self->debug("translate: Got a GLOB reference\n");
 458             $self->data($_[0]);
 459         }
 460
 461         # Passed a reference to a string containing the data
 462         elsif (isa($_[0], 'SCALAR')) {
 463             # passed a ref to a string
 464             $self->debug("translate: Got a SCALAR reference (string)\n");
 465             $self->data($_[0]);
 466         }
 467
 468         # Not a reference; treat it as a filename
 469         elsif (! ref $_[0]) {
 470             # Not a ref, it's a filename
 471             $self->debug("translate: Got a filename\n");
 472             $self->filename($_[0]);
 473         }
 474
 475         # Passed something else entirely.
 476         else {
 477             # We're not impressed.  Take your empty string and leave.
 478             # return "";
 479
 480             # Actually, if data, parser, and producer are set, then we
 481             # can continue.  Too bad, because I like my comment
 482             # (above)...
 483             return "" unless ($self->data     &&
 484                               $self->producer &&
 485                               $self->parser);
 486         }
 487     }
 488     else {
 489         # You must pass in a hash, or you get nothing.
 490         return "" if @_ % 2;
 491         $args = { @_ };
 492     }
 493
 494     # ----------------------------------------------------------------------
 495     # Can specify the data to be transformed using "filename", "file",
 496     # "data", or "datasource".
 497     # ----------------------------------------------------------------------
 498     if (my $filename = ($args->{'filename'} || $args->{'file'})) {
 499         $self->filename($filename);
 500     }
 501
 502     if (my $data = ($args->{'data'} || $args->{'datasource'})) {
 503         $self->data($data);
 504     }
 505
 506     # ----------------------------------------------------------------
 507     # Get the data.
 508     # ----------------------------------------------------------------
 509     my $data = $self->data;
 510     unless (ref($data) eq 'SCALAR' and length $$data) {
 511         return $self->error("Empty data file!");
 512     }
 513
 514     # ----------------------------------------------------------------
 515     # Local reference to the parser subroutine
 516     # ----------------------------------------------------------------
 517     if ($parser = ($args->{'parser'} || $args->{'from'})) {
 518         $self->parser($parser);
 519     }
 520     $parser      = $self->parser;
 521     $parser_type = $self->parser_type;
 522
 523     # ----------------------------------------------------------------
 524     # Local reference to the producer subroutine
 525     # ----------------------------------------------------------------
 526     if ($producer = ($args->{'producer'} || $args->{'to'})) {
 527         $self->producer($producer);
 528     }
 529     $producer      = $self->producer;
 530     $producer_type = $self->producer_type;
 531
 532     # ----------------------------------------------------------------
 533     # Execute the parser, then execute the producer with that output.
 534     # Allowances are made for each piece to die, or fail to compile,
 535     # since the referenced subroutines could be almost anything.  In
 536     # the future, each of these might happen in a Safe environment,
 537     # depending on how paranoid we want to be.
 538     # ----------------------------------------------------------------
 539     eval { $parser_output = $parser->($self, $$data) };
 540     if ($@ || ! $parser_output) {
 541         my $msg = sprintf "translate: Error with parser '%s': %s",
 542             $parser_type, ($@) ? $@ : " no results";
 543         return $self->error($msg);
 544     }
 545
 546     eval { $producer_output = $producer->($self, $parser_output) };
 547     if ($@ || ! $producer_output) {
 548         my $msg = sprintf "translate: Error with producer '%s': %s",
 549             $producer_type, ($@) ? $@ : " no results";
 550         return $self->error($msg);
 551     }
 552
 553     return $producer_output;
 554 }
 555
 556 # ----------------------------------------------------------------------
 557 # list_parsers()
 558 #
 559 # Hacky sort of method to list all available parsers.  This has
 560 # several problems:
 561 #
 562 #   - Only finds things in the SQL::Translator::Parser namespace
 563 #
 564 #   - Only finds things that are located in the same directory
 565 #     as SQL::Translator::Parser.  Yeck.
 566 #
 567 # This method will fail in several very likely cases:
 568 #
 569 #   - Parser modules in different namespaces
 570 #
 571 #   - Parser modules in the SQL::Translator::Parser namespace that
 572 #     have any XS componenets will be installed in
 573 #     arch_lib/SQL/Translator.
 574 #
 575 # ----------------------------------------------------------------------
 576 sub list_parsers {
 577     return shift->_list("parser");
 578 }
 579
 580 # ----------------------------------------------------------------------
 581 # list_producers()
 582 #
 583 # See notes for list_parsers(), above; all the problems apply to
 584 # list_producers as well.
 585 # ----------------------------------------------------------------------
 586 sub list_producers {
 587     return shift->_list("producer");
 588 }
 589
 590
 591 # ======================================================================
 592 # Private Methods
 593 # ======================================================================
 594
 595 # ----------------------------------------------------------------------
 596 # _args($type, \%args);
 597 #
 598 # Gets or sets ${type}_args.  Called by parser_args and producer_args.
 599 # ----------------------------------------------------------------------
 600 sub _args {
 601     my $self = shift;
 602     my $type = shift;
 603     $type = "${type}_args" unless $type =~ /_args$/;
 604
 605     unless (defined $self->{$type} && isa($self->{$type}, 'HASH')) {
 606         $self->{$type} = { };
 607     }
 608
 609     if (@_) {
 610         # If the first argument is an explicit undef (remember, we
 611         # don't get here unless there is stuff in @_), then we clear
 612         # out the producer_args hash.
 613         if (! defined $_[0]) {
 614             shift @_;
 615             %{$self->{$type}} = ();
 616         }
 617
 618         my $args = isa($_[0], 'HASH') ? shift : { @_ };
 619         %{$self->{$type}} = (%{$self->{$type}}, %$args);
 620     }
 621
 622     $self->{$type};
 623 }
 624
 625
 626 # ----------------------------------------------------------------------
 627 # _list($type)
 628 # ----------------------------------------------------------------------
 629 sub _list {
 630     my $self = shift;
 631     my $type = shift || return ();
 632     my $uctype = ucfirst lc $type;
 633     my %found;
 634
 635     load("SQL::Translator::$uctype") or return ();
 636     my $path = catfile "SQL", "Translator", $uctype;
 637     for (@INC) {
 638         my $dir = catfile $_, $path;
 639         $self->debug("_list_${type}s searching $dir");
 640         next unless -d $dir;
 641
 642         my $dh = IO::Dir->new($dir);
 643         for (grep /\.pm$/, $dh->read) {
 644             s/\.pm$//;
 645             $found{ join "::", "SQL::Translator::$uctype", $_ } = 1;
 646         }
 647     }
 648
 649     return keys %found;
 650 }
 651
 652 # ----------------------------------------------------------------------
 653 # load($module)
 654 #
 655 # Loads a Perl module.  Short circuits if a module is already loaded.
 656 # ----------------------------------------------------------------------
 657 sub load {
 658     my $module = do { my $m = shift; $m =~ s[::][/]g; "$m.pm" };
 659     return 1 if $INC{$module};
 660
 661     eval { require $module };
 662
 663     return __PACKAGE__->error($@) if ($@);
 664     return 1;
 665 }
 666
 667 sub format_table_name {
 668   my $self = shift;
 669   my $sub = shift;
 670   $self->{_format_table_name} = $sub if ref($sub) eq 'CODE';
 671   return $self->{_format_table_name}->($sub,@_) if defined($self->{_format_table_name});
 672   return($sub);
 673 }
 674
 675 sub format_package_name {
 676   my $self = shift;
 677   my $sub = shift;
 678   $self->{_format_package_name} = $sub if ref($sub) eq 'CODE';
 679   return $self->{_format_package_name}->($sub,@_) if defined($self->{_format_package_name});
 680   return($sub);
 681 }
 682
 683 sub format_fk_name {
 684   my $self = shift;
 685   my $sub = shift;
 686   $self->{_format_fk_name} = $sub if ref($sub) eq 'CODE';
 687   return $self->{_format_fk_name}->($sub,@_) if defined($self->{_format_fk_name});
 688   return($sub);
 689 }
 690
 691 sub format_pk_name {
 692   my $self = shift;
 693   my $sub = shift;
 694   $self->{_format_pk_name} = $sub if ref($sub) eq 'CODE';
 695   return $self->{_format_pk_name}->($sub,@_) if defined($self->{_format_pk_name});
 696   return($sub);
 697 }
 698
 699 # ----------------------------------------------------------------------
 700 # isa($ref, $type)
 701 #
 702 # Calls UNIVERSAL::isa($ref, $type).  I think UNIVERSAL::isa is ugly,
 703 # but I like function overhead.
 704 # ----------------------------------------------------------------------
 705 sub isa($$) {
 706     my ($ref, $type) = @_;
 707     return UNIVERSAL::isa($ref, $type);
 708 }
 709
 710 1;
 711 #-----------------------------------------------------
 712 # Rescue the drowning and tie your shoestrings.
 713 # Henry David Thoreau
 714 #-----------------------------------------------------
 715
 716 __END__
 717
 718 =head1 NAME
 719
 720 SQL::Translator - convert schema from one database to another
 721
 722 =head1 SYNOPSIS
 723
 724   use SQL::Translator;
 725
 726   my $translator     = SQL::Translator->new(
 727       debug          => 1, # Print debug info
 728       trace          => 0, # Print Parse::RecDescent trace
 729       no_comments    => 0, # Don't include comments in output
 730       show_warnings  => 0, # Print name mutations, conflicts
 731       add_drop_table => 1, # Add "drop table" statements
 732
 733       #make all table names CAPS in producers which support this option
 734       format_table_name => sub {my $tablename = shift; return uc($tablename)},
 735       #null-op formatting, only here for documentation's sake
 736       format_package_name => sub {return shift},
 737       format_fk_name      => sub {return shift},
 738       format_pk_name      => sub {return shift},
 739   );
 740
 741   my $output     = $translator->translate(
 742       from       => "MySQL",
 743       to         => "Oracle",
 744       filename   => $file, #or an arrayref of filenames, ie [$file1,$file2,$file3]
 745   ) or die $translator->error;
 746
 747   print $output;
 748
 749 =head1 DESCRIPTION
 750
 751 This module attempts to simplify the task of converting one database
 752 create syntax to another through the use of Parsers (which understand
 753 the source format) and Producers (which understand the destination
 754 format).  The idea is that any Parser can be used with any Producer in
 755 the conversion process.  So, if you wanted Postgres-to-Oracle, you
 756 would use the Postgres parser and the Oracle producer.
 757
 758 =head1 CONSTRUCTOR
 759
 760 The constructor is called B<new>, and accepts a optional hash of options.
 761 Valid options are:
 762
 763 =over 4
 764
 765 =item *
 766
 767 parser / from
 768
 769 =item *
 770
 771 parser_args
 772
 773 =item *
 774
 775 producer / to
 776
 777 =item *
 778
 779 producer_args
 780
 781 =item *
 782
 783 filename / file
 784
 785 =item *
 786
 787 data
 788
 789 =item *
 790
 791 debug
 792
 793 =back
 794
 795 All options are, well, optional; these attributes can be set via
 796 instance methods.  Internally, they are; no (non-syntactical)
 797 advantage is gained by passing options to the constructor.
 798
 799 =head1 METHODS
 800
 801 =head2 B<add_drop_table>
 802
 803 Toggles whether or not to add "DROP TABLE" statements just before the
 804 create definitions.
 805
 806 =head2 B<custom_translate>
 807
 808 Allows the user to override default translation of fields.  For example,
 809 if a MySQL "text" field would normally be converted to a "long" for Oracle,
 810 the user could specify to change it to a "CLOB."  Accepts a hashref where
 811 keys are the "from" value and values are the "to," returns the current
 812 value of the field.
 813
 814 =head2 B<no_comments>
 815
 816 Toggles whether to print comments in the output.  Accepts a true or false
 817 value, returns the current value.
 818
 819 =head2 B<producer>
 820
 821 The B<producer> method is an accessor/mutator, used to retrieve or
 822 define what subroutine is called to produce the output.  A subroutine
 823 defined as a producer will be invoked as a function (I<not a method>)
 824 and passed 2 parameters: its container C<SQL::Translator> instance and a
 825 data structure.  It is expected that the function transform the data
 826 structure to a string.  The C<SQL::Transformer> instance is provided for
 827 informational purposes; for example, the type of the parser can be
 828 retrieved using the B<parser_type> method, and the B<error> and
 829 B<debug> methods can be called when needed.
 830
 831 When defining a producer, one of several things can be passed in:  A
 832 module name (e.g., C<My::Groovy::Producer>, a module name relative to
 833 the C<SQL::Translator::Producer> namespace (e.g., MySQL), a module
 834 name and function combination (C<My::Groovy::Producer::transmogrify>),
 835 or a reference to an anonymous subroutine.  If a full module name is
 836 passed in (for the purposes of this method, a string containing "::"
 837 is considered to be a module name), it is treated as a package, and a
 838 function called "produce" will be invoked: C<$modulename::produce>.
 839 If $modulename cannot be loaded, the final portion is stripped off and
 840 treated as a function.  In other words, if there is no file named
 841 F<My/Groovy/Producer/transmogrify.pm>, C<SQL::Translator> will attempt
 842 to load F<My/Groovy/Producer.pm> and use transmogrify as the name of
 843 the function, instead of the default "produce".
 844
 845   my $tr = SQL::Translator->new;
 846
 847   # This will invoke My::Groovy::Producer::produce($tr, $data)
 848   $tr->producer("My::Groovy::Producer");
 849
 850   # This will invoke SQL::Translator::Producer::Sybase::produce($tr, $data)
 851   $tr->producer("Sybase");
 852
 853   # This will invoke My::Groovy::Producer::transmogrify($tr, $data),
 854   # assuming that My::Groovy::Producer::transmogrify is not a module
 855   # on disk.
 856   $tr->producer("My::Groovy::Producer::transmogrify");
 857
 858   # This will invoke the referenced subroutine directly, as
 859   # $subref->($tr, $data);
 860   $tr->producer(\&my_producer);
 861
 862 There is also a method named B<producer_type>, which is a string
 863 containing the classname to which the above B<produce> function
 864 belongs.  In the case of anonymous subroutines, this method returns
 865 the string "CODE".
 866
 867 Finally, there is a method named B<producer_args>, which is both an
 868 accessor and a mutator.  Arbitrary data may be stored in name => value
 869 pairs for the producer subroutine to access:
 870
 871   sub My::Random::producer {
 872       my ($tr, $data) = @_;
 873       my $pr_args = $tr->producer_args();
 874
 875       # $pr_args is a hashref.
 876
 877 Extra data passed to the B<producer> method is passed to
 878 B<producer_args>:
 879
 880   $tr->producer("xSV", delimiter => ',\s*');
 881
 882   # In SQL::Translator::Producer::xSV:
 883   my $args = $tr->producer_args;
 884   my $delimiter = $args->{'delimiter'}; # value is ,\s*
 885
 886 =head2 B<parser>
 887
 888 The B<parser> method defines or retrieves a subroutine that will be
 889 called to perform the parsing.  The basic idea is the same as that of
 890 B<producer> (see above), except the default subroutine name is
 891 "parse", and will be invoked as C<$module_name::parse($tr, $data)>.
 892 Also, the parser subroutine will be passed a string containing the
 893 entirety of the data to be parsed.
 894
 895   # Invokes SQL::Translator::Parser::MySQL::parse()
 896   $tr->parser("MySQL");
 897
 898   # Invokes My::Groovy::Parser::parse()
 899   $tr->parser("My::Groovy::Parser");
 900
 901   # Invoke an anonymous subroutine directly
 902   $tr->parser(sub {
 903     my $dumper = Data::Dumper->new([ $_[1] ], [ "SQL" ]);
 904     $dumper->Purity(1)->Terse(1)->Deepcopy(1);
 905     return $dumper->Dump;
 906   });
 907
 908 There is also B<parser_type> and B<parser_args>, which perform
 909 analogously to B<producer_type> and B<producer_args>
 910
 911 =head2 B<show_warnings>
 912
 913 Toggles whether to print warnings of name conflicts, identifier
 914 mutations, etc.  Probably only generated by producers to let the user
 915 know when something won't translate very smoothly (e.g., MySQL "enum"
 916 fields into Oracle).  Accepts a true or false value, returns the
 917 current value.
 918
 919 =head2 B<translate>
 920
 921 The B<translate> method calls the subroutines referenced by the
 922 B<parser> and B<producer> data members (described above).  It accepts
 923 as arguments a number of things, in key => value format, including
 924 (potentially) a parser and a producer (they are passed directly to the
 925 B<parser> and B<producer> methods).
 926
 927 Here is how the parameter list to B<translate> is parsed:
 928
 929 =over
 930
 931 =item *
 932
 933 1 argument means it's the data to be parsed; which could be a string
 934 (filename) or a reference to a scalar (a string stored in memory), or a
 935 reference to a hash, which is parsed as being more than one argument
 936 (see next section).
 937
 938   # Parse the file /path/to/datafile
 939   my $output = $tr->translate("/path/to/datafile");
 940
 941   # Parse the data contained in the string $data
 942   my $output = $tr->translate(\$data);
 943
 944 =item *
 945
 946 More than 1 argument means its a hash of things, and it might be
 947 setting a parser, producer, or datasource (this key is named
 948 "filename" or "file" if it's a file, or "data" for a SCALAR reference.
 949
 950   # As above, parse /path/to/datafile, but with different producers
 951   for my $prod ("MySQL", "XML", "Sybase") {
 952       print $tr->translate(
 953                 producer => $prod,
 954                 filename => "/path/to/datafile",
 955             );
 956   }
 957
 958   # The filename hash key could also be:
 959       datasource => \$data,
 960
 961 You get the idea.
 962
 963 =back
 964
 965 =head2 B<filename>, B<data>
 966
 967 Using the B<filename> method, the filename of the data to be parsed
 968 can be set. This method can be used in conjunction with the B<data>
 969 method, below.  If both the B<filename> and B<data> methods are
 970 invoked as mutators, the data set in the B<data> method is used.
 971
 972     $tr->filename("/my/data/files/create.sql");
 973
 974 or:
 975
 976     my $create_script = do {
 977         local $/;
 978         open CREATE, "/my/data/files/create.sql" or die $!;
 979         <CREATE>;
 980     };
 981     $tr->data(\$create_script);
 982
 983 B<filename> takes a string, which is interpreted as a filename.
 984 B<data> takes a reference to a string, which is used as the data to be
 985 parsed.  If a filename is set, then that file is opened and read when
 986 the B<translate> method is called, as long as the data instance
 987 variable is not set.
 988
 989 =pod
 990
 991 =head2 B<trace>
 992
 993 Turns on/off the tracing option of Parse::RecDescent.
 994
 995 =pod
 996
 997 =head1 AUTHORS
 998
 999 Ken Y. Clark, E<lt>kclark@cpan.orgE<gt>,
1000 darren chamberlain E<lt>darren@cpan.orgE<gt>,
1001 Chris Mungall E<lt>cjm@fruitfly.orgE<gt>,
1002 Allen Day E<lt>allenday@users.sourceforge.netE<gt>
1003
1004 =head1 COPYRIGHT
1005
1006 This program is free software; you can redistribute it and/or modify
1007 it under the terms of the GNU General Public License as published by
1008 the Free Software Foundation; version 2.
1009
1010 This program is distributed in the hope that it will be useful, but
1011 WITHOUT ANY WARRANTY; without even the implied warranty of
1012 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
1013 General Public License for more details.
1014
1015 You should have received a copy of the GNU General Public License
1016 along with this program; if not, write to the Free Software
1017 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
1018 USA
1019
1020 =head1 BUGS
1021
1022 Please use http://rt.cpan.org/ for reporting bugs.
1023
1024 =head1 SEE ALSO
1025
1026 L<perl>,
1027 L<SQL::Translator::Parser>,
1028 L<SQL::Translator::Producer>,
1029 L<Parse::RecDescent>
1030