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);
33 use Params::Validate qw(validate_with :types);
37 $DEBUG = 0 unless defined $DEBUG;
40 %EXPORT_TAGS = (configuration => [qw(dirsize create_debbugs_configuration send_message)],
43 Exporter::export_ok_tags(qw(configuration));
44 $EXPORT_TAGS{all} = [@EXPORT_OK];
47 # First, we're going to send mesages to receive.
48 # To do so, we'll first send a message to submit,
49 # then send messages to the newly created bugnumber.
53 sub create_debbugs_configuration {
54 my %param = validate_with(params => \@_,
55 spec => {debug => {type => BOOLEAN,
58 cleanup => {type => BOOLEAN,
63 $param{cleanup} = $param{debug}?0:1 if not exists $param{cleanup};
64 my $sendmail_dir = tempdir(CLEANUP => $param{cleanup});
65 my $spool_dir = tempdir(CLEANUP => $param{cleanup});
66 my $config_dir = tempdir(CLEANUP => $param{cleanup});
69 $ENV{DEBBUGS_CONFIG_FILE} ="$config_dir/debbugs_config";
70 $ENV{PERL5LIB} = getcwd();
71 $ENV{SENDMAIL_TESTDIR} = $sendmail_dir;
72 my $sendmail_tester = getcwd().'/t/sendmail_tester';
73 unless (-x $sendmail_tester) {
74 die q(t/sendmail_tester doesn't exist or isn't executable. You may be in the wrong directory.);
76 my %files_to_create = ("$config_dir/debbugs_config" => <<END,
77 \$gSendmail='$sendmail_tester';
78 \$gSpoolDir='$spool_dir';
79 \$gLibPath='@{[getcwd()]}/scripts';
82 "$spool_dir/nextnumber" => qq(1\n),
83 "$config_dir/Maintainers" => qq(foo Blah Bleargh <bar\@baz.com>\n),
84 "$config_dir/Maintainers.override" => qq(),
85 "$config_dir/indices/sources" => <<END,
89 while (my ($file,$contents) = each %files_to_create) {
90 system('mkdir','-p',dirname($file));
91 my $fh = IO::File->new($file,'w') or
92 die "Unable to create $file: $!";
93 print {$fh} $contents or die "Unable to write $contents to $file: $!";
94 close $fh or die "Unable to close $file: $!";
97 system('touch',"$spool_dir/index.db.realtime");
98 system('ln','-s','index.db.realtime',
99 "$spool_dir/index.db");
100 system('touch',"$spool_dir/index.archive.realtime");
101 system('ln','-s','index.archive.realtime',
102 "$spool_dir/index.archive");
104 # create the spool files and sub directories
105 map {system('mkdir','-p',"$spool_dir/$_"); }
106 map {('db-h/'.$_,'archive/'.$_)}
107 map { sprintf "%02d",$_ % 100} 0..99;
108 system('mkdir','-p',"$spool_dir/incoming");
109 system('mkdir','-p',"$spool_dir/lock");
111 return (spool_dir => $spool_dir,
112 sendmail_dir => $sendmail_dir,
113 config_dir => $config_dir,
120 my @content = grep {!/^\.\.?$/} readdir(DIR);
122 return scalar @content;
126 # We're going to use create mime message to create these messages, and
127 # then just send them to receive.
128 # First, check that submit@ works
131 my %param = validate_with(params => \@_,
132 spec => {to => {type => SCALAR,
133 default => 'submit@bugs.something',
135 headers => {type => ARRAYREF,
137 body => {type => SCALAR,
139 run_processall =>{type => BOOLEAN,
144 $ENV{LOCAL_PART} = $param{to};
145 my $receive = new IO::File ('|scripts/receive.in') or die "Unable to start receive.in: $!";
147 print {$receive} create_mime_message($param{headers},
148 $param{body}) or die "Unable to to print to receive.in";
149 close($receive) or die "Unable to close receive.in";
150 $? == 0 or die "receive.in failed";
151 # now we should run processall to see if the message gets processed
152 if ($param{run_processall}) {
153 system('scripts/processall.in') == 0 or die "processall.in failed";