line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Protocol::IMAP::Client; |
2
|
|
|
|
|
|
|
{ |
3
|
|
|
|
|
|
|
$Protocol::IMAP::Client::VERSION = '0.004'; |
4
|
|
|
|
|
|
|
} |
5
|
1
|
|
|
1
|
|
20314
|
use strict; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
31
|
|
6
|
1
|
|
|
1
|
|
4
|
use warnings; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
25
|
|
7
|
1
|
|
|
1
|
|
865
|
use parent qw{Protocol::IMAP}; |
|
1
|
|
|
|
|
257
|
|
|
1
|
|
|
|
|
5
|
|
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
=head1 NAME |
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
Protocol::IMAP::Client - client support for the Internet Message Access Protocol. |
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
=head1 VERSION |
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
version 0.004 |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
=head1 SYNOPSIS |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
package Some::IMAP::Client; |
20
|
|
|
|
|
|
|
use parent 'Protocol::IMAP::Client'; |
21
|
|
|
|
|
|
|
sub on_message { warn "new message!" } |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
package main; |
24
|
|
|
|
|
|
|
my $client = Some::IMAP::Client->new; |
25
|
|
|
|
|
|
|
$client->login('user', 'pass'); |
26
|
|
|
|
|
|
|
$client->idle; |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
=head1 DESCRIPTION |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
There are two standard modes of operation: |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
=over 4 |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
=item * One-shot - connect to a server, process some messages, then disconnect |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
=item * Long-term connection - connect to a server, update status, then sit in idle mode waiting for events |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
=back |
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
For one-shot operation against a server that doesn't keep you waiting, other more mature IMAP implementations |
41
|
|
|
|
|
|
|
are suggested ("see also" section). |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
=head1 IMPLEMENTATION DETAILS |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
All requests from the client have a tag, which is a 'unique' alphanumeric identifier - it is the client's responsibility |
46
|
|
|
|
|
|
|
to ensure these are unique for the session, see the L method for the implementation used here. |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
Server responses are always one of three possible states: |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
=over 4 |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
=item * B - Command was successful |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
=item * B - The server's having none of it |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
=item * B - You sent something invalid |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
=back |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
with additional 'untagged' responses in between. Any significant data is typically exchanged in the untagged sections - the |
61
|
|
|
|
|
|
|
final response to a command is indicated by a tagged response, once the client receives this then it knows that the server |
62
|
|
|
|
|
|
|
has finished with the original request. |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
The IMAP connection will be in one of the following states: |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
=over 4 |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
=item * ConnectionEstablished - we have a valid socket but no data has been exchanged yet, waiting for ServerGreeting |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
=item * ServerGreeting - server has sent an initial greeting, for some servers this may take a few seconds |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
=item * NotAuthenticated - server is waiting for client response, and the client has not yet been authenticated |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
=item * Authenticated - server is waiting on client but we have valid authentication credentials, for PREAUTH state this may happen immediately after ServerGreeting |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
=item * Selected - mailbox has been selected and we have valid context for commands |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
=item * Logout - logout request has been issued, waiting for server response |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
=item * ConnectionClosed - connection has been closed on both sides |
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
=back |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
State changes are provided by the L method. Some actions run automatically on state changes, for example switching to TLS mode and exchanging login information |
85
|
|
|
|
|
|
|
when server greeting has been received. |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
=head1 IMPLEMENTING SUBCLASSES |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
The L classes only provide the framework for handling IMAP data. Typically you would need to subclass this to get a usable IMAP implementation. |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
The following methods are required: |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
=over 4 |
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
=item * write - called at various points to send data back across to the other side of the IMAP connection |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
=item * on_user - called when the user name is required for the login stage |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
=item * on_pass - called when the password is required for the login stage |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
=item * start_idle_timer - switching into idle mode, hint to start the timer so that we can refresh the session as required |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
=item * stop_idle_timer - switch out of idle mode due to other tasks that need to be performed |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
=back |
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
Optionally, you may consider providing these: |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
=over 4 |
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
=item * on_starttls - the STARTTLS stanza has been received and we need to upgrade to a TLS connection. This only applies to STARTTLS connections, which start in plaintext - a regular SSL connection will be SSL encrypted from the initial connection onwards. |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
=back |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
To pass data back into the L layer, you will need the following methods: |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
=over 4 |
118
|
|
|
|
|
|
|
|
119
|
|
|
|
|
|
|
=item * is_multi_line - send a single line of data for handling |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
=item * on_single_line - send a single line of data for handling |
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
=item * on_multi_line - send a multi-line section for handling |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
=back |
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
=head1 LIMITATIONS |
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
=over 4 |
130
|
|
|
|
|
|
|
|
131
|
|
|
|
|
|
|
=item * There is no provision for dealing with messages that exceed memory limits - if someone has a 2Gb email then this will attempt to read it |
132
|
|
|
|
|
|
|
all into memory, and it's quite possible that buffers are being copied around as well. |
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
=item * Limited support for some of the standard protocol pieces, since I'm mainly interested in pulling all new messages then listening for any |
135
|
|
|
|
|
|
|
new ones. |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
=item * SASL authentication is not implemented yet. |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
=back |
140
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
=head1 SEE ALSO |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
=over 4 |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
=item * L - up-to-date, supports IDLE, generally seems to be the best of the bunch. |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
=item * L - rewritten version of Net::IMAP::Simple, seems to be well maintained and up to date although it's not been |
148
|
|
|
|
|
|
|
around as long as some of the other options. |
149
|
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
=item * L - handy for simple one-off mailbox access although has a few API limitations. |
151
|
|
|
|
|
|
|
|
152
|
|
|
|
|
|
|
=item * L - over a decade since the last update, and doesn't appear to be passing on many platforms, but at least the API |
153
|
|
|
|
|
|
|
is reasonably full-featured. |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
=back |
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
=cut |
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
use Protocol::IMAP::Fetch; |
160
|
|
|
|
|
|
|
use List::Util qw(min); |
161
|
|
|
|
|
|
|
use Try::Tiny; |
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
=head1 METHODS |
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
=cut |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
=head2 new |
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
Instantiate a new object - the subclass does not need to call this if it hits L at some point before attempting to transfer data. |
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
=cut |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
sub new { |
174
|
|
|
|
|
|
|
my $class = shift; |
175
|
|
|
|
|
|
|
my $self = bless { @_ }, $class; |
176
|
|
|
|
|
|
|
return $self; |
177
|
|
|
|
|
|
|
} |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
sub on_read { |
180
|
|
|
|
|
|
|
my $self = shift; |
181
|
|
|
|
|
|
|
my $buffref = shift; |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
# warn "on_read with " . $$buffref; |
184
|
|
|
|
|
|
|
if(my $fetch = $self->{fetching}) { |
185
|
|
|
|
|
|
|
return 0 if $fetch->on_read($buffref); |
186
|
|
|
|
|
|
|
# warn "Finished the read!\n"; |
187
|
|
|
|
|
|
|
delete $self->{fetching}; |
188
|
|
|
|
|
|
|
return 1; |
189
|
|
|
|
|
|
|
} |
190
|
|
|
|
|
|
|
|
191
|
|
|
|
|
|
|
if($self->is_multi_line) { |
192
|
|
|
|
|
|
|
$self->debug("Multi line: buffer has " . $$buffref); |
193
|
|
|
|
|
|
|
$self->on_multi_line($buffref); |
194
|
|
|
|
|
|
|
return 0; |
195
|
|
|
|
|
|
|
} |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
if($$buffref =~ s/^(.*)[\r\n]+//) { |
198
|
|
|
|
|
|
|
$self->on_single_line($1); |
199
|
|
|
|
|
|
|
return 1; |
200
|
|
|
|
|
|
|
$self->debug("Switched to multiline mode") if $self->is_multi_line; |
201
|
|
|
|
|
|
|
return 1 if $self->is_multi_line; |
202
|
|
|
|
|
|
|
} |
203
|
|
|
|
|
|
|
return 0; |
204
|
|
|
|
|
|
|
} |
205
|
|
|
|
|
|
|
|
206
|
|
|
|
|
|
|
=head2 on_single_line |
207
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
Called when there's more data to process for a single-line (standard mode) response. |
209
|
|
|
|
|
|
|
|
210
|
|
|
|
|
|
|
=cut |
211
|
|
|
|
|
|
|
|
212
|
|
|
|
|
|
|
sub on_single_line { |
213
|
|
|
|
|
|
|
my ($self, $data) = @_; |
214
|
|
|
|
|
|
|
|
215
|
|
|
|
|
|
|
$data =~ s/[\r\n]+//g; |
216
|
|
|
|
|
|
|
$self->debug("Had [$data]"); |
217
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
if($self->in_state('ConnectionEstablished')) { |
219
|
|
|
|
|
|
|
$self->check_greeting($data); |
220
|
|
|
|
|
|
|
} |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
# Untagged responses either have a numeric or a text prefix |
223
|
|
|
|
|
|
|
if($data =~ /^\* ([A-Z]+) (.*?)$/) { |
224
|
|
|
|
|
|
|
# untagged |
225
|
|
|
|
|
|
|
$self->handle_untagged($1, $2); |
226
|
|
|
|
|
|
|
} elsif($data =~ /^\* (\d+) (.*?)$/) { |
227
|
|
|
|
|
|
|
# untagged |
228
|
|
|
|
|
|
|
$self->handle_numeric($1, $2); |
229
|
|
|
|
|
|
|
} elsif($data =~ /^([\w]+) (OK|NO|BAD) (.*?)$/i) { |
230
|
|
|
|
|
|
|
# And tagged responses indicate that a server command has finished |
231
|
|
|
|
|
|
|
my $id = $1; |
232
|
|
|
|
|
|
|
my $status = $2; |
233
|
|
|
|
|
|
|
my $response = $3; |
234
|
|
|
|
|
|
|
$self->debug("Check for $1 with waiting: " . join(',', keys %{$self->{waiting}})); |
235
|
|
|
|
|
|
|
my $code = $self->{waiting}->{$id}; |
236
|
|
|
|
|
|
|
$code->($status, $response) if $code; |
237
|
|
|
|
|
|
|
delete $self->{waiting}->{$id}; |
238
|
|
|
|
|
|
|
} |
239
|
|
|
|
|
|
|
|
240
|
|
|
|
|
|
|
return 0 unless $self->is_multi_line; |
241
|
|
|
|
|
|
|
return $self->{multiline}->{remaining}; |
242
|
|
|
|
|
|
|
} |
243
|
|
|
|
|
|
|
|
244
|
|
|
|
|
|
|
=head2 on_multi_line |
245
|
|
|
|
|
|
|
|
246
|
|
|
|
|
|
|
Called when we have multi-line data (fixed size in characters). |
247
|
|
|
|
|
|
|
|
248
|
|
|
|
|
|
|
=cut |
249
|
|
|
|
|
|
|
|
250
|
|
|
|
|
|
|
sub on_multi_line { |
251
|
|
|
|
|
|
|
my ($self, $buffref) = @_; |
252
|
|
|
|
|
|
|
|
253
|
|
|
|
|
|
|
if($self->{multiline}->{remaining}) { |
254
|
|
|
|
|
|
|
my $chunk = substr $$buffref, 0, min($self->{multiline}->{remaining}, length $$buffref), ''; |
255
|
|
|
|
|
|
|
$self->{multiline}->{buffer} .= $chunk; |
256
|
|
|
|
|
|
|
$self->{multiline}->{remaining} -= length $chunk; |
257
|
|
|
|
|
|
|
} |
258
|
|
|
|
|
|
|
|
259
|
|
|
|
|
|
|
if($self->{multiline}->{remaining} == 0) { |
260
|
|
|
|
|
|
|
$self->{multiline}->{on_complete}->($self->{multiline}->{buffer}); |
261
|
|
|
|
|
|
|
delete $self->{multiline}; |
262
|
|
|
|
|
|
|
} |
263
|
|
|
|
|
|
|
return $self; |
264
|
|
|
|
|
|
|
} |
265
|
|
|
|
|
|
|
|
266
|
|
|
|
|
|
|
=head2 handle_untagged |
267
|
|
|
|
|
|
|
|
268
|
|
|
|
|
|
|
Process an untagged message from the server. |
269
|
|
|
|
|
|
|
|
270
|
|
|
|
|
|
|
=cut |
271
|
|
|
|
|
|
|
|
272
|
|
|
|
|
|
|
sub handle_untagged { |
273
|
|
|
|
|
|
|
my $self = shift; |
274
|
|
|
|
|
|
|
my ($cmd, $response) = @_; |
275
|
|
|
|
|
|
|
$self->debug("Had untagged: $cmd with data $response"); |
276
|
|
|
|
|
|
|
my $method = join('_', 'check', lc $cmd); |
277
|
|
|
|
|
|
|
$self->$method($response) if $self->can($method); |
278
|
|
|
|
|
|
|
return $self; |
279
|
|
|
|
|
|
|
} |
280
|
|
|
|
|
|
|
|
281
|
|
|
|
|
|
|
=head2 untagged_fetch |
282
|
|
|
|
|
|
|
|
283
|
|
|
|
|
|
|
Fetch untagged message data. Defines the multiline callback so that we build up a buffer for the data to process. |
284
|
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
Once we call this method, the pending message takes over input until it has managed |
286
|
|
|
|
|
|
|
to read the entire response. |
287
|
|
|
|
|
|
|
|
288
|
|
|
|
|
|
|
=cut |
289
|
|
|
|
|
|
|
|
290
|
|
|
|
|
|
|
sub untagged_fetch { |
291
|
|
|
|
|
|
|
my $self = shift; |
292
|
|
|
|
|
|
|
my ($idx, $data) = @_; |
293
|
|
|
|
|
|
|
$self->debug("Fetch data: $data"); |
294
|
|
|
|
|
|
|
|
295
|
|
|
|
|
|
|
try { |
296
|
|
|
|
|
|
|
my $fetch = Protocol::IMAP::Fetch->new; |
297
|
|
|
|
|
|
|
$fetch->completion->on_done($self->{fetch_handler}[0]); |
298
|
|
|
|
|
|
|
push @{$self->{fetch_stack}}, $fetch; |
299
|
|
|
|
|
|
|
$self->{fetching} = $fetch if $fetch->on_read(\$data); |
300
|
|
|
|
|
|
|
} catch { |
301
|
|
|
|
|
|
|
warn "error: $_" |
302
|
|
|
|
|
|
|
}; |
303
|
|
|
|
|
|
|
return $self; |
304
|
|
|
|
|
|
|
} |
305
|
|
|
|
|
|
|
|
306
|
|
|
|
|
|
|
sub untagged_list { |
307
|
|
|
|
|
|
|
my $self = shift; |
308
|
|
|
|
|
|
|
my ($idx, $data) = @_; |
309
|
|
|
|
|
|
|
$self->debug("List data: $data"); |
310
|
|
|
|
|
|
|
|
311
|
|
|
|
|
|
|
# $fetch->completion->on_done($self->{fetch_handler}[0]); |
312
|
|
|
|
|
|
|
return $self; |
313
|
|
|
|
|
|
|
} |
314
|
|
|
|
|
|
|
|
315
|
|
|
|
|
|
|
=head2 handle_numeric |
316
|
|
|
|
|
|
|
|
317
|
|
|
|
|
|
|
Deal with an untagged response with a numeric prefix. |
318
|
|
|
|
|
|
|
|
319
|
|
|
|
|
|
|
=cut |
320
|
|
|
|
|
|
|
|
321
|
|
|
|
|
|
|
sub handle_numeric { |
322
|
|
|
|
|
|
|
my $self = shift; |
323
|
|
|
|
|
|
|
my ($num, $data) = @_; |
324
|
|
|
|
|
|
|
$data =~ s/^(\w+)\s*//; |
325
|
|
|
|
|
|
|
my $cmd = $1; |
326
|
|
|
|
|
|
|
$self->debug("Now we have $cmd with $num"); |
327
|
|
|
|
|
|
|
my $method = join('_', 'untagged', lc $cmd); |
328
|
|
|
|
|
|
|
$self->$method($num, $data) if $self->can($method); |
329
|
|
|
|
|
|
|
$self->{on_idle_update}->($cmd, $num) if $self->{on_idle_update} && $self->{in_idle}; |
330
|
|
|
|
|
|
|
return $self; |
331
|
|
|
|
|
|
|
} |
332
|
|
|
|
|
|
|
|
333
|
|
|
|
|
|
|
=head2 on_server_greeting |
334
|
|
|
|
|
|
|
|
335
|
|
|
|
|
|
|
Parse the server greeting, and move on to the capabilities step. |
336
|
|
|
|
|
|
|
|
337
|
|
|
|
|
|
|
=cut |
338
|
|
|
|
|
|
|
|
339
|
|
|
|
|
|
|
sub on_server_greeting { |
340
|
|
|
|
|
|
|
my $self = shift; |
341
|
|
|
|
|
|
|
my $data = shift; |
342
|
|
|
|
|
|
|
$self->debug("Had valid server greeting"); |
343
|
|
|
|
|
|
|
($self->{server_name}) = $data =~ /^\* OK (.*?)$/; |
344
|
|
|
|
|
|
|
$self->get_capabilities; |
345
|
|
|
|
|
|
|
} |
346
|
|
|
|
|
|
|
|
347
|
|
|
|
|
|
|
=head2 on_not_authenticated |
348
|
|
|
|
|
|
|
|
349
|
|
|
|
|
|
|
Handle the change of state from 'connected' to 'not authenticated', which indicates that we've had a valid server greeting and it's |
350
|
|
|
|
|
|
|
time to get ourselves authenticated. |
351
|
|
|
|
|
|
|
|
352
|
|
|
|
|
|
|
Depending on whether we're expecting (and supporting) the STARTTLS upgrade, we'll either switch to TLS mode at this point or just log |
353
|
|
|
|
|
|
|
in directly. |
354
|
|
|
|
|
|
|
|
355
|
|
|
|
|
|
|
=cut |
356
|
|
|
|
|
|
|
|
357
|
|
|
|
|
|
|
sub on_not_authenticated { |
358
|
|
|
|
|
|
|
my $self = shift; |
359
|
|
|
|
|
|
|
if($self->{tls} && $self->{capability}->{STARTTLS} && !$self->{tls_enabled}) { |
360
|
|
|
|
|
|
|
return $self->starttls; |
361
|
|
|
|
|
|
|
} else { |
362
|
|
|
|
|
|
|
$self->debug("Attempt to log in"); |
363
|
|
|
|
|
|
|
$self->invoke_event(authentication_required => ); |
364
|
|
|
|
|
|
|
} |
365
|
|
|
|
|
|
|
} |
366
|
|
|
|
|
|
|
|
367
|
|
|
|
|
|
|
=head2 on_authenticated |
368
|
|
|
|
|
|
|
|
369
|
|
|
|
|
|
|
What to do when we've been authenticated and are ready to begin the session. Suggest the subclass overrides this to make it do |
370
|
|
|
|
|
|
|
something useful. |
371
|
|
|
|
|
|
|
|
372
|
|
|
|
|
|
|
=cut |
373
|
|
|
|
|
|
|
|
374
|
|
|
|
|
|
|
sub on_authenticated { |
375
|
|
|
|
|
|
|
my $self = shift; |
376
|
|
|
|
|
|
|
$self->debug("Authenticated session"); |
377
|
|
|
|
|
|
|
} |
378
|
|
|
|
|
|
|
|
379
|
|
|
|
|
|
|
=head2 check_capability |
380
|
|
|
|
|
|
|
|
381
|
|
|
|
|
|
|
Check the server capabilities, and store them locally. |
382
|
|
|
|
|
|
|
|
383
|
|
|
|
|
|
|
=cut |
384
|
|
|
|
|
|
|
|
385
|
|
|
|
|
|
|
sub check_capability { |
386
|
|
|
|
|
|
|
my $self = shift; |
387
|
|
|
|
|
|
|
my $data = shift; |
388
|
|
|
|
|
|
|
foreach my $cap (split ' ', $data) { |
389
|
|
|
|
|
|
|
$self->debug("Have cap: $cap"); |
390
|
|
|
|
|
|
|
if($cap =~ /^auth=(.*)/i) { |
391
|
|
|
|
|
|
|
push @{ $self->{authtype} }, $1; |
392
|
|
|
|
|
|
|
} else { |
393
|
|
|
|
|
|
|
# Some servers have variations on the case here, fold to a standard case for ease of checking later |
394
|
|
|
|
|
|
|
$cap = 'IMAP4rev1' if lc $cap eq 'imap4rev1'; |
395
|
|
|
|
|
|
|
$self->{capability}->{$cap} = 1; |
396
|
|
|
|
|
|
|
} |
397
|
|
|
|
|
|
|
} |
398
|
|
|
|
|
|
|
die "Not IMAP4rev1-capable" unless $self->{capability}->{'IMAP4rev1'}; |
399
|
|
|
|
|
|
|
$self->on_capability($self->{capability}); |
400
|
|
|
|
|
|
|
} |
401
|
|
|
|
|
|
|
|
402
|
|
|
|
|
|
|
=head2 on_capability |
403
|
|
|
|
|
|
|
|
404
|
|
|
|
|
|
|
Virtual method called when we have capabilities back from the server. |
405
|
|
|
|
|
|
|
|
406
|
|
|
|
|
|
|
=cut |
407
|
|
|
|
|
|
|
|
408
|
|
|
|
|
|
|
sub on_capability { |
409
|
|
|
|
|
|
|
my $self = shift; |
410
|
|
|
|
|
|
|
my $caps = shift; |
411
|
|
|
|
|
|
|
} |
412
|
|
|
|
|
|
|
|
413
|
|
|
|
|
|
|
=head2 check_greeting |
414
|
|
|
|
|
|
|
|
415
|
|
|
|
|
|
|
Verify that we had a reasonable response back from the server as an initial greeting, just in case someone pointed us at an SSH listener |
416
|
|
|
|
|
|
|
or something equally unexpected. |
417
|
|
|
|
|
|
|
|
418
|
|
|
|
|
|
|
=cut |
419
|
|
|
|
|
|
|
|
420
|
|
|
|
|
|
|
sub check_greeting { |
421
|
|
|
|
|
|
|
my $self = shift; |
422
|
|
|
|
|
|
|
my $data = shift; |
423
|
|
|
|
|
|
|
if($data =~ /^\* OK/) { |
424
|
|
|
|
|
|
|
$self->state('ServerGreeting', $data); |
425
|
|
|
|
|
|
|
} else { |
426
|
|
|
|
|
|
|
$self->state('Logout'); |
427
|
|
|
|
|
|
|
} |
428
|
|
|
|
|
|
|
} |
429
|
|
|
|
|
|
|
|
430
|
|
|
|
|
|
|
=head2 get_capabilities |
431
|
|
|
|
|
|
|
|
432
|
|
|
|
|
|
|
Request capabilities from the server. |
433
|
|
|
|
|
|
|
|
434
|
|
|
|
|
|
|
=cut |
435
|
|
|
|
|
|
|
|
436
|
|
|
|
|
|
|
sub get_capabilities { |
437
|
|
|
|
|
|
|
my $self = shift; |
438
|
|
|
|
|
|
|
my %args = @_; |
439
|
|
|
|
|
|
|
my $f = $self->_future_from_args(\%args); |
440
|
|
|
|
|
|
|
$self->send_command( |
441
|
|
|
|
|
|
|
command => 'CAPABILITY', |
442
|
|
|
|
|
|
|
on_ok => $self->_capture_weakself(sub { |
443
|
|
|
|
|
|
|
my $self = shift; |
444
|
|
|
|
|
|
|
my $data = shift; |
445
|
|
|
|
|
|
|
$self->debug("Successfully retrieved caps: $data"); |
446
|
|
|
|
|
|
|
$self->state('NotAuthenticated'); |
447
|
|
|
|
|
|
|
$f->done($data); |
448
|
|
|
|
|
|
|
}), |
449
|
|
|
|
|
|
|
on_bad => $self->_capture_weakself(sub { |
450
|
|
|
|
|
|
|
my $self = shift; |
451
|
|
|
|
|
|
|
my $data = shift; |
452
|
|
|
|
|
|
|
$self->debug("Caps retrieval failed: $data"); |
453
|
|
|
|
|
|
|
$f->fail($data); |
454
|
|
|
|
|
|
|
}) |
455
|
|
|
|
|
|
|
); |
456
|
|
|
|
|
|
|
$f |
457
|
|
|
|
|
|
|
} |
458
|
|
|
|
|
|
|
|
459
|
|
|
|
|
|
|
=head2 next_id |
460
|
|
|
|
|
|
|
|
461
|
|
|
|
|
|
|
Returns the next ID in the sequence. Uses a standard Perl increment, tags are suggested to be 'alphanumeric' |
462
|
|
|
|
|
|
|
but with no particular restrictions in place so this should be good for even long-running sessions. |
463
|
|
|
|
|
|
|
|
464
|
|
|
|
|
|
|
=cut |
465
|
|
|
|
|
|
|
|
466
|
|
|
|
|
|
|
sub next_id { |
467
|
|
|
|
|
|
|
my $self = shift; |
468
|
|
|
|
|
|
|
unless($self->{id}) { |
469
|
|
|
|
|
|
|
$self->{id} = 'A0001'; |
470
|
|
|
|
|
|
|
} |
471
|
|
|
|
|
|
|
my $id = $self->{id}; |
472
|
|
|
|
|
|
|
++$self->{id}; |
473
|
|
|
|
|
|
|
return $id; |
474
|
|
|
|
|
|
|
} |
475
|
|
|
|
|
|
|
|
476
|
|
|
|
|
|
|
=head2 push_waitlist |
477
|
|
|
|
|
|
|
|
478
|
|
|
|
|
|
|
Add a command to the waitlist. |
479
|
|
|
|
|
|
|
|
480
|
|
|
|
|
|
|
Sometimes we need to wait for the server to catch up before sending the next entry. |
481
|
|
|
|
|
|
|
|
482
|
|
|
|
|
|
|
TODO - maybe a mergepoint would be better for this? |
483
|
|
|
|
|
|
|
|
484
|
|
|
|
|
|
|
=cut |
485
|
|
|
|
|
|
|
|
486
|
|
|
|
|
|
|
sub push_waitlist { |
487
|
|
|
|
|
|
|
my $self = shift; |
488
|
|
|
|
|
|
|
my $id = shift; |
489
|
|
|
|
|
|
|
my $sub = shift; |
490
|
|
|
|
|
|
|
$self->{waiting}->{$id} = $sub; |
491
|
|
|
|
|
|
|
return $self; |
492
|
|
|
|
|
|
|
} |
493
|
|
|
|
|
|
|
|
494
|
|
|
|
|
|
|
=head2 send_command |
495
|
|
|
|
|
|
|
|
496
|
|
|
|
|
|
|
Generic helper method to send a command to the server. |
497
|
|
|
|
|
|
|
|
498
|
|
|
|
|
|
|
=cut |
499
|
|
|
|
|
|
|
|
500
|
|
|
|
|
|
|
sub send_command { |
501
|
|
|
|
|
|
|
my $self = shift; |
502
|
|
|
|
|
|
|
my %args = @_; |
503
|
|
|
|
|
|
|
my $id = exists $args{id} ? $args{id} : $self->next_id; |
504
|
|
|
|
|
|
|
if($self->{in_idle} && defined $id) { |
505
|
|
|
|
|
|
|
# If we're currently in IDLE mode, we have to finish the current command first by issuing the DONE command. |
506
|
|
|
|
|
|
|
return $self->done( |
507
|
|
|
|
|
|
|
on_ok => $self->_capture_weakself(sub { |
508
|
|
|
|
|
|
|
my $self = shift; |
509
|
|
|
|
|
|
|
$self->{in_idle} = 0; |
510
|
|
|
|
|
|
|
$self->send_command(%args, id => $id); |
511
|
|
|
|
|
|
|
}) |
512
|
|
|
|
|
|
|
); |
513
|
|
|
|
|
|
|
} |
514
|
|
|
|
|
|
|
|
515
|
|
|
|
|
|
|
my $cmd = $args{command}; |
516
|
|
|
|
|
|
|
my $data = defined $id ? "$id " : ''; |
517
|
|
|
|
|
|
|
$data .= $cmd; |
518
|
|
|
|
|
|
|
$data .= ' ' . $args{param} if $args{param}; |
519
|
|
|
|
|
|
|
$self->push_waitlist($id, sub { |
520
|
|
|
|
|
|
|
my ($status, $data) = @_; |
521
|
|
|
|
|
|
|
my $method = join('_', 'on', lc $status); |
522
|
|
|
|
|
|
|
(delete $args{$method})->($data) if exists $args{$method}; |
523
|
|
|
|
|
|
|
(delete $args{on_response})->("$status $data") if exists $args{on_response}; |
524
|
|
|
|
|
|
|
}) if defined $id; |
525
|
|
|
|
|
|
|
$self->debug("Sending [$data] to server"); |
526
|
|
|
|
|
|
|
if($self->{in_idle} && defined $id) { |
527
|
|
|
|
|
|
|
# If we're currently in IDLE mode, we have to finish the current command first by issuing the DONE command. |
528
|
|
|
|
|
|
|
$self->{idle_queue} = $data; |
529
|
|
|
|
|
|
|
$self->done; |
530
|
|
|
|
|
|
|
} else { |
531
|
|
|
|
|
|
|
$self->debug("In idle?") if $self->{in_idle}; |
532
|
|
|
|
|
|
|
$self->write("$data\x0D\x0A"); |
533
|
|
|
|
|
|
|
$self->{in_idle} = 1 if $args{command} eq 'IDLE'; |
534
|
|
|
|
|
|
|
} |
535
|
|
|
|
|
|
|
return $id; |
536
|
|
|
|
|
|
|
} |
537
|
|
|
|
|
|
|
|
538
|
|
|
|
|
|
|
=head2 login |
539
|
|
|
|
|
|
|
|
540
|
|
|
|
|
|
|
Issue the LOGIN command. |
541
|
|
|
|
|
|
|
|
542
|
|
|
|
|
|
|
Takes two parameters: |
543
|
|
|
|
|
|
|
|
544
|
|
|
|
|
|
|
=over 4 |
545
|
|
|
|
|
|
|
|
546
|
|
|
|
|
|
|
=item * $user - username to send |
547
|
|
|
|
|
|
|
|
548
|
|
|
|
|
|
|
=item * $pass - password to send |
549
|
|
|
|
|
|
|
|
550
|
|
|
|
|
|
|
=back |
551
|
|
|
|
|
|
|
|
552
|
|
|
|
|
|
|
See also the L command, which does the same thing but via L if I ever get around to writing it. |
553
|
|
|
|
|
|
|
|
554
|
|
|
|
|
|
|
=cut |
555
|
|
|
|
|
|
|
|
556
|
|
|
|
|
|
|
sub login { |
557
|
|
|
|
|
|
|
my ($self, $user, $pass) = @_; |
558
|
|
|
|
|
|
|
my %args; |
559
|
|
|
|
|
|
|
my $f = $self->_future_from_args(\%args); |
560
|
|
|
|
|
|
|
$self->send_command( |
561
|
|
|
|
|
|
|
command => 'LOGIN', |
562
|
|
|
|
|
|
|
param => qq{$user "$pass"}, |
563
|
|
|
|
|
|
|
on_ok => $self->_capture_weakself(sub { |
564
|
|
|
|
|
|
|
my $self = shift; |
565
|
|
|
|
|
|
|
my $data = shift; |
566
|
|
|
|
|
|
|
$self->debug("Successfully logged in: $data"); |
567
|
|
|
|
|
|
|
$self->state('Authenticated'); |
568
|
|
|
|
|
|
|
$f->done($data); |
569
|
|
|
|
|
|
|
}), |
570
|
|
|
|
|
|
|
on_bad => $self->_capture_weakself(sub { |
571
|
|
|
|
|
|
|
my $self = shift; |
572
|
|
|
|
|
|
|
my $data = shift; |
573
|
|
|
|
|
|
|
$self->debug("Login failed: $data"); |
574
|
|
|
|
|
|
|
$f->fail($data); |
575
|
|
|
|
|
|
|
}) |
576
|
|
|
|
|
|
|
); |
577
|
|
|
|
|
|
|
$f |
578
|
|
|
|
|
|
|
} |
579
|
|
|
|
|
|
|
|
580
|
|
|
|
|
|
|
=head2 check_status |
581
|
|
|
|
|
|
|
|
582
|
|
|
|
|
|
|
Check the mailbox status response as received from the server. |
583
|
|
|
|
|
|
|
|
584
|
|
|
|
|
|
|
=cut |
585
|
|
|
|
|
|
|
|
586
|
|
|
|
|
|
|
sub check_status { |
587
|
|
|
|
|
|
|
my $self = shift; |
588
|
|
|
|
|
|
|
my $data = shift; |
589
|
|
|
|
|
|
|
my %status; |
590
|
|
|
|
|
|
|
my ($mbox) = $data =~ /([^ ]+)/; |
591
|
|
|
|
|
|
|
$mbox =~ s/^(['"])(.*)\1$/$2/; |
592
|
|
|
|
|
|
|
foreach (qw(MESSAGES UNSEEN RECENT UIDNEXT)) { |
593
|
|
|
|
|
|
|
$status{lc($_)} = $1 if $data =~ /$_ (\d+)/i; |
594
|
|
|
|
|
|
|
} |
595
|
|
|
|
|
|
|
$self->{status}->{$mbox} = \%status; |
596
|
|
|
|
|
|
|
return $self; |
597
|
|
|
|
|
|
|
} |
598
|
|
|
|
|
|
|
|
599
|
|
|
|
|
|
|
=head2 noop |
600
|
|
|
|
|
|
|
|
601
|
|
|
|
|
|
|
Send a null command to the server, used as a keepalive or server ping. |
602
|
|
|
|
|
|
|
|
603
|
|
|
|
|
|
|
=cut |
604
|
|
|
|
|
|
|
|
605
|
|
|
|
|
|
|
sub noop { |
606
|
|
|
|
|
|
|
my $self = shift; |
607
|
|
|
|
|
|
|
my %args = @_; |
608
|
|
|
|
|
|
|
|
609
|
|
|
|
|
|
|
my $f = $self->_future_from_args(\%args); |
610
|
|
|
|
|
|
|
$self->send_command( |
611
|
|
|
|
|
|
|
command => 'NOOP', |
612
|
|
|
|
|
|
|
on_ok => sub { |
613
|
|
|
|
|
|
|
my $data = shift; |
614
|
|
|
|
|
|
|
$self->debug("Status completed"); |
615
|
|
|
|
|
|
|
$f->done; |
616
|
|
|
|
|
|
|
}, |
617
|
|
|
|
|
|
|
on_bad => sub { |
618
|
|
|
|
|
|
|
my $data = shift; |
619
|
|
|
|
|
|
|
$self->debug("Login failed: $data"); |
620
|
|
|
|
|
|
|
$f->fail($data); |
621
|
|
|
|
|
|
|
} |
622
|
|
|
|
|
|
|
); |
623
|
|
|
|
|
|
|
return $self; |
624
|
|
|
|
|
|
|
} |
625
|
|
|
|
|
|
|
|
626
|
|
|
|
|
|
|
=head2 starttls |
627
|
|
|
|
|
|
|
|
628
|
|
|
|
|
|
|
Issue the STARTTLS command in an attempt to get the connection upgraded to something more secure. |
629
|
|
|
|
|
|
|
|
630
|
|
|
|
|
|
|
=cut |
631
|
|
|
|
|
|
|
|
632
|
|
|
|
|
|
|
sub starttls { |
633
|
|
|
|
|
|
|
my $self = shift; |
634
|
|
|
|
|
|
|
my %args = @_; |
635
|
|
|
|
|
|
|
|
636
|
|
|
|
|
|
|
my $f = $self->_future_from_args(\%args); |
637
|
|
|
|
|
|
|
$self->send_command( |
638
|
|
|
|
|
|
|
command => 'STARTTLS', |
639
|
|
|
|
|
|
|
on_ok => sub { |
640
|
|
|
|
|
|
|
my $data = shift; |
641
|
|
|
|
|
|
|
$self->debug("STARTTLS in progress"); |
642
|
|
|
|
|
|
|
$f->done(); |
643
|
|
|
|
|
|
|
$self->invoke_event(starttls => ); |
644
|
|
|
|
|
|
|
$self->on_starttls if $self->can('on_starttls'); |
645
|
|
|
|
|
|
|
}, |
646
|
|
|
|
|
|
|
on_bad => sub { |
647
|
|
|
|
|
|
|
my $data = shift; |
648
|
|
|
|
|
|
|
$self->debug("STARTTLS failed: $data"); |
649
|
|
|
|
|
|
|
$f->fail($data); |
650
|
|
|
|
|
|
|
} |
651
|
|
|
|
|
|
|
); |
652
|
|
|
|
|
|
|
$f |
653
|
|
|
|
|
|
|
} |
654
|
|
|
|
|
|
|
|
655
|
|
|
|
|
|
|
sub list { |
656
|
|
|
|
|
|
|
my $self = shift; |
657
|
|
|
|
|
|
|
my %args = @_; |
658
|
|
|
|
|
|
|
|
659
|
|
|
|
|
|
|
my $f = $self->_future_from_args(\%args); |
660
|
|
|
|
|
|
|
push @{$self->{list_handler}}, $args{on_list}; |
661
|
|
|
|
|
|
|
$self->send_command( |
662
|
|
|
|
|
|
|
command => join(' ', 'LIST', ($args{reference} || '""'), ($args{mailbox} || '*')), |
663
|
|
|
|
|
|
|
on_ok => sub { |
664
|
|
|
|
|
|
|
my $data = shift; |
665
|
|
|
|
|
|
|
shift @{$self->{list_handler}}; |
666
|
|
|
|
|
|
|
$f->done($data); |
667
|
|
|
|
|
|
|
}, |
668
|
|
|
|
|
|
|
on_bad => sub { |
669
|
|
|
|
|
|
|
my $data = shift; |
670
|
|
|
|
|
|
|
$f->fail($data); |
671
|
|
|
|
|
|
|
} |
672
|
|
|
|
|
|
|
); |
673
|
|
|
|
|
|
|
$f |
674
|
|
|
|
|
|
|
} |
675
|
|
|
|
|
|
|
|
676
|
|
|
|
|
|
|
sub _future_from_args { |
677
|
|
|
|
|
|
|
my $self = shift; |
678
|
|
|
|
|
|
|
my $args = shift; |
679
|
|
|
|
|
|
|
my $f = shift || Future->new; |
680
|
|
|
|
|
|
|
$f->on_done(delete $args->{on_ok}) if exists $args->{on_ok}; |
681
|
|
|
|
|
|
|
$f->on_fail(delete $args->{on_bad}) if exists $args->{on_bad}; |
682
|
|
|
|
|
|
|
return $f |
683
|
|
|
|
|
|
|
} |
684
|
|
|
|
|
|
|
|
685
|
|
|
|
|
|
|
=head2 status |
686
|
|
|
|
|
|
|
|
687
|
|
|
|
|
|
|
Issue the STATUS command for either the given mailbox, or INBOX if none is provided. |
688
|
|
|
|
|
|
|
|
689
|
|
|
|
|
|
|
=cut |
690
|
|
|
|
|
|
|
|
691
|
|
|
|
|
|
|
sub status { |
692
|
|
|
|
|
|
|
my $self = shift; |
693
|
|
|
|
|
|
|
my %args = @_; |
694
|
|
|
|
|
|
|
|
695
|
|
|
|
|
|
|
my $mbox = $args{mailbox} || 'INBOX'; |
696
|
|
|
|
|
|
|
my $f = $self->_future_from_args(\%args); |
697
|
|
|
|
|
|
|
$self->send_command( |
698
|
|
|
|
|
|
|
command => 'STATUS', |
699
|
|
|
|
|
|
|
param => "$mbox (unseen recent messages uidnext)", |
700
|
|
|
|
|
|
|
on_ok => sub { |
701
|
|
|
|
|
|
|
my $data = shift; |
702
|
|
|
|
|
|
|
$self->debug("Status completed"); |
703
|
|
|
|
|
|
|
$f->done($self->{status}->{$mbox}); |
704
|
|
|
|
|
|
|
}, |
705
|
|
|
|
|
|
|
on_bad => sub { |
706
|
|
|
|
|
|
|
my $data = shift; |
707
|
|
|
|
|
|
|
$self->debug("Login failed: $data"); |
708
|
|
|
|
|
|
|
$f->fail($data); |
709
|
|
|
|
|
|
|
} |
710
|
|
|
|
|
|
|
); |
711
|
|
|
|
|
|
|
return $f; |
712
|
|
|
|
|
|
|
} |
713
|
|
|
|
|
|
|
|
714
|
|
|
|
|
|
|
=head2 select |
715
|
|
|
|
|
|
|
|
716
|
|
|
|
|
|
|
Issue the SELECT command to switch to a different mailbox. |
717
|
|
|
|
|
|
|
|
718
|
|
|
|
|
|
|
=cut |
719
|
|
|
|
|
|
|
|
720
|
|
|
|
|
|
|
sub select : method { |
721
|
|
|
|
|
|
|
my $self = shift; |
722
|
|
|
|
|
|
|
my %args = @_; |
723
|
|
|
|
|
|
|
|
724
|
|
|
|
|
|
|
my $mbox = $args{mailbox} || 'INBOX'; |
725
|
|
|
|
|
|
|
my $f = $self->_future_from_args(\%args); |
726
|
|
|
|
|
|
|
$self->send_command( |
727
|
|
|
|
|
|
|
command => 'SELECT', |
728
|
|
|
|
|
|
|
param => $mbox, |
729
|
|
|
|
|
|
|
on_ok => sub { |
730
|
|
|
|
|
|
|
my $data = shift; |
731
|
|
|
|
|
|
|
$self->debug("Have selected"); |
732
|
|
|
|
|
|
|
$f->done($self->{status}->{$mbox}); |
733
|
|
|
|
|
|
|
}, |
734
|
|
|
|
|
|
|
on_bad => sub { |
735
|
|
|
|
|
|
|
my $data = shift; |
736
|
|
|
|
|
|
|
$self->debug("Login failed: $data"); |
737
|
|
|
|
|
|
|
$f->fail($data); |
738
|
|
|
|
|
|
|
} |
739
|
|
|
|
|
|
|
); |
740
|
|
|
|
|
|
|
$f; |
741
|
|
|
|
|
|
|
} |
742
|
|
|
|
|
|
|
|
743
|
|
|
|
|
|
|
=head2 examine |
744
|
|
|
|
|
|
|
|
745
|
|
|
|
|
|
|
Like L, but readonly. |
746
|
|
|
|
|
|
|
|
747
|
|
|
|
|
|
|
=cut |
748
|
|
|
|
|
|
|
|
749
|
|
|
|
|
|
|
sub examine : method { |
750
|
|
|
|
|
|
|
my $self = shift; |
751
|
|
|
|
|
|
|
my %args = @_; |
752
|
|
|
|
|
|
|
|
753
|
|
|
|
|
|
|
my $mbox = $args{mailbox} || 'INBOX'; |
754
|
|
|
|
|
|
|
my $f = $self->_future_from_args(\%args); |
755
|
|
|
|
|
|
|
$self->send_command( |
756
|
|
|
|
|
|
|
command => 'EXAMINE', |
757
|
|
|
|
|
|
|
param => $mbox, |
758
|
|
|
|
|
|
|
on_ok => sub { |
759
|
|
|
|
|
|
|
my $data = shift; |
760
|
|
|
|
|
|
|
$self->debug("Have selected for readonly"); |
761
|
|
|
|
|
|
|
$f->done($self->{status}->{$mbox}); |
762
|
|
|
|
|
|
|
}, |
763
|
|
|
|
|
|
|
on_bad => sub { |
764
|
|
|
|
|
|
|
my $data = shift; |
765
|
|
|
|
|
|
|
$self->debug("Login failed: $data"); |
766
|
|
|
|
|
|
|
$f->fail($data); |
767
|
|
|
|
|
|
|
} |
768
|
|
|
|
|
|
|
); |
769
|
|
|
|
|
|
|
$f; |
770
|
|
|
|
|
|
|
} |
771
|
|
|
|
|
|
|
|
772
|
|
|
|
|
|
|
=head2 fetch |
773
|
|
|
|
|
|
|
|
774
|
|
|
|
|
|
|
Issue the FETCH command to retrieve one or more messages. |
775
|
|
|
|
|
|
|
|
776
|
|
|
|
|
|
|
=cut |
777
|
|
|
|
|
|
|
|
778
|
|
|
|
|
|
|
sub fetch : method { |
779
|
|
|
|
|
|
|
my $self = shift; |
780
|
|
|
|
|
|
|
my %args = @_; |
781
|
|
|
|
|
|
|
|
782
|
|
|
|
|
|
|
my $msg = exists($args{message}) ? $args{message} : 1; |
783
|
|
|
|
|
|
|
my $type = exists($args{type}) ? $args{type} : 'ALL'; |
784
|
|
|
|
|
|
|
my $f = $self->_future_from_args(\%args); |
785
|
|
|
|
|
|
|
push @{$self->{fetch_handler}}, $args{on_fetch}; |
786
|
|
|
|
|
|
|
$self->send_command( |
787
|
|
|
|
|
|
|
command => 'FETCH', |
788
|
|
|
|
|
|
|
param => "$msg $type", |
789
|
|
|
|
|
|
|
on_ok => sub { |
790
|
|
|
|
|
|
|
my $data = shift; |
791
|
|
|
|
|
|
|
$self->debug("Have fetched"); |
792
|
|
|
|
|
|
|
shift @{$self->{fetch_handler}}; |
793
|
|
|
|
|
|
|
$f->done($data); |
794
|
|
|
|
|
|
|
}, |
795
|
|
|
|
|
|
|
on_bad => sub { |
796
|
|
|
|
|
|
|
my $data = shift; |
797
|
|
|
|
|
|
|
pop @{$self->{fetch_handler}}; |
798
|
|
|
|
|
|
|
$f->fail($data); |
799
|
|
|
|
|
|
|
} |
800
|
|
|
|
|
|
|
); |
801
|
|
|
|
|
|
|
$f |
802
|
|
|
|
|
|
|
} |
803
|
|
|
|
|
|
|
|
804
|
|
|
|
|
|
|
=head2 delete |
805
|
|
|
|
|
|
|
|
806
|
|
|
|
|
|
|
Issue the DELETE command, which will delete one or more messages if it can. |
807
|
|
|
|
|
|
|
|
808
|
|
|
|
|
|
|
=cut |
809
|
|
|
|
|
|
|
|
810
|
|
|
|
|
|
|
sub delete : method { |
811
|
|
|
|
|
|
|
my $self = shift; |
812
|
|
|
|
|
|
|
my %args = @_; |
813
|
|
|
|
|
|
|
|
814
|
|
|
|
|
|
|
my $msg = exists $args{message} ? $args{message} : 1; |
815
|
|
|
|
|
|
|
my $f = $self->_future_from_args(\%args); |
816
|
|
|
|
|
|
|
$self->send_command( |
817
|
|
|
|
|
|
|
command => 'STORE', |
818
|
|
|
|
|
|
|
param => $msg . ' +FLAGS (\Deleted)', |
819
|
|
|
|
|
|
|
on_ok => sub { |
820
|
|
|
|
|
|
|
my $data = shift; |
821
|
|
|
|
|
|
|
$self->debug("Have deleted"); |
822
|
|
|
|
|
|
|
$f->done; |
823
|
|
|
|
|
|
|
}, |
824
|
|
|
|
|
|
|
on_bad => sub { |
825
|
|
|
|
|
|
|
my $data = shift; |
826
|
|
|
|
|
|
|
$self->debug("Login failed: $data"); |
827
|
|
|
|
|
|
|
$f->fail($data); |
828
|
|
|
|
|
|
|
} |
829
|
|
|
|
|
|
|
); |
830
|
|
|
|
|
|
|
$f |
831
|
|
|
|
|
|
|
} |
832
|
|
|
|
|
|
|
|
833
|
|
|
|
|
|
|
=head2 expunge |
834
|
|
|
|
|
|
|
|
835
|
|
|
|
|
|
|
Issue an EXPUNGE to clear any deleted messages from storage. |
836
|
|
|
|
|
|
|
|
837
|
|
|
|
|
|
|
=cut |
838
|
|
|
|
|
|
|
|
839
|
|
|
|
|
|
|
sub expunge : method { |
840
|
|
|
|
|
|
|
my $self = shift; |
841
|
|
|
|
|
|
|
my %args = @_; |
842
|
|
|
|
|
|
|
|
843
|
|
|
|
|
|
|
my $f = $self->_future_from_args(\%args); |
844
|
|
|
|
|
|
|
$self->send_command( |
845
|
|
|
|
|
|
|
command => 'EXPUNGE', |
846
|
|
|
|
|
|
|
on_ok => sub { |
847
|
|
|
|
|
|
|
my $data = shift; |
848
|
|
|
|
|
|
|
$self->debug("Have expunged"); |
849
|
|
|
|
|
|
|
$f->done; |
850
|
|
|
|
|
|
|
}, |
851
|
|
|
|
|
|
|
on_bad => sub { |
852
|
|
|
|
|
|
|
my $data = shift; |
853
|
|
|
|
|
|
|
$self->debug("Login failed: $data"); |
854
|
|
|
|
|
|
|
$f->fail($data); |
855
|
|
|
|
|
|
|
} |
856
|
|
|
|
|
|
|
); |
857
|
|
|
|
|
|
|
$f |
858
|
|
|
|
|
|
|
} |
859
|
|
|
|
|
|
|
|
860
|
|
|
|
|
|
|
=head2 done |
861
|
|
|
|
|
|
|
|
862
|
|
|
|
|
|
|
Issue a DONE command, which did something useful and important at the time although I no longer remember what this was. |
863
|
|
|
|
|
|
|
|
864
|
|
|
|
|
|
|
=cut |
865
|
|
|
|
|
|
|
|
866
|
|
|
|
|
|
|
sub done { |
867
|
|
|
|
|
|
|
my $self = shift; |
868
|
|
|
|
|
|
|
my %args = @_; |
869
|
|
|
|
|
|
|
|
870
|
|
|
|
|
|
|
my $f = $self->_future_from_args(\%args); |
871
|
|
|
|
|
|
|
$self->send_command( |
872
|
|
|
|
|
|
|
command => 'DONE', |
873
|
|
|
|
|
|
|
id => undef, |
874
|
|
|
|
|
|
|
on_ok => sub { |
875
|
|
|
|
|
|
|
my $data = shift; |
876
|
|
|
|
|
|
|
$self->debug("Done completed"); |
877
|
|
|
|
|
|
|
$f->done; |
878
|
|
|
|
|
|
|
}, |
879
|
|
|
|
|
|
|
on_bad => sub { |
880
|
|
|
|
|
|
|
my $data = shift; |
881
|
|
|
|
|
|
|
$self->debug("DONE command failed: $data"); |
882
|
|
|
|
|
|
|
$f->fail($data); |
883
|
|
|
|
|
|
|
} |
884
|
|
|
|
|
|
|
); |
885
|
|
|
|
|
|
|
$f |
886
|
|
|
|
|
|
|
} |
887
|
|
|
|
|
|
|
|
888
|
|
|
|
|
|
|
sub untagged_exists { |
889
|
|
|
|
|
|
|
my $self = shift; |
890
|
|
|
|
|
|
|
my $count = shift; |
891
|
|
|
|
|
|
|
$self->debug("Exists @_"); |
892
|
|
|
|
|
|
|
$self->invoke_event(message_available => $count); |
893
|
|
|
|
|
|
|
return $self; |
894
|
|
|
|
|
|
|
} |
895
|
|
|
|
|
|
|
|
896
|
|
|
|
|
|
|
=head2 idle |
897
|
|
|
|
|
|
|
|
898
|
|
|
|
|
|
|
Switch to IDLE mode. This will put the server into a state where it will continue to send untagged |
899
|
|
|
|
|
|
|
responses as any changes happen to the selected mailboxes. |
900
|
|
|
|
|
|
|
|
901
|
|
|
|
|
|
|
=cut |
902
|
|
|
|
|
|
|
|
903
|
|
|
|
|
|
|
sub idle { |
904
|
|
|
|
|
|
|
my $self = shift; |
905
|
|
|
|
|
|
|
my %args = @_; |
906
|
|
|
|
|
|
|
|
907
|
|
|
|
|
|
|
$self->{start_idle_timer}->(%args) if $self->{start_idle_timer}; |
908
|
|
|
|
|
|
|
my $f = $self->_future_from_args(\%args); |
909
|
|
|
|
|
|
|
$self->send_command( |
910
|
|
|
|
|
|
|
command => 'IDLE', |
911
|
|
|
|
|
|
|
on_ok => $self->_capture_weakself( sub { |
912
|
|
|
|
|
|
|
my $data = shift; |
913
|
|
|
|
|
|
|
$self->debug("Left IDLE mode"); |
914
|
|
|
|
|
|
|
$self->{idle_timer}->stop if $self->{idle_timer}; |
915
|
|
|
|
|
|
|
$self->{in_idle} = 0; |
916
|
|
|
|
|
|
|
my $queued = $self->{idle_queue}; |
917
|
|
|
|
|
|
|
$self->write("$queued\x0D\x0A") if $queued; |
918
|
|
|
|
|
|
|
$f->done; |
919
|
|
|
|
|
|
|
}), |
920
|
|
|
|
|
|
|
on_bad => sub { |
921
|
|
|
|
|
|
|
my $data = shift; |
922
|
|
|
|
|
|
|
$self->debug("Idle failed: $data"); |
923
|
|
|
|
|
|
|
$self->{in_idle} = 0; |
924
|
|
|
|
|
|
|
$f->fail($data); |
925
|
|
|
|
|
|
|
} |
926
|
|
|
|
|
|
|
); |
927
|
|
|
|
|
|
|
$f; |
928
|
|
|
|
|
|
|
} |
929
|
|
|
|
|
|
|
|
930
|
|
|
|
|
|
|
=head2 is_multi_line |
931
|
|
|
|
|
|
|
|
932
|
|
|
|
|
|
|
Returns true if we're in a multiline (fixed size read) state. |
933
|
|
|
|
|
|
|
|
934
|
|
|
|
|
|
|
=cut |
935
|
|
|
|
|
|
|
|
936
|
|
|
|
|
|
|
sub is_multi_line { shift->{multiline} ? 1 : 0 } |
937
|
|
|
|
|
|
|
|
938
|
|
|
|
|
|
|
=head2 configure |
939
|
|
|
|
|
|
|
|
940
|
|
|
|
|
|
|
Set up any callbacks that were available. |
941
|
|
|
|
|
|
|
|
942
|
|
|
|
|
|
|
=cut |
943
|
|
|
|
|
|
|
|
944
|
|
|
|
|
|
|
sub configure { |
945
|
|
|
|
|
|
|
my $self = shift; |
946
|
|
|
|
|
|
|
my %args = @_; |
947
|
|
|
|
|
|
|
|
948
|
|
|
|
|
|
|
# Enable TLS by default |
949
|
|
|
|
|
|
|
if(exists $args{tls}) { |
950
|
|
|
|
|
|
|
$self->{tls} = delete $args{tls}; |
951
|
|
|
|
|
|
|
} else { |
952
|
|
|
|
|
|
|
$self->{tls} = 1; |
953
|
|
|
|
|
|
|
} |
954
|
|
|
|
|
|
|
|
955
|
|
|
|
|
|
|
foreach ($self->STATE_HANDLERS, qw{ |
956
|
|
|
|
|
|
|
on_idle_update |
957
|
|
|
|
|
|
|
on_message |
958
|
|
|
|
|
|
|
on_message_received |
959
|
|
|
|
|
|
|
on_message_available |
960
|
|
|
|
|
|
|
}) { |
961
|
|
|
|
|
|
|
$self->{$_} = delete $args{$_} if exists $args{$_}; |
962
|
|
|
|
|
|
|
} |
963
|
|
|
|
|
|
|
return %args; |
964
|
|
|
|
|
|
|
} |
965
|
|
|
|
|
|
|
|
966
|
|
|
|
|
|
|
1; |
967
|
|
|
|
|
|
|
|
968
|
|
|
|
|
|
|
__END__ |