/lib/gaa_mbox.tcl
TCL | 254 lines | 212 code | 25 blank | 17 comment | 44 complexity | 891fae102d7d2075e47795dcbc379b5e MD5 | raw file
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}