lib/SQL/Translator.pm

   1 package SQL::Translator;
   2
   3 # ----------------------------------------------------------------------
   4 # $Id: Translator.pm,v 1.54 2004-03-09 19:15:31 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.05';
  30 $REVISION = sprintf "%d.%02d", q$Revision: 1.54 $ =~ /(\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 2 parameters: its container C<SQL::Translator> instance and a
 939 data structure.  It is expected that the function transform the data
 940 structure to a string.  The C<SQL::Transformer> instance is provided for
 941 informational purposes; for example, the type of the parser can be
 942 retrieved using the C<parser_type> method, and the C<error> and
 943 C<debug> methods can be called when needed.
 944
 945 When defining a producer, one of several things can be passed in:  A
 946 module name (e.g., C<My::Groovy::Producer>), a module name relative to
 947 the C<SQL::Translator::Producer> namespace (e.g., C<MySQL>), a module
 948 name and function combination (C<My::Groovy::Producer::transmogrify>),
 949 or a reference to an anonymous subroutine.  If a full module name is
 950 passed in (for the purposes of this method, a string containing "::"
 951 is considered to be a module name), it is treated as a package, and a
 952 function called "produce" will be invoked: C<$modulename::produce>.
 953 If $modulename cannot be loaded, the final portion is stripped off and
 954 treated as a function.  In other words, if there is no file named
 955 F<My/Groovy/Producer/transmogrify.pm>, C<SQL::Translator> will attempt
 956 to load F<My/Groovy/Producer.pm> and use C<transmogrify> as the name of
 957 the function, instead of the default C<produce>.
 958
 959   my $tr = SQL::Translator->new;
 960
 961   # This will invoke My::Groovy::Producer::produce($tr, $data)
 962   $tr->producer("My::Groovy::Producer");
 963
 964   # This will invoke SQL::Translator::Producer::Sybase::produce($tr, $data)
 965   $tr->producer("Sybase");
 966
 967   # This will invoke My::Groovy::Producer::transmogrify($tr, $data),
 968   # assuming that My::Groovy::Producer::transmogrify is not a module
 969   # on disk.
 970   $tr->producer("My::Groovy::Producer::transmogrify");
 971
 972   # This will invoke the referenced subroutine directly, as
 973   # $subref->($tr, $data);
 974   $tr->producer(\&my_producer);
 975
 976 There is also a method named C<producer_type>, which is a string
 977 containing the classname to which the above C<produce> function
 978 belongs.  In the case of anonymous subroutines, this method returns
 979 the string "CODE".
 980
 981 Finally, there is a method named C<producer_args>, which is both an
 982 accessor and a mutator.  Arbitrary data may be stored in name => value
 983 pairs for the producer subroutine to access:
 984
 985   sub My::Random::producer {
 986       my ($tr, $data) = @_;
 987       my $pr_args = $tr->producer_args();
 988
 989       # $pr_args is a hashref.
 990
 991 Extra data passed to the C<producer> method is passed to
 992 C<producer_args>:
 993
 994   $tr->producer("xSV", delimiter => ',\s*');
 995
 996   # In SQL::Translator::Producer::xSV:
 997   my $args = $tr->producer_args;
 998   my $delimiter = $args->{'delimiter'}; # value is ,\s*
 999
1000 =head2 parser
1001
1002 The C<parser> method defines or retrieves a subroutine that will be
1003 called to perform the parsing.  The basic idea is the same as that of
1004 C<producer> (see above), except the default subroutine name is
1005 "parse", and will be invoked as C<$module_name::parse($tr, $data)>.
1006 Also, the parser subroutine will be passed a string containing the
1007 entirety of the data to be parsed.
1008
1009   # Invokes SQL::Translator::Parser::MySQL::parse()
1010   $tr->parser("MySQL");
1011
1012   # Invokes My::Groovy::Parser::parse()
1013   $tr->parser("My::Groovy::Parser");
1014
1015   # Invoke an anonymous subroutine directly
1016   $tr->parser(sub {
1017     my $dumper = Data::Dumper->new([ $_[1] ], [ "SQL" ]);
1018     $dumper->Purity(1)->Terse(1)->Deepcopy(1);
1019     return $dumper->Dump;
1020   });
1021
1022 There is also C<parser_type> and C<parser_args>, which perform
1023 analogously to C<producer_type> and C<producer_args>
1024
1025 =head2 show_warnings
1026
1027 Toggles whether to print warnings of name conflicts, identifier
1028 mutations, etc.  Probably only generated by producers to let the user
1029 know when something won't translate very smoothly (e.g., MySQL "enum"
1030 fields into Oracle).  Accepts a true or false value, returns the
1031 current value.
1032
1033 =head2 translate
1034
1035 The C<translate> method calls the subroutines referenced by the
1036 C<parser> and C<producer> data members (described above).  It accepts
1037 as arguments a number of things, in key => value format, including
1038 (potentially) a parser and a producer (they are passed directly to the
1039 C<parser> and C<producer> methods).
1040
1041 Here is how the parameter list to C<translate> is parsed:
1042
1043 =over
1044
1045 =item *
1046
1047 1 argument means it's the data to be parsed; which could be a string
1048 (filename) or a reference to a scalar (a string stored in memory), or a
1049 reference to a hash, which is parsed as being more than one argument
1050 (see next section).
1051
1052   # Parse the file /path/to/datafile
1053   my $output = $tr->translate("/path/to/datafile");
1054
1055   # Parse the data contained in the string $data
1056   my $output = $tr->translate(\$data);
1057
1058 =item *
1059
1060 More than 1 argument means its a hash of things, and it might be
1061 setting a parser, producer, or datasource (this key is named
1062 "filename" or "file" if it's a file, or "data" for a SCALAR reference.
1063
1064   # As above, parse /path/to/datafile, but with different producers
1065   for my $prod ("MySQL", "XML", "Sybase") {
1066       print $tr->translate(
1067                 producer => $prod,
1068                 filename => "/path/to/datafile",
1069             );
1070   }
1071
1072   # The filename hash key could also be:
1073       datasource => \$data,
1074
1075 You get the idea.
1076
1077 =back
1078
1079 =head2 filename, data
1080
1081 Using the C<filename> method, the filename of the data to be parsed
1082 can be set. This method can be used in conjunction with the C<data>
1083 method, below.  If both the C<filename> and C<data> methods are
1084 invoked as mutators, the data set in the C<data> method is used.
1085
1086     $tr->filename("/my/data/files/create.sql");
1087
1088 or:
1089
1090     my $create_script = do {
1091         local $/;
1092         open CREATE, "/my/data/files/create.sql" or die $!;
1093         <CREATE>;
1094     };
1095     $tr->data(\$create_script);
1096
1097 C<filename> takes a string, which is interpreted as a filename.
1098 C<data> takes a reference to a string, which is used as the data to be
1099 parsed.  If a filename is set, then that file is opened and read when
1100 the C<translate> method is called, as long as the data instance
1101 variable is not set.
1102
1103 =head2 schema
1104
1105 Returns the SQL::Translator::Schema object.
1106
1107 =head2 trace
1108
1109 Turns on/off the tracing option of Parse::RecDescent.
1110
1111 =head2 validate
1112
1113 Whether or not to validate the schema object after parsing and before
1114 producing.
1115
1116 =head2 version
1117
1118 Returns the version of the SQL::Translator release.
1119
1120 =head1 AUTHORS
1121
1122 The following people have contributed to the SQLFairy project:
1123
1124 =over 4
1125
1126 =item * Mark Addison <grommit@users.sourceforge.net>
1127
1128 =item * Sam Angiuoli <angiuoli@users.sourceforge.net>
1129
1130 =item * Dave Cash <dave@gnofn.org>
1131
1132 =item * Darren Chamberlain <dlc@users.sourceforge.net>
1133
1134 =item * Ken Y. Clark <kclark@cpan.org>
1135
1136 =item * Allen Day <allenday@users.sourceforge.net>
1137
1138 =item * Paul Harrington <phrrngtn@users.sourceforge.net>
1139
1140 =item * Mikey Melillo <mmelillo@users.sourceforge.net>
1141
1142 =item * Chris Mungall <cjm@fruitfly.org>
1143
1144 =item * Ross Smith II <rossta@users.sf.net>
1145
1146 =item * Gudmundur A. Thorisson <mummi@cshl.org>
1147
1148 =item * Chris To <christot@users.sourceforge.net>
1149
1150 =item * Jason Williams <smdwilliams@users.sourceforge.net>
1151
1152 =item * Ying Zhang <zyolive@yahoo.com>
1153
1154 =back
1155
1156 If you would like to contribute to the project, you can send patches
1157 to the developers mailing list:
1158
1159     sqlfairy-developers@lists.sourceforge.net
1160
1161 Or send us a message (with your Sourceforge username) asking to be
1162 added to the project and what you'd like to contribute.
1163
1164
1165 =head1 COPYRIGHT
1166
1167 This program is free software; you can redistribute it and/or modify
1168 it under the terms of the GNU General Public License as published by
1169 the Free Software Foundation; version 2.
1170
1171 This program is distributed in the hope that it will be useful, but
1172 WITHOUT ANY WARRANTY; without even the implied warranty of
1173 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
1174 General Public License for more details.
1175
1176 You should have received a copy of the GNU General Public License
1177 along with this program; if not, write to the Free Software
1178 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
1179 USA
1180
1181 =head1 BUGS
1182
1183 Please use L<http://rt.cpan.org/> for reporting bugs.
1184
1185 =head1 PRAISE
1186
1187 If you find this module useful, please use
1188 L<http://cpanratings.perl.org/rate/?distribution=SQL-Translator> to rate it.
1189
1190 =head1 SEE ALSO
1191
1192 L<perl>,
1193 L<SQL::Translator::Parser>,
1194 L<SQL::Translator::Producer>,
1195 L<Parse::RecDescent>,
1196 L<GD>,
1197 L<GraphViz>,
1198 L<Text::RecordParser>,
1199 L<Class::DBI>,
1200 L<XML::Writer>.