lib/SQL/Translator.pm

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