home *** CD-ROM | disk | FTP | other *** search
/ PC World 2002 May / PCWorld_2002-05_cd.bin / Software / TemaCD / activetcltk / ActiveTcl8.3.4.1-8.win32-ix86.exe / ActiveTcl8.3.4.1-win32-ix86 / lib / bwidget1.3.0 / dropsite.tcl < prev    next >
Encoding:
Text File  |  2001-10-22  |  15.4 KB  |  454 lines
  1. # ------------------------------------------------------------------------------
  2. #  dropsite.tcl
  3. #  This file is part of Unifix BWidget Toolkit
  4. #  $Id: dropsite.tcl,v 1.5 2000/06/15 00:45:16 kuchler Exp $
  5. # ------------------------------------------------------------------------------
  6. #  Index of commands:
  7. #     - DropSite::include
  8. #     - DropSite::setdrop
  9. #     - DropSite::register
  10. #     - DropSite::setcursor
  11. #     - DropSite::setoperation
  12. #     - DropSite::_update_operation
  13. #     - DropSite::_compute_operation
  14. #     - DropSite::_draw_operation
  15. #     - DropSite::_init_drag
  16. #     - DropSite::_motion
  17. #     - DropSite::_release
  18. # ------------------------------------------------------------------------------
  19.  
  20.  
  21. namespace eval DropSite {
  22.     Widget::declare DropSite [list \
  23.         [list -dropovercmd String "" 0] \
  24.         [list -dropcmd     String "" 0] \
  25.         [list -droptypes   String "" 0] \
  26.         ]
  27.  
  28.     proc use {} {}
  29.  
  30.     variable _top  ".drag"
  31.     variable _opw  ".drag.\#op"
  32.     variable _target  ""
  33.     variable _status  0
  34.     variable _tabops
  35.     variable _defops
  36.     variable _source
  37.     variable _type
  38.     variable _data
  39.     variable _evt
  40.     # key       win    unix
  41.     # shift       1   |   1    ->  1
  42.     # control     4   |   4    ->  4
  43.     # alt         8   |  16    -> 24
  44.     # meta            |  64    -> 88
  45.  
  46.     array set _tabops {
  47.         mod,none    0
  48.         mod,shift   1
  49.         mod,control 4
  50.         mod,alt     24
  51.         ops,copy    1
  52.         ops,move    1
  53.         ops,link    1
  54.     }
  55.  
  56.     if { $tcl_platform(platform) == "unix" } {
  57.         set _tabops(mod,alt) 8
  58.     } else {
  59.         set _tabops(mod,alt) 16
  60.     }
  61.     array set _defops \
  62.         [list \
  63.              copy,mod  shift   \
  64.              move,mod  control \
  65.              link,mod  alt     \
  66.              copy,img  @[file join $::BWIDGET::LIBRARY "images" "opcopy.xbm"] \
  67.              move,img  @[file join $::BWIDGET::LIBRARY "images" "opmove.xbm"] \
  68.              link,img  @[file join $::BWIDGET::LIBRARY "images" "oplink.xbm"]]
  69.  
  70.     bind DragTop <KeyPress-Shift_L>     {DropSite::_update_operation [expr %s | 1]}
  71.     bind DragTop <KeyPress-Shift_R>     {DropSite::_update_operation [expr %s | 1]}
  72.     bind DragTop <KeyPress-Control_L>   {DropSite::_update_operation [expr %s | 4]}
  73.     bind DragTop <KeyPress-Control_R>   {DropSite::_update_operation [expr %s | 4]}
  74.     if { $tcl_platform(platform) == "unix" } {
  75.         bind DragTop <KeyPress-Alt_L>       {DropSite::_update_operation [expr %s | 8]}
  76.         bind DragTop <KeyPress-Alt_R>       {DropSite::_update_operation [expr %s | 8]}
  77.     } else {
  78.         bind DragTop <KeyPress-Alt_L>       {DropSite::_update_operation [expr %s | 16]}
  79.         bind DragTop <KeyPress-Alt_R>       {DropSite::_update_operation [expr %s | 16]}
  80.     }
  81.  
  82.     bind DragTop <KeyRelease-Shift_L>   {DropSite::_update_operation [expr %s & ~1]}
  83.     bind DragTop <KeyRelease-Shift_R>   {DropSite::_update_operation [expr %s & ~1]}
  84.     bind DragTop <KeyRelease-Control_L> {DropSite::_update_operation [expr %s & ~4]}
  85.     bind DragTop <KeyRelease-Control_R> {DropSite::_update_operation [expr %s & ~4]}
  86.     if { $tcl_platform(platform) == "unix" } {
  87.         bind DragTop <KeyRelease-Alt_L>     {DropSite::_update_operation [expr %s & ~8]}
  88.         bind DragTop <KeyRelease-Alt_R>     {DropSite::_update_operation [expr %s & ~8]}
  89.     } else {
  90.         bind DragTop <KeyRelease-Alt_L>     {DropSite::_update_operation [expr %s & ~16]}
  91.         bind DragTop <KeyRelease-Alt_R>     {DropSite::_update_operation [expr %s & ~16]}
  92.     }
  93. }
  94.  
  95.  
  96. # ------------------------------------------------------------------------------
  97. #  Command DropSite::include
  98. # ------------------------------------------------------------------------------
  99. proc DropSite::include { class types } {
  100.     set dropoptions [list \
  101.         [list    -dropenabled    Boolean    0    0] \
  102.         [list    -dropovercmd    String    ""    0] \
  103.         [list    -dropcmd    String    ""    0] \
  104.         [list    -droptypes    String    $types    0] \
  105.         ]
  106.     Widget::declare $class $dropoptions
  107. }
  108.  
  109.  
  110. # ------------------------------------------------------------------------------
  111. #  Command DropSite::setdrop
  112. #  Widget interface to register
  113. # ------------------------------------------------------------------------------
  114. proc DropSite::setdrop { path subpath dropover drop {force 0}} {
  115.     set cen    [Widget::hasChanged $path -dropenabled en]
  116.     set ctypes [Widget::hasChanged $path -droptypes   types]
  117.     if { $en } {
  118.         if { $force || $cen || $ctypes } {
  119.             register $subpath \
  120.                 -droptypes   $types \
  121.                 -dropcmd     $drop  \
  122.                 -dropovercmd $dropover
  123.         }
  124.     } else {
  125.         register $subpath
  126.     }
  127. }
  128.  
  129.  
  130. # ------------------------------------------------------------------------------
  131. #  Command DropSite::register
  132. # ------------------------------------------------------------------------------
  133. proc DropSite::register { path args } {
  134.     variable _tabops
  135.     variable _defops
  136.     upvar \#0 DropSite::$path drop
  137.  
  138.     Widget::init DropSite .drop$path $args
  139.     if { [info exists drop] } {
  140.         unset drop
  141.     }
  142.     set dropcmd [Widget::getMegawidgetOption .drop$path -dropcmd]
  143.     set types   [Widget::getMegawidgetOption .drop$path -droptypes]
  144.     set overcmd [Widget::getMegawidgetOption .drop$path -dropovercmd]
  145.     Widget::destroy .drop$path
  146.     if { $dropcmd != "" && $types != "" } {
  147.         set drop(dropcmd) $dropcmd
  148.         set drop(overcmd) $overcmd
  149.         foreach {type ops} $types {
  150.             set drop($type,ops) {}
  151.             foreach {descop lmod} $ops {
  152.                 if { ![llength $descop] || [llength $descop] > 3 } {
  153.                     return -code error "invalid operation description \"$descop\""
  154.                 }
  155.                 foreach {subop baseop imgop} $descop {
  156.                     set subop [string trim $subop]
  157.                     if { ![string length $subop] } {
  158.                         return -code error "sub operation is empty"
  159.                     }
  160.                     if { ![string length $baseop] } {
  161.                         set baseop $subop
  162.                     }
  163.                     if { [info exists drop($type,ops,$subop)] } {
  164.                         return -code error "operation \"$subop\" already defined"
  165.                     }
  166.                     if { ![info exists _tabops(ops,$baseop)] } {
  167.                         return -code error "invalid base operation \"$baseop\""
  168.                     }
  169.                     if { [string compare $subop $baseop] &&
  170.                          [info exists _tabops(ops,$subop)] } {
  171.                         return -code error "sub operation \"$subop\" is a base operation"
  172.                     }
  173.                     if { ![string length $imgop] } {
  174.                         set imgop $_defops($baseop,img)
  175.                     }
  176.                 }
  177.                 if { ![string compare $lmod "program"] } {
  178.                     set drop($type,ops,$subop) $baseop
  179.                     set drop($type,img,$subop) $imgop
  180.                 } else {
  181.                     if { ![string length $lmod] } {
  182.                         set lmod $_defops($baseop,mod)
  183.                     }
  184.                     set mask 0
  185.                     foreach mod $lmod {
  186.                         if { ![info exists _tabops(mod,$mod)] } {
  187.                             return -code error "invalid modifier \"$mod\""
  188.                         }
  189.                         set mask [expr {$mask | $_tabops(mod,$mod)}]
  190.                     }
  191.                     if { ($mask == 0) != ([string compare $subop "default"] == 0) } {
  192.                         return -code error "sub operation default can only be used with modifier \"none\""
  193.                     }
  194.                     set drop($type,mod,$mask)  $subop
  195.                     set drop($type,ops,$subop) $baseop
  196.                     set drop($type,img,$subop) $imgop
  197.                     lappend masklist $mask
  198.                 }
  199.             }
  200.             if { ![info exists drop($type,mod,0)] } {
  201.                 set drop($type,mod,0)       default
  202.                 set drop($type,ops,default) copy
  203.                 set drop($type,img,default) $_defops(copy,img)
  204.                 lappend masklist 0
  205.             }
  206.             set drop($type,ops,force) copy
  207.             set drop($type,img,force) $_defops(copy,img)
  208.             foreach mask [lsort -integer -decreasing $masklist] {
  209.                 lappend drop($type,ops) $mask $drop($type,mod,$mask)
  210.             }
  211.         }
  212.     }
  213. }
  214.  
  215.  
  216. # ------------------------------------------------------------------------------
  217. #  Command DropSite::setcursor
  218. # ------------------------------------------------------------------------------
  219. proc DropSite::setcursor { cursor } {
  220.     catch {.drag configure -cursor $cursor}
  221. }
  222.  
  223.  
  224. # ------------------------------------------------------------------------------
  225. #  Command DropSite::setoperation
  226. # ------------------------------------------------------------------------------
  227. proc DropSite::setoperation { op } {
  228.     variable _curop
  229.     variable _dragops
  230.     variable _target
  231.     variable _type
  232.     upvar \#0 DropSite::$_target drop
  233.  
  234.     if { [info exist drop($_type,ops,$op)] &&
  235.          $_dragops($drop($_type,ops,$op)) } {
  236.         set _curop $op
  237.     } else {
  238.         # force to a copy operation
  239.         set _curop force
  240.     }
  241. }
  242.  
  243.  
  244. # ------------------------------------------------------------------------------
  245. #  Command DropSite::_init_drag
  246. # ------------------------------------------------------------------------------
  247. proc DropSite::_init_drag { top evt source state X Y type ops data } {
  248.     variable _top
  249.     variable _source
  250.     variable _type
  251.     variable _data
  252.     variable _target
  253.     variable _status
  254.     variable _state
  255.     variable _dragops
  256.     variable _opw
  257.     variable _evt
  258.  
  259.     if {[info exists _dragops]} {
  260.         unset _dragops
  261.     }
  262.     array set _dragops {copy 1 move 0 link 0}
  263.     foreach op $ops {
  264.         set _dragops($op) 1
  265.     }
  266.     set _target ""
  267.     set _status  0
  268.     set _top     $top
  269.     set _source  $source
  270.     set _type    $type
  271.     set _data    $data
  272.  
  273.     label $_opw -relief flat -bd 0 -highlightthickness 0 \
  274.         -foreground black -background white
  275.  
  276.     bind $top <ButtonRelease-$evt> {DropSite::_release %X %Y}
  277.     bind $top <B$evt-Motion>       {DropSite::_motion  %X %Y}
  278.     bind $top <Motion>             {DropSite::_release %X %Y}
  279.     set _state $state
  280.     set _evt   $evt
  281.     _motion $X $Y
  282. }
  283.  
  284.  
  285. # ------------------------------------------------------------------------------
  286. #  Command DropSite::_update_operation
  287. # ------------------------------------------------------------------------------
  288. proc DropSite::_update_operation { state } {
  289.     variable _top
  290.     variable _status
  291.     variable _state
  292.  
  293.     if { $_status & 3 } {
  294.         set _state $state
  295.         _motion [winfo pointerx $_top] [winfo pointery $_top]
  296.     }
  297. }
  298.  
  299.  
  300. # ------------------------------------------------------------------------------
  301. #  Command DropSite::_compute_operation
  302. # ------------------------------------------------------------------------------
  303. proc DropSite::_compute_operation { target state type } {
  304.     variable  _curop
  305.     variable  _dragops
  306.     upvar \#0 DropSite::$target drop
  307.  
  308.     foreach {mask op} $drop($type,ops) {
  309.         if { ($state & $mask) == $mask } {
  310.             if { $_dragops($drop($type,ops,$op)) } {
  311.                 set _curop $op
  312.                 return
  313.             }
  314.         }
  315.     }
  316.     set _curop force
  317. }
  318.  
  319.  
  320. # ------------------------------------------------------------------------------
  321. #  Command DropSite::_draw_operation
  322. # ------------------------------------------------------------------------------
  323. proc DropSite::_draw_operation { target type } {
  324.     variable _opw
  325.     variable _curop
  326.     variable _dragops
  327.     variable _tabops
  328.     variable _status
  329.  
  330.     upvar \#0 DropSite::$target drop
  331.  
  332.     if { !($_status & 1) } {
  333.         catch {place forget $_opw}
  334.         return
  335.     }
  336.  
  337.     if { 0 } {
  338.     if { ![info exist drop($type,ops,$_curop)] ||
  339.          !$_dragops($drop($type,ops,$_curop)) } {
  340.         # force to a copy operation
  341.         set _curop copy
  342.         catch {
  343.             $_opw configure -bitmap $_tabops(img,copy)
  344.             place $_opw -relx 1 -rely 1 -anchor se
  345.         }
  346.     }
  347.     } elseif { ![string compare $_curop "default"] } {
  348.         catch {place forget $_opw}
  349.     } else {
  350.         catch {
  351.             $_opw configure -bitmap $drop($type,img,$_curop)
  352.             place $_opw -relx 1 -rely 1 -anchor se
  353.         }
  354.     }
  355. }
  356.  
  357.  
  358. # ------------------------------------------------------------------------------
  359. #  Command DropSite::_motion
  360. # ------------------------------------------------------------------------------
  361. proc DropSite::_motion { X Y } {
  362.     variable _top
  363.     variable _target
  364.     variable _status
  365.     variable _state
  366.     variable _curop
  367.     variable _type
  368.     variable _data
  369.     variable _source
  370.     variable _evt
  371.  
  372.     set script [bind $_top <B$_evt-Motion>]
  373.     bind $_top <B$_evt-Motion> {}
  374.     bind $_top <Motion>        {}
  375.     wm geometry $_top "+[expr {$X+1}]+[expr {$Y+1}]"
  376.     update
  377.     if { ![winfo exists $_top] } {
  378.         return
  379.     }
  380.     set path [winfo containing $X $Y]
  381.     if { [string compare $path $_target] } {
  382.         # path != current target
  383.         if { $_status & 2 } {
  384.             # current target is valid and has recall status
  385.             # generate leave event
  386.             upvar   \#0 DropSite::$_target drop
  387.             uplevel \#0 $drop(overcmd) [list $_target $_source leave $X $Y $_curop $_type $_data]
  388.         }
  389.         set _target $path
  390.         upvar \#0 DropSite::$_target drop
  391.         if { [info exists drop($_type,ops)] } {
  392.             # path is a valid target
  393.             _compute_operation $_target $_state $_type
  394.             if { $drop(overcmd) != "" } {
  395.                 set arg     [list $_target $_source enter $X $Y $_curop $_type $_data]
  396.                 set _status [uplevel \#0 $drop(overcmd) $arg]
  397.             } else {
  398.                 set _status 1
  399.                 catch {$_top configure -cursor based_arrow_down}
  400.             }
  401.             _draw_operation $_target $_type
  402.             update
  403.             catch {
  404.                 bind $_top <B$_evt-Motion> {DropSite::_motion  %X %Y}
  405.                 bind $_top <Motion>        {DropSite::_release %X %Y}
  406.             }
  407.             return
  408.         } else {
  409.             set _status 0
  410.             catch {$_top configure -cursor dot}
  411.             _draw_operation "" ""
  412.         }
  413.     } elseif { $_status & 2 } {
  414.         upvar \#0 DropSite::$_target drop
  415.         _compute_operation $_target $_state $_type
  416.         set arg     [list $_target $_source motion $X $Y $_curop $_type $_data]
  417.         set _status [uplevel \#0 $drop(overcmd) $arg]
  418.         _draw_operation $_target $_type
  419.     }
  420.     update
  421.     catch {
  422.         bind $_top <B$_evt-Motion> {DropSite::_motion  %X %Y}
  423.         bind $_top <Motion>        {DropSite::_release %X %Y}
  424.     }
  425. }
  426.  
  427.  
  428.  
  429. # ------------------------------------------------------------------------------
  430. #  Command DropSite::_release
  431. # ------------------------------------------------------------------------------
  432. proc DropSite::_release { X Y } {
  433.     variable _target
  434.     variable _status
  435.     variable _curop
  436.     variable _source
  437.     variable _type
  438.     variable _data
  439.  
  440.     if { $_status & 1 } {
  441.         upvar \#0 DropSite::$_target drop
  442.  
  443.         set res [uplevel \#0 $drop(dropcmd) [list $_target $_source $X $Y $_curop $_type $_data]]
  444.         DragSite::_end_drag $_source $_target $drop($_type,ops,$_curop) $_type $_data $res
  445.     } else {
  446.         if { $_status & 2 } {
  447.             # notify leave event
  448.             upvar \#0 DropSite::$_target drop
  449.             uplevel \#0 $drop(overcmd) [list $_target $_source leave $X $Y $_curop $_type $_data]
  450.         }
  451.         DragSite::_end_drag $_source "" "" $_type $_data 0
  452.     }
  453. }
  454.