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);
37 use Params::Validate qw(validate_with :types);
41 $DEBUG = 0 unless defined $DEBUG;
44 %EXPORT_TAGS = (configuration => [qw(dirsize create_debbugs_configuration send_message)],
45 mail => [qw(num_messages_sent)],
46 database => [qw(create_postgresql_database update_postgresql_database)]
49 Exporter::export_ok_tags(keys %EXPORT_TAGS);
50 $EXPORT_TAGS{all} = [@EXPORT_OK];
53 # First, we're going to send mesages to receive.
54 # To do so, we'll first send a message to submit,
55 # then send messages to the newly created bugnumber.
59 sub create_debbugs_configuration {
60 my %param = validate_with(params => \@_,
61 spec => {debug => {type => BOOLEAN,
62 default => exists $ENV{DEBUG}?
65 cleanup => {type => BOOLEAN,
70 $param{cleanup} = $param{debug}?0:1 if not exists $param{cleanup};
71 my $sendmail_dir = tempdir(CLEANUP => $param{cleanup});
72 my $spool_dir = tempdir(CLEANUP => $param{cleanup});
73 my $config_dir = tempdir(CLEANUP => $param{cleanup});
76 $ENV{DEBBUGS_CONFIG_FILE} ="$config_dir/debbugs_config";
77 $ENV{PERL5LIB} = getcwd();
78 $ENV{SENDMAIL_TESTDIR} = $sendmail_dir;
80 my $sendmail_tester = getcwd().'/t/sendmail_tester';
81 unless (-x $sendmail_tester) {
82 die q(t/sendmail_tester doesn't exist or isn't executable. You may be in the wrong directory.);
84 my %files_to_create = ("$config_dir/debbugs_config" => <<END,
85 \$gSendmail='$sendmail_tester';
86 \$gSpoolDir='$spool_dir';
87 \$gLibPath='@{[getcwd()]}/scripts';
88 \$gTemplateDir='@{[getcwd()]}/templates';
89 \$gWebDir='@{[getcwd()]}/html';
90 \$gWebHost='localhost';
93 "$spool_dir/nextnumber" => qq(1\n),
94 "$config_dir/Maintainers" => qq(foo Blah Bleargh <foo\@baz.com>\nbar Bar Bleargh <bar\@baz.com>\n),
95 "$config_dir/Maintainers.override" => qq(),
96 "$config_dir/Source_maintainers" => qq(foo Blah Bleargh <foo\@baz.com>\nbar Bar Bleargh <bar\@baz.com>\n),
97 "$config_dir/indices/sources" => <<END,
100 "$config_dir/pseudo-packages.description" => '',
101 "$config_dir/pseudo-packages.maintainers" => '',
103 while (my ($file,$contents) = each %files_to_create) {
104 system('mkdir','-p',dirname($file));
105 my $fh = IO::File->new($file,'w') or
106 die "Unable to create $file: $!";
107 print {$fh} $contents or die "Unable to write $contents to $file: $!";
108 close $fh or die "Unable to close $file: $!";
111 system('touch',"$spool_dir/index.db.realtime");
112 system('ln','-s','index.db.realtime',
113 "$spool_dir/index.db");
114 system('touch',"$spool_dir/index.archive.realtime");
115 system('ln','-s','index.archive.realtime',
116 "$spool_dir/index.archive");
118 # create the spool files and sub directories
119 for my $dir (0..99) {
120 for my $archive (qw(db-h archive)) {
121 system('mkdir','-p',"$spool_dir/$archive/".sprintf('%02d',$dir));
124 system('mkdir','-p',"$spool_dir/incoming");
125 system('mkdir','-p',"$spool_dir/lock");
129 diag("spool_dir: $spool_dir\n");
130 diag("config_dir: $config_dir\n",);
131 diag("sendmail_dir: $sendmail_dir\n");
136 BAIL_OUT ($@) if ($@);
137 return (spool_dir => $spool_dir,
138 sendmail_dir => $sendmail_dir,
139 config_dir => $config_dir,
146 my @content = grep {!/^\.\.?$/} readdir(DIR);
148 return scalar @content;
152 # We're going to use create mime message to create these messages, and
153 # then just send them to receive.
154 # First, check that submit@ works
157 my %param = validate_with(params => \@_,
158 spec => {to => {type => SCALAR,
159 default => 'submit@bugs.something',
161 headers => {type => ARRAYREF,
163 body => {type => SCALAR,
165 attachments => {type => ARRAYREF,
168 run_processall =>{type => BOOLEAN,
173 $ENV{LOCAL_PART} = $param{to};
176 my $pipe_handler = $SIG{PIPE};
177 $SIG{PIPE} = 'IGNORE';
178 $SIG{CHLD} = 'DEFAULT';
179 my $pid = open3($wfd,$rfd,$rfd,'scripts/receive')
180 or die "Unable to start receive: $!";
181 print {$wfd} create_mime_message($param{headers},
183 $param{attachments}) or
184 die "Unable to to print to receive";
185 close($wfd) or die "Unable to close receive";
186 $SIG{PIPE} = $pipe_handler;
188 my $childpid = waitpid($pid,0);
189 if ($childpid != -1) {
191 print STDERR "receive pid: $pid doesn't match childpid: $childpid\n" if $childpid != $pid;
194 my $rfh = IO::Handle->new_from_fd($rfd,'r') or die "Unable to create filehandle: $!";
197 while ($rv = $rfh->sysread($output,1000,length($output))) {}
198 if (not defined $rv) {
199 print STDERR "Reading from STDOUT/STDERR would have blocked.";
201 print STDERR $output,qq(\n);
202 die "receive failed with exit status $err";
204 # now we should run processall to see if the message gets processed
205 if ($param{run_processall}) {
206 system('scripts/processall') == 0 or die "processall failed";
213 package DebbugsTest::HTTPServer;
214 use base qw(HTTP::Server::Simple::CGI HTTP::Server::Simple::CGI::Environment);
216 our $child_pid = undef;
217 our $webserver = undef;
218 our $server_handler = undef;
221 if (defined $child_pid) {
230 sub fork_and_create_webserver {
231 my ($handler,$port) = @_;
233 if (defined $child_pid) {
234 die "We appear to have already forked once";
236 $server_handler = $handler;
238 return 0 if not defined $pid;
241 # Wait here for a second to let the child start up
246 $webserver = DebbugsTest::HTTPServer->new($port);
253 if (defined $server_handler) {
254 $server_handler->(@_);
257 warn "No handler defined\n";
258 print "No handler defined\n";
263 =head2 num_messages_sent
265 $SD_SIZE = num_messages_sent($SD_SIZE,2,$sendmail_dir,'2 messages have been sent properly');
267 Tests to make sure that at least a certain number of messages have
268 been sent since the last time this command was run. Usefull to test to
269 make sure that mail has been sent.
273 sub num_messages_sent {
274 my ($prev_size,$num_messages,$sendmail_dir,$test_name) = @_;
275 my $cur_size = dirsize($sendmail_dir);
276 ## print STDERR "sendmail: $sendmail_dir, want: $num_messages,
277 ## size: $cur_size, prev_size: $prev_size\n";
278 ok($cur_size-$prev_size >= $num_messages, $test_name);
282 =head2 create_postgresql_database
284 C<my $pgsql = create_postgresql_database();>
286 Create a postgresql database for testing; when the L<Test::PostgreSQL> object it
287 returns is destroyed (or goes out of scope) the database will be removed.
291 sub create_postgresql_database {
292 my $pgsql = Test::PostgreSQL->new(use_socket => 1) or
295 File::Spec->rel2abs(dirname(__FILE__).'/../..').
296 '/bin/debbugs-installsql';
297 # create the debversion extension
298 print STDERR $pgsql->dsn;
300 my $dbh = DBI->connect($pgsql->dsn);
301 $dbh->do(<<END) or die "Unable to create extension";
302 CREATE EXTENSION IF NOT EXISTS debversion;
304 # create the schema for the bug tracking system
305 my $dep_dir = File::Temp::tempdir(CLEANUP=>1);
309 '--deployment-dir',$dep_dir);
311 initialize_postgresql_database($pgsql,@_);
315 =item iniitalize_postgresql_database
317 C<initialize_postgresql_database();>
319 Initialize postgresql database by calling debbugs-loadsql appropriately.
323 sub initialize_postgresql_database {
324 my ($pgsql,@options) = @_;
326 File::Spec->rel2abs(dirname(__FILE__).'/../..').
327 '/bin/debbugs-loadsql';
330 File::Spec->rel2abs(dirname(__FILE__).'/../debian/dist');
332 File::Spec->rel2abs(dirname(__FILE__).'/../debian/debinfo');
333 my %loadsql_commands =
334 (configuration => [],
335 suites => ['--ftpdists',$ftpdists],
336 debinfo => ['--debinfo-dir',$debinfo_dir],
337 packages => ['--ftpdists',$ftpdists],
340 for my $command (keys %loadsql_commands) {
341 system($loadsql,$command,
344 @{$loadsql_commands{$command}}) == 0 or
345 die "Unable to load $command";
350 =item update_postgresql_database
352 C<update_postgresql_database();>
354 Update the postgresql database by calling debbugs-loadsql appropriately.
357 sub update_postgresql_database {
358 my ($pgsql,@options) = @_;
360 File::Spec->rel2abs(dirname(__FILE__).'/../..').
361 '/bin/debbugs-loadsql';
363 my %loadsql_commands =
364 (bugs_and_logs => [],
366 for my $command (keys %loadsql_commands) {
367 system($loadsql,$command,
370 @{$loadsql_commands{$command}}) == 0 or
371 die "Unable to load $command";