lib/SQL/Translator.pm

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