1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
|
#!/usr/bin/env perl
# -*-mode:cperl; indent-tabs-mode: nil-*-
## Various code analysis
use 5.006;
use strict;
use warnings;
use Test::More;
use Data::Dumper;
select(($|=1,select(STDERR),$|=1)[1]);
if (! $ENV{RELEASE_TESTING}) {
plan (skip_all => 'Test skipped unless environment variable RELEASE_TESTING is set');
}
## The 'bucardo' script
my $file = 'bucardo';
my $fh;
if (! open $fh, '<', $file) {
$file = "../$file";
if (! open $fh, '<', $file) {
BAIL OUT qq{Could not find the file '$file'!};
}
}
check_subroutines($file, $fh);
check_whitespace($file, $fh);
check_hash_names($file, $fh);
close $fh or die qq{Could not close filehandle for "$file": $!\n};
pass "Scanned file $file";
$file = 'Bucardo.pm';
if (! open $fh, '<', $file) {
$file = "../$file";
if (! open $fh, '<', $file) {
BAIL OUT qq{Could not find the file '$file'!};
}
}
check_whitespace($file, $fh);
check_hash_names($file, $fh);
pass "Scanned file $file";
done_testing();
sub check_subroutines {
## Check that each subroutine has a contract stating a description line,
## an argument list, and what it returns
## Also check that the closing brace indicates the end of the sub
## Arguments: two
## 1. File name
## 2. file handle
## Returns: undef
my $filename = shift;
my $fh = shift;
## Rewind to the beginning
seek $fh, 0, 0;
my $subname = '';
my %found;
my $step = 1;
## Just in case, reset the line counter
$. = 0;
while (<$fh>) {
## Are we still in a subroutine?
if ($subname) {
## Skip things that look like the end of the sub, but are not
next if /^};$/;
## Check for the end of the subroutine
if (/^}(.*)/) {
## Is there a comment indicating the end of the sub?
my $end = $1;
if ($end !~ /^ ## end of (\w+)$/) {
fail "No ending comment for sub ${filename}::$subname at line $.";
}
my $endname = $1;
if ($endname ne $subname) {
fail "End of sub ${filename}::$subname has wrong name at line $.";
}
## Did this subroutine have an 'Arguments' comment?
if (! exists $found{argument}) {
fail "No argument line found for sub ${filename}::$subname";
}
delete $found{argument};
## Did this subroutine have a 'Returns' comment?
if (! exists $found{returns}) {
fail "No returns line found for sub ${filename}::$subname";
}
delete $found{returns};
if (! keys %found) {
pass "Subroutine ${filename}::$subname passed all tests";
}
undef %found;
$subname = '';
next;
}
## Skip empty lines
next if /^\s*$/;
## Make sure we have a description as the first comment
if (1 == $step) {
if (! /^\s*## [A-Z]/) {
fail "No description at start of sub ${filename}::$subname";
}
$step = 2;
next;
}
## Must state the number of arguments
if (2 == $step) {
## Check for and process an "Arguments:" line
if (/^\s*## Arguments: (\w+)/) {
my $word = $1;
if ($word !~ /^[a-z]/) {
fail "Argument line does not start with a lowercase letter for sub ${filename}::$subname";
}
$found{argument} = 1;
$step = 3;
}
}
## Must tell us what it returns
if (3 == $step) {
## Check for an process a "Returns:" line
if (/^\s*## Returns: \w.+/) {
$found{returns} = 1;
$step = 4;
}
}
} ## end if inside a subroutine
if (/^sub (\w+)/) {
$subname = $1;
$step = 1;
}
}
## Do *not* close the file handle!
return;
} ## end of check_for_contract
sub check_whitespace {
## Check various whitespace rules
## Arguments: two
## 1. File name
## 2. file handle
## Returns: undef
my $filename = shift;
my $fh = shift;
## Rewind to the beginning
seek $fh, 0, 0;
my %found;
## Just in case, reset the line counter
$. = 0;
while (<$fh>) {
if (/ +$/) {
fail "Trailing whitespace found at line $. of file $filename";
}
}
## Do *not* close the file handle!
return;
} ## end of check_whitespace
sub check_hash_names {
## Make sure our hashes stay simple
## Arguments: two
## 1. File name
## 2. file handle
## Returns: undef
my $filename = shift;
my $fh = shift;
## Rewind to the beginning
seek $fh, 0, 0;
my %found;
## Just in case, reset the line counter
$. = 0;
while (<$fh>) {
next if /[mq]{/;
next if /(?:map|grep|first|eval) *{/;
while (m/(?<!q[wqrx])\{(.+?)\}/g) {
my $word = $1;
next if $word =~ /^q[wr]/;
if ($word =~ /\w \w/) {
fail "Invalid hash name ($word) at line $. of $filename";
}
last;
}
}
## Do *not* close the file handle!
return;
} ## end of check_hash_names
|
