/lib/gaa_mbox.tcl

  1############################################################################
  2#   Copyright (C) 2008 Alexander Galanin <gaa.nnov@mail.ru>                #
  3#                                                                          #
  4#   This program is free software: you can redistribute it and/or modify   #
  5#   it under the terms of the GNU Lesser General Public License as         #
  6#   published by the Free Software Foundation, either version 3 of the     #
  7#   License, or (at your option) any later version.                        #
  8#                                                                          #
  9#   This program is distributed in the hope that it will be useful,        #
 10#   but WITHOUT ANY WARRANTY; without even the implied warranty of         #
 11#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the          #
 12#   GNU General Public License for more details.                           #
 13#                                                                          #
 14#   You should have received a copy of the GNU Lesser GNU General Public   #
 15#   License along with this program.                                       #
 16#   If not, see <http://www.gnu.org/licenses/>.                            #
 17############################################################################
 18
 19package provide gaa_mbox 1.1
 20
 21package require Tcl 8.4
 22package require cmdline 1.2.5
 23
 24namespace eval mbox {
 25
 26namespace export \
 27    initParser \
 28    closeParser \
 29    parseLine \
 30    parseFile \
 31    parseStream \
 32    writeToFile \
 33    writeToStream
 34
 35set id 0
 36
 37proc parseLine {id line} {
 38    variable letter$id
 39    variable state$id
 40    variable command$id
 41
 42    set letter [ set letter$id ]
 43    set state [ set state$id ]
 44    array unset lt
 45    array set lt $letter
 46
 47    if { $state == "EOF" ||
 48            ( [ regexp {^From:{0,1} (.+)$} $line dummy nick ] &&
 49                ( $state == "BODYSPACE" || $state == "BEGIN" ) ) } {
 50        regsub {(\n)+$} $lt(body) "" lt(body)
 51        set letter [ array get lt ]
 52
 53        if [ info exists lt(From) ] {
 54            uplevel #0 [ concat [ set command$id ] [ list $letter ] ]
 55        }
 56        if { $state != "EOF" } {
 57            set state$id HEAD
 58            set letter$id [ list "From" $nick ]
 59        }
 60        return
 61    }
 62    if { $line == "" } {
 63        switch -exact $state {
 64            HEAD {
 65                set state$id BODY
 66                set lt(body) ""
 67            }
 68            BODY {
 69                set state$id BODYSPACE
 70                set lt(body) "$lt(body)\n"
 71            }
 72            BODYSPACE {
 73                set lt(body) "$lt(body)\n"
 74            }
 75        }
 76        set letter$id [ array get lt ]
 77        return
 78    }
 79    if { $state == "HEAD" || $state == "BEGIN" } {
 80        if [ regexp {^([\w-]+):\s*(.*)$} $line dummy tag val ] {
 81            set lt($tag) $val
 82        } else {
 83            error "Invalid data in the header section: $line"
 84        }
 85    } else {
 86        if [ regexp {^>(>*From:{0,1} .*)$} $line dummy ss ] {
 87            set line $ss
 88        }
 89        append lt(body) "$line\n"
 90    }
 91    set letter$id [ array get lt ]
 92}
 93
 94proc outputHandler {id stream onoutput onerror oncomplete} {
 95    if { [ gets $stream s ] < 0 } {
 96        if [ eof $stream ] {
 97            if [ catch {
 98                fconfigure $stream -blocking 1
 99                close $stream
100            } err ] {
101                lappend onerror $err
102                uplevel #0 $onerror
103            } else {
104                closeParser $id
105                uplevel #0 $oncomplete
106            }
107        }
108    } else {
109        lappend onoutput $s
110        uplevel #0 $onoutput
111    }
112}
113
114proc parseFile {fileName command args} {
115    array set p [ ::cmdline::getoptions args {
116        {mode.arg       "r"     "Stream open mode"}
117        {encoding.arg   "utf-8" "Encoding"}
118        {sync.arg       "0"     "Parse stream in synchronous mode"}
119        {oncomplete.arg ""      "Script to execute on complete(async mode)"}
120        {onerror.arg    "error" "Script to execute on error(async mode)"}
121    } ]
122
123    set f [ open $fileName $p(mode) ]
124    fconfigure $f -encoding $p(encoding)
125    parseStream $f $command \
126        -oncomplete [ join [ list $p(oncomplete) [ list close $f ] ] ";" ] \
127        -onerror $p(onerror) \
128        -sync $p(sync)
129}
130
131proc parseStream {stream command args} {
132    array set p [ ::cmdline::getoptions args {
133        {sync.arg       "0"     "Parse stream in synchronous mode"}
134        {oncomplete.arg ""      "Script to execute on complete(async mode)"}
135        {onerror.arg    "error" "Script to execute on error(async mode)"}
136    } ]
137
138    set id [ initParser $command ]
139    if $p(sync) {
140        fconfigure $stream -blocking 1
141        if [ catch {
142            while { [ gets $stream s ] >= 0 } {
143                parseLine $id $s
144            }
145        } err ] {
146            set errInfo $::errorInfo
147            catch {closeParser $id}
148            error $err $errInfo
149        }
150        closeParser $id
151        close $stream
152    } else {
153        fconfigure $stream \
154            -buffering line \
155            -blocking 0
156        fileevent $stream readable [ list \
157            [ namespace current ]::outputHandler \
158            $id \
159            $stream \
160            [ list [ namespace current ]::parseLine $id ] \
161            $p(onerror) \
162            $p(oncomplete) \
163        ]
164    }
165}
166
167proc initParser {command} {
168    variable id
169    incr id
170
171    variable letter$id
172    variable state$id
173    variable command$id
174
175    set letter$id {body ""}
176    set state$id "BEGIN"
177    set command$id $command
178
179    return $id
180}
181
182proc closeParser {id} {
183    variable letter$id
184    variable state$id
185    variable command$id
186
187    set state$id EOF
188    if [ catch {parseLine $id ""} err ] {
189        unset letter$id state$id command$id
190
191        error $err $::errorInfo
192    }
193    unset letter$id state$id command$id
194}
195
196proc writeToFile {fileName letter args} {
197    array set param [ ::cmdline::getoptions args {
198        {encoding.arg   ""  "Encoding"}
199        {append             "Append to file instead of overwriting"}
200    } ]
201    if $param(append) {
202        set mode "a"
203    } else {
204        set mode "w"
205    }
206    set f [ open $fileName $mode ]
207    if {$param(encoding) != ""} {
208        fconfigure $f -encoding $param(encoding)
209    }
210    if [ catch {
211        foreach letter $letter {
212            writeToStream $f $letter
213        }
214    } err ] {
215        close $f
216        error $err $::errorInfo
217    }
218    close $f
219}
220
221proc writeToStream {stream letter} {
222    set body ""
223    set fromExists 0
224    foreach {header value} $letter {
225        if { $header == "From"} {
226            puts $stream "From $value"
227            set fromExists 1
228            break
229        }
230    }
231    if { $fromExists == 0 } {
232        error "No From header"
233    }
234    foreach {header value} $letter {
235        if {$header != "body"} {
236            if {$header != "From"} {
237                puts $stream "$header: $value"
238            }
239        } else {
240            set body $value
241        }
242    }
243    puts $stream ""
244
245    foreach line [ split $body "\n" ] {
246        if [ regexp {^>*From } $line ] {
247            puts -nonewline $stream ">"
248        }
249        puts $stream $line
250    }
251    puts $stream ""
252}
253
254}