1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
|
# This code is part of Perl distribution Mail-Box version 4.01.
# The POD got stripped from this file by OODoc version 3.05.
# For contributors see file ChangeLog.
# This software is copyright (c) 2001-2025 by Mark Overmeer.
# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
# SPDX-License-Identifier: Artistic-1.0-Perl OR GPL-1.0-or-later
package Mail::Box::MH::Labels;{
our $VERSION = '4.01';
}
use parent 'Mail::Reporter';
use strict;
use warnings;
use Log::Report 'mail-box', import => [ qw/__x error fault info/ ];
use Mail::Message::Head::Subset ();
#--------------------
#--------------------
sub init($)
{ my ($self, $args) = @_;
$self->SUPER::init($args);
$self->{MBML_filename} = $args->{filename} or error __x"MH labels require a filename.";
$self;
}
#--------------------
sub filename() { $_[0]->{MBML_filename} }
#--------------------
sub get($)
{ my ($self, $msgnr) = @_;
$self->{MBML_labels}[$msgnr];
}
sub read()
{ my $self = shift;
my $seqfn = $self->filename;
open my $seq, '<:raw', $seqfn
or return;
my @labels;
local $_;
while(<$seq>)
{ s/\s*\#.*$//;
length or next;
s/^\s*(\w+)\s*\:\s*// or next;
my $label = $1;
my $set = 1;
if($label eq 'cur' ) { $label = 'current' }
elsif($label eq 'unseen') { $label = 'seen'; $set = 0 }
foreach (split /\s+/)
{ if( /^(\d+)\-(\d+)\s*$/ )
{ push @{$labels[$_]}, $label, $set foreach $1..$2;
}
elsif( /^\d+\s*$/ )
{ push @{$labels[$_]}, $label, $set;
}
}
}
$seq->close;
$self->{MBML_labels} = \@labels;
$self;
}
sub write(@)
{ my $self = shift;
my $filename = $self->filename;
# Remove when no messages are left.
unless(@_)
{ unlink $filename;
return $self;
}
open my $out, '>:raw', $filename
or fault __x"cannot write MH labels file to {file}", file => $filename;
$self->print($out, @_);
close $out
or fault __x"error while closing MH labels file {file} after write", file => $filename;
$self;
}
sub append(@)
{ my $self = shift;
my $filename = $self->filename;
open my $out, '>>:raw', $filename
or fault __x"cannot append to MH labels file {file}", file => $filename;
$self->print($out, @_);
close $out
or fault __x"error while closing MH labels file {file} after append", file => $filename;
$self;
}
sub print($@)
{ my ($self, $out) = (shift, shift);
# Collect the labels from the selected messages.
my %labeled;
foreach my $message (@_)
{ my $labels = $message->labels;
my $seq = $message->filename =~ s!.*/!!r;
push @{$labeled{unseen}}, $seq
unless $labels->{seen};
foreach (keys %$labels)
{ push @{$labeled{$_}}, $seq
if $labels->{$_};
}
}
delete $labeled{seen};
# Write it out
local $" = ' ';
foreach (sort keys %labeled)
{
my @msgs = @{$labeled{$_}}; #they are ordered already.
$_ = 'cur' if $_ eq 'current';
print $out "$_:";
while(@msgs)
{ my $start = shift @msgs;
my $end = $start;
$end = shift @msgs while @msgs && $msgs[0]==$end+1;
print $out ($start==$end ? " $start" : " $start-$end");
}
print $out "\n";
}
$self;
}
1;
|
