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";
211 package DebbugsTest::HTTPServer;
212 use base qw(HTTP::Server::Simple::CGI HTTP::Server::Simple::CGI::Environment);
214 our $child_pid = undef;
215 our $webserver = undef;
216 our $server_handler = undef;
219 if (defined $child_pid) {
228 sub fork_and_create_webserver {
229 my ($handler,$port) = @_;
231 if (defined $child_pid) {
232 die "We appear to have already forked once";
234 $server_handler = $handler;
236 return 0 if not defined $pid;
239 # Wait here for a second to let the child start up
244 $webserver = DebbugsTest::HTTPServer->new($port);
251 if (defined $server_handler) {
252 $server_handler->(@_);
255 warn "No handler defined\n";
256 print "No handler defined\n";
261 =head2 num_messages_sent
263 $SD_SIZE = num_messages_sent($SD_SIZE,2,$sendmail_dir,'2 messages have been sent properly');
265 Tests to make sure that at least a certain number of messages have
266 been sent since the last time this command was run. Usefull to test to
267 make sure that mail has been sent.
271 sub num_messages_sent {
272 my ($prev_size,$num_messages,$sendmail_dir,$test_name) = @_;
273 my $cur_size = dirsize($sendmail_dir);
274 ## print STDERR "sendmail: $sendmail_dir, want: $num_messages,
275 ## size: $cur_size, prev_size: $prev_size\n";
276 ok($cur_size-$prev_size >= $num_messages, $test_name);
280 =head2 create_postgresql_database
282 C<my $pgsql = create_postgresql_database();>
284 Create a postgresql database for testing; when the L<Test::PostgreSQL> object it
285 returns is destroyed (or goes out of scope) the database will be removed.
289 sub create_postgresql_database {
290 my $pgsql = Test::PostgreSQL->new(use_socket => 1) or
293 File::Spec->rel2abs(dirname(__FILE__).'/../..').
294 '/bin/debbugs-installsql';
295 # create the debversion extension
296 my $dbh = DBI->connect($pgsql->dsn);
297 $dbh->do(<<END) or die "Unable to create extension";
298 CREATE EXTENSION IF NOT EXISTS debversion;
300 # create the schema for the bug tracking system
301 my $dep_dir = File::Temp::tempdir(CLEANUP=>1);
305 '--deployment-dir',$dep_dir);
307 initialize_postgresql_database($pgsql,@_);
311 =item iniitalize_postgresql_database
313 C<initialize_postgresql_database();>
315 Initialize postgresql database by calling debbugs-loadsql appropriately.
319 sub initialize_postgresql_database {
320 my ($pgsql,@options) = @_;
322 File::Spec->rel2abs(dirname(__FILE__).'/../..').
323 '/bin/debbugs-loadsql';
326 File::Spec->rel2abs(dirname(__FILE__).'/../debian/dist');
328 File::Spec->rel2abs(dirname(__FILE__).'/../debian/debinfo');
329 my %loadsql_commands =
330 (configuration => [],
331 suites => ['--ftpdists',$ftpdists],
332 debinfo => ['--debinfo-dir',$debinfo_dir],
333 packages => ['--ftpdists',$ftpdists],
336 for my $command (keys %loadsql_commands) {
337 system($loadsql,$command,
340 @{$loadsql_commands{$command}}) == 0 or
341 die "Unable to load $command";
346 =item update_postgresql_database
348 C<update_postgresql_database();>
350 Update the postgresql database by calling debbugs-loadsql appropriately.
353 sub update_postgresql_database {
354 my ($pgsql,@options) = @_;
356 File::Spec->rel2abs(dirname(__FILE__).'/../..').
357 '/bin/debbugs-loadsql';
359 my %loadsql_commands =
360 (bugs_and_logs => [],
362 for my $command (keys %loadsql_commands) {
363 system($loadsql,$command,
366 @{$loadsql_commands{$command}}) == 0 or
367 die "Unable to load $command";