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 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 attachments => {type => ARRAYREF,
151 run_processall =>{type => BOOLEAN,
156 $ENV{LOCAL_PART} = $param{to};
159 local $SIG{PIPE} = 'IGNORE';
160 local $SIG{CHLD} = sub {};
161 my $pid = open3($wfd,$rfd,$rfd,'scripts/receive')
162 or die "Unable to start receive: $!";
163 print {$wfd} create_mime_message($param{headers},
165 $param{attachments}) or
166 die "Unable to to print to receive";
167 close($wfd) or die "Unable to close receive";
169 my $childpid = waitpid($pid,0);
170 if ($childpid != -1) {
172 print STDERR "receive pid: $pid doesn't match childpid: $childpid\n" if $childpid != $pid;
175 my $rfh = IO::Handle->new_from_fd($rfd,'r') or die "Unable to create filehandle: $!";
178 while ($rv = $rfh->sysread($output,1000,length($output))) {}
179 if (not defined $rv) {
180 print STDERR "Reading from STDOUT/STDERR would have blocked.";
182 print STDERR $output,qq(\n);
183 die "receive failed with exit status $err";
185 # now we should run processall to see if the message gets processed
186 if ($param{run_processall}) {
187 system('scripts/processall') == 0 or die "processall failed";
192 package DebbugsTest::HTTPServer;
193 use base qw(HTTP::Server::Simple::CGI);
195 our $child_pid = undef;
196 our $webserver = undef;
197 our $server_handler = undef;
200 if (defined $child_pid) {
209 sub fork_and_create_webserver {
210 my ($handler,$port) = @_;
212 if (defined $child_pid) {
213 die "We appear to have already forked once";
215 $server_handler = $handler;
217 return 0 if not defined $pid;
220 # Wait here for a second to let the child start up
225 $webserver = DebbugsTest::HTTPServer->new($port);
232 if (defined $server_handler) {
233 $server_handler->(@_);
236 warn "No handler defined\n";
237 print "No handler defined\n";
242 =head2 num_messages_sent
244 $SD_SIZE = num_messages_sent($SD_SIZE,2,$sendmail_dir,'2 messages have been sent properly');
246 Tests to make sure that at least a certain number of messages have
247 been sent since the last time this command was run. Usefull to test to
248 make sure that mail has been sent.
252 sub num_messages_sent {
253 my ($prev_size,$num_messages,$sendmail_dir,$test_name) = @_;
254 my $cur_size = dirsize($sendmail_dir);
255 ## print STDERR "sendmail: $sendmail_dir, want: $num_messages,
256 ## size: $cur_size, prev_size: $prev_size\n";
257 ok($cur_size-$prev_size >= $num_messages, $test_name);