File Coverage

blib/lib/Mail/Box/MH/Labels.pm
Criterion Covered Total %
statement 89 91 97.8
branch 23 30 76.6
condition 3 3 100.0
subroutine 14 14 100.0
pod 6 7 85.7
total 135 145 93.1


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::MH::Labels;
10 11     11   1132 use vars '$VERSION';
  11         20  
  11         484  
11             $VERSION = '3.008';
12              
13 11     11   51 use base 'Mail::Reporter';
  11         18  
  11         841  
14              
15 11     11   61 use strict;
  11         19  
  11         180  
16 11     11   53 use warnings;
  11         52  
  11         280  
17              
18 11     11   61 use Mail::Message::Head::Subset;
  11         14  
  11         259  
19              
20 11     11   49 use File::Copy;
  11         18  
  11         650  
21 11     11   57 use Carp;
  11         17  
  11         9233  
22              
23              
24             #-------------------------------------------
25              
26              
27             sub init($)
28 21     21 0 345 { my ($self, $args) = @_;
29 21         90 $self->SUPER::init($args);
30             $self->{MBML_filename} = $args->{filename}
31 21 50       208 or croak "No label filename specified.";
32              
33 21         80 $self;
34             }
35              
36             #-------------------------------------------
37              
38              
39 29     29 1 71 sub filename() {shift->{MBML_filename}}
40              
41             #-------------------------------------------
42              
43              
44             sub get($)
45 434     434 1 723 { my ($self, $msgnr) = @_;
46 434         749 $self->{MBML_labels}[$msgnr];
47             }
48              
49             #-------------------------------------------
50              
51              
52             sub read()
53 17     17 1 30 { my $self = shift;
54 17         45 my $seq = $self->filename;
55              
56 17 100       480 open SEQ, '<:raw', $seq
57             or return;
58              
59 9         27 my @labels;
60              
61 9         20 local $_;
62 9         136 while()
63 16         44 { s/\s*\#.*$//;
64 16 50       37 next unless length;
65              
66 16 50       91 next unless s/^\s*(\w+)\s*\:\s*//;
67 16         56 my $label = $1;
68              
69 16         27 my $set = 1;
70 16 100       50 if($label eq 'cur' ) { $label = 'current' }
  1 100       2  
71 2         3 elsif($label eq 'unseen') { $label = 'seen'; $set = 0 }
  2         4  
72              
73 16         73 foreach (split /\s+/)
74 32 100       163 { if( /^(\d+)\-(\d+)\s*$/ )
    50          
75 10         50 { push @{$labels[$_]}, $label, $set foreach $1..$2;
  78         210  
76             }
77             elsif( /^\d+\s*$/ )
78 22         32 { push @{$labels[$_]}, $label, $set;
  22         93  
79             }
80             }
81             }
82              
83 9         76 close SEQ;
84              
85 9         34 $self->{MBML_labels} = \@labels;
86 9         35 $self;
87             }
88              
89             #-------------------------------------------
90              
91              
92             sub write(@)
93 11     11 1 22 { my $self = shift;
94 11         46 my $filename = $self->filename;
95              
96             # Remove when no messages are left.
97 11 50       33 unless(@_)
98 0         0 { unlink $filename;
99 0         0 return $self;
100             }
101              
102 11 50       605 open my $out, '>:raw', $filename or return;
103 11         100 $self->print($out, @_);
104 11         437 close $out;
105              
106 11         66 $self;
107             }
108              
109             #-------------------------------------------
110              
111              
112             sub append(@)
113 1     1 1 3 { my $self = shift;
114 1         3 my $filename = $self->filename;
115              
116 1 50       37 open(my $out, '>>:raw', $filename) or return;
117 1         7 $self->print($out, @_);
118 1         19 close $out;
119              
120 1         6 $self;
121             }
122              
123             #-------------------------------------------
124              
125              
126             sub print($@)
127 12     12 1 31 { my ($self, $out) = (shift, shift);
128              
129             # Collect the labels from the selected messages.
130 12         24 my %labeled;
131 12         31 foreach my $message (@_)
132 310         545 { my $labels = $message->labels;
133 310         1203 (my $seq = $message->filename) =~ s!.*/!!;
134              
135 10         25 push @{$labeled{unseen}}, $seq
136 310 100       622 unless $labels->{seen};
137              
138 310         611 foreach (keys %$labels)
139 351         785 { push @{$labeled{$_}}, $seq
140 369 100       559 if $labels->{$_};
141             }
142             }
143 12         71 delete $labeled{seen};
144              
145             # Write it out
146              
147 12         30 local $" = ' ';
148 12         49 foreach (sort keys %labeled)
149             {
150 12         19 my @msgs = @{$labeled{$_}}; #they are ordered already.
  12         37  
151 12 100       31 $_ = 'cur' if $_ eq 'current';
152 12         68 print $out "$_:";
153              
154 12         37 while(@msgs)
155 21         40 { my $start = shift @msgs;
156 21         31 my $end = $start;
157              
158 21   100     122 $end = shift @msgs
159             while @msgs && $msgs[0]==$end+1;
160              
161 21 100       74 print $out ($start==$end ? " $start" : " $start-$end");
162             }
163 12         30 print $out "\n";
164             }
165              
166 12         37 $self;
167             }
168              
169             #-------------------------------------------
170              
171              
172             1;