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);
35 use Params::Validate qw(validate_with :types);
39 $DEBUG = 0 unless defined $DEBUG;
42 %EXPORT_TAGS = (configuration => [qw(dirsize create_debbugs_configuration send_message)],
45 Exporter::export_ok_tags(qw(configuration));
46 $EXPORT_TAGS{all} = [@EXPORT_OK];
49 # First, we're going to send mesages to receive.
50 # To do so, we'll first send a message to submit,
51 # then send messages to the newly created bugnumber.
55 sub create_debbugs_configuration {
56 my %param = validate_with(params => \@_,
57 spec => {debug => {type => BOOLEAN,
60 cleanup => {type => BOOLEAN,
65 $param{cleanup} = $param{debug}?0:1 if not exists $param{cleanup};
66 my $sendmail_dir = tempdir(CLEANUP => $param{cleanup});
67 my $spool_dir = tempdir(CLEANUP => $param{cleanup});
68 my $config_dir = tempdir(CLEANUP => $param{cleanup});
71 $ENV{DEBBUGS_CONFIG_FILE} ="$config_dir/debbugs_config";
72 $ENV{PERL5LIB} = getcwd();
73 $ENV{SENDMAIL_TESTDIR} = $sendmail_dir;
74 my $sendmail_tester = getcwd().'/t/sendmail_tester';
75 unless (-x $sendmail_tester) {
76 die q(t/sendmail_tester doesn't exist or isn't executable. You may be in the wrong directory.);
78 my %files_to_create = ("$config_dir/debbugs_config" => <<END,
79 \$gSendmail='$sendmail_tester';
80 \$gSpoolDir='$spool_dir';
81 \$gLibPath='@{[getcwd()]}/scripts';
82 \$gTemplateDir='@{[getcwd()]}/templates';
83 \$gWebHost='localhost';
86 "$spool_dir/nextnumber" => qq(1\n),
87 "$config_dir/Maintainers" => qq(foo Blah Bleargh <bar\@baz.com>\n),
88 "$config_dir/Maintainers.override" => qq(),
89 "$config_dir/indices/sources" => <<END,
92 "$config_dir/pseudo-packages.description" => '',
94 while (my ($file,$contents) = each %files_to_create) {
95 system('mkdir','-p',dirname($file));
96 my $fh = IO::File->new($file,'w') or
97 die "Unable to create $file: $!";
98 print {$fh} $contents or die "Unable to write $contents to $file: $!";
99 close $fh or die "Unable to close $file: $!";
102 system('touch',"$spool_dir/index.db.realtime");
103 system('ln','-s','index.db.realtime',
104 "$spool_dir/index.db");
105 system('touch',"$spool_dir/index.archive.realtime");
106 system('ln','-s','index.archive.realtime',
107 "$spool_dir/index.archive");
109 # create the spool files and sub directories
110 map {system('mkdir','-p',"$spool_dir/$_"); }
111 map {('db-h/'.$_,'archive/'.$_)}
112 map { sprintf "%02d",$_ % 100} 0..99;
113 system('mkdir','-p',"$spool_dir/incoming");
114 system('mkdir','-p',"$spool_dir/lock");
116 return (spool_dir => $spool_dir,
117 sendmail_dir => $sendmail_dir,
118 config_dir => $config_dir,
125 my @content = grep {!/^\.\.?$/} readdir(DIR);
127 return scalar @content;
131 # We're going to use create mime message to create these messages, and
132 # then just send them to receive.
133 # First, check that submit@ works
136 my %param = validate_with(params => \@_,
137 spec => {to => {type => SCALAR,
138 default => 'submit@bugs.something',
140 headers => {type => ARRAYREF,
142 body => {type => SCALAR,
144 run_processall =>{type => BOOLEAN,
149 $ENV{LOCAL_PART} = $param{to};
152 local $SIG{PIPE} = 'IGNORE';
153 local $SIG{CHLD} = sub {};
154 my $pid = open3($wfd,$rfd,$rfd,'scripts/receive')
155 or die "Unable to start receive: $!";
156 print {$wfd} create_mime_message($param{headers},
157 $param{body}) or die "Unable to to print to receive";
158 close($wfd) or die "Unable to close receive";
160 my $childpid = waitpid($pid,0);
161 if ($childpid != -1) {
163 print STDERR "receive pid: $pid doesn't match childpid: $childpid\n" if $childpid != $pid;
166 my $rfh = IO::Handle->new_from_fd($rfd,'r') or die "Unable to create filehandle: $!";
169 while ($rv = $rfh->sysread($output,1000,length($output))) {}
170 if (not defined $rv) {
171 print STDERR "Reading from STDOUT/STDERR would have blocked.";
173 print STDERR $output,qq(\n);
174 die "receive failed with exit status $err";
176 # now we should run processall to see if the message gets processed
177 if ($param{run_processall}) {
178 system('scripts/processall') == 0 or die "processall failed";
183 package DebbugsTest::HTTPServer;
184 use base qw(HTTP::Server::Simple::CGI);
186 our $child_pid = undef;
187 our $webserver = undef;
188 our $server_handler = undef;
191 if (defined $child_pid) {
200 sub fork_and_create_webserver {
201 my ($handler,$port) = @_;
203 if (defined $child_pid) {
204 die "We appear to have already forked once";
206 $server_handler = $handler;
208 return 0 if not defined $pid;
211 # Wait here for a second to let the child start up
216 $webserver = DebbugsTest::HTTPServer->new($port);
223 if (defined $server_handler) {
224 $server_handler->(@_);
227 warn "No handler defined\n";
228 print "No handler defined\n";