lib/SQL/Translator.pm

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