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";
214 =item test_control_commands
216 test_control_commands(\%config,
217 forcemerge => {command => 'forcemerge',
219 status_key => 'mergedwith',
224 Test a set of control commands to see if they will fail or not. Takes
225 SCALAR/HASHREF pairs, where the scalar should be unique, and the HASHREF
226 contains the following keys:
230 =item command -- control command to issue
232 =item value -- value to pass to control command
234 =item status_key -- bug status key to check
236 =item status_value -- value of status key
238 =item expect_error -- whether to expect the control command to error or not
244 sub test_control_commands {
245 my ($config,@commands) = @_;
247 # now we need to check to make sure that the control message actually did anything
248 # This is an eval because $ENV{DEBBUGS_CONFIG_FILE} isn't set at BEGIN{} time
249 eval "use Debbugs::Status qw(read_bug writebug);";
250 while (my ($command,$control_command) = splice(@commands,0,2)) {
251 # just check to see that control doesn't explode
252 $control_command->{value} = " $control_command->{value}" if length $control_command->{value}
253 and $control_command->{value} !~ /^\s/;
254 send_message(to => 'control@bugs.something',
255 headers => [To => 'control@bugs.something',
256 From => 'foo@bugs.something',
257 Subject => "Munging a bug with $command",
259 body => <<EOF) or fail 'message to control@bugs.something failed';
261 $control_command->{command} $control_command->{value}
265 # now we need to check to make sure the control message was processed without errors
266 if (not ($control_command->{expect_error} // 0)) {
267 ok(system('sh','-c','find '.$config->{sendmail_dir}.
268 q( -type f | xargs grep -q "Subject: Processed: Munging a bug with $command")
270 'control@bugs.something'. "$command message was parsed without errors");
272 # now we need to check to make sure that the control message actually did anything
274 $status = read_bug(exists $control_command->{bug}?(bug => $control_command->{bug}):(bug=>1),
275 exists $control_command->{location}?(location => $control_command->{location}):(),
277 is_deeply($status->{$control_command->{status_key}},
278 $control_command->{status_value},
280 (exists $control_command->{bug}?$control_command->{bug}:1).
283 or fail(Data::Dumper->Dump([$status],[qw(status)]));
289 package DebbugsTest::HTTPServer;
290 use base qw(HTTP::Server::Simple::CGI HTTP::Server::Simple::CGI::Environment);
292 our $child_pid = undef;
293 our $webserver = undef;
294 our $server_handler = undef;
297 if (defined $child_pid) {
306 sub fork_and_create_webserver {
307 my ($handler,$port) = @_;
309 if (defined $child_pid) {
310 die "We appear to have already forked once";
312 $server_handler = $handler;
314 return 0 if not defined $pid;
317 # Wait here for a second to let the child start up
322 $webserver = DebbugsTest::HTTPServer->new($port);
329 if (defined $server_handler) {
330 $server_handler->(@_);
333 warn "No handler defined\n";
334 print "No handler defined\n";
339 =head2 num_messages_sent
341 $SD_SIZE = num_messages_sent($SD_SIZE,2,$sendmail_dir,'2 messages have been sent properly');
343 Tests to make sure that at least a certain number of messages have
344 been sent since the last time this command was run. Usefull to test to
345 make sure that mail has been sent.
349 sub num_messages_sent {
350 my ($prev_size,$num_messages,$sendmail_dir,$test_name) = @_;
351 my $cur_size = dirsize($sendmail_dir);
352 ## print STDERR "sendmail: $sendmail_dir, want: $num_messages,
353 ## size: $cur_size, prev_size: $prev_size\n";
354 ok($cur_size-$prev_size >= $num_messages, $test_name);
358 =head2 create_postgresql_database
360 C<my $pgsql = create_postgresql_database();>
362 Create a postgresql database for testing; when the L<Test::PostgreSQL> object it
363 returns is destroyed (or goes out of scope) the database will be removed.
367 sub create_postgresql_database {
368 my $pgsql = Test::PostgreSQL->new(use_socket => 1) or
371 File::Spec->rel2abs(dirname(__FILE__).'/../..').
372 '/bin/debbugs-installsql';
373 # create the debversion extension
374 my $dbh = DBI->connect($pgsql->dsn);
375 $dbh->do(<<END) or die "Unable to create extension";
376 CREATE EXTENSION IF NOT EXISTS debversion;
378 # create the schema for the bug tracking system
379 my $dep_dir = File::Temp::tempdir(CLEANUP=>1);
383 '--deployment-dir',$dep_dir);
385 initialize_postgresql_database($pgsql,@_);
389 =item iniitalize_postgresql_database
391 C<initialize_postgresql_database();>
393 Initialize postgresql database by calling debbugs-loadsql appropriately.
397 sub initialize_postgresql_database {
398 my ($pgsql,@options) = @_;
400 File::Spec->rel2abs(dirname(__FILE__).'/../..').
401 '/bin/debbugs-loadsql';
404 File::Spec->rel2abs(dirname(__FILE__).'/../debian/dist');
406 File::Spec->rel2abs(dirname(__FILE__).'/../debian/debinfo');
407 my %loadsql_commands =
408 (configuration => [],
409 suites => ['--ftpdists',$ftpdists],
410 debinfo => ['--debinfo-dir',$debinfo_dir],
411 packages => ['--ftpdists',$ftpdists],
414 for my $command (keys %loadsql_commands) {
415 system($loadsql,$command,
418 @{$loadsql_commands{$command}}) == 0 or
419 die "Unable to load $command";
424 =item update_postgresql_database
426 C<update_postgresql_database();>
428 Update the postgresql database by calling debbugs-loadsql appropriately.
431 sub update_postgresql_database {
432 my ($pgsql,@options) = @_;
434 File::Spec->rel2abs(dirname(__FILE__).'/../..').
435 '/bin/debbugs-loadsql';
437 my %loadsql_commands =
438 (bugs_and_logs => [],
440 for my $command (keys %loadsql_commands) {
441 system($loadsql,$command,
444 @{$loadsql_commands{$command}}) == 0 or
445 die "Unable to load $command";