lib/SQL/Translator.pm

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