lib/SQL/Translator.pm

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