1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
|
# This code is part of Perl distribution Mail-Box version 4.01.
# The POD got stripped from this file by OODoc version 3.05.
# For contributors see file ChangeLog.
# This software is copyright (c) 2001-2025 by Mark Overmeer.
# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
# SPDX-License-Identifier: Artistic-1.0-Perl OR GPL-1.0-or-later
package Mail::Box::Net;{
our $VERSION = '4.01';
}
use parent 'Mail::Box';
use strict;
use warnings;
use Log::Report 'mail-box', import => [ qw/__x warning/ ];
use Mail::Box::Net::Message ();
use Mail::Message::Body::Lines ();
use Mail::Message::Body::File ();
use Mail::Message::Body::Delayed ();
use Mail::Message::Body::Multipart ();
use Mail::Message::Head ();
use Mail::Message::Head::Delayed ();
#--------------------
sub init($)
{ my ($self, $args) = @_;
$args->{lock_type} ||= 'NONE';
$args->{body_type} ||= 'Mail::Message::Body::Lines';
$args->{trusted} ||= 0;
my ($scheme, $s, $port, $u, $pwd, $f);
if(my $d = $args->{folderdir})
{ # cannot use URI, because some scheme's are fake
($scheme, $u, $pwd, $s, $port, $f) = $d =~ m!
^ (\w+) \:// # scheme
(?: ( [^:\@/]+ ) # username
(?: \: ( [^\@/]+ ))? # password
\@ )?
( [a-zA-Z0-9.-]+ )? # hostname
(?: \: ([0-9]+) )? # port
( / .* )? # path
!x;
defined && s/%([0-9a-fA-F]{2})/hex $1/ge
for $u, $pwd, $s, $port, $f;
$args->{folderdir} =~ s!/$!!;
}
$args->{folder} ||= $f || '/';
$self->SUPER::init($args);
$self->{MBN_hostname} = $args->{server_name} || $s;
$self->{MBN_port} = $args->{server_port} || $port;
$self->{MBN_username} = $args->{username} || $u;
$self->{MBN_password} = $args->{password} || $pwd;
! exists $args->{hostname}
or warning __x"the term 'hostname' is confusing wrt folder. You probably need 'server_name'.";
$self;
}
sub create(@) { $_[0]->notImplemented }
sub organization() { 'REMOTE' }
sub url()
{ my $self = shift;
my ($user, $pass, $host, $port) = @$self{ qw/MBN_username MBN_password MBN_hostname MBN_port/ };
my $perm = '';
$perm = $user if defined $user;
if(defined $pass)
{ $pass =~ s/(\W)/sprintf "%%%02X", ord $1/ge;
$perm .= ':'.$pass;
}
$perm .= '@' if length $perm;
my $loc = $host;
$loc .= ':'.$port if length $port;
my $name = $self->name;
$loc .= '/'.$name if $name ne '/';
$self->type . '://' . $perm . $loc;
}
1;
|
