lib/SQL/Translator/Validator.pm

   1 package SQL::Translator::Validator;
   2
   3 # ----------------------------------------------------------------------
   4 # $Id: Validator.pm,v 1.1 2002-03-26 12:46:54 dlc Exp $
   5 # ----------------------------------------------------------------------
   6 # Copyright (C) 2002 Ken Y. Clark <kycl4rk@users.sourceforge.net>,
   7 #                    darren chamberlain <darren@cpan.org>
   8 #
   9 # This program is free software; you can redistribute it and/or
  10 # modify it under the terms of the GNU General Public License as
  11 # published by the Free Software Foundation; version 2.
  12 #
  13 # This program is distributed in the hope that it will be useful, but
  14 # WITHOUT ANY WARRANTY; without even the implied warranty of
  15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  16 # General Public License for more details.
  17 #
  18 # You should have received a copy of the GNU General Public License
  19 # along with this program; if not, write to the Free Software
  20 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
  21 # 02111-1307  USA
  22 # ----------------------------------------------------------------------
  23
  24 use strict;
  25 use vars qw($VERSION @EXPORT);
  26 $VERSION = sprintf "%d.%02d", q$Revision: 1.1 $ =~ /(\d+)\.(\d+)/;
  27
  28 use Exporter;
  29 use base qw(Exporter);
  30 @EXPORT = qw(validate);
  31
  32 use Data::Dumper;
  33
  34 sub by_context($$$) { ($_[0]) ? ($_[1], $_[2]) : $_[1]; }
  35
  36 sub validate {
  37     my $data = shift;
  38     my $wa = wantarray;
  39     my ($ok, $log);
  40
  41     unless (ref $data) {
  42         return by_context $wa, 0, "Not a reference";
  43     }
  44
  45     unless (UNIVERSAL::isa($data, "HASH")) {
  46         return by_context $wa, 0, "Not a HASH reference";
  47     } else {
  48         my $num = scalar keys %{$data};
  49         $log = sprintf "Contains %d table%s.", $num, ($num == 1 ? "" : "s");
  50     }
  51
  52     my @tables = sort keys %{$data};
  53     for (my $i = 0; $i < @tables; $i++) {
  54         my $table = $tables[$i];
  55         my $table_num = $i + 1;
  56
  57         $log .= "\nTable $table_num: $table";
  58         my $table_data = $data->{$table};
  59
  60         # Table must be a hashref
  61         unless (UNIVERSAL::isa($table_data, "HASH")) {
  62             return by_context $wa, 0,
  63                 "Table `$table' is not a HASH reference";
  64         }
  65
  66         # Table must contain three elements: type, indeces, and fields
  67         # XXX If there are other keys, is this an error?
  68         unless (exists $table_data->{"type"}) {
  69             return by_context $wa, 0, "Missing type for table `$table'";
  70         } else {
  71             $log .= sprintf "\n\tType: %s", $table_data->{"type"} ||
  72                 "not defined";
  73         }
  74
  75         # Indeces: array of hashes
  76         unless (defined $table_data->{"indeces"} &&
  77                 UNIVERSAL::isa($table_data->{"indeces"}, "ARRAY")) {
  78             return by_context $wa, 0, "Indeces is missing or is not an ARRAY";
  79         } else {
  80             my @indeces = @{$table_data->{"indeces"}};
  81             $log .= "\n\tIndeces:";
  82             if (@indeces) {
  83                 for my $index (@indeces) {
  84                     $log .= "\n\t\t" . ($index->{"name"} || "(unnamed)")
  85                          .  " on "
  86                          .  join ", ", @{$index->{"fields"}};
  87                 }
  88             } else {
  89                 $log .= " none defined";
  90             }
  91         }
  92
  93         # Fields
  94         unless (defined $table_data->{"fields"} &&
  95             UNIVERSAL::isa($table_data->{"fields"}, "HASH")) {
  96             return by_context $wa, 0, "Fields is missing or is not a HASH";
  97         } else {
  98             $log .= "\n\tFields:";
  99             my @fields = sort { $table_data->{$a}->{"order"} <=>
 100                                 $table_data->{$b}->{"order"}
 101                               } keys %{$table_data->{"fields"}};
 102             for my $field (@fields) {
 103                 my $field_data = $table_data->{"fields"}->{$field};
 104                 $log .= qq|\n\t\t$field_data->{"name"}|
 105                      .  qq| $field_data->{"data_type"} ($field_data->{"size"})|;
 106                 $log .= qq|\n\t\t\tDefault: $field_data->{"default"}|
 107                             if length $field_data->{"default"};
 108                 $log .= sprintf qq|\n\t\t\tNull: %s|,
 109                             $field_data->{"null"} ? "yes" : "no";
 110             }
 111         }
 112     }
 113
 114     $log .= "\n";
 115
 116     return by_context $wa, 1, $log;
 117 }
 118
 119
 120 1;
 121 __END__
 122
 123 =head1 NAME
 124
 125 SQL::Translator::Validate - Validate that a data structure is correct
 126
 127 =head1 SYNOPSIS
 128
 129   print "1..1\n";
 130
 131   use SQL::Translator;
 132   use SQL::Translator::Validator;
 133
 134   my $tr = SQL::Translator->new(parser => "My::Swell::Parser");
 135
 136   # Default producer passes the data structure through unchanged
 137   my $parsed = $tr->translate($datafile);
 138
 139   print "not " unless validate($parsed);
 140   print "ok 1 # data structure looks OK\n";
 141
 142 =head1 DESCRIPTION
 143
 144 When writing a parser module for SQL::Translator, it is helpful to
 145 have a tool to automatically check the return of your module, to make
 146 sure that it is returning the Right Thing.  While only a full Producer
 147 and the associated database can determine if you are producing valud
 148 output, SQL::Translator::Validator can tell you if the basic format of
 149 the data structure is correct.  While this will not catch many errors,
 150 it will catch the basic ones.
 151
 152 SQL::Translator::Validator can be used as a development tool, a
 153 testing tool (every SQL::Translator install will have this module),
 154 or, potentially, even as a runtime assertion for producers you don't
 155 trust:
 156
 157   $tr->producer(\&paranoid_producer);
 158   sub paranoid_producer {
 159       my ($tr, $data) = @_;
 160       return unless validate($data);
 161
 162       # continue...
 163
 164 =head1 EXPORTED FUNCTIONS
 165
 166 SQL::Translator::Validator exports a single function, called
 167 B<validate>, which expects a data structure as its only argument.
 168 When called in scalar context, it returns a 1 (valid data structure)
 169 or 0 (not a valid data structure).  In list context, B<validate>
 170 returns a 2 element list: the first element is a 1 or 0, as in scalar
 171 context, and the second value is a reason (for a malformed data
 172 structure) or a summary of the data (for a well-formed data
 173 structure).
 174
 175 =head1 TODO
 176
 177 =over 4
 178
 179 =item *
 180
 181 color, either via Term::ANSI, or something along those lines, or just
 182 plain $RED = "\033[31m" type stuff.
 183
 184 =back
 185
 186 =head1 AUTHOR
 187
 188 darren chamberlain E<lt>darren@cpan.orgE<gt>