1# Copyrights 2001-2020 by [Mark Overmeer]. 2# For other contributors see ChangeLog. 3# See the manual pages for details on the licensing terms. 4# Pod stripped from pm file by OODoc 2.02. 5# This code is part of distribution Mail-Box. Meta-POD processed with 6# OODoc into POD and HTML manual-pages. See README.md 7# Copyright Mark Overmeer. Licensed under the same terms as Perl itself. 8 9package Mail::Box::Test; 10use vars '$VERSION'; 11$VERSION = '3.009'; 12 13use base 'Exporter'; 14 15use strict; 16use warnings; 17 18use File::Copy 'copy'; 19use List::Util 'first'; 20use IO::File; # to overrule open() 21use File::Spec; 22use File::Temp 'tempdir'; 23use Cwd qw(getcwd); 24use Sys::Hostname qw(hostname); 25use Test::More; 26 27 28our @EXPORT = 29 qw/clean_dir copy_dir 30 unpack_mbox2mh unpack_mbox2maildir 31 compare_lists listdir 32 compare_message_prints reproducable_text 33 compare_thread_dumps 34 35 $folderdir 36 $workdir 37 $src $unixsrc $winsrc 38 $fn $unixfn $winfn 39 $cpy $cpyfn 40 $raw_html_data 41 $crlf_platform $windows 42 /; 43 44our ($logfile, $folderdir); 45our ($src, $unixsrc, $winsrc); 46our ($fn, $unixfn, $winfn); 47our ($cpy, $cpyfn); 48our ($crlf_platform, $windows); 49our $workdir; 50 51BEGIN { 52 $windows = $^O =~ m/mswin32/i; 53 $crlf_platform = $windows; 54 55 $folderdir = File::Spec->catdir('t','folders'); 56 $workdir = tempdir(CLEANUP => 1); 57 58 59 $logfile = File::Spec->catfile(getcwd(), 'run-log'); 60 $unixfn = 'mbox.src'; 61 $winfn = 'mbox.win'; 62 $cpyfn = 'mbox.cpy'; 63 64 $unixsrc = File::Spec->catfile($folderdir, $unixfn); 65 $winsrc = File::Spec->catfile($folderdir, $winfn); 66 $cpy = File::Spec->catfile($workdir, $cpyfn); 67 68 ($src, $fn) = $windows ? ($winsrc, $winfn) : ($unixsrc, $unixfn); 69 70 # ensure to test the Perl Parser not the C-Parser (separate distribution) 71 require Mail::Box::Parser::Perl; 72 Mail::Box::Parser->defaultParserType( 'Mail::Box::Parser::Perl' ); 73} 74 75# 76# CLEAN_DIR 77# Clean a directory structure, typically created by unpack_mbox() 78# 79 80sub clean_dir($); 81sub clean_dir($) 82{ my $dir = shift; 83 local *DIR; 84 opendir DIR, $dir or return; 85 86 my @items = map { m/(.*)/ && "$dir/$1" } # untainted 87 grep !/^\.\.?$/, readdir DIR; 88 foreach (@items) 89 { if(-d) { clean_dir $_ } 90 else { unlink $_ } 91 } 92 93 closedir DIR; 94 rmdir $dir; 95} 96 97# 98# COPY_DIR FROM, TO 99# Copy directory to other place (not recursively), cleaning the 100# destination first. 101# 102 103sub copy_dir($$) 104{ my ($orig, $dest) = @_; 105 106 clean_dir($dest); 107 108 mkdir $dest 109 or die "Cannot create copy destination $dest: $!\n"; 110 111 opendir ORIG, $orig 112 or die "Cannot open directory $orig: $!\n"; 113 114 foreach my $name (map { !m/^\.\.?$/ && m/(.*)/ ? $1 : () } readdir ORIG) 115 { my $from = File::Spec->catfile($orig, $name); 116 next if -d $from; 117 118 my $to = File::Spec->catfile($dest, $name); 119 copy($from, $to) or die "Couldn't copy $from,$to: $!\n"; 120 } 121 122 close ORIG; 123} 124 125# UNPACK_MBOX2MH 126# Unpack an mbox-file into an MH-directory. 127# This skips message-nr 13 for testing purposes. 128# Blanks before "From" are removed. 129 130sub unpack_mbox2mh($$) 131{ my ($file, $dir) = @_; 132 clean_dir($dir); 133 134 mkdir $dir, 0700; 135 my $count = 1; 136 my $blank; 137 138 open FILE, $file or die; 139 open OUT, '>', File::Spec->devnull; 140 141 while(<FILE>) 142 { if( /^From / ) 143 { close OUT; 144 undef $blank; 145 open OUT, ">$dir/".$count++ or die; 146 $count++ if $count==13; # skip 13 for test 147 next; # from line not included in file. 148 } 149 150 print OUT $blank 151 if defined $blank; 152 153 if( m/^\015?\012$/ ) 154 { $blank = $_; 155 next; 156 } 157 158 undef $blank; 159 print OUT; 160 } 161 162 close OUT; 163 close FILE; 164} 165 166# UNPACK_MBOX2MAILDIR 167# Unpack an mbox-file into an Maildir-directory. 168 169our @maildir_names = 170 ( '8000000.localhost.23:2,' 171 , '90000000.localhost.213:2,' 172 , '110000000.localhost.12:2,' 173 , '110000001.l.42:2,' 174 , '110000002.l.42:2,' 175 , '110000002.l.43:2,' 176 , '110000004.l.43:2,' 177 , '110000005.l.43:2,' 178 , '110000006.l.43:2,' 179 , '110000007.l.43:2,D' 180 , '110000008.l.43:2,DF' 181 , '110000009.l.43:2,DFR' 182 , '110000010.l.43:2,DFRS' 183 , '110000011.l.43:2,DFRST' 184 , '110000012.l.43:2,F' 185 , '110000013.l.43:2,FR' 186 , '110000014.l.43:2,FRS' 187 , '110000015.l.43:2,FRST' 188 , '110000016.l.43:2,DR' 189 , '110000017.l.43:2,DRS' 190 , '110000018.l.43:2,DRST' 191 , '110000019.l.43:2,FS' 192 , '110000020.l.43:2,FST' 193 , '110000021.l.43:2,R' 194 , '110000022.l.43:2,RS' 195 , '110000023.l.43:2,RST' 196 , '110000024.l.43:2,S' 197 , '110000025.l.43:2,ST' 198 , '110000026.l.43:2,T' 199 , '110000027.l.43:2,' 200 , '110000028.l.43:2,' 201 , '110000029.l.43:2,' 202 , '110000030.l.43:2,' 203 , '110000031.l.43:2,' 204 , '110000032.l.43:2,' 205 , '110000033.l.43:2,' 206 , '110000034.l.43:2,' 207 , '110000035.l.43:2,' 208 , '110000036.l.43:2,' 209 , '110000037.l.43:2,' 210 , '110000038.l.43' 211 , '110000039.l.43' 212 , '110000040.l.43' 213 , '110000041.l.43' 214 , '110000042.l.43' 215 ); 216 217sub unpack_mbox2maildir($$) 218{ my ($file, $dir) = @_; 219 clean_dir($dir); 220 221 die unless @maildir_names==45; 222 223 mkdir $dir or die; 224 mkdir File::Spec->catfile($dir, 'cur') or die; 225 mkdir File::Spec->catfile($dir, 'new') or die; 226 mkdir File::Spec->catfile($dir, 'tmp') or die; 227 my $msgnr = 0; 228 229 open FILE, $file or die; 230 open OUT, '>', File::Spec->devnull; 231 232 my $last_empty = 0; 233 my $blank; 234 235 while(<FILE>) 236 { if( m/^From / ) 237 { close OUT; 238 undef $blank; 239 my $now = time; 240 my $hostname = hostname; 241 242 my $msgfile = File::Spec->catfile($dir 243 , ($msgnr > 40 ? 'new' : 'cur') 244 , $maildir_names[$msgnr++] 245 ); 246 247 open OUT, ">", $msgfile or die "Create $msgfile: $!\n"; 248 next; # from line not included in file. 249 } 250 251 print OUT $blank 252 if defined $blank; 253 254 if( m/^\015?\012$/ ) 255 { $blank = $_; 256 next; 257 } 258 259 undef $blank; 260 print OUT; 261 } 262 263 close OUT; 264 close FILE; 265} 266 267# 268# Compare two lists. 269# 270 271sub compare_lists($$) 272{ my ($first, $second) = @_; 273#warn "[@$first]==[@$second]\n"; 274 return 0 unless @$first == @$second; 275 for(my $i=0; $i<@$first; $i++) 276 { return 0 unless $first->[$i] eq $second->[$i]; 277 } 278 1; 279} 280 281# 282# Compare the text of two messages, rather strict. 283# On CRLF platforms, the Content-Length may be different. 284# 285 286sub compare_message_prints($$$) 287{ my ($first, $second, $label) = @_; 288 289 if($crlf_platform) 290 { $first =~ s/Content-Length: (\d+)/Content-Length: <removed>/g; 291 $second =~ s/Content-Length: (\d+)/Content-Length: <removed>/g; 292 } 293 294 is($first, $second, $label); 295} 296 297# 298# Strip message text down the things which are the same on all 299# platforms and all situations. 300# 301 302sub reproducable_text($) 303{ my $text = shift; 304 my @lines = split /^/m, $text; 305 foreach (@lines) 306 { s/((?:references|message-id|date|content-length)\: ).*/$1<removed>/i; 307 s/boundary-\d+/boundary-<removed>/g; 308 } 309 join '', @lines; 310} 311 312# 313# Compare two outputs of thread details. 314# On CRLF platforms, the reported sizes are ignored. 315# 316 317sub compare_thread_dumps($$$) 318{ my ($first, $second, $label) = @_; 319 320 if($crlf_platform) 321 { $first =~ s/^..../ /gm; 322 $second =~ s/^..../ /gm; 323 } 324 325 is($first, $second, $label); 326} 327 328# 329# List directory 330# This removes '.' and '..' 331# 332 333sub listdir($) 334{ my $dir = shift; 335 opendir LISTDIR, $dir or return (); 336 my @entities = grep !/^\.\.?$/, readdir LISTDIR; 337 closedir LISTDIR; 338 @entities; 339} 340 341# 342# A piece of HTML text which is used in some tests. 343# 344 345our $raw_html_data = <<'TEXT'; 346<HTML> 347<HEAD> 348<TITLE>My home page</TITLE> 349</HEAD> 350<BODY BGCOLOR=red> 351 352<H1>Life according to Brian</H1> 353 354This is normal text, but not in a paragraph.<P>New paragraph 355in a bad way. 356 357And this is just a continuation. When texts get long, they must be 358auto-wrapped; and even that is working already. 359 360<H3>Silly subsection at once</H3> 361<H1>and another chapter</H1> 362<H2>again a section</H2> 363<P>Normal paragraph, which contains an <IMG 364SRC=image.gif>, some 365<I>italics with linebreak 366</I> and <TT>code</TT> 367 368<PRE> 369And now for the preformatted stuff 370 it should stay as it was 371 even with strange blanks 372 and indentations 373</PRE> 374 375And back to normal text... 376<UL> 377<LI>list item 1 378 <OL> 379 <LI>list item 1.1 380 <LI>list item 1.2 381 </OL> 382<LI>list item 2 383</UL> 384</BODY> 385</HTML> 386TEXT 387 3881; 389