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);
36 use Params::Validate qw(validate_with :types);
40 $DEBUG = 0 unless defined $DEBUG;
43 %EXPORT_TAGS = (configuration => [qw(dirsize create_debbugs_configuration send_message)],
44 mail => [qw(num_messages_sent)],
45 control => [qw(test_control_commands)],
48 Exporter::export_ok_tags(qw(configuration mail control));
49 $EXPORT_TAGS{all} = [@EXPORT_OK];
52 # First, we're going to send mesages to receive.
53 # To do so, we'll first send a message to submit,
54 # then send messages to the newly created bugnumber.
58 sub create_debbugs_configuration {
59 my %param = validate_with(params => \@_,
60 spec => {debug => {type => BOOLEAN,
61 default => exists $ENV{DEBUG}?
64 cleanup => {type => BOOLEAN,
69 $param{cleanup} = $param{debug}?0:1 if not exists $param{cleanup};
70 my $sendmail_dir = tempdir(CLEANUP => $param{cleanup});
71 my $spool_dir = tempdir(CLEANUP => $param{cleanup});
72 my $config_dir = tempdir(CLEANUP => $param{cleanup});
75 $ENV{DEBBUGS_CONFIG_FILE} ="$config_dir/debbugs_config";
76 $ENV{PERL5LIB} = getcwd();
77 $ENV{SENDMAIL_TESTDIR} = $sendmail_dir;
79 my $sendmail_tester = getcwd().'/t/sendmail_tester';
80 unless (-x $sendmail_tester) {
81 die q(t/sendmail_tester doesn't exist or isn't executable. You may be in the wrong directory.);
83 my %files_to_create = ("$config_dir/debbugs_config" => <<END,
84 \$gSendmail='$sendmail_tester';
85 \$gSpoolDir='$spool_dir';
86 \$gLibPath='@{[getcwd()]}/scripts';
87 \$gTemplateDir='@{[getcwd()]}/templates';
88 \$gWebDir='@{[getcwd()]}/html';
89 \$gWebHost='localhost';
92 "$spool_dir/nextnumber" => qq(1\n),
93 "$config_dir/Maintainers" => qq(foo Blah Bleargh <foo\@baz.com>\nbar Bar Bleargh <bar\@baz.com>\n),
94 "$config_dir/Maintainers.override" => qq(),
95 "$config_dir/Source_maintainers" => qq(foo Blah Bleargh <foo\@baz.com>\nbar Bar Bleargh <bar\@baz.com>\n),
96 "$config_dir/indices/sources" => <<END,
99 "$config_dir/pseudo-packages.description" => '',
100 "$config_dir/pseudo-packages.maintainers" => '',
102 while (my ($file,$contents) = each %files_to_create) {
103 system('mkdir','-p',dirname($file));
104 my $fh = IO::File->new($file,'w') or
105 die "Unable to create $file: $!";
106 print {$fh} $contents or die "Unable to write $contents to $file: $!";
107 close $fh or die "Unable to close $file: $!";
110 system('touch',"$spool_dir/index.db.realtime");
111 system('ln','-s','index.db.realtime',
112 "$spool_dir/index.db");
113 system('touch',"$spool_dir/index.archive.realtime");
114 system('ln','-s','index.archive.realtime',
115 "$spool_dir/index.archive");
117 # create the spool files and sub directories
118 for my $dir (0..99) {
119 for my $archive (qw(db-h archive)) {
120 system('mkdir','-p',"$spool_dir/$archive/".sprintf('%02d',$dir));
123 system('mkdir','-p',"$spool_dir/incoming");
124 system('mkdir','-p',"$spool_dir/lock");
125 # generate the maintainers index files
126 system('scripts/maintainer-indices') == 0
127 or die "Unable to generate maintainer index files";
131 diag("spool_dir: $spool_dir\n");
132 diag("config_dir: $config_dir\n",);
133 diag("sendmail_dir: $sendmail_dir\n");
138 BAIL_OUT ($@) if ($@);
139 return (spool_dir => $spool_dir,
140 sendmail_dir => $sendmail_dir,
141 config_dir => $config_dir,
148 my @content = grep {!/^\.\.?$/} readdir(DIR);
150 return scalar @content;
154 # We're going to use create mime message to create these messages, and
155 # then just send them to receive.
156 # First, check that submit@ works
159 my %param = validate_with(params => \@_,
160 spec => {to => {type => SCALAR,
161 default => 'submit@bugs.something',
163 headers => {type => ARRAYREF,
165 body => {type => SCALAR,
167 attachments => {type => ARRAYREF,
170 run_processall =>{type => BOOLEAN,
175 $ENV{LOCAL_PART} = $param{to};
178 my $pipe_handler = $SIG{PIPE};
179 $SIG{PIPE} = 'IGNORE';
180 $SIG{CHLD} = 'DEFAULT';
181 my $pid = open3($wfd,$rfd,$rfd,'scripts/receive')
182 or die "Unable to start receive: $!";
183 print {$wfd} create_mime_message($param{headers},
185 $param{attachments}) or
186 die "Unable to to print to receive";
187 close($wfd) or die "Unable to close receive";
188 $SIG{PIPE} = $pipe_handler;
190 my $childpid = waitpid($pid,0);
191 if ($childpid != -1) {
193 print STDERR "receive pid: $pid doesn't match childpid: $childpid\n" if $childpid != $pid;
196 my $rfh = IO::Handle->new_from_fd($rfd,'r') or die "Unable to create filehandle: $!";
199 while ($rv = $rfh->sysread($output,1000,length($output))) {}
200 if (not defined $rv) {
201 print STDERR "Reading from STDOUT/STDERR would have blocked.";
203 print STDERR $output,qq(\n);
204 die "receive failed with exit status $err";
206 # now we should run processall to see if the message gets processed
207 if ($param{run_processall}) {
208 system('scripts/processall') == 0 or die "processall failed";
212 =item test_control_commands
214 test_control_commands(\%config,
215 forcemerge => {command => 'forcemerge',
217 status_key => 'mergedwith',
222 Test a set of control commands to see if they will fail or not. Takes
223 SCALAR/HASHREF pairs, where the scalar should be unique, and the HASHREF
224 contains the following keys:
228 =item command -- control command to issue
230 =item value -- value to pass to control command
232 =item status_key -- bug status key to check
234 =item status_value -- value of status key
236 =item expect_error -- whether to expect the control command to error or not
242 sub test_control_commands {
243 my ($config,@commands) = @_;
245 # now we need to check to make sure that the control message actually did anything
246 # This is an eval because $ENV{DEBBUGS_CONFIG_FILE} isn't set at BEGIN{} time
247 eval "use Debbugs::Status qw(read_bug writebug);";
248 while (my ($command,$control_command) = splice(@commands,0,2)) {
249 # just check to see that control doesn't explode
250 $control_command->{value} = " $control_command->{value}" if length $control_command->{value}
251 and $control_command->{value} !~ /^\s/;
252 send_message(to => 'control@bugs.something',
253 headers => [To => 'control@bugs.something',
254 From => 'foo@bugs.something',
255 Subject => "Munging a bug with $command",
257 body => <<EOF) or fail 'message to control@bugs.something failed';
259 $control_command->{command} $control_command->{value}
263 # now we need to check to make sure the control message was processed without errors
264 if (not ($control_command->{expect_error} // 0)) {
265 ok(system('sh','-c','find '.$config->{sendmail_dir}.
266 q( -type f | xargs grep -q "Subject: Processed: Munging a bug with $command")
268 'control@bugs.something'. "$command message was parsed without errors");
270 # now we need to check to make sure that the control message actually did anything
272 $status = read_bug(exists $control_command->{bug}?(bug => $control_command->{bug}):(bug=>1),
273 exists $control_command->{location}?(location => $control_command->{location}):(),
275 is_deeply($status->{$control_command->{status_key}},
276 $control_command->{status_value},
278 (exists $control_command->{bug}?$control_command->{bug}:1).
281 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);