lib/SQL/Translator.pm

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