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);
28 use File::Temp qw(tempdir);
30 use Debbugs::MIME qw(create_mime_message);
31 use File::Basename qw(dirname basename);
37 use Params::Validate qw(validate_with :types);
41 $DEBUG = 0 unless defined $DEBUG;
44 %EXPORT_TAGS = (configuration => [qw(dirsize create_debbugs_configuration send_message)],
45 mail => [qw(num_messages_sent)],
46 control => [qw(test_control_commands)],
47 database => [qw(create_postgresql_database update_postgresql_database)]
50 Exporter::export_ok_tags(keys %EXPORT_TAGS);
51 $EXPORT_TAGS{all} = [@EXPORT_OK];
54 # First, we're going to send mesages to receive.
55 # To do so, we'll first send a message to submit,
56 # then send messages to the newly created bugnumber.
60 sub create_debbugs_configuration {
61 my %param = validate_with(params => \@_,
62 spec => {debug => {type => BOOLEAN,
63 default => exists $ENV{DEBUG}?
66 cleanup => {type => BOOLEAN,
71 $param{cleanup} = $param{debug}?0:1 if not exists $param{cleanup};
72 my $sendmail_dir = tempdir(CLEANUP => $param{cleanup});
73 my $spool_dir = tempdir(CLEANUP => $param{cleanup});
74 my $config_dir = tempdir(CLEANUP => $param{cleanup});
77 $ENV{DEBBUGS_CONFIG_FILE} ="$config_dir/debbugs_config";
78 $ENV{PERL5LIB} = getcwd();
79 $ENV{SENDMAIL_TESTDIR} = $sendmail_dir;
81 my $sendmail_tester = getcwd().'/t/sendmail_tester';
82 unless (-x $sendmail_tester) {
83 die q(t/sendmail_tester doesn't exist or isn't executable. You may be in the wrong directory.);
85 my %files_to_create = ("$config_dir/debbugs_config" => <<END,
86 \$gSendmail='$sendmail_tester';
87 \$gSpoolDir='$spool_dir';
88 \$gLibPath='@{[getcwd()]}/scripts';
89 \$gTemplateDir='@{[getcwd()]}/templates';
90 \$gWebDir='@{[getcwd()]}/html';
91 \$gWebHost='localhost';
94 "$spool_dir/nextnumber" => qq(1\n),
95 "$config_dir/Maintainers" => qq(foo Blah Bleargh <foo\@baz.com>\nbar Bar Bleargh <bar\@baz.com>\n),
96 "$config_dir/Maintainers.override" => qq(),
97 "$config_dir/Source_maintainers" => qq(foo Blah Bleargh <foo\@baz.com>\nbar Bar Bleargh <bar\@baz.com>\n),
98 "$config_dir/indices/sources" => <<END,
101 "$config_dir/pseudo-packages.description" => '',
102 "$config_dir/pseudo-packages.maintainers" => '',
104 while (my ($file,$contents) = each %files_to_create) {
105 system('mkdir','-p',dirname($file));
106 my $fh = IO::File->new($file,'w') or
107 die "Unable to create $file: $!";
108 print {$fh} $contents or die "Unable to write $contents to $file: $!";
109 close $fh or die "Unable to close $file: $!";
112 system('touch',"$spool_dir/index.db.realtime");
113 system('ln','-s','index.db.realtime',
114 "$spool_dir/index.db");
115 system('touch',"$spool_dir/index.archive.realtime");
116 system('ln','-s','index.archive.realtime',
117 "$spool_dir/index.archive");
119 # create the spool files and sub directories
120 for my $dir (0..99) {
121 for my $archive (qw(db-h archive)) {
122 system('mkdir','-p',"$spool_dir/$archive/".sprintf('%02d',$dir));
125 system('mkdir','-p',"$spool_dir/incoming");
126 system('mkdir','-p',"$spool_dir/lock");
127 # generate the maintainers index files
128 system('scripts/maintainer-indices') == 0
129 or die "Unable to generate maintainer index files";
133 diag("spool_dir: $spool_dir\n");
134 diag("config_dir: $config_dir\n",);
135 diag("sendmail_dir: $sendmail_dir\n");
140 BAIL_OUT ($@) if ($@);
141 return (spool_dir => $spool_dir,
142 sendmail_dir => $sendmail_dir,
143 config_dir => $config_dir,
150 my @content = grep {!/^\.\.?$/} readdir(DIR);
152 return scalar @content;
156 # We're going to use create mime message to create these messages, and
157 # then just send them to receive.
158 # First, check that submit@ works
161 my %param = validate_with(params => \@_,
162 spec => {to => {type => SCALAR,
163 default => 'submit@bugs.something',
165 headers => {type => ARRAYREF,
167 body => {type => SCALAR,
169 attachments => {type => ARRAYREF,
172 run_processall =>{type => BOOLEAN,
177 $ENV{LOCAL_PART} = $param{to};
180 my $pipe_handler = $SIG{PIPE};
181 $SIG{PIPE} = 'IGNORE';
182 $SIG{CHLD} = 'DEFAULT';
183 my $pid = open3($wfd,$rfd,$rfd,'scripts/receive')
184 or die "Unable to start receive: $!";
185 print {$wfd} create_mime_message($param{headers},
187 $param{attachments}) or
188 die "Unable to to print to receive";
189 close($wfd) or die "Unable to close receive";
190 $SIG{PIPE} = $pipe_handler;
192 my $childpid = waitpid($pid,0);
193 if ($childpid != -1) {
195 print STDERR "receive pid: $pid doesn't match childpid: $childpid\n" if $childpid != $pid;
198 my $rfh = IO::Handle->new_from_fd($rfd,'r') or die "Unable to create filehandle: $!";
201 while ($rv = $rfh->sysread($output,1000,length($output))) {}
202 if (not defined $rv) {
203 print STDERR "Reading from STDOUT/STDERR would have blocked.";
205 print STDERR $output,qq(\n);
206 die "receive failed with exit status $err";
208 # now we should run processall to see if the message gets processed
209 if ($param{run_processall}) {
210 system('scripts/processall') == 0 or die "processall failed";
215 =item test_control_commands
217 test_control_commands(\%config,
218 forcemerge => {command => 'forcemerge',
220 status_key => 'mergedwith',
225 Test a set of control commands to see if they will fail or not. Takes
226 SCALAR/HASHREF pairs, where the scalar should be unique, and the HASHREF
227 contains the following keys:
231 =item command -- control command to issue
233 =item value -- value to pass to control command
235 =item status_key -- bug status key to check
237 =item status_value -- value of status key
239 =item expect_error -- whether to expect the control command to error or not
245 sub test_control_commands {
246 my ($config,@commands) = @_;
248 # now we need to check to make sure that the control message actually did anything
249 # This is an eval because $ENV{DEBBUGS_CONFIG_FILE} isn't set at BEGIN{} time
250 eval "use Debbugs::Status qw(read_bug writebug);";
251 while (my ($command,$control_command) = splice(@commands,0,2)) {
252 # just check to see that control doesn't explode
253 $control_command->{value} = " $control_command->{value}" if length $control_command->{value}
254 and $control_command->{value} !~ /^\s/;
255 send_message(to => 'control@bugs.something',
256 headers => [To => 'control@bugs.something',
257 From => 'foo@bugs.something',
258 Subject => "Munging a bug with $command",
260 body => <<EOF) or fail 'message to control@bugs.something failed';
262 $control_command->{command} $control_command->{value}
266 # now we need to check to make sure the control message was processed without errors
267 if (not ($control_command->{expect_error} // 0)) {
268 ok(system('sh','-c','find '.$config->{sendmail_dir}.
269 q( -type f | xargs grep -q "Subject: Processed: Munging a bug with $command")
271 'control@bugs.something'. "$command message was parsed without errors");
273 # now we need to check to make sure that the control message actually did anything
275 $status = read_bug(exists $control_command->{bug}?(bug => $control_command->{bug}):(bug=>1),
276 exists $control_command->{location}?(location => $control_command->{location}):(),
278 is_deeply($status->{$control_command->{status_key}},
279 $control_command->{status_value},
281 (exists $control_command->{bug}?$control_command->{bug}:1).
284 or fail(Data::Dumper->Dump([$status],[qw(status)]));
290 package DebbugsTest::HTTPServer;
291 use base qw(HTTP::Server::Simple::CGI HTTP::Server::Simple::CGI::Environment);
293 our $child_pid = undef;
294 our $webserver = undef;
295 our $server_handler = undef;
298 if (defined $child_pid) {
307 sub fork_and_create_webserver {
308 my ($handler,$port) = @_;
310 if (defined $child_pid) {
311 die "We appear to have already forked once";
313 $server_handler = $handler;
315 return 0 if not defined $pid;
318 # Wait here for a second to let the child start up
323 $webserver = DebbugsTest::HTTPServer->new($port);
330 if (defined $server_handler) {
331 $server_handler->(@_);
334 warn "No handler defined\n";
335 print "No handler defined\n";
340 =head2 num_messages_sent
342 $SD_SIZE = num_messages_sent($SD_SIZE,2,$sendmail_dir,'2 messages have been sent properly');
344 Tests to make sure that at least a certain number of messages have
345 been sent since the last time this command was run. Usefull to test to
346 make sure that mail has been sent.
350 sub num_messages_sent {
351 my ($prev_size,$num_messages,$sendmail_dir,$test_name) = @_;
352 my $cur_size = dirsize($sendmail_dir);
353 ## print STDERR "sendmail: $sendmail_dir, want: $num_messages,
354 ## size: $cur_size, prev_size: $prev_size\n";
355 ok($cur_size-$prev_size >= $num_messages, $test_name);
359 =head2 create_postgresql_database
361 C<my $pgsql = create_postgresql_database();>
363 Create a postgresql database for testing; when the L<Test::PostgreSQL> object it
364 returns is destroyed (or goes out of scope) the database will be removed.
368 sub create_postgresql_database {
369 my $pgsql = Test::PostgreSQL->new(use_socket => 1) or
372 File::Spec->rel2abs(dirname(__FILE__).'/../..').
373 '/bin/debbugs-installsql';
374 # create the debversion extension
375 my $dbh = DBI->connect($pgsql->dsn);
376 $dbh->do(<<END) or die "Unable to create extension";
377 CREATE EXTENSION IF NOT EXISTS debversion;
379 # create the schema for the bug tracking system
380 my $dep_dir = File::Temp::tempdir(CLEANUP=>1);
384 '--deployment-dir',$dep_dir);
386 initialize_postgresql_database($pgsql,@_);
390 =item iniitalize_postgresql_database
392 C<initialize_postgresql_database();>
394 Initialize postgresql database by calling debbugs-loadsql appropriately.
398 sub initialize_postgresql_database {
399 my ($pgsql,@options) = @_;
401 File::Spec->rel2abs(dirname(__FILE__).'/../..').
402 '/bin/debbugs-loadsql';
405 File::Spec->rel2abs(dirname(__FILE__).'/../debian/dist');
407 File::Spec->rel2abs(dirname(__FILE__).'/../debian/debinfo');
408 my %loadsql_commands =
409 (configuration => [],
410 suites => ['--ftpdists',$ftpdists],
411 debinfo => ['--debinfo-dir',$debinfo_dir],
412 packages => ['--ftpdists',$ftpdists],
415 for my $command (keys %loadsql_commands) {
416 system($loadsql,$command,
419 @{$loadsql_commands{$command}}) == 0 or
420 die "Unable to load $command";
425 =item update_postgresql_database
427 C<update_postgresql_database();>
429 Update the postgresql database by calling debbugs-loadsql appropriately.
432 sub update_postgresql_database {
433 my ($pgsql,@options) = @_;
435 File::Spec->rel2abs(dirname(__FILE__).'/../..').
436 '/bin/debbugs-loadsql';
438 my %loadsql_commands =
439 (bugs_and_logs => [],
441 for my $command (keys %loadsql_commands) {
442 system($loadsql,$command,
445 @{$loadsql_commands{$command}}) == 0 or
446 die "Unable to load $command";