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" => '',
96 "$config_dir/pseudo-packages.maintainers" => '',
98 while (my ($file,$contents) = each %files_to_create) {
99 system('mkdir','-p',dirname($file));
100 my $fh = IO::File->new($file,'w') or
101 die "Unable to create $file: $!";
102 print {$fh} $contents or die "Unable to write $contents to $file: $!";
103 close $fh or die "Unable to close $file: $!";
106 system('touch',"$spool_dir/index.db.realtime");
107 system('ln','-s','index.db.realtime',
108 "$spool_dir/index.db");
109 system('touch',"$spool_dir/index.archive.realtime");
110 system('ln','-s','index.archive.realtime',
111 "$spool_dir/index.archive");
113 # create the spool files and sub directories
114 for my $dir (0..99) {
115 for my $archive (qw(db-h archive)) {
116 system('mkdir','-p',"$spool_dir/$archive/".sprintf('%02d',$dir));
119 system('mkdir','-p',"$spool_dir/incoming");
120 system('mkdir','-p',"$spool_dir/lock");
122 return (spool_dir => $spool_dir,
123 sendmail_dir => $sendmail_dir,
124 config_dir => $config_dir,
131 my @content = grep {!/^\.\.?$/} readdir(DIR);
133 return scalar @content;
137 # We're going to use create mime message to create these messages, and
138 # then just send them to receive.
139 # First, check that submit@ works
142 my %param = validate_with(params => \@_,
143 spec => {to => {type => SCALAR,
144 default => 'submit@bugs.something',
146 headers => {type => ARRAYREF,
148 body => {type => SCALAR,
150 attachments => {type => ARRAYREF,
153 run_processall =>{type => BOOLEAN,
158 $ENV{LOCAL_PART} = $param{to};
161 my $pipe_handler = $SIG{PIPE};
162 $SIG{PIPE} = 'IGNORE';
163 $SIG{CHLD} = 'DEFAULT';
164 my $pid = open3($wfd,$rfd,$rfd,'scripts/receive')
165 or die "Unable to start receive: $!";
166 print {$wfd} create_mime_message($param{headers},
168 $param{attachments}) or
169 die "Unable to to print to receive";
170 close($wfd) or die "Unable to close receive";
171 $SIG{PIPE} = $pipe_handler;
173 my $childpid = waitpid($pid,0);
174 if ($childpid != -1) {
176 print STDERR "receive pid: $pid doesn't match childpid: $childpid\n" if $childpid != $pid;
179 my $rfh = IO::Handle->new_from_fd($rfd,'r') or die "Unable to create filehandle: $!";
182 while ($rv = $rfh->sysread($output,1000,length($output))) {}
183 if (not defined $rv) {
184 print STDERR "Reading from STDOUT/STDERR would have blocked.";
186 print STDERR $output,qq(\n);
187 die "receive failed with exit status $err";
189 # now we should run processall to see if the message gets processed
190 if ($param{run_processall}) {
191 system('scripts/processall') == 0 or die "processall failed";
196 package DebbugsTest::HTTPServer;
197 use base qw(HTTP::Server::Simple::CGI);
199 our $child_pid = undef;
200 our $webserver = undef;
201 our $server_handler = undef;
204 if (defined $child_pid) {
213 sub fork_and_create_webserver {
214 my ($handler,$port) = @_;
216 if (defined $child_pid) {
217 die "We appear to have already forked once";
219 $server_handler = $handler;
221 return 0 if not defined $pid;
224 # Wait here for a second to let the child start up
229 $webserver = DebbugsTest::HTTPServer->new($port);
236 if (defined $server_handler) {
237 $server_handler->(@_);
240 warn "No handler defined\n";
241 print "No handler defined\n";
246 =head2 num_messages_sent
248 $SD_SIZE = num_messages_sent($SD_SIZE,2,$sendmail_dir,'2 messages have been sent properly');
250 Tests to make sure that at least a certain number of messages have
251 been sent since the last time this command was run. Usefull to test to
252 make sure that mail has been sent.
256 sub num_messages_sent {
257 my ($prev_size,$num_messages,$sendmail_dir,$test_name) = @_;
258 my $cur_size = dirsize($sendmail_dir);
259 ## print STDERR "sendmail: $sendmail_dir, want: $num_messages,
260 ## size: $cur_size, prev_size: $prev_size\n";
261 ok($cur_size-$prev_size >= $num_messages, $test_name);