1package SQL::Translator; 2 3use Moo; 4our ( $DEFAULT_SUB, $DEBUG, $ERROR ); 5 6our $VERSION = '1.62'; 7$VERSION =~ tr/_//d; 8$DEBUG = 0 unless defined $DEBUG; 9$ERROR = ""; 10 11use Carp qw(carp croak); 12 13use Data::Dumper; 14use File::Find; 15use File::Spec::Functions qw(catfile); 16use File::Basename qw(dirname); 17use IO::Dir; 18use Sub::Quote qw(quote_sub); 19use SQL::Translator::Producer; 20use SQL::Translator::Schema; 21use SQL::Translator::Utils qw(throw ex2err carp_ro normalize_quote_options); 22 23$DEFAULT_SUB = sub { $_[0]->schema } unless defined $DEFAULT_SUB; 24 25with qw( 26 SQL::Translator::Role::Debug 27 SQL::Translator::Role::Error 28 SQL::Translator::Role::BuildArgs 29); 30 31around BUILDARGS => sub { 32 my $orig = shift; 33 my $self = shift; 34 my $config = $self->$orig(@_); 35 36 # If a 'parser' or 'from' parameter is passed in, use that as the 37 # parser; if a 'producer' or 'to' parameter is passed in, use that 38 # as the producer; both default to $DEFAULT_SUB. 39 $config->{parser} ||= $config->{from} if defined $config->{from}; 40 $config->{producer} ||= $config->{to} if defined $config->{to}; 41 42 $config->{filename} ||= $config->{file} if defined $config->{file}; 43 44 my $quote = normalize_quote_options($config); 45 $config->{quote_identifiers} = $quote if defined $quote; 46 47 return $config; 48}; 49 50sub BUILD { 51 my ($self) = @_; 52 # Make sure all the tool-related stuff is set up 53 foreach my $tool (qw(producer parser)) { 54 $self->$tool($self->$tool); 55 } 56} 57 58has $_ => ( 59 is => 'rw', 60 default => quote_sub(q{ 0 }), 61 coerce => quote_sub(q{ $_[0] ? 1 : 0 }), 62) foreach qw(add_drop_table no_comments show_warnings trace validate); 63 64# quote_identifiers is on by default, use a 0-but-true as indicator 65# so we can allow individual producers to change the default 66has quote_identifiers => ( 67 is => 'rw', 68 default => quote_sub(q{ '0E0' }), 69 coerce => quote_sub(q{ $_[0] || 0 }), 70); 71 72sub quote_table_names { 73 (@_ > 1 and ($_[1] xor $_[0]->quote_identifiers) ) 74 ? croak 'Using quote_table_names as a setter is no longer supported' 75 : $_[0]->quote_identifiers; 76} 77 78sub quote_field_names { 79 (@_ > 1 and ($_[1] xor $_[0]->quote_identifiers) ) 80 ? croak 'Using quote_field_names as a setter is no longer supported' 81 : $_[0]->quote_identifiers; 82} 83 84after quote_identifiers => sub { 85 if (@_ > 1) { 86 # synchronize for old code reaching directly into guts 87 $_[0]->{quote_table_names} 88 = $_[0]->{quote_field_names} 89 = $_[1] ? 1 : 0; 90 } 91}; 92 93has producer => ( is => 'rw', default => sub { $DEFAULT_SUB } ); 94 95around producer => sub { 96 my $orig = shift; 97 shift->_tool({ 98 orig => $orig, 99 name => 'producer', 100 path => "SQL::Translator::Producer", 101 default_sub => "produce", 102 }, @_); 103}; 104 105has producer_type => ( is => 'rwp', init_arg => undef ); 106 107around producer_type => carp_ro('producer_type'); 108 109has producer_args => ( is => 'rw', default => quote_sub(q{ +{} }) ); 110 111around producer_args => sub { 112 my $orig = shift; 113 shift->_args($orig, @_); 114}; 115 116has parser => ( is => 'rw', default => sub { $DEFAULT_SUB } ); 117 118around parser => sub { 119 my $orig = shift; 120 shift->_tool({ 121 orig => $orig, 122 name => 'parser', 123 path => "SQL::Translator::Parser", 124 default_sub => "parse", 125 }, @_); 126}; 127 128has parser_type => ( is => 'rwp', init_arg => undef ); 129 130around parser_type => carp_ro('parser_type'); 131 132has parser_args => ( is => 'rw', default => quote_sub(q{ +{} }) ); 133 134around parser_args => sub { 135 my $orig = shift; 136 shift->_args($orig, @_); 137}; 138 139has filters => ( 140 is => 'rw', 141 default => quote_sub(q{ [] }), 142 coerce => sub { 143 my @filters; 144 # Set. Convert args to list of [\&code,@args] 145 foreach (@{$_[0]||[]}) { 146 my ($filt,@args) = ref($_) eq "ARRAY" ? @$_ : $_; 147 if ( isa($filt,"CODE") ) { 148 push @filters, [$filt,@args]; 149 next; 150 } 151 else { 152 __PACKAGE__->debug("Adding $filt filter. Args:".Dumper(\@args)."\n") if __PACKAGE__->debugging; 153 $filt = _load_sub("$filt\::filter", "SQL::Translator::Filter") 154 || throw(__PACKAGE__->error); 155 push @filters, [$filt,@args]; 156 } 157 } 158 return \@filters; 159 }, 160); 161 162around filters => sub { 163 my $orig = shift; 164 my $self = shift; 165 return @{$self->$orig([@{$self->$orig}, @_])} if @_; 166 return @{$self->$orig}; 167}; 168 169has filename => ( 170 is => 'rw', 171 isa => sub { 172 foreach my $filename (ref($_[0]) eq 'ARRAY' ? @{$_[0]} : $_[0]) { 173 if (-d $filename) { 174 throw("Cannot use directory '$filename' as input source"); 175 } 176 elsif (not -f _ && -r _) { 177 throw("Cannot use '$filename' as input source: ". 178 "file does not exist or is not readable."); 179 } 180 } 181 }, 182); 183 184around filename => \&ex2err; 185 186has data => ( 187 is => 'rw', 188 builder => 1, 189 lazy => 1, 190 coerce => sub { 191 # Set $self->data based on what was passed in. We will 192 # accept a number of things; do our best to get it right. 193 my $data = shift; 194 if (isa($data, 'ARRAY')) { 195 $data = join '', @$data; 196 } 197 elsif (isa($data, 'GLOB')) { 198 seek ($data, 0, 0) if eof ($data); 199 local $/; 200 $data = <$data>; 201 } 202 return isa($data, 'SCALAR') ? $data : \$data; 203 }, 204); 205 206around data => sub { 207 my $orig = shift; 208 my $self = shift; 209 210 if (@_ > 1 && !ref $_[0]) { 211 return $self->$orig(\join('', @_)); 212 } 213 elsif (@_) { 214 return $self->$orig(@_); 215 } 216 return ex2err($orig, $self); 217}; 218 219sub _build_data { 220 my $self = shift; 221 # If we have a filename but no data yet, populate. 222 if (my $filename = $self->filename) { 223 $self->debug("Opening '$filename' to get contents.\n"); 224 local $/; 225 my $data; 226 227 my @files = ref($filename) eq 'ARRAY' ? @$filename : ($filename); 228 229 foreach my $file (@files) { 230 open my $fh, '<', $file 231 or throw("Can't read file '$file': $!"); 232 233 $data .= <$fh>; 234 235 close $fh or throw("Can't close file '$file': $!"); 236 } 237 238 return \$data; 239 } 240} 241 242has schema => ( 243 is => 'lazy', 244 init_arg => undef, 245 clearer => 'reset', 246 predicate => '_has_schema', 247); 248 249around schema => carp_ro('schema'); 250 251around reset => sub { 252 my $orig = shift; 253 my $self = shift; 254 $self->$orig(@_); 255 return 1 256}; 257 258sub _build_schema { SQL::Translator::Schema->new(translator => shift) } 259 260sub translate { 261 my $self = shift; 262 my ($args, $parser, $parser_type, $producer, $producer_type); 263 my ($parser_output, $producer_output, @producer_output); 264 265 # Parse arguments 266 if (@_ == 1) { 267 # Passed a reference to a hash? 268 if (isa($_[0], 'HASH')) { 269 # yep, a hashref 270 $self->debug("translate: Got a hashref\n"); 271 $args = $_[0]; 272 } 273 274 # Passed a GLOB reference, i.e., filehandle 275 elsif (isa($_[0], 'GLOB')) { 276 $self->debug("translate: Got a GLOB reference\n"); 277 $self->data($_[0]); 278 } 279 280 # Passed a reference to a string containing the data 281 elsif (isa($_[0], 'SCALAR')) { 282 # passed a ref to a string 283 $self->debug("translate: Got a SCALAR reference (string)\n"); 284 $self->data($_[0]); 285 } 286 287 # Not a reference; treat it as a filename 288 elsif (! ref $_[0]) { 289 # Not a ref, it's a filename 290 $self->debug("translate: Got a filename\n"); 291 $self->filename($_[0]); 292 } 293 294 # Passed something else entirely. 295 else { 296 # We're not impressed. Take your empty string and leave. 297 # return ""; 298 299 # Actually, if data, parser, and producer are set, then we 300 # can continue. Too bad, because I like my comment 301 # (above)... 302 return "" unless ($self->data && 303 $self->producer && 304 $self->parser); 305 } 306 } 307 else { 308 # You must pass in a hash, or you get nothing. 309 return "" if @_ % 2; 310 $args = { @_ }; 311 } 312 313 # ---------------------------------------------------------------------- 314 # Can specify the data to be transformed using "filename", "file", 315 # "data", or "datasource". 316 # ---------------------------------------------------------------------- 317 if (my $filename = ($args->{'filename'} || $args->{'file'})) { 318 $self->filename($filename); 319 } 320 321 if (my $data = ($args->{'data'} || $args->{'datasource'})) { 322 $self->data($data); 323 } 324 325 # ---------------------------------------------------------------- 326 # Get the data. 327 # ---------------------------------------------------------------- 328 my $data = $self->data; 329 330 # ---------------------------------------------------------------- 331 # Local reference to the parser subroutine 332 # ---------------------------------------------------------------- 333 if ($parser = ($args->{'parser'} || $args->{'from'})) { 334 $self->parser($parser); 335 } 336 $parser = $self->parser; 337 $parser_type = $self->parser_type; 338 339 # ---------------------------------------------------------------- 340 # Local reference to the producer subroutine 341 # ---------------------------------------------------------------- 342 if ($producer = ($args->{'producer'} || $args->{'to'})) { 343 $self->producer($producer); 344 } 345 $producer = $self->producer; 346 $producer_type = $self->producer_type; 347 348 # ---------------------------------------------------------------- 349 # Execute the parser, the filters and then execute the producer. 350 # Allowances are made for each piece to die, or fail to compile, 351 # since the referenced subroutines could be almost anything. In 352 # the future, each of these might happen in a Safe environment, 353 # depending on how paranoid we want to be. 354 # ---------------------------------------------------------------- 355 356 # Run parser 357 unless ( $self->_has_schema ) { 358 eval { $parser_output = $parser->($self, $$data) }; 359 if ($@ || ! $parser_output) { 360 my $msg = sprintf "translate: Error with parser '%s': %s", 361 $parser_type, ($@) ? $@ : " no results"; 362 return $self->error($msg); 363 } 364 } 365 $self->debug("Schema =\n", Dumper($self->schema), "\n") if $self->debugging;; 366 367 # Validate the schema if asked to. 368 if ($self->validate) { 369 my $schema = $self->schema; 370 return $self->error('Invalid schema') unless $schema->is_valid; 371 } 372 373 # Run filters 374 my $filt_num = 0; 375 foreach ($self->filters) { 376 $filt_num++; 377 my ($code,@args) = @$_; 378 eval { $code->($self->schema, @args) }; 379 my $err = $@ || $self->error || 0; 380 return $self->error("Error with filter $filt_num : $err") if $err; 381 } 382 383 # Run producer 384 # Calling wantarray in the eval no work, wrong scope. 385 my $wantarray = wantarray ? 1 : 0; 386 eval { 387 if ($wantarray) { 388 @producer_output = $producer->($self); 389 } else { 390 $producer_output = $producer->($self); 391 } 392 }; 393 if ($@ || !( $producer_output || @producer_output)) { 394 my $err = $@ || $self->error || "no results"; 395 my $msg = "translate: Error with producer '$producer_type': $err"; 396 return $self->error($msg); 397 } 398 399 return wantarray ? @producer_output : $producer_output; 400} 401 402sub list_parsers { 403 return shift->_list("parser"); 404} 405 406sub list_producers { 407 return shift->_list("producer"); 408} 409 410 411# ====================================================================== 412# Private Methods 413# ====================================================================== 414 415# ---------------------------------------------------------------------- 416# _args($type, \%args); 417# 418# Gets or sets ${type}_args. Called by parser_args and producer_args. 419# ---------------------------------------------------------------------- 420sub _args { 421 my $self = shift; 422 my $orig = shift; 423 424 if (@_) { 425 # If the first argument is an explicit undef (remember, we 426 # don't get here unless there is stuff in @_), then we clear 427 # out the producer_args hash. 428 if (! defined $_[0]) { 429 shift @_; 430 $self->$orig({}); 431 } 432 433 my $args = isa($_[0], 'HASH') ? shift : { @_ }; 434 return $self->$orig({ %{$self->$orig}, %$args }); 435 } 436 437 return $self->$orig; 438} 439 440# ---------------------------------------------------------------------- 441# Does the get/set work for parser and producer. e.g. 442# return $self->_tool({ 443# name => 'producer', 444# path => "SQL::Translator::Producer", 445# default_sub => "produce", 446# }, @_); 447# ---------------------------------------------------------------------- 448sub _tool { 449 my ($self,$args) = (shift, shift); 450 my $name = $args->{name}; 451 my $orig = $args->{orig}; 452 return $self->{$name} unless @_; # get accessor 453 454 my $path = $args->{path}; 455 my $default_sub = $args->{default_sub}; 456 my $tool = shift; 457 458 # passed an anonymous subroutine reference 459 if (isa($tool, 'CODE')) { 460 $self->$orig($tool); 461 $self->${\"_set_${name}_type"}("CODE"); 462 $self->debug("Got $name: code ref\n"); 463 } 464 465 # Module name was passed directly 466 # We try to load the name; if it doesn't load, there's a 467 # possibility that it has a function name attached to it, 468 # so we give it a go. 469 else { 470 $tool =~ s/-/::/g if $tool !~ /::/; 471 my ($code,$sub); 472 ($code,$sub) = _load_sub("$tool\::$default_sub", $path); 473 unless ($code) { 474 if ( __PACKAGE__->error =~ m/Can't find module/ ) { 475 # Mod not found so try sub 476 ($code,$sub) = _load_sub("$tool", $path) unless $code; 477 die "Can't load $name subroutine '$tool' : ".__PACKAGE__->error 478 unless $code; 479 } 480 else { 481 die "Can't load $name '$tool' : ".__PACKAGE__->error; 482 } 483 } 484 485 # get code reference and assign 486 my (undef,$module,undef) = $sub =~ m/((.*)::)?(\w+)$/; 487 $self->$orig($code); 488 $self->${\"_set_$name\_type"}($sub eq "CODE" ? "CODE" : $module); 489 $self->debug("Got $name: $sub\n"); 490 } 491 492 # At this point, $self->{$name} contains a subroutine 493 # reference that is ready to run 494 495 # Anything left? If so, it's args 496 my $meth = "$name\_args"; 497 $self->$meth(@_) if (@_); 498 499 return $self->{$name}; 500} 501 502# ---------------------------------------------------------------------- 503# _list($type) 504# ---------------------------------------------------------------------- 505sub _list { 506 my $self = shift; 507 my $type = shift || return (); 508 my $uctype = ucfirst lc $type; 509 510 # 511 # First find all the directories where SQL::Translator 512 # parsers or producers (the "type") appear to live. 513 # 514 load("SQL::Translator::$uctype") or return (); 515 my $path = catfile "SQL", "Translator", $uctype; 516 my @dirs; 517 for (@INC) { 518 my $dir = catfile $_, $path; 519 $self->debug("_list_${type}s searching $dir\n"); 520 next unless -d $dir; 521 push @dirs, $dir; 522 } 523 524 # 525 # Now use File::File::find to look recursively in those 526 # directories for all the *.pm files, then present them 527 # with the slashes turned into dashes. 528 # 529 my %found; 530 find( 531 sub { 532 if ( -f && m/\.pm$/ ) { 533 my $mod = $_; 534 $mod =~ s/\.pm$//; 535 my $cur_dir = $File::Find::dir; 536 my $base_dir = quotemeta catfile 'SQL', 'Translator', $uctype; 537 538 # 539 # See if the current directory is below the base directory. 540 # 541 if ( $cur_dir =~ m/$base_dir(.*)/ ) { 542 $cur_dir = $1; 543 $cur_dir =~ s!^/!!; # kill leading slash 544 $cur_dir =~ s!/!-!g; # turn other slashes into dashes 545 } 546 else { 547 $cur_dir = ''; 548 } 549 550 $found{ join '-', map { $_ || () } $cur_dir, $mod } = 1; 551 } 552 }, 553 @dirs 554 ); 555 556 return sort { lc $a cmp lc $b } keys %found; 557} 558 559# ---------------------------------------------------------------------- 560# load(MODULE [,PATH[,PATH]...]) 561# 562# Loads a Perl module. Short circuits if a module is already loaded. 563# 564# MODULE - is the name of the module to load. 565# 566# PATH - optional list of 'package paths' to look for the module in. e.g 567# If you called load('Super::Foo' => 'My', 'Other') it will 568# try to load the mod Super::Foo then My::Super::Foo then Other::Super::Foo. 569# 570# Returns package name of the module actually loaded or false and sets error. 571# 572# Note, you can't load a name from the root namespace (ie one without '::' in 573# it), therefore a single word name without a path fails. 574# ---------------------------------------------------------------------- 575sub load { 576 my $name = shift; 577 my @path; 578 push @path, "" if $name =~ /::/; # Empty path to check name on its own first 579 push @path, @_ if @_; 580 581 foreach (@path) { 582 my $module = $_ ? "$_\::$name" : $name; 583 my $file = $module; $file =~ s[::][/]g; $file .= ".pm"; 584 __PACKAGE__->debug("Loading $name as $file\n"); 585 return $module if $INC{$file}; # Already loaded 586 587 eval { require $file }; 588 next if $@ =~ /Can't locate $file in \@INC/; 589 eval { $module->import() } unless $@; 590 return __PACKAGE__->error("Error loading $name as $module : $@") 591 if $@ && $@ !~ /"SQL::Translator::Producer" is not exported/; 592 593 return $module; # Module loaded ok 594 } 595 596 return __PACKAGE__->error("Can't find module $name. Path:".join(",",@path)); 597} 598 599# ---------------------------------------------------------------------- 600# Load the sub name given (including package), optionally using a base package 601# path. Returns code ref and name of sub loaded, including its package. 602# (\&code, $sub) = load_sub( 'MySQL::produce', "SQL::Translator::Producer" ); 603# (\&code, $sub) = load_sub( 'MySQL::produce', @path ); 604# ---------------------------------------------------------------------- 605sub _load_sub { 606 my ($tool, @path) = @_; 607 608 my (undef,$module,$func_name) = $tool =~ m/((.*)::)?(\w+)$/; 609 if ( my $module = load($module => @path) ) { 610 my $sub = "$module\::$func_name"; 611 return wantarray ? ( \&{ $sub }, $sub ) : \&$sub; 612 } 613 return undef; 614} 615 616sub format_table_name { 617 return shift->_format_name('_format_table_name', @_); 618} 619 620sub format_package_name { 621 return shift->_format_name('_format_package_name', @_); 622} 623 624sub format_fk_name { 625 return shift->_format_name('_format_fk_name', @_); 626} 627 628sub format_pk_name { 629 return shift->_format_name('_format_pk_name', @_); 630} 631 632# ---------------------------------------------------------------------- 633# The other format_*_name methods rely on this one. It optionally 634# accepts a subroutine ref as the first argument (or uses an identity 635# sub if one isn't provided or it doesn't already exist), and applies 636# it to the rest of the arguments (if any). 637# ---------------------------------------------------------------------- 638sub _format_name { 639 my $self = shift; 640 my $field = shift; 641 my @args = @_; 642 643 if (ref($args[0]) eq 'CODE') { 644 $self->{$field} = shift @args; 645 } 646 elsif (! exists $self->{$field}) { 647 $self->{$field} = sub { return shift }; 648 } 649 650 return @args ? $self->{$field}->(@args) : $self->{$field}; 651} 652 653sub isa($$) { 654 my ($ref, $type) = @_; 655 return UNIVERSAL::isa($ref, $type); 656} 657 658sub version { 659 my $self = shift; 660 return $VERSION; 661} 662 663# Must come after all 'has' declarations 664around new => \&ex2err; 665 6661; 667 668# ---------------------------------------------------------------------- 669# Who killed the pork chops? 670# What price bananas? 671# Are you my Angel? 672# Allen Ginsberg 673# ---------------------------------------------------------------------- 674 675=pod 676 677=head1 NAME 678 679SQL::Translator - manipulate structured data definitions (SQL and more) 680 681=head1 SYNOPSIS 682 683 use SQL::Translator; 684 685 my $translator = SQL::Translator->new( 686 # Print debug info 687 debug => 1, 688 # Print Parse::RecDescent trace 689 trace => 0, 690 # Don't include comments in output 691 no_comments => 0, 692 # Print name mutations, conflicts 693 show_warnings => 0, 694 # Add "drop table" statements 695 add_drop_table => 1, 696 # to quote or not to quote, thats the question 697 quote_identifiers => 1, 698 # Validate schema object 699 validate => 1, 700 # Make all table names CAPS in producers which support this option 701 format_table_name => sub {my $tablename = shift; return uc($tablename)}, 702 # Null-op formatting, only here for documentation's sake 703 format_package_name => sub {return shift}, 704 format_fk_name => sub {return shift}, 705 format_pk_name => sub {return shift}, 706 ); 707 708 my $output = $translator->translate( 709 from => 'MySQL', 710 to => 'Oracle', 711 # Or an arrayref of filenames, i.e. [ $file1, $file2, $file3 ] 712 filename => $file, 713 ) or die $translator->error; 714 715 print $output; 716 717=head1 DESCRIPTION 718 719This documentation covers the API for SQL::Translator. For a more general 720discussion of how to use the modules and scripts, please see 721L<SQL::Translator::Manual>. 722 723SQL::Translator is a group of Perl modules that converts 724vendor-specific SQL table definitions into other formats, such as 725other vendor-specific SQL, ER diagrams, documentation (POD and HTML), 726XML, and Class::DBI classes. The main focus of SQL::Translator is 727SQL, but parsers exist for other structured data formats, including 728Excel spreadsheets and arbitrarily delimited text files. Through the 729separation of the code into parsers and producers with an object model 730in between, it's possible to combine any parser with any producer, to 731plug in custom parsers or producers, or to manipulate the parsed data 732via the built-in object model. Presently only the definition parts of 733SQL are handled (CREATE, ALTER), not the manipulation of data (INSERT, 734UPDATE, DELETE). 735 736=head1 CONSTRUCTOR 737 738=head2 new 739 740The constructor is called C<new>, and accepts a optional hash of options. 741Valid options are: 742 743=over 4 744 745=item * 746 747parser / from 748 749=item * 750 751parser_args 752 753=item * 754 755producer / to 756 757=item * 758 759producer_args 760 761=item * 762 763filters 764 765=item * 766 767filename / file 768 769=item * 770 771data 772 773=item * 774 775debug 776 777=item * 778 779add_drop_table 780 781=item * 782 783quote_identifiers 784 785=item * 786 787quote_table_names (DEPRECATED) 788 789=item * 790 791quote_field_names (DEPRECATED) 792 793=item * 794 795no_comments 796 797=item * 798 799trace 800 801=item * 802 803validate 804 805=back 806 807All options are, well, optional; these attributes can be set via 808instance methods. Internally, they are; no (non-syntactical) 809advantage is gained by passing options to the constructor. 810 811=head1 METHODS 812 813=head2 add_drop_table 814 815Toggles whether or not to add "DROP TABLE" statements just before the 816create definitions. 817 818=head2 quote_identifiers 819 820Toggles whether or not to quote identifiers (table, column, constraint, etc.) 821with a quoting mechanism suitable for the chosen Producer. The default (true) 822is to quote them. 823 824=head2 quote_table_names 825 826DEPRECATED - A legacy proxy to L</quote_identifiers> 827 828=head2 quote_field_names 829 830DEPRECATED - A legacy proxy to L</quote_identifiers> 831 832=head2 no_comments 833 834Toggles whether to print comments in the output. Accepts a true or false 835value, returns the current value. 836 837=head2 producer 838 839The C<producer> method is an accessor/mutator, used to retrieve or 840define what subroutine is called to produce the output. A subroutine 841defined as a producer will be invoked as a function (I<not a method>) 842and passed its container C<SQL::Translator> instance, which it should 843call the C<schema> method on, to get the C<SQL::Translator::Schema> 844generated by the parser. It is expected that the function transform the 845schema structure to a string. The C<SQL::Translator> instance is also useful 846for informational purposes; for example, the type of the parser can be 847retrieved using the C<parser_type> method, and the C<error> and 848C<debug> methods can be called when needed. 849 850When defining a producer, one of several things can be passed in: A 851module name (e.g., C<My::Groovy::Producer>), a module name relative to 852the C<SQL::Translator::Producer> namespace (e.g., C<MySQL>), a module 853name and function combination (C<My::Groovy::Producer::transmogrify>), 854or a reference to an anonymous subroutine. If a full module name is 855passed in (for the purposes of this method, a string containing "::" 856is considered to be a module name), it is treated as a package, and a 857function called "produce" will be invoked: C<$modulename::produce>. 858If $modulename cannot be loaded, the final portion is stripped off and 859treated as a function. In other words, if there is no file named 860F<My/Groovy/Producer/transmogrify.pm>, C<SQL::Translator> will attempt 861to load F<My/Groovy/Producer.pm> and use C<transmogrify> as the name of 862the function, instead of the default C<produce>. 863 864 my $tr = SQL::Translator->new; 865 866 # This will invoke My::Groovy::Producer::produce($tr, $data) 867 $tr->producer("My::Groovy::Producer"); 868 869 # This will invoke SQL::Translator::Producer::Sybase::produce($tr, $data) 870 $tr->producer("Sybase"); 871 872 # This will invoke My::Groovy::Producer::transmogrify($tr, $data), 873 # assuming that My::Groovy::Producer::transmogrify is not a module 874 # on disk. 875 $tr->producer("My::Groovy::Producer::transmogrify"); 876 877 # This will invoke the referenced subroutine directly, as 878 # $subref->($tr, $data); 879 $tr->producer(\&my_producer); 880 881There is also a method named C<producer_type>, which is a string 882containing the classname to which the above C<produce> function 883belongs. In the case of anonymous subroutines, this method returns 884the string "CODE". 885 886Finally, there is a method named C<producer_args>, which is both an 887accessor and a mutator. Arbitrary data may be stored in name => value 888pairs for the producer subroutine to access: 889 890 sub My::Random::producer { 891 my ($tr, $data) = @_; 892 my $pr_args = $tr->producer_args(); 893 894 # $pr_args is a hashref. 895 896Extra data passed to the C<producer> method is passed to 897C<producer_args>: 898 899 $tr->producer("xSV", delimiter => ',\s*'); 900 901 # In SQL::Translator::Producer::xSV: 902 my $args = $tr->producer_args; 903 my $delimiter = $args->{'delimiter'}; # value is ,\s* 904 905=head2 parser 906 907The C<parser> method defines or retrieves a subroutine that will be 908called to perform the parsing. The basic idea is the same as that of 909C<producer> (see above), except the default subroutine name is 910"parse", and will be invoked as C<$module_name::parse($tr, $data)>. 911Also, the parser subroutine will be passed a string containing the 912entirety of the data to be parsed. 913 914 # Invokes SQL::Translator::Parser::MySQL::parse() 915 $tr->parser("MySQL"); 916 917 # Invokes My::Groovy::Parser::parse() 918 $tr->parser("My::Groovy::Parser"); 919 920 # Invoke an anonymous subroutine directly 921 $tr->parser(sub { 922 my $dumper = Data::Dumper->new([ $_[1] ], [ "SQL" ]); 923 $dumper->Purity(1)->Terse(1)->Deepcopy(1); 924 return $dumper->Dump; 925 }); 926 927There is also C<parser_type> and C<parser_args>, which perform 928analogously to C<producer_type> and C<producer_args> 929 930=head2 filters 931 932Set or retrieve the filters to run over the schema during the 933translation, before the producer creates its output. Filters are sub 934routines called, in order, with the schema object to filter as the 1st 935arg and a hash of options (passed as a list) for the rest of the args. 936They are free to do whatever they want to the schema object, which will be 937handed to any following filters, then used by the producer. 938 939Filters are set as an array, which gives the order they run in. 940Like parsers and producers, they can be defined by a module name, a 941module name relative to the SQL::Translator::Filter namespace, a module 942name and function name together or a reference to an anonymous subroutine. 943When using a module name a function called C<filter> will be invoked in 944that package to do the work. 945 946To pass args to the filter set it as an array ref with the 1st value giving 947the filter (name or sub) and the rest its args. e.g. 948 949 $tr->filters( 950 sub { 951 my $schema = shift; 952 # Do stuff to schema here! 953 }, 954 DropFKeys, 955 [ "Names", table => 'lc' ], 956 [ "Foo", foo => "bar", hello => "world" ], 957 [ "Filter5" ], 958 ); 959 960Although you normally set them in the constructor, which calls 961through to filters. i.e. 962 963 my $translator = SQL::Translator->new( 964 ... 965 filters => [ 966 sub { ... }, 967 [ "Names", table => 'lc' ], 968 ], 969 ... 970 ); 971 972See F<t/36-filters.t> for more examples. 973 974Multiple set calls to filters are cumulative with new filters added to 975the end of the current list. 976 977Returns the filters as a list of array refs, the 1st value being a 978reference to the filter sub and the rest its args. 979 980=head2 show_warnings 981 982Toggles whether to print warnings of name conflicts, identifier 983mutations, etc. Probably only generated by producers to let the user 984know when something won't translate very smoothly (e.g., MySQL "enum" 985fields into Oracle). Accepts a true or false value, returns the 986current value. 987 988=head2 translate 989 990The C<translate> method calls the subroutine referenced by the 991C<parser> data member, then calls any C<filters> and finally calls 992the C<producer> sub routine (these members are described above). 993It accepts as arguments a number of things, in key => value format, 994including (potentially) a parser and a producer (they are passed 995directly to the C<parser> and C<producer> methods). 996 997Here is how the parameter list to C<translate> is parsed: 998 999=over 1000 1001=item * 1002 10031 argument means it's the data to be parsed; which could be a string 1004(filename) or a reference to a scalar (a string stored in memory), or a 1005reference to a hash, which is parsed as being more than one argument 1006(see next section). 1007 1008 # Parse the file /path/to/datafile 1009 my $output = $tr->translate("/path/to/datafile"); 1010 1011 # Parse the data contained in the string $data 1012 my $output = $tr->translate(\$data); 1013 1014=item * 1015 1016More than 1 argument means its a hash of things, and it might be 1017setting a parser, producer, or datasource (this key is named 1018"filename" or "file" if it's a file, or "data" for a SCALAR reference. 1019 1020 # As above, parse /path/to/datafile, but with different producers 1021 for my $prod ("MySQL", "XML", "Sybase") { 1022 print $tr->translate( 1023 producer => $prod, 1024 filename => "/path/to/datafile", 1025 ); 1026 } 1027 1028 # The filename hash key could also be: 1029 datasource => \$data, 1030 1031You get the idea. 1032 1033=back 1034 1035=head2 filename, data 1036 1037Using the C<filename> method, the filename of the data to be parsed 1038can be set. This method can be used in conjunction with the C<data> 1039method, below. If both the C<filename> and C<data> methods are 1040invoked as mutators, the data set in the C<data> method is used. 1041 1042 $tr->filename("/my/data/files/create.sql"); 1043 1044or: 1045 1046 my $create_script = do { 1047 local $/; 1048 open CREATE, "/my/data/files/create.sql" or die $!; 1049 <CREATE>; 1050 }; 1051 $tr->data(\$create_script); 1052 1053C<filename> takes a string, which is interpreted as a filename. 1054C<data> takes a reference to a string, which is used as the data to be 1055parsed. If a filename is set, then that file is opened and read when 1056the C<translate> method is called, as long as the data instance 1057variable is not set. 1058 1059=head2 schema 1060 1061Returns the SQL::Translator::Schema object. 1062 1063=head2 trace 1064 1065Turns on/off the tracing option of Parse::RecDescent. 1066 1067=head2 validate 1068 1069Whether or not to validate the schema object after parsing and before 1070producing. 1071 1072=head2 version 1073 1074Returns the version of the SQL::Translator release. 1075 1076=head1 AUTHORS 1077 1078See the included AUTHORS file: 1079L<http://search.cpan.org/dist/SQL-Translator/AUTHORS> 1080 1081=head1 GETTING HELP/SUPPORT 1082 1083If you are stuck with a problem or have doubts about a particular 1084approach do not hesitate to contact us via any of the following 1085options (the list is sorted by "fastest response time"): 1086 1087=over 1088 1089=item * IRC: irc.perl.org#sql-translator 1090 1091=for html 1092<a href="https://chat.mibbit.com/#sql-translator@irc.perl.org">(click for instant chatroom login)</a> 1093 1094=item * Mailing list: L<http://lists.scsys.co.uk/mailman/listinfo/dbix-class> 1095 1096=item * RT Bug Tracker: L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=SQL-Translator> 1097 1098=back 1099 1100=head1 HOW TO CONTRIBUTE 1101 1102Contributions are always welcome, in all usable forms (we especially 1103welcome documentation improvements). The delivery methods include git- 1104or unified-diff formatted patches, GitHub pull requests, or plain bug 1105reports either via RT or the Mailing list. Contributors are generally 1106granted access to the official repository after their first several 1107patches pass successful review. Don't hesitate to 1108L<contact|/GETTING HELP/SUPPORT> us with any further questions you may 1109have. 1110 1111This project is maintained in a git repository. The code and related tools are 1112accessible at the following locations: 1113 1114=over 1115 1116=item * Official repo: L<git://git.shadowcat.co.uk/dbsrgits/SQL-Translator.git> 1117 1118=item * Official gitweb: L<http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits/SQL-Translator.git> 1119 1120=item * GitHub mirror: L<https://github.com/dbsrgits/SQL-Translator> 1121 1122=item * Authorized committers: L<ssh://dbsrgits@git.shadowcat.co.uk/sql-translator.git> 1123 1124=item * Travis-CI log: L<https://travis-ci.org/dbsrgits/sql-translator/builds> 1125 1126=for html 1127↪ Stable branch CI status: <img src="https://secure.travis-ci.org/dbsrgits/sql-translator.png?branch=master"></img> 1128 1129=back 1130 1131=head1 COPYRIGHT 1132 1133Copyright 2012 the SQL::Translator authors, as listed in L</AUTHORS>. 1134 1135=head1 LICENSE 1136 1137This library is free software and may be distributed under the same terms as 1138Perl 5 itself. 1139 1140=head1 PRAISE 1141 1142If you find this module useful, please use 1143L<http://cpanratings.perl.org/rate/?distribution=SQL-Translator> to rate it. 1144 1145=head1 SEE ALSO 1146 1147L<perl>, 1148L<SQL::Translator::Parser>, 1149L<SQL::Translator::Producer>, 1150L<Parse::RecDescent>, 1151L<GD>, 1152L<GraphViz>, 1153L<Text::RecordParser>, 1154L<Class::DBI>, 1155L<XML::Writer>. 1156