lib/SQL/Translator.pm

   1 package SQL::Translator;
   2
   3 # ----------------------------------------------------------------------
   4 # $Id: Translator.pm 1448 2009-02-07 18:32:52Z ribasushi $
   5 # ----------------------------------------------------------------------
   6 # Copyright (C) 2002-2009 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 $DEFAULT_SUB $DEBUG $ERROR );
  25 use base 'Class::Base';
  26
  27 require 5.004;
  28
  29 $VERSION  = '0.09003';
  30 $DEBUG    = 0 unless defined $DEBUG;
  31 $ERROR    = "";
  32
  33 use Carp qw(carp);
  34
  35 use Data::Dumper;
  36 use Class::Base;
  37 use File::Find;
  38 use File::Spec::Functions qw(catfile);
  39 use File::Basename qw(dirname);
  40 use IO::Dir;
  41 use SQL::Translator::Producer;
  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 {
 540         if ($wantarray) {
 541             @producer_output = $producer->($self);
 542         } else {
 543             $producer_output = $producer->($self);
 544         }
 545     };
 546     if ($@ || !( $producer_output || @producer_output)) {
 547         my $err = $@ || $self->error || "no results";
 548         my $msg = "translate: Error with producer '$producer_type': $err";
 549         return $self->error($msg);
 550     }
 551
 552     return wantarray ? @producer_output : $producer_output;
 553 }
 554
 555 # ----------------------------------------------------------------------
 556 # list_parsers()
 557 #
 558 # Hacky sort of method to list all available parsers.  This has
 559 # several problems:
 560 #
 561 #   - Only finds things in the SQL::Translator::Parser namespace
 562 #
 563 #   - Only finds things that are located in the same directory
 564 #     as SQL::Translator::Parser.  Yeck.
 565 #
 566 # This method will fail in several very likely cases:
 567 #
 568 #   - Parser modules in different namespaces
 569 #
 570 #   - Parser modules in the SQL::Translator::Parser namespace that
 571 #     have any XS componenets will be installed in
 572 #     arch_lib/SQL/Translator.
 573 #
 574 # ----------------------------------------------------------------------
 575 sub list_parsers {
 576     return shift->_list("parser");
 577 }
 578
 579 # ----------------------------------------------------------------------
 580 # list_producers()
 581 #
 582 # See notes for list_parsers(), above; all the problems apply to
 583 # list_producers as well.
 584 # ----------------------------------------------------------------------
 585 sub list_producers {
 586     return shift->_list("producer");
 587 }
 588
 589
 590 # ======================================================================
 591 # Private Methods
 592 # ======================================================================
 593
 594 # ----------------------------------------------------------------------
 595 # _args($type, \%args);
 596 #
 597 # Gets or sets ${type}_args.  Called by parser_args and producer_args.
 598 # ----------------------------------------------------------------------
 599 sub _args {
 600     my $self = shift;
 601     my $type = shift;
 602     $type = "${type}_args" unless $type =~ /_args$/;
 603
 604     unless (defined $self->{$type} && isa($self->{$type}, 'HASH')) {
 605         $self->{$type} = { };
 606     }
 607
 608     if (@_) {
 609         # If the first argument is an explicit undef (remember, we
 610         # don't get here unless there is stuff in @_), then we clear
 611         # out the producer_args hash.
 612         if (! defined $_[0]) {
 613             shift @_;
 614             %{$self->{$type}} = ();
 615         }
 616
 617         my $args = isa($_[0], 'HASH') ? shift : { @_ };
 618         %{$self->{$type}} = (%{$self->{$type}}, %$args);
 619     }
 620
 621     $self->{$type};
 622 }
 623
 624 # ----------------------------------------------------------------------
 625 # Does the get/set work for parser and producer. e.g.
 626 # return $self->_tool({
 627 #   name => 'producer',
 628 #   path => "SQL::Translator::Producer",
 629 #   default_sub => "produce",
 630 # }, @_);
 631 # ----------------------------------------------------------------------
 632 sub _tool {
 633     my ($self,$args) = (shift, shift);
 634     my $name = $args->{name};
 635     return $self->{$name} unless @_; # get accessor
 636
 637     my $path = $args->{path};
 638     my $default_sub = $args->{default_sub};
 639     my $tool = shift;
 640
 641     # passed an anonymous subroutine reference
 642     if (isa($tool, 'CODE')) {
 643         $self->{$name} = $tool;
 644         $self->{"$name\_type"} = "CODE";
 645         $self->debug("Got $name: code ref\n");
 646     }
 647
 648     # Module name was passed directly
 649     # We try to load the name; if it doesn't load, there's a
 650     # possibility that it has a function name attached to it,
 651     # so we give it a go.
 652     else {
 653         $tool =~ s/-/::/g if $tool !~ /::/;
 654         my ($code,$sub);
 655         ($code,$sub) = _load_sub("$tool\::$default_sub", $path);
 656         unless ($code) {
 657             if ( __PACKAGE__->error =~ m/Can't find module/ ) {
 658                 # Mod not found so try sub
 659                 ($code,$sub) = _load_sub("$tool", $path) unless $code;
 660                 die "Can't load $name subroutine '$tool' : ".__PACKAGE__->error
 661                 unless $code;
 662             }
 663             else {
 664                 die "Can't load $name '$tool' : ".__PACKAGE__->error;
 665             }
 666         }
 667
 668         # get code reference and assign
 669         my (undef,$module,undef) = $sub =~ m/((.*)::)?(\w+)$/;
 670         $self->{$name} = $code;
 671         $self->{"$name\_type"} = $sub eq "CODE" ? "CODE" : $module;
 672         $self->debug("Got $name: $sub\n");
 673     }
 674
 675     # At this point, $self->{$name} contains a subroutine
 676     # reference that is ready to run
 677
 678     # Anything left?  If so, it's args
 679     my $meth = "$name\_args";
 680     $self->$meth(@_) if (@_);
 681
 682     return $self->{$name};
 683 }
 684
 685 # ----------------------------------------------------------------------
 686 # _list($type)
 687 # ----------------------------------------------------------------------
 688 sub _list {
 689     my $self   = shift;
 690     my $type   = shift || return ();
 691     my $uctype = ucfirst lc $type;
 692
 693     #
 694     # First find all the directories where SQL::Translator
 695     # parsers or producers (the "type") appear to live.
 696     #
 697     load("SQL::Translator::$uctype") or return ();
 698     my $path = catfile "SQL", "Translator", $uctype;
 699     my @dirs;
 700     for (@INC) {
 701         my $dir = catfile $_, $path;
 702         $self->debug("_list_${type}s searching $dir\n");
 703         next unless -d $dir;
 704         push @dirs, $dir;
 705     }
 706
 707     #
 708     # Now use File::File::find to look recursively in those
 709     # directories for all the *.pm files, then present them
 710     # with the slashes turned into dashes.
 711     #
 712     my %found;
 713     find(
 714         sub {
 715             if ( -f && m/\.pm$/ ) {
 716                 my $mod      =  $_;
 717                    $mod      =~ s/\.pm$//;
 718                 my $cur_dir  = $File::Find::dir;
 719                 my $base_dir = quotemeta catfile 'SQL', 'Translator', $uctype;
 720
 721                 #
 722                 # See if the current directory is below the base directory.
 723                 #
 724                 if ( $cur_dir =~ m/$base_dir(.*)/ ) {
 725                     $cur_dir = $1;
 726                     $cur_dir =~ s!^/!!;  # kill leading slash
 727                     $cur_dir =~ s!/!-!g; # turn other slashes into dashes
 728                 }
 729                 else {
 730                     $cur_dir = '';
 731                 }
 732
 733                 $found{ join '-', map { $_ || () } $cur_dir, $mod } = 1;
 734             }
 735         },
 736         @dirs
 737     );
 738
 739     return sort { lc $a cmp lc $b } keys %found;
 740 }
 741
 742 # ----------------------------------------------------------------------
 743 # load(MODULE [,PATH[,PATH]...])
 744 #
 745 # Loads a Perl module.  Short circuits if a module is already loaded.
 746 #
 747 # MODULE - is the name of the module to load.
 748 #
 749 # PATH - optional list of 'package paths' to look for the module in. e.g
 750 # If you called load('Super::Foo' => 'My', 'Other') it will
 751 # try to load the mod Super::Foo then My::Super::Foo then Other::Super::Foo.
 752 #
 753 # Returns package name of the module actually loaded or false and sets error.
 754 #
 755 # Note, you can't load a name from the root namespace (ie one without '::' in
 756 # it), therefore a single word name without a path fails.
 757 # ----------------------------------------------------------------------
 758 sub load {
 759     my $name = shift;
 760     my @path;
 761     push @path, "" if $name =~ /::/; # Empty path to check name on its own first
 762     push @path, @_ if @_;
 763
 764     foreach (@path) {
 765         my $module = $_ ? "$_\::$name" : $name;
 766         my $file = $module; $file =~ s[::][/]g; $file .= ".pm";
 767         __PACKAGE__->debug("Loading $name as $file\n");
 768         return $module if $INC{$file}; # Already loaded
 769
 770         eval { require $file };
 771         next if $@ =~ /Can't locate $file in \@INC/;
 772         eval { $module->import() } unless $@;
 773         return __PACKAGE__->error("Error loading $name as $module : $@")
 774         if $@ && $@ !~ /"SQL::Translator::Producer" is not exported/;
 775
 776         return $module; # Module loaded ok
 777     }
 778
 779     return __PACKAGE__->error("Can't find module $name. Path:".join(",",@path));
 780 }
 781
 782 # ----------------------------------------------------------------------
 783 # Load the sub name given (including package), optionally using a base package
 784 # path. Returns code ref and name of sub loaded, including its package.
 785 # (\&code, $sub) = load_sub( 'MySQL::produce', "SQL::Translator::Producer" );
 786 # (\&code, $sub) = load_sub( 'MySQL::produce', @path );
 787 # ----------------------------------------------------------------------
 788 sub _load_sub {
 789     my ($tool, @path) = @_;
 790
 791     my (undef,$module,$func_name) = $tool =~ m/((.*)::)?(\w+)$/;
 792     if ( my $module = load($module => @path) ) {
 793         my $sub = "$module\::$func_name";
 794         return wantarray ? ( \&{ $sub }, $sub ) : \&$sub;
 795     }
 796     return undef;
 797 }
 798
 799 # ----------------------------------------------------------------------
 800 sub format_table_name {
 801     return shift->_format_name('_format_table_name', @_);
 802 }
 803
 804 # ----------------------------------------------------------------------
 805 sub format_package_name {
 806     return shift->_format_name('_format_package_name', @_);
 807 }
 808
 809 # ----------------------------------------------------------------------
 810 sub format_fk_name {
 811     return shift->_format_name('_format_fk_name', @_);
 812 }
 813
 814 # ----------------------------------------------------------------------
 815 sub format_pk_name {
 816     return shift->_format_name('_format_pk_name', @_);
 817 }
 818
 819 # ----------------------------------------------------------------------
 820 # The other format_*_name methods rely on this one.  It optionally
 821 # accepts a subroutine ref as the first argument (or uses an identity
 822 # sub if one isn't provided or it doesn't already exist), and applies
 823 # it to the rest of the arguments (if any).
 824 # ----------------------------------------------------------------------
 825 sub _format_name {
 826     my $self = shift;
 827     my $field = shift;
 828     my @args = @_;
 829
 830     if (ref($args[0]) eq 'CODE') {
 831         $self->{$field} = shift @args;
 832     }
 833     elsif (! exists $self->{$field}) {
 834         $self->{$field} = sub { return shift };
 835     }
 836
 837     return @args ? $self->{$field}->(@args) : $self->{$field};
 838 }
 839
 840 # ----------------------------------------------------------------------
 841 # isa($ref, $type)
 842 #
 843 # Calls UNIVERSAL::isa($ref, $type).  I think UNIVERSAL::isa is ugly,
 844 # but I like function overhead.
 845 # ----------------------------------------------------------------------
 846 sub isa($$) {
 847     my ($ref, $type) = @_;
 848     return UNIVERSAL::isa($ref, $type);
 849 }
 850
 851 # ----------------------------------------------------------------------
 852 # version
 853 #
 854 # Returns the $VERSION of the main SQL::Translator package.
 855 # ----------------------------------------------------------------------
 856 sub version {
 857     my $self = shift;
 858     return $VERSION;
 859 }
 860
 861 # ----------------------------------------------------------------------
 862 sub validate {
 863     my ( $self, $arg ) = @_;
 864     if ( defined $arg ) {
 865         $self->{'validate'} = $arg ? 1 : 0;
 866     }
 867     return $self->{'validate'} || 0;
 868 }
 869
 870 1;
 871
 872 # ----------------------------------------------------------------------
 873 # Who killed the pork chops?
 874 # What price bananas?
 875 # Are you my Angel?
 876 # Allen Ginsberg
 877 # ----------------------------------------------------------------------
 878
 879 =pod
 880
 881 =head1 NAME
 882
 883 SQL::Translator - manipulate structured data definitions (SQL and more)
 884
 885 =head1 SYNOPSIS
 886
 887   use SQL::Translator;
 888
 889   my $translator          = SQL::Translator->new(
 890       # Print debug info
 891       debug               => 1,
 892       # Print Parse::RecDescent trace
 893       trace               => 0,
 894       # Don't include comments in output
 895       no_comments         => 0,
 896       # Print name mutations, conflicts
 897       show_warnings       => 0,
 898       # Add "drop table" statements
 899       add_drop_table      => 1,
 900       # to quote or not to quote, thats the question
 901       quote_table_names     => 1,
 902       quote_field_names     => 1,
 903       # Validate schema object
 904       validate            => 1,
 905       # Make all table names CAPS in producers which support this option
 906       format_table_name   => sub {my $tablename = shift; return uc($tablename)},
 907       # Null-op formatting, only here for documentation's sake
 908       format_package_name => sub {return shift},
 909       format_fk_name      => sub {return shift},
 910       format_pk_name      => sub {return shift},
 911   );
 912
 913   my $output     = $translator->translate(
 914       from       => 'MySQL',
 915       to         => 'Oracle',
 916       # Or an arrayref of filenames, i.e. [ $file1, $file2, $file3 ]
 917       filename   => $file,
 918   ) or die $translator->error;
 919
 920   print $output;
 921
 922 =head1 DESCRIPTION
 923
 924 This documentation covers the API for SQL::Translator.  For a more general
 925 discussion of how to use the modules and scripts, please see
 926 L<SQL::Translator::Manual>.
 927
 928 SQL::Translator is a group of Perl modules that converts
 929 vendor-specific SQL table definitions into other formats, such as
 930 other vendor-specific SQL, ER diagrams, documentation (POD and HTML),
 931 XML, and Class::DBI classes.  The main focus of SQL::Translator is
 932 SQL, but parsers exist for other structured data formats, including
 933 Excel spreadsheets and arbitrarily delimited text files.  Through the
 934 separation of the code into parsers and producers with an object model
 935 in between, it's possible to combine any parser with any producer, to
 936 plug in custom parsers or producers, or to manipulate the parsed data
 937 via the built-in object model.  Presently only the definition parts of
 938 SQL are handled (CREATE, ALTER), not the manipulation of data (INSERT,
 939 UPDATE, DELETE).
 940
 941 =head1 CONSTRUCTOR
 942
 943 The constructor is called C<new>, and accepts a optional hash of options.
 944 Valid options are:
 945
 946 =over 4
 947
 948 =item *
 949
 950 parser / from
 951
 952 =item *
 953
 954 parser_args
 955
 956 =item *
 957
 958 producer / to
 959
 960 =item *
 961
 962 producer_args
 963
 964 =item *
 965
 966 filters
 967
 968 =item *
 969
 970 filename / file
 971
 972 =item *
 973
 974 data
 975
 976 =item *
 977
 978 debug
 979
 980 =item *
 981
 982 add_drop_table
 983
 984 =item *
 985
 986 quote_table_names
 987
 988 =item *
 989
 990 quote_field_names
 991
 992 =item *
 993
 994 no_comments
 995
 996 =item *
 997
 998 trace
 999
1000 =item *
1001
1002 validate
1003
1004 =back
1005
1006 All options are, well, optional; these attributes can be set via
1007 instance methods.  Internally, they are; no (non-syntactical)
1008 advantage is gained by passing options to the constructor.
1009
1010 =head1 METHODS
1011
1012 =head2 add_drop_table
1013
1014 Toggles whether or not to add "DROP TABLE" statements just before the
1015 create definitions.
1016
1017 =head2 quote_table_names
1018
1019 Toggles whether or not to quote table names with " in DROP and CREATE
1020 statements. The default (true) is to quote them.
1021
1022 =head2 quote_field_names
1023
1024 Toggles whether or not to quote field names with " in most
1025 statements. The default (true), is to quote them.
1026
1027 =head2 no_comments
1028
1029 Toggles whether to print comments in the output.  Accepts a true or false
1030 value, returns the current value.
1031
1032 =head2 producer
1033
1034 The C<producer> method is an accessor/mutator, used to retrieve or
1035 define what subroutine is called to produce the output.  A subroutine
1036 defined as a producer will be invoked as a function (I<not a method>)
1037 and passed its container C<SQL::Translator> instance, which it should
1038 call the C<schema> method on, to get the C<SQL::Translator::Schema>
1039 generated by the parser.  It is expected that the function transform the
1040 schema structure to a string.  The C<SQL::Translator> instance is also useful
1041 for informational purposes; for example, the type of the parser can be
1042 retrieved using the C<parser_type> method, and the C<error> and
1043 C<debug> methods can be called when needed.
1044
1045 When defining a producer, one of several things can be passed in:  A
1046 module name (e.g., C<My::Groovy::Producer>), a module name relative to
1047 the C<SQL::Translator::Producer> namespace (e.g., C<MySQL>), a module
1048 name and function combination (C<My::Groovy::Producer::transmogrify>),
1049 or a reference to an anonymous subroutine.  If a full module name is
1050 passed in (for the purposes of this method, a string containing "::"
1051 is considered to be a module name), it is treated as a package, and a
1052 function called "produce" will be invoked: C<$modulename::produce>.
1053 If $modulename cannot be loaded, the final portion is stripped off and
1054 treated as a function.  In other words, if there is no file named
1055 F<My/Groovy/Producer/transmogrify.pm>, C<SQL::Translator> will attempt
1056 to load F<My/Groovy/Producer.pm> and use C<transmogrify> as the name of
1057 the function, instead of the default C<produce>.
1058
1059   my $tr = SQL::Translator->new;
1060
1061   # This will invoke My::Groovy::Producer::produce($tr, $data)
1062   $tr->producer("My::Groovy::Producer");
1063
1064   # This will invoke SQL::Translator::Producer::Sybase::produce($tr, $data)
1065   $tr->producer("Sybase");
1066
1067   # This will invoke My::Groovy::Producer::transmogrify($tr, $data),
1068   # assuming that My::Groovy::Producer::transmogrify is not a module
1069   # on disk.
1070   $tr->producer("My::Groovy::Producer::transmogrify");
1071
1072   # This will invoke the referenced subroutine directly, as
1073   # $subref->($tr, $data);
1074   $tr->producer(\&my_producer);
1075
1076 There is also a method named C<producer_type>, which is a string
1077 containing the classname to which the above C<produce> function
1078 belongs.  In the case of anonymous subroutines, this method returns
1079 the string "CODE".
1080
1081 Finally, there is a method named C<producer_args>, which is both an
1082 accessor and a mutator.  Arbitrary data may be stored in name => value
1083 pairs for the producer subroutine to access:
1084
1085   sub My::Random::producer {
1086       my ($tr, $data) = @_;
1087       my $pr_args = $tr->producer_args();
1088
1089       # $pr_args is a hashref.
1090
1091 Extra data passed to the C<producer> method is passed to
1092 C<producer_args>:
1093
1094   $tr->producer("xSV", delimiter => ',\s*');
1095
1096   # In SQL::Translator::Producer::xSV:
1097   my $args = $tr->producer_args;
1098   my $delimiter = $args->{'delimiter'}; # value is ,\s*
1099
1100 =head2 parser
1101
1102 The C<parser> method defines or retrieves a subroutine that will be
1103 called to perform the parsing.  The basic idea is the same as that of
1104 C<producer> (see above), except the default subroutine name is
1105 "parse", and will be invoked as C<$module_name::parse($tr, $data)>.
1106 Also, the parser subroutine will be passed a string containing the
1107 entirety of the data to be parsed.
1108
1109   # Invokes SQL::Translator::Parser::MySQL::parse()
1110   $tr->parser("MySQL");
1111
1112   # Invokes My::Groovy::Parser::parse()
1113   $tr->parser("My::Groovy::Parser");
1114
1115   # Invoke an anonymous subroutine directly
1116   $tr->parser(sub {
1117     my $dumper = Data::Dumper->new([ $_[1] ], [ "SQL" ]);
1118     $dumper->Purity(1)->Terse(1)->Deepcopy(1);
1119     return $dumper->Dump;
1120   });
1121
1122 There is also C<parser_type> and C<parser_args>, which perform
1123 analogously to C<producer_type> and C<producer_args>
1124
1125 =head2 filters
1126
1127 Set or retreive the filters to run over the schema during the
1128 translation, before the producer creates its output. Filters are sub
1129 routines called, in order, with the schema object to filter as the 1st
1130 arg and a hash of options (passed as a list) for the rest of the args.
1131 They are free to do whatever they want to the schema object, which will be
1132 handed to any following filters, then used by the producer.
1133
1134 Filters are set as an array, which gives the order they run in.
1135 Like parsers and producers, they can be defined by a module name, a
1136 module name relative to the SQL::Translator::Filter namespace, a module
1137 name and function name together or a reference to an anonymous subroutine.
1138 When using a module name a function called C<filter> will be invoked in
1139 that package to do the work.
1140
1141 To pass args to the filter set it as an array ref with the 1st value giving
1142 the filter (name or sub) and the rest its args. e.g.
1143
1144  $tr->filters(
1145      sub {
1146         my $schema = shift;
1147         # Do stuff to schema here!
1148      },
1149      DropFKeys,
1150      [ "Names", table => 'lc' ],
1151      [ "Foo",   foo => "bar", hello => "world" ],
1152      [ "Filter5" ],
1153  );
1154
1155 Although you normally set them in the constructor, which calls
1156 through to filters. i.e.
1157
1158   my $translator  = SQL::Translator->new(
1159       ...
1160       filters => [
1161           sub { ... },
1162           [ "Names", table => 'lc' ],
1163       ],
1164       ...
1165   );
1166
1167 See F<t/36-filters.t> for more examples.
1168
1169 Multiple set calls to filters are cumulative with new filters added to
1170 the end of the current list.
1171
1172 Returns the filters as a list of array refs, the 1st value being a
1173 reference to the filter sub and the rest its args.
1174
1175 =head2 show_warnings
1176
1177 Toggles whether to print warnings of name conflicts, identifier
1178 mutations, etc.  Probably only generated by producers to let the user
1179 know when something won't translate very smoothly (e.g., MySQL "enum"
1180 fields into Oracle).  Accepts a true or false value, returns the
1181 current value.
1182
1183 =head2 translate
1184
1185 The C<translate> method calls the subroutine referenced by the
1186 C<parser> data member, then calls any C<filters> and finally calls
1187 the C<producer> sub routine (these members are described above).
1188 It accepts as arguments a number of things, in key => value format,
1189 including (potentially) a parser and a producer (they are passed
1190 directly to the C<parser> and C<producer> methods).
1191
1192 Here is how the parameter list to C<translate> is parsed:
1193
1194 =over
1195
1196 =item *
1197
1198 1 argument means it's the data to be parsed; which could be a string
1199 (filename) or a reference to a scalar (a string stored in memory), or a
1200 reference to a hash, which is parsed as being more than one argument
1201 (see next section).
1202
1203   # Parse the file /path/to/datafile
1204   my $output = $tr->translate("/path/to/datafile");
1205
1206   # Parse the data contained in the string $data
1207   my $output = $tr->translate(\$data);
1208
1209 =item *
1210
1211 More than 1 argument means its a hash of things, and it might be
1212 setting a parser, producer, or datasource (this key is named
1213 "filename" or "file" if it's a file, or "data" for a SCALAR reference.
1214
1215   # As above, parse /path/to/datafile, but with different producers
1216   for my $prod ("MySQL", "XML", "Sybase") {
1217       print $tr->translate(
1218                 producer => $prod,
1219                 filename => "/path/to/datafile",
1220             );
1221   }
1222
1223   # The filename hash key could also be:
1224       datasource => \$data,
1225
1226 You get the idea.
1227
1228 =back
1229
1230 =head2 filename, data
1231
1232 Using the C<filename> method, the filename of the data to be parsed
1233 can be set. This method can be used in conjunction with the C<data>
1234 method, below.  If both the C<filename> and C<data> methods are
1235 invoked as mutators, the data set in the C<data> method is used.
1236
1237     $tr->filename("/my/data/files/create.sql");
1238
1239 or:
1240
1241     my $create_script = do {
1242         local $/;
1243         open CREATE, "/my/data/files/create.sql" or die $!;
1244         <CREATE>;
1245     };
1246     $tr->data(\$create_script);
1247
1248 C<filename> takes a string, which is interpreted as a filename.
1249 C<data> takes a reference to a string, which is used as the data to be
1250 parsed.  If a filename is set, then that file is opened and read when
1251 the C<translate> method is called, as long as the data instance
1252 variable is not set.
1253
1254 =head2 schema
1255
1256 Returns the SQL::Translator::Schema object.
1257
1258 =head2 trace
1259
1260 Turns on/off the tracing option of Parse::RecDescent.
1261
1262 =head2 validate
1263
1264 Whether or not to validate the schema object after parsing and before
1265 producing.
1266
1267 =head2 version
1268
1269 Returns the version of the SQL::Translator release.
1270
1271 =head1 AUTHORS
1272
1273 The following people have contributed to the SQLFairy project:
1274
1275 =over 4
1276
1277 =item * Mark Addison <grommit@users.sourceforge.net>
1278
1279 =item * Sam Angiuoli <angiuoli@users.sourceforge.net>
1280
1281 =item * Anders Nor Berle <berle@cpan.org>
1282
1283 =item * Dave Cash <dave@gnofn.org>
1284
1285 =item * Darren Chamberlain <dlc@users.sourceforge.net>
1286
1287 =item * Ken Y. Clark <kclark@cpan.org>
1288
1289 =item * Allen Day <allenday@users.sourceforge.net>
1290
1291 =item * Paul Harrington <phrrngtn@users.sourceforge.net>
1292
1293 =item * Mikey Melillo <mmelillo@users.sourceforge.net>
1294
1295 =item * Chris Mungall <cjm@fruitfly.org>
1296
1297 =item * Ross Smith II <rossta@users.sf.net>
1298
1299 =item * Gudmundur A. Thorisson <mummi@cshl.org>
1300
1301 =item * Chris To <christot@users.sourceforge.net>
1302
1303 =item * Jason Williams <smdwilliams@users.sourceforge.net>
1304
1305 =item * Ying Zhang <zyolive@yahoo.com>
1306
1307 =item * Daniel Ruoso <daniel@ruoso.com>
1308
1309 =item * Ryan D Johnson <ryan@innerfence.com>
1310
1311 =item * Jonathan Yu <frequency@cpan.org>
1312
1313 =back
1314
1315 If you would like to contribute to the project, you can send patches
1316 to the developers mailing list:
1317
1318     sqlfairy-developers@lists.sourceforge.net
1319
1320 Or send us a message (with your Sourceforge username) asking to be
1321 added to the project and what you'd like to contribute.
1322
1323
1324 =head1 COPYRIGHT
1325
1326 This program is free software; you can redistribute it and/or modify
1327 it under the terms of the GNU General Public License as published by
1328 the Free Software Foundation; version 2.
1329
1330 This program is distributed in the hope that it will be useful, but
1331 WITHOUT ANY WARRANTY; without even the implied warranty of
1332 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
1333 General Public License for more details.
1334
1335 You should have received a copy of the GNU General Public License
1336 along with this program; if not, write to the Free Software
1337 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
1338 USA
1339
1340 =head1 BUGS
1341
1342 Please use L<http://rt.cpan.org/> for reporting bugs.
1343
1344 =head1 PRAISE
1345
1346 If you find this module useful, please use
1347 L<http://cpanratings.perl.org/rate/?distribution=SQL-Translator> to rate it.
1348
1349 =head1 SEE ALSO
1350
1351 L<perl>,
1352 L<SQL::Translator::Parser>,
1353 L<SQL::Translator::Producer>,
1354 L<Parse::RecDescent>,
1355 L<GD>,
1356 L<GraphViz>,
1357 L<Text::RecordParser>,
1358 L<Class::DBI>,
1359 L<XML::Writer>.