lib/SQL/Translator.pm

   1 package SQL::Translator;
   2
   3 # ----------------------------------------------------------------------
   4 # $Id: Translator.pm,v 1.25 2003-05-06 12:44:54 dlc Exp $
   5 # ----------------------------------------------------------------------
   6 # Copyright (C) 2003 Ken Y. Clark <kclark@cpan.org>,
   7 #                    darren chamberlain <darren@cpan.org>,
   8 #                    Chris Mungall <cjm@fruitfly.org>
   9 #
  10 # This program is free software; you can redistribute it and/or
  11 # modify it under the terms of the GNU General Public License as
  12 # published by the Free Software Foundation; version 2.
  13 #
  14 # This program is distributed in the hope that it will be useful, but
  15 # WITHOUT ANY WARRANTY; without even the implied warranty of
  16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17 # General Public License for more details.
  18 #
  19 # You should have received a copy of the GNU General Public License
  20 # along with this program; if not, write to the Free Software
  21 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
  22 # 02111-1307  USA
  23 # -------------------------------------------------------------------
  24
  25 use strict;
  26 use vars qw( $VERSION $REVISION $DEFAULT_SUB $DEBUG $ERROR );
  27 use base 'Class::Base';
  28
  29 $VERSION  = '0.01';
  30 $REVISION = sprintf "%d.%02d", q$Revision: 1.25 $ =~ /(\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 {
 661         require $module;
 662         $module->import(@_);
 663     };
 664
 665     return __PACKAGE__->error($@) if ($@);
 666     return 1;
 667 }
 668
 669 sub format_table_name {
 670     my $self = shift;
 671     my $sub  = shift;
 672     $self->{'_format_table_name'} = $sub if ref $sub eq 'CODE';
 673     return $self->{'_format_table_name'}->( $sub, @_ )
 674         if defined $self->{'_format_table_name'};
 675     return $sub;
 676 }
 677
 678 sub format_package_name {
 679     my $self = shift;
 680     my $sub  = shift;
 681     $self->{'_format_package_name'} = $sub if ref $sub eq 'CODE';
 682     return $self->{'_format_package_name'}->( $sub, @_ )
 683         if defined $self->{'_format_package_name'};
 684     return $sub;
 685 }
 686
 687 sub format_fk_name {
 688     my $self = shift;
 689     my $sub  = shift;
 690     $self->{'_format_fk_name'} = $sub if ref $sub eq 'CODE';
 691     return $self->{'_format_fk_name'}->( $sub, @_ )
 692         if defined $self->{'_format_fk_name'};
 693     return $sub;
 694 }
 695
 696 sub format_pk_name {
 697     my $self = shift;
 698     my $sub  = shift;
 699     $self->{'_format_pk_name'} = $sub if ref $sub eq 'CODE';
 700     return $self->{'_format_pk_name'}->( $sub, @_ )
 701         if defined $self->{'_format_pk_name'};
 702     return $sub;
 703 }
 704
 705 # ----------------------------------------------------------------------
 706 # isa($ref, $type)
 707 #
 708 # Calls UNIVERSAL::isa($ref, $type).  I think UNIVERSAL::isa is ugly,
 709 # but I like function overhead.
 710 # ----------------------------------------------------------------------
 711 sub isa($$) {
 712     my ($ref, $type) = @_;
 713     return UNIVERSAL::isa($ref, $type);
 714 }
 715
 716 1;
 717 #-----------------------------------------------------
 718 # Rescue the drowning and tie your shoestrings.
 719 # Henry David Thoreau
 720 #-----------------------------------------------------
 721
 722 __END__
 723
 724 =head1 NAME
 725
 726 SQL::Translator - convert schema from one database to another
 727
 728 =head1 SYNOPSIS
 729
 730   use SQL::Translator;
 731
 732   my $translator     = SQL::Translator->new(
 733       debug          => 1, # Print debug info
 734       trace          => 0, # Print Parse::RecDescent trace
 735       no_comments    => 0, # Don't include comments in output
 736       show_warnings  => 0, # Print name mutations, conflicts
 737       add_drop_table => 1, # Add "drop table" statements
 738
 739       # Make all table names CAPS in producers which support this option
 740       format_table_name => sub {my $tablename = shift; return uc($tablename)},
 741
 742       # Null-op formatting, only here for documentation's sake
 743       format_package_name => sub {return shift},
 744       format_fk_name      => sub {return shift},
 745       format_pk_name      => sub {return shift},
 746   );
 747
 748   my $output     = $translator->translate(
 749       from       => "MySQL",
 750       to         => "Oracle",
 751       # Or an arrayref of filenames, i.e. [ $file1, $file2, $file3 ]
 752       filename   => $file,
 753   ) or die $translator->error;
 754
 755   print $output;
 756
 757 =head1 DESCRIPTION
 758
 759 This module attempts to simplify the task of converting one database
 760 create syntax to another through the use of Parsers (which understand
 761 the source format) and Producers (which understand the destination
 762 format).  The idea is that any Parser can be used with any Producer in
 763 the conversion process.  So, if you wanted Postgres-to-Oracle, you
 764 would use the Postgres parser and the Oracle producer.
 765
 766 =head1 CONSTRUCTOR
 767
 768 The constructor is called C<new>, and accepts a optional hash of options.
 769 Valid options are:
 770
 771 =over 4
 772
 773 =item *
 774
 775 parser / from
 776
 777 =item *
 778
 779 parser_args
 780
 781 =item *
 782
 783 producer / to
 784
 785 =item *
 786
 787 producer_args
 788
 789 =item *
 790
 791 filename / file
 792
 793 =item *
 794
 795 data
 796
 797 =item *
 798
 799 debug
 800
 801 =back
 802
 803 All options are, well, optional; these attributes can be set via
 804 instance methods.  Internally, they are; no (non-syntactical)
 805 advantage is gained by passing options to the constructor.
 806
 807 =head1 METHODS
 808
 809 =head2 add_drop_table
 810
 811 Toggles whether or not to add "DROP TABLE" statements just before the
 812 create definitions.
 813
 814 =head2 custom_translate
 815
 816 Allows the user to override default translation of fields.  For example,
 817 if a MySQL "text" field would normally be converted to a "long" for Oracle,
 818 the user could specify to change it to a "CLOB."  Accepts a hashref where
 819 keys are the "from" value and values are the "to," returns the current
 820 value of the field.
 821
 822 =head2 no_comments
 823
 824 Toggles whether to print comments in the output.  Accepts a true or false
 825 value, returns the current value.
 826
 827 =head2 producer
 828
 829 The C<producer> method is an accessor/mutator, used to retrieve or
 830 define what subroutine is called to produce the output.  A subroutine
 831 defined as a producer will be invoked as a function (I<not a method>)
 832 and passed 2 parameters: its container C<SQL::Translator> instance and a
 833 data structure.  It is expected that the function transform the data
 834 structure to a string.  The C<SQL::Transformer> instance is provided for
 835 informational purposes; for example, the type of the parser can be
 836 retrieved using the C<parser_type> method, and the C<error> and
 837 C<debug> methods can be called when needed.
 838
 839 When defining a producer, one of several things can be passed in:  A
 840 module name (e.g., C<My::Groovy::Producer>), a module name relative to
 841 the C<SQL::Translator::Producer> namespace (e.g., C<MySQL>), a module
 842 name and function combination (C<My::Groovy::Producer::transmogrify>),
 843 or a reference to an anonymous subroutine.  If a full module name is
 844 passed in (for the purposes of this method, a string containing "::"
 845 is considered to be a module name), it is treated as a package, and a
 846 function called "produce" will be invoked: C<$modulename::produce>.
 847 If $modulename cannot be loaded, the final portion is stripped off and
 848 treated as a function.  In other words, if there is no file named
 849 F<My/Groovy/Producer/transmogrify.pm>, C<SQL::Translator> will attempt
 850 to load F<My/Groovy/Producer.pm> and use C<transmogrify> as the name of
 851 the function, instead of the default C<produce>.
 852
 853   my $tr = SQL::Translator->new;
 854
 855   # This will invoke My::Groovy::Producer::produce($tr, $data)
 856   $tr->producer("My::Groovy::Producer");
 857
 858   # This will invoke SQL::Translator::Producer::Sybase::produce($tr, $data)
 859   $tr->producer("Sybase");
 860
 861   # This will invoke My::Groovy::Producer::transmogrify($tr, $data),
 862   # assuming that My::Groovy::Producer::transmogrify is not a module
 863   # on disk.
 864   $tr->producer("My::Groovy::Producer::transmogrify");
 865
 866   # This will invoke the referenced subroutine directly, as
 867   # $subref->($tr, $data);
 868   $tr->producer(\&my_producer);
 869
 870 There is also a method named C<producer_type>, which is a string
 871 containing the classname to which the above C<produce> function
 872 belongs.  In the case of anonymous subroutines, this method returns
 873 the string "CODE".
 874
 875 Finally, there is a method named C<producer_args>, which is both an
 876 accessor and a mutator.  Arbitrary data may be stored in name => value
 877 pairs for the producer subroutine to access:
 878
 879   sub My::Random::producer {
 880       my ($tr, $data) = @_;
 881       my $pr_args = $tr->producer_args();
 882
 883       # $pr_args is a hashref.
 884
 885 Extra data passed to the C<producer> method is passed to
 886 C<producer_args>:
 887
 888   $tr->producer("xSV", delimiter => ',\s*');
 889
 890   # In SQL::Translator::Producer::xSV:
 891   my $args = $tr->producer_args;
 892   my $delimiter = $args->{'delimiter'}; # value is ,\s*
 893
 894 =head2 parser
 895
 896 The C<parser> method defines or retrieves a subroutine that will be
 897 called to perform the parsing.  The basic idea is the same as that of
 898 C<producer> (see above), except the default subroutine name is
 899 "parse", and will be invoked as C<$module_name::parse($tr, $data)>.
 900 Also, the parser subroutine will be passed a string containing the
 901 entirety of the data to be parsed.
 902
 903   # Invokes SQL::Translator::Parser::MySQL::parse()
 904   $tr->parser("MySQL");
 905
 906   # Invokes My::Groovy::Parser::parse()
 907   $tr->parser("My::Groovy::Parser");
 908
 909   # Invoke an anonymous subroutine directly
 910   $tr->parser(sub {
 911     my $dumper = Data::Dumper->new([ $_[1] ], [ "SQL" ]);
 912     $dumper->Purity(1)->Terse(1)->Deepcopy(1);
 913     return $dumper->Dump;
 914   });
 915
 916 There is also C<parser_type> and C<parser_args>, which perform
 917 analogously to C<producer_type> and C<producer_args>
 918
 919 =head2 show_warnings
 920
 921 Toggles whether to print warnings of name conflicts, identifier
 922 mutations, etc.  Probably only generated by producers to let the user
 923 know when something won't translate very smoothly (e.g., MySQL "enum"
 924 fields into Oracle).  Accepts a true or false value, returns the
 925 current value.
 926
 927 =head2 translate
 928
 929 The C<translate> method calls the subroutines referenced by the
 930 C<parser> and C<producer> data members (described above).  It accepts
 931 as arguments a number of things, in key => value format, including
 932 (potentially) a parser and a producer (they are passed directly to the
 933 C<parser> and C<producer> methods).
 934
 935 Here is how the parameter list to C<translate> is parsed:
 936
 937 =over
 938
 939 =item *
 940
 941 1 argument means it's the data to be parsed; which could be a string
 942 (filename) or a reference to a scalar (a string stored in memory), or a
 943 reference to a hash, which is parsed as being more than one argument
 944 (see next section).
 945
 946   # Parse the file /path/to/datafile
 947   my $output = $tr->translate("/path/to/datafile");
 948
 949   # Parse the data contained in the string $data
 950   my $output = $tr->translate(\$data);
 951
 952 =item *
 953
 954 More than 1 argument means its a hash of things, and it might be
 955 setting a parser, producer, or datasource (this key is named
 956 "filename" or "file" if it's a file, or "data" for a SCALAR reference.
 957
 958   # As above, parse /path/to/datafile, but with different producers
 959   for my $prod ("MySQL", "XML", "Sybase") {
 960       print $tr->translate(
 961                 producer => $prod,
 962                 filename => "/path/to/datafile",
 963             );
 964   }
 965
 966   # The filename hash key could also be:
 967       datasource => \$data,
 968
 969 You get the idea.
 970
 971 =back
 972
 973 =head2 filename, data
 974
 975 Using the C<filename> method, the filename of the data to be parsed
 976 can be set. This method can be used in conjunction with the C<data>
 977 method, below.  If both the C<filename> and C<data> methods are
 978 invoked as mutators, the data set in the C<data> method is used.
 979
 980     $tr->filename("/my/data/files/create.sql");
 981
 982 or:
 983
 984     my $create_script = do {
 985         local $/;
 986         open CREATE, "/my/data/files/create.sql" or die $!;
 987         <CREATE>;
 988     };
 989     $tr->data(\$create_script);
 990
 991 C<filename> takes a string, which is interpreted as a filename.
 992 C<data> takes a reference to a string, which is used as the data to be
 993 parsed.  If a filename is set, then that file is opened and read when
 994 the C<translate> method is called, as long as the data instance
 995 variable is not set.
 996
 997 =pod
 998
 999 =head2 trace
1000
1001 Turns on/off the tracing option of Parse::RecDescent.
1002
1003 =pod
1004
1005 =head1 AUTHORS
1006
1007 Ken Y. Clark, E<lt>kclark@cpan.orgE<gt>,
1008 darren chamberlain E<lt>darren@cpan.orgE<gt>,
1009 Chris Mungall E<lt>cjm@fruitfly.orgE<gt>,
1010 Allen Day E<lt>allenday@users.sourceforge.netE<gt>
1011
1012 =head1 COPYRIGHT
1013
1014 This program is free software; you can redistribute it and/or modify
1015 it under the terms of the GNU General Public License as published by
1016 the Free Software Foundation; version 2.
1017
1018 This program is distributed in the hope that it will be useful, but
1019 WITHOUT ANY WARRANTY; without even the implied warranty of
1020 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
1021 General Public License for more details.
1022
1023 You should have received a copy of the GNU General Public License
1024 along with this program; if not, write to the Free Software
1025 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
1026 USA
1027
1028 =head1 BUGS
1029
1030 Please use http://rt.cpan.org/ for reporting bugs.
1031
1032 =head1 SEE ALSO
1033
1034 L<perl>,
1035 L<SQL::Translator::Parser>,
1036 L<SQL::Translator::Producer>,
1037 L<Parse::RecDescent>
1038