lib/SQL/Translator/Validator.pm

   1 package SQL::Translator::Validator;
   2
   3 # ----------------------------------------------------------------------
   4 # $Id: Validator.pm,v 1.7 2003-01-27 17:04:45 dlc 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 @EXPORT);
  27 $VERSION = sprintf "%d.%02d", q$Revision: 1.7 $ =~ /(\d+)\.(\d+)/;
  28
  29 use Exporter;
  30 use base qw(Exporter);
  31 @EXPORT = qw(validate);
  32
  33 use Data::Dumper;
  34
  35 sub by_context($$$) { ($_[0]) ? ($_[1], $_[2]) : $_[1]; }
  36
  37 # XXX If called in scalar context, then validate should *not*
  38 # genertate or return $log.  It's a lot of extra work if we know we
  39 # are not going to use it.
  40 sub validate {
  41     my $data = shift;
  42     my $wa = wantarray;
  43     my ($ok, $log);
  44
  45     unless (ref $data) {
  46         return by_context $wa, 0, "Not a reference";
  47     }
  48
  49     unless (UNIVERSAL::isa($data, "HASH")) {
  50         return by_context $wa, 0, "Not a HASH reference";
  51     } else {
  52         my $num = scalar keys %{$data};
  53         $log = sprintf "Contains %d table%s.", $num, ($num == 1 ? "" : "s");
  54     }
  55
  56     my @tables = sort keys %{$data};
  57     for (my $i = 0; $i < @tables; $i++) {
  58         my $table = $tables[$i];
  59         my $table_num = $i + 1;
  60
  61         $log .= "\nTable $table_num: $table";
  62         my $table_data = $data->{$table};
  63
  64         # Table must be a hashref
  65         unless (UNIVERSAL::isa($table_data, "HASH")) {
  66             return by_context $wa, 0,
  67                 "Table `$table' is not a HASH reference";
  68         }
  69
  70         # Table must contain three elements: type, indices, and fields
  71         # XXX If there are other keys, is this an error?
  72         unless (exists $table_data->{"type"}) {
  73             return by_context $wa, 0, "Missing type for table `$table'";
  74         } else {
  75             $log .= sprintf "\n\tType: %s", $table_data->{"type"} ||
  76                 "not defined";
  77         }
  78
  79         # Indices: array of hashes
  80         unless (defined $table_data->{"indices"} &&
  81                 UNIVERSAL::isa($table_data->{"indices"}, "ARRAY")) {
  82             return by_context $wa, 0, "Indices is missing or is not an ARRAY";
  83         } else {
  84             my @indices = @{$table_data->{"indices"}};
  85             $log .= "\n\tIndices:";
  86             if (@indices) {
  87                 for my $index (@indices) {
  88                     $log .= "\n\t\t" . ($index->{"name"} || "(unnamed)")
  89                          .  " on "
  90                          .  join ", ", @{$index->{"fields"}};
  91                 }
  92             } else {
  93                 $log .= " none defined";
  94             }
  95         }
  96
  97         # Fields
  98         unless (defined $table_data->{"fields"} &&
  99             UNIVERSAL::isa($table_data->{"fields"}, "HASH")) {
 100             return by_context $wa, 0, "Fields is missing or is not a HASH";
 101         } else {
 102             $log .= "\n\tFields:";
 103             my @fields = sort { $table_data->{$a}->{"order"} <=>
 104                                 $table_data->{$b}->{"order"}
 105                               } keys %{$table_data->{"fields"}};
 106             for my $field (@fields) {
 107                 my $field_data = $table_data->{"fields"}->{$field};
 108                 $log .= qq|\n\t\t$field_data->{"name"}|
 109                      .  qq| $field_data->{"data_type"} ($field_data->{"size"})|;
 110                 $log .= qq|\n\t\t\tDefault: $field_data->{"default"}|
 111                             if length $field_data->{"default"};
 112                 $log .= sprintf qq|\n\t\t\tNull: %s|,
 113                             $field_data->{"null"} ? "yes" : "no";
 114             }
 115         }
 116     }
 117
 118     $log .= "\n";
 119
 120     return by_context $wa, 1, $log;
 121 }
 122
 123
 124 1;
 125 __END__
 126
 127 =head1 NAME
 128
 129 SQL::Translator::Validate - Validate that a data structure is correct
 130
 131 =head1 SYNOPSIS
 132
 133   use Test::More plan tests => 1;
 134   use SQL::Translator;
 135   use SQL::Translator::Validator;
 136
 137   my $tr = SQL::Translator->new(parser => "My::Swell::Parser");
 138
 139   # Default producer passes the data structure through unchanged
 140   my $parsed = $tr->translate($datafile);
 141
 142   ok(validate($parsed), "data structure conformance to definition");
 143
 144 =head1 DESCRIPTION
 145
 146 When writing a parser module for SQL::Translator, it is helpful to
 147 have a tool to automatically check the return of your module, to make
 148 sure that it is returning the Right Thing.  While only a full Producer
 149 and the associated database can determine if you are producing valid
 150 output, SQL::Translator::Validator can tell you if the basic format of
 151 the data structure is correct.  While this will not catch many errors,
 152 it will catch the basic ones.
 153
 154 SQL::Translator::Validator can be used as a development tool, a
 155 testing tool (every SQL::Translator install will have this module),
 156 or, potentially, even as a runtime assertion for producers you don't
 157 trust:
 158
 159   $tr->producer(\&paranoid_producer, real_producer => "MySQL");
 160   sub paranoid_producer {
 161       my ($tr, $data) = @_;
 162       validate($data) or die "You gave me crap!"
 163
 164       # Load real producer, and execute it
 165       $tr->producer($tr->producer_args->{'real_producer'});
 166       return $tr->produce($data);
 167   }
 168
 169 SQL::Translator::Validator can also be used as a reporting tool.  When
 170 B<validate> is called in a list context, the second value returned
 171 (assuming the data structure is well-formed) is a summary of the
 172 table's information.  For example, the following table definition
 173 (MySQL format):
 174
 175   CREATE TABLE random (
 176     id  int(11) not null default 1,
 177     seed char(32) not null default 1
 178   );
 179
 180   CREATE TABLE session (
 181     foo char(255),
 182     id int(11) not null default 1 primary key
 183   ) TYPE=HEAP;
 184
 185 Produces the following summary:
 186
 187     Contains 2 tables.
 188     Table 1: random
 189             Type: not defined
 190             Indices: none defined
 191             Fields:
 192                     id int (11)
 193                             Default: 1
 194                             Null: no
 195                     seed char (32)
 196                             Default: 1
 197                             Null: no
 198     Table 2: session
 199             Type: HEAP
 200             Indices:
 201                     (unnamed) on id
 202             Fields:
 203                     foo char (255)
 204                             Null: yes
 205                     id int (11)
 206                             Default: 1
 207                             Null: no
 208
 209
 210 =head1 EXPORTED FUNCTIONS
 211
 212 SQL::Translator::Validator exports a single function, called
 213 B<validate>, which expects a data structure as its only argument.
 214 When called in scalar context, it returns a 1 (valid data structure)
 215 or 0 (not a valid data structure).  In list context, B<validate>
 216 returns a 2 element list: the first element is a 1 or 0, as in scalar
 217 context, and the second value is a reason (for a malformed data
 218 structure) or a summary of the data (for a well-formed data
 219 structure).
 220
 221 =head1 TODO
 222
 223 =over 4
 224
 225 =item *
 226
 227 color, either via Term::ANSI, or something along those lines, or just
 228 plain $RED = "\033[31m" type stuff.
 229
 230 =back
 231
 232 =head1 AUTHOR
 233
 234 darren chamberlain E<lt>darren@cpan.orgE<gt>