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");
130 diag("spool_dir: $spool_dir\n");
131 diag("config_dir: $config_dir\n",);
132 diag("sendmail_dir: $sendmail_dir\n");
137 BAIL_OUT ($@) if ($@);
138 return (spool_dir => $spool_dir,
139 sendmail_dir => $sendmail_dir,
140 config_dir => $config_dir,
147 my @content = grep {!/^\.\.?$/} readdir(DIR);
149 return scalar @content;
153 # We're going to use create mime message to create these messages, and
154 # then just send them to receive.
155 # First, check that submit@ works
158 my %param = validate_with(params => \@_,
159 spec => {to => {type => SCALAR,
160 default => 'submit@bugs.something',
162 headers => {type => ARRAYREF,
164 body => {type => SCALAR,
166 attachments => {type => ARRAYREF,
169 run_processall =>{type => BOOLEAN,
174 $ENV{LOCAL_PART} = $param{to};
177 my $pipe_handler = $SIG{PIPE};
178 $SIG{PIPE} = 'IGNORE';
179 $SIG{CHLD} = 'DEFAULT';
180 my $pid = open3($wfd,$rfd,$rfd,'scripts/receive')
181 or die "Unable to start receive: $!";
182 print {$wfd} create_mime_message($param{headers},
184 $param{attachments}) or
185 die "Unable to to print to receive";
186 close($wfd) or die "Unable to close receive";
187 $SIG{PIPE} = $pipe_handler;
189 my $childpid = waitpid($pid,0);
190 if ($childpid != -1) {
192 print STDERR "receive pid: $pid doesn't match childpid: $childpid\n" if $childpid != $pid;
195 my $rfh = IO::Handle->new_from_fd($rfd,'r') or die "Unable to create filehandle: $!";
198 while ($rv = $rfh->sysread($output,1000,length($output))) {}
199 if (not defined $rv) {
200 print STDERR "Reading from STDOUT/STDERR would have blocked.";
202 print STDERR $output,qq(\n);
203 die "receive failed with exit status $err";
205 # now we should run processall to see if the message gets processed
206 if ($param{run_processall}) {
207 system('scripts/processall') == 0 or die "processall failed";
211 =item test_control_commands
213 test_control_commands(\%config,
214 forcemerge => {command => 'forcemerge',
216 status_key => 'mergedwith',
221 Test a set of control commands to see if they will fail or not. Takes
222 SCALAR/HASHREF pairs, where the scalar should be unique, and the HASHREF
223 contains the following keys:
227 =item command -- control command to issue
229 =item value -- value to pass to control command
231 =item status_key -- bug status key to check
233 =item status_value -- value of status key
235 =item expect_error -- whether to expect the control command to error or not
241 sub test_control_commands {
242 my ($config,@commands) = @_;
244 # now we need to check to make sure that the control message actually did anything
245 # This is an eval because $ENV{DEBBUGS_CONFIG_FILE} isn't set at BEGIN{} time
246 eval "use Debbugs::Status qw(read_bug writebug);";
247 while (my ($command,$control_command) = splice(@commands,0,2)) {
248 # just check to see that control doesn't explode
249 $control_command->{value} = " $control_command->{value}" if length $control_command->{value}
250 and $control_command->{value} !~ /^\s/;
251 send_message(to => 'control@bugs.something',
252 headers => [To => 'control@bugs.something',
253 From => 'foo@bugs.something',
254 Subject => "Munging a bug with $command",
256 body => <<EOF) or fail 'message to control@bugs.something failed';
258 $control_command->{command} $control_command->{value}
262 # now we need to check to make sure the control message was processed without errors
263 if (not ($control_command->{expect_error} // 0)) {
264 ok(system('sh','-c','find '.$config->{sendmail_dir}.
265 q( -type f | xargs grep -q "Subject: Processed: Munging a bug with $command")
267 'control@bugs.something'. "$command message was parsed without errors");
269 # now we need to check to make sure that the control message actually did anything
271 $status = read_bug(exists $control_command->{bug}?(bug => $control_command->{bug}):(bug=>1),
272 exists $control_command->{location}?(location => $control_command->{location}):(),
274 is_deeply($status->{$control_command->{status_key}},
275 $control_command->{status_value},
277 (exists $control_command->{bug}?$control_command->{bug}:1).
280 or fail(Data::Dumper->Dump([$status],[qw(status)]));
286 package DebbugsTest::HTTPServer;
287 use base qw(HTTP::Server::Simple::CGI HTTP::Server::Simple::CGI::Environment);
289 our $child_pid = undef;
290 our $webserver = undef;
291 our $server_handler = undef;
294 if (defined $child_pid) {
303 sub fork_and_create_webserver {
304 my ($handler,$port) = @_;
306 if (defined $child_pid) {
307 die "We appear to have already forked once";
309 $server_handler = $handler;
311 return 0 if not defined $pid;
314 # Wait here for a second to let the child start up
319 $webserver = DebbugsTest::HTTPServer->new($port);
326 if (defined $server_handler) {
327 $server_handler->(@_);
330 warn "No handler defined\n";
331 print "No handler defined\n";
336 =head2 num_messages_sent
338 $SD_SIZE = num_messages_sent($SD_SIZE,2,$sendmail_dir,'2 messages have been sent properly');
340 Tests to make sure that at least a certain number of messages have
341 been sent since the last time this command was run. Usefull to test to
342 make sure that mail has been sent.
346 sub num_messages_sent {
347 my ($prev_size,$num_messages,$sendmail_dir,$test_name) = @_;
348 my $cur_size = dirsize($sendmail_dir);
349 ## print STDERR "sendmail: $sendmail_dir, want: $num_messages,
350 ## size: $cur_size, prev_size: $prev_size\n";
351 ok($cur_size-$prev_size >= $num_messages, $test_name);
355 =head2 create_postgresql_database
357 C<my $pgsql = create_postgresql_database();>
359 Create a postgresql database for testing; when the L<Test::PostgreSQL> object it
360 returns is destroyed (or goes out of scope) the database will be removed.
364 sub create_postgresql_database {
365 my $pgsql = Test::PostgreSQL->new(use_socket => 1) or
368 File::Spec->rel2abs(dirname(__FILE__).'/../..').
369 '/bin/debbugs-installsql';
370 # create the debversion extension
371 my $dbh = DBI->connect($pgsql->dsn);
372 $dbh->do(<<END) or die "Unable to create extension";
373 CREATE EXTENSION IF NOT EXISTS debversion;
375 # create the schema for the bug tracking system
376 my $dep_dir = File::Temp::tempdir(CLEANUP=>1);
380 '--deployment-dir',$dep_dir);
382 initialize_postgresql_database($pgsql,@_);
386 =item iniitalize_postgresql_database
388 C<initialize_postgresql_database();>
390 Initialize postgresql database by calling debbugs-loadsql appropriately.
394 sub initialize_postgresql_database {
395 my ($pgsql,@options) = @_;
397 File::Spec->rel2abs(dirname(__FILE__).'/../..').
398 '/bin/debbugs-loadsql';
401 File::Spec->rel2abs(dirname(__FILE__).'/../debian/dist');
403 File::Spec->rel2abs(dirname(__FILE__).'/../debian/debinfo');
404 my %loadsql_commands =
405 (configuration => [],
406 suites => ['--ftpdists',$ftpdists],
407 debinfo => ['--debinfo-dir',$debinfo_dir],
408 packages => ['--ftpdists',$ftpdists],
411 for my $command (keys %loadsql_commands) {
412 system($loadsql,$command,
415 @{$loadsql_commands{$command}}) == 0 or
416 die "Unable to load $command";
421 =item update_postgresql_database
423 C<update_postgresql_database();>
425 Update the postgresql database by calling debbugs-loadsql appropriately.
428 sub update_postgresql_database {
429 my ($pgsql,@options) = @_;
431 File::Spec->rel2abs(dirname(__FILE__).'/../..').
432 '/bin/debbugs-loadsql';
434 my %loadsql_commands =
435 (bugs_and_logs => [],
437 for my $command (keys %loadsql_commands) {
438 system($loadsql,$command,
441 @{$loadsql_commands{$command}}) == 0 or
442 die "Unable to load $command";