File Coverage

blib/lib/Mail/Box/Mbox.pm
Criterion Covered Total %
statement 103 105 98.1
branch 50 60 83.3
condition 30 49 61.2
subroutine 14 14 100.0
pod 7 8 87.5
total 204 236 86.4


line stmt bran cond sub pod time code
1             # Copyrights 2001-2019 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              
9             package Mail::Box::Mbox;
10 25     25   9123 use vars '$VERSION';
  25         45  
  25         1314  
11             $VERSION = '3.008';
12              
13 25     25   121 use base 'Mail::Box::File';
  25         88  
  25         10468  
14              
15 25     25   158 use strict;
  25         44  
  25         463  
16 25     25   105 use warnings;
  25         47  
  25         604  
17 25     25   110 use filetest 'access';
  25         39  
  25         156  
18              
19 25     25   10095 use Mail::Box::Mbox::Message;
  25         54  
  25         26295  
20              
21              
22             our $default_folder_dir = exists $ENV{HOME} ? $ENV{HOME} . '/Mail' : '.';
23             our $default_sub_extension = '.d';
24              
25             sub init($)
26 49     49 0 532 { my ($self, $args) = @_;
27              
28             $self->{MBM_sub_ext} # required during init
29 49   66     1253 = $args->{subfolder_extension} || $default_sub_extension;
30              
31 49         241 $self->SUPER::init($args);
32             }
33              
34              
35             sub create($@)
36 11     11 1 67 { my ($thingy, $name, %args) = @_;
37 11   33     57 my $class = ref $thingy || $thingy;
38 11   33     35 $args{folderdir} ||= $default_folder_dir;
39 11   66     49 $args{subfolder_extension} ||= $default_sub_extension;
40              
41 11         71 $class->SUPER::create($name, %args);
42             }
43              
44              
45             sub foundIn($@)
46 21     21 1 125 { my $class = shift;
47 21 100       91 my $name = @_ % 2 ? shift : undef;
48 21         118 my %args = @_;
49 21 50 66     100 $name ||= $args{folder} or return;
50              
51 21   66     71 my $folderdir = $args{folderdir} || $default_folder_dir;
52 21   33     108 my $extension = $args{subfolder_extension} || $default_sub_extension;
53 21         66 my $filename = $class->folderToFilename($name, $folderdir, $extension);
54              
55 21 100       296 if(-d $filename)
56             { # Maildir and MH Sylpheed have a 'new' sub-directory
57 7 100       186 return 0 if -d File::Spec->catdir($filename, 'new');
58 5         21 local *DIR;
59 5 50       142 if(opendir DIR, $filename)
60 5         289 { my @f = grep !/^\./, readdir DIR; # skip . .. and hidden
61 5 100 66     171 return 0 if @f && ! grep /\D/, @f; # MH
62 1         17 closedir DIR;
63             }
64              
65 1 50       22 return 0 # Other MH
66             if -f "$filename/.mh_sequences";
67              
68 0         0 return 1; # faked empty Mbox sub-folder (with subsub-folders?)
69             }
70              
71 14 100       157 return 0 unless -f $filename;
72 13 100       195 return 1 if -z $filename; # empty folder is ok
73              
74 12 50       496 open my $file, '<:raw', $filename or return 0;
75 12         75 local $_;
76 12         291 while(<$file>)
77 12 50       65 { next if /^\s*$/; # skip empty lines
78 12         101 $file->close;
79 12         385 return substr($_, 0, 5) eq 'From '; # found Mbox separator?
80             }
81              
82 0         0 return 1;
83             }
84              
85             sub delete(@)
86 12     12 1 30 { my $self = shift;
87 12         49 $self->SUPER::delete(@_);
88              
89 12         62 my $subfdir = $self->filename . $default_sub_extension;
90 12         223 rmdir $subfdir; # may fail, when there are still subfolders (no recurse)
91             }
92              
93             sub writeMessages($)
94 14     14 1 35 { my ($self, $args) = @_;
95              
96 14 50       71 $self->SUPER::writeMessages($args) or return;
97              
98 14 50       57 if($self->{MB_remove_empty})
99             { # Can the sub-folder directory be removed? Don't mind if this
100             # doesn't work: probably no subdir or still something in it. This
101             # is a rather blunt approach...
102 14         49 rmdir $self->filename . $self->{MBM_sub_ext};
103             }
104              
105 14         116 $self;
106             }
107              
108             sub type() {'mbox'}
109              
110              
111             sub listSubFolders(@)
112 20     20 1 4641 { my ($thingy, %args) = @_;
113 20   66     63 my $class = ref $thingy || $thingy;
114              
115 20   100     62 my $skip_empty = $args{skip_empty} || 0;
116 20   100     57 my $check = $args{check} || 0;
117              
118 20 100       76 my $folder = exists $args{folder} ? $args{folder} : '=';
119             my $folderdir = exists $args{folderdir}
120             ? $args{folderdir}
121 20 100       72 : $default_folder_dir;
122              
123 20         26 my $extension = $args{subfolder_extension};
124              
125 20         23 my $dir;
126 20 100       36 if(ref $thingy) # Mail::Box::Mbox
127 13   33     50 { $extension ||= $thingy->{MBM_sub_ext};
128 13         35 $dir = $thingy->filename;
129             }
130             else
131 7   33     25 { $extension ||= $default_sub_extension;
132 7         15 $dir = $class->folderToFilename($folder, $folderdir, $extension);
133             }
134              
135 20 100       255 my $real = -d $dir ? $dir : "$dir$extension";
136              
137 20 100       441 opendir DIR, $real
138             or return ();
139              
140             # Some files have to be removed because they are created by all
141             # kinds of programs, but are no folders.
142              
143 11         465 my @entries = grep !m/\.lo?ck$|^\./, readdir DIR;
144 11         147 closedir DIR;
145              
146             # Look for files in the folderdir. They should be readable to
147             # avoid warnings for usage later. Furthermore, if we check on
148             # the size too, we avoid a syscall especially to get the size
149             # of the file by performing that check immediately.
150              
151 11         53 my %folders; # hash to immediately un-double names.
152              
153 11         26 foreach (@entries)
154 48         489 { my $entry = File::Spec->catfile($real, $_);
155 48 100       801 if( -f $entry )
    50          
156 34 100 100     187 { next if $args{skip_empty} && ! -s _;
157 33 100 100     77 next if $args{check} && !$class->foundIn($entry);
158 32         83 $folders{$_}++;
159             }
160             elsif( -d _ )
161             { # Directories may create fake folders.
162 14 100       73 if($args{skip_empty})
163 3 50       51 { opendir DIR, $entry or next;
164 3         86 my @sub = grep !/^\./, readdir DIR;
165 3         27 closedir DIR;
166 3 100       12 next unless @sub;
167             }
168              
169 13         132 (my $folder = $_) =~ s/$extension$//;
170 13         41 $folders{$folder}++;
171             }
172             }
173              
174 11   33     298 map +(m/(.*)/ && $1), keys %folders; # untained names
175             }
176              
177             sub openRelatedFolder(@)
178 11     11 1 19 { my $self = shift;
179             $self->SUPER::openRelatedFolder(subfolder_extension => $self->{MBM_sub_ext}
180 11         40 , @_);
181             }
182              
183             #-------------------------------------------
184              
185              
186             sub folderToFilename($$;$)
187 88     88 1 232 { my ($thingy, $name, $folderdir, $extension) = @_;
188              
189             $extension ||=
190 88 50 66     391 ref $thingy ? $thingy->{MBM_sub_ext} : $default_sub_extension;
191              
192 88         351 $name =~ s#^=#$folderdir/#;
193 88         337 my @parts = split m!/!, $name;
194              
195 88         180 my $real = shift @parts;
196 88 100       249 $real = '/' if $real eq '';
197              
198 88 100       198 if(@parts)
199 79         129 { my $file = pop @parts;
200              
201             $real = File::Spec->catdir($real.(-d $real ? '' : $extension), $_)
202 79 100       3724 foreach @parts;
203              
204 79 100       1542 $real = File::Spec->catfile($real.(-d $real ? '' : $extension), $file);
205             }
206              
207 88         418 $real;
208             }
209              
210             #-------------------------------------------
211              
212              
213             1;