lib/SQL/Translator.pm

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