Artifact cc436ae405d570207775bcfc4cd69f0d81c79a51:

• Executable file packages/string/lib/chan.tcl — part of check-in [6842ef1911] at 2015-11-03 13:10:04 on branch trunk — Rename various packages in list format .

  First commit of sql .

  Early version of entity-attribute-value model in test/lib/data.tcl . It has a context column , but the idea of using an events and attributes in the "what" colun comes in the next changeset . (user: pooryorick size: 8450)

#! /bin/env tclsh

package require {ycl proc}
variable proc [yclprefix]::proc
namespace import ${proc}::checkargs
package require ycl::yobj
variable yobj [yclprefix]::yobj

namespace eval doc {}

variable doc::open {
	description {
		open a new string I/O channel
	}
	args {
		access {
			description {
				same as the access argument of [open]
				if the "data" option is supplied the file will pass the
				criteria of already existing for access modes that require that
				criteria.
			}
			validate {
				$access in [list r r+ w w+ a a+]
			}
			default {
				set access [list r]
			}
		}
		attach {
			description {
				specify a channel to attach to.
			}
			default {}
		}
		size {
			description {
				maximum size limit for file, in bytes
			}
			default {
				set size -1
			}
		}
		pipe {
			description {
				specifies whether a channel should be treated as a pipe, e.g.
				no backwards, and discard data that has been read
			}
			validate {
				[string is boolean $pipe]
			}
			default {
				set pipe 0
			}

		}
		data {
			description {
				the initial string data value of the channel
			}
			default {}
		}
	}
}
proc open args {
	variable yobj
	variable buffermap
	variable chancount
	variable channels
	variable names
	if {[catch {checkargs doc::open} catchres catchopt]} {
		return -options $catchopt $catchres
	}
	set mode read
	set new 1
	set truncate 0
	set append 0
	set startatend 0
	switch -glob -- $access {
		r {
			set new 0
		}
		r+ {
			set mode [list read write]
			set new 0
		}
		w {
			set mode write
			set truncate 1
		}
		w+ {
			set mode [list read write]
			set truncate 1
		}
		a {
			set mode write
			set append 1
		}
		a+ {
			set mode [list read write]
			set startatend 1
		}
	}

	set state [$yobj object]
	set chan [chan create $mode [namespace current]]
	set channels($chan) $state
	set ${state}::chan $chan
	if {![info exists attach]} {
		set attach $chan
	}
	set ${state}::attach $attach
	namespace eval $state [list namespace upvar [namespace current] buffers::$attach data]
	if {[info exists data]} {
		if {$truncate} {
			set ${state}::data $data[set data {}]
		} else {
			if {[info exists ${state}::data]} {
				return -code error "data provided when buffer already exists for channel $attach"
			} else {
				set ${state}::data $data[set data {}]
			}
		}
	} elseif {[info exists ${state}::data]} {
		if {$truncate} {
			set ${state}::data {}
		}
	} else {
		if {$new} {
			set ${state}::data {}
		} else {
			finalize $chan
			if {$attach eq $chan} {
				return -code error "access is \"$access\", but no variable name was found and no data was found.  Either use \"data\" option or \"name\" an existing variable"
			} else {
				return -code error "file does not exist: $chan"
			}
		}
	}

	set ${state}::cursor 0
	if {$startatend} {
		set ${state}::cursor [string length [set ${state}::data]]
	}
	set ${state}::mode $mode
	set ${state}::append $append 
	set ${state}::blocking 1
	set ${state}::pipe $pipe
	variable ${state}::watch [dict create]
	variable ${state}::rythm [set [namespace current]::rythm]
	set ${state}::size $size
	lappend buffermap($attach) $chan 
	namespace eval $state [list variable mode $mode]
	return $chan 
}

proc initialize {chan mode} {
	return \
		[list initialize finalize watch read write seek configure cget cgetall blocking]
}

proc finalize {chan} {
	variable channels
	variable buffermap
	variable buffer
	variable channels
	namespace upvar $channels($chan) attach attach 
	if {![catch {
	set buffermap($attach) [lsearch -exact -inline -all -not $buffermap($attach) $chan]
	}]} {
		if {[llength $buffermap($attach)] == 0} {
			unset buffers::$attach
		}
	}
	catch {unset channels($chan)}
}

proc watch {chan eventspec} {
	variable channels
	namespace upvar $channels($chan) watch watch rythm rythm
	if {$eventspec eq {}} {
		foreach key [dict keys $watch] {
			after cancel [dict get $watch $key]
			dict unset keys $watch
		}
		return
	}

	if {[dict exist $watch $eventspec]} {
		after cancel [dict get $watch $eventspec]
		dict unset keys $watch
	}
	dict set watch $eventspec [after $rythm \
		[namespace code [list watch $chan $eventspec]]]
	if {[${eventspec}able $chan]} {
		chan postevent $chan $eventspec
	}
}

proc readable chan {
	variable channels
	namespace upvar $channels($chan) cursor cursor data data
	if {$cursor <[string length $data] || ![llength [writers $chan]]} {
		return 1 
	} else {
		return 0 
	}
}

proc writeable chan {
	variable channels
	namespace upvar $channels($chan) cursor cursor data data
	return 1
}

### optional commands ###
proc read {chan count} {
	#this module assumes that the underlying data is in a single-byte encoding
	variable channels
	namespace upvar $channels($chan) blocking blocking cursor cursor data data \
		attach attach rythm rythm
	set newcursor [expr {min($cursor + $count ,[string length $data])}]
	set res [string range $data $cursor [expr {$newcursor - 1}]]
	if {$res eq {} && [info exists name]} {
		variable buffermap
		if {[llength [writers $chan]]} {
			if {$blocking} {
				while {[set res [string range $data $cursor [expr {$newcursor - 1}]]] \
					eq {}} {
					after $rythm
				}
			} else {
				#a writer exists.  Channel is still open
				return -code error EAGAIN
			}
		}
	}
	if {[ispipe $chan]} {
		set data [string range $data $newcursor end]
		set cursor 0
	} else {
		set cursor $newcursor
	}
	return $res
}

proc write {chan newdata} {
	variable channels
	namespace upvar $channels($chan) cursor cursor data data size size append append
	if {$append} {
		set cursor [string length $data]
	}
	set length [string length $newdata]
	if {$length} {
		set dlength [string length $data]
		if {[ispipe $chan]} {
			set cursor $dlength
		}
		set last [expr {$cursor + $length -1}]
		if {$size > -1 && $last >= $size} {
			if {[ispipe $chan]} {
				return -code error EAGAIN
			} else {
				return -code error \
					"write failed: would exceed file size limitation of $size bytes"
			}
		}
		if {$cursor > $dlength} {
			set pad [expr {$cursor - $dlength}]
			append data [string repeat \0 $pad]
		}
		
		if {$cursor < $dlength} {
			set data [string replace $data[set data {}] $cursor $last $newdata]
		} else {
			append data $newdata
		}
		set cursor $last
	}
	return $length
}

proc seek {chan offset base} {
	if 0 {
		seeking by itself does not add any bytes to a stream, but writing to a
		point beyond the end of the stream results in null bytes being added to
		pad the stream up until that point
	}
	variable channels
	namespace upvar $channels($chan) cursor cursor data data 
	switch $base {
		start {
			set base 0
		}
		current {
			set base $cursor
		}
		end {
			set base [string length $data]
		}
	}
	set newcursor [expr {$base + $offset}]
	if {[ispipe $chan]} {
		return -code error "channel $chan is a pipe.  Cannot seek"
	} else {
		set cursor [expr {$base + $offset}]
	}
	return $cursor
}

proc configure {chan option value} {
	variable channels
	case $option {
		-size {
			namespace upvar $channels($chan) size size
			set size $value
		}
		-mode {
			namespace upvar $channels($chan) mode mode
			set mode $value
		}
		-pipe {
			namespace upvar $channels($chan) pipe pipe
			set pipe [expr {!!$value}]
		}
		rythm {
			namespace upvar $channels($chan) rythm rythm
			set rythm $value
		}
		* {
			return -code error "no such configuration option for $chan: $option"
		}
	}
}

proc cget {chan option} {
	variable channels
	switch $option {
		pipe -
		size -
		rythm -
		attach {
			namespace upvar $channels($chan) $option $option
			set $option
		}
		default {
			return -code error "invalid option:  $option"
		}
	}
}

proc cgetall {chan} {
	variable channels
	namespace upvar $channels($chan) size size attach attach
	return [list attach attach size $size]
}

proc blocking {chan mode} {
	variable channels
	namespace upvar $channels($chan) blocking blocking 
	set blocking $mode
}

proc ispipe chan {
	variable channels
	namespace upvar $channels($chan) pipe pipe
	return $pipe
}

proc writers chan {
	set res [list]
	variable channels
	variable buffermap
	namespace upvar $channels($chan) attach attach mode mode
	foreach other $buffermap($attach)  {
		namespace upvar $channels($other) mode mode chan otherchan
		if {$otherchan ne $chan && "write" in $mode} {
			lappend res $otherchan
		}
	}
	return $res
}


variable buffermap
namespace eval buffers {}
variable channels
variable chancount
variable rythm 5

### private functions ###
proc K {x y} {set x}