#! /bin/env tclsh
### rfc822h.tcl --- RFC 822 (and alike) headers -*- Tcl -*-
## $Id: 15254,v 1.5 2006-01-16 07:00:23 jcw Exp $
### Copyright (C) 2005, 2006 Ivan Shmakov
## This library is free software; you can redistribute it and/or modify
## it under the terms of the GNU Lesser General Public License as
## published by the Free Software Foundation; either version 2.1 of the
## License, or (at your option) any later version.
## This library is distributed in the hope that it will be useful, but
## WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
## Lesser General Public License for more details.
## You should have received a copy of the GNU General Public License
## along with this program; if not, write to the Free Software
## Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301
## USA
### Code:
variable re-header-name "\[\\041-\\071\\073-\\177\]+"
variable re-header-del ":"
## In the code below, header is an array keyed by header field name,
## and whose values are corresponding header field values. Because RFC
## 822 header field name cannot contain colons, the convention is to
## put additional information (such as the order of fields) into array
## elements with keys beginning with one or more colons. Eg. the order
## of fields is stored in the element with key ":colon". The keys of
## the private fields of the package begin with two colons.
## : Get the value of a variable, or default if it's not existent
proc safe-get { varn { default "" } } {
upvar $varn var
## .
expr { [ info exists var ] ? [ set var ] : $default }
}
## : Get the order of fields in the header
proc header-fields-order { arrayName } {
## .
safe-get header(:order) [ list ]
}
## : Store an accumulated header line (if any) in the header
proc header-field-finish { arrayName } {
upvar $arrayName header
set varnf header(::last-field)
set varnv header(::last-value)
if { ! [ info exists $varnf ] } {
## no header field to finish
## .
return
}
set field [ set $varnf ]
lappend header($field) [ set $varnv ]
lappend header(:order) $field
unset $varnf $varnv
## .
return
}
## : Parse just one given header line, modifying the header
proc header-parse-line { arrayName line } {
## => 0 | 1 (done)
variable re-header-name
variable re-header-del
upvar $arrayName header
if { [ string length $line ] == 0 } {
## end of header, store accumulated field, if any
header-field-finish header
return 1
} elseif { [ string match "\[ \t\]*" $line ] } {
## accumulate continuation of a header field
if { [ info exists header(::last-field) ] == 0 } {
error "no header to continue"
}
append header(::last-value) "\n" $line
} elseif { [ regexp -- \
"^(${re-header-name})${re-header-del}(.*)\$" \
$line \
dummy n v ] } {
## new header field
header-field-finish header
set header(::last-field) $n
set header(::last-value) $v
} else {
error "cannot parse header line"
}
## .
return 0
}
## : Read lines from the channel, parsing them as the RFC 822 header
proc read-parse-header { { channelId stdin } arrayName } {
upvar $arrayName header
set done 0
if { ! [ info exists header(:order) ] } {
set header(:order) [ list ]
}
while { ! $done } {
if { [ gets $channelId line ] < 0 } {
error "eof or no data while reading header"
}
if { [ header-parse-line header $line ] } {
set done 1
}
}
## .
set header(:order)
}
## : Write lines to the given channel, formatting them as the header
proc write-header { { channelId stdout } order arrayName } {
## FIXME: should it write header fields not in ORDER?
upvar $arrayName header
array unset is
foreach hf $order {
if { ! [ info exists is($hf) ] } {
set is($hf) 0
}
set i $is($hf)
set l $header($hf)
if { $i >= [ llength $l ] } {
## silently ignore this case
continue
}
puts $channelId \
[ format "%s:%s" $hf [ lindex $l $i ] ]
incr is($hf)
}
## .
return
}
### Emacs stuff
## Local variables:
## fill-column: 72
## indent-tabs-mode: nil
## ispell-local-dictionary: "english"
## mode: outline-minor
## outline-regexp: "###\\|proc"
## End:
## LocalWords:
### rfc822h.tcl ends here