File Coverage

blib/lib/Mail/Box/Message/Destructed.pm
Criterion Covered Total %
statement 32 51 62.7
branch 6 18 33.3
condition 2 12 16.6
subroutine 8 12 66.6
pod 7 7 100.0
total 55 100 55.0


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::Message::Destructed;
10 3     3   963 use vars '$VERSION';
  3         9  
  3         204  
11             $VERSION = '3.009';
12              
13 3     3   27 use base 'Mail::Box::Message';
  3         8  
  3         411  
14              
15 3     3   22 use strict;
  3         9  
  3         100  
16 3     3   18 use warnings;
  3         7  
  3         110  
17              
18 3     3   27 use Carp;
  3         7  
  3         1956  
19              
20              
21             sub new(@)
22 0     0 1 0 { my $class = shift;
23 0         0 $class->log(ERROR => 'You cannot instantiate a destructed message');
24 0         0 undef;
25             }
26            
27             sub isDummy() { 1 }
28              
29              
30             sub head(;$)
31 0     0 1 0 { my $self = shift;
32 0 0 0     0 return undef if @_ && !defined(shift);
33              
34 0         0 $self->log(ERROR => "You cannot take the head of a destructed message");
35 0         0 undef;
36             }
37              
38              
39             sub body(;$)
40 0     0 1 0 { my $self = shift;
41 0 0 0     0 return undef if @_ && !defined(shift);
42              
43 0         0 $self->log(ERROR => "You cannot take the body of a destructed message");
44 0         0 undef;
45             }
46              
47              
48             sub coerce($)
49 55     55 1 108 { my ($class, $message) = @_;
50              
51 55 50       202 unless($message->isa('Mail::Box::Message'))
52 0         0 { $class->log(ERROR=>"Cannot coerce a ",ref($message), " into destruction");
53 0         0 return ();
54             }
55              
56 55         173 $message->body(undef);
57 55         6816 $message->head(undef);
58 55         556 $message->modified(0);
59              
60 55         764 bless $message, $class;
61             }
62              
63             sub modified(;$)
64 1     1 1 4 { my $self = shift;
65              
66 1 0 33     5 $self->log(ERROR => 'Do not set the modified flag on a destructed message')
67             if @_ && $_[0];
68              
69 1         8 0;
70             }
71              
72             sub isModified() { 0 }
73              
74              
75             sub label($;@)
76 13     13 1 368 { my $self = shift;
77              
78 13 100       29 if(@_==1)
79 12         21 { my $label = shift;
80 12 50       43 return $self->SUPER::label('deleted') if $label eq 'deleted';
81 0         0 $self->log(ERROR => "Destructed message has no labels except 'deleted', requested is $label");
82 0         0 return 0;
83             }
84              
85 1         5 my %flags = @_;
86 1 50 33     10 unless(keys %flags==1 && exists $flags{deleted})
87 0         0 { $self->log(ERROR => "Destructed message has no labels except 'deleted', trying to set @{[ keys %flags ]}");
  0         0  
88 0         0 return;
89             }
90              
91             $self->log(ERROR => "Destructed messages can not be undeleted")
92 1 50       5 unless $flags{deleted};
93              
94 1         5 1;
95             }
96              
97 0 0   0 1   sub labels() { wantarray ? ('deleted') : +{deleted => 1} }
98              
99             1;