Artifact 1d27f476f79cf31b268122f5541707f11f9d9194:

• File packages/gryp/lib/session.tcl — part of check-in [c47a5ff0ea] at 2019-01-17 12:07:09 on branch trunk — gryp separate tree from session

  math fix small error.

  struct tree

  new package

  (user: pooryorick size: 5683)

#! /usr/bin/env tclsh

package require {ycl proc}
package require {ycl list}
[yclprefix] proc import [yclprefix]::list::merge


package require {ycl eav sqlite}
namespace import [yclprefix]::eav::sqlite::eav
package require {ycl db sqlite util}
[yclprefix] proc alias dbget [yclprefix]::db::sqlite::util::get


package require {ycl struct tree}
[yclprefix] proc alias tree [yclprefix]::struct::tree

namespace eval doc {}


proc .init {_ args} {
	variable magic
	$_ .vars lastfocus eventtypes error info lastfocusrowid settings \
		subscribers system

	sqlite3 [$_ .namespace]::db
	$_ .eval [list $_ .routine db]
	$_ setupdb

	set lastfocus {}
	set lastfocusrowid {}

	set magicb [binary format H* $magic]

	set system [$_ tree node new {} system]
	$_ tree node forge $system type $magicb
	$_ tree node tree $system {
		errors {
		}
		navigation {
			cursor {}
			trail {}
		}
		event {
			types {
				close {}
				delete {}
				edit {}
				focus {}
				insert {}
				options {}
				open {}
				view {} 
			}
			handlers {
			}
		}
	}
	set eventtypes [$_ tree node get $system event types]
	if {$eventtypes eq {}} {
		error [list {could not find event types}]
	}
	set settings [$_ tree node new {} settings]
	set workdir [$_ tree node new $settings workdir]
	$_ tree node new $workdir new
	set workdiropennode [$_ tree node new $workdir open]
	$_ tree node set {} attributes $workdiropennode datatype directory
	$_ tree node set {} attributes $workdiropennode write [list $_ workdir_open]

	eav [$_ .namespace]::eav
	$_ .eval [list $_ .routine eav]
	$_ eav init fname :memory:
	dict size $args
	foreach {opt val} $args {
		switch $opt {
			gryp {
				set $opt $val
			}
			default {
				error [list {unknown option} $opt]
			}
		}
	}
	$_ .eval [list $_ .routine gryp $gryp]
	set subscribers {}
	return $_
}
.my .method .init


proc .new {_ args} {
	set new [uplevel 1 [list $_ .prototype .new {*}$args]]

	namespace ensemble create -command [$new .namespace]::history \
		-parameters _ -map {

			next history_next
			previous history_previous
		}
	$new .eval [list $new .method history]

	namespace ensemble create -command [$new .namespace]::handler \
		-parameters _  -map {

		add handler_add
		activate handler_activate
	}
	$new .eval [list $new .method handler]


	tree .new [$new .namespace]::tree
	$new .eval [list $new .routine tree]
	$new tree .routine ondeleted $new ondeleted
	$new tree .routine oninserted $new oninserted
	$new tree .init

	return $new
}
.my .method .new


proc activated {_ node} {
}
.my .method activated


proc event {_ node event args} {
	$_ notify $event $node
	return
}
.my .method event


proc error_ {_ tres topts} {
	$_ .vars system
	set node [$_ tree node new $system errors $tres]
	$_ tree node set $node $topts
	$_ notify focus $node
	return
}
.my .method error error_


proc focus {_ selection} {
	$_ .vars lastfocus system
	if {$lastfocus ne $selection} {
		set trail [$_ tree node get $system navigation trail]
		set cursor [$_ tree node new $trail $selection]
		$_ tree node set $system navigation cursor $cursor
		set lastfocus $selection
	}
	$_ notify focus $selection 
	return
}
.my .method focus


proc handler_add {_ node type command} {
	$_ .vars eventtypes
	set typeid [dbget [list $_ db] {
		select rowid ,value from treevals
		where parent = $eventtypes and value = $type
	}]
	set found [$_ tree node get $system event handlers $node $typeid $command]
	return
}


proc history_next _ {
	$_ .vars lastfocus system
	set cursor [$_ tree node pivot $system navigation cursor]
	set cval [$_ tree node last $cursor]
	set next [$_ tree node next $cval]
	if {$next ne {}} {
		$_ tree node set $cursor $next
		set last [$_ tree node name $next]
		set lastfocus $last
		$_ notify focus $last
	}
	return
}
.my .method history_next


proc history_previous _ {
	$_ .vars lastfocus system
	set cursor [$_ tree node pivot $system navigation cursor]
	set cval [$_ tree node last $cursor]
	set previous [$_ tree node previous $cval]
	if {$previous ne {}} {
		$_ tree node set $cursor $previous
		set last [$_ tree node name $previous]
		set lastfocus $last
		$_ notify focus $last
	}
	return
}
.my .method history_previous


proc notify {_ type args} {
	$_ db eval {
		select cmd from subscriptions where event = $type
	} {
		{*}$cmd {*}$args
	}
}
.my .method notify


proc ondeleted {_ parent old value} {
	$_ notify delete $parent $old $value
	return
}
.my .method ondeleted


proc oninserted {_ parent new value} {
	$_ notify insert $parent $new $value
	return
}
.my .method oninserted


proc setupdb {_} {$_ db transaction {
	$_ db eval {
		; create table if not exists selections (
			rowid integer primary key
			, selection
			, previous
		)

		; create table if not exists subscriptions (
			rowid integer primary key
			, event
			, cmd
		)
	}
}}
.my .method setupdb




proc subscribe {_ to cmd} {
	set types [$_ tree node all {} system event types]
	set types [merge $types [
		lrepeat [expr {[llength $types] -1}] -]]
	switch $to [list \
		{*}$types {
			$_ db eval {
				insert into subscriptions values (null ,$to ,$cmd)
			}
			set token [$_ db last_insert_rowid]
		} \
		default {
			error [list {unknown event type}]
		}
	]
	return $token
}
.my .method subscribe


proc write {_ node data} {
	set write [$_ tree node last {} attributes $node write]
	if {$write ne {}} {
		{*}$write $node $data
	}
	return
}
.my .method write


proc workdir_open {_ node value} {
	try {
		$_ gryp workdir $value
	} on error {tres topts} {
		$_ error $tres $topts
	} on ok {} {
		$_ tree node set {} settings workdir current $value
	}
	return
}
.my .method workdir_open


set magic 65e956cb9517b62fcee39bac25748d4d2f94f91a31c334fa0b842959cb860d31