lib/SQL/Translator.pm

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