lib/SQL/Translator.pm

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