lib/SQL/Translator.pm

   1 package SQL::Translator;
   2
   3 # ----------------------------------------------------------------------
   4 # $Id: Translator.pm,v 1.37 2003-07-31 20:49:42 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.37 $ =~ /(\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 schema {
 410 #
 411 # Returns the SQL::Translator::Schema object
 412 #
 413     my $self = shift;
 414
 415     unless ( defined $self->{'schema'} ) {
 416         $self->{'schema'} = SQL::Translator::Schema->new;
 417     }
 418
 419     return $self->{'schema'};
 420 }
 421
 422 # ----------------------------------------------------------------------
 423 sub trace {
 424     my $self = shift;
 425     my $arg  = shift;
 426     if ( defined $arg ) {
 427         $self->{'trace'} = $arg ? 1 : 0;
 428     }
 429     return $self->{'trace'} || 0;
 430 }
 431
 432 # ----------------------------------------------------------------------
 433 # translate([source], [\%args])
 434 #
 435 # translate does the actual translation.  The main argument is the
 436 # source of the data to be translated, which can be a filename, scalar
 437 # reference, or glob reference.
 438 #
 439 # Alternatively, translate takes optional arguements, which are passed
 440 # to the appropriate places.  Most notable of these arguments are
 441 # parser and producer, which can be used to set the parser and
 442 # producer, respectively.  This is the applications last chance to set
 443 # these.
 444 #
 445 # translate returns a string.
 446 # ----------------------------------------------------------------------
 447 sub translate {
 448     my $self = shift;
 449     my ($args, $parser, $parser_type, $producer, $producer_type);
 450     my ($parser_output, $producer_output);
 451
 452     # Parse arguments
 453     if (@_ == 1) {
 454         # Passed a reference to a hash?
 455         if (isa($_[0], 'HASH')) {
 456             # yep, a hashref
 457             $self->debug("translate: Got a hashref\n");
 458             $args = $_[0];
 459         }
 460
 461         # Passed a GLOB reference, i.e., filehandle
 462         elsif (isa($_[0], 'GLOB')) {
 463             $self->debug("translate: Got a GLOB reference\n");
 464             $self->data($_[0]);
 465         }
 466
 467         # Passed a reference to a string containing the data
 468         elsif (isa($_[0], 'SCALAR')) {
 469             # passed a ref to a string
 470             $self->debug("translate: Got a SCALAR reference (string)\n");
 471             $self->data($_[0]);
 472         }
 473
 474         # Not a reference; treat it as a filename
 475         elsif (! ref $_[0]) {
 476             # Not a ref, it's a filename
 477             $self->debug("translate: Got a filename\n");
 478             $self->filename($_[0]);
 479         }
 480
 481         # Passed something else entirely.
 482         else {
 483             # We're not impressed.  Take your empty string and leave.
 484             # return "";
 485
 486             # Actually, if data, parser, and producer are set, then we
 487             # can continue.  Too bad, because I like my comment
 488             # (above)...
 489             return "" unless ($self->data     &&
 490                               $self->producer &&
 491                               $self->parser);
 492         }
 493     }
 494     else {
 495         # You must pass in a hash, or you get nothing.
 496         return "" if @_ % 2;
 497         $args = { @_ };
 498     }
 499
 500     # ----------------------------------------------------------------------
 501     # Can specify the data to be transformed using "filename", "file",
 502     # "data", or "datasource".
 503     # ----------------------------------------------------------------------
 504     if (my $filename = ($args->{'filename'} || $args->{'file'})) {
 505         $self->filename($filename);
 506     }
 507
 508     if (my $data = ($args->{'data'} || $args->{'datasource'})) {
 509         $self->data($data);
 510     }
 511
 512     # ----------------------------------------------------------------
 513     # Get the data.
 514     # ----------------------------------------------------------------
 515     my $data = $self->data;
 516     unless (ref($data) eq 'SCALAR' and length $$data) {
 517         return $self->error("Empty data file!");
 518     }
 519
 520     # ----------------------------------------------------------------
 521     # Local reference to the parser subroutine
 522     # ----------------------------------------------------------------
 523     if ($parser = ($args->{'parser'} || $args->{'from'})) {
 524         $self->parser($parser);
 525     }
 526     $parser      = $self->parser;
 527     $parser_type = $self->parser_type;
 528
 529     # ----------------------------------------------------------------
 530     # Local reference to the producer subroutine
 531     # ----------------------------------------------------------------
 532     if ($producer = ($args->{'producer'} || $args->{'to'})) {
 533         $self->producer($producer);
 534     }
 535     $producer      = $self->producer;
 536     $producer_type = $self->producer_type;
 537
 538     # ----------------------------------------------------------------
 539     # Execute the parser, then execute the producer with that output.
 540     # Allowances are made for each piece to die, or fail to compile,
 541     # since the referenced subroutines could be almost anything.  In
 542     # the future, each of these might happen in a Safe environment,
 543     # depending on how paranoid we want to be.
 544     # ----------------------------------------------------------------
 545     eval { $parser_output = $parser->($self, $$data) };
 546     if ($@ || ! $parser_output) {
 547         my $msg = sprintf "translate: Error with parser '%s': %s",
 548             $parser_type, ($@) ? $@ : " no results";
 549         return $self->error($msg);
 550     }
 551
 552     if ($self->validate) {
 553         my $schema = $self->schema;
 554         return $self->error('Invalid schema') unless $schema->is_valid;
 555     }
 556
 557     eval { $producer_output = $producer->($self) };
 558     if ($@ || ! $producer_output) {
 559         my $msg = sprintf "translate: Error with producer '%s': %s",
 560             $producer_type, ($@) ? $@ : " no results";
 561         return $self->error($msg);
 562     }
 563
 564     return $producer_output;
 565 }
 566
 567 # ----------------------------------------------------------------------
 568 # list_parsers()
 569 #
 570 # Hacky sort of method to list all available parsers.  This has
 571 # several problems:
 572 #
 573 #   - Only finds things in the SQL::Translator::Parser namespace
 574 #
 575 #   - Only finds things that are located in the same directory
 576 #     as SQL::Translator::Parser.  Yeck.
 577 #
 578 # This method will fail in several very likely cases:
 579 #
 580 #   - Parser modules in different namespaces
 581 #
 582 #   - Parser modules in the SQL::Translator::Parser namespace that
 583 #     have any XS componenets will be installed in
 584 #     arch_lib/SQL/Translator.
 585 #
 586 # ----------------------------------------------------------------------
 587 sub list_parsers {
 588     return shift->_list("parser");
 589 }
 590
 591 # ----------------------------------------------------------------------
 592 # list_producers()
 593 #
 594 # See notes for list_parsers(), above; all the problems apply to
 595 # list_producers as well.
 596 # ----------------------------------------------------------------------
 597 sub list_producers {
 598     return shift->_list("producer");
 599 }
 600
 601
 602 # ======================================================================
 603 # Private Methods
 604 # ======================================================================
 605
 606 # ----------------------------------------------------------------------
 607 # _args($type, \%args);
 608 #
 609 # Gets or sets ${type}_args.  Called by parser_args and producer_args.
 610 # ----------------------------------------------------------------------
 611 sub _args {
 612     my $self = shift;
 613     my $type = shift;
 614     $type = "${type}_args" unless $type =~ /_args$/;
 615
 616     unless (defined $self->{$type} && isa($self->{$type}, 'HASH')) {
 617         $self->{$type} = { };
 618     }
 619
 620     if (@_) {
 621         # If the first argument is an explicit undef (remember, we
 622         # don't get here unless there is stuff in @_), then we clear
 623         # out the producer_args hash.
 624         if (! defined $_[0]) {
 625             shift @_;
 626             %{$self->{$type}} = ();
 627         }
 628
 629         my $args = isa($_[0], 'HASH') ? shift : { @_ };
 630         %{$self->{$type}} = (%{$self->{$type}}, %$args);
 631     }
 632
 633     $self->{$type};
 634 }
 635
 636 # ----------------------------------------------------------------------
 637 # _list($type)
 638 # ----------------------------------------------------------------------
 639 sub _list {
 640     my $self = shift;
 641     my $type = shift || return ();
 642     my $uctype = ucfirst lc $type;
 643     my %found;
 644
 645     load("SQL::Translator::$uctype") or return ();
 646     my $path = catfile "SQL", "Translator", $uctype;
 647     for (@INC) {
 648         my $dir = catfile $_, $path;
 649         $self->debug("_list_${type}s searching $dir\n");
 650         next unless -d $dir;
 651
 652         my $dh = IO::Dir->new($dir);
 653         for (grep /\.pm$/, $dh->read) {
 654             s/\.pm$//;
 655             $found{ join "::", "SQL::Translator::$uctype", $_ } = 1;
 656         }
 657     }
 658
 659     return keys %found;
 660 }
 661
 662 # ----------------------------------------------------------------------
 663 # load($module)
 664 #
 665 # Loads a Perl module.  Short circuits if a module is already loaded.
 666 # ----------------------------------------------------------------------
 667 sub load {
 668     my $module = do { my $m = shift; $m =~ s[::][/]g; "$m.pm" };
 669     return 1 if $INC{$module};
 670
 671     eval {
 672         require $module;
 673         $module->import(@_);
 674     };
 675
 676     return __PACKAGE__->error($@) if ($@);
 677     return 1;
 678 }
 679
 680 # ----------------------------------------------------------------------
 681 sub format_table_name {
 682     my $self = shift;
 683     my $sub  = shift;
 684     $self->{'_format_table_name'} = $sub if ref $sub eq 'CODE';
 685     return $self->{'_format_table_name'}->( $sub, @_ )
 686         if defined $self->{'_format_table_name'};
 687     return $sub;
 688 }
 689
 690 # ----------------------------------------------------------------------
 691 sub format_package_name {
 692     my $self = shift;
 693     my $sub  = shift;
 694     $self->{'_format_package_name'} = $sub if ref $sub eq 'CODE';
 695     return $self->{'_format_package_name'}->( $sub, @_ )
 696         if defined $self->{'_format_package_name'};
 697     return $sub;
 698 }
 699
 700 # ----------------------------------------------------------------------
 701 sub format_fk_name {
 702     my $self = shift;
 703
 704     if ( ref $_[0] eq 'CODE' ) {
 705         $self->{'_format_pk_name'} = shift;
 706     }
 707
 708     if ( @_ ) {
 709         if ( defined $self->{'_format_pk_name'} ) {
 710             return $self->{'_format_pk_name'}->( @_ );
 711         }
 712         else {
 713             return '';
 714         }
 715     }
 716
 717     return $self->{'_format_pk_name'};
 718 #    my $sub  = shift;
 719 #    $self->{'_format_fk_name'} = $sub if ref $sub eq 'CODE';
 720 #    return $self->{'_format_fk_name'}->( $sub, @_ )
 721 #        if defined $self->{'_format_fk_name'};
 722 #    return $sub;
 723 }
 724
 725 # ----------------------------------------------------------------------
 726 sub format_pk_name {
 727     my $self = shift;
 728
 729     if ( ref $_[0] eq 'CODE' ) {
 730         $self->{'_format_pk_name'} = shift;
 731     }
 732
 733     if ( @_ ) {
 734         if ( defined $self->{'_format_pk_name'} ) {
 735             return $self->{'_format_pk_name'}->( @_ );
 736         }
 737         else {
 738             return '';
 739         }
 740     }
 741
 742     return $self->{'_format_pk_name'};
 743 }
 744
 745 # ----------------------------------------------------------------------
 746 # isa($ref, $type)
 747 #
 748 # Calls UNIVERSAL::isa($ref, $type).  I think UNIVERSAL::isa is ugly,
 749 # but I like function overhead.
 750 # ----------------------------------------------------------------------
 751 sub isa($$) {
 752     my ($ref, $type) = @_;
 753     return UNIVERSAL::isa($ref, $type);
 754 }
 755
 756 # ----------------------------------------------------------------------
 757 sub validate {
 758     my ( $self, $arg ) = @_;
 759     if ( defined $arg ) {
 760         $self->{'validate'} = $arg ? 1 : 0;
 761     }
 762     return $self->{'validate'} || 0;
 763 }
 764
 765 1;
 766
 767 # ----------------------------------------------------------------------
 768 # Who killed the pork chops?
 769 # What price bananas?
 770 # Are you my Angel?
 771 # Allen Ginsberg
 772 # ----------------------------------------------------------------------
 773
 774 =pod
 775
 776 =head1 NAME
 777
 778 SQL::Translator - manipulate structured data definitions (SQL and more)
 779
 780 =head1 SYNOPSIS
 781
 782   use SQL::Translator;
 783
 784   my $translator          = SQL::Translator->new(
 785       # Print debug info
 786       debug               => 1,
 787       # Print Parse::RecDescent trace
 788       trace               => 0,
 789       # Don't include comments in output
 790       no_comments         => 0,
 791       # Print name mutations, conflicts
 792       show_warnings       => 0,
 793       # Add "drop table" statements
 794       add_drop_table      => 1,
 795       # Validate schema object
 796       validate            => 1,
 797       # Make all table names CAPS in producers which support this option
 798       format_table_name   => sub {my $tablename = shift; return uc($tablename)},
 799       # Null-op formatting, only here for documentation's sake
 800       format_package_name => sub {return shift},
 801       format_fk_name      => sub {return shift},
 802       format_pk_name      => sub {return shift},
 803   );
 804
 805   my $output     = $translator->translate(
 806       from       => 'MySQL',
 807       to         => 'Oracle',
 808       # Or an arrayref of filenames, i.e. [ $file1, $file2, $file3 ]
 809       filename   => $file,
 810   ) or die $translator->error;
 811
 812   print $output;
 813
 814 =head1 DESCRIPTION
 815
 816 SQL::Translator is a group of Perl modules that converts
 817 vendor-specific SQL table definitions into other formats, such as
 818 other vendor-specific SQL, ER diagrams, documentation (POD and HTML),
 819 XML, and Class::DBI classes.  The main focus of SQL::Translator is
 820 SQL, but parsers exist for other structured data formats, including
 821 Excel spreadsheets and arbitrarily delimited text files.  Through the
 822 separation of the code into parsers and producers with an object model
 823 in between, it's possible to combine any parser with any producer, to
 824 plug in custom parsers or producers, or to manipulate the parsed data
 825 via the built-in object model.  Presently only the definition parts of
 826 SQL are handled (CREATE, ALTER), not the manipulation of data (INSERT,
 827 UPDATE, DELETE).
 828
 829 =head1 CONSTRUCTOR
 830
 831 The constructor is called C<new>, and accepts a optional hash of options.
 832 Valid options are:
 833
 834 =over 4
 835
 836 =item *
 837
 838 parser / from
 839
 840 =item *
 841
 842 parser_args
 843
 844 =item *
 845
 846 producer / to
 847
 848 =item *
 849
 850 producer_args
 851
 852 =item *
 853
 854 filename / file
 855
 856 =item *
 857
 858 data
 859
 860 =item *
 861
 862 debug
 863
 864 =item *
 865
 866 add_drop_table
 867
 868 =item *
 869
 870 no_comments
 871
 872 =item *
 873
 874 trace
 875
 876 =item *
 877
 878 validate
 879
 880 =back
 881
 882 All options are, well, optional; these attributes can be set via
 883 instance methods.  Internally, they are; no (non-syntactical)
 884 advantage is gained by passing options to the constructor.
 885
 886 =head1 METHODS
 887
 888 =head2 add_drop_table
 889
 890 Toggles whether or not to add "DROP TABLE" statements just before the
 891 create definitions.
 892
 893 =head2 no_comments
 894
 895 Toggles whether to print comments in the output.  Accepts a true or false
 896 value, returns the current value.
 897
 898 =head2 producer
 899
 900 The C<producer> method is an accessor/mutator, used to retrieve or
 901 define what subroutine is called to produce the output.  A subroutine
 902 defined as a producer will be invoked as a function (I<not a method>)
 903 and passed 2 parameters: its container C<SQL::Translator> instance and a
 904 data structure.  It is expected that the function transform the data
 905 structure to a string.  The C<SQL::Transformer> instance is provided for
 906 informational purposes; for example, the type of the parser can be
 907 retrieved using the C<parser_type> method, and the C<error> and
 908 C<debug> methods can be called when needed.
 909
 910 When defining a producer, one of several things can be passed in:  A
 911 module name (e.g., C<My::Groovy::Producer>), a module name relative to
 912 the C<SQL::Translator::Producer> namespace (e.g., C<MySQL>), a module
 913 name and function combination (C<My::Groovy::Producer::transmogrify>),
 914 or a reference to an anonymous subroutine.  If a full module name is
 915 passed in (for the purposes of this method, a string containing "::"
 916 is considered to be a module name), it is treated as a package, and a
 917 function called "produce" will be invoked: C<$modulename::produce>.
 918 If $modulename cannot be loaded, the final portion is stripped off and
 919 treated as a function.  In other words, if there is no file named
 920 F<My/Groovy/Producer/transmogrify.pm>, C<SQL::Translator> will attempt
 921 to load F<My/Groovy/Producer.pm> and use C<transmogrify> as the name of
 922 the function, instead of the default C<produce>.
 923
 924   my $tr = SQL::Translator->new;
 925
 926   # This will invoke My::Groovy::Producer::produce($tr, $data)
 927   $tr->producer("My::Groovy::Producer");
 928
 929   # This will invoke SQL::Translator::Producer::Sybase::produce($tr, $data)
 930   $tr->producer("Sybase");
 931
 932   # This will invoke My::Groovy::Producer::transmogrify($tr, $data),
 933   # assuming that My::Groovy::Producer::transmogrify is not a module
 934   # on disk.
 935   $tr->producer("My::Groovy::Producer::transmogrify");
 936
 937   # This will invoke the referenced subroutine directly, as
 938   # $subref->($tr, $data);
 939   $tr->producer(\&my_producer);
 940
 941 There is also a method named C<producer_type>, which is a string
 942 containing the classname to which the above C<produce> function
 943 belongs.  In the case of anonymous subroutines, this method returns
 944 the string "CODE".
 945
 946 Finally, there is a method named C<producer_args>, which is both an
 947 accessor and a mutator.  Arbitrary data may be stored in name => value
 948 pairs for the producer subroutine to access:
 949
 950   sub My::Random::producer {
 951       my ($tr, $data) = @_;
 952       my $pr_args = $tr->producer_args();
 953
 954       # $pr_args is a hashref.
 955
 956 Extra data passed to the C<producer> method is passed to
 957 C<producer_args>:
 958
 959   $tr->producer("xSV", delimiter => ',\s*');
 960
 961   # In SQL::Translator::Producer::xSV:
 962   my $args = $tr->producer_args;
 963   my $delimiter = $args->{'delimiter'}; # value is ,\s*
 964
 965 =head2 parser
 966
 967 The C<parser> method defines or retrieves a subroutine that will be
 968 called to perform the parsing.  The basic idea is the same as that of
 969 C<producer> (see above), except the default subroutine name is
 970 "parse", and will be invoked as C<$module_name::parse($tr, $data)>.
 971 Also, the parser subroutine will be passed a string containing the
 972 entirety of the data to be parsed.
 973
 974   # Invokes SQL::Translator::Parser::MySQL::parse()
 975   $tr->parser("MySQL");
 976
 977   # Invokes My::Groovy::Parser::parse()
 978   $tr->parser("My::Groovy::Parser");
 979
 980   # Invoke an anonymous subroutine directly
 981   $tr->parser(sub {
 982     my $dumper = Data::Dumper->new([ $_[1] ], [ "SQL" ]);
 983     $dumper->Purity(1)->Terse(1)->Deepcopy(1);
 984     return $dumper->Dump;
 985   });
 986
 987 There is also C<parser_type> and C<parser_args>, which perform
 988 analogously to C<producer_type> and C<producer_args>
 989
 990 =head2 show_warnings
 991
 992 Toggles whether to print warnings of name conflicts, identifier
 993 mutations, etc.  Probably only generated by producers to let the user
 994 know when something won't translate very smoothly (e.g., MySQL "enum"
 995 fields into Oracle).  Accepts a true or false value, returns the
 996 current value.
 997
 998 =head2 translate
 999
1000 The C<translate> method calls the subroutines referenced by the
1001 C<parser> and C<producer> data members (described above).  It accepts
1002 as arguments a number of things, in key => value format, including
1003 (potentially) a parser and a producer (they are passed directly to the
1004 C<parser> and C<producer> methods).
1005
1006 Here is how the parameter list to C<translate> is parsed:
1007
1008 =over
1009
1010 =item *
1011
1012 1 argument means it's the data to be parsed; which could be a string
1013 (filename) or a reference to a scalar (a string stored in memory), or a
1014 reference to a hash, which is parsed as being more than one argument
1015 (see next section).
1016
1017   # Parse the file /path/to/datafile
1018   my $output = $tr->translate("/path/to/datafile");
1019
1020   # Parse the data contained in the string $data
1021   my $output = $tr->translate(\$data);
1022
1023 =item *
1024
1025 More than 1 argument means its a hash of things, and it might be
1026 setting a parser, producer, or datasource (this key is named
1027 "filename" or "file" if it's a file, or "data" for a SCALAR reference.
1028
1029   # As above, parse /path/to/datafile, but with different producers
1030   for my $prod ("MySQL", "XML", "Sybase") {
1031       print $tr->translate(
1032                 producer => $prod,
1033                 filename => "/path/to/datafile",
1034             );
1035   }
1036
1037   # The filename hash key could also be:
1038       datasource => \$data,
1039
1040 You get the idea.
1041
1042 =back
1043
1044 =head2 filename, data
1045
1046 Using the C<filename> method, the filename of the data to be parsed
1047 can be set. This method can be used in conjunction with the C<data>
1048 method, below.  If both the C<filename> and C<data> methods are
1049 invoked as mutators, the data set in the C<data> method is used.
1050
1051     $tr->filename("/my/data/files/create.sql");
1052
1053 or:
1054
1055     my $create_script = do {
1056         local $/;
1057         open CREATE, "/my/data/files/create.sql" or die $!;
1058         <CREATE>;
1059     };
1060     $tr->data(\$create_script);
1061
1062 C<filename> takes a string, which is interpreted as a filename.
1063 C<data> takes a reference to a string, which is used as the data to be
1064 parsed.  If a filename is set, then that file is opened and read when
1065 the C<translate> method is called, as long as the data instance
1066 variable is not set.
1067
1068 =head2 schema
1069
1070 Returns the SQL::Translator::Schema object.
1071
1072 =head2 trace
1073
1074 Turns on/off the tracing option of Parse::RecDescent.
1075
1076 =head2 validate
1077
1078 Whether or not to validate the schema object after parsing and before
1079 producing.
1080
1081 =head1 AUTHORS
1082
1083 Ken Y. Clark, E<lt>kclark@cpan.orgE<gt>,
1084 darren chamberlain E<lt>darren@cpan.orgE<gt>,
1085 Chris Mungall E<lt>cjm@fruitfly.orgE<gt>,
1086 Allen Day E<lt>allenday@users.sourceforge.netE<gt>,
1087 Sam Angiuoli E<lt>angiuoli@users.sourceforge.netE<gt>,
1088 Ying Zhang E<lt>zyolive@yahoo.comE<gt>,
1089 Mike Mellilo <mmelillo@users.sourceforge.net>.
1090
1091 =head1 COPYRIGHT
1092
1093 This program is free software; you can redistribute it and/or modify
1094 it under the terms of the GNU General Public License as published by
1095 the Free Software Foundation; version 2.
1096
1097 This program is distributed in the hope that it will be useful, but
1098 WITHOUT ANY WARRANTY; without even the implied warranty of
1099 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
1100 General Public License for more details.
1101
1102 You should have received a copy of the GNU General Public License
1103 along with this program; if not, write to the Free Software
1104 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
1105 USA
1106
1107 =head1 BUGS
1108
1109 Please use http://rt.cpan.org/ for reporting bugs.
1110
1111 =head1 SEE ALSO
1112
1113 L<perl>,
1114 L<SQL::Translator::Parser>,
1115 L<SQL::Translator::Producer>,
1116 L<Parse::RecDescent>,
1117 L<GD>,
1118 L<GraphViz>,
1119 L<Text::RecordParser>,
1120 L<Class::DBI>
1121 L<XML::Writer>.