From 6b634e612bc813489cfdbbb64f5562aae3ff44b6 Mon Sep 17 00:00:00 2001 From: Cyan Ogilvie Date: Fri, 23 Nov 2007 15:39:09 +0200 Subject: [PATCH] 0.91.0-1 --- debian/changelog | 6 +++ pkgIndex.tcl | 4 +- scripts/baselog.itcl | 53 +++++++++++++++++++++- scripts/datasource_chan_backend.itcl | 2 + scripts/fileio.tcl | 42 +++++++++++++++++ scripts/form.itk | 1 + scripts/refcounted.itcl | 87 ++++++++++++++++++++++++++++++++++++ scripts/stackdump.tcl | 13 ++++-- tlc-base.tcl | 2 +- 9 files changed, 202 insertions(+), 8 deletions(-) create mode 100644 scripts/fileio.tcl create mode 100644 scripts/refcounted.itcl diff --git a/debian/changelog b/debian/changelog index 931f179..f69a77f 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +tlc (0.91.0-1) gutsy; urgency=low + + * Released 0.91.0-1 + + -- Cyan Ogilvie Fri, 23 Nov 2007 15:36:55 +0200 + tlc (0.75.0-1) unstable; urgency=low * Added nested arm / disarm diff --git a/pkgIndex.tcl b/pkgIndex.tcl index 3c0f6d8..9450cc6 100755 --- a/pkgIndex.tcl +++ b/pkgIndex.tcl @@ -1,4 +1,4 @@ #Tcl package index file, version 1.0 -package ifneeded TLC-base 0.90.0 [list eval [list namespace eval ::tlc [list variable library $dir]]\n[list source [file join $dir tlc-base.tcl]]] -package ifneeded TLC 0.90.0 [list source [file join $dir tlc.tcl]] +package ifneeded TLC-base 0.91.0 [list eval [list namespace eval ::tlc [list variable library $dir]]\n[list source [file join $dir tlc-base.tcl]]] +package ifneeded TLC 0.91.0 [list source [file join $dir tlc.tcl]] diff --git a/scripts/baselog.itcl b/scripts/baselog.itcl index 86072c7..43def5f 100644 --- a/scripts/baselog.itcl +++ b/scripts/baselog.itcl @@ -7,7 +7,10 @@ class tlc::Baselog { } protected { + variable debuglogmode 0 + method log {lvl {msg ""} args} + method parray {args} } private { @@ -129,6 +132,7 @@ class tlc::Baselog { body tlc::Baselog::log {lvl {msg ""} args} { #<<<1 + if {$debuglogmode} {puts stderr "foo"} # Get a timestamp <<< set now [timestamp] #if {[info exists helpers(timestamp)]} { @@ -175,6 +179,7 @@ body tlc::Baselog::log {lvl {msg ""} args} { #<<<1 set logzone [namespace qualifiers $fqname] + if {$debuglogmode} {puts stderr "bar"} if {[info exists helpers(output)]} { set output_cmd [linsert [lrange $helpers(output) 1 end] 0 \ [lindex $helpers(output) 0]] @@ -241,7 +246,11 @@ body tlc::Baselog::log {lvl {msg ""} args} { #<<<1 } { set stackname [lindex [info level $i] 0] if {$stackname == {}} continue - set fqname [uplevel $depth [list namespace origin $stackname]] + if {[catch { + set fqname [uplevel $depth [list namespace origin $stackname]] + } errmsg]} { + set fqname "??$stackname" + } if {[info exists hotfuncs($fqname)]} { set threshold $hotfuncs($fqname) @@ -322,10 +331,12 @@ body tlc::Baselog::log {lvl {msg ""} args} { #<<<1 puts stderr $outmsg } } + if {$debuglogmode} {puts stderr "baz"} } body tlc::Baselog::c {args} { #<<<1 + if {$::tcl_platform(platform) == "windows"} {return ""} set build "" foreach name $args { switch -- [string tolower $name] { @@ -358,3 +369,43 @@ body tlc::Baselog::c {args} { #<<<1 } +body tlc::Baselog::parray {args} { #<<<1 + switch -- [llength $args] { + 1 { + uplevel [list ::parray [lindex $args 0]] + } + + 2 { + set lvl [lindex $args 0] + set arrname [lindex $args 1] + + upvar $arrname a + set keys [array names a] + + set maxlen -1 + foreach key $keys { + set thislen [string length $key] + if {$thislen > $maxlen} { + set maxlen $thislen + } + } + + incr maxlen [string length $arrname] + incr maxlen 2 + + set msg "\n" + foreach key [lsort $keys] { + append msg [format "%-${maxlen}s = \"%s\"\n" "${arrname}($key)" $a($key)] + } + + uplevel [list log $lvl $msg] + } + + default { + error "Invalid number of arguments, expecting lvl arrayvar" "" \ + [list syntax_error] + } + } +} + + diff --git a/scripts/datasource_chan_backend.itcl b/scripts/datasource_chan_backend.itcl index a7c087e..7722262 100644 --- a/scripts/datasource_chan_backend.itcl +++ b/scripts/datasource_chan_backend.itcl @@ -193,6 +193,8 @@ body tlc::DSchan_backend::change_item {pool id newitem} { #<<<1 } set olditem [get_item $pool $id] + if {$olditem == $newitem} return + set last_updated [clock seconds] $db eval { update diff --git a/scripts/fileio.tcl b/scripts/fileio.tcl new file mode 100644 index 0000000..e9906d3 --- /dev/null +++ b/scripts/fileio.tcl @@ -0,0 +1,42 @@ +# vim: ft=tcl foldmethod=marker foldmarker=<<<,>>> ts=4 shiftwidth=4 + +proc tlc::readfile {fn {mode "text"}} { #<<< + set fp [open $fn r] + switch -- $mode { + text {} + + binary { + fconfigure $fp -encoding binary -translation binary + } + + default { + error "Invalid mode: \"$mode\"" "" [list invalid_mode $mode] + } + } + + set dat [read $fp] + close $fp + + return $dat +} + +#>>> +proc tlc::writefile {fn dat {mode "text"}} { #<<< + set fp [open $fn w] + switch -- $mode { + text {} + + binary { + fconfigure $fp -encoding binary -translation binary + } + + default { + error "Invalid mode: \"$mode\"" "" [list invalid_mode $mode] + } + } + + puts -nonewline $fp $dat + close $fp +} + +#>>> diff --git a/scripts/form.itk b/scripts/form.itk index 744e59b..24bb9d1 100644 --- a/scripts/form.itk +++ b/scripts/form.itk @@ -17,6 +17,7 @@ proc tlc::form {pathName args} { class tlc::Form { inherit tlc::Border tlc::Handlers tlc::Textvariable tlc::Signalsource + #inherit tlc::Formbase tlc::Border constructor {args} {} destructor {} diff --git a/scripts/refcounted.itcl b/scripts/refcounted.itcl new file mode 100644 index 0000000..24379aa --- /dev/null +++ b/scripts/refcounted.itcl @@ -0,0 +1,87 @@ +# vim: ft=tcl foldmethod=marker foldmarker=<<<,>>> ts=4 shiftwidth=4 + +class tlc::Refcounted { + constructor {} {} + destructor {} + + public { + method object_registry {varname} + method incref {args} + method decref {args} + method refcount {} + } + + protected { + method autoscoperef {} + } + + private { + variable refcount 1 + variable registry_var + + method clear_registry {} + } +} + + +body tlc::Refcounted::constructor {} { #<<< +} + +#>>> +body tlc::Refcounted::destructor {} { #<<< + clear_registry +} + +#>>> +body tlc::Refcounted::autoscoperef {} { #<<< + #puts stderr "Refcounted::constructor callstack: [tlc::stackdump]" + upvar 2 _mware_msg_scoperef_[string map {:: //} $this] scopevar + set scopevar $this + trace variable scopevar u [code $this decref] +} + +#>>> +body tlc::Refcounted::incref {args} { #<<< + set old $refcount + incr refcount + #puts stderr "$this: refcount $old -> $refcount ($args)" +} + +#>>> +body tlc::Refcounted::decref {args} { #<<< + set old $refcount + incr refcount -1 + #puts stderr "$this: refcount $old -> $refcount ($args)" + if {$refcount <= 0} { + #puts stderr "$this: our time has come" + delete object $this + return -code return + } +} + +#>>> +body tlc::Refcounted::refcount {} { #<<< + return $refcount +} + +#>>> +body tlc::Refcounted::object_registry {varname} { #<<< + clear_registry + + set registry_var $varname + upvar $registry_var var_ref + + set var_ref $this +} + +#>>> +body tlc::Refcounted::clear_registry {} { #<<< + if {[info exists registry_var]} { + upvar $registry_var old_registry + if {[info exists old_registry]} { + unset old_registry + } + } +} + +#>>> diff --git a/scripts/stackdump.tcl b/scripts/stackdump.tcl index 4e0a8f1..5e74e31 100644 --- a/scripts/stackdump.tcl +++ b/scripts/stackdump.tcl @@ -13,10 +13,14 @@ proc tlc::stackdump {} { } { set levelinfo [info level $i] set stackname [lindex $levelinfo 0] - set passed_args [lindex $levelinfo 1] + set passed_args [lrange $levelinfo 1 end] if {$stackname != "" && $stackname != "namespace"} { - set fqname \ - [uplevel $depth [list namespace origin $stackname]] + if {[catch { + set fqname \ + [uplevel $depth [list namespace origin $stackname]] + } errmsg]} { + set fqname "??$stackname" + } set caller_args_def \ [uplevel $depth [list info args $stackname]] } else { @@ -26,10 +30,11 @@ proc tlc::stackdump {} { lappend caller_args_def "" } } - set idx 0 + set idx -1 set substmap [list "\n" "\\n" "\t" "\\t"] set argdesc {} foreach arg $caller_args_def { + incr idx if {$arg == "args"} { set this_passed_arg [lrange $passed_args $idx end] } else { diff --git a/tlc-base.tcl b/tlc-base.tcl index 32d2b2f..1d0f6c1 100755 --- a/tlc-base.tcl +++ b/tlc-base.tcl @@ -4,7 +4,7 @@ package require Itcl 3.3 namespace eval ::tlc { namespace export * - variable version 0.90.0 + variable version 0.91.0 variable log set log(threshold) 20 -- 2.11.4.GIT