0.11_09 commit
[bse.git] / t / BSE / Test.pm
CommitLineData
5ba09b9b
TC
1package BSE::Test;
2use strict;
3use vars qw(@ISA @EXPORT @EXPORT_OK);
4@ISA = qw(Exporter);
5require 'Exporter.pm';
6@EXPORT = qw(base_url ok fetch_ok make_url skip make_ua);
3bc94f98
TC
7@EXPORT_OK = qw(base_url ok make_ua fetch_url fetch_ok make_url skip
8 make_post check_form post_ok);
5ba09b9b
TC
9
10my %conf;
11
12open TESTCFG, "< test.cfg" or die "Cannot open test.cfg: $!";
13while (<TESTCFG>) {
14 next if /^\s*[\#;]/;
15 chomp;
16 next unless /^\s*(\w+)\s*=\s*(.*)/;
17 $conf{$1} = $2;
18}
19close TESTCFG;
20
21sub base_url { $conf{base_url} or die "No base_url in test config" }
22
3bc94f98
TC
23sub base_dir { $conf{base_dir} or die "No base_dir in test config" }
24
25sub mysql_name { $conf{mysql} or die "No mysql in test config" }
26
27sub test_dsn { $conf{dsn} or die "No dsn in test config" }
28
29sub test_dbuser { $conf{dbuser} or die "No dbuser in test config" }
30
31sub test_dbpass { $conf{dbpass} or die "No dbpass in test config" }
32
33sub test_dbclass { $conf{dbclass} or die "No dbclass in test config" }
34
35sub test_sessionclass { $conf{sessionclass} or die "No sessionclass in config" }
36
5ba09b9b
TC
37my $test_num = 1;
38
39sub ok ($$) {
40 my ($ok, $desc) = @_;
41
42 if ($ok) {
43 print "ok $test_num # $desc\n";
44 }
45 else {
3bc94f98 46 print "not ok $test_num # $desc ",join(",", caller()),"\n";
5ba09b9b
TC
47 }
48 ++$test_num;
49 return $ok;
50}
51
52sub skip {
53 my ($desc, $count) = @_;
54
55 $count ||= 1;
56 for my $i (1..$count) {
57 print "ok $test_num # skipped: $desc\n";
58 ++$test_num;
59 }
60}
61
62sub make_ua {
63 require "LWP/UserAgent.pm";
64 require "HTTP/Cookies.pm";
65 my $ua = LWP::UserAgent->new;
66 $ua->cookie_jar(HTTP::Cookies->new);
67
68 $ua;
69}
70
71# in scalar context returns content
72# in list context returns ($content, $code)
73# $post is any data to be part of a post request
74sub fetch_url {
75 my ($ua, $url, $method, $post) = @_;
76
77 $method ||= 'GET';
3bc94f98
TC
78 my $hdrs = HTTP::Headers->new;
79 $hdrs->header(Content_Length => length $post) if $post;
80 my $req = HTTP::Request->new($method, $url, $hdrs);
81 $req->content($post) if $post;
5ba09b9b
TC
82 my $resp = $ua->request($req);
83 if (wantarray) {
84 return ($resp->content(), $resp->code(), $resp->is_success,
85 $resp->headers_as_string());
86 }
87 else {
88 return $resp->is_success() ? $resp->content() : undef;
89 }
90}
91
92sub make_url {
93 my ($base, @data) = @_;
94
95 require "URI/Escape.pm";
96 my @pairs;
97 while (my ($key, $value) = splice(@data, 0, 2)) {
98 push(@pairs, "$key=".URI::uri_escape($value));
99 }
100 return $base."?".join("&",@pairs);
101}
102
3bc94f98
TC
103sub _check_fetch {
104 my ($content, $code, $ok, $headers,
105 $note, $match, $headmatch) = @_;
5ba09b9b 106
3bc94f98 107 my $good = $ok;
5ba09b9b
TC
108 ok($ok, "$note: fetch ($code)");
109 if ($ok) {
110 if ($match) {
111 unless (ok($content =~ /$match/s, "$note: match")) {
112 print "# wanted /$match/ got:\n";
113 my $copy = $content;
114 $copy =~ s/^/# /gm;
115 $copy .= "\n" unless $copy =~ /\n\z/;
116 print $copy;
3bc94f98 117 $good = 0;
5ba09b9b
TC
118 }
119 }
120 if ($headmatch) {
121 unless (ok($headers =~ /$headmatch/s, "$note: headmatch")) {
122 print "# wanted /$headmatch/ got:\n";
123 my $copy = $headers;
124 $copy =~ s/^/# /gm;
125 $copy .= "\n" unless $copy =~ /\n\z/;
126 print $copy;
3bc94f98 127 $good = 0;
5ba09b9b
TC
128 }
129 }
130 }
131 else {
132 my $count = 0;
133 $count++ if $match;
134 $count++ if $headmatch;
135 skip("$note: fetch failed", $count) if $count;
136 }
3bc94f98
TC
137
138 if (wantarray) {
139 return ($content, $code, $good, $headers);
140 }
141 else {
142 return $good ? $content : undef;
143 }
144}
145
146sub make_post {
147 my (@data) = @_;
148
149 require "URI/Escape.pm";
150 my @pairs;
151 while (my ($key, $value) = splice(@data, 0, 2)) {
152 push(@pairs, "$key=".URI::Escape::uri_escape($value));
153 }
154 return join("&",@pairs);
155}
156
157sub post_ok {
158 my ($ua, $note, $url, $data, $match, $headmatch) = @_;
159
160 $data = make_post(@$data) if ref $data;
161
162 my ($content, $code, $ok, $headers) = fetch_url($ua, $url, POST=>$data);
163
164 return _check_fetch($content, $code, $ok, $headers,
165 $note, $match, $headmatch)
166}
167
168sub fetch_ok {
169 my ($ua, $note, $url, $match, $headmatch) = @_;
170
171 my ($content, $code, $ok, $headers) = fetch_url($ua, $url);
172 return _check_fetch($content, $code, $ok, $headers,
173 $note, $match, $headmatch)
174}
175
176sub check_form {
177 my ($content, $note, %checks) = @_;
178
179 require 'HTML/Parser.pm';
180 require 'HTML/Entities.pm';
181 my $in;
182 my $keep;
183 my $saved = '';
184 my %todo = %checks;
185 my $inselect;
186 my $selname;
187 my $checked_sel_value;
188 my $textname;
189 my %values;
190
191 my $text =
192 sub {
193 my ($t) = @_;
194 $saved .= $t if $keep;
195 };
196 my $start =
197 sub {
198 my ($tagname, $attr) = @_;
199
200 if ($tagname eq 'input') {
201 my $name = $attr->{name};
202 if ($name && $todo{$name}) {
203 ok(1, "$note - $name - field is present");
204 $values{$name} = $attr->{$name};
205 if (defined $todo{$name}[0]) {
206 my $cvalue = $checks{$name}[0];
207 my $fvalue = $attr->{value};
208 if (defined $fvalue) {
209 ok($cvalue eq $fvalue, "$note - $name - comparing values");
210 }
211 else {
212 ok(0, "$note - $name - value is not present");
213 }
214 }
215 if (defined $todo{$name}[1]) {
216 my $ttype = $todo{$name}[1];
217 my $ftype = $attr->{type};
218 if (defined $ftype) {
219 ok($ttype eq $ftype, "$note - $name - comparing types");
220 }
221 else {
222 ok(0, "$note - $name - type not present");
223 }
224 }
225 delete $todo{$name};
226 }
227 }
228 elsif ($tagname eq 'select') {
229 $selname = $attr->{name};
230
231 if ($todo{$selname}) {
232 ok(1, "$note - $selname - field is present");
233 $inselect = 1;
234 if (defined $todo{$selname}[1]) {
235 $checked_sel_value = 0;
236 my $ttype = $todo{$selname}[1];
237 ok ($ttype eq 'select', "$note - $selname - checking type (select)");
238 }
239 }
240 }
241 elsif ($tagname eq 'option' && $inselect) {
242 unless (exists $attr->{value}) {
243 print "# warning - option in select $selname missing value\n";
244 }
245 if (exists $attr->{selected}) {
246 $checked_sel_value = 1;
247 $values{$selname} = $attr->{value};
248 if (defined $todo{$selname}[0]) {
249 my $fvalue = $attr->{value};
250 my $tvalue = $todo{$selname}[0];
251 if (defined $fvalue) {
252 ok($fvalue eq $tvalue, "$note - $selname - checking value ($fvalue vs $tvalue)");
253 }
254 else {
255 ok(0, "$note - $selname - no value supplied");
256 }
257 }
258 }
259 }
260 elsif ($tagname eq 'textarea') {
261 $textname = $attr->{name};
262 $saved = '';
263 ++$keep;
264 }
265 };
266 my $end =
267 sub {
268 my ($tagname) = @_;
269
270 if ($tagname eq 'select' && $inselect) {
271 if (!$checked_sel_value) {
272 ok(0, "$note - $selname - no value selected");
273 }
274 delete $todo{$selname};
275 }
276 elsif ($tagname eq 'textarea') {
277 $keep = 0;
278 if ($todo{$textname}) {
279 my $fvalue = HTML::Entities::decode_entities($saved);
280 $values{$textname} = $fvalue;
281 ok(1, "$note - $textname - field exists");
282 if (defined $todo{$textname}[0]) {
283 my $tvalue = $todo{$textname}[0];
284 ok($tvalue eq $fvalue, "$note - $textname - checking value");
285 }
286 if (defined $todo{$textname}[1]) {
287 ok ($todo{$textname}[1] eq 'textarea',
288 "$note - $textname - check field type");
289 }
290 delete $todo{$textname};
291 }
292 }
293 };
294 my $p = HTML::Parser->new( text_h => [ $text, "dtext" ],
295 start_h => [ $start, "tagname, attr" ],
296 end_h => [ $end, "tagname" ]);
297 $p->parse($content);
298 $p->eof;
299 for my $name (keys %todo) {
300 ok(0, "$note - $name - field doesn't exist");
301 my $count = 0;
302 ++$count if defined $todo{$name}[0];
303 ++$count if defined $todo{$name}[1];
304 skip("$note - $name - no field", $count);
305 }
306
307 return %values;
5ba09b9b
TC
308}
309
3101;
311