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).
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
--- /dev/null
+#!/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";
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 <kycl4rk@users.sourceforge.net>,
# darren chamberlain <darren@cpan.org>
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;
# ----------------------------------------------------------------------
$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("");
# 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);
belongs. In the case of anonymous subroutines, this method returns
the string "CODE".
+Finally, there is a method named B<producer_args>, 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<producer> method is passed to
+B<producer_args>:
+
+ $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
# {{{ 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");
# }}}
} # }}}
# 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<parser>
return $dumper->Dump;
});
+There is also B<parser_type> and B<parser_args>, which perform
+analogously to B<producer_type> and B<producer_args>
+
=cut
-# {{{ parser and parser_type
+# {{{ parser, parser_type, and parser_args
sub parser {
my $self = shift;
# 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<translate>
--- /dev/null
+package SQL::Translator::Validator;
+
+# ----------------------------------------------------------------------
+# $Id: Validator.pm,v 1.1 2002-03-26 12:46:54 dlc Exp $
+# ----------------------------------------------------------------------
+# Copyright (C) 2002 Ken Y. Clark <kycl4rk@users.sourceforge.net>,
+# darren chamberlain <darren@cpan.org>
+#
+# 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<validate>, 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<validate>
+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 E<lt>darren@cpan.orgE<gt>
--- /dev/null
+#!/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";
+
projects / dbsrgits/SQL-Translator.git / commitdiff