[bse.git] / t / BSE / Test.pm

package BSE::Test;
use strict;
use vars qw(@ISA @EXPORT @EXPORT_OK);
@ISA = qw(Exporter);
require 'Exporter.pm';
@EXPORT = qw(base_url ok fetch_ok make_url skip make_ua);
@EXPORT_OK = qw(base_url ok make_ua fetch_url fetch_ok make_url skip 
                make_post check_form post_ok);

my %conf;

my $conffile = $ENV{BSETEST} || 'test.cfg';

open TESTCFG, "< $conffile" or die "Cannot open $conffile: $!";
while (<TESTCFG>) {
  next if /^\s*[\#;]/;
  chomp;
  next unless /^\s*(\w+)\s*=\s*(.*)/;
  $conf{$1} = $2;
}
close TESTCFG;

sub base_url { $conf{base_url} or die "No base_url in test config" }

sub base_securl { 
  $conf{securl} or $conf{base_url} or die "No securl or base_url in $conffile"
}

sub base_dir { $conf{base_dir} or die "No base_dir in test config" }

sub mysql_name { $conf{mysql} or die "No mysql in test config" }

sub test_dsn { $conf{dsn} or die "No dsn in test config" }

sub test_dbuser { $conf{dbuser} or die "No dbuser in test config" }

sub test_dbpass { $conf{dbpass} or die "No dbpass in test config" }

sub test_dbclass { $conf{dbclass} or die "No dbclass in test config" }

sub test_sessionclass { $conf{sessionclass} or die "No sessionclass in config" }

my $test_num = 1;

sub ok ($$) {
  my ($ok, $desc) = @_;

  if ($ok) {
    print "ok $test_num # $desc\n";
  }
  else {
    print "not ok $test_num # $desc ",join(",", caller()),"\n";
  }
  ++$test_num;
  return $ok;
}

sub skip {
  my ($desc, $count) = @_;

  $count ||= 1;
  for my $i (1..$count) {
    print "ok $test_num # skipped: $desc\n";
    ++$test_num;
  }
}

sub make_ua {
  require "LWP/UserAgent.pm";
  require "HTTP/Cookies.pm";
  my $ua = LWP::UserAgent->new;
  $ua->cookie_jar(HTTP::Cookies->new);

  $ua;
}

# in scalar context returns content
# in list context returns ($content, $code)
# $post is any data to be part of a post request
sub fetch_url {
  my ($ua, $url, $method, $post) = @_;

  $method ||= 'GET';
  my $hdrs = HTTP::Headers->new;
  $hdrs->header(Content_Length => length $post) if $post;
  my $req = HTTP::Request->new($method, $url, $hdrs);
  $req->content($post) if $post;
  my $resp = $ua->request($req);
  if (wantarray) {
    return ($resp->content(), $resp->code(), $resp->is_success, 
	    $resp->headers_as_string());
  }
  else {
    return $resp->is_success() ? $resp->content() : undef;
  }
}

sub make_url {
  my ($base, @data) = @_;

  require "URI/Escape.pm";
  my @pairs;
  while (my ($key, $value) = splice(@data, 0, 2)) {
    push(@pairs, "$key=".URI::uri_escape($value));
  }
  return $base."?".join("&",@pairs);
}

sub _check_fetch {
  my ($content, $code, $ok, $headers,
      $note, $match, $headmatch) = @_;  

  my $good = $ok;
  ok($ok, "$note: fetch ($code)");
  if ($ok) {
    if ($match) {
      unless (ok($content =~ /$match/s, "$note: match")) {
	print "# wanted /$match/ got:\n";
	my $copy = $content;
	$copy =~ s/^/# /gm;
	$copy .= "\n" unless $copy =~ /\n\z/;
	print $copy;
	$good = 0;
      }
    }
    if ($headmatch) {
      unless (ok($headers =~ /$headmatch/s, "$note: headmatch")) {
	print "# wanted /$headmatch/ got:\n";
	my $copy = $headers;
	$copy =~ s/^/# /gm;
	$copy .= "\n" unless $copy =~ /\n\z/;
	print $copy;
	$good = 0;
      }
    }
  }
  else {
    my $count = 0;
    $count++ if $match;
    $count++ if $headmatch;
    skip("$note: fetch failed", $count) if $count;
  }

  if (wantarray) {
    return ($content, $code, $good, $headers);
  }
  else {
    return $good ? $content : undef;
  }
}

sub make_post {
  my (@data) = @_;

  require "URI/Escape.pm";
  my @pairs;
  while (my ($key, $value) = splice(@data, 0, 2)) {
    push(@pairs, "$key=".URI::Escape::uri_escape($value));
  }
  return join("&",@pairs);
}

sub post_ok {
  my ($ua, $note, $url, $data, $match, $headmatch) = @_;

  $data = make_post(@$data) if ref $data;

  my ($content, $code, $ok, $headers) = fetch_url($ua, $url, POST=>$data);

  return _check_fetch($content, $code, $ok, $headers,
		      $note, $match, $headmatch)
}

sub fetch_ok {
  my ($ua, $note, $url, $match, $headmatch) = @_;

  my ($content, $code, $ok, $headers) = fetch_url($ua, $url);
  return _check_fetch($content, $code, $ok, $headers,
		      $note, $match, $headmatch)
}

sub check_form {
  my ($content, $note, %checks) = @_;

  require 'HTML/Parser.pm';
  require 'HTML/Entities.pm';
  my $in;
  my $keep;
  my $saved = '';
  my %todo = %checks;
  my $inselect;
  my $selname;
  my $checked_sel_value;
  my $textname;
  my %values;

  my $text =
    sub {
      my ($t) = @_;
      $saved .= $t if $keep;
    };
  my $start = 
    sub {
      my ($tagname, $attr) = @_;

      if ($tagname eq 'input') {
	my $name = $attr->{name};
	if ($name && $todo{$name}) {
	  ok(1, "$note - $name - field is present");
	  $values{$name} = $attr->{$name};
	  if (defined $todo{$name}[0]) {
	    my $cvalue = $checks{$name}[0];
	    my $fvalue = $attr->{value};
	    if (defined $fvalue) {
	      ok($cvalue eq $fvalue, "$note - $name - comparing values");
	    }
	    else {
	      ok(0, "$note - $name - value is not present");
	    }
	  }
	  if (defined $todo{$name}[1]) {
	    my $ttype = $todo{$name}[1];
	    my $ftype = $attr->{type};
	    if (defined $ftype) {
	      ok($ttype eq $ftype, "$note - $name - comparing types");
	    }
	    else {
	      ok(0, "$note - $name - type not present");
	    }
	  }
	  delete $todo{$name};
	}
      }
      elsif ($tagname eq 'select') {
	$selname = $attr->{name};
	
	if ($todo{$selname}) {
	  ok(1, "$note - $selname - field is present");
	  $inselect = 1;
	  if (defined $todo{$selname}[1]) {
	    $checked_sel_value = 0;
	    my $ttype = $todo{$selname}[1];
	    ok ($ttype eq 'select', "$note - $selname - checking type (select)");
	  }
	}
      }
      elsif ($tagname eq 'option' && $inselect) {
	unless (exists $attr->{value}) {
	  print "# warning - option in select $selname missing value\n";
	}
	if (exists $attr->{selected}) {
	  $checked_sel_value = 1;
	  $values{$selname} = $attr->{value};
	  if (defined $todo{$selname}[0]) {
	    my $fvalue = $attr->{value};
	    my $tvalue = $todo{$selname}[0];
	    if (defined $fvalue) {
	      ok($fvalue eq $tvalue, "$note - $selname - checking value ($fvalue vs $tvalue)");
	    }
	    else {
	      ok(0, "$note - $selname - no value supplied");
	    }
	  }
	}
      }
      elsif ($tagname eq 'textarea') {
	$textname = $attr->{name};
	$saved = '';
	++$keep;
      }
    };
  my $end =
    sub {
      my ($tagname) = @_;

      if ($tagname eq 'select' && $inselect) {
	if (!$checked_sel_value) {
	  ok(0, "$note - $selname - no value selected");
	}
	delete $todo{$selname};
      }
      elsif ($tagname eq 'textarea') {
	$keep = 0;
	if ($todo{$textname}) {
	  my $fvalue = HTML::Entities::decode_entities($saved);
	  $values{$textname} = $fvalue;
	  ok(1, "$note - $textname - field exists");
	  if (defined $todo{$textname}[0]) {
	    my $tvalue = $todo{$textname}[0];
	    ok($tvalue eq $fvalue, "$note - $textname - checking value");
	  }
	  if (defined $todo{$textname}[1]) {
	    ok ($todo{$textname}[1] eq 'textarea',
		"$note - $textname - check field type");
	  }
	  delete $todo{$textname};
	}
      }
    };
  my $p = HTML::Parser->new( text_h => [ $text, "dtext" ],
			     start_h => [ $start, "tagname, attr" ],
			     end_h => [ $end, "tagname" ]);
  $p->parse($content);
  $p->eof;
  for my $name (keys %todo) {
    ok(0, "$note - $name - field doesn't exist");
    my $count = 0;
    ++$count if defined $todo{$name}[0];
    ++$count if defined $todo{$name}[1];
    skip("$note - $name - no field", $count);
  }

  return %values;
}

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