1# mbox.tcl - mailbox package
2#
3# (c) 1999 Marshall T. Rose
4# Hold harmless the author, and any lawful use is allowed.
5#
6
7#
8# TODO:
9#
10#     mbox::initialize
11#         add -pop server option
12#         add -imap server option
13#         along with -username, -password, and -passback
14#
15#     mbox::getmsgproperty
16#         add support for deleted messages
17#
18#     mbox::deletemsg token msgNo
19#         marks a message for deletion
20#
21#     mbox::synchronize token ?-commit boolean?
22#         commits or rollllbacks changes
23
24
25package provide mbox 1.0
26
27package require mime 1.1
28
29
30#
31# state variables:
32#
33#     msgs: serialized array of messages, containing array of:
34#           msgNo, mime
35#     count: number of messages
36#     first: number of initial message
37#     last: number of final message
38#     value: either "file", or "directory"
39#
40#     file: file containing mailbox
41#     fd: corresponding file descriptor
42#     fileA: serialized array of messages, containing array of:
43#            msgNo, offset, size
44#
45#     directory: directory containing mailbox
46#     dirA: serialized array of messages, containing array of:
47#           msgNo, size
48#
49
50namespace eval mbox {
51    variable mbox
52    array set mbox { uid 0 }
53
54    namespace export initialize finalize getproperty \
55                     getmsgtoken getmsgproperty
56}
57
58
59proc mbox::initialize {args} {
60    global errorCode errorInfo
61
62    variable mbox
63
64    set token [namespace current]::[incr mbox(uid)]
65
66    variable $token
67    upvar 0 $token state
68
69    if {[set code [catch { eval [list mbox::initializeaux $token] $args } \
70                         result]]} {
71        set ecode $errorCode
72        set einfo $errorInfo
73
74        catch { mbox::finalize $token -subordinates dynamic }
75
76        return -code $code -errorinfo $einfo -errorcode $ecode $result
77    }
78
79    return $token
80}
81
82
83proc mbox::initializeaux {token args} {
84    variable $token
85    upvar 0 $token state
86
87    set state(msgs) ""
88    set state(count) 0
89    set state(first) 0
90    set state(last) 0
91
92    set argc [llength $args]
93    for {set argx 0} {$argx < $argc} {incr argx} {
94        set option [lindex $args $argx]
95        if {[incr argx] >= $argc} {
96            error "missing argument to $option"
97        }
98        set value [lindex $args $argx]
99
100        switch -- $option {
101            -directory {
102                set state(directory) $value
103            }
104
105            -file {
106                set state(file) $value
107            }
108
109            default {
110                error "unknown option $option"
111            }
112        }
113    }
114
115    set valueN 0
116    foreach value [list directory file] {
117        if {[info exists state($value)]} {
118            set state(value) $value
119            incr valueN
120        }
121    }
122    if {$valueN != 1} {
123        error "specify exactly one of -directory, or -file"
124    }
125
126    return [mbox::initialize_$state(value) $token]
127}
128
129
130proc mbox::initialize_file {token} {
131    variable $token
132    upvar 0 $token state
133
134    fconfigure [set state(fd) [open $state(file) { RDONLY }]] \
135               -translation binary
136
137    array set fileA ""
138    set msgNo 0
139
140    if {[gets $state(fd) line] < 0} {
141        return $token
142    }
143    switch -regexp -- $line {
144        "^From " {
145            set format Mailx
146            set preB "From "
147
148            set phase ""
149        }
150
151        "\01\01\01\01" {
152            set format MMDF
153            set preB "\01\01\01\01"
154            set postB "\01\01\01\01"
155
156            if {([gets $state(fd) line] >= 0) \
157                    && ([string first "From MAILER-DAEMON " $line] == 0)} {
158                set phase skip
159            } else {
160                set phase pre
161            }
162        }
163
164        default {
165            error "unrecognized mailbox format"
166        }
167    }
168    seek $state(fd) 0 start
169
170    while {[gets $state(fd) line] >= 0} {
171        switch -- $format/$phase {
172            Mailx/ {
173                if {[string first $preB $line] == 0} {
174                    if {$msgNo > 0} {
175                        set fileA($msgNo) [list msgNo $msgNo offset $offset \
176                                                size $size]
177                    }
178
179                    incr msgNo
180                    set offset [tell $state(fd)]
181                    set size 0
182                } else {
183                    incr size [expr {[string length $line]+1}]
184                }
185            }
186
187            MMDF/pre {
188                if {![string compare $preB $line]} {
189                    incr msgNo
190                    set offset [tell $state(fd)]
191                    set size 0
192
193                    set phase post
194                } else {
195                    error "invalid mailbox"
196                }
197            }
198
199            MMDF/post {
200                if {![string compare $postB $line]} {
201                    set fileA($msgNo) [list msgNo $msgNo offset $offset \
202                                            size $size]
203
204                    set phase pre
205                } else {
206                    incr size [expr {[string length $line]+1}]
207                }
208            }
209
210            MMDF/skip {
211                if {![string compare $preB $line]} {
212                    set phase skip2
213                }
214            }
215
216            MMDF/skip2 {
217                if {![string compare $postB $line]} {
218                    set phase pre
219                }
220            }
221        }
222    }
223
224    switch -- $format/$phase {
225        Mailx/ {
226            if {$msgNo > 0} {
227                set fileA($msgNo) [list msgNo $msgNo offset $offset \
228                                        size $size]
229            }
230        }
231
232        MMDF/post
233            -
234        MMDF/skip2 {
235            error "incomplete mailbox"
236        }
237    }
238
239    set state(fileA) [array get fileA]
240    if {[set state(last) [set state(count) $msgNo]] > 0} {
241        set state(first) 1
242    }
243
244    return $token
245}
246
247
248proc mbox::initialize_directory {token} {
249    variable $token
250    upvar 0 $token state
251
252    array set dirA ""
253
254    set first 0
255    set last 0
256    foreach file [glob -nocomplain [file join $state(directory) *]] {
257        if {(![regexp {^[1-9][0-9]*$} [set msgNo [file tail $file]]]) \
258                || ([catch { file size $file } size])} {
259            continue
260        }
261
262        if {($first == 0) || ($msgNo < $first)} {
263            set first $msgNo
264        }
265        if {$last < $msgNo} {
266            set last $msgNo
267        }
268
269        set dirA($msgNo) [list msgNo $msgNo size $size]
270        incr state(count)
271    }
272
273    set state(dirA) [array get dirA]
274    if {[set state(last) $last] > 0} {
275        set state(first) $first
276    }
277
278    return $token
279}
280
281proc mbox::finalize {token args} {
282    variable $token
283    upvar 0 $token state
284
285    array set options [list -subordinates dynamic]
286    array set options $args
287
288    switch -- $options(-subordinates) {
289        all
290            -
291        dynamic {
292            array set msgs $state(msgs)
293
294            for {set msgNo $state(first)} \
295                    {$msgNo <= $state(last)} \
296                    {incr msgNo} {
297                if {![catch { array set msg $msgs($msgNo) }]} {
298                    eval [list mime::finalize $msg(mime)] $args
299                }
300            }
301        }
302
303        none {
304        }
305
306        default {
307            error "unknown value for -subordinates $options(-subordinates)"
308        }
309    }
310
311    if {[info exists state(fd)]} {
312        catch { close $state(fd) }
313    }
314
315    foreach name [array names state] {
316        unset state($name)
317    }
318    unset $token
319}
320
321
322proc mbox::getproperty {token {property ""}} {
323    variable $token
324    upvar 0 $token state
325
326    switch -- $property {
327        "" {
328            return [list count    $state(count) \
329                         first    $state(first) \
330                         last     $state(last)  \
331                         messages [mbox::getmessages $token]]
332        }
333
334        -names {
335            return [list count first last messages]
336        }
337
338        count
339            -
340        first
341            -
342        last  {
343            return $state($property)
344        }
345
346        messages {
347            return [mbox::getmessages $token]
348        }
349
350        default {
351            error "unknown property $property"
352        }
353    }
354}
355
356
357proc mbox::getmessages {token} {
358    variable $token
359    upvar 0 $token state
360
361    switch -- $state(value) {
362        directory {
363            array set msgs $state(dirA)
364        }
365
366        file {
367            array set msgs $state(fileA)
368        }
369    }
370
371    return [lsort -integer [array names msgs]]
372}
373
374
375proc mbox::getmsgtoken {token msgNo} {
376    variable $token
377    upvar 0 $token state
378
379    if {($msgNo < $state(first)) || ($msgNo > $state(last))} {
380        error "message number out of range: $state(first)..$state(last)"
381    }
382
383    array set msgs $state(msgs)
384    if {![catch { array set msg $msgs($msgNo) }]} {
385        return $msg(mime)
386    }
387
388    switch -- $state(value) {
389        directory {
390            set mime [mime::initialize \
391                          -file [file join $state(directory) $msgNo]]
392        }
393
394        file {
395            array set fileA $state(fileA)
396            array set msg $fileA($msgNo)
397            set mime [mime::initialize -file $state(file) -root $token \
398                          -offset $msg(offset) -count $msg(size)]
399        }
400    }
401
402    set msgs($msgNo) [list msgNo $msgNo mime $mime]
403    set state(msgs) [array get msgs]
404
405    return $mime
406}
407
408
409proc mbox::getmsgproperty {token msgNo {property ""}} {
410    variable $token
411    upvar 0 $token state
412
413    if {($msgNo < $state(first)) || ($msgNo > $state(last))} {
414        error "message number out of range: $state(first)..$state(last)"
415    }
416
417    switch -- $state(value) {
418        directory {
419            array set dirA $state(dirA)
420            if {[catch { array set msg $dirA($msgNo) }]} {
421                error "message $msgNo doesn't exist"
422            }
423        }
424
425        file {
426            array set fileA $state(fileA)
427            array set msg $fileA($msgNo)
428        }
429    }
430
431    set props [list flags size uidl]
432
433    switch -- $property {
434        "" {
435            array set properties ""
436
437            foreach prop $props {
438                if {[info exists msg($prop)]} {
439                    set properties($prop) $msg($prop)
440                }
441            }
442
443            return [array get properties]
444        }
445
446        -names  {
447            set names ""
448            foreach prop $props {
449                if {[info exists msg($prop)]} {
450                    lappend names $prop
451                }
452            }
453
454            return $names
455        }
456
457        default {
458            if {[lsearch -exact $props $property] < 0} {
459                error "unknown property $property"
460            }
461
462            return $msg($property)
463        }
464    }
465}
466