home *** CD-ROM | disk | FTP | other *** search
/ PC World 2000 December / PCWorld_2000-12_cd.bin / Komunikace / Comanche / BWidget-1.2 / dropsite.tcl < prev    next >
Text File  |  2000-11-02  |  16KB  |  440 lines
  1. # ------------------------------------------------------------------------------
  2. #  dropsite.tcl
  3. #  This file is part of Unifix BWidget Toolkit
  4. #  $Id: dropsite.tcl,v 1.1.1.1 1996/02/22 06:05:55 daniel 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 {
  23.         {-dropovercmd String "" 0}
  24.         {-dropcmd     String "" 0}
  25.         {-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.  
  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 $env(BWIDGET_LIBRARY) "images" "opcopy.xbm"] \
  67.              move,img  @[file join $env(BWIDGET_LIBRARY) "images" "opmove.xbm"] \
  68.              link,img  @[file join $env(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 {
  101.         {-dropenabled Boolean 0  0}
  102.         {-dropovercmd String  "" 0}
  103.         {-dropcmd     String  "" 0}
  104.     }
  105.     lappend dropoptions [list -droptypes String $types 0]
  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::getoption .drop$path -dropcmd]
  143.     set types   [Widget::getoption .drop$path -droptypes]
  144.     set overcmd [Widget::getoption .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 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.  
  258.     catch {unset _dragops}
  259.     array set _dragops {copy 1 move 0 link 0}
  260.     foreach op $ops {
  261.         set _dragops($op) 1
  262.     }
  263.     set _target ""
  264.     set _status  0
  265.     set _top     $top
  266.     set _source  $source
  267.     set _type    $type
  268.     set _data    $data
  269.  
  270.     label $_opw -relief flat -bd 0 -highlightthickness 0 \
  271.         -foreground black -background white
  272.  
  273.     bind $top <ButtonRelease> {DropSite::_release %X %Y}
  274.     bind $top <Motion>        {DropSite::_motion  %X %Y}
  275.     set _state $state
  276.     _motion $X $Y
  277. }
  278.  
  279.  
  280. # ------------------------------------------------------------------------------
  281. #  Command DropSite::_update_operation
  282. # ------------------------------------------------------------------------------
  283. proc DropSite::_update_operation { state } {
  284.     variable _top
  285.     variable _status
  286.     variable _state
  287.  
  288.     if { $_status & 3 } {
  289.         set _state $state
  290.         _motion [winfo pointerx $_top] [winfo pointery $_top]
  291.     }
  292. }
  293.  
  294.  
  295. # ------------------------------------------------------------------------------
  296. #  Command DropSite::_compute_operation
  297. # ------------------------------------------------------------------------------
  298. proc DropSite::_compute_operation { target state type } {
  299.     variable  _curop
  300.     variable  _dragops
  301.     upvar \#0 DropSite::$target drop
  302.  
  303.     foreach {mask op} $drop($type,ops) {
  304.         if { ($state & $mask) == $mask } {
  305.             if { $_dragops($drop($type,ops,$op)) } {
  306.                 set _curop $op
  307.                 return
  308.             }
  309.         }
  310.     }
  311.     set _curop force
  312. }
  313.  
  314.  
  315. # ------------------------------------------------------------------------------
  316. #  Command DropSite::_draw_operation
  317. # ------------------------------------------------------------------------------
  318. proc DropSite::_draw_operation { target type } {
  319.     variable _opw
  320.     variable _curop
  321.     variable _dragops
  322.     variable _tabops
  323.     variable _status
  324.  
  325.     upvar \#0 DropSite::$target drop
  326.  
  327.     if { !($_status & 1) } {
  328.         catch {place forget $_opw}
  329.         return
  330.     }
  331.  
  332.     if { 0 } {
  333.     if { ![info exist drop($type,ops,$_curop)] ||
  334.          !$_dragops($drop($type,ops,$_curop)) } {
  335.         # force to a copy operation
  336.         set _curop copy
  337.         catch {
  338.             $_opw configure -bitmap $_tabops(img,copy)
  339.             place $_opw -relx 1 -rely 1 -anchor se
  340.         }
  341.     }
  342.     } elseif { ![string compare $_curop "default"] } {
  343.         catch {place forget $_opw}
  344.     } else {
  345.         catch {
  346.             $_opw configure -bitmap $drop($type,img,$_curop)
  347.             place $_opw -relx 1 -rely 1 -anchor se
  348.         }
  349.     }
  350. }
  351.  
  352.  
  353. # ------------------------------------------------------------------------------
  354. #  Command DropSite::_motion
  355. # ------------------------------------------------------------------------------
  356. proc DropSite::_motion { X Y } {
  357.     variable _top
  358.     variable _target
  359.     variable _status
  360.     variable _state
  361.     variable _curop
  362.     variable _type
  363.     variable _data
  364.     variable _source
  365.  
  366.     set script [bind $_top <Motion>]
  367.     bind $_top <Motion> {}
  368.     wm geometry $_top "+[expr {$X+1}]+[expr {$Y+1}]"
  369.     update
  370.     if { ![winfo exists $_top] } {
  371.         return
  372.     }
  373.     set path [winfo containing $X $Y]
  374.     if { [string compare $path $_target] } {
  375.         # path != current target
  376.         if { $_status & 2 } {
  377.             # current target is valid and has recall status
  378.             # generate leave event
  379.             upvar   \#0 DropSite::$_target drop
  380.             uplevel \#0 $drop(overcmd) [list $_target $_source leave $X $Y $_curop $_type $_data]
  381.         }
  382.         set _target $path
  383.         upvar \#0 DropSite::$_target drop
  384.         if { [info exists drop($_type,ops)] } {
  385.             # path is a valid target
  386.             _compute_operation $_target $_state $_type
  387.             if { $drop(overcmd) != "" } {
  388.                 set arg     [list $_target $_source enter $X $Y $_curop $_type $_data]
  389.                 set _status [uplevel \#0 $drop(overcmd) $arg]
  390.             } else {
  391.                 set _status 1
  392.                 catch {$top configure -cursor based_arrow_down}
  393.             }
  394.             _draw_operation $_target $_type
  395.             catch {bind $_top <Motion> $script}
  396.             return
  397.         } else {
  398.             set _status 0
  399.             catch {$_top configure -cursor dot}
  400.             _draw_operation "" ""
  401.         }
  402.     } elseif { $_status & 2 } {
  403.         upvar \#0 DropSite::$_target drop
  404.         _compute_operation $_target $_state $_type
  405.         set arg     [list $_target $_source motion $X $Y $_curop $_type $_data]
  406.         set _status [uplevel \#0 $drop(overcmd) $arg]
  407.         _draw_operation $_target $_type
  408.     }
  409.     update
  410.     catch {bind $_top <Motion> $script}
  411. }
  412.  
  413.  
  414.  
  415. # ------------------------------------------------------------------------------
  416. #  Command DropSite::_release
  417. # ------------------------------------------------------------------------------
  418. proc DropSite::_release { X Y } {
  419.     variable _target
  420.     variable _status
  421.     variable _curop
  422.     variable _source
  423.     variable _type
  424.     variable _data
  425.  
  426.     if { $_status & 1 } {
  427.         upvar \#0 DropSite::$_target drop
  428.  
  429.         set res [uplevel \#0 $drop(dropcmd) [list $_target $_source $X $Y $_curop $_type $_data]]
  430.         DragSite::_end_drag $_source $_target $drop($_type,ops,$_curop) $_type $_data $res
  431.     } else {
  432.         if { $_status & 2 } {
  433.             # notify leave event
  434.             upvar \#0 DropSite::$_target drop
  435.             uplevel \#0 $drop(overcmd) [list $_target $_source leave $X $Y $_curop $_type $_data]
  436.         }
  437.         DragSite::_end_drag $_source "" "" $_type $_data 0
  438.     }
  439. }
  440.