panner is a proper package

diff --git a/.gitignore b/.gitignore
index 9beb60b750d2464935fe401f3c4f57834f606650..a580b970b1b2d1a3a00ed34384cd3fca62d670a2 100644 (file)
--- a/.gitignore
+++ b/.gitignore
@@ -15,3 +15,5 @@ yarrg/_*.*
 yarrg/OCEAN-*.db
 yarrg/Writer.lock
 yarrg/DATA
 yarrg/OCEAN-*.db
 yarrg/Writer.lock
 yarrg/DATA

+
+yarrg/pkgIndex.tcl

diff --git a/yarrg/panner.tcl b/yarrg/panner.tcl
index 9f181a7c05f79af28200753c812c71c58f3c9e7c..cc3819aaa3af154d5efd37bb2768269336603778 100644 (file)
--- a/yarrg/panner.tcl
+++ b/yarrg/panner.tcl
@@ -1,78 +1,71 @@
 package provide panner 0.1;
 namespace eval panner {
 
 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 {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"
 }
 
     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
     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
     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
 
 
 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
     destroy $w

-    debug $w "destroyed"
+    _debug $w "destroyed"

     unset d
 }
 
     unset d
 }
 

-pannerproc-export disable {} {
-    debug $w "disable"
+pannerproc disable {} {
+    _debug $w "disable"

     if {[info exists d(canvas)]} {
     if {[info exists d(canvas)]} {

-       debug $w "disable unbind"
+       _debug $w "disable unbind"

        bind $d(canvas) <Configure> {}
        unset d(canvas)
     }
     set d(enabled) 0
        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
 }
 
     $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
     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} {
 }
 
 proc manyset {list args} {


@@ -82,20 +75,20 @@ proc manyset {list args} {
     }
 }
 
     }
 }
 

-pannerproc-export updatecanvas-bbox {} {
+pannerproc updatecanvas-bbox {} {

     canvas-scroll-bbox $d(canvas)
     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}]
     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)}]
 
     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)}]
 
     # 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}]
     }
        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
 
     $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]
 
 
     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)}]
     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)}]
 
        [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"
 
         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)}]
     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
 }
 
     return $r
 }
 

-pannerproc redisplay {} {
-    debug $w "redisplay"
+pannerproc _redisplay {} {
+    _debug $w "_redisplay"

     $w coords core \
     $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]
     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 {
     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
     }
        $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) }
 }
 
     catch { unset d(down_x) }
 }
 

diff --git a/yarrg/pantest.tcl b/yarrg/pantest.tcl
index b13326e9c3bd1a604fd7283824891644e3d1162d..e864d0bd722130fc800bdcff64f0ed28b384217a 100755 (executable)
--- a/yarrg/pantest.tcl
+++ b/yarrg/pantest.tcl
@@ -1,7 +1,12 @@
 #!/usr/bin/wish
 
 #!/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
 
 
 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
 
 pack .p -side right
 pack .c -expand y -fill both -side left