lib/SQL/Translator.pm

   1 package SQL::Translator;
   2
   3 # ----------------------------------------------------------------------
   4 # $Id: Translator.pm,v 1.27 2003-05-09 19:51:28 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.27 $ =~ /(\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     eval { $parser_output = $parser->($self, $$data) };
 554     if ($@ || ! $parser_output) {
 555         my $msg = sprintf "translate: Error with parser '%s': %s",
 556             $parser_type, ($@) ? $@ : " no results";
 557         return $self->error($msg);
 558     }
 559
 560     eval { $producer_output = $producer->($self, $parser_output) };
 561     if ($@ || ! $producer_output) {
 562         my $msg = sprintf "translate: Error with producer '%s': %s",
 563             $producer_type, ($@) ? $@ : " no results";
 564         return $self->error($msg);
 565     }
 566
 567     return $producer_output;
 568 }
 569
 570 # ----------------------------------------------------------------------
 571 # list_parsers()
 572 #
 573 # Hacky sort of method to list all available parsers.  This has
 574 # several problems:
 575 #
 576 #   - Only finds things in the SQL::Translator::Parser namespace
 577 #
 578 #   - Only finds things that are located in the same directory
 579 #     as SQL::Translator::Parser.  Yeck.
 580 #
 581 # This method will fail in several very likely cases:
 582 #
 583 #   - Parser modules in different namespaces
 584 #
 585 #   - Parser modules in the SQL::Translator::Parser namespace that
 586 #     have any XS componenets will be installed in
 587 #     arch_lib/SQL/Translator.
 588 #
 589 # ----------------------------------------------------------------------
 590 sub list_parsers {
 591     return shift->_list("parser");
 592 }
 593
 594 # ----------------------------------------------------------------------
 595 # list_producers()
 596 #
 597 # See notes for list_parsers(), above; all the problems apply to
 598 # list_producers as well.
 599 # ----------------------------------------------------------------------
 600 sub list_producers {
 601     return shift->_list("producer");
 602 }
 603
 604
 605 # ======================================================================
 606 # Private Methods
 607 # ======================================================================
 608
 609 # ----------------------------------------------------------------------
 610 # _args($type, \%args);
 611 #
 612 # Gets or sets ${type}_args.  Called by parser_args and producer_args.
 613 # ----------------------------------------------------------------------
 614 sub _args {
 615     my $self = shift;
 616     my $type = shift;
 617     $type = "${type}_args" unless $type =~ /_args$/;
 618
 619     unless (defined $self->{$type} && isa($self->{$type}, 'HASH')) {
 620         $self->{$type} = { };
 621     }
 622
 623     if (@_) {
 624         # If the first argument is an explicit undef (remember, we
 625         # don't get here unless there is stuff in @_), then we clear
 626         # out the producer_args hash.
 627         if (! defined $_[0]) {
 628             shift @_;
 629             %{$self->{$type}} = ();
 630         }
 631
 632         my $args = isa($_[0], 'HASH') ? shift : { @_ };
 633         %{$self->{$type}} = (%{$self->{$type}}, %$args);
 634     }
 635
 636     $self->{$type};
 637 }
 638
 639
 640 # ----------------------------------------------------------------------
 641 # _list($type)
 642 # ----------------------------------------------------------------------
 643 sub _list {
 644     my $self = shift;
 645     my $type = shift || return ();
 646     my $uctype = ucfirst lc $type;
 647     my %found;
 648
 649     load("SQL::Translator::$uctype") or return ();
 650     my $path = catfile "SQL", "Translator", $uctype;
 651     for (@INC) {
 652         my $dir = catfile $_, $path;
 653         $self->debug("_list_${type}s searching $dir");
 654         next unless -d $dir;
 655
 656         my $dh = IO::Dir->new($dir);
 657         for (grep /\.pm$/, $dh->read) {
 658             s/\.pm$//;
 659             $found{ join "::", "SQL::Translator::$uctype", $_ } = 1;
 660         }
 661     }
 662
 663     return keys %found;
 664 }
 665
 666 # ----------------------------------------------------------------------
 667 # load($module)
 668 #
 669 # Loads a Perl module.  Short circuits if a module is already loaded.
 670 # ----------------------------------------------------------------------
 671 sub load {
 672     my $module = do { my $m = shift; $m =~ s[::][/]g; "$m.pm" };
 673     return 1 if $INC{$module};
 674
 675     eval {
 676         require $module;
 677         $module->import(@_);
 678     };
 679
 680     return __PACKAGE__->error($@) if ($@);
 681     return 1;
 682 }
 683
 684 sub format_table_name {
 685     my $self = shift;
 686     my $sub  = shift;
 687     $self->{'_format_table_name'} = $sub if ref $sub eq 'CODE';
 688     return $self->{'_format_table_name'}->( $sub, @_ )
 689         if defined $self->{'_format_table_name'};
 690     return $sub;
 691 }
 692
 693 sub format_package_name {
 694     my $self = shift;
 695     my $sub  = shift;
 696     $self->{'_format_package_name'} = $sub if ref $sub eq 'CODE';
 697     return $self->{'_format_package_name'}->( $sub, @_ )
 698         if defined $self->{'_format_package_name'};
 699     return $sub;
 700 }
 701
 702 sub format_fk_name {
 703     my $self = shift;
 704     my $sub  = shift;
 705     $self->{'_format_fk_name'} = $sub if ref $sub eq 'CODE';
 706     return $self->{'_format_fk_name'}->( $sub, @_ )
 707         if defined $self->{'_format_fk_name'};
 708     return $sub;
 709 }
 710
 711 sub format_pk_name {
 712     my $self = shift;
 713     my $sub  = shift;
 714     $self->{'_format_pk_name'} = $sub if ref $sub eq 'CODE';
 715     return $self->{'_format_pk_name'}->( $sub, @_ )
 716         if defined $self->{'_format_pk_name'};
 717     return $sub;
 718 }
 719
 720 # ----------------------------------------------------------------------
 721 # isa($ref, $type)
 722 #
 723 # Calls UNIVERSAL::isa($ref, $type).  I think UNIVERSAL::isa is ugly,
 724 # but I like function overhead.
 725 # ----------------------------------------------------------------------
 726 sub isa($$) {
 727     my ($ref, $type) = @_;
 728     return UNIVERSAL::isa($ref, $type);
 729 }
 730
 731 1;
 732 #-----------------------------------------------------
 733 # Rescue the drowning and tie your shoestrings.
 734 # Henry David Thoreau
 735 #-----------------------------------------------------
 736
 737 __END__
 738
 739 =head1 NAME
 740
 741 SQL::Translator - convert schema from one database to another
 742
 743 =head1 SYNOPSIS
 744
 745   use SQL::Translator;
 746
 747   my $translator     = SQL::Translator->new(
 748       debug          => 1, # Print debug info
 749       trace          => 0, # Print Parse::RecDescent trace
 750       no_comments    => 0, # Don't include comments in output
 751       show_warnings  => 0, # Print name mutations, conflicts
 752       add_drop_table => 1, # Add "drop table" statements
 753
 754       # Make all table names CAPS in producers which support this option
 755       format_table_name => sub {my $tablename = shift; return uc($tablename)},
 756
 757       # Null-op formatting, only here for documentation's sake
 758       format_package_name => sub {return shift},
 759       format_fk_name      => sub {return shift},
 760       format_pk_name      => sub {return shift},
 761   );
 762
 763   my $output     = $translator->translate(
 764       from       => "MySQL",
 765       to         => "Oracle",
 766       # Or an arrayref of filenames, i.e. [ $file1, $file2, $file3 ]
 767       filename   => $file,
 768   ) or die $translator->error;
 769
 770   print $output;
 771
 772 =head1 DESCRIPTION
 773
 774 This module attempts to simplify the task of converting one database
 775 create syntax to another through the use of Parsers (which understand
 776 the source format) and Producers (which understand the destination
 777 format).  The idea is that any Parser can be used with any Producer in
 778 the conversion process.  So, if you wanted Postgres-to-Oracle, you
 779 would use the Postgres parser and the Oracle producer.
 780
 781 =head1 CONSTRUCTOR
 782
 783 The constructor is called C<new>, and accepts a optional hash of options.
 784 Valid options are:
 785
 786 =over 4
 787
 788 =item *
 789
 790 parser / from
 791
 792 =item *
 793
 794 parser_args
 795
 796 =item *
 797
 798 producer / to
 799
 800 =item *
 801
 802 producer_args
 803
 804 =item *
 805
 806 filename / file
 807
 808 =item *
 809
 810 data
 811
 812 =item *
 813
 814 debug
 815
 816 =back
 817
 818 All options are, well, optional; these attributes can be set via
 819 instance methods.  Internally, they are; no (non-syntactical)
 820 advantage is gained by passing options to the constructor.
 821
 822 =head1 METHODS
 823
 824 =head2 add_drop_table
 825
 826 Toggles whether or not to add "DROP TABLE" statements just before the
 827 create definitions.
 828
 829 =head2 custom_translate
 830
 831 Allows the user to override default translation of fields.  For example,
 832 if a MySQL "text" field would normally be converted to a "long" for Oracle,
 833 the user could specify to change it to a "CLOB."  Accepts a hashref where
 834 keys are the "from" value and values are the "to," returns the current
 835 value of the field.
 836
 837 =head2 no_comments
 838
 839 Toggles whether to print comments in the output.  Accepts a true or false
 840 value, returns the current value.
 841
 842 =head2 producer
 843
 844 The C<producer> method is an accessor/mutator, used to retrieve or
 845 define what subroutine is called to produce the output.  A subroutine
 846 defined as a producer will be invoked as a function (I<not a method>)
 847 and passed 2 parameters: its container C<SQL::Translator> instance and a
 848 data structure.  It is expected that the function transform the data
 849 structure to a string.  The C<SQL::Transformer> instance is provided for
 850 informational purposes; for example, the type of the parser can be
 851 retrieved using the C<parser_type> method, and the C<error> and
 852 C<debug> methods can be called when needed.
 853
 854 When defining a producer, one of several things can be passed in:  A
 855 module name (e.g., C<My::Groovy::Producer>), a module name relative to
 856 the C<SQL::Translator::Producer> namespace (e.g., C<MySQL>), a module
 857 name and function combination (C<My::Groovy::Producer::transmogrify>),
 858 or a reference to an anonymous subroutine.  If a full module name is
 859 passed in (for the purposes of this method, a string containing "::"
 860 is considered to be a module name), it is treated as a package, and a
 861 function called "produce" will be invoked: C<$modulename::produce>.
 862 If $modulename cannot be loaded, the final portion is stripped off and
 863 treated as a function.  In other words, if there is no file named
 864 F<My/Groovy/Producer/transmogrify.pm>, C<SQL::Translator> will attempt
 865 to load F<My/Groovy/Producer.pm> and use C<transmogrify> as the name of
 866 the function, instead of the default C<produce>.
 867
 868   my $tr = SQL::Translator->new;
 869
 870   # This will invoke My::Groovy::Producer::produce($tr, $data)
 871   $tr->producer("My::Groovy::Producer");
 872
 873   # This will invoke SQL::Translator::Producer::Sybase::produce($tr, $data)
 874   $tr->producer("Sybase");
 875
 876   # This will invoke My::Groovy::Producer::transmogrify($tr, $data),
 877   # assuming that My::Groovy::Producer::transmogrify is not a module
 878   # on disk.
 879   $tr->producer("My::Groovy::Producer::transmogrify");
 880
 881   # This will invoke the referenced subroutine directly, as
 882   # $subref->($tr, $data);
 883   $tr->producer(\&my_producer);
 884
 885 There is also a method named C<producer_type>, which is a string
 886 containing the classname to which the above C<produce> function
 887 belongs.  In the case of anonymous subroutines, this method returns
 888 the string "CODE".
 889
 890 Finally, there is a method named C<producer_args>, which is both an
 891 accessor and a mutator.  Arbitrary data may be stored in name => value
 892 pairs for the producer subroutine to access:
 893
 894   sub My::Random::producer {
 895       my ($tr, $data) = @_;
 896       my $pr_args = $tr->producer_args();
 897
 898       # $pr_args is a hashref.
 899
 900 Extra data passed to the C<producer> method is passed to
 901 C<producer_args>:
 902
 903   $tr->producer("xSV", delimiter => ',\s*');
 904
 905   # In SQL::Translator::Producer::xSV:
 906   my $args = $tr->producer_args;
 907   my $delimiter = $args->{'delimiter'}; # value is ,\s*
 908
 909 =head2 parser
 910
 911 The C<parser> method defines or retrieves a subroutine that will be
 912 called to perform the parsing.  The basic idea is the same as that of
 913 C<producer> (see above), except the default subroutine name is
 914 "parse", and will be invoked as C<$module_name::parse($tr, $data)>.
 915 Also, the parser subroutine will be passed a string containing the
 916 entirety of the data to be parsed.
 917
 918   # Invokes SQL::Translator::Parser::MySQL::parse()
 919   $tr->parser("MySQL");
 920
 921   # Invokes My::Groovy::Parser::parse()
 922   $tr->parser("My::Groovy::Parser");
 923
 924   # Invoke an anonymous subroutine directly
 925   $tr->parser(sub {
 926     my $dumper = Data::Dumper->new([ $_[1] ], [ "SQL" ]);
 927     $dumper->Purity(1)->Terse(1)->Deepcopy(1);
 928     return $dumper->Dump;
 929   });
 930
 931 There is also C<parser_type> and C<parser_args>, which perform
 932 analogously to C<producer_type> and C<producer_args>
 933
 934 =head2 show_warnings
 935
 936 Toggles whether to print warnings of name conflicts, identifier
 937 mutations, etc.  Probably only generated by producers to let the user
 938 know when something won't translate very smoothly (e.g., MySQL "enum"
 939 fields into Oracle).  Accepts a true or false value, returns the
 940 current value.
 941
 942 =head2 translate
 943
 944 The C<translate> method calls the subroutines referenced by the
 945 C<parser> and C<producer> data members (described above).  It accepts
 946 as arguments a number of things, in key => value format, including
 947 (potentially) a parser and a producer (they are passed directly to the
 948 C<parser> and C<producer> methods).
 949
 950 Here is how the parameter list to C<translate> is parsed:
 951
 952 =over
 953
 954 =item *
 955
 956 1 argument means it's the data to be parsed; which could be a string
 957 (filename) or a reference to a scalar (a string stored in memory), or a
 958 reference to a hash, which is parsed as being more than one argument
 959 (see next section).
 960
 961   # Parse the file /path/to/datafile
 962   my $output = $tr->translate("/path/to/datafile");
 963
 964   # Parse the data contained in the string $data
 965   my $output = $tr->translate(\$data);
 966
 967 =item *
 968
 969 More than 1 argument means its a hash of things, and it might be
 970 setting a parser, producer, or datasource (this key is named
 971 "filename" or "file" if it's a file, or "data" for a SCALAR reference.
 972
 973   # As above, parse /path/to/datafile, but with different producers
 974   for my $prod ("MySQL", "XML", "Sybase") {
 975       print $tr->translate(
 976                 producer => $prod,
 977                 filename => "/path/to/datafile",
 978             );
 979   }
 980
 981   # The filename hash key could also be:
 982       datasource => \$data,
 983
 984 You get the idea.
 985
 986 =back
 987
 988 =head2 filename, data
 989
 990 Using the C<filename> method, the filename of the data to be parsed
 991 can be set. This method can be used in conjunction with the C<data>
 992 method, below.  If both the C<filename> and C<data> methods are
 993 invoked as mutators, the data set in the C<data> method is used.
 994
 995     $tr->filename("/my/data/files/create.sql");
 996
 997 or:
 998
 999     my $create_script = do {
1000         local $/;
1001         open CREATE, "/my/data/files/create.sql" or die $!;
1002         <CREATE>;
1003     };
1004     $tr->data(\$create_script);
1005
1006 C<filename> takes a string, which is interpreted as a filename.
1007 C<data> takes a reference to a string, which is used as the data to be
1008 parsed.  If a filename is set, then that file is opened and read when
1009 the C<translate> method is called, as long as the data instance
1010 variable is not set.
1011
1012 =pod
1013
1014 =head2 schema
1015
1016 Returns the SQL::Translator::Schema object.
1017
1018 =head2 trace
1019
1020 Turns on/off the tracing option of Parse::RecDescent.
1021
1022 =pod
1023
1024 =head1 AUTHORS
1025
1026 Ken Y. Clark, E<lt>kclark@cpan.orgE<gt>,
1027 darren chamberlain E<lt>darren@cpan.orgE<gt>,
1028 Chris Mungall E<lt>cjm@fruitfly.orgE<gt>,
1029 Allen Day E<lt>allenday@users.sourceforge.netE<gt>
1030
1031 =head1 COPYRIGHT
1032
1033 This program is free software; you can redistribute it and/or modify
1034 it under the terms of the GNU General Public License as published by
1035 the Free Software Foundation; version 2.
1036
1037 This program is distributed in the hope that it will be useful, but
1038 WITHOUT ANY WARRANTY; without even the implied warranty of
1039 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
1040 General Public License for more details.
1041
1042 You should have received a copy of the GNU General Public License
1043 along with this program; if not, write to the Free Software
1044 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
1045 USA
1046
1047 =head1 BUGS
1048
1049 Please use http://rt.cpan.org/ for reporting bugs.
1050
1051 =head1 SEE ALSO
1052
1053 L<perl>,
1054 L<SQL::Translator::Parser>,
1055 L<SQL::Translator::Producer>,
1056 L<Parse::RecDescent>
1057