Hex Artifact Content
Not logged in

Artifact a50231f216f6196323065450eb69d32865a9c254:


0000: 23 20 45 78 61 6d 70 6c 65 3a 20 63 68 61 74 20  # Example: chat 
0010: 6f 76 65 72 20 42 6c 75 65 74 6f 6f 74 68 0a 0a  over Bluetooth..
0020: 73 65 74 20 75 75 69 64 20 22 65 64 63 34 65 39  set uuid "edc4e9
0030: 65 66 2d 39 63 39 32 2d 34 32 39 33 2d 39 66 35  ef-9c92-4293-9f5
0040: 36 2d 64 37 31 35 34 39 32 38 65 61 64 35 22 0a  6-d7154928ead5".
0050: 0a 70 72 6f 63 20 74 70 75 74 20 7b 74 65 78 74  .proc tput {text
0060: 7d 20 7b 0a 20 20 20 20 2e 74 65 78 74 20 63 6f  } {.    .text co
0070: 6e 66 69 67 75 72 65 20 2d 73 74 61 74 65 20 6e  nfigure -state n
0080: 6f 72 6d 61 6c 0a 20 20 20 20 2e 74 65 78 74 20  ormal.    .text 
0090: 69 6e 73 65 72 74 20 65 6e 64 20 24 74 65 78 74  insert end $text
00a0: 0a 20 20 20 20 2e 74 65 78 74 20 69 6e 73 65 72  .    .text inser
00b0: 74 20 65 6e 64 20 22 5c 6e 22 0a 20 20 20 20 2e  t end "\n".    .
00c0: 74 65 78 74 20 63 6f 6e 66 69 67 75 72 65 20 2d  text configure -
00d0: 73 74 61 74 65 20 64 69 73 61 62 6c 65 64 0a 20  state disabled. 
00e0: 20 20 20 2e 74 65 78 74 20 79 76 69 65 77 20 2d     .text yview -
00f0: 70 69 63 6b 70 6c 61 63 65 20 65 6e 64 0a 7d 0a  pickplace end.}.
0100: 0a 70 72 6f 63 20 74 63 6c 65 61 72 20 7b 7d 20  .proc tclear {} 
0110: 7b 0a 20 20 20 20 2e 74 65 78 74 20 63 6f 6e 66  {.    .text conf
0120: 69 67 75 72 65 20 2d 73 74 61 74 65 20 6e 6f 72  igure -state nor
0130: 6d 61 6c 0a 20 20 20 20 2e 74 65 78 74 20 64 65  mal.    .text de
0140: 6c 65 74 65 20 31 2e 30 20 65 6e 64 0a 20 20 20  lete 1.0 end.   
0150: 20 2e 74 65 78 74 20 63 6f 6e 66 69 67 75 72 65   .text configure
0160: 20 2d 73 74 61 74 65 20 64 69 73 61 62 6c 65 64   -state disabled
0170: 0a 7d 0a 0a 70 72 6f 63 20 63 6f 6e 6e 65 63 74  .}..proc connect
0180: 20 7b 7d 20 7b 0a 20 20 20 20 69 66 20 7b 5b 69   {} {.    if {[i
0190: 6e 66 6f 20 65 78 69 73 74 73 20 3a 3a 74 78 73  nfo exists ::txs
01a0: 6f 63 6b 5d 7d 20 7b 0a 09 74 78 63 6c 6f 73 65  ock]} {..txclose
01b0: 20 22 63 6c 6f 73 69 6e 67 20 63 6f 6e 6e 65 63   "closing connec
01c0: 74 69 6f 6e 22 0a 09 72 65 74 75 72 6e 0a 20 20  tion"..return.  
01d0: 20 20 7d 0a 20 20 20 20 73 65 74 20 64 65 76 73    }.    set devs
01e0: 20 5b 62 6f 72 67 20 62 6c 75 65 74 6f 6f 74 68   [borg bluetooth
01f0: 20 64 65 76 69 63 65 73 5d 0a 20 20 20 20 73 65   devices].    se
0200: 74 20 63 64 65 76 20 5b 2e 74 6f 70 2e 62 74 6c  t cdev [.top.btl
0210: 69 73 74 20 67 65 74 5d 0a 20 20 20 20 73 65 74  ist get].    set
0220: 20 69 6e 64 65 78 20 30 0a 20 20 20 20 66 6f 72   index 0.    for
0230: 65 61 63 68 20 7b 61 64 64 72 20 6e 61 6d 65 7d  each {addr name}
0240: 20 24 64 65 76 73 20 7b 0a 09 69 66 20 7b 24 6e   $devs {..if {$n
0250: 61 6d 65 20 65 71 20 24 63 64 65 76 7d 20 7b 0a  ame eq $cdev} {.
0260: 09 20 20 20 20 73 65 74 20 66 6f 75 6e 64 20 24  .    set found $
0270: 61 64 64 72 0a 09 20 20 20 20 62 72 65 61 6b 0a  addr..    break.
0280: 09 7d 0a 09 69 6e 63 72 20 69 6e 64 65 78 0a 20  .}..incr index. 
0290: 20 20 20 7d 0a 20 20 20 20 73 65 74 20 6e 64 65     }.    set nde
02a0: 76 73 20 7b 7d 0a 20 20 20 20 66 6f 72 65 61 63  vs {}.    foreac
02b0: 68 20 7b 64 75 6d 6d 79 20 6e 61 6d 65 7d 20 24  h {dummy name} $
02c0: 64 65 76 73 20 7b 0a 09 6c 61 70 70 65 6e 64 20  devs {..lappend 
02d0: 6e 64 65 76 73 20 24 6e 61 6d 65 0a 20 20 20 20  ndevs $name.    
02e0: 7d 0a 20 20 20 20 2e 74 6f 70 2e 62 74 6c 69 73  }.    .top.btlis
02f0: 74 20 63 6f 6e 66 69 67 75 72 65 20 2d 76 61 6c  t configure -val
0300: 75 65 73 20 5b 6c 73 6f 72 74 20 2d 61 73 63 69  ues [lsort -asci
0310: 69 20 24 6e 64 65 76 73 5d 0a 20 20 20 20 69 66  i $ndevs].    if
0320: 20 7b 5b 69 6e 66 6f 20 65 78 69 73 74 73 20 66   {[info exists f
0330: 6f 75 6e 64 5d 7d 20 7b 0a 09 2e 74 6f 70 2e 62  ound]} {...top.b
0340: 74 6c 69 73 74 20 73 65 74 20 24 63 64 65 76 0a  tlist set $cdev.
0350: 09 69 66 20 7b 5b 63 61 74 63 68 20 7b 72 66 63  .if {[catch {rfc
0360: 6f 6d 6d 20 2d 61 73 79 6e 63 20 5b 6c 69 73 74  omm -async [list
0370: 20 24 66 6f 75 6e 64 20 24 3a 3a 75 75 69 64 5d   $found $::uuid]
0380: 20 30 7d 20 73 6f 63 6b 5d 7d 20 7b 0a 09 20 20   0} sock]} {..  
0390: 20 20 74 70 75 74 20 24 73 6f 63 6b 0a 09 7d 20    tput $sock..} 
03a0: 65 6c 73 65 20 7b 0a 09 20 20 20 20 74 70 75 74  else {..    tput
03b0: 20 22 63 6f 6e 6e 65 63 74 69 6e 67 20 74 6f 20   "connecting to 
03c0: 24 66 6f 75 6e 64 22 0a 09 20 20 20 20 2e 74 6f  $found"..    .to
03d0: 70 2e 63 6f 6e 6e 20 63 6f 6e 66 69 67 75 72 65  p.conn configure
03e0: 20 2d 74 65 78 74 20 44 69 73 63 6f 6e 6e 65 63   -text Disconnec
03f0: 74 0a 09 20 20 20 20 66 63 6f 6e 66 69 67 75 72  t..    fconfigur
0400: 65 20 24 73 6f 63 6b 20 2d 62 6c 6f 63 6b 69 6e  e $sock -blockin
0410: 67 20 30 20 2d 62 75 66 66 65 72 69 6e 67 20 6c  g 0 -buffering l
0420: 69 6e 65 0a 09 20 20 20 20 66 69 6c 65 65 76 65  ine..    fileeve
0430: 6e 74 20 24 73 6f 63 6b 20 72 65 61 64 61 62 6c  nt $sock readabl
0440: 65 20 5b 6c 69 73 74 20 72 65 63 65 69 76 65 20  e [list receive 
0450: 24 73 6f 63 6b 5d 0a 09 20 20 20 20 73 65 74 20  $sock]..    set 
0460: 3a 3a 74 78 73 6f 63 6b 20 24 73 6f 63 6b 0a 09  ::txsock $sock..
0470: 7d 0a 20 20 20 20 7d 0a 7d 0a 0a 70 72 6f 63 20  }.    }.}..proc 
0480: 72 65 63 65 69 76 65 20 7b 73 6f 63 6b 7d 20 7b  receive {sock} {
0490: 0a 20 20 20 20 69 66 20 7b 5b 63 61 74 63 68 20  .    if {[catch 
04a0: 7b 67 65 74 73 20 24 73 6f 63 6b 20 6c 69 6e 65  {gets $sock line
04b0: 7d 20 72 65 74 5d 7d 20 7b 0a 09 74 78 63 6c 6f  } ret]} {..txclo
04c0: 73 65 20 24 72 65 74 0a 09 72 65 74 75 72 6e 0a  se $ret..return.
04d0: 20 20 20 20 7d 0a 20 20 20 20 69 66 20 7b 24 72      }.    if {$r
04e0: 65 74 20 3c 20 30 7d 20 7b 0a 09 69 66 20 7b 5b  et < 0} {..if {[
04f0: 66 62 6c 6f 63 6b 65 64 20 24 73 6f 63 6b 5d 7d  fblocked $sock]}
0500: 20 7b 0a 09 20 20 20 20 72 65 74 75 72 6e 0a 09   {..    return..
0510: 7d 0a 09 74 78 63 6c 6f 73 65 20 22 63 6c 6f 73  }..txclose "clos
0520: 65 64 20 63 6f 6e 6e 65 63 74 69 6f 6e 22 0a 09  ed connection"..
0530: 72 65 74 75 72 6e 0a 20 20 20 20 7d 0a 20 20 20  return.    }.   
0540: 20 74 70 75 74 20 22 3c 3c 20 24 6c 69 6e 65 22   tput "<< $line"
0550: 0a 7d 0a 0a 70 72 6f 63 20 73 65 6e 64 20 7b 7d  .}..proc send {}
0560: 20 7b 0a 20 20 20 20 73 65 74 20 6c 69 6e 65 20   {.    set line 
0570: 5b 2e 73 65 6e 64 20 67 65 74 5d 0a 20 20 20 20  [.send get].    
0580: 69 66 20 7b 5b 69 6e 66 6f 20 65 78 69 73 74 73  if {[info exists
0590: 20 3a 3a 74 78 73 6f 63 6b 5d 7d 20 7b 0a 09 69   ::txsock]} {..i
05a0: 66 20 7b 5b 63 61 74 63 68 20 7b 70 75 74 73 20  f {[catch {puts 
05b0: 24 3a 3a 74 78 73 6f 63 6b 20 24 6c 69 6e 65 7d  $::txsock $line}
05c0: 5d 20 7c 7c 0a 09 20 20 20 20 5b 63 61 74 63 68  ] ||..    [catch
05d0: 20 7b 66 6c 75 73 68 20 24 3a 3a 74 78 73 6f 63   {flush $::txsoc
05e0: 6b 7d 5d 7d 20 7b 0a 09 20 20 20 20 74 78 63 6c  k}]} {..    txcl
05f0: 6f 73 65 20 22 77 72 69 74 65 20 65 72 72 6f 72  ose "write error
0600: 2c 20 63 6c 6f 73 69 6e 67 20 63 6f 6e 6e 65 63  , closing connec
0610: 74 69 6f 6e 22 0a 09 7d 20 65 6c 73 65 20 7b 0a  tion"..} else {.
0620: 09 20 20 20 20 74 70 75 74 20 22 3e 3e 20 24 6c  .    tput ">> $l
0630: 69 6e 65 22 0a 09 20 20 20 20 2e 73 65 6e 64 20  ine"..    .send 
0640: 64 65 6c 65 74 65 20 30 20 65 6e 64 0a 09 7d 0a  delete 0 end..}.
0650: 20 20 20 20 7d 0a 7d 0a 0a 70 72 6f 63 20 61 63      }.}..proc ac
0660: 63 65 70 74 20 7b 73 6f 63 6b 20 61 72 67 73 7d  cept {sock args}
0670: 20 7b 0a 20 20 20 20 74 78 63 6c 6f 73 65 20 22   {.    txclose "
0680: 63 6c 6f 73 69 6e 67 20 63 6f 6e 6e 65 63 74 69  closing connecti
0690: 6f 6e 22 0a 20 20 20 20 74 70 75 74 20 22 63 6f  on".    tput "co
06a0: 6e 6e 65 63 74 20 66 72 6f 6d 20 24 61 72 67 73  nnect from $args
06b0: 22 0a 20 20 20 20 66 63 6f 6e 66 69 67 75 72 65  ".    fconfigure
06c0: 20 24 73 6f 63 6b 20 2d 62 6c 6f 63 6b 69 6e 67   $sock -blocking
06d0: 20 30 20 2d 62 75 66 66 65 72 69 6e 67 20 6c 69   0 -buffering li
06e0: 6e 65 0a 20 20 20 20 66 69 6c 65 65 76 65 6e 74  ne.    fileevent
06f0: 20 24 73 6f 63 6b 20 72 65 61 64 61 62 6c 65 20   $sock readable 
0700: 5b 6c 69 73 74 20 72 65 63 65 69 76 65 20 24 73  [list receive $s
0710: 6f 63 6b 5d 0a 20 20 20 20 73 65 74 20 3a 3a 74  ock].    set ::t
0720: 78 73 6f 63 6b 20 24 73 6f 63 6b 0a 20 20 20 20  xsock $sock.    
0730: 2e 74 6f 70 2e 63 6f 6e 6e 20 63 6f 6e 66 69 67  .top.conn config
0740: 75 72 65 20 2d 74 65 78 74 20 44 69 73 63 6f 6e  ure -text Discon
0750: 6e 65 63 74 0a 7d 0a 0a 70 72 6f 63 20 74 78 63  nect.}..proc txc
0760: 6c 6f 73 65 20 7b 74 65 78 74 7d 20 7b 0a 20 20  lose {text} {.  
0770: 20 20 69 66 20 7b 5b 69 6e 66 6f 20 65 78 69 73    if {[info exis
0780: 74 73 20 3a 3a 74 78 73 6f 63 6b 5d 7d 20 7b 0a  ts ::txsock]} {.
0790: 09 63 61 74 63 68 20 7b 63 6c 6f 73 65 20 24 3a  .catch {close $:
07a0: 3a 74 78 73 6f 63 6b 7d 0a 09 75 6e 73 65 74 20  :txsock}..unset 
07b0: 3a 3a 74 78 73 6f 63 6b 0a 09 2e 74 6f 70 2e 63  ::txsock...top.c
07c0: 6f 6e 6e 20 63 6f 6e 66 69 67 75 72 65 20 2d 74  onn configure -t
07d0: 65 78 74 20 43 6f 6e 6e 65 63 74 0a 09 74 70 75  ext Connect..tpu
07e0: 74 20 24 74 65 78 74 0a 20 20 20 20 7d 0a 7d 0a  t $text.    }.}.
07f0: 0a 70 72 6f 63 20 62 74 73 74 61 74 20 7b 7d 20  .proc btstat {} 
0800: 7b 0a 20 20 20 20 69 66 20 7b 5b 62 6f 72 67 20  {.    if {[borg 
0810: 62 6c 75 65 74 6f 6f 74 68 20 73 74 61 74 65 5d  bluetooth state]
0820: 20 65 71 20 22 6f 6e 22 7d 20 7b 0a 09 69 66 20   eq "on"} {..if 
0830: 7b 21 5b 69 6e 66 6f 20 65 78 69 73 74 73 20 3a  {![info exists :
0840: 3a 73 72 76 73 6f 63 6b 5d 7d 20 7b 0a 09 20 20  :srvsock]} {..  
0850: 20 20 73 65 74 20 6d 79 61 64 64 72 20 5b 6c 69    set myaddr [li
0860: 73 74 20 24 3a 3a 75 75 69 64 20 42 54 2d 63 68  st $::uuid BT-ch
0870: 61 74 5d 0a 09 20 20 20 20 69 66 20 7b 5b 63 61  at]..    if {[ca
0880: 74 63 68 20 7b 72 66 63 6f 6d 6d 20 2d 73 65 72  tch {rfcomm -ser
0890: 76 65 72 20 61 63 63 65 70 74 20 2d 6d 79 61 64  ver accept -myad
08a0: 64 72 20 24 6d 79 61 64 64 72 20 30 7d 20 3a 3a  dr $myaddr 0} ::
08b0: 73 72 76 73 6f 63 6b 5d 7d 20 7b 0a 09 09 74 70  srvsock]} {...tp
08c0: 75 74 20 22 73 65 72 76 65 72 20 73 6f 63 6b 65  ut "server socke
08d0: 74 20 66 61 69 6c 65 64 3a 20 24 3a 3a 73 72 76  t failed: $::srv
08e0: 73 6f 63 6b 22 0a 09 09 75 6e 73 65 74 20 3a 3a  sock"...unset ::
08f0: 73 72 76 73 6f 63 6b 0a 09 20 20 20 20 7d 0a 09  srvsock..    }..
0900: 7d 0a 20 20 20 20 7d 20 65 6c 73 65 20 7b 0a 09  }.    } else {..
0910: 63 61 74 63 68 20 7b 63 6c 6f 73 65 20 24 3a 3a  catch {close $::
0920: 73 72 76 73 6f 63 6b 7d 0a 09 63 61 74 63 68 20  srvsock}..catch 
0930: 7b 75 6e 73 65 74 20 3a 3a 73 72 76 73 6f 63 6b  {unset ::srvsock
0940: 7d 0a 09 74 78 63 6c 6f 73 65 20 22 42 6c 75 65  }..txclose "Blue
0950: 74 6f 6f 74 68 20 64 69 73 61 62 6c 65 64 2c 20  tooth disabled, 
0960: 63 6c 6f 73 69 6e 67 20 63 6f 6e 6e 65 63 74 69  closing connecti
0970: 6f 6e 22 0a 20 20 20 20 7d 0a 7d 0a 0a 77 6d 20  on".    }.}..wm 
0980: 61 74 74 72 69 62 75 74 65 73 20 2e 20 2d 66 75  attributes . -fu
0990: 6c 6c 73 63 72 65 65 6e 20 31 0a 62 69 6e 64 20  llscreen 1.bind 
09a0: 61 6c 6c 20 3c 4b 65 79 2d 42 72 65 61 6b 3e 20  all <Key-Break> 
09b0: 65 78 69 74 0a 62 69 6e 64 20 2e 20 3c 3c 42 6c  exit.bind . <<Bl
09c0: 75 65 74 6f 6f 74 68 3e 3e 20 62 74 73 74 61 74  uetooth>> btstat
09d0: 0a 66 72 61 6d 65 20 2e 74 6f 70 0a 3a 3a 74 74  .frame .top.::tt
09e0: 6b 3a 3a 63 6f 6d 62 6f 62 6f 78 20 2e 74 6f 70  k::combobox .top
09f0: 2e 62 74 6c 69 73 74 20 2d 73 74 61 74 65 20 72  .btlist -state r
0a00: 65 61 64 6f 6e 6c 79 0a 62 75 74 74 6f 6e 20 2e  eadonly.button .
0a10: 74 6f 70 2e 63 6f 6e 6e 20 2d 74 65 78 74 20 43  top.conn -text C
0a20: 6f 6e 6e 65 63 74 20 2d 77 69 64 74 68 20 31 32  onnect -width 12
0a30: 20 2d 63 6f 6d 6d 61 6e 64 20 63 6f 6e 6e 65 63   -command connec
0a40: 74 0a 70 61 63 6b 20 2e 74 6f 70 20 2d 73 69 64  t.pack .top -sid
0a50: 65 20 74 6f 70 20 2d 66 69 6c 6c 20 78 0a 70 61  e top -fill x.pa
0a60: 63 6b 20 2e 74 6f 70 2e 63 6f 6e 6e 20 2d 73 69  ck .top.conn -si
0a70: 64 65 20 6c 65 66 74 20 2d 70 61 64 78 20 31 30  de left -padx 10
0a80: 20 2d 70 61 64 79 20 31 30 0a 70 61 63 6b 20 2e   -pady 10.pack .
0a90: 74 6f 70 2e 62 74 6c 69 73 74 20 2d 73 69 64 65  top.btlist -side
0aa0: 20 6c 65 66 74 20 2d 66 69 6c 6c 20 78 20 2d 65   left -fill x -e
0ab0: 78 70 61 6e 64 20 31 20 2d 70 61 64 78 20 31 30  xpand 1 -padx 10
0ac0: 20 2d 70 61 64 79 20 31 30 0a 0a 3a 3a 74 74 6b   -pady 10..::ttk
0ad0: 3a 3a 65 6e 74 72 79 20 2e 73 65 6e 64 0a 70 61  ::entry .send.pa
0ae0: 63 6b 20 2e 73 65 6e 64 20 2d 73 69 64 65 20 74  ck .send -side t
0af0: 6f 70 20 2d 66 69 6c 6c 20 78 20 2d 70 61 64 78  op -fill x -padx
0b00: 20 31 30 20 2d 70 61 64 79 20 31 30 0a 62 69 6e   10 -pady 10.bin
0b10: 64 20 2e 73 65 6e 64 20 3c 52 65 74 75 72 6e 3e  d .send <Return>
0b20: 20 73 65 6e 64 0a 0a 74 65 78 74 20 2e 74 65 78   send..text .tex
0b30: 74 20 2d 73 74 61 74 65 20 64 69 73 61 62 6c 65  t -state disable
0b40: 64 0a 70 61 63 6b 20 2e 74 65 78 74 20 2d 73 69  d.pack .text -si
0b50: 64 65 20 74 6f 70 20 2d 66 69 6c 6c 20 62 6f 74  de top -fill bot
0b60: 68 20 2d 65 78 70 61 6e 64 20 31 20 2d 70 61 64  h -expand 1 -pad
0b70: 78 20 31 30 20 2d 70 61 64 79 20 31 30 0a 62 69  x 10 -pady 10.bi
0b80: 6e 64 20 2e 74 65 78 74 20 3c 44 6f 75 62 6c 65  nd .text <Double
0b90: 2d 31 3e 20 74 63 6c 65 61 72 0a 0a 61 66 74 65  -1> tclear..afte
0ba0: 72 20 69 64 6c 65 20 62 74 73 74 61 74 0a 61 66  r idle btstat.af
0bb0: 74 65 72 20 69 64 6c 65 20 63 6f 6e 6e 65 63 74  ter idle connect
0bc0: 0a                                               .