lib/SQL/Translator.pm

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