lib/SQL/Translator.pm

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