lib/SQL/Translator.pm

   1 package SQL::Translator;
   2
   3 # ----------------------------------------------------------------------
   4 # $Id: Translator.pm,v 1.60 2004-11-09 02:09:52 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.60 $ =~ /(\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 @_;
 547     my $tool = shift;
 548
 549     # passed an anonymous subroutine reference
 550     if (isa($tool, 'CODE')) {
 551         $self->{$name} = $tool;
 552         $self->{"$name\_type"} = "CODE";
 553         $self->debug("Got $name: code ref\n");
 554     }
 555
 556     # Passed a module name or module and sub name
 557     else {
 558         my $func_name;
 559
 560         # Module name was passed directly
 561         # We try to load the name; if it doesn't load, there's a
 562         # possibility that it has a function name attached to it.
 563         $tool =~ s/-/::/g if $tool !~ /::/;
 564         if ( my $loaded = load($tool => $args->{path}) ) {
 565             $tool = $loaded;
 566             $func_name = $args->{default_sub};
 567         }
 568
 569         # Passed Module::Name::function; try to recover
 570         else {
 571             my @func_parts = split /::/, $tool;
 572             $func_name = pop @func_parts;
 573             $tool = join "::", @func_parts;
 574
 575             # If this doesn't work, then we have a legitimate
 576             # problem.
 577             load($tool) or die "Can't load $tool: $@";
 578         }
 579
 580         # get code reference and assign
 581         $self->{$name} = \&{ "$tool\::$func_name" };
 582         $self->{"$name\_type"} = $tool;
 583         $self->debug("Got $name: $tool\::$func_name\n");
 584     }
 585
 586     # At this point, $self->{$name} contains a subroutine
 587     # reference that is ready to run
 588
 589     # Anything left?  If so, it's args
 590     my $meth = "$name\_args";
 591     $self->$meth(@_) if (@_);
 592
 593     return $self->{$name};
 594 }
 595
 596 # ----------------------------------------------------------------------
 597 # _list($type)
 598 # ----------------------------------------------------------------------
 599 sub _list {
 600     my $self   = shift;
 601     my $type   = shift || return ();
 602     my $uctype = ucfirst lc $type;
 603
 604     #
 605     # First find all the directories where SQL::Translator
 606     # parsers or producers (the "type") appear to live.
 607     #
 608     load("SQL::Translator::$uctype") or return ();
 609     my $path = catfile "SQL", "Translator", $uctype;
 610     my @dirs;
 611     for (@INC) {
 612         my $dir = catfile $_, $path;
 613         $self->debug("_list_${type}s searching $dir\n");
 614         next unless -d $dir;
 615         push @dirs, $dir;
 616     }
 617
 618     #
 619     # Now use File::File::find to look recursively in those
 620     # directories for all the *.pm files, then present them
 621     # with the slashes turned into dashes.
 622     #
 623     my %found;
 624     find(
 625         sub {
 626             if ( -f && m/\.pm$/ ) {
 627                 my $mod      =  $_;
 628                    $mod      =~ s/\.pm$//;
 629                 my $cur_dir  = $File::Find::dir;
 630                 my $base_dir = quotemeta catfile 'SQL', 'Translator', $uctype;
 631
 632                 #
 633                 # See if the current directory is below the base directory.
 634                 #
 635                 if ( $cur_dir =~ m/$base_dir(.*)/ ) {
 636                     $cur_dir = $1;
 637                     $cur_dir =~ s!^/!!;  # kill leading slash
 638                     $cur_dir =~ s!/!-!g; # turn other slashes into dashes
 639                 }
 640                 else {
 641                     $cur_dir = '';
 642                 }
 643
 644                 $found{ join '-', map { $_ || () } $cur_dir, $mod } = 1;
 645             }
 646         },
 647         @dirs
 648     );
 649
 650     return sort { lc $a cmp lc $b } keys %found;
 651 }
 652
 653 # ----------------------------------------------------------------------
 654 # load(MODULE [,PATH[,PATH]...])
 655 #
 656 # Loads a Perl module.  Short circuits if a module is already loaded.
 657 #
 658 # MODULE - is the name of the module to load.
 659 #
 660 # PATH - optional list of 'package paths' to look for the module in. e.g
 661 # If you called load(Bar => 'Foo', 'My::Modules') it will try to load the mod
 662 # Bar then Foo::Bar then My::Modules::Bar.
 663 #
 664 # Returns package name of the module actually loaded or false and sets error.
 665 #
 666 # Note, you can't load a name from the root namespace (ie one without '::' in
 667 # it), therefore a single word name without a path fails.
 668 # ----------------------------------------------------------------------
 669 sub load {
 670     my $name = shift;
 671     my @path;
 672     push @path, "" if $name =~ /::/; # Empty path to check name on its own first
 673     push @path, @_ if @_;
 674
 675     foreach (@path) {
 676         my $module = $_ ? "$_\::$name" : $name;
 677         my $file = $module; $file =~ s[::][/]g; $file .= ".pm";
 678         __PACKAGE__->debug("Loading $name as $file\n");
 679         return $module if $INC{$file}; # Already loaded
 680
 681         eval { require $file };
 682         next if $@ =~ /Can't locate $file in \@INC/;
 683         eval { $file->import(@_) } unless $@;
 684         return __PACKAGE__->error("Error loading $name as $module : $@") if $@;
 685
 686         return $module; # Module loaded ok
 687     }
 688
 689     return 0;
 690 }
 691
 692 # ----------------------------------------------------------------------
 693 sub format_table_name {
 694     return shift->_format_name('_format_table_name', @_);
 695 }
 696
 697 # ----------------------------------------------------------------------
 698 sub format_package_name {
 699     return shift->_format_name('_format_package_name', @_);
 700 }
 701
 702 # ----------------------------------------------------------------------
 703 sub format_fk_name {
 704     return shift->_format_name('_format_fk_name', @_);
 705 }
 706
 707 # ----------------------------------------------------------------------
 708 sub format_pk_name {
 709     return shift->_format_name('_format_pk_name', @_);
 710 }
 711
 712 # ----------------------------------------------------------------------
 713 # The other format_*_name methods rely on this one.  It optionally
 714 # accepts a subroutine ref as the first argument (or uses an identity
 715 # sub if one isn't provided or it doesn't already exist), and applies
 716 # it to the rest of the arguments (if any).
 717 # ----------------------------------------------------------------------
 718 sub _format_name {
 719     my $self = shift;
 720     my $field = shift;
 721     my @args = @_;
 722
 723     if (ref($args[0]) eq 'CODE') {
 724         $self->{$field} = shift @args;
 725     }
 726     elsif (! exists $self->{$field}) {
 727         $self->{$field} = sub { return shift };
 728     }
 729
 730     return @args ? $self->{$field}->(@args) : $self->{$field};
 731 }
 732
 733 # ----------------------------------------------------------------------
 734 # isa($ref, $type)
 735 #
 736 # Calls UNIVERSAL::isa($ref, $type).  I think UNIVERSAL::isa is ugly,
 737 # but I like function overhead.
 738 # ----------------------------------------------------------------------
 739 sub isa($$) {
 740     my ($ref, $type) = @_;
 741     return UNIVERSAL::isa($ref, $type);
 742 }
 743
 744 # ----------------------------------------------------------------------
 745 # version
 746 #
 747 # Returns the $VERSION of the main SQL::Translator package.
 748 # ----------------------------------------------------------------------
 749 sub version {
 750     my $self = shift;
 751     return $VERSION;
 752 }
 753
 754 # ----------------------------------------------------------------------
 755 sub validate {
 756     my ( $self, $arg ) = @_;
 757     if ( defined $arg ) {
 758         $self->{'validate'} = $arg ? 1 : 0;
 759     }
 760     return $self->{'validate'} || 0;
 761 }
 762
 763 1;
 764
 765 # ----------------------------------------------------------------------
 766 # Who killed the pork chops?
 767 # What price bananas?
 768 # Are you my Angel?
 769 # Allen Ginsberg
 770 # ----------------------------------------------------------------------
 771
 772 =pod
 773
 774 =head1 NAME
 775
 776 SQL::Translator - manipulate structured data definitions (SQL and more)
 777
 778 =head1 SYNOPSIS
 779
 780   use SQL::Translator;
 781
 782   my $translator          = SQL::Translator->new(
 783       # Print debug info
 784       debug               => 1,
 785       # Print Parse::RecDescent trace
 786       trace               => 0,
 787       # Don't include comments in output
 788       no_comments         => 0,
 789       # Print name mutations, conflicts
 790       show_warnings       => 0,
 791       # Add "drop table" statements
 792       add_drop_table      => 1,
 793       # Validate schema object
 794       validate            => 1,
 795       # Make all table names CAPS in producers which support this option
 796       format_table_name   => sub {my $tablename = shift; return uc($tablename)},
 797       # Null-op formatting, only here for documentation's sake
 798       format_package_name => sub {return shift},
 799       format_fk_name      => sub {return shift},
 800       format_pk_name      => sub {return shift},
 801   );
 802
 803   my $output     = $translator->translate(
 804       from       => 'MySQL',
 805       to         => 'Oracle',
 806       # Or an arrayref of filenames, i.e. [ $file1, $file2, $file3 ]
 807       filename   => $file,
 808   ) or die $translator->error;
 809
 810   print $output;
 811
 812 =head1 DESCRIPTION
 813
 814 This documentation covers the API for SQL::Translator.  For a more general
 815 discussion of how to use the modules and scripts, please see
 816 L<SQL::Translator::Manual>.
 817
 818 SQL::Translator is a group of Perl modules that converts
 819 vendor-specific SQL table definitions into other formats, such as
 820 other vendor-specific SQL, ER diagrams, documentation (POD and HTML),
 821 XML, and Class::DBI classes.  The main focus of SQL::Translator is
 822 SQL, but parsers exist for other structured data formats, including
 823 Excel spreadsheets and arbitrarily delimited text files.  Through the
 824 separation of the code into parsers and producers with an object model
 825 in between, it's possible to combine any parser with any producer, to
 826 plug in custom parsers or producers, or to manipulate the parsed data
 827 via the built-in object model.  Presently only the definition parts of
 828 SQL are handled (CREATE, ALTER), not the manipulation of data (INSERT,
 829 UPDATE, DELETE).
 830
 831 =head1 CONSTRUCTOR
 832
 833 The constructor is called C<new>, and accepts a optional hash of options.
 834 Valid options are:
 835
 836 =over 4
 837
 838 =item *
 839
 840 parser / from
 841
 842 =item *
 843
 844 parser_args
 845
 846 =item *
 847
 848 producer / to
 849
 850 =item *
 851
 852 producer_args
 853
 854 =item *
 855
 856 filename / file
 857
 858 =item *
 859
 860 data
 861
 862 =item *
 863
 864 debug
 865
 866 =item *
 867
 868 add_drop_table
 869
 870 =item *
 871
 872 no_comments
 873
 874 =item *
 875
 876 trace
 877
 878 =item *
 879
 880 validate
 881
 882 =back
 883
 884 All options are, well, optional; these attributes can be set via
 885 instance methods.  Internally, they are; no (non-syntactical)
 886 advantage is gained by passing options to the constructor.
 887
 888 =head1 METHODS
 889
 890 =head2 add_drop_table
 891
 892 Toggles whether or not to add "DROP TABLE" statements just before the
 893 create definitions.
 894
 895 =head2 no_comments
 896
 897 Toggles whether to print comments in the output.  Accepts a true or false
 898 value, returns the current value.
 899
 900 =head2 producer
 901
 902 The C<producer> method is an accessor/mutator, used to retrieve or
 903 define what subroutine is called to produce the output.  A subroutine
 904 defined as a producer will be invoked as a function (I<not a method>)
 905 and passed its container C<SQL::Translator> instance, which it should
 906 call the C<schema> method on, to get the C<SQL::Translator::Schema>
 907 generated by the parser.  It is expected that the function transform the
 908 schema structure to a string.  The C<SQL::Translator> instance is also useful
 909 for informational purposes; for example, the type of the parser can be
 910 retrieved using the C<parser_type> method, and the C<error> and
 911 C<debug> methods can be called when needed.
 912
 913 When defining a producer, one of several things can be passed in:  A
 914 module name (e.g., C<My::Groovy::Producer>), a module name relative to
 915 the C<SQL::Translator::Producer> namespace (e.g., C<MySQL>), a module
 916 name and function combination (C<My::Groovy::Producer::transmogrify>),
 917 or a reference to an anonymous subroutine.  If a full module name is
 918 passed in (for the purposes of this method, a string containing "::"
 919 is considered to be a module name), it is treated as a package, and a
 920 function called "produce" will be invoked: C<$modulename::produce>.
 921 If $modulename cannot be loaded, the final portion is stripped off and
 922 treated as a function.  In other words, if there is no file named
 923 F<My/Groovy/Producer/transmogrify.pm>, C<SQL::Translator> will attempt
 924 to load F<My/Groovy/Producer.pm> and use C<transmogrify> as the name of
 925 the function, instead of the default C<produce>.
 926
 927   my $tr = SQL::Translator->new;
 928
 929   # This will invoke My::Groovy::Producer::produce($tr, $data)
 930   $tr->producer("My::Groovy::Producer");
 931
 932   # This will invoke SQL::Translator::Producer::Sybase::produce($tr, $data)
 933   $tr->producer("Sybase");
 934
 935   # This will invoke My::Groovy::Producer::transmogrify($tr, $data),
 936   # assuming that My::Groovy::Producer::transmogrify is not a module
 937   # on disk.
 938   $tr->producer("My::Groovy::Producer::transmogrify");
 939
 940   # This will invoke the referenced subroutine directly, as
 941   # $subref->($tr, $data);
 942   $tr->producer(\&my_producer);
 943
 944 There is also a method named C<producer_type>, which is a string
 945 containing the classname to which the above C<produce> function
 946 belongs.  In the case of anonymous subroutines, this method returns
 947 the string "CODE".
 948
 949 Finally, there is a method named C<producer_args>, which is both an
 950 accessor and a mutator.  Arbitrary data may be stored in name => value
 951 pairs for the producer subroutine to access:
 952
 953   sub My::Random::producer {
 954       my ($tr, $data) = @_;
 955       my $pr_args = $tr->producer_args();
 956
 957       # $pr_args is a hashref.
 958
 959 Extra data passed to the C<producer> method is passed to
 960 C<producer_args>:
 961
 962   $tr->producer("xSV", delimiter => ',\s*');
 963
 964   # In SQL::Translator::Producer::xSV:
 965   my $args = $tr->producer_args;
 966   my $delimiter = $args->{'delimiter'}; # value is ,\s*
 967
 968 =head2 parser
 969
 970 The C<parser> method defines or retrieves a subroutine that will be
 971 called to perform the parsing.  The basic idea is the same as that of
 972 C<producer> (see above), except the default subroutine name is
 973 "parse", and will be invoked as C<$module_name::parse($tr, $data)>.
 974 Also, the parser subroutine will be passed a string containing the
 975 entirety of the data to be parsed.
 976
 977   # Invokes SQL::Translator::Parser::MySQL::parse()
 978   $tr->parser("MySQL");
 979
 980   # Invokes My::Groovy::Parser::parse()
 981   $tr->parser("My::Groovy::Parser");
 982
 983   # Invoke an anonymous subroutine directly
 984   $tr->parser(sub {
 985     my $dumper = Data::Dumper->new([ $_[1] ], [ "SQL" ]);
 986     $dumper->Purity(1)->Terse(1)->Deepcopy(1);
 987     return $dumper->Dump;
 988   });
 989
 990 There is also C<parser_type> and C<parser_args>, which perform
 991 analogously to C<producer_type> and C<producer_args>
 992
 993 =head2 show_warnings
 994
 995 Toggles whether to print warnings of name conflicts, identifier
 996 mutations, etc.  Probably only generated by producers to let the user
 997 know when something won't translate very smoothly (e.g., MySQL "enum"
 998 fields into Oracle).  Accepts a true or false value, returns the
 999 current value.
1000
1001 =head2 translate
1002
1003 The C<translate> method calls the subroutines referenced by the
1004 C<parser> and C<producer> data members (described above).  It accepts
1005 as arguments a number of things, in key => value format, including
1006 (potentially) a parser and a producer (they are passed directly to the
1007 C<parser> and C<producer> methods).
1008
1009 Here is how the parameter list to C<translate> is parsed:
1010
1011 =over
1012
1013 =item *
1014
1015 1 argument means it's the data to be parsed; which could be a string
1016 (filename) or a reference to a scalar (a string stored in memory), or a
1017 reference to a hash, which is parsed as being more than one argument
1018 (see next section).
1019
1020   # Parse the file /path/to/datafile
1021   my $output = $tr->translate("/path/to/datafile");
1022
1023   # Parse the data contained in the string $data
1024   my $output = $tr->translate(\$data);
1025
1026 =item *
1027
1028 More than 1 argument means its a hash of things, and it might be
1029 setting a parser, producer, or datasource (this key is named
1030 "filename" or "file" if it's a file, or "data" for a SCALAR reference.
1031
1032   # As above, parse /path/to/datafile, but with different producers
1033   for my $prod ("MySQL", "XML", "Sybase") {
1034       print $tr->translate(
1035                 producer => $prod,
1036                 filename => "/path/to/datafile",
1037             );
1038   }
1039
1040   # The filename hash key could also be:
1041       datasource => \$data,
1042
1043 You get the idea.
1044
1045 =back
1046
1047 =head2 filename, data
1048
1049 Using the C<filename> method, the filename of the data to be parsed
1050 can be set. This method can be used in conjunction with the C<data>
1051 method, below.  If both the C<filename> and C<data> methods are
1052 invoked as mutators, the data set in the C<data> method is used.
1053
1054     $tr->filename("/my/data/files/create.sql");
1055
1056 or:
1057
1058     my $create_script = do {
1059         local $/;
1060         open CREATE, "/my/data/files/create.sql" or die $!;
1061         <CREATE>;
1062     };
1063     $tr->data(\$create_script);
1064
1065 C<filename> takes a string, which is interpreted as a filename.
1066 C<data> takes a reference to a string, which is used as the data to be
1067 parsed.  If a filename is set, then that file is opened and read when
1068 the C<translate> method is called, as long as the data instance
1069 variable is not set.
1070
1071 =head2 schema
1072
1073 Returns the SQL::Translator::Schema object.
1074
1075 =head2 trace
1076
1077 Turns on/off the tracing option of Parse::RecDescent.
1078
1079 =head2 validate
1080
1081 Whether or not to validate the schema object after parsing and before
1082 producing.
1083
1084 =head2 version
1085
1086 Returns the version of the SQL::Translator release.
1087
1088 =head1 AUTHORS
1089
1090 The following people have contributed to the SQLFairy project:
1091
1092 =over 4
1093
1094 =item * Mark Addison <grommit@users.sourceforge.net>
1095
1096 =item * Sam Angiuoli <angiuoli@users.sourceforge.net>
1097
1098 =item * Dave Cash <dave@gnofn.org>
1099
1100 =item * Darren Chamberlain <dlc@users.sourceforge.net>
1101
1102 =item * Ken Y. Clark <kclark@cpan.org>
1103
1104 =item * Allen Day <allenday@users.sourceforge.net>
1105
1106 =item * Paul Harrington <phrrngtn@users.sourceforge.net>
1107
1108 =item * Mikey Melillo <mmelillo@users.sourceforge.net>
1109
1110 =item * Chris Mungall <cjm@fruitfly.org>
1111
1112 =item * Ross Smith II <rossta@users.sf.net>
1113
1114 =item * Gudmundur A. Thorisson <mummi@cshl.org>
1115
1116 =item * Chris To <christot@users.sourceforge.net>
1117
1118 =item * Jason Williams <smdwilliams@users.sourceforge.net>
1119
1120 =item * Ying Zhang <zyolive@yahoo.com>
1121
1122 =back
1123
1124 If you would like to contribute to the project, you can send patches
1125 to the developers mailing list:
1126
1127     sqlfairy-developers@lists.sourceforge.net
1128
1129 Or send us a message (with your Sourceforge username) asking to be
1130 added to the project and what you'd like to contribute.
1131
1132
1133 =head1 COPYRIGHT
1134
1135 This program is free software; you can redistribute it and/or modify
1136 it under the terms of the GNU General Public License as published by
1137 the Free Software Foundation; version 2.
1138
1139 This program is distributed in the hope that it will be useful, but
1140 WITHOUT ANY WARRANTY; without even the implied warranty of
1141 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
1142 General Public License for more details.
1143
1144 You should have received a copy of the GNU General Public License
1145 along with this program; if not, write to the Free Software
1146 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
1147 USA
1148
1149 =head1 BUGS
1150
1151 Please use L<http://rt.cpan.org/> for reporting bugs.
1152
1153 =head1 PRAISE
1154
1155 If you find this module useful, please use
1156 L<http://cpanratings.perl.org/rate/?distribution=SQL-Translator> to rate it.
1157
1158 =head1 SEE ALSO
1159
1160 L<perl>,
1161 L<SQL::Translator::Parser>,
1162 L<SQL::Translator::Producer>,
1163 L<Parse::RecDescent>,
1164 L<GD>,
1165 L<GraphViz>,
1166 L<Text::RecordParser>,
1167 L<Class::DBI>,
1168 L<XML::Writer>.