File Coverage

blib/lib/Mail/Box/Manage/User.pm
Criterion Covered Total %
statement 31 90 34.4
branch 4 46 8.7
condition 3 11 27.2
subroutine 8 14 57.1
pod 8 9 88.8
total 54 170 31.7


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::Manage::User;
10 3     3   2027 use vars '$VERSION';
  3         7  
  3         164  
11             $VERSION = '3.008';
12              
13 3     3   16 use base 'Mail::Box::Manager';
  3         15  
  3         897  
14              
15 3     3   19 use strict;
  3         5  
  3         49  
16 3     3   13 use warnings;
  3         5  
  3         60  
17              
18 3     3   735 use Mail::Box::Collection ();
  3         7  
  3         2452  
19              
20             #-------------------------------------------
21              
22              
23             sub init($)
24 2     2 0 2631 { my ($self, $args) = @_;
25              
26 2 50       14 $self->SUPER::init($args) or return ();
27              
28 2         8 my $identity = $self->{MBMU_id} = $args->{identity};
29 2 50       6 defined $identity or die;
30              
31 2   50     11 my $top = $args->{folder_id_type} || 'Mail::Box::Identity';
32 2   50     9 my $coltype = $args->{collection_type} || 'Mail::Box::Collection';
33              
34 2 50       5 unless(ref $top)
35 2         11 { my $name = $args->{topfolder_name};
36 2 50       7 $name = '=' unless defined $name; # MailBox's abbrev to top
37              
38 2         14 $top = $top->new
39             ( name => $name
40             , manager => $self
41             , location => scalar($self->folderdir)
42             , folder_type => $self->defaultFolderType
43             , collection_type => $coltype
44             );
45             }
46              
47 2         5 $self->{MBMU_topfolder} = $top;
48 2   50     10 $self->{MBMU_delim} = $args->{delimiter} || '/';
49 2         4 $self->{MBMU_inbox} = $args->{inbox};
50              
51 2         6 $self;
52             }
53              
54             #-------------------------------------------
55              
56              
57 1     1 1 838 sub identity() { shift->{MBMU_id} }
58              
59             #-------------------------------------------
60              
61              
62             sub inbox(;$)
63 0     0 1 0 { my $self = shift;
64 0 0       0 @_ ? ($self->{MBMU_inbox} = shift) : $self->{MBMU_inbox};
65             }
66              
67             #-------------------------------------------
68              
69              
70             # A lot of work still has to be done here: all moves etc must inform
71             # the "existence" administration as well.
72              
73             #-------------------------------------------
74              
75              
76 2     2 1 929 sub topfolder() { shift->{MBMU_topfolder} }
77              
78              
79              
80             sub folder($)
81 0     0 1   { my ($self, $name) = @_;
82 0 0         my $top = $self->topfolder or return ();
83 0           my @path = split $self->{MBMU_delim}, $name;
84 0 0         return () unless shift @path eq $top->name;
85              
86 0           $top->folder(@path);
87             }
88              
89              
90              
91             sub folderCollection($)
92 0     0 1   { my ($self, $name) = @_;
93 0 0         my $top = $self->topfolder or return ();
94              
95 0           my @path = split $self->{MBMU_delim}, $name;
96 0 0         unless(shift @path eq $top->name)
97 0           { $self->log(ERROR => "Folder name $name not under top.");
98 0           return ();
99             }
100              
101 0           my $base = pop @path;
102              
103 0           ($top->folder(@path), $base);
104             }
105              
106              
107              
108             # This feature is thoroughly tested in the Mail::Box::Netzwert distribution
109              
110             sub create($@)
111 0     0 1   { my ($self, $name, %args) = @_;
112 0           my ($dir, $base) = $self->folderCollection($name);
113              
114 0 0         unless(defined $dir)
115 0 0         { unless($args{create_supers})
116 0           { $self->log(ERROR => "Cannot create $name: higher levels missing");
117 0           return undef;
118             }
119              
120 0 0         (my $upper = $name) =~ s!$self->{MBMU_delim}$base!!
121             or die "$name - $base";
122              
123 0           $dir = $self->create($upper, %args, deleted => 1);
124             }
125              
126 0           my $id = $dir->folder($base);
127 0 0         if(!defined $id)
    0          
    0          
128 0   0       { my $idopt= $args{id_options} || [];
129 0           $id = $dir->addSubfolder($base, @$idopt, deleted => $args{deleted});
130             }
131             elsif($args{deleted})
132 0           { $id->deleted(1);
133 0           return $id;
134             }
135             elsif($id->deleted)
136             { # Revive! Raise the death!
137 0           $id->deleted(0);
138             }
139             else
140             { # Bumped into existing folder
141 0           $self->log(ERROR => "Folder $name already exists");
142 0           return undef;
143             }
144              
145 0 0 0       if(!defined $args{create_real} || $args{create_real})
146 0 0         { $self->defaultFolderType->create($id->location, %args)
147             or return undef;
148             }
149              
150 0           $id;
151             }
152              
153            
154              
155             sub delete($)
156 0     0 1   { my ($self, $name) = @_;
157 0 0         my $id = $self->folder($name) or return ();
158 0           $id->remove;
159              
160 0           $self->SUPER::delete($name);
161             }
162              
163              
164              
165             sub rename($$@)
166 0     0 1   { my ($self, $oldname, $newname, %args) = @_;
167              
168 0           my $old = $self->folder($oldname);
169 0 0         unless(defined $old)
170 0           { $self->log(WARNING
171             => "Source for rename does not exist: $oldname to $newname");
172 0           return ();
173             }
174              
175 0           my ($newdir, $base) = $self->folderCollection($newname);
176 0 0         unless(defined $newdir)
177 0 0         { unless($args{create_supers})
178 0           { $self->log(ERROR
179             => "Cannot rename $oldname to $newname: higher levels missing");
180 0           return ();
181             }
182              
183 0 0         (my $upper = $newname) =~ s!$self->{MBMU_delim}$base!!
184             or die "$newname - $base";
185              
186 0           $newdir = $self->create($upper, %args, deleted => 1);
187             }
188              
189 0           my $oldlocation = $old->location;
190 0           my $new = $old->rename($newdir, $base);
191              
192 0           my $newlocation = $new->location;
193 0 0         if($oldlocation ne $newlocation)
194 0           { require Carp;
195 0           croak("Physical folder relocation not yet implemented");
196             # this needs a $old->rename(xx,yy) which isn't implemented yet
197             }
198              
199 0           $self->log(PROGRESS => "Renamed folder $oldname to $newname");
200 0           $new;
201             }
202              
203             #-------------------------------------------
204              
205              
206             1;