#! /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

