/[webpac2]/trunk/lib/WebPAC/Validate.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Diff of /trunk/lib/WebPAC/Validate.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 514 by dpavlin, Tue May 16 13:38:09 2006 UTC revision 516 by dpavlin, Tue May 16 15:23:12 2006 UTC
# Line 7  use blib; Line 7  use blib;
7    
8  use base 'WebPAC::Common';  use base 'WebPAC::Common';
9  use File::Slurp;  use File::Slurp;
10    use List::Util qw/first/;
11  use Data::Dumper;  use Data::Dumper;
12    
13  =head1 NAME  =head1 NAME
# Line 68  sub new { Line 69  sub new {
69    
70          foreach my $l (split(/[\n\r]+/, $v_file)) {          foreach my $l (split(/[\n\r]+/, $v_file)) {
71                  $curr_line++;                  $curr_line++;
72                  # skip comments  
73                  next if ($l =~ m/^#/);                  # skip comments and whitespaces
74                    next if ($l =~ /^#/ || $l =~ /^\s*$/);
75    
76                  $l =~ s/^\s+//;                  $l =~ s/^\s+//;
77                  $l =~ s/\s+$//;                  $l =~ s/\s+$//;
78    
79                  my @d = split(/\s+/, $l);                  my @d = split(/\s+/, $l);
80    
81                  my $fld = shift @d || $log->logdie("need field name in line $curr_line: $l");                  my $fld = shift @d;
82    
83                    $log->logdie("need field name in line $curr_line: $l") unless (defined($fld));
84    
85                  if (@d) {                  if (@d) {
86                          $v->{$fld}->{ref} = 'ARRAY';                          $v->{$fld} = \@d;
                         $v->{$fld}->{sf} = \@d;  
87                  } else {                  } else {
88                          $v->{$fld}->{ref} = '';                          $v->{$fld} = 1;
89                  }                  }
90    
91          }          }
# Line 91  sub new { Line 94  sub new {
94    
95          $self->{rules} = $v;          $self->{rules} = $v;
96    
97            $log->info("validation uses rules from $self->{path}");
98    
99          $self ? return $self : return undef;          $self ? return $self : return undef;
100  }  }
101    
102    =head2 validate_errors
103    
104    Validate record and return errors
105    
106      my @errors = $validate->validate_errors( $rec );
107    
108    =cut
109    
110    sub validate_errors {
111            my $self = shift;
112    
113            my $log = $self->_get_logger();
114    
115            my $rec = shift || $log->logdie("validate_errors need record");
116    
117            $log->logdie("rec isn't HASH") unless (ref($rec) eq 'HASH');
118            $log->logdie("can't find validation rules") unless (my $r = $self->{rules});
119    
120            my @errors;
121    
122            $log->debug("rec = ", sub { Dumper($rec) }, "keys = ", keys %{ $rec });
123    
124            foreach my $f (keys %{ $rec }) {
125    
126                    next if (!defined($f) || $f eq '' || $f eq '000');
127    
128                    if (! defined($r->{$f})) {
129                            push @errors, "field '$f' shouldn't exists";
130                            next;
131                    }
132    
133                    if (ref($rec->{$f}) ne 'ARRAY') {
134                            push @errors, "field '$f' isn't repetable, probably bug in parsing input data";
135                            next;
136                    }
137    
138                    foreach my $v (@{ $rec->{$f} }) {
139                            # can we have subfields?
140                            if (ref($r->{$f}) eq 'ARRAY') {
141                                    # are values hashes? (has subfields)
142                                    if (ref($v) ne 'HASH') {
143                                            push @errors, "$f has value without subfields: $v";
144                                            next;
145                                    } else {
146                                            foreach my $sf (keys %{ $v }) {
147                                                    # permited subfield?
148                                                    if (! first { $_ eq $sf } @{ $r->{$f} }) {
149                                                            push @errors, "$f has unknown subfield: $sf";
150                                                    }
151                                            }
152                                    }
153                            } elsif (ref($v) eq 'HASH') {
154                                    push @errors, "$f has subfields which is not valid";
155                            }
156                    }
157            }
158    
159            #$log->logcluck("return from this function is ARRAY") unless wantarray;
160    
161            $log->debug("errors: ", join(", ", @errors)) if (@errors);
162    
163            return @errors;
164    }
165    
166  =head1 AUTHOR  =head1 AUTHOR
167    
168  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
Legend:
Removed from v.514  
changed lines
  Added in v.516
  ViewVC Help
Powered by ViewVC 1.1.26