File Coverage

blib/lib/Mail/Box/MH/Index.pm
Criterion Covered Total %
statement 60 75 80.0
branch 10 24 41.6
condition 5 16 31.2
subroutine 12 12 100.0
pod 5 6 83.3
total 92 133 69.1


line stmt bran cond sub pod time code
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              
9             package Mail::Box::MH::Index;
10 11     11   1441 use vars '$VERSION';
  11         24  
  11         584  
11             $VERSION = '3.009';
12              
13 11     11   67 use base 'Mail::Reporter';
  11         27  
  11         1039  
14              
15 11     11   70 use strict;
  11         34  
  11         328  
16 11     11   75 use warnings;
  11         21  
  11         323  
17              
18 11     11   5062 use Mail::Message::Head::Subset;
  11         27  
  11         408  
19 11     11   79 use Carp;
  11         22  
  11         8637  
20              
21              
22             #-------------------------------------------
23              
24              
25             sub init($)
26 4     4 0 112 { my ($self, $args) = @_;
27 4         26 $self->SUPER::init($args);
28              
29             $self->{MBMI_filename} = $args->{filename}
30 4 50       57 or croak "No index filename specified.";
31              
32 4   50     26 $self->{MBMI_head_wrap} = $args->{head_wrap} || 72;
33             $self->{MBMI_head_type}
34 4   50     23 = $args->{head_type} || 'Mail::Message::Head::Subset';
35              
36 4         20 $self;
37             }
38              
39             #-------------------------------------------
40              
41              
42 6     6 1 33 sub filename() {shift->{MBMI_filename}}
43              
44             #-------------------------------------------
45              
46              
47             sub write(@)
48 5     5 1 11 { my $self = shift;
49 5 50       23 my $index = $self->filename or return $self;
50              
51             # Remove empty index-file.
52 5 50       16 unless(@_)
53 0         0 { unlink $index;
54 0         0 return $self;
55             }
56              
57 5         27 local *INDEX;
58 5 50       350 open INDEX, '>:raw', $index
59             or return $self;
60              
61 5         23 my $fieldtype = 'Mail::Message::Field';
62 5         23 my $written = 0;
63              
64 5         16 foreach my $msg (@_)
65 178         525 { my $head = $msg->head;
66 178 50 66     2374 next if $head->isDelayed && $head->isa('Mail::Message::Head::Subset');
67              
68 178         1076 my $filename = $msg->filename;
69 178         3345 print INDEX "X-MailBox-Filename: $filename\n"
70             , 'X-MailBox-Size: ', (-s $filename), "\n";
71              
72 178         1941 $head->print(\*INDEX);
73 178         43800 $written++;
74             }
75              
76 5         365 close INDEX;
77              
78 5 50       31 $written or unlink $index;
79              
80 5         39 $self;
81             }
82              
83             #-------------------------------------------
84              
85              
86             sub append(@)
87 1     1 1 3 { my $self = shift;
88 1 50       5 my $index = $self->filename or return $self;
89              
90 1         4 local *INDEX;
91 1 50       57 open INDEX, '>>:raw', $index
92             or return $self;
93              
94 1         5 my $fieldtype = 'Mail::Message::Field';
95              
96 1         3 foreach my $msg (@_)
97 1         6 { my $head = $msg->head;
98 1 50 33     13 next if $head->isDelayed && $head->isa('Mail::Message::Head::Subset');
99              
100 1         5 my $filename = $msg->filename;
101 1         30 print INDEX "X-MailBox-Filename: $filename\n"
102             , 'X-MailBox-Size: ', (-s $filename), "\n";
103              
104 1         9 $head->print(\*INDEX);
105             }
106              
107 1         170 close INDEX;
108 1         9 $self;
109             }
110              
111             #-------------------------------------------
112              
113              
114             sub read(;$)
115 4     4 1 10 { my $self = shift;
116 4         12 my $filename = $self->{MBMI_filename};
117              
118 4 50       37 my $parser = Mail::Box::Parser->new
119             ( filename => $filename
120             , mode => 'r'
121             ) or return;
122              
123 0         0 my @options = ($self->logSettings, wrap_length => $self->{MBMI_head_wrap});
124 0         0 my $type = $self->{MBMI_head_type};
125 0         0 my $index_age= -M $filename;
126 0         0 my %index;
127              
128 0         0 while(my $head = $type->new(@options)->read($parser))
129             {
130             # cleanup the index from files which were renamed
131 0         0 my $msgfile = $head->get('x-mailbox-filename');
132 0         0 my $size = int $head->get('x-mailbox-size');
133 0 0 0     0 next unless -f $msgfile && -s _ == $size;
134 0 0 0     0 next if defined $index_age && -M _ < $index_age;
135              
136             # keep this one
137 0         0 $index{$msgfile} = $head;
138             }
139              
140 0         0 $parser->stop;
141              
142 0         0 $self->{MBMI_index} = \%index;
143 0         0 $self;
144             }
145              
146             #-------------------------------------------
147              
148              
149             sub get($)
150 94     94 1 169 { my ($self, $msgfile) = @_;
151 94         185 $self->{MBMI_index}{$msgfile};
152             }
153              
154             #-------------------------------------------
155              
156              
157             1;