File Coverage

blib/lib/Mail/Box/Maildir/Message.pm
Criterion Covered Total %
statement 50 58 86.2
branch 32 42 76.1
condition 16 23 69.5
subroutine 9 10 90.0
pod 5 5 100.0
total 112 138 81.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::Maildir::Message;
10 6     6   748 use vars '$VERSION';
  6         12  
  6         252  
11             $VERSION = '3.008';
12              
13 6     6   29 use base 'Mail::Box::Dir::Message';
  6         10  
  6         463  
14              
15 6     6   31 use strict;
  6         11  
  6         132  
16 6     6   28 use warnings;
  6         8  
  6         165  
17              
18 6     6   28 use File::Copy;
  6         13  
  6         4176  
19              
20              
21             sub filename(;$)
22 781     781 1 1148 { my $self = shift;
23 781         1290 my $oldname = $self->SUPER::filename();
24 781 100       1569 return $oldname unless @_;
25              
26 303         367 my $newname = shift;
27 303 50 33     491 return $newname if defined $oldname && $oldname eq $newname;
28              
29 303 100       1421 my ($id, $semantics, $flags)
30             = $newname =~ m!(.*?)(?:\:([12])\,([A-Za-z]*))!
31             ? ($1, $2, $3)
32             : ($newname, '','');
33              
34 303         410 my %flags;
35 303         810 $flags{$_}++ foreach split //, $flags;
36              
37             $self->SUPER::label
38             ( draft => (delete $flags{D} || 0)
39             , flagged => (delete $flags{F} || 0)
40             , replied => (delete $flags{R} || 0)
41             , seen => (delete $flags{S} || 0)
42             , deleted => (delete $flags{T} || 0)
43              
44 303   100     2891 , passed => (delete $flags{P} || 0) # uncommon
      100        
      100        
      100        
      100        
      50        
45             , unknown => join('', sort keys %flags) # application specific
46             );
47              
48 303 50 33     4962 if(defined $oldname && ! move $oldname, $newname)
49 0         0 { $self->log(ERROR => "Cannot move $oldname to $newname: $!");
50 0         0 return undef;
51             }
52              
53 303         679 $self->SUPER::filename($newname);
54             }
55              
56              
57             sub guessTimestamp()
58 0     0 1 0 { my $self = shift;
59 0         0 my $timestamp = $self->SUPER::guessTimestamp;
60 0 0       0 return $timestamp if defined $timestamp;
61              
62 0 0       0 $self->filename =~ m/^(\d+)/ ? $1 : undef;
63             }
64              
65             #-------------------------------------------
66              
67              
68             sub label(@)
69 431     431 1 1112 { my $self = shift;
70 431 50       675 return $self->SUPER::label unless @_;
71              
72 431         706 my $return = $self->SUPER::label(@_);
73 431         2190 $self->labelsToFilename;
74 431         921 $return;
75             }
76              
77              
78             sub labelsToFilename()
79 433     433 1 502 { my $self = shift;
80 433         669 my $labels = $self->labels;
81 433         1643 my $old = $self->filename;
82              
83 433         2896 my ($folderdir, $set, $oldname, $oldflags)
84             = $old =~ m!(.*)/(new|cur|tmp)/(.+?)(\:2,[^:]*)?$!;
85              
86             my $newflags # alphabeticly ordered!
87             = ($labels->{draft} ? 'D' : '')
88             . ($labels->{flagged} ? 'F' : '')
89             . ($labels->{passed} ? 'P' : '')
90             . ($labels->{replied} ? 'R' : '')
91             . ($labels->{seen} ? 'S' : '')
92             . ($labels->{deleted} ? 'T' : '')
93 433 100 50     2297 . ($labels->{unknown} || '');
    100          
    50          
    100          
    100          
    100          
94              
95 433 100       662 my $newset = $labels->{accepted} ? 'cur' : 'new';
96 433 100       665 if($set ne $newset)
97 4         14 { my $folder = $self->folder;
98 4 100       15 $folder->modified(1) if defined $folder;
99             }
100              
101 433 100 66     892 my $flags = $newset ne 'new' || $newflags ne '' ? ":2,$newflags"
    100          
102             : $oldflags ? ':2,' : '';
103 433         2484 my $new = File::Spec->catfile($folderdir, $newset, $oldname.$flags);
104              
105 433 100       1039 if($new ne $old)
106 13 50       52 { unless(move $old, $new)
107 0         0 { $self->log(ERROR => "Cannot rename $old to $new: $!");
108 0         0 return;
109             }
110 13         1209 $self->log(PROGRESS => "Moved $old to $new.");
111 13         239 $self->SUPER::filename($new);
112             }
113              
114 433         593 $new;
115             }
116              
117             #-------------------------------------------
118              
119              
120             sub accept(;$)
121 1     1 1 3 { my $self = shift;
122 1 50       4 my $accept = @_ ? shift : 1;
123 1         3 $self->label(accepted => $accept);
124             }
125              
126             #-------------------------------------------
127              
128              
129             1;