File Coverage

blib/lib/Mail/Box/Net.pm
Criterion Covered Total %
statement 45 76 59.2
branch 0 14 0.0
condition 0 23 0.0
subroutine 15 18 83.3
pod 2 3 66.6
total 62 134 46.2


line stmt bran cond sub pod time code
1             # Copyrights 2001-2023 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.03.
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::Net;
10 1     1   895 use vars '$VERSION';
  1         2  
  1         52  
11             $VERSION = '3.010';
12              
13              
14 1     1   12 use strict;
  1         4  
  1         31  
15 1     1   6 use warnings;
  1         2  
  1         27  
16              
17 1     1   4 use base 'Mail::Box';
  1         2  
  1         149  
18              
19 1     1   15 use Mail::Box::Net::Message;
  1         3  
  1         53  
20              
21 1     1   7 use Mail::Message::Body::Lines;
  1         2  
  1         33  
22 1     1   5 use Mail::Message::Body::File;
  1         4  
  1         46  
23 1     1   6 use Mail::Message::Body::Delayed;
  1         2  
  1         29  
24 1     1   5 use Mail::Message::Body::Multipart;
  1         2  
  1         33  
25              
26 1     1   9 use Mail::Message::Head;
  1         1  
  1         20  
27 1     1   4 use Mail::Message::Head::Delayed;
  1         2  
  1         40  
28              
29 1     1   5 use Carp;
  1         2  
  1         85  
30 1     1   7 use File::Copy;
  1         2  
  1         43  
31 1     1   23 use File::Spec;
  1         5  
  1         30  
32 1     1   6 use File::Basename;
  1         10  
  1         634  
33              
34              
35             sub init($)
36 0     0 0   { my ($self, $args) = @_;
37              
38 0   0       $args->{lock_type} ||= 'NONE';
39 0   0       $args->{body_type} ||= 'Mail::Message::Body::Lines';
40 0   0       $args->{trusted} ||= 0;
41              
42 0           my ($scheme, $s, $port, $u, $pwd, $f);
43 0 0         if(my $d = $args->{folderdir})
44             { # cannot use URI, because some scheme's are fake
45 0           ($scheme, $u, $pwd, $s, $port, $f) = $d =~
46             m! ^ (\w+) \:// # scheme
47             (?: ( [^:\@/]+ ) # username
48             (?: \: ( [^\@/]+ ))? # password
49             \@ )?
50             ( [a-zA-Z0-9.-]+ )? # hostname
51             (?: \: ([0-9]+) )? # port
52             ( / .* )? # path
53             !x;
54 0           $args->{folderdir} =~ s!/$!!;
55             }
56              
57 0   0       $args->{folder} ||= $f || '/';
      0        
58              
59 0           $self->SUPER::init($args);
60              
61 0   0       $self->{MBN_hostname} = $args->{server_name} || $s;
62 0   0       $self->{MBN_port} = $args->{server_port} || $port;
63 0   0       $self->{MBN_username} = $args->{username} || $u;
64 0   0       $self->{MBN_password} = $args->{password} || $pwd;
65              
66             $self->log(WARNING => "The term 'hostname' is confusing wrt folder. You probably need 'server_name'")
67 0 0         if exists $args->{hostname};
68              
69 0           $self;
70             }
71              
72              
73 0     0 1   sub create(@) {shift->notImplemented}
74             sub organization() { 'REMOTE' }
75              
76             sub url()
77 0     0 1   { my $self = shift;
78              
79             my ($user, $pass, $host, $port)
80 0           = @$self{ qw/MBN_username MBN_password MBN_hostname MBN_port/ };
81              
82 0           my $perm = '';
83 0 0         $perm = $user if defined $user;
84 0 0         if(defined $pass)
85 0           { $pass =~ s/(\W)/sprintf "%%%02X", ord $1/ge;
  0            
86 0           $perm .= ':'.$pass;
87             }
88              
89 0 0         $perm .= '@' if length $perm;
90              
91 0           my $loc = $host;
92 0 0         $loc .= ':'.$port if length $port;
93              
94 0           my $name = $self->name;
95 0 0         $loc .= '/'.$name if $name ne '/';
96            
97 0           $self->type . '://' . $perm . $loc;
98             }
99              
100             1;