From: Ian Jackson <ijackson@chiark.greenend.org.uk>
Date: Thu, 10 Dec 2009 18:53:51 +0000 (+0000)
Subject: panner is a proper package
X-Git-Tag: 6.3.0~15
X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~yarrgweb/git?p=ypp-sc-tools.main.git;a=commitdiff_plain;h=66b7b921f50bc3242a7e45a63a94391bcebf7cb9

panner is a proper package
---

diff --git a/.gitignore b/.gitignore
index 9beb60b..a580b97 100644
--- a/.gitignore
+++ b/.gitignore
@@ -15,3 +15,5 @@ yarrg/_*.*
 yarrg/OCEAN-*.db
 yarrg/Writer.lock
 yarrg/DATA
+
+yarrg/pkgIndex.tcl
diff --git a/yarrg/panner.tcl b/yarrg/panner.tcl
index 9f181a7..cc3819a 100644
--- a/yarrg/panner.tcl
+++ b/yarrg/panner.tcl
@@ -1,78 +1,71 @@
 package provide panner 0.1;
 namespace eval panner {
 
-namespace export -clear
-
 proc pannerproc {name argl body} {
     proc $name [concat w $argl] "
     upvar panner::i/\$w d
 $body
 "
 }
-proc pannerproc-export {name argl body} {
-    pannerproc panner-$name $argl $body
-    namespace export panner-$name
-}
-
-pannerproc debug {m} {
+pannerproc _debug {m} {
     if {!$d(debug)} return
     puts "PANNER $w $m"
 }
 
-pannerproc-export create {canvas maxwidth maxheight {debug 0}} {
+pannerproc create {canvas maxwidth maxheight {debug 0}} {
     set d(debug) $debug
-    debug $w "create $canvas $maxwidth,$maxheight"
+    _debug $w "create $canvas $maxwidth,$maxheight"
     set d(maxwidth) $maxwidth
     set d(maxheight) $maxheight
     canvas $w
     $w create rectangle -5 -5 -5 -5 -tags base -outline {} -fill black
     $w create rectangle -5 -5 -5 -5 -tags core -outline blue
-    bind $w <Configure> [list panner::resize $w w-event]
-    bind $w <ButtonPress> [list panner::press $w %b %x %y]
-    bind $w <B1-Motion> [list panner::motion $w %x %y]
-    bind $w <B1-ButtonRelease> [list panner::release $w %x %y]
-    panner-setcanvas $w $canvas
+    bind $w <Configure> [list panner::_resize $w w-event]
+    bind $w <ButtonPress> [list panner::_press $w %b %x %y]
+    bind $w <B1-Motion> [list panner::_motion $w %x %y]
+    bind $w <B1-ButtonRelease> [list panner::_release $w %x %y]
+    setcanvas $w $canvas
 }
-pannerproc-export setcolor-background {c} { $w configure -background $c }
-pannerproc-export setcolor-base {c} { $w itemconfigure base -fill $c }
-pannerproc-export setcolor-core {c} { $w itemconfigure core -outline $c }
+pannerproc setcolor-background {c} { $w configure -background $c }
+pannerproc setcolor-base {c} { $w itemconfigure base -fill $c }
+pannerproc setcolor-core {c} { $w itemconfigure core -outline $c }
 
 proc canvas-scroll-bbox {canvas} {
     $canvas configure -scrollregion [$canvas bbox all]
 }
 namespace export canvas-scroll-bbox
 
-pannerproc-export destroy {w} {
-    debug $w "destroy"
-    panner-disable $w
+pannerproc destroy {w} {
+    _debug $w "destroy"
+    disable $w
     destroy $w
-    debug $w "destroyed"
+    _debug $w "destroyed"
     unset d
 }
 
-pannerproc-export disable {} {
-    debug $w "disable"
+pannerproc disable {} {
+    _debug $w "disable"
     if {[info exists d(canvas)]} {
-	debug $w "disable unbind"
+	_debug $w "disable unbind"
 	bind $d(canvas) <Configure> {}
 	unset d(canvas)
     }
     set d(enabled) 0
-    noshow $w
+    _noshow $w
 }
 
-pannerproc noshow {} {
-    debug $w " noshow"
+pannerproc _noshow {} {
+    _debug $w " _noshow"
     $w coords base -5 -5 -5 -5
     $w coords core -5 -5 -5 -5
 }
 
-pannerproc-export setcanvas {canvas} {
-    debug $w "setcanvas $canvas"
-    panner-disable $w
+pannerproc setcanvas {canvas} {
+    _debug $w "setcanvas $canvas"
+    disable $w
     set d(canvas) $canvas
-    bind $d(canvas) <Configure> [list panner::resize $w c-event]
-    panner-updatecanvas $w
+    bind $d(canvas) <Configure> [list panner::_resize $w c-event]
+    updatecanvas $w
 }
 
 proc manyset {list args} {
@@ -82,20 +75,20 @@ proc manyset {list args} {
     }
 }
 
-pannerproc-export updatecanvas-bbox {} {
+pannerproc updatecanvas-bbox {} {
     canvas-scroll-bbox $d(canvas)
-    panner-updatecanvas $w
+    updatecanvas $w
 }
 
-pannerproc-export updatecanvas {} {
+pannerproc updatecanvas {} {
     set d(bbox) [$d(canvas) cget -scrollregion]
     manyset $d(bbox) x1 y1 x2 y2
     set d(cwidth) [expr {$x2-$x1}]
     set d(cheight) [expr {$y2-$y1}]
-    debug $w "updatecanvas bbox=[join $d(bbox) ,] c=$d(cwidth),$d(cheight)"
+    _debug $w "updatecanvas bbox=[join $d(bbox) ,] c=$d(cwidth),$d(cheight)"
 
     set d(enabled) [expr {$d(cwidth) && $d(cheight)}]
-    if {!$d(enabled)} { noshow $w; return }
+    if {!$d(enabled)} { _noshow $w; return }
 
     # here we only set the pager's _requested_ height
     set caspect [expr {($x2-$x1) * 1.0 / ($y2-$y1)}]
@@ -110,19 +103,19 @@ pannerproc-export updatecanvas {} {
 	set reqw $d(maxwidth)
 	set reqh [expr {$d(maxwidth) * $caspect}]
     }
-    debug $w "updatecanvas  aspects=$caspect,$waspect too=$too req=$reqw,$reqh"
+    _debug $w "updatecanvas  aspects=$caspect,$waspect too=$too req=$reqw,$reqh"
     $w configure -width $reqw -height $reqh
 
-    resize $w c-update
+    _resize $w c-update
 }
 
-pannerproc resize {why} {
-    noshow $w
+pannerproc _resize {why} {
+    _noshow $w
 
     set d(wwidth) [winfo width $w]
     set d(wheight) [winfo height $w]
 
-    debug $w "resize $why w=$d(wwidth),$d(wheight)"
+    _debug $w "_resize $why w=$d(wwidth),$d(wheight)"
     if {!$d(enabled) || $d(wwidth)<2 || $d(wheight)<2} return
 
     set hscale [expr {$d(wwidth) * 1.0 / $d(cwidth)}]
@@ -143,40 +136,40 @@ pannerproc resize {why} {
 	[expr {$corewidth + $d(add_xview)}] \
 	[expr {$coreheight + $d(add_yview)}]
 
-    debug $w "resize     scales=$hscale,$vscale scale=$d(scale)\
+    _debug $w "_resize     scales=$hscale,$vscale scale=$d(scale)\
         mul=$d(mul_xview),$d(mul_yview)\
         add=$d(add_xview),$d(add_yview)\
         coresz=$corewidth,$coreheight"
 
-    redisplay $w
+    _redisplay $w
 }
 
-pannerproc mapc {view which} {
+pannerproc _mapc {view which} {
     set viewpos [lindex [$d(canvas) $view] $which]
     set r [expr {$viewpos * $d(mul_$view) + $d(add_$view)}]
-    debug $w "  mapc $view wh=$which viewpos=$viewpos => $r"
+    _debug $w "  _mapc $view wh=$which viewpos=$viewpos => $r"
     return $r
 }
 
-pannerproc redisplay {} {
-    debug $w "redisplay"
+pannerproc _redisplay {} {
+    _debug $w "_redisplay"
     $w coords core \
-	[mapc $w xview 0] \
-	[mapc $w yview 0] \
-	[mapc $w xview 1] \
-	[mapc $w yview 1]
+	[_mapc $w xview 0] \
+	[_mapc $w yview 0] \
+	[_mapc $w xview 1] \
+	[_mapc $w yview 1]
 }
 
-pannerproc press {b x y} {
+pannerproc _press {b x y} {
     if {$b != 1} return
     set d(down_x) $x
     set d(down_y) $y
     set d(down_xview) [lindex [$d(canvas) xview] 0]
     set d(down_yview) [lindex [$d(canvas) yview] 0]
-    debug $w "press down=$x,$y view=$d(down_xview),$d(down_yview)"
+    _debug $w "_press down=$x,$y view=$d(down_xview),$d(down_yview)"
 }
 
-pannerproc motion {x y} {
+pannerproc _motion {x y} {
     if {![info exists d(down_x)]} return
     foreach xy {x y} wh {width height} {
 	set newpos [expr {
@@ -186,13 +179,13 @@ pannerproc motion {x y} {
 	$d(canvas) ${xy}view moveto $newpos
 	lappend dl $newpos
     }
-    debug $w "motion $x,$y [join $dl ,]"
-    redisplay $w
+    _debug $w "_motion $x,$y [join $dl ,]"
+    _redisplay $w
 }
 
-pannerproc release {x y} {
-    debug $w "release $x,$y"
-    motion $w $x $y
+pannerproc _release {x y} {
+    _debug $w "_release $x,$y"
+    _motion $w $x $y
     catch { unset d(down_x) }
 }
 
diff --git a/yarrg/pantest.tcl b/yarrg/pantest.tcl
index b13326e..e864d0b 100755
--- a/yarrg/pantest.tcl
+++ b/yarrg/pantest.tcl
@@ -1,7 +1,12 @@
 #!/usr/bin/wish
 
-source panner.tcl
-namespace import panner::*
+pkg_mkIndex .
+set auto_path [concat . $auto_path]
+
+#source panner.tcl
+#namespace import panner::*
+
+package require panner
 
 set scale 50
 
@@ -12,8 +17,8 @@ for {set x -$scale} {$x < 500} {incr x $scale} {
     }
 }
 
-canvas-scroll-bbox .c
-panner-create .p .c 200 200 1
+panner::canvas-scroll-bbox .c
+panner::create .p .c 200 200 1
 
 pack .p -side right
 pack .c -expand y -fill both -side left