lib/SQL/Translator.pm

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