root/prompop/trunk/prompop

Revision 587 (checked in by miyagawa, 19 years ago)

Initial revision

  • Property svn:eol-style set to native
  • Property svn:executable set to *
  • Property svn:keywords set to Author Date Id Revision
Line 
1 #!/usr/local/bin/perl
2
3 use strict;
4
5 use vars qw($VERSION);
6 $VERSION = '0.01';
7
8 use strict;
9 use FileHandle;
10
11 package ProcMailToMHPopper;
12 use Digest::MD5 qw(md5_hex);
13
14 sub new {
15     my($class, $out, $in, $maildir, $crypt) = @_;
16     bless {
17         inhandle => $in,
18         outhandle => $out,
19         maildir => $maildir,
20         crypted => $crypt,
21         mails => [],
22     }, $class;
23 }
24
25 sub mail_count {
26     my $self = shift;
27     return scalar @{$self->{mails}};
28 }
29
30 sub mail {
31     my($self, $i) = @_;
32     return $self->{mails}->[$i - 1];
33 }
34
35 sub size {
36     my($self, $i) = @_;
37     return $self->mail($i)->{size};
38 }
39
40 sub handle {
41     my($self, $i) = @_;
42     return FileHandle->new($self->mail($i)->{path});
43 }
44
45 sub retrieve {
46     my($self, $i) = @_;
47     $self->out("+OK\r\n");
48     my $handle = $self->handle($i) or die;
49     while (defined ($_ = $handle->getline)) {
50         s/\n/\r\n/g;
51         $self->out($_);
52     }
53     $self->out(".\r\n");
54 }
55
56 sub top {
57     my($self, $i, $line) = @_;
58     $self->out("+OK\r\n");
59     my $handle = $self->handle($i) or die;
60
61     # header
62     my $header = do { local $/ = "\n\n"; <$handle> };
63     $header =~ s/\n/\r\n/g;
64     $self->out($header);
65
66     my $outline = 0;
67     while (defined ($_ = $handle->getline)) {
68         last if ++$outline > $line;
69         s/\n/\r\n/g;
70         $self->out($_);
71     }
72     $self->out("\r\n.\r\n");
73 }
74
75 sub authorized { shift->{authorized} }
76 sub crypted    { shift->{crypted} }
77 sub maildir    { shift->{maildir} }
78
79 sub in {
80     my $self = shift;
81     return wantarray ? $self->{inhandle}->getlines : $self->{inhandle}->getline;
82 }
83
84 sub out {
85     my $self = shift;
86     $self->{outhandle}->print(@_);
87 }
88
89 sub init_session {
90     my $self = shift;
91     $self->out("+OK\r\n");
92 }
93
94 sub parse_mailinfo {
95     my($self, $logfile) = @_;
96     my $log = FileHandle->new($logfile) or return; # no new mail
97     my @mails;
98     while (<$log>) {
99         /^  Folder: (\S*)/ and push @mails, $self->mailinfo($1);
100     }
101     $self->{mails} = \@mails;
102 }
103
104 sub mailinfo {
105     my($self, $file) = @_;
106     unless (substr($file, 0, 1) eq '/') {
107         # default: full path
108         $file =  join('/', $self->maildir, $file);
109     }
110     return {
111         path => $file, size => -s $file,
112     };
113 }
114
115 sub stat {
116     my $self = shift;
117     my $count = $self->mail_count;
118     my $size = 0;
119     $size += $self->size($_) for 1..$self->mail_count;
120     $self->out("+OK $count $size\r\n");
121 }
122
123 sub uidl {
124     my $self = shift;
125     $self->out("+OK\r\n");
126     for my $i (1 .. $self->mail_count) {
127         my $uidl = $self->_mail_uidl($i);
128         $self->out("$i $uidl\r\n");
129     }
130     $self->out(".\r\n");
131 }
132
133 sub _mail_uidl {
134     my($self, $i) = @_;
135     my $path = $self->mail($i)->{path};
136     return md5_hex $path;
137 }
138
139 sub quit {
140     my $self = shift;
141     $self->out("+OK\r\n");
142 }
143
144 sub listing {
145     my($self, $i) = @_;
146     my $size = $self->size($i);
147     $self->out("+OK $i $size\r\n");
148 }
149
150 sub authorize_first {
151     my $self = shift;
152     $self->out("-ERR authorization first\r\n");
153 }
154
155 sub authorize {
156     my($self, $input) = @_;
157     if (crypt($input, $self->crypted) eq $self->crypted) {
158         $self->out("+OK\r\n");
159         $self->{authorized} = 1;
160         return 1;
161     }
162     else {
163         $self->out("-ERR authorization failed\r\n");
164         return;
165     }
166 }
167
168 sub start_session {
169     my $self = shift;
170     while (defined($_ = $self->in)) {
171         if (/^USER /i) {
172             $self->out("+OK\r\n"); # ignore
173         }
174         elsif (/^PASS (\S*)/i) {
175             $self->authorize($1) or die "auth failure";
176         }
177         elsif (/^QUIT/i) {
178             $self->quit;
179             last;
180         }
181         elsif (! $self->authorized) {
182             $self->authorize_first;
183         }
184         elsif (/^STAT/i) {
185             $self->stat;
186         }
187         elsif (/^LIST (\d+)/i) {
188             $self->listing($1);
189         }
190         elsif (/^RETR (\d+)/i) {
191             $self->retrieve($1);
192         }
193         elsif (/^TOP (\d+) (\d+)/i) {
194             $self->top($1, $2);
195         }
196         elsif (/^UIDL/i) {
197             $self->uidl;
198         }
199     }
200 }
201
202 package main;
203
204 my $logfile = shift;
205 my $maildir = shift;
206 my $cryptpw = shift;
207
208 $| = 1;
209
210 my $popper = ProcMailToMHPopper->new(*STDOUT, *STDIN, $maildir, $cryptpw);
211 $popper->init_session;
212 $popper->parse_mailinfo($logfile);
213 $popper->start_session;
214
215
216
217 =pod
218
219 =head1 NAME
220
221 prompop - prom-wl pop3d
222
223 =head1 SYNOPSIS
224
225   prompop ~/.procmail/log ~/Mail xxxxxx
226
227 =head1 DESCRIPTION
228
229 See http://bulknews.net/lib/utils/prompop/ for details.
230
231 =head1 AUTHOR
232
233 Tatsuhiko Miyagawa <miyagawa@bulknews.net>
234
235 =head1 SEE ALSO
236
237 prom-wl
238
239 =head1 COPYRIGHT
240
241  prompop is Copyright (c) 2002, by Tatsuhiko Miyagawa.
242  All rights reserved. You may distribute this code under the terms
243  of either the GNU General Public License or the Artistic License,
244  as specified in the Perl README file.
245
246 =cut
Note: See TracBrowser for help on using the browser.