lib/SQL/Translator.pm

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