From: Darren Chamberlain Date: Tue, 26 Mar 2002 12:46:54 +0000 (+0000) Subject: Added support for producer_args and parser_args. X-Git-Tag: v0.01~52 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e2158c408a30ce43e277e68d586130a89126c733;p=dbsrgits%2FSQL-Translator.git Added support for producer_args and parser_args. Added test for producer_args and parser_args. Added t/07p_test.t to MANIFEST. Added validator_test.pl to bin (though not to MANIFEST). --- diff --git a/MANIFEST b/MANIFEST index d3e2846..0bf94d3 100644 --- a/MANIFEST +++ b/MANIFEST @@ -19,5 +19,6 @@ t/04file,fh,string.t t/03mysql-to-oracle.t t/05bgep-re.t t/06xsv.t +t/07p_args.t t/data/mysql/Apache-Session-MySQL.sql t/data/mysql/BGEP-RE-create.sql diff --git a/bin/validator_test.pl b/bin/validator_test.pl new file mode 100755 index 0000000..92893ba --- /dev/null +++ b/bin/validator_test.pl @@ -0,0 +1,65 @@ +#!/usr/local/bin/perl + +use SQL::Translator::Validator; +my $data = { + random => { + type => undef, + indeces => [ ], + fields => { + id => { + name => "id", + data_type => "int", + size => 11, + order => 1, + null => 0, + default => 1 + }, + seed => { + name => "seed", + data_type => "char", + size => 32, + order => 2, + null => 0, + default => 1 + }, + + } + }, + session => { + type => "HEAP", + indeces => [ + { + name => "main_idx", + primary_key => 1, + fields => [ "id" ], + } + ], + fields => { + id => { + name => "id", + data_type => "int", + size => 11, + order => 2, + null => 0, + default => 1 + }, + foo => { + name => "foo", + data_type => "char", + size => 255, + order => 1, + null => 1 + }, + } + } +}; + +use SQL::Translator; + +my $tr = SQL::Translator->new(parser => "MySQL"); + +$data = $tr->translate("t/data/mysql/BGEP-RE-create.sql"); + +my @r = validate($data); + +printf "%s%s", $r[1], $r[0]? "" : "\n"; diff --git a/lib/SQL/Translator.pm b/lib/SQL/Translator.pm index 00c2dea..7cf4179 100644 --- a/lib/SQL/Translator.pm +++ b/lib/SQL/Translator.pm @@ -1,7 +1,7 @@ package SQL::Translator; # ---------------------------------------------------------------------- -# $Id: Translator.pm,v 1.4 2002-03-21 18:50:53 dlc Exp $ +# $Id: Translator.pm,v 1.5 2002-03-26 12:46:54 dlc Exp $ # ---------------------------------------------------------------------- # Copyright (C) 2002 Ken Y. Clark , # darren chamberlain @@ -57,7 +57,7 @@ contributing their parsers or producers back to the project. use strict; use vars qw($VERSION $DEFAULT_SUB $DEBUG); -$VERSION = sprintf "%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/; +$VERSION = sprintf "%d.%02d", q$Revision: 1.5 $ =~ /(\d+)\.(\d+)/; $DEBUG = 1 unless defined $DEBUG; # ---------------------------------------------------------------------- @@ -126,6 +126,13 @@ sub new { $self->producer($args->{'producer'} || $args->{'to'} || $DEFAULT_SUB); # ------------------------------------------------------------------ + # Set the parser_args and producer_args + # ------------------------------------------------------------------ + for my $pargs (qw(parser_args producer_args)) { + $self->$pargs($args->{$pargs}) if defined $args->{$pargs}; + } + + # ------------------------------------------------------------------ # Clear the error # ------------------------------------------------------------------ $self->error_out(""); @@ -173,7 +180,7 @@ instead of the default "produce". # This will invoke My::Groovy::Producer::transmogrify($tr, $data), # assuming that My::Groovy::Producer::transmogrify is not a module # on disk. - # $tr->producer("My::Groovy::Producer::transmogrify); + $tr->producer("My::Groovy::Producer::transmogrify"); # This will invoke the referenced subroutine directly, as # $subref->($tr, $data); @@ -184,6 +191,25 @@ containing the classname to which the above B function belongs. In the case of anonymous subroutines, this method returns the string "CODE". +Finally, there is a method named B, which is both an +accessor and a mutator. Arbitrary data may be stored in name => value +pairs for the producer subroutine to access: + + sub My::Random::producer { + my ($tr, $data) = @_; + my $pr_args = $tr->producer_args(); + + # $pr_args is a hashref. + +Extra data passed to the B method is passed to +B: + + $tr->producer("xSV", delimiter => ',\s*'); + + # In SQL::Translator::Producer::xSV: + my $args = $tr->producer_args; + my $delimiter = $args->{'delimiter'}; # value is => ,\s* + =cut # {{{ producer and producer_type @@ -221,7 +247,7 @@ sub producer { # {{{ get code reference and assign $self->{'producer'} = \&{ "$producer\::$func_name" }; $self->{'producer_type'} = $producer; - $self->debug("Got 'producer': $producer\::$func_name"); + $self->debug("Got producer: $producer\::$func_name"); # }}} } # }}} @@ -243,12 +269,34 @@ sub producer { # At this point, $self->{'producer'} contains a subroutine # reference that is ready to run + + # {{{ Anything left? If so, it's producer_args + $self->produser_args(@_) if (@_); + # }}} } # }}} return $self->{'producer'}; }; -sub producer_type { $_[0]->{'producer_type'} } +# {{{ producer_type +# producer_type is an accessor that allows producer subs to get +# information about their origin. This is poptentially important; +# since all producer subs are called as subroutine refernces, there is +# no way for a producer to find out which package the sub lives in +# originally, for example. +sub producer_type { $_[0]->{'producer_type'} } # }}} + +# {{{ producer_args +# Arbitrary name => value pairs of paramters can be passed to a +# producer using this method. +sub producer_args { + my $self = shift; + if (@_) { + my $args = isa($_[0], 'HASH') ? shift : { @_ }; + $self->{'producer_args'} = $args; + } + $self->{'producer_args'}; +} # }}} # }}} =head2 B @@ -273,9 +321,12 @@ entirety of the data to be parsed (or possibly a reference to a string?). return $dumper->Dump; }); +There is also B and B, which perform +analogously to B and B + =cut -# {{{ parser and parser_type +# {{{ parser, parser_type, and parser_args sub parser { my $self = shift; @@ -332,13 +383,24 @@ sub parser { # At this point, $self->{'parser'} contains a subroutine # reference that is ready to run - } # }}} + $self->parser_args(@_) if (@_); + } # }}} return $self->{'parser'}; } sub parser_type { $_[0]->{'parser_type'} } + +# {{{ parser_args +sub parser_args { + my $self = shift; + if (@_) { + my $args = isa($_[0], 'HASH') ? shift : { @_ }; + $self->{'parser_args'} = $args; + } + $self->{'parser_args'}; +} # }}} # }}} =head2 B diff --git a/lib/SQL/Translator/Validator.pm b/lib/SQL/Translator/Validator.pm new file mode 100644 index 0000000..9b14928 --- /dev/null +++ b/lib/SQL/Translator/Validator.pm @@ -0,0 +1,188 @@ +package SQL::Translator::Validator; + +# ---------------------------------------------------------------------- +# $Id: Validator.pm,v 1.1 2002-03-26 12:46:54 dlc Exp $ +# ---------------------------------------------------------------------- +# Copyright (C) 2002 Ken Y. Clark , +# darren chamberlain +# +# This program is free software; you can redistribute it and/or +# modify it under the terms of the GNU General Public License as +# published by the Free Software Foundation; version 2. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +# 02111-1307 USA +# ---------------------------------------------------------------------- + +use strict; +use vars qw($VERSION @EXPORT); +$VERSION = sprintf "%d.%02d", q$Revision: 1.1 $ =~ /(\d+)\.(\d+)/; + +use Exporter; +use base qw(Exporter); +@EXPORT = qw(validate); + +use Data::Dumper; + +sub by_context($$$) { ($_[0]) ? ($_[1], $_[2]) : $_[1]; } + +sub validate { + my $data = shift; + my $wa = wantarray; + my ($ok, $log); + + unless (ref $data) { + return by_context $wa, 0, "Not a reference"; + } + + unless (UNIVERSAL::isa($data, "HASH")) { + return by_context $wa, 0, "Not a HASH reference"; + } else { + my $num = scalar keys %{$data}; + $log = sprintf "Contains %d table%s.", $num, ($num == 1 ? "" : "s"); + } + + my @tables = sort keys %{$data}; + for (my $i = 0; $i < @tables; $i++) { + my $table = $tables[$i]; + my $table_num = $i + 1; + + $log .= "\nTable $table_num: $table"; + my $table_data = $data->{$table}; + + # Table must be a hashref + unless (UNIVERSAL::isa($table_data, "HASH")) { + return by_context $wa, 0, + "Table `$table' is not a HASH reference"; + } + + # Table must contain three elements: type, indeces, and fields + # XXX If there are other keys, is this an error? + unless (exists $table_data->{"type"}) { + return by_context $wa, 0, "Missing type for table `$table'"; + } else { + $log .= sprintf "\n\tType: %s", $table_data->{"type"} || + "not defined"; + } + + # Indeces: array of hashes + unless (defined $table_data->{"indeces"} && + UNIVERSAL::isa($table_data->{"indeces"}, "ARRAY")) { + return by_context $wa, 0, "Indeces is missing or is not an ARRAY"; + } else { + my @indeces = @{$table_data->{"indeces"}}; + $log .= "\n\tIndeces:"; + if (@indeces) { + for my $index (@indeces) { + $log .= "\n\t\t" . ($index->{"name"} || "(unnamed)") + . " on " + . join ", ", @{$index->{"fields"}}; + } + } else { + $log .= " none defined"; + } + } + + # Fields + unless (defined $table_data->{"fields"} && + UNIVERSAL::isa($table_data->{"fields"}, "HASH")) { + return by_context $wa, 0, "Fields is missing or is not a HASH"; + } else { + $log .= "\n\tFields:"; + my @fields = sort { $table_data->{$a}->{"order"} <=> + $table_data->{$b}->{"order"} + } keys %{$table_data->{"fields"}}; + for my $field (@fields) { + my $field_data = $table_data->{"fields"}->{$field}; + $log .= qq|\n\t\t$field_data->{"name"}| + . qq| $field_data->{"data_type"} ($field_data->{"size"})|; + $log .= qq|\n\t\t\tDefault: $field_data->{"default"}| + if length $field_data->{"default"}; + $log .= sprintf qq|\n\t\t\tNull: %s|, + $field_data->{"null"} ? "yes" : "no"; + } + } + } + + $log .= "\n"; + + return by_context $wa, 1, $log; +} + + +1; +__END__ + +=head1 NAME + +SQL::Translator::Validate - Validate that a data structure is correct + +=head1 SYNOPSIS + + print "1..1\n"; + + use SQL::Translator; + use SQL::Translator::Validator; + + my $tr = SQL::Translator->new(parser => "My::Swell::Parser"); + + # Default producer passes the data structure through unchanged + my $parsed = $tr->translate($datafile); + + print "not " unless validate($parsed); + print "ok 1 # data structure looks OK\n"; + +=head1 DESCRIPTION + +When writing a parser module for SQL::Translator, it is helpful to +have a tool to automatically check the return of your module, to make +sure that it is returning the Right Thing. While only a full Producer +and the associated database can determine if you are producing valud +output, SQL::Translator::Validator can tell you if the basic format of +the data structure is correct. While this will not catch many errors, +it will catch the basic ones. + +SQL::Translator::Validator can be used as a development tool, a +testing tool (every SQL::Translator install will have this module), +or, potentially, even as a runtime assertion for producers you don't +trust: + + $tr->producer(\¶noid_producer); + sub paranoid_producer { + my ($tr, $data) = @_; + return unless validate($data); + + # continue... + +=head1 EXPORTED FUNCTIONS + +SQL::Translator::Validator exports a single function, called +B, which expects a data structure as its only argument. +When called in scalar context, it returns a 1 (valid data structure) +or 0 (not a valid data structure). In list context, B +returns a 2 element list: the first element is a 1 or 0, as in scalar +context, and the second value is a reason (for a malformed data +structure) or a summary of the data (for a well-formed data +structure). + +=head1 TODO + +=over 4 + +=item * + +color, either via Term::ANSI, or something along those lines, or just +plain $RED = "\033[31m" type stuff. + +=back + +=head1 AUTHOR + +darren chamberlain Edarren@cpan.orgE diff --git a/t/07p_args.t b/t/07p_args.t new file mode 100644 index 0000000..0185cdd --- /dev/null +++ b/t/07p_args.t @@ -0,0 +1,65 @@ +#!/usr/bin/perl +# vim: set ft=perl: +# +# + +BEGIN { print "1..6\n"; } + +use strict; + +use SQL::Translator; +$SQL::Translator::DEBUG = 0; + +sub silly_parser { + my ($tr, $data) = @_; + my $pargs = $tr->parser_args; + + my @fields = split /$pargs->{'delimiter'}/, $data; + + return \@fields; +} + +# The "data" to be parsed +my $data = q(Id|Name|Phone Number|Favorite Flavor|); + +my $tr = SQL::Translator->new; + +# Pass parser_args as an explicit method call +$tr->parser(\&silly_parser); +$tr->parser_args(delimiter => '\|'); + +my $pargs = $tr->parser_args; +my $parsed = $tr->translate(\$data); + +print "not " unless ($pargs->{'delimiter'} eq '\|'); +print "ok 1 # parser_args works when called directly\n"; + +print "not " unless (scalar @{$parsed} == 4); +print "ok 2 # right number of fields\n"; + +# Now, pass parser_args indirectly... +$tr->parser(\&silly_parser, { delimiter => "\t" }); +$data =~ s/\|/\t/g; + +$pargs = $tr->parser_args; +$parsed = $tr->translate(\$data); + +print "not " unless ($pargs->{'delimiter'} eq "\t"); +print "ok 3 # parser_args works when called indirectly\n"; + +print "not " unless (scalar @{$parsed} == 4); +print "ok 4 # right number of fields with new delimiter\n"; + +undef $tr; +$tr = SQL::Translator->new(parser => \&silly_parser, + parser_args => { delimiter => ":" }); +$data =~ s/\t/:/g; +$pargs = $tr->parser_args; +$parsed = $tr->translate(\$data); + +print "not " unless ($pargs->{'delimiter'} eq ":"); +print "ok 5 # parser_args works when called as constructor arg\n"; + +print "not " unless (scalar @{$parsed} == 4); +print "ok 6 # right number of fields with new delimiter\n"; +