lib/SQL/Translator.pm

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