0.11_09 commit
[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);
9
10 my %conf;
11
12 open TESTCFG, "< test.cfg" or die "Cannot open test.cfg: $!";
13 while (<TESTCFG>) {
14   next if /^\s*[\#;]/;
15   chomp;
16   next unless /^\s*(\w+)\s*=\s*(.*)/;
17   $conf{$1} = $2;
18 }
19 close TESTCFG;
20
21 sub base_url { $conf{base_url} or die "No base_url in test config" }
22
23 sub base_dir { $conf{base_dir} or die "No base_dir in test config" }
24
25 sub mysql_name { $conf{mysql} or die "No mysql in test config" }
26
27 sub test_dsn { $conf{dsn} or die "No dsn in test config" }
28
29 sub test_dbuser { $conf{dbuser} or die "No dbuser in test config" }
30
31 sub test_dbpass { $conf{dbpass} or die "No dbpass in test config" }
32
33 sub test_dbclass { $conf{dbclass} or die "No dbclass in test config" }
34
35 sub test_sessionclass { $conf{sessionclass} or die "No sessionclass in config" }
36
37 my $test_num = 1;
38
39 sub ok ($$) {
40   my ($ok, $desc) = @_;
41
42   if ($ok) {
43     print "ok $test_num # $desc\n";
44   }
45   else {
46     print "not ok $test_num # $desc ",join(",", caller()),"\n";
47   }
48   ++$test_num;
49   return $ok;
50 }
51
52 sub 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
62 sub 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
74 sub fetch_url {
75   my ($ua, $url, $method, $post) = @_;
76
77   $method ||= 'GET';
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;
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
92 sub 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
103 sub _check_fetch {
104   my ($content, $code, $ok, $headers,
105       $note, $match, $headmatch) = @_;  
106
107   my $good = $ok;
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;
117         $good = 0;
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;
127         $good = 0;
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   }
137
138   if (wantarray) {
139     return ($content, $code, $good, $headers);
140   }
141   else {
142     return $good ? $content : undef;
143   }
144 }
145
146 sub 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
157 sub 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
168 sub 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
176 sub 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;
308 }
309
310 1;
311