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.maint" => '',
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 map {system('mkdir','-p',"$spool_dir/$_"); }
115 map {('db-h/'.$_,'archive/'.$_)}
116 map { sprintf "%02d",$_ % 100} 0..99;
117 system('mkdir','-p',"$spool_dir/incoming");
118 system('mkdir','-p',"$spool_dir/lock");
120 return (spool_dir => $spool_dir,
121 sendmail_dir => $sendmail_dir,
122 config_dir => $config_dir,
129 my @content = grep {!/^\.\.?$/} readdir(DIR);
131 return scalar @content;
135 # We're going to use create mime message to create these messages, and
136 # then just send them to receive.
137 # First, check that submit@ works
140 my %param = validate_with(params => \@_,
141 spec => {to => {type => SCALAR,
142 default => 'submit@bugs.something',
144 headers => {type => ARRAYREF,
146 body => {type => SCALAR,
148 run_processall =>{type => BOOLEAN,
153 $ENV{LOCAL_PART} = $param{to};
156 local $SIG{PIPE} = 'IGNORE';
157 local $SIG{CHLD} = sub {};
158 my $pid = open3($wfd,$rfd,$rfd,'scripts/receive')
159 or die "Unable to start receive: $!";
160 print {$wfd} create_mime_message($param{headers},
161 $param{body}) or die "Unable to to print to receive";
162 close($wfd) or die "Unable to close receive";
164 my $childpid = waitpid($pid,0);
165 if ($childpid != -1) {
167 print STDERR "receive pid: $pid doesn't match childpid: $childpid\n" if $childpid != $pid;
170 my $rfh = IO::Handle->new_from_fd($rfd,'r') or die "Unable to create filehandle: $!";
173 while ($rv = $rfh->sysread($output,1000,length($output))) {}
174 if (not defined $rv) {
175 print STDERR "Reading from STDOUT/STDERR would have blocked.";
177 print STDERR $output,qq(\n);
178 die "receive failed with exit status $err";
180 # now we should run processall to see if the message gets processed
181 if ($param{run_processall}) {
182 system('scripts/processall') == 0 or die "processall failed";
187 package DebbugsTest::HTTPServer;
188 use base qw(HTTP::Server::Simple::CGI);
190 our $child_pid = undef;
191 our $webserver = undef;
192 our $server_handler = undef;
195 if (defined $child_pid) {
204 sub fork_and_create_webserver {
205 my ($handler,$port) = @_;
207 if (defined $child_pid) {
208 die "We appear to have already forked once";
210 $server_handler = $handler;
212 return 0 if not defined $pid;
215 # Wait here for a second to let the child start up
220 $webserver = DebbugsTest::HTTPServer->new($port);
227 if (defined $server_handler) {
228 $server_handler->(@_);
231 warn "No handler defined\n";
232 print "No handler defined\n";
237 =head2 num_messages_sent
239 $SD_SIZE = num_messages_sent($SD_SIZE,2,$sendmail_dir,'2 messages have been sent properly');
241 Tests to make sure that at least a certain number of messages have
242 been sent since the last time this command was run. Usefull to test to
243 make sure that mail has been sent.
247 sub num_messages_sent {
248 my ($prev_size,$num_messages,$sendmail_dir,$test_name) = @_;
249 my $cur_size = dirsize($sendmail_dir);
250 ## print STDERR "sendmail: $sendmail_dir, want: $num_messages,
251 ## size: $cur_size, prev_size: $prev_size\n";
252 ok($cur_size-$prev_size >= $num_messages, $test_name);