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