lib/SQL/Translator.pm

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