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