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");
128 diag("spool_dir: $spool_dir\n");
129 diag("config_dir: $config_dir\n",);
130 diag("sendmail_dir: $sendmail_dir\n");
135 BAIL_OUT ($@) if ($@);
136 return (spool_dir => $spool_dir,
137 sendmail_dir => $sendmail_dir,
138 config_dir => $config_dir,
145 my @content = grep {!/^\.\.?$/} readdir(DIR);
147 return scalar @content;
151 # We're going to use create mime message to create these messages, and
152 # then just send them to receive.
153 # First, check that submit@ works
156 my %param = validate_with(params => \@_,
157 spec => {to => {type => SCALAR,
158 default => 'submit@bugs.something',
160 headers => {type => ARRAYREF,
162 body => {type => SCALAR,
164 attachments => {type => ARRAYREF,
167 run_processall =>{type => BOOLEAN,
172 $ENV{LOCAL_PART} = $param{to};
175 my $pipe_handler = $SIG{PIPE};
176 $SIG{PIPE} = 'IGNORE';
177 $SIG{CHLD} = 'DEFAULT';
178 my $pid = open3($wfd,$rfd,$rfd,'scripts/receive')
179 or die "Unable to start receive: $!";
180 print {$wfd} create_mime_message($param{headers},
182 $param{attachments}) or
183 die "Unable to to print to receive";
184 close($wfd) or die "Unable to close receive";
185 $SIG{PIPE} = $pipe_handler;
187 my $childpid = waitpid($pid,0);
188 if ($childpid != -1) {
190 print STDERR "receive pid: $pid doesn't match childpid: $childpid\n" if $childpid != $pid;
193 my $rfh = IO::Handle->new_from_fd($rfd,'r') or die "Unable to create filehandle: $!";
196 while ($rv = $rfh->sysread($output,1000,length($output))) {}
197 if (not defined $rv) {
198 print STDERR "Reading from STDOUT/STDERR would have blocked.";
200 print STDERR $output,qq(\n);
201 die "receive failed with exit status $err";
203 # now we should run processall to see if the message gets processed
204 if ($param{run_processall}) {
205 system('scripts/processall') == 0 or die "processall failed";
209 =item test_control_commands
211 test_control_commands(\%config,
212 forcemerge => {command => 'forcemerge',
214 status_key => 'mergedwith',
219 Test a set of control commands to see if they will fail or not. Takes
220 SCALAR/HASHREF pairs, where the scalar should be unique, and the HASHREF
221 contains the following keys:
225 =item command -- control command to issue
227 =item value -- value to pass to control command
229 =item status_key -- bug status key to check
231 =item status_value -- value of status key
233 =item expect_error -- whether to expect the control command to error or not
239 sub test_control_commands {
240 my ($config,@commands) = @_;
242 # now we need to check to make sure that the control message actually did anything
243 # This is an eval because $ENV{DEBBUGS_CONFIG_FILE} isn't set at BEGIN{} time
244 eval "use Debbugs::Status qw(read_bug writebug);";
245 while (my ($command,$control_command) = splice(@commands,0,2)) {
246 # just check to see that control doesn't explode
247 $control_command->{value} = " $control_command->{value}" if length $control_command->{value}
248 and $control_command->{value} !~ /^\s/;
249 send_message(to => 'control@bugs.something',
250 headers => [To => 'control@bugs.something',
251 From => 'foo@bugs.something',
252 Subject => "Munging a bug with $command",
254 body => <<EOF) or fail 'message to control@bugs.something failed';
256 $control_command->{command} $control_command->{value}
260 # now we need to check to make sure the control message was processed without errors
261 if (not ($control_command->{expect_error} // 0)) {
262 ok(system('sh','-c','find '.$config->{sendmail_dir}.
263 q( -type f | xargs grep -q "Subject: Processed: Munging a bug with $command")
265 'control@bugs.something'. "$command message was parsed without errors");
267 # now we need to check to make sure that the control message actually did anything
269 $status = read_bug(exists $control_command->{bug}?(bug => $control_command->{bug}):(bug=>1),
270 exists $control_command->{location}?(location => $control_command->{location}):(),
272 is_deeply($status->{$control_command->{status_key}},
273 $control_command->{status_value},
275 (exists $control_command->{bug}?$control_command->{bug}:1).
278 or fail(Dumper($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);