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