lib/SQL/Translator.pm

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