util/X86LINUX64/lib/blt2.5/demos/scripts/send.tcl

   1
   2
   3 # --------------------------------------------------------------------------
   4 #
   5 # SendInit --
   6 #
   7 #       Creates a "send" proc to replace the former Tk send command.
   8 #       Uses DDE services to simulate the transfer.  This must be
   9 #       called before any drag&drop targets are registered. Otherwise
  10 #       they will pick up the wrong application name.
  11 #
  12 #       The first trick is to determine a unique application name. This
  13 #       is what other applications will use to send to us.  Tk used to
  14 #       do this for us.
  15 #
  16 #       Note that we can generate the same name for two different Tk
  17 #       applications.  This can happen if two Tk applications picking
  18 #       names at exactly the same time.   [In the future, we should
  19 #       probably generate a name based upon a global system value, such
  20 #       as the handle of the main window ".".]   The proc "SendVerify"
  21 #       below will verify that you have only one DDE server registered
  22 #       with this application's name.
  23 #
  24 # Arguments:
  25 #       myInterp        Sets the application name explicitly to this
  26 #                       string. If the argument isn't given, or is the
  27 #                       empty string, then the routine picks a name for
  28 #                       us.
  29 #
  30 # Results:
  31 #       Returns the name of the application.
  32 #
  33 # Side Effects:
  34 #       Sets the name of our application.  You can call "tk appname" to
  35 #       get the name.  A DDE topic using the same name is also created.
  36 #       A send proc is also automatically created.  Be careful that you
  37 #       don't overwrite an existing send command.
  38 #
  39 # --------------------------------------------------------------------------
  40
  41 proc SendInit { {myInterp ""} } {
  42
  43     # Load the DDE package.
  44     package require dde
  45
  46     if { $myInterp == "" } {
  47
  48         # Pick a unique application name, replicating what Tk used to do.
  49         # This is what other applications will use to "send" to us. We'll
  50         # use DDE topics to represent interpreters.
  51
  52         set appName [tk appname]
  53         set count 0
  54         set suffix {}
  55
  56         # Keep generating interpreter names by suffix-ing the original
  57         # application name with " #number".  Sooner of later we'll find
  58         # one that's not currently use.
  59
  60         while { 1 } {
  61             set myInterp "${appName}${suffix}"
  62             set myServer [list TclEval $myInterp]
  63             if { [lsearch [dde services TclEval {}] $myServer] < 0 } {
  64                 break
  65             }
  66             incr count
  67             set suffix " \#$count"
  68         }
  69     }
  70     tk appname $myInterp
  71     dde servername $myInterp
  72     proc send { interp args } {
  73         dde eval $interp $args
  74     }
  75     return $myInterp
  76 }
  77
  78
  79 # --------------------------------------------------------------------------
  80 #
  81 # SendVerify --
  82 #
  83 #       Verifies that application name picked is uniquely registered
  84 #       as a DDE server.  This checks that two Tk applications don't
  85 #       accidently use the same name.
  86 #
  87 # Arguments:
  88 #       None            Used the current application name.
  89 #
  90 # Results:
  91 #       Generates an error if either a server can't be found or more
  92 #       than one server is registered.
  93 #
  94 # --------------------------------------------------------------------------
  95
  96 proc SendVerify {} {
  97     # Load the DDE package.
  98     package require dde
  99
 100     set count 0
 101     set appName [tk appname]
 102     foreach server [dde services TclEval {}] {
 103         set topic [lindex $server 1]
 104         if { [string compare $topic $appName] == 0 } {
 105             incr count
 106         }
 107     }
 108     if {$count == 0} {
 109         error "Service not found: wrong name registered???"
 110     }
 111     if { $count > 1 } {
 112         error "Duplicate names found for \"[tk appname]\""
 113     }
 114 }
 115