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)],
47 Exporter::export_ok_tags(qw(configuration mail));
48 $EXPORT_TAGS{all} = [@EXPORT_OK];
51 # First, we're going to send mesages to receive.
52 # To do so, we'll first send a message to submit,
53 # then send messages to the newly created bugnumber.
57 sub create_debbugs_configuration {
58 my %param = validate_with(params => \@_,
59 spec => {debug => {type => BOOLEAN,
62 cleanup => {type => BOOLEAN,
67 $param{cleanup} = $param{debug}?0:1 if not exists $param{cleanup};
68 my $sendmail_dir = tempdir(CLEANUP => $param{cleanup});
69 my $spool_dir = tempdir(CLEANUP => $param{cleanup});
70 my $config_dir = tempdir(CLEANUP => $param{cleanup});
73 $ENV{DEBBUGS_CONFIG_FILE} ="$config_dir/debbugs_config";
74 $ENV{PERL5LIB} = getcwd();
75 $ENV{SENDMAIL_TESTDIR} = $sendmail_dir;
76 my $sendmail_tester = getcwd().'/t/sendmail_tester';
77 unless (-x $sendmail_tester) {
78 die q(t/sendmail_tester doesn't exist or isn't executable. You may be in the wrong directory.);
80 my %files_to_create = ("$config_dir/debbugs_config" => <<END,
81 \$gSendmail='$sendmail_tester';
82 \$gSpoolDir='$spool_dir';
83 \$gLibPath='@{[getcwd()]}/scripts';
84 \$gTemplateDir='@{[getcwd()]}/templates';
85 \$gWebHost='localhost';
88 "$spool_dir/nextnumber" => qq(1\n),
89 "$config_dir/Maintainers" => qq(foo Blah Bleargh <foo\@baz.com>\nbar Bar Bleargh <bar\@baz.com>\n),
90 "$config_dir/Maintainers.override" => qq(),
91 "$config_dir/Source_maintainers" => qq(foo Blah Bleargh <foo\@baz.com>\nbar Bar Bleargh <bar\@baz.com>\n),
92 "$config_dir/indices/sources" => <<END,
95 "$config_dir/pseudo-packages.description" => '',
97 while (my ($file,$contents) = each %files_to_create) {
98 system('mkdir','-p',dirname($file));
99 my $fh = IO::File->new($file,'w') or
100 die "Unable to create $file: $!";
101 print {$fh} $contents or die "Unable to write $contents to $file: $!";
102 close $fh or die "Unable to close $file: $!";
105 system('touch',"$spool_dir/index.db.realtime");
106 system('ln','-s','index.db.realtime',
107 "$spool_dir/index.db");
108 system('touch',"$spool_dir/index.archive.realtime");
109 system('ln','-s','index.archive.realtime',
110 "$spool_dir/index.archive");
112 # create the spool files and sub directories
113 map {system('mkdir','-p',"$spool_dir/$_"); }
114 map {('db-h/'.$_,'archive/'.$_)}
115 map { sprintf "%02d",$_ % 100} 0..99;
116 system('mkdir','-p',"$spool_dir/incoming");
117 system('mkdir','-p',"$spool_dir/lock");
119 return (spool_dir => $spool_dir,
120 sendmail_dir => $sendmail_dir,
121 config_dir => $config_dir,
128 my @content = grep {!/^\.\.?$/} readdir(DIR);
130 return scalar @content;
134 # We're going to use create mime message to create these messages, and
135 # then just send them to receive.
136 # First, check that submit@ works
139 my %param = validate_with(params => \@_,
140 spec => {to => {type => SCALAR,
141 default => 'submit@bugs.something',
143 headers => {type => ARRAYREF,
145 body => {type => SCALAR,
147 run_processall =>{type => BOOLEAN,
152 $ENV{LOCAL_PART} = $param{to};
155 local $SIG{PIPE} = 'IGNORE';
156 local $SIG{CHLD} = sub {};
157 my $pid = open3($wfd,$rfd,$rfd,'scripts/receive')
158 or die "Unable to start receive: $!";
159 print {$wfd} create_mime_message($param{headers},
160 $param{body}) or die "Unable to to print to receive";
161 close($wfd) or die "Unable to close receive";
163 my $childpid = waitpid($pid,0);
164 if ($childpid != -1) {
166 print STDERR "receive pid: $pid doesn't match childpid: $childpid\n" if $childpid != $pid;
169 my $rfh = IO::Handle->new_from_fd($rfd,'r') or die "Unable to create filehandle: $!";
172 while ($rv = $rfh->sysread($output,1000,length($output))) {}
173 if (not defined $rv) {
174 print STDERR "Reading from STDOUT/STDERR would have blocked.";
176 print STDERR $output,qq(\n);
177 die "receive failed with exit status $err";
179 # now we should run processall to see if the message gets processed
180 if ($param{run_processall}) {
181 system('scripts/processall') == 0 or die "processall failed";
186 package DebbugsTest::HTTPServer;
187 use base qw(HTTP::Server::Simple::CGI);
189 our $child_pid = undef;
190 our $webserver = undef;
191 our $server_handler = undef;
194 if (defined $child_pid) {
203 sub fork_and_create_webserver {
204 my ($handler,$port) = @_;
206 if (defined $child_pid) {
207 die "We appear to have already forked once";
209 $server_handler = $handler;
211 return 0 if not defined $pid;
214 # Wait here for a second to let the child start up
219 $webserver = DebbugsTest::HTTPServer->new($port);
226 if (defined $server_handler) {
227 $server_handler->(@_);
230 warn "No handler defined\n";
231 print "No handler defined\n";
236 =head2 num_messages_sent
238 $SD_SIZE = num_messages_sent($SD_SIZE,2,$sendmail_dir,'2 messages have been sent properly');
240 Tests to make sure that at least a certain number of messages have
241 been sent since the last time this command was run. Usefull to test to
242 make sure that mail has been sent.
246 sub num_messages_sent {
247 my ($prev_size,$num_messages,$sendmail_dir,$test_name) = @_;
248 my $cur_size = dirsize($sendmail_dir);
249 ## print STDERR "sendmail: $sendmail_dir, want: $num_messages,
250 ## size: $cur_size, prev_size: $prev_size\n";
251 ok($cur_size-$prev_size >= $num_messages, $test_name);