15 This module contains various testing routines used to test debbugs in
24 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
25 use base qw(Exporter);
30 use File::Temp qw(tempdir);
32 use Debbugs::MIME qw(create_mime_message);
33 use File::Basename qw(dirname basename);
39 use Params::Validate qw(validate_with :types);
43 $DEBUG = 0 unless defined $DEBUG;
46 %EXPORT_TAGS = (configuration => [qw(dirsize create_debbugs_configuration send_message),
47 qw(submit_bug run_processall)],
48 mail => [qw(num_messages_sent)],
49 control => [qw(test_control_commands)],
50 database => [qw(create_postgresql_database update_postgresql_database)]
53 Exporter::export_ok_tags(keys %EXPORT_TAGS);
54 $EXPORT_TAGS{all} = [@EXPORT_OK];
57 # First, we're going to send mesages to receive.
58 # To do so, we'll first send a message to submit,
59 # then send messages to the newly created bugnumber.
63 sub create_debbugs_configuration {
64 my %param = validate_with(params => \@_,
65 spec => {debug => {type => BOOLEAN,
66 default => exists $ENV{DEBUG}?
69 cleanup => {type => BOOLEAN,
74 $param{cleanup} = $param{debug}?0:1 if not exists $param{cleanup};
75 my $sendmail_dir = tempdir(CLEANUP => $param{cleanup});
76 my $spool_dir = tempdir(CLEANUP => $param{cleanup});
77 my $config_dir = tempdir(CLEANUP => $param{cleanup});
80 $ENV{DEBBUGS_CONFIG_FILE} ="$config_dir/debbugs_config";
81 $ENV{PERL5LIB} = getcwd();
82 $ENV{SENDMAIL_TESTDIR} = $sendmail_dir;
84 my $sendmail_tester = getcwd().'/t/sendmail_tester';
85 unless (-x $sendmail_tester) {
86 die q(t/sendmail_tester doesn't exist or isn't executable. You may be in the wrong directory.);
88 my %files_to_create = ("$config_dir/debbugs_config" => <<END,
89 \$gSendmail='$sendmail_tester';
90 \$gSpoolDir='$spool_dir';
91 \$gLibPath='@{[getcwd()]}/scripts';
92 \$gTemplateDir='@{[getcwd()]}/templates';
93 \$gWebDir='@{[getcwd()]}/html';
94 \$gWebHost='localhost';
97 "$spool_dir/nextnumber" => qq(1\n),
98 "$config_dir/Maintainers" => qq(foo Blah Bleargh <foo\@baz.com>\nbar Bar Bleargh <bar\@baz.com>\n),
99 "$config_dir/Maintainers.override" => qq(),
100 "$config_dir/Source_maintainers" => qq(foo Blah Bleargh <foo\@baz.com>\nbar Bar Bleargh <bar\@baz.com>\n),
101 "$config_dir/indices/sources" => <<END,
104 "$config_dir/pseudo-packages.description" => '',
105 "$config_dir/pseudo-packages.maintainers" => '',
107 while (my ($file,$contents) = each %files_to_create) {
108 system('mkdir','-p',dirname($file));
109 my $fh = IO::File->new($file,'w') or
110 die "Unable to create $file: $!";
111 print {$fh} $contents or die "Unable to write $contents to $file: $!";
112 close $fh or die "Unable to close $file: $!";
115 system('touch',"$spool_dir/index.db.realtime");
116 system('ln','-s','index.db.realtime',
117 "$spool_dir/index.db");
118 system('touch',"$spool_dir/index.archive.realtime");
119 system('ln','-s','index.archive.realtime',
120 "$spool_dir/index.archive");
122 # create the spool files and sub directories
123 for my $dir (0..99) {
124 for my $archive (qw(db-h archive)) {
125 system('mkdir','-p',"$spool_dir/$archive/".sprintf('%02d',$dir));
128 system('mkdir','-p',"$spool_dir/incoming");
129 system('mkdir','-p',"$spool_dir/lock");
130 # generate the maintainers index files
131 system('scripts/maintainer-indices') == 0
132 or die "Unable to generate maintainer index files";
136 diag("spool_dir: $spool_dir\n");
137 diag("config_dir: $config_dir\n",);
138 diag("sendmail_dir: $sendmail_dir\n");
143 BAIL_OUT ($@) if ($@);
144 return (spool_dir => $spool_dir,
145 sendmail_dir => $sendmail_dir,
146 config_dir => $config_dir,
153 my @content = grep {!/^\.\.?$/} readdir(DIR);
155 return scalar @content;
159 # We're going to use create mime message to create these messages, and
160 # then just send them to receive.
161 # First, check that submit@ works
164 my %param = validate_with(params => \@_,
165 spec => {to => {type => SCALAR,
166 default => 'submit@bugs.something',
168 headers => {type => ARRAYREF,
170 body => {type => SCALAR,
172 attachments => {type => ARRAYREF,
175 run_processall =>{type => BOOLEAN,
180 $ENV{LOCAL_PART} = $param{to};
183 my $pipe_handler = $SIG{PIPE};
184 $SIG{PIPE} = 'IGNORE';
185 $SIG{CHLD} = 'DEFAULT';
186 my $pid = open3($wfd,$rfd,$rfd,'scripts/receive')
187 or die "Unable to start receive: $!";
188 print {$wfd} create_mime_message($param{headers},
190 $param{attachments}) or
191 die "Unable to to print to receive";
192 close($wfd) or die "Unable to close receive";
193 $SIG{PIPE} = $pipe_handler;
195 my $childpid = waitpid($pid,0);
196 if ($childpid != -1) {
198 print STDERR "receive pid: $pid doesn't match childpid: $childpid\n" if $childpid != $pid;
201 my $rfh = IO::Handle->new_from_fd($rfd,'r') or die "Unable to create filehandle: $!";
204 while ($rv = $rfh->sysread($output,1000,length($output))) {}
205 if (not defined $rv) {
206 print STDERR "Reading from STDOUT/STDERR would have blocked.";
208 print STDERR $output,qq(\n);
209 die "receive failed with exit status $err";
211 # now we should run processall to see if the message gets processed
212 if ($param{run_processall}) {
219 system('scripts/processall') == 0 or die "processall failed";
222 =item test_control_commands
224 test_control_commands(\%config,
225 forcemerge => {command => 'forcemerge',
227 status_key => 'mergedwith',
232 Test a set of control commands to see if they will fail or not. Takes
233 SCALAR/HASHREF pairs, where the scalar should be unique, and the HASHREF
234 contains the following keys:
238 =item command -- control command to issue
240 =item value -- value to pass to control command
242 =item status_key -- bug status key to check
244 =item status_value -- value of status key
246 =item expect_error -- whether to expect the control command to error or not
252 sub test_control_commands {
253 my ($config,@commands) = @_;
255 # now we need to check to make sure that the control message actually did anything
256 # This is an eval because $ENV{DEBBUGS_CONFIG_FILE} isn't set at BEGIN{} time
257 eval "use Debbugs::Status qw(read_bug writebug);";
258 while (my ($command,$control_command) = splice(@commands,0,2)) {
259 # just check to see that control doesn't explode
260 $control_command->{value} = " $control_command->{value}" if length $control_command->{value}
261 and $control_command->{value} !~ /^\s/;
262 send_message(to => 'control@bugs.something',
263 headers => [To => 'control@bugs.something',
264 From => 'foo@bugs.something',
265 Subject => "Munging a bug with $command",
267 body => <<EOF) or fail 'message to control@bugs.something failed';
269 $control_command->{command} $control_command->{value}
273 # now we need to check to make sure the control message was processed without errors
274 if (not ($control_command->{expect_error} // 0)) {
275 ok(system('sh','-c','find '.$config->{sendmail_dir}.
276 q( -type f | xargs grep -q "Subject: Processed: Munging a bug with $command")
278 'control@bugs.something'. "$command message was parsed without errors");
280 # now we need to check to make sure that the control message actually did anything
282 $status = read_bug(exists $control_command->{bug}?(bug => $control_command->{bug}):(bug=>1),
283 exists $control_command->{location}?(location => $control_command->{location}):(),
285 is_deeply($status->{$control_command->{status_key}},
286 $control_command->{status_value},
288 (exists $control_command->{bug}?$control_command->{bug}:1).
291 or fail(Data::Dumper->Dump([$status],[qw(status)]));
297 {subject => {type => SCALAR,
298 default => 'Submitting a bug',
300 body => {type => SCALAR,
301 default => 'This is a silly bug',
303 submitter => {type => SCALAR,
304 default => 'foo@bugs.something',
306 pseudoheaders => {type => HASHREF,
309 package => {type => SCALAR,
312 run_processall => {type => SCALAR,
317 validate_with(params => \@_,
319 my $body = 'Package: '.$param{package}."\n";
320 foreach my $key (keys %{$param{pseudoheaders}}) {
321 for my $val (ref($param{pseudoheaders}{$key}) ?
322 @{$param{pseudoheaders}{$key}} :
323 $param{pseudoheaders}{$key}) {
324 $body .= $key. ': '.$val."\n";
327 $body .="\n".$param{body};
328 send_message(to => 'submit@bugs.something',
329 headers => [To => 'submit@bugs.something',
330 From => $param{submitter},
331 Subject => $param{subject},
333 run_processall => $param{run_processall},
340 package DebbugsTest::HTTPServer;
341 use base qw(HTTP::Server::Simple::CGI HTTP::Server::Simple::CGI::Environment);
343 our $child_pid = undef;
344 our $webserver = undef;
345 our $server_handler = undef;
348 if (defined $child_pid) {
357 sub fork_and_create_webserver {
358 my ($handler,$port) = @_;
360 if (defined $child_pid) {
361 die "We appear to have already forked once";
363 $server_handler = $handler;
365 return 0 if not defined $pid;
368 # Wait here for a second to let the child start up
373 $webserver = DebbugsTest::HTTPServer->new($port);
380 if (defined $server_handler) {
381 $server_handler->(@_);
384 warn "No handler defined\n";
385 print "No handler defined\n";
390 =head2 num_messages_sent
392 $SD_SIZE = num_messages_sent($SD_SIZE,2,$sendmail_dir,'2 messages have been sent properly');
394 Tests to make sure that at least a certain number of messages have
395 been sent since the last time this command was run. Usefull to test to
396 make sure that mail has been sent.
400 sub num_messages_sent {
401 my ($prev_size,$num_messages,$sendmail_dir,$test_name) = @_;
402 my $cur_size = dirsize($sendmail_dir);
403 ## print STDERR "sendmail: $sendmail_dir, want: $num_messages,
404 ## size: $cur_size, prev_size: $prev_size\n";
405 ok($cur_size-$prev_size >= $num_messages, $test_name);
409 =head2 create_postgresql_database
411 C<my $pgsql = create_postgresql_database();>
413 Create a postgresql database for testing; when the L<Test::PostgreSQL> object it
414 returns is destroyed (or goes out of scope) the database will be removed.
418 sub create_postgresql_database {
419 my $pgsql = Test::PostgreSQL->new(use_socket => 1) or
422 File::Spec->rel2abs(dirname(__FILE__).'/../..').
423 '/bin/debbugs-installsql';
424 # create the debversion extension
425 my $dbh = DBI->connect($pgsql->dsn);
426 $dbh->do(<<END) or die "Unable to create extension";
427 CREATE EXTENSION IF NOT EXISTS debversion;
429 # create the schema for the bug tracking system
430 my $dep_dir = File::Temp::tempdir(CLEANUP=>1);
434 '--deployment-dir',$dep_dir);
436 initialize_postgresql_database($pgsql,@_);
440 =item iniitalize_postgresql_database
442 C<initialize_postgresql_database();>
444 Initialize postgresql database by calling debbugs-loadsql appropriately.
448 sub initialize_postgresql_database {
449 my ($pgsql,@options) = @_;
451 File::Spec->rel2abs(dirname(__FILE__).'/../..').
452 '/bin/debbugs-loadsql';
455 File::Spec->rel2abs(dirname(__FILE__).'/../debian/dist');
457 File::Spec->rel2abs(dirname(__FILE__).'/../debian/debinfo');
458 my %loadsql_commands =
459 (configuration => [],
460 suites => ['--ftpdists',$ftpdists],
461 debinfo => ['--debinfo-dir',$debinfo_dir],
462 packages => ['--ftpdists',$ftpdists],
465 for my $command (keys %loadsql_commands) {
466 system($loadsql,$command,
469 @{$loadsql_commands{$command}}) == 0 or
470 die "Unable to load $command";
475 =item update_postgresql_database
477 C<update_postgresql_database();>
479 Update the postgresql database by calling debbugs-loadsql appropriately.
482 sub update_postgresql_database {
483 my ($pgsql,@options) = @_;
485 File::Spec->rel2abs(dirname(__FILE__).'/../..').
486 '/bin/debbugs-loadsql';
488 my %loadsql_commands =
489 (bugs_and_logs => [],
491 for my $command (keys %loadsql_commands) {
492 system($loadsql,$command,
495 @{$loadsql_commands{$command}}) == 0 or
496 die "Unable to load $command";