lib/SQL/Translator.pm

   1 package SQL::Translator;
   2
   3 # ----------------------------------------------------------------------
   4 # $Id: Translator.pm,v 1.3.2.3 2002-03-18 20:35:51 dlc Exp $
   5 # ----------------------------------------------------------------------
   6 # Copyright (C) 2002 Ken Y. Clark <kycl4rk@users.sourceforge.net>,
   7 #                    darren chamberlain <darren@cpan.org>
   8 #
   9 # This program is free software; you can redistribute it and/or
  10 # modify it under the terms of the GNU General Public License as
  11 # published by the Free Software Foundation; version 2.
  12 #
  13 # This program is distributed in the hope that it will be useful, but
  14 # WITHOUT ANY WARRANTY; without even the implied warranty of
  15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  16 # General Public License for more details.
  17 #
  18 # You should have received a copy of the GNU General Public License
  19 # along with this program; if not, write to the Free Software
  20 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
  21 # 02111-1307  USA
  22 # -------------------------------------------------------------------
  23
  24 =head1 NAME
  25
  26 SQL::Translator - convert schema from one database to another
  27
  28 =head1 SYNOPSIS
  29
  30   use SQL::Translator;
  31   my $translator = SQL::Translator->new;
  32
  33   my $output = $translator->translate(
  34                       from     => "MySQL",
  35                       to       => "Oracle",
  36                       filename => $file,
  37                ) or die $translator->error;
  38   print $output;
  39
  40 =head1 DESCRIPTION
  41
  42 This module attempts to simplify the task of converting one database
  43 create syntax to another through the use of Parsers and Producers.
  44 The idea is that any Parser can be used with any Producer in the
  45 conversion process.  So, if you wanted PostgreSQL-to-Oracle, you would
  46 use the PostgreSQL parser and the Oracle producer.
  47
  48 Currently, the existing parsers use Parse::RecDescent, but this not
  49 a requirement, or even a recommendation.  New parser modules don't
  50 necessarily have to use Parse::RecDescent, as long as the module
  51 implements the appropriate API.  With this separation of code, it is
  52 hoped that developers will find it easy to add more database dialects
  53 by using what's written, writing only what they need, and then
  54 contributing their parsers or producers back to the project.
  55
  56 =cut
  57
  58 use strict;
  59 use vars qw($VERSION $DEFAULT_SUB $DEBUG);
  60 $VERSION = sprintf "%d.%02d", q$Revision: 1.3.2.3 $ =~ /(\d+)\.(\d+)/;
  61 $DEBUG = 1 unless defined $DEBUG;
  62
  63 # ----------------------------------------------------------------------
  64 # The default behavior is to "pass through" values (note that the
  65 # SQL::Translator instance is the first value ($_[0]), and the stuff
  66 # to be parsed is the second value ($_[1])
  67 # ----------------------------------------------------------------------
  68 $DEFAULT_SUB = sub { $_[1] } unless defined $DEFAULT_SUB;
  69
  70 *isa = \&UNIVERSAL::isa;
  71
  72 use Carp qw(carp);
  73
  74 =head1 CONSTRUCTOR
  75
  76 The constructor is called B<new>, and accepts a optional hash of options.
  77 Valid options are:
  78
  79 =over 4
  80
  81 =item parser (aka from)
  82
  83 =item producer (aka to)
  84
  85 =item filename
  86
  87 =back
  88
  89 All options are, well, optional; these attributes can be set via
  90 instance methods.  Internally, they are; no (non-syntactical)
  91 advantage is gained by passing options to the constructor.
  92
  93 =cut
  94
  95 # {{{ new
  96 # ----------------------------------------------------------------------
  97 # new([ARGS])
  98 #   The constructor.
  99 #
 100 #   new takes an optional hash of arguments.  These arguments may
 101 #   include a parser, specified with the keys "parser" or "from",
 102 #   and a producer, specified with the keys "producer" or "to".
 103 #
 104 #   The values that can be passed as the parser or producer are
 105 #   given directly to the parser or producer methods, respectively.
 106 #   See the appropriate method description below for details about
 107 #   what each expects/accepts.
 108 #
 109 #   TODO
 110 #     * Support passing an input (filename or string) as with
 111 #       translate
 112 # ----------------------------------------------------------------------
 113 sub new {
 114     my $class = shift;
 115     my $args  = isa($_[0], 'HASH') ? shift : { @_ };
 116     my $self  = bless { } => $class;
 117
 118     # ------------------------------------------------------------------
 119     # Set the parser and producer.
 120     #
 121     # If a 'parser' or 'from' parameter is passed in, use that as the
 122     # parser; if a 'producer' or 'to' parameter is passed in, use that
 123     # as the producer; both default to $DEFAULT_SUB.
 124     # ------------------------------------------------------------------
 125     $self->parser(  $args->{'parser'}   || $args->{'from'} || $DEFAULT_SUB);
 126     $self->producer($args->{'producer'} || $args->{'to'}   || $DEFAULT_SUB);
 127
 128     # ------------------------------------------------------------------
 129     # Clear the error
 130     # ------------------------------------------------------------------
 131     $self->error_out("");
 132
 133     return $self;
 134 }
 135 # }}}
 136
 137 =head1 METHODS
 138
 139 =head2 B<producer>
 140
 141 The B<producer> method is an accessor/mutator, used to retrieve or
 142 define what subroutine is called to produce the output.  A subroutine
 143 defined as a producer will be invoked as a function (not a method) and
 144 passed 2 parameters: its container SQL::Translator instance and a
 145 data structure.  It is expected that the function transform the data
 146 structure to a string.  The SQL::Transformer instance is provided for
 147 informational purposes; for example, the type of the parser can be
 148 retrieved using the B<parser_type> method, and the B<error> and
 149 B<debug> methods can be called when needed.
 150
 151 When defining a producer, one of several things can be passed
 152 in:  A module name (e.g., My::Groovy::Producer), a module name
 153 relative to the SQL::Translator::Producer namespace (e.g., MySQL), a
 154 module name and function combination (My::Groovy::Producer::transmogrify),
 155 or a reference to an anonymous subroutine.  If a full module name is
 156 passed in (for the purposes of this method, a string containing "::"
 157 is considered to be a module name), it is treated as a package, and a
 158 function called "produce" will be invoked: $modulename::produce.  If
 159 $modulename cannot be loaded, the final portion is stripped off and
 160 treated as a function.  In other words, if there is no file named
 161 My/Groovy/Producer/transmogrify.pm, SQL::Translator will attempt to load
 162 My/Groovy/Producer.pm and use transmogrify as the name of the function,
 163 instead of the default "produce".
 164
 165   my $tr = SQL::Translator->new;
 166
 167   # This will invoke My::Groovy::Producer::produce($tr, $data)
 168   $tr->producer("My::Groovy::Producer");
 169
 170   # This will invoke SQL::Translator::Producer::Sybase::produce($tr, $data)
 171   $tr->producer("Sybase");
 172
 173   # This will invoke My::Groovy::Producer::transmogrify($tr, $data),
 174   # assuming that My::Groovy::Producer::transmogrify is not a module
 175   # on disk.
 176   # $tr->producer("My::Groovy::Producer::transmogrify);
 177
 178   # This will invoke the referenced subroutine directly, as
 179   # $subref->($tr, $data);
 180   $tr->producer(\&my_producer);
 181
 182 There is also a method named B<producer_type>, which is a string
 183 containing the classname to which the above B<produce> function
 184 belongs.  In the case of anonymous subroutines, this method returns
 185 the string "CODE".
 186
 187 =cut
 188
 189 # {{{ producer and producer_type
 190 sub producer {
 191     my $self = shift;
 192
 193     # {{{ producer as a mutator
 194     if (@_) {
 195         my $producer = shift;
 196
 197         # {{{ Passed a module name (string containing "::")
 198         if ($producer =~ /::/) {
 199             my $func_name;
 200
 201             # {{{ Module name was passed directly
 202             # We try to load the name; if it doesn't load, there's
 203             # a possibility that it has a function name attached to
 204             # it.
 205             if (load($producer)) {
 206                 $func_name = "produce";
 207             } # }}}
 208
 209             # {{{ Module::function was passed
 210             else {
 211                 # Passed Module::Name::function; try to recover
 212                 my @func_parts = split /::/, $producer;
 213                 $func_name = pop @func_parts;
 214                 $producer = join "::", @func_parts;
 215
 216                 # If this doesn't work, then we have a legitimate
 217                 # problem.
 218                 load($producer) or die "Can't load $producer: $@";
 219             } # }}}
 220
 221             # {{{ get code reference and assign
 222             $self->{'producer'} = \&{ "$producer\::$func_name" };
 223             $self->{'producer_type'} = $producer;
 224             $self->debug("Got 'producer': $producer\::$func_name");
 225             # }}}
 226         } # }}}
 227
 228         # {{{ passed an anonymous subroutine reference
 229         elsif (isa($producer, 'CODE')) {
 230             $self->{'producer'} = $producer;
 231             $self->{'producer_type'} = "CODE";
 232             $self->debug("Got 'producer': code ref");
 233         } # }}}
 234
 235         # {{{ passed a string containing no "::"; relative package name
 236         else {
 237             my $Pp = sprintf "SQL::Translator::Producer::$producer";
 238             load($Pp) or die "Can't load $Pp: $@";
 239             $self->{'producer'} = \&{ "$Pp\::produce" };
 240             $self->{'producer_type'} = $Pp;
 241             $self->debug("Got producer: $Pp");
 242         } # }}}
 243
 244         # At this point, $self->{'producer'} contains a subroutine
 245         # reference that is ready to run
 246     } # }}}
 247
 248     return $self->{'producer'};
 249 };
 250
 251 sub producer_type { $_[0]->{'producer_type'} }
 252 # }}}
 253
 254 =head2 B<parser>
 255
 256 The B<parser> method defines or retrieves a subroutine that will be
 257 called to perform the parsing.  The basic idea is the same as that of
 258 B<producer> (see above), except the default subroutine name is
 259 "parse", and will be invoked as $module_name::parse($tr, $data).
 260 Also, the parser subroutine will be passed a string containing the
 261 entirety of the data to be parsed (or possibly a reference to a string?).
 262
 263   # Invokes SQL::Translator::Parser::MySQL::parse()
 264   $tr->parser("MySQL");
 265
 266   # Invokes My::Groovy::Parser::parse()
 267   $tr->parser("My::Groovy::Parser");
 268
 269   # Invoke an anonymous subroutine directly
 270   $tr->parser(sub {
 271     my $dumper = Data::Dumper->new([ $_[1] ], [ "SQL" ]);
 272     $dumper->Purity(1)->Terse(1)->Deepcopy(1);
 273     return $dumper->Dump;
 274   });
 275
 276 =cut
 277
 278 # {{{ parser and parser_type
 279 sub parser {
 280     my $self = shift;
 281
 282     # {{{ parser as a mutator
 283     if (@_) {
 284         my $parser = shift;
 285
 286         # {{{ Passed a module name (string containing "::")
 287         if ($parser =~ /::/) {
 288             my $func_name;
 289
 290             # {{{ Module name was passed directly
 291             # We try to load the name; if it doesn't load, there's
 292             # a possibility that it has a function name attached to
 293             # it.
 294             if (load($parser)) {
 295                 $func_name = "parse";
 296             } # }}}
 297
 298             # {{{ Module::function was passed
 299             else {
 300                 # Passed Module::Name::function; try to recover
 301                 my @func_parts = split /::/, $parser;
 302                 $func_name = pop @func_parts;
 303                 $parser = join "::", @func_parts;
 304
 305                 # If this doesn't work, then we have a legitimate
 306                 # problem.
 307                 load($parser) or die "Can't load $parser: $@";
 308             } # }}}
 309
 310             # {{{ get code reference and assign
 311             $self->{'parser'} = \&{ "$parser\::$func_name" };
 312             $self->{'parser_type'} = $parser;
 313             $self->debug("Got parser: $parser\::$func_name");
 314             # }}}
 315         } # }}}
 316
 317         # {{{ passed an anonymous subroutine reference
 318         elsif (isa($parser, 'CODE')) {
 319             $self->{'parser'} = $parser;
 320             $self->{'parser_type'} = "CODE";
 321             $self->debug("Got 'parser': code ref");
 322         } # }}}
 323
 324         # {{{ passed a string containing no "::"; relative package name
 325         else {
 326             my $Pp = sprintf "SQL::Translator::Parser::$parser";
 327             load($Pp) or die "Can't load $Pp: $@";
 328             $self->{'parser'} = \&{ "$Pp\::parse" };
 329             $self->{'parser_type'} = $Pp;
 330             $self->debug("Got parser: $Pp");
 331         } # }}}
 332
 333         # At this point, $self->{'parser'} contains a subroutine
 334         # reference that is ready to run
 335     } # }}}
 336
 337
 338     return $self->{'parser'};
 339 }
 340
 341 sub parser_type { $_[0]->{'parser_type'} }
 342 # }}}
 343
 344 =head2 B<translate>
 345
 346 The B<translate> method calls the subroutines referenced by the
 347 B<parser> and B<producer> data members (described above).  It accepts
 348 as arguments a number of things, in key => value format, including
 349 (potentially) a parser and a producer (they are passed directly to the
 350 B<parser> and B<producer> methods).
 351
 352 Here is how the parameter list to B<translate> is parsed:
 353
 354 =over
 355
 356 =item *
 357
 358 1 argument means it's the data to be parsed; which could be a string
 359 (filename) or a refernce to a scalar (a string stored in memory), or a
 360 reference to a hash, which is parsed as being more than one argument
 361 (see next section).
 362
 363   # Parse the file /path/to/datafile
 364   my $output = $tr->translate("/path/to/datafile");
 365
 366   # Parse the data contained in the string $data
 367   my $output = $tr->translate(\$data);
 368
 369 =item *
 370
 371 More than 1 argument means its a hash of things, and it might be
 372 setting a parser, producer, or datasource (this key is named
 373 "filename" or "file" if it's a file, or "data" for a SCALAR reference.
 374
 375   # As above, parse /path/to/datafile, but with different producers
 376   for my $prod ("MySQL", "XML", "Sybase") {
 377       print $tr->translate(
 378                 producer => $prod,
 379                 filename => "/path/to/datafile",
 380             );
 381   }
 382
 383   # The filename hash key could also be:
 384       datasource => \$data,
 385
 386 You get the idea.
 387
 388 =back
 389
 390 =cut
 391
 392 # {{{ translate
 393 sub translate {
 394     my $self = shift;
 395     my ($args, $parser, $producer);
 396
 397     if (@_ == 1) {
 398         if (isa($_[0], 'HASH')) {
 399             # Passed a hashref
 400             $self->debug("translate: Got a hashref");
 401             $args = $_[0];
 402         }
 403         elsif (isa($_[0], 'SCALAR')) {
 404             # passed a ref to a string; deref it
 405             $self->debug("translate: Got a SCALAR reference (string)");
 406             $args = { data => ${$_[0]} };
 407         }
 408         elsif (! ref $_[0]) {
 409             # Not a ref, it's a filename
 410             $self->debug("translate: Got a filename");
 411             $args = { filename => $_[0] };
 412         }
 413         else {
 414             # We're not impressed.  Take your empty string and leave.
 415             return "";
 416         }
 417     }
 418     else {
 419         # You must pass in a hash, or you get nothing.
 420         return "" if @_ % 2;
 421         $args = { @_ };
 422     }
 423
 424     if ((defined $args->{'filename'} || defined $args->{'file'}) &&
 425          not $args->{'data'}) {
 426         local *FH;
 427         local $/;
 428
 429         open FH, $args->{'filename'}
 430             or die "Can't open $args->{'filename'} for reading: $!";
 431         $args->{'data'} = <FH>;
 432         close FH or die "Can't close $args->{'filename'}: $!";
 433     }
 434
 435     #
 436     # Last chance to bail out; if there's nothing in the data
 437     # key of %args, back out.
 438     #
 439     return "" unless defined $args->{'data'};
 440
 441     #
 442     # Local reference to the parser subroutine
 443     #
 444     if ($parser = ($args->{'parser'} || $args->{'from'})) {
 445         $self->parser($parser);
 446     } else {
 447         $parser = $self->parser;
 448     }
 449
 450     #
 451     # Local reference to the producer subroutine
 452     #
 453     if ($producer = ($args->{'producer'} || $args->{'to'})) {
 454         $self->producer($producer);
 455     } else {
 456         $producer = $self->producer;
 457     }
 458
 459     #
 460     # Execute the parser, then execute the producer with that output
 461     #
 462     return $producer->($self, $parser->($self, $args->{'data'}));
 463 }
 464 # }}}
 465
 466 =head2 B<error>
 467
 468 The error method returns the last error.
 469
 470 =cut
 471
 472 # {{{ error
 473 #-----------------------------------------------------
 474 sub error {
 475 #
 476 # Return the last error.
 477 #
 478     return shift()->{'error'} || '';
 479 }
 480 # }}}
 481
 482 =head2 B<error_out>
 483
 484 Record the error and return undef.  The error can be retrieved by
 485 calling programs using $tr->error.
 486
 487 For Parser or Producer writers, primarily.
 488
 489 =cut
 490
 491 # {{{ error_out
 492 sub error_out {
 493     my $self = shift;
 494     if ( my $error = shift ) {
 495         $self->{'error'} = $error;
 496     }
 497     return;
 498 }
 499 # }}}
 500
 501 =head2 B<debug>
 502
 503 If the global variable $SQL::Translator::DEBUG is set to a true value,
 504 then calls to $tr->debug($msg) will be carped to STDERR.  If $DEBUG is
 505 not set, then this method does nothing.
 506
 507 =cut
 508
 509 # {{{ debug
 510 sub debug {
 511     my $self = shift;
 512     carp @_ if ($DEBUG);
 513 }
 514 # }}}
 515
 516 # {{{ load
 517 sub load {
 518     my $module = do { my $m = shift; $m =~ s[::][/]g; "$m.pm" };
 519     return 1 if $INC{$module};
 520
 521     eval { require $module };
 522
 523     return if ($@);
 524     return 1;
 525 }
 526 # }}}
 527
 528 1;
 529
 530 __END__
 531 #-----------------------------------------------------
 532 # Rescue the drowning and tie your shoestrings.
 533 # Henry David Thoreau
 534 #-----------------------------------------------------
 535
 536 =head1 AUTHOR
 537
 538 Ken Y. Clark, E<lt>kclark@logsoft.comE<gt>,
 539 darren chamberlain E<lt>darren@cpan.orgE<gt>
 540
 541 =head1 COPYRIGHT
 542
 543 This program is free software; you can redistribute it and/or modify
 544 it under the terms of the GNU General Public License as published by
 545 the Free Software Foundation; version 2.
 546
 547 This program is distributed in the hope that it will be useful, but
 548 WITHOUT ANY WARRANTY; without even the implied warranty of
 549 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 550 General Public License for more details.
 551
 552 You should have received a copy of the GNU General Public License
 553 along with this program; if not, write to the Free Software
 554 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
 555 USA
 556
 557 =head1 SEE ALSO
 558
 559 L<perl>, L<Parse::RecDescent>
 560
 561 =cut