lib/SQL/Translator.pm

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