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