lib/SQL/Translator.pm

   1 package SQL::Translator;
   2
   3 #-----------------------------------------------------
   4 # $Id: Translator.pm,v 1.3.2.1 2002-03-07 14:14:48 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   my $output     =  $translator->translate(
  33       parser     => 'mysql',
  34       producer   => 'oracle',
  35       file       => $file,
  36   ) or die $translator->error;
  37   print $output;
  38
  39 =head1 DESCRIPTION
  40
  41 This module attempts to simplify the task of converting one database
  42 create syntax to another through the use of Parsers and Producers.
  43 The idea is that any Parser can be used with any Producer in the
  44 conversion process.  So, if you wanted PostgreSQL-to-Oracle, you could
  45 just write the PostgreSQL parser and use an existing Oracle producer.
  46
  47 Currently, the existing parsers use Parse::RecDescent, and the
  48 producers are just printing formatted output of the parsed data
  49 structure.  New parsers don't necessarily have to use
  50 Parse::RecDescent, however, as long as the data structure conforms to
  51 what the producers are expecting.  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.1 $ =~ /(\d+)\.(\d+)/;
  61 $DEBUG = 1 unless defined $DEBUG;
  62
  63 $DEFAULT_SUB = sub { $_[0] } unless defined $DEFAULT_SUB;
  64 *isa = \&UNIVERSAL::isa;
  65
  66 =head1 CONSTRUCTOR
  67
  68 The constructor is called B<new>, and accepts a hash of options.
  69 Valid options are:
  70
  71 =over 4
  72
  73 =item parser (aka from)
  74
  75 =item producer (aka to)
  76
  77 =item filename
  78
  79 =back
  80
  81 All options are, well, optional; these attributes can be set via
  82 instance methods.
  83
  84 =cut
  85
  86 # {{{ new
  87
  88 sub new {
  89     my $class = shift;
  90     my $args  = isa($_[0], 'HASH') ? shift : { @_ };
  91     my $self  = bless { } => $class;
  92
  93     #
  94     # Set the parser and producer.  If a 'parser' or 'from' parameter
  95     # is passed in, use that as the parser; if a 'producer' or 'to'
  96     # parameter is passed in, use that as the producer; both default
  97     # to $DEFAULT_SUB.
  98     #
  99     $self->parser(  $args->{'parser'}   || $args->{'from'} || $DEFAULT_SUB);
 100     $self->producer($args->{'producer'} || $args->{'to'}   || $DEFAULT_SUB);
 101
 102     #
 103     # Clear the error
 104     #
 105     $self->error_out("");
 106
 107     return $self;
 108 }
 109 # }}}
 110
 111 =head1 METHODS
 112
 113
 114 =head2 B<producer>
 115
 116 The B<producer> method is an accessor/mutator, used to retrieve or
 117 define what subroutine is called to produce the output.  A subroutine
 118 defined as a producer subroutine will be invoked as a function (not a
 119 method) and passed a data structure as its only argument.  It is
 120 expected that the function transform the data structure to the output
 121 format, and return a string.
 122
 123 When defining a producer, one of three things can be passed
 124 in:  A full module name (e.g., My::Groovy::Parser), a module name
 125 relative to the SQL::Translator::Producer namespace (e.g., MySQL), or
 126 a reference to an anonymous subroutine.  If a full module name is
 127 passed in, it is treated as a package, and a function called
 128 "transform" will be invoked as $modulename::transform.
 129
 130   my $tr = SQL::Translator->new;
 131
 132   # This will invoke My::Groovy::Producer::transform($data)
 133   $tr->producer("My::Groovy::Producer");
 134
 135   # This will invoke SQL::Translator::Producer::Sybase::transform($data)
 136   $tr->producer("Sybase");
 137
 138   # This will inoke the referenced subroutine directly
 139   $tr->producer(\&my_producer);
 140
 141 =cut
 142 # TODO Make mod_perl-like assumptions about the name being passed in:
 143 # try to load the module; if that fails, pop off the last piece
 144 # (everything after the last ::) and try to load that; if that loads,
 145 # use the popped off piece as the function name, and not transform.
 146
 147 # {{{ producer
 148 sub producer {
 149     my $self = shift;
 150     if (@_) {
 151         my $producer = shift;
 152         if ($producer =~ /::/) {
 153             load($producer) or die "Can't load $producer: $@";
 154             $self->{'producer'} = \&{ "$producer\::'producer'" };
 155             $self->debug("Got 'producer': $producer\::'producer'");
 156         } elsif (isa($producer, 'CODE')) {
 157             $self->{'producer'} = $producer;
 158             $self->debug("Got 'producer': code ref");
 159         } else {
 160             my $Pp = sprintf "SQL::Translator::Producer::$producer";
 161             load($Pp) or die "Can't load $Pp: $@";
 162             $self->{'producer'} = \&{ "$Pp\::translate" };
 163             $self->debug("Got producer: $Pp");
 164         }
 165         # At this point, $self->{'producer'} contains a subroutine
 166         # reference that is ready to run!
 167     }
 168     return $self->{'producer'};
 169 };
 170 # }}}
 171
 172 =head2 B<parser>
 173
 174 The B<parser> method defines or retrieves a subroutine that will be
 175 called to perform the parsing.  The basic idea is the same as that of
 176 B<producer> (see above), except the default subroutine name is
 177 "parse", and will be invoked as $module_name::parse.  Also, the parser
 178 subroutine will be passed a string containing the entirety of the data
 179 to be parsed.
 180
 181   # Invokes SQL::Translator::Parser::MySQL::parse()
 182   $tr->parser("MySQL");
 183
 184   # Invokes My::Groovy::Parser::parse()
 185   $tr->parser("My::Groovy::Parser");
 186
 187   # Invoke an anonymous subroutine directly
 188   $tr->parser(sub {
 189     my $dumper = Data::Dumper->new([ $_[0] ], [ "SQL" ]);
 190     $dumper->Purity(1)->Terse(1)->Deepcopy(1);
 191     return $dumper->Dump;
 192   });
 193
 194 =cut
 195
 196 # {{{ parser
 197 sub parser {
 198     my $self = shift;
 199     if (@_) {
 200         my $parser = shift;
 201         if ($parser =~ /::/) {
 202             load($parser) or die "Can't load $parser: $@";
 203             $self->{'parser'} = \&{ "$parser\::parse" };
 204             $self->debug("Got parser: $parser\::parse");
 205         } elsif (isa($parser, 'CODE')) {
 206             $self->{'parser'} = $parser;
 207             $self->debug("Got parser: code ref");
 208         } else {
 209             my $Pp = "SQL::Translator::Parser::$parser";
 210             load($Pp) or die "Can't load $Pp: $@";
 211             $self->{'parser'} = \&{ "$Pp\::parse" };
 212             $self->debug("Got parser: $Pp");
 213         }
 214         # At this point, $self->{$pp} contains a subroutine
 215         # reference that is ready to run!
 216     }
 217     return $self->{'parser'};
 218 }
 219 # }}}
 220
 221 =head2 B<translate>
 222
 223 The B<translate> method calls the subroutines referenced by the
 224 B<parser> and B<producer> data members (described above).  It accepts
 225 as arguments a number of things, in key => value format, including
 226 (potentially) a parser and a producer (they are passed directly to the
 227 B<parser> and B<producer> methods).
 228
 229 Here is how the parameter list to B<translate> is parsed:
 230
 231 =over
 232
 233 =item *
 234
 235 1 argument means it's the data to be parsed; which could be a string
 236 (filename), a reference to a GLOB (filehandle from which to read a
 237 string), a refernce to a scalar (a string stored in memory), or a
 238 reference to a hash (which means the same thing as below).
 239
 240   # Parse the file /path/to/datafile
 241   my $output = $tr->translate("/path/to/datafile");
 242
 243   # The same thing:
 244   my $fh = IO::File->new("/path/to/datafile");
 245   my $output = $tr->translate($fh);
 246
 247   # Again, the same thing:
 248   my $fh = IO::File->new("/path/to/datafile");
 249   my $data = { local $/; <$fh> };
 250   my $output = $tr->translate(\$data);
 251
 252 =item *
 253
 254 > 1 argument means its a hash of things, and it might be setting a
 255 parser, producer, or datasource (this key is named "filename" or
 256 "file" if it's a file, or "data" for a GLOB or SCALAR reference).
 257
 258   # As above, parse /path/to/datafile, but with different producers
 259   for my $prod ("MySQL", "XML", "Sybase") {
 260       print $tr->translate(
 261                 producer => $prod,
 262                 filename => "/path/to/datafile",
 263             );
 264   }
 265
 266   # The filename hash key could also be:
 267       datasource => $fh,
 268
 269   # or
 270       datasource => \$data,
 271
 272 You get the idea.
 273
 274 =back
 275
 276 =cut
 277
 278 # {{{ translate
 279 sub translate {
 280     my $self = shift;
 281     my ($args, $parser, $producer);
 282
 283     if (@_ == 1) {
 284         if (isa($_[0], 'HASH')) {
 285             # Passed a hashref
 286             $args = $_[0];
 287         }
 288         elsif (isa($_[0], 'GLOB')) {
 289             # passed a filehandle; slurp it
 290             local $/;
 291             $args = { data => <$_[0]> };
 292         }
 293         elsif (isa($_[0], 'SCALAR')) {
 294             # passed a ref to a string; deref it
 295             $args = { data => ${$_[0]} };
 296         }
 297         else {
 298             # Not a ref, it's a filename
 299             $args = { filename => $_[0] };
 300         }
 301     }
 302     else {
 303         # Should we check if @_ % 2, or just eat the errors if they occur?
 304         $args = { @_ };
 305     }
 306
 307     if ((defined $args->{'filename'} ||
 308          defined $args->{'file'}   ) && not $args->{'data'}) {
 309         local *FH;
 310         local $/;
 311
 312         open FH, $args->{'filename'} or die $!;
 313         $args->{'data'} = <FH>;
 314         close FH or die $!;
 315     }
 316
 317     #
 318     # Last chance to bail out; if there's nothing in the data
 319     # key of %args, back out.
 320     #
 321     return unless defined $args->{'data'};
 322
 323     #
 324     # Local reference to the parser subroutine
 325     #
 326     if ($parser = ($args->{'parser'} || $args->{'from'})) {
 327         $self->parser($parser);
 328     } else {
 329         $parser = $self->parser;
 330     }
 331
 332     #
 333     # Local reference to the producer subroutine
 334     #
 335     if ($producer = ($args->{'producer'} || $args->{'to'})) {
 336         $self->producer($producer);
 337     } else {
 338         $producer = $self->producer;
 339     }
 340
 341     #
 342     # Execute the parser, then execute the producer with that output
 343     #
 344     my $translated = $parser->($args->{'data'});
 345
 346     return $producer->($translated);
 347 }
 348 # }}}
 349
 350 =head2 B<error>
 351
 352 The error method returns the last error.
 353
 354 =cut
 355
 356 # {{{ error
 357 #-----------------------------------------------------
 358 sub error {
 359 #
 360 # Return the last error.
 361 #
 362     return shift()->{'error'} || '';
 363 }
 364 # }}}
 365
 366 =head2 B<error_out>
 367
 368 Record the error and return undef.  The error can be retrieved by
 369 calling programs using $tr->error.
 370
 371 For Parser or Producer writers, primarily.
 372
 373 =cut
 374
 375 # {{{ error_out
 376 sub error_out {
 377     my $self = shift;
 378     if ( my $error = shift ) {
 379         $self->{'error'} = $error;
 380     }
 381     return;
 382 }
 383 # }}}
 384
 385 =head2 B<debug>
 386
 387 If the global variable $SQL::Translator::DEBUG is set to a true value,
 388 then calls to $tr->debug($msg) will be carped to STDERR.  If $DEBUG is
 389 not set, then this method does nothing.
 390
 391 =cut
 392
 393 # {{{ debug
 394 use Carp qw(carp);
 395 sub debug {
 396     my $self = shift;
 397     carp @_ if ($DEBUG);
 398 }
 399 # }}}
 400
 401 # {{{ load
 402 sub load {
 403     my $module = do { my $m = shift; $m =~ s[::][/]g; "$m.pm" };
 404     return 1 if $INC{$module};
 405
 406     eval { require $module };
 407
 408     return if ($@);
 409     return 1;
 410 }
 411 # }}}
 412
 413 1;
 414
 415 __END__
 416 #-----------------------------------------------------
 417 # Rescue the drowning and tie your shoestrings.
 418 # Henry David Thoreau
 419 #-----------------------------------------------------
 420
 421 =head1 AUTHOR
 422
 423 Ken Y. Clark, E<lt>kclark@logsoft.comE<gt>,
 424 darren chamberlain E<lt>darren@cpan.orgE<gt>
 425
 426 =head1 COPYRIGHT
 427
 428 This program is free software; you can redistribute it and/or modify
 429 it under the terms of the GNU General Public License as published by
 430 the Free Software Foundation; version 2.
 431
 432 This program is distributed in the hope that it will be useful, but
 433 WITHOUT ANY WARRANTY; without even the implied warranty of
 434 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 435 General Public License for more details.
 436
 437 You should have received a copy of the GNU General Public License
 438 along with this program; if not, write to the Free Software
 439 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
 440 USA
 441
 442 =head1 SEE ALSO
 443
 444 L<perl>, L<Parse::RecDescent>
 445
 446 =cut