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