lib/SQL/Translator.pm

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