lib/SQL/Translator.pm

   1 package SQL::Translator;
   2
   3 # ----------------------------------------------------------------------
   4 # $Id: Translator.pm,v 1.52 2004-02-06 17:51:26 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.04';
  30 $REVISION = sprintf "%d.%02d", q$Revision: 1.52 $ =~ /(\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 sub validate {
 779     my ( $self, $arg ) = @_;
 780     if ( defined $arg ) {
 781         $self->{'validate'} = $arg ? 1 : 0;
 782     }
 783     return $self->{'validate'} || 0;
 784 }
 785
 786 1;
 787
 788 # ----------------------------------------------------------------------
 789 # Who killed the pork chops?
 790 # What price bananas?
 791 # Are you my Angel?
 792 # Allen Ginsberg
 793 # ----------------------------------------------------------------------
 794
 795 =pod
 796
 797 =head1 NAME
 798
 799 SQL::Translator - manipulate structured data definitions (SQL and more)
 800
 801 =head1 SYNOPSIS
 802
 803   use SQL::Translator;
 804
 805   my $translator          = SQL::Translator->new(
 806       # Print debug info
 807       debug               => 1,
 808       # Print Parse::RecDescent trace
 809       trace               => 0,
 810       # Don't include comments in output
 811       no_comments         => 0,
 812       # Print name mutations, conflicts
 813       show_warnings       => 0,
 814       # Add "drop table" statements
 815       add_drop_table      => 1,
 816       # Validate schema object
 817       validate            => 1,
 818       # Make all table names CAPS in producers which support this option
 819       format_table_name   => sub {my $tablename = shift; return uc($tablename)},
 820       # Null-op formatting, only here for documentation's sake
 821       format_package_name => sub {return shift},
 822       format_fk_name      => sub {return shift},
 823       format_pk_name      => sub {return shift},
 824   );
 825
 826   my $output     = $translator->translate(
 827       from       => 'MySQL',
 828       to         => 'Oracle',
 829       # Or an arrayref of filenames, i.e. [ $file1, $file2, $file3 ]
 830       filename   => $file,
 831   ) or die $translator->error;
 832
 833   print $output;
 834
 835 =head1 DESCRIPTION
 836
 837 SQL::Translator is a group of Perl modules that converts
 838 vendor-specific SQL table definitions into other formats, such as
 839 other vendor-specific SQL, ER diagrams, documentation (POD and HTML),
 840 XML, and Class::DBI classes.  The main focus of SQL::Translator is
 841 SQL, but parsers exist for other structured data formats, including
 842 Excel spreadsheets and arbitrarily delimited text files.  Through the
 843 separation of the code into parsers and producers with an object model
 844 in between, it's possible to combine any parser with any producer, to
 845 plug in custom parsers or producers, or to manipulate the parsed data
 846 via the built-in object model.  Presently only the definition parts of
 847 SQL are handled (CREATE, ALTER), not the manipulation of data (INSERT,
 848 UPDATE, DELETE).
 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 =head1 CONSTRUCTOR
 855
 856 The constructor is called C<new>, and accepts a optional hash of options.
 857 Valid options are:
 858
 859 =over 4
 860
 861 =item *
 862
 863 parser / from
 864
 865 =item *
 866
 867 parser_args
 868
 869 =item *
 870
 871 producer / to
 872
 873 =item *
 874
 875 producer_args
 876
 877 =item *
 878
 879 filename / file
 880
 881 =item *
 882
 883 data
 884
 885 =item *
 886
 887 debug
 888
 889 =item *
 890
 891 add_drop_table
 892
 893 =item *
 894
 895 no_comments
 896
 897 =item *
 898
 899 trace
 900
 901 =item *
 902
 903 validate
 904
 905 =back
 906
 907 All options are, well, optional; these attributes can be set via
 908 instance methods.  Internally, they are; no (non-syntactical)
 909 advantage is gained by passing options to the constructor.
 910
 911 =head1 METHODS
 912
 913 =head2 add_drop_table
 914
 915 Toggles whether or not to add "DROP TABLE" statements just before the
 916 create definitions.
 917
 918 =head2 no_comments
 919
 920 Toggles whether to print comments in the output.  Accepts a true or false
 921 value, returns the current value.
 922
 923 =head2 producer
 924
 925 The C<producer> method is an accessor/mutator, used to retrieve or
 926 define what subroutine is called to produce the output.  A subroutine
 927 defined as a producer will be invoked as a function (I<not a method>)
 928 and passed 2 parameters: its container C<SQL::Translator> instance and a
 929 data structure.  It is expected that the function transform the data
 930 structure to a string.  The C<SQL::Transformer> instance is provided for
 931 informational purposes; for example, the type of the parser can be
 932 retrieved using the C<parser_type> method, and the C<error> and
 933 C<debug> methods can be called when needed.
 934
 935 When defining a producer, one of several things can be passed in:  A
 936 module name (e.g., C<My::Groovy::Producer>), a module name relative to
 937 the C<SQL::Translator::Producer> namespace (e.g., C<MySQL>), a module
 938 name and function combination (C<My::Groovy::Producer::transmogrify>),
 939 or a reference to an anonymous subroutine.  If a full module name is
 940 passed in (for the purposes of this method, a string containing "::"
 941 is considered to be a module name), it is treated as a package, and a
 942 function called "produce" will be invoked: C<$modulename::produce>.
 943 If $modulename cannot be loaded, the final portion is stripped off and
 944 treated as a function.  In other words, if there is no file named
 945 F<My/Groovy/Producer/transmogrify.pm>, C<SQL::Translator> will attempt
 946 to load F<My/Groovy/Producer.pm> and use C<transmogrify> as the name of
 947 the function, instead of the default C<produce>.
 948
 949   my $tr = SQL::Translator->new;
 950
 951   # This will invoke My::Groovy::Producer::produce($tr, $data)
 952   $tr->producer("My::Groovy::Producer");
 953
 954   # This will invoke SQL::Translator::Producer::Sybase::produce($tr, $data)
 955   $tr->producer("Sybase");
 956
 957   # This will invoke My::Groovy::Producer::transmogrify($tr, $data),
 958   # assuming that My::Groovy::Producer::transmogrify is not a module
 959   # on disk.
 960   $tr->producer("My::Groovy::Producer::transmogrify");
 961
 962   # This will invoke the referenced subroutine directly, as
 963   # $subref->($tr, $data);
 964   $tr->producer(\&my_producer);
 965
 966 There is also a method named C<producer_type>, which is a string
 967 containing the classname to which the above C<produce> function
 968 belongs.  In the case of anonymous subroutines, this method returns
 969 the string "CODE".
 970
 971 Finally, there is a method named C<producer_args>, which is both an
 972 accessor and a mutator.  Arbitrary data may be stored in name => value
 973 pairs for the producer subroutine to access:
 974
 975   sub My::Random::producer {
 976       my ($tr, $data) = @_;
 977       my $pr_args = $tr->producer_args();
 978
 979       # $pr_args is a hashref.
 980
 981 Extra data passed to the C<producer> method is passed to
 982 C<producer_args>:
 983
 984   $tr->producer("xSV", delimiter => ',\s*');
 985
 986   # In SQL::Translator::Producer::xSV:
 987   my $args = $tr->producer_args;
 988   my $delimiter = $args->{'delimiter'}; # value is ,\s*
 989
 990 =head2 parser
 991
 992 The C<parser> method defines or retrieves a subroutine that will be
 993 called to perform the parsing.  The basic idea is the same as that of
 994 C<producer> (see above), except the default subroutine name is
 995 "parse", and will be invoked as C<$module_name::parse($tr, $data)>.
 996 Also, the parser subroutine will be passed a string containing the
 997 entirety of the data to be parsed.
 998
 999   # Invokes SQL::Translator::Parser::MySQL::parse()
1000   $tr->parser("MySQL");
1001
1002   # Invokes My::Groovy::Parser::parse()
1003   $tr->parser("My::Groovy::Parser");
1004
1005   # Invoke an anonymous subroutine directly
1006   $tr->parser(sub {
1007     my $dumper = Data::Dumper->new([ $_[1] ], [ "SQL" ]);
1008     $dumper->Purity(1)->Terse(1)->Deepcopy(1);
1009     return $dumper->Dump;
1010   });
1011
1012 There is also C<parser_type> and C<parser_args>, which perform
1013 analogously to C<producer_type> and C<producer_args>
1014
1015 =head2 show_warnings
1016
1017 Toggles whether to print warnings of name conflicts, identifier
1018 mutations, etc.  Probably only generated by producers to let the user
1019 know when something won't translate very smoothly (e.g., MySQL "enum"
1020 fields into Oracle).  Accepts a true or false value, returns the
1021 current value.
1022
1023 =head2 translate
1024
1025 The C<translate> method calls the subroutines referenced by the
1026 C<parser> and C<producer> data members (described above).  It accepts
1027 as arguments a number of things, in key => value format, including
1028 (potentially) a parser and a producer (they are passed directly to the
1029 C<parser> and C<producer> methods).
1030
1031 Here is how the parameter list to C<translate> is parsed:
1032
1033 =over
1034
1035 =item *
1036
1037 1 argument means it's the data to be parsed; which could be a string
1038 (filename) or a reference to a scalar (a string stored in memory), or a
1039 reference to a hash, which is parsed as being more than one argument
1040 (see next section).
1041
1042   # Parse the file /path/to/datafile
1043   my $output = $tr->translate("/path/to/datafile");
1044
1045   # Parse the data contained in the string $data
1046   my $output = $tr->translate(\$data);
1047
1048 =item *
1049
1050 More than 1 argument means its a hash of things, and it might be
1051 setting a parser, producer, or datasource (this key is named
1052 "filename" or "file" if it's a file, or "data" for a SCALAR reference.
1053
1054   # As above, parse /path/to/datafile, but with different producers
1055   for my $prod ("MySQL", "XML", "Sybase") {
1056       print $tr->translate(
1057                 producer => $prod,
1058                 filename => "/path/to/datafile",
1059             );
1060   }
1061
1062   # The filename hash key could also be:
1063       datasource => \$data,
1064
1065 You get the idea.
1066
1067 =back
1068
1069 =head2 filename, data
1070
1071 Using the C<filename> method, the filename of the data to be parsed
1072 can be set. This method can be used in conjunction with the C<data>
1073 method, below.  If both the C<filename> and C<data> methods are
1074 invoked as mutators, the data set in the C<data> method is used.
1075
1076     $tr->filename("/my/data/files/create.sql");
1077
1078 or:
1079
1080     my $create_script = do {
1081         local $/;
1082         open CREATE, "/my/data/files/create.sql" or die $!;
1083         <CREATE>;
1084     };
1085     $tr->data(\$create_script);
1086
1087 C<filename> takes a string, which is interpreted as a filename.
1088 C<data> takes a reference to a string, which is used as the data to be
1089 parsed.  If a filename is set, then that file is opened and read when
1090 the C<translate> method is called, as long as the data instance
1091 variable is not set.
1092
1093 =head2 schema
1094
1095 Returns the SQL::Translator::Schema object.
1096
1097 =head2 trace
1098
1099 Turns on/off the tracing option of Parse::RecDescent.
1100
1101 =head2 validate
1102
1103 Whether or not to validate the schema object after parsing and before
1104 producing.
1105
1106 =head1 AUTHORS
1107
1108 The following people have contributed to the SQLFairy project:
1109
1110 =over 4
1111
1112 =item * Mark Addison <grommit@users.sourceforge.net>
1113
1114 =item * Sam Angiuoli <angiuoli@users.sourceforge.net>
1115
1116 =item * Dave Cash <dave@gnofn.org>
1117
1118 =item * Darren Chamberlain <dlc@users.sourceforge.net>
1119
1120 =item * Ken Y. Clark <kclark@cpan.org>
1121
1122 =item * Allen Day <allenday@users.sourceforge.net>
1123
1124 =item * Paul Harrington <phrrngtn@users.sourceforge.net>
1125
1126 =item * Mikey Melillo <mmelillo@users.sourceforge.net>
1127
1128 =item * Chris Mungall <cjm@fruitfly.org>
1129
1130 =item * Ross Smith II <rossta@users.sf.net>
1131
1132 =item * Gudmundur A. Thorisson <mummi@cshl.org>
1133
1134 =item * Chris To <christot@users.sourceforge.net>
1135
1136 =item * Jason Williams <smdwilliams@users.sourceforge.net>
1137
1138 =item * Ying Zhang <zyolive@yahoo.com>
1139
1140 =back
1141
1142 If you would like to contribute to the project, you can send patches
1143 to the developers mailing list:
1144
1145     sqlfairy-developers@lists.sourceforge.net
1146
1147 Or send us a message (with your Sourceforge username) asking to be
1148 added to the project and what you'd like to contribute.
1149
1150
1151 =head1 COPYRIGHT
1152
1153 This program is free software; you can redistribute it and/or modify
1154 it under the terms of the GNU General Public License as published by
1155 the Free Software Foundation; version 2.
1156
1157 This program is distributed in the hope that it will be useful, but
1158 WITHOUT ANY WARRANTY; without even the implied warranty of
1159 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
1160 General Public License for more details.
1161
1162 You should have received a copy of the GNU General Public License
1163 along with this program; if not, write to the Free Software
1164 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
1165 USA
1166
1167 =head1 BUGS
1168
1169 Please use L<http://rt.cpan.org/> for reporting bugs.
1170
1171 =head1 PRAISE
1172
1173 If you find this module useful, please use
1174 L<http://cpanratings.perl.org/rate/?distribution=SQL-Translator> to rate it.
1175
1176 =head1 SEE ALSO
1177
1178 L<perl>,
1179 L<SQL::Translator::Parser>,
1180 L<SQL::Translator::Producer>,
1181 L<Parse::RecDescent>,
1182 L<GD>,
1183 L<GraphViz>,
1184 L<Text::RecordParser>,
1185 L<Class::DBI>,
1186 L<XML::Writer>.