0d916c38d225e043b1797739a0ed5c832c6f5a5f
[bse.git] / t / BSE / Test.pm
1 package BSE::Test;
2 use strict;
3 use vars qw(@ISA @EXPORT @EXPORT_OK);
4 @ISA = qw(Exporter);
5 require 'Exporter.pm';
6 @EXPORT = qw(base_url ok fetch_ok make_url skip make_ua);
7 @EXPORT_OK = qw(base_url ok make_ua fetch_url fetch_ok make_url skip 
8                 make_post check_form post_ok check_content follow_ok
9                 follow_refresh_ok click_ok config test_actions);
10
11 my %conf;
12
13 my $conffile = $ENV{BSETEST} || 'test.cfg';
14
15 open TESTCFG, "< $conffile" or die "Cannot open $conffile: $!";
16 while (<TESTCFG>) {
17   next if /^\s*[\#;]/;
18   chomp;
19   next unless /^\s*(\w+)\s*=\s*(.*)/ 
20     or  /^\s*(\w[^=]*\w\.\w+)\s*=\s*(.*\S)\s*$/;
21   $conf{$1} = $2;
22 }
23 close TESTCFG;
24
25 sub base_url { $conf{base_url} or die "No base_url in test config" }
26
27 sub base_securl { 
28   $conf{securl} or $conf{base_url} or die "No securl or base_url in $conffile"
29 }
30
31 sub base_dir { $conf{base_dir} or die "No base_dir in test config" }
32
33 sub mysql_name { $conf{mysql} or die "No mysql in test config" }
34
35 sub test_dsn { $conf{dsn} or die "No dsn in test config" }
36
37 sub test_dbuser { $conf{dbuser} or die "No dbuser in test config" }
38
39 sub test_dbpass { $conf{dbpass} or die "No dbpass in test config" }
40
41 sub test_dbclass { $conf{dbclass} or die "No dbclass in test config" }
42
43 sub test_sessionclass { $conf{sessionclass} or die "No sessionclass in config" }
44 sub test_perl { $conf{perl} or "/usr/bin/perl" }
45
46 sub test_conffile {
47   return $conffile;
48 }
49
50 sub config {
51   my ($name) = @_;
52
53   $conf{$name};
54 }
55
56 my $test_num = 1;
57
58 sub ok ($$) {
59   my ($ok, $desc) = @_;
60
61   if ($INC{"Test/More.pm"}) {
62     return Test::More::ok($ok, $desc);
63   }
64   else {
65     if ($ok) {
66       print "ok $test_num # $desc\n";
67     }
68     else {
69       print "not ok $test_num # $desc ",join(",", caller()),"\n";
70     }
71     ++$test_num;
72     return $ok;
73   }
74 }
75
76 sub skip {
77   my ($desc, $count) = @_;
78
79   if ($INC{"Test/More.pm"}) {
80   SKIP: {
81       Test::More::skip($desc, $count);
82     }
83   }
84   else {
85     $count ||= 1;
86     for my $i (1..$count) {
87       print "ok $test_num # skipped: $desc\n";
88       ++$test_num;
89     }
90   }
91 }
92
93 sub make_ua {
94   require WWW::Mechanize;
95   require "HTTP/Cookies.pm";
96   my $ua = WWW::Mechanize->new(onerror => undef);
97   $ua->cookie_jar(HTTP::Cookies->new);
98
99   $ua;
100 }
101
102 # in scalar context returns content
103 # in list context returns ($content, $code)
104 # $post is any data to be part of a post request
105 sub fetch_url {
106   my ($ua, $url, $method, $post) = @_;
107
108   $method ||= 'GET';
109   my $hdrs = HTTP::Headers->new;
110   $hdrs->header(Content_Length => length $post) if $post;
111   my $req = HTTP::Request->new($method, $url, $hdrs);
112   $req->content($post) if $post;
113   my $resp = $ua->request($req);
114   if (wantarray) {
115     return ($resp->content(), $resp->code(), $resp->is_success, 
116             $resp->headers_as_string());
117   }
118   else {
119     return $resp->is_success() ? $resp->content() : undef;
120   }
121 }
122
123 sub make_url {
124   my ($base, @data) = @_;
125
126   require "URI/Escape.pm";
127   my @pairs;
128   while (my ($key, $value) = splice(@data, 0, 2)) {
129     push(@pairs, "$key=".URI::uri_escape($value));
130   }
131   return $base."?".join("&",@pairs);
132 }
133
134 sub check_content {
135   my ($content, $note, $match) = @_;
136   unless (ok($content =~ /$match/s, "$note: match")) {
137     print "# wanted /$match/ got:\n";
138     my $copy = $content;
139     $copy =~ s/^/# /gm;
140     $copy .= "\n" unless $copy =~ /\n\z/;
141     print $copy;
142   }
143 }
144
145 sub _check_fetch {
146   my ($content, $code, $ok, $headers,
147       $note, $match, $headmatch) = @_;  
148
149   my $good = $ok;
150   ok($ok, "$note: fetch ($code)");
151   if ($ok) {
152     if ($match) {
153       unless (ok($content =~ /$match/s, "$note: match")) {
154         print "# wanted /$match/ got:\n";
155         my $copy = $content;
156         $copy =~ s/^/# /gm;
157         $copy .= "\n" unless $copy =~ /\n\z/;
158         print $copy;
159         $good = 0;
160       }
161     }
162     if ($headmatch) {
163       unless (ok($headers =~ /$headmatch/s, "$note: headmatch")) {
164         print "# wanted /$headmatch/ got:\n";
165         my $copy = $headers;
166         $copy =~ s/^/# /gm;
167         $copy .= "\n" unless $copy =~ /\n\z/;
168         print $copy;
169         $good = 0;
170       }
171     }
172   }
173   else {
174     my $count = 0;
175     $count++ if $match;
176     $count++ if $headmatch;
177     skip("$note: fetch failed", $count) if $count;
178   }
179
180   if (wantarray) {
181     return ($content, $code, $good, $headers);
182   }
183   else {
184     return $good ? $content : undef;
185   }
186 }
187
188 sub make_post {
189   my (@data) = @_;
190
191   require "URI/Escape.pm";
192   my @pairs;
193   while (my ($key, $value) = splice(@data, 0, 2)) {
194     push(@pairs, "$key=".URI::Escape::uri_escape($value));
195   }
196   return join("&",@pairs);
197 }
198
199 sub post_ok {
200   my ($ua, $note, $url, $data, $match, $headmatch) = @_;
201
202   $data = make_post(@$data) if ref $data;
203
204   my ($content, $code, $ok, $headers) = fetch_url($ua, $url, POST=>$data);
205
206   return _check_fetch($content, $code, $ok, $headers,
207                       $note, $match, $headmatch)
208 }
209
210 sub fetch_ok {
211   my ($ua, $note, $url, $match, $headmatch) = @_;
212
213   my $resp = $ua->get($url);
214   my $ok = $resp->is_success;
215   return _check_fetch($ua->{content}, $ua->{status}, $ok, 
216                       $ua->{res}->headers_as_string, $note, 
217                       $match, $headmatch)
218 }
219
220 sub follow_ok {
221   my ($ua, $note, $link, $match, $headmatch) = @_;
222
223   my $ok;
224   if (ref $link) {
225     my $resp = $ua->follow_link(%$link);
226     $ok = $resp->is_success;
227   }
228   else {
229     $ok = $ua->follow_link(text_regex => qr/\Q$link/);
230   }
231
232   return _check_fetch($ua->{content}, $ua->{status}, $ok, 
233                       $ua->{res}->headers_as_string, $note, 
234                       $match, $headmatch)
235 }
236
237 sub follow_refresh_ok {
238   my ($ua, $note, $match, $headmatch) = @_;
239
240   my $skip = 1;
241   ++$skip if $match;
242   ++$headmatch if $headmatch;
243   my $refresh = $ua->response->header('Refresh');
244   if (ok($refresh, "$note - refresh header")) {
245     my $url;
246     if ($refresh =~ /^\s*\d+\s*;\s*url=\"([^\"]+)\"/
247        or $refresh =~ /^\s*\d+\s*;\s*url\s*=\s*(\S+)/) {
248       $url = $1;
249       $url = URI->new_abs($url, $ua->uri);
250     }
251     else {
252       $url = $ua->uri;
253     }
254     print "# refresh to $url\n";
255     fetch_ok($ua, "$note - fetch", $url);
256   }
257   else {
258     skip("$note - skipped, not a refresh", $skip);
259   }
260 }
261
262 sub click_ok {
263   my ($ua, $note, $name, $match, $headmatch) = @_;
264
265   my $ok = ok($ua->click($name), "$note - click");
266   return _check_fetch($ua->{content}, $ua->{status}, $ok, 
267                       $ua->{res}->headers_as_string, $note, 
268                       $match, $headmatch)
269 }
270
271 sub check_form {
272   my ($content, $note, %checks) = @_;
273
274   require 'HTML/Parser.pm';
275   require 'HTML/Entities.pm';
276   my $in;
277   my $keep;
278   my $saved = '';
279   my %todo = %checks;
280   my $inselect;
281   my $selname;
282   my $checked_sel_value;
283   my $textname;
284   my %values;
285
286   my $text =
287     sub {
288       my ($t) = @_;
289       $saved .= $t if $keep;
290     };
291   my $start = 
292     sub {
293       my ($tagname, $attr) = @_;
294
295       if ($tagname eq 'input') {
296         my $name = $attr->{name};
297         if ($name && $todo{$name}) {
298           ok(1, "$note - $name - field is present");
299           $values{$name} = $attr->{$name};
300           if (defined $todo{$name}[0]) {
301             my $cvalue = $checks{$name}[0];
302             my $fvalue = $attr->{value};
303             if (defined $fvalue) {
304               ok($cvalue eq $fvalue, "$note - $name - comparing values");
305             }
306             else {
307               ok(0, "$note - $name - value is not present");
308             }
309           }
310           if (defined $todo{$name}[1]) {
311             my $ttype = $todo{$name}[1];
312             my $ftype = $attr->{type};
313             if (defined $ftype) {
314               ok($ttype eq $ftype, "$note - $name - comparing types");
315             }
316             else {
317               ok(0, "$note - $name - type not present");
318             }
319           }
320           delete $todo{$name};
321         }
322       }
323       elsif ($tagname eq 'select') {
324         $selname = $attr->{name};
325         
326         if ($todo{$selname}) {
327           ok(1, "$note - $selname - field is present");
328           $inselect = 1;
329           if (defined $todo{$selname}[1]) {
330             $checked_sel_value = 0;
331             my $ttype = $todo{$selname}[1];
332             ok ($ttype eq 'select', "$note - $selname - checking type (select)");
333           }
334         }
335       }
336       elsif ($tagname eq 'option' && $inselect) {
337         unless (exists $attr->{value}) {
338           print "# warning - option in select $selname missing value\n";
339         }
340         if (exists $attr->{selected}) {
341           $checked_sel_value = 1;
342           $values{$selname} = $attr->{value};
343           if (defined $todo{$selname}[0]) {
344             my $fvalue = $attr->{value};
345             my $tvalue = $todo{$selname}[0];
346             if (defined $fvalue) {
347               ok($fvalue eq $tvalue, "$note - $selname - checking value ($fvalue vs $tvalue)");
348             }
349             else {
350               ok(0, "$note - $selname - no value supplied");
351             }
352           }
353         }
354       }
355       elsif ($tagname eq 'textarea') {
356         $textname = $attr->{name};
357         $saved = '';
358         ++$keep;
359       }
360     };
361   my $end =
362     sub {
363       my ($tagname) = @_;
364
365       if ($tagname eq 'select' && $inselect) {
366         if (!$checked_sel_value) {
367           ok(0, "$note - $selname - no value selected");
368         }
369         delete $todo{$selname};
370       }
371       elsif ($tagname eq 'textarea') {
372         $keep = 0;
373         if ($todo{$textname}) {
374           my $fvalue = HTML::Entities::decode_entities($saved);
375           $values{$textname} = $fvalue;
376           ok(1, "$note - $textname - field exists");
377           if (defined $todo{$textname}[0]) {
378             my $tvalue = $todo{$textname}[0];
379             ok($tvalue eq $fvalue, "$note - $textname - checking value($tvalue vs $fvalue)");
380           }
381           if (defined $todo{$textname}[1]) {
382             ok ($todo{$textname}[1] eq 'textarea',
383                 "$note - $textname - check field type");
384           }
385           delete $todo{$textname};
386         }
387       }
388     };
389   my $p = HTML::Parser->new( text_h => [ $text, "dtext" ],
390                              start_h => [ $start, "tagname, attr" ],
391                              end_h => [ $end, "tagname" ]);
392   $p->parse($content);
393   $p->eof;
394   for my $name (keys %todo) {
395     ok(0, "$note - $name - field doesn't exist");
396     my $count = 0;
397     ++$count if defined $todo{$name}[0];
398     ++$count if defined $todo{$name}[1];
399     skip("$note - $name - no field", $count);
400   }
401
402   return %values;
403 }
404
405 # test that all actions have methods for a given dispatcher class
406 sub test_actions {
407   my ($class) = @_;
408
409   my $tb = Test::Builder->new;
410
411   my $obj = $class->new;
412   my $actions = $obj->actions;
413   my @bad;
414   for my $action (sort keys %$actions) {
415     my $method = "req_$action";
416     unless ($obj->can($method)) {
417       push @bad, $action;
418     }
419   }
420   $tb->ok(!@bad, "check all actions have a method for $class");
421   print STDERR "No method found for $class action $_\n" for @bad;
422
423   return !@bad;
424 }
425
426 1;
427