lib/SQL/Translator.pm

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