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