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/indices/sources" => <<END,
94 "$config_dir/pseudo-packages.description" => '',
96 while (my ($file,$contents) = each %files_to_create) {
97 system('mkdir','-p',dirname($file));
98 my $fh = IO::File->new($file,'w') or
99 die "Unable to create $file: $!";
100 print {$fh} $contents or die "Unable to write $contents to $file: $!";
101 close $fh or die "Unable to close $file: $!";
104 system('touch',"$spool_dir/index.db.realtime");
105 system('ln','-s','index.db.realtime',
106 "$spool_dir/index.db");
107 system('touch',"$spool_dir/index.archive.realtime");
108 system('ln','-s','index.archive.realtime',
109 "$spool_dir/index.archive");
111 # create the spool files and sub directories
112 map {system('mkdir','-p',"$spool_dir/$_"); }
113 map {('db-h/'.$_,'archive/'.$_)}
114 map { sprintf "%02d",$_ % 100} 0..99;
115 system('mkdir','-p',"$spool_dir/incoming");
116 system('mkdir','-p',"$spool_dir/lock");
118 return (spool_dir => $spool_dir,
119 sendmail_dir => $sendmail_dir,
120 config_dir => $config_dir,
127 my @content = grep {!/^\.\.?$/} readdir(DIR);
129 return scalar @content;
133 # We're going to use create mime message to create these messages, and
134 # then just send them to receive.
135 # First, check that submit@ works
138 my %param = validate_with(params => \@_,
139 spec => {to => {type => SCALAR,
140 default => 'submit@bugs.something',
142 headers => {type => ARRAYREF,
144 body => {type => SCALAR,
146 run_processall =>{type => BOOLEAN,
151 $ENV{LOCAL_PART} = $param{to};
154 local $SIG{PIPE} = 'IGNORE';
155 local $SIG{CHLD} = sub {};
156 my $pid = open3($wfd,$rfd,$rfd,'scripts/receive')
157 or die "Unable to start receive: $!";
158 print {$wfd} create_mime_message($param{headers},
159 $param{body}) or die "Unable to to print to receive";
160 close($wfd) or die "Unable to close receive";
162 my $childpid = waitpid($pid,0);
163 if ($childpid != -1) {
165 print STDERR "receive pid: $pid doesn't match childpid: $childpid\n" if $childpid != $pid;
168 my $rfh = IO::Handle->new_from_fd($rfd,'r') or die "Unable to create filehandle: $!";
171 while ($rv = $rfh->sysread($output,1000,length($output))) {}
172 if (not defined $rv) {
173 print STDERR "Reading from STDOUT/STDERR would have blocked.";
175 print STDERR $output,qq(\n);
176 die "receive failed with exit status $err";
178 # now we should run processall to see if the message gets processed
179 if ($param{run_processall}) {
180 system('scripts/processall') == 0 or die "processall failed";
185 package DebbugsTest::HTTPServer;
186 use base qw(HTTP::Server::Simple::CGI);
188 our $child_pid = undef;
189 our $webserver = undef;
190 our $server_handler = undef;
193 if (defined $child_pid) {
202 sub fork_and_create_webserver {
203 my ($handler,$port) = @_;
205 if (defined $child_pid) {
206 die "We appear to have already forked once";
208 $server_handler = $handler;
210 return 0 if not defined $pid;
213 # Wait here for a second to let the child start up
218 $webserver = DebbugsTest::HTTPServer->new($port);
225 if (defined $server_handler) {
226 $server_handler->(@_);
229 warn "No handler defined\n";
230 print "No handler defined\n";
235 =head2 num_messages_sent
237 $SD_SIZE = num_messages_sent($SD_SIZE,2,$sendmail_dir,'2 messages have been sent properly');
239 Tests to make sure that at least a certain number of messages have
240 been sent since the last time this command was run. Usefull to test to
241 make sure that mail has been sent.
245 sub num_messages_sent {
246 my ($prev_size,$num_messages,$sendmail_dir,$test_name) = @_;
247 my $cur_size = dirsize($sendmail_dir);
248 ## print STDERR "sendmail: $sendmail_dir, want: $num_messages,
249 ## size: $cur_size, prev_size: $prev_size\n";
250 ok($cur_size-$prev_size >= $num_messages, $test_name);