8
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
12
# $Id: Checker.pm,v 1.2 2000/12/19 22:54:56 helgew Exp $ RCS Identification
21
my $class = ref($proto) || $proto;
28
#######################
29
# Class method: check #
30
#######################
34
my ($self, @parameters) = @_;
35
my ($data,$dict,$options);
38
while ($_ = shift @parameters) {
39
$data = shift @parameters if /-datablock/;
40
$dict = shift @parameters if /-dictionary/;
41
$options = shift @parameters if /-options/;
44
my ($n, $d, $save, @saves, $cat, @cats, $item, @items);
45
my (@depend_items, $depend_item);
47
my (%dict_lookup, %item_lookup, %cat_lookup);
48
my (@parent_items, @child_items);
49
my (%cp_hash, $cp_hash_ref); #child parent hash
51
my ($construct, @constructs, $code, @code_data, @codes, %item_types);
52
my ($debug, $log,$problem);
54
$log = 1 if $options =~ /l/;
55
$debug = 1 if $options =~ /d/;
57
if ( $data->type eq 'dictionary' ) {
58
print STDERR "Method check_against_dict is to be invoked only on\n",
59
"DataBlock objects, not on dictionaries themselves.\n";
63
print STDERR "-"x50,"\n" if $log;
64
print STDERR "$0 ", ctime(),"\n" if $log;
65
print STDERR "Checking ",$data->title,
66
" against ",$dict->title,"\n" if $log;
68
@items = $data->get_items;
69
@cats = $data->get_categories;
70
@saves = $dict->get_save_blocks;
72
#make a dictionary lookup hash -- keys: lowercase, values: original case
73
foreach $save (@saves) {
74
$dict_lookup{lc($save)} = $save;
77
#same for an file item lookup hash
78
foreach $item (@items) {
79
$item_lookup{lc($item)} = $item;
82
#same for a file category lookup hash
83
foreach $cat (@cats) {
84
$cat_lookup{lc($cat)} = $cat;
87
# 1) checking whether items are present in dictionary
88
# ---------------------------------------------------
90
print STDERR "Checking whether items are present in dictionary\n" if $log;
92
foreach $item (@items) {
93
if ( ! exists $dict_lookup{lc($item)} ) {
95
print STDERR "\t$item not in dictionary\n" if $log;
99
# 2) checking for presence of mandatory items in file
100
# ---------------------------------------------------
102
print STDERR "Checking whether mandatory items ",
103
"are present in file\n" if $log;
105
foreach $save ( @saves ) {
106
if ( $save =~ /^(_\S+?)\.\S+/ ) { # $save is item, not cat
109
$mand = ($dict->get_item_data(-save=>$save,
110
-item=>"_item.mandatory_code"))[0];
111
if ( $mand eq "yes" ) { #item is mandatory
112
if ( exists $cat_lookup{lc($cat)} ) { #the cat is in the file
113
if ( ! exists $item_lookup{lc($item)} ) { #oops, should've
116
print STDERR "\t$item not present\n" if $log;
123
# 3) checking for presence of dependent items in file
124
# ---------------------------------------------------
126
print STDERR "Checking whether dependent items",
127
" are present in file\n" if $log;
129
foreach $item ( @items ) {
130
if ( exists $dict_lookup{lc($item)} ) {
131
@depend_items = $dict->get_item_data(
132
-save=>$dict_lookup{lc($item)},
133
-item=>"_item_dependent.dependent_name");
134
foreach $depend_item ( @depend_items ) {
135
if ( ! exists $item_lookup{lc($depend_item)} ) {
137
print STDERR "\t$depend_item not present ",
138
"(required by $item)\n" if $log;
144
# 4) checking for presence of parent items
145
# ----------------------------------------
147
print STDERR "Checking for presence of parent items\n" if $log;
149
if ( -r "cp_hash" ) {
150
print "Retrieving previously stored cp_hash\n" if $log;
151
$cp_hash_ref = Storable::retrieve("cp_hash");
152
%cp_hash = %$cp_hash_ref;
155
print "Assembling and storing new cp_hash\n" if $log;
156
foreach $save ( @saves ) {
157
@parent_items = $dict->get_item_data(-save=>$save,
158
-item=>"_item_linked.parent_name");
159
@child_items = $dict->get_item_data(-save=>$save,
160
-item=>"_item_linked.child_name");
161
if ( $#parent_items >=0 ) {
162
foreach $n ( 0..$#parent_items ) {
163
$cp_hash{lc($child_items[$n])} = lc($parent_items[$n]);
167
Storable::store \%cp_hash, "cp_hash";
170
foreach $item ( @items ) {
171
if ( exists $cp_hash{lc($item)} ) {
172
if ( ! exists $item_lookup{$cp_hash{lc($item)}} ) {
173
print STDERR "\t",$cp_hash{lc($item)}, " not present ",
174
"(parent to $item)\n" if $log;
179
# 5) checking for correct item types
180
# ----------------------------------
182
print STDERR "Checking values against type definitions\n" if $log;
184
@constructs=$dict->get_item_data(-save=>'-',
185
-item=>'_item_type_list.construct');
186
@codes=$dict->get_item_data(-save=>'-',
187
-item=>'_item_type_list.code');
188
foreach $n (0..$#codes) {
189
$item_types{$codes[$n]} = $constructs[$n];
192
foreach $item ( @items ) {
194
print STDERR "data item: $item\n" if $debug;
195
print STDERR "dict item: ",$dict_lookup{lc($item)},"\n" if $debug;
196
if ($dict_lookup{lc($item)}) {
197
$code = ($dict->get_item_data
198
(-save=>$dict_lookup{lc($item)},
199
-item=>'_item_type.code'))[0];
200
# not all items have this defined
201
$construct = $item_types{$code} if $code;
205
print STDERR "type code undefined\n" if $debug;
208
@values = $data->get_item_data(-item=>$item);
209
print STDERR "values 0..",$#values,"\n" if $debug;
211
foreach $value (@values) {
212
if ( $value eq '.' || $value eq '?' ) {
213
print STDERR "$n item value undefined\n" if $debug;
215
elsif ( $value =~ /^$construct$/ ) {
216
print STDERR "$n type $code ok\n" if $debug;
221
print STDERR "\t","-"x14,"\n","\ttype mismatch:\n";
222
print STDERR "\titem: $item\n";
223
print STDERR "\titeration: $n\n";
224
print STDERR "\tvalue: $value\n";
225
print STDERR "\tcode: $code\n";
226
print STDERR "\tconstruct: $construct\n";
233
return ( $problem ? 0 : 1 ); #returns 1 if check ok (no problem)
234
#returns 0 if problem found
242
STAR::Checker - Perl extension for checking DataBlock objects
246
This documentation refers to version 0.02 of this module.
252
$check = STAR::Checker->check( -datablock=>$ARGV[0],
253
-dictionary=>$ARGV[1] );
257
Contains the checker object, with methods for checking DataBlock object against
258
STAR rules and against a specified dictionary.
259
DataBlock objects are created by Parser and modified by DataBlock.
265
Usage: $check = STAR::Checker->check(-datablock=>$data,
266
-dictionary=>$dict [,
267
-options=>$options ] );
269
Checks the DataBlock object C<$data> against the dictionary object
270
C<$dict> (see STAR::Parser and STAR::DataBlock). Checks 1) whether
271
all items in the DataBlock are defined in the dictionary,
272
2) whether mandatory items are present in the file, 3) whether dependent
273
items are present in the file (e.g. cartn_x makes cartn_y and cartn_z
274
dependent), 4) whether parent items are present,
275
and 5) whether the item values in the DataBlock conform to the item type
276
definitions in the dictionary.
278
Returns 1 if the check was successful (no problems were found),
279
and 0 if the check was unsuccessful (problems were found).
280
A list of the specific problems is written to STDERR when C<-options=E<gt>'l'>
285
Wolfgang Bluhm, mail@wbluhm.com
287
=head2 Acknowledgments
289
Thanks to Phil Bourne, Helge Weissig, Anne Kuller, Doug Greer,
290
Michele Bluhm, and others for support, help, and comments.
294
A full copyright statement is provided with the distribution
295
Copyright (c) 2000 University of California, San Diego
299
STAR::Parser, STAR::DataBlock, STAR::Dictionary.
added
removed
0CPAN/STAR-Parser-0.59/lib/STAR/Checker.pm
