lib/SQL/Translator.pm

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