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 \$gWebDir='@{[getcwd()]}/html';
86 \$gWebHost='localhost';
89 "$spool_dir/nextnumber" => qq(1\n),
90 "$config_dir/Maintainers" => qq(foo Blah Bleargh <foo\@baz.com>\nbar Bar Bleargh <bar\@baz.com>\n),
91 "$config_dir/Maintainers.override" => qq(),
92 "$config_dir/Source_maintainers" => qq(foo Blah Bleargh <foo\@baz.com>\nbar Bar Bleargh <bar\@baz.com>\n),
93 "$config_dir/indices/sources" => <<END,
96 "$config_dir/pseudo-packages.description" => '',
97 "$config_dir/pseudo-packages.maintainers" => '',
99 while (my ($file,$contents) = each %files_to_create) {
100 system('mkdir','-p',dirname($file));
101 my $fh = IO::File->new($file,'w') or
102 die "Unable to create $file: $!";
103 print {$fh} $contents or die "Unable to write $contents to $file: $!";
104 close $fh or die "Unable to close $file: $!";
107 system('touch',"$spool_dir/index.db.realtime");
108 system('ln','-s','index.db.realtime',
109 "$spool_dir/index.db");
110 system('touch',"$spool_dir/index.archive.realtime");
111 system('ln','-s','index.archive.realtime',
112 "$spool_dir/index.archive");
114 # create the spool files and sub directories
115 for my $dir (0..99) {
116 for my $archive (qw(db-h archive)) {
117 system('mkdir','-p',"$spool_dir/$archive/".sprintf('%02d',$dir));
120 system('mkdir','-p',"$spool_dir/incoming");
121 system('mkdir','-p',"$spool_dir/lock");
123 return (spool_dir => $spool_dir,
124 sendmail_dir => $sendmail_dir,
125 config_dir => $config_dir,
132 my @content = grep {!/^\.\.?$/} readdir(DIR);
134 return scalar @content;
138 # We're going to use create mime message to create these messages, and
139 # then just send them to receive.
140 # First, check that submit@ works
143 my %param = validate_with(params => \@_,
144 spec => {to => {type => SCALAR,
145 default => 'submit@bugs.something',
147 headers => {type => ARRAYREF,
149 body => {type => SCALAR,
151 attachments => {type => ARRAYREF,
154 run_processall =>{type => BOOLEAN,
159 $ENV{LOCAL_PART} = $param{to};
162 my $pipe_handler = $SIG{PIPE};
163 $SIG{PIPE} = 'IGNORE';
164 $SIG{CHLD} = 'DEFAULT';
165 my $pid = open3($wfd,$rfd,$rfd,'scripts/receive')
166 or die "Unable to start receive: $!";
167 print {$wfd} create_mime_message($param{headers},
169 $param{attachments}) or
170 die "Unable to to print to receive";
171 close($wfd) or die "Unable to close receive";
172 $SIG{PIPE} = $pipe_handler;
174 my $childpid = waitpid($pid,0);
175 if ($childpid != -1) {
177 print STDERR "receive pid: $pid doesn't match childpid: $childpid\n" if $childpid != $pid;
180 my $rfh = IO::Handle->new_from_fd($rfd,'r') or die "Unable to create filehandle: $!";
183 while ($rv = $rfh->sysread($output,1000,length($output))) {}
184 if (not defined $rv) {
185 print STDERR "Reading from STDOUT/STDERR would have blocked.";
187 print STDERR $output,qq(\n);
188 die "receive failed with exit status $err";
190 # now we should run processall to see if the message gets processed
191 if ($param{run_processall}) {
192 system('scripts/processall') == 0 or die "processall failed";
197 package DebbugsTest::HTTPServer;
198 use base qw(HTTP::Server::Simple::CGI HTTP::Server::Simple::CGI::Environment);
200 our $child_pid = undef;
201 our $webserver = undef;
202 our $server_handler = undef;
205 if (defined $child_pid) {
214 sub fork_and_create_webserver {
215 my ($handler,$port) = @_;
217 if (defined $child_pid) {
218 die "We appear to have already forked once";
220 $server_handler = $handler;
222 return 0 if not defined $pid;
225 # Wait here for a second to let the child start up
230 $webserver = DebbugsTest::HTTPServer->new($port);
237 if (defined $server_handler) {
238 $server_handler->(@_);
241 warn "No handler defined\n";
242 print "No handler defined\n";
247 =head2 num_messages_sent
249 $SD_SIZE = num_messages_sent($SD_SIZE,2,$sendmail_dir,'2 messages have been sent properly');
251 Tests to make sure that at least a certain number of messages have
252 been sent since the last time this command was run. Usefull to test to
253 make sure that mail has been sent.
257 sub num_messages_sent {
258 my ($prev_size,$num_messages,$sendmail_dir,$test_name) = @_;
259 my $cur_size = dirsize($sendmail_dir);
260 ## print STDERR "sendmail: $sendmail_dir, want: $num_messages,
261 ## size: $cur_size, prev_size: $prev_size\n";
262 ok($cur_size-$prev_size >= $num_messages, $test_name);