package require base64
namespace eval OBEX {
namespace eval _utils {
variable DEBUG 1
if {$DEBUG} {
proc DEBUG {str} {
puts [uplevel 1 [list subst $str]]
}
} else {proc DEBUG {str} {}}
interp alias {} [namespace current]::lpfn {} namespace which
proc to_short {var} {
upvar 1 $var v
set v [expr {$v & 0xFFFF}]
return $v
}
proc to_byte {var} {
upvar 1 $var v
set v [expr {$v & 0xFF}]
return $v
}
proc to_hex {var} {
upvar 1 $var v
set v [format 0x%02X [expr {$v & 0xFF}] ]
return $v
}
variable HDRS [dict create \
count 0xC0 \
name 0x01 \
type 0x42 \
length 0xC3 \
timestamp 0x44 \
timestamp-4 0xC4 \
description 0x05 \
target 0x46 \
http 0x47 \
body 0x48 \
eob 0x49 \
who 0x4A \
connection-id 0xCB \
parameters 0x4C \
auth-challenge 0x4D \
auth-response 0x4E \
creator-id 0xCF \
wan-uuid 0x50 \
object-class 0x51 \
session-parameters 0x52 \
session-sequence-number 0x93 ]
dict for {k v} $HDRS {dict set rvHDRS [expr {$v}] $k}
variable OPCODES [dict create \
connect 0x80 \
disconnect 0x81 \
put 0x02 \
get 0x03 \
put-final 0x82 \
get-final 0x83 \
chdir 0x85 ]
dict for {k v} $OPCODES {dict set rvOPCODES [expr {$v}] $k}
proc gethid {hdr} {
variable HDRS
if {![string is integer $hdr]} {
return [dict get $HDRS $hdr]
}
return $hdr
}
proc getopname {id} {
variable rvOPCODES
to_byte id
if {[dict exists $rvOPCODES $id]} {
return [dict get $rvOPCODES $id]
}
return $id
}
proc gethname {id} {
variable rvHDRS
to_byte id
if {[dict exists $rvHDRS $id ]} {
return [dict get $rvHDRS $id]
}
return $id
}
if {[string equal $::tcl_platform(byteOrder) littleEndian]} {
proc brev {str} {
set r {}
foreach {b1 b2} [split $str {}] {
append r $b2 $b1
}
return $r
}
} else {
proc brev {str} {set str}
}
proc ctounicode {str} {
return [brev [encoding convertto unicode $str] ]
}
proc cfromunicode {str} {
return [encoding convertfrom unicode [brev $str] ]
}
# Formatting header for transmission
proc fh {hdr hdata} {
DEBUG {Fh: $hdr , $hdata}
set hval [gethid $hdr]
set htype [expr {($hval & 0xC0)>>6}]
set r [binary format c $hval]
switch $htype {
0 {
set cbin [ctounicode $hdata]
append cbin [binary format x2]
append r [binary format S [
expr {[string length $cbin]+3}]] $cbin
}
1 {
append r [binary format S [
expr {[string length $hdata]+3}]] $hdata
}
2 {
append r [binary format c $hdata]
}
3 {
append r [binary format I $hdata]
}
}
return $r
}
proc fhs {args} {
flattenargs
set data {}
foreach {h v} $args { append data [fh $h $v] }
return $data
}
# convert headers from binary form to keyed-list
proc parse_headers {data} {
set r [list]
while {[string length $data]} {
binary scan $data c hval
switch [expr {($hval & 0xC0)>>6}] {
0 {
binary scan $data cS byte length
to_short length
set utext [string range $data 3 [expr {$length - 3}] ]
set v [cfromunicode $utext]
set drop $length
}
1 {
binary scan $data cS byte length
to_short length
set v [string range $data 3 [expr {$length - 1}]]
set drop $length
}
2 {
binary scan $data cc byte quantity
set v [to_byte quantity]
set drop 2
}
3 {
binary scan $data cI byte quantity
set v $quantity
set drop 5
}
}
dict set r [gethname [to_byte hval]] $v
set data [string range $data $drop end]
}
return $r
}
# format an operation
proc fop {opcode data} {
set r [binary format c $opcode]
append r [binary format S [expr {[string length $data]+3}]]
append r $data
return $r
}
proc flattenargs {} {
upvar 1 args _args
set limit 200
while {[llength $_args]%2} {
if {![incr limit -1]} {
return -code error "Too many levels"
}
set _args [concat [lindex $_args 0] [lreplace $_args 0 0] ]
}
return
}
proc f_connect {args} {
# OBEX 1.0, Flags=0, MRU=8k
flattenargs
return \
[fop 0x80 [binary format ccSa* 0x10 0x00 0x4000 [fhs $args] ] ]
}
proc fr_connect {args} {
flattenargs
return \
[fop 0xA0 [ binary format ccSa* 0x10 0x00 0x4000 [fhs $args] ] ]
}
proc f_generic {opc args} {
variable OPCODES
flattenargs
DEBUG {Fg: $opc,$args}
if {[dict exists $OPCODES $opc ]} {
set opc [dict get $OPCODES $opc]
}
return [fop $opc [fhs $args]]
}
proc fr_generic {opc args} {
flattenargs
return [fop $opc [fhs $args]]
}
proc f_setpath {flags args} {
flattenargs
dict set flagbits up 1 nocreate 2
set fb 0
foreach flag $flags {
incr fb [dict get $flabgits $flag]
}
return [fop 0x85 [binary format cca* $fb 0 [fhs $args]]]
}
variable buffer [dict create]
proc packet_splitter {fh handler} {
variable buffer
if {[catch {read $fh} data]||[eof $fh]} {
fileevent $fh readable {}
DEBUG {Unwinding...}
# close $fh
dict unset buffer $fh
after idle $handler [list {}]
return
}
dict append buffer $fh $data
set input [dict get $buffer $fh]
if {[binary scan $input cS opcode length]!=2} {
DEBUG {Not even 3 bytes...}
return
}
to_short length
DEBUG {Length $length...}
if {[string length $input]>=$length} {
DEBUG {Yeah! data is here...}
after idle $handler \
[list [ string range $input 0 [expr {$length-1}]] ]
dict set buffer $fh [string range $input $length end]
}
}
proc packet_parse_request {str} {
binary scan $str cS resp length
to_byte resp
to_short length
if {$resp==0x80} {
binary scan $str cSccS _ _ version flags mtu
set data [parse_headers [string range $str 7 end]]
lappend data MTU $mtu
} elseif {$resp==0x85} {
binary scan $str cScc _ _ flags _
set data [parse_headers [string range $str 5 end]]
lappend data UP [expr {$flags&1}] NOCREATE [expr {$flags&2!=0}]
} else {
set data [parse_headers [string range $str 3 end]]
}
return [list [getopname $resp] $data]
}
proc put {fh data} {
puts -nonewline $fh $data
flush $fh
}
namespace export *
}
namespace eval server {
# OBEX::server uses the ad-hoc oop
# OBEX::server::Class MyServer {Push}
namespace import [namespace parent]::_utils::*
namespace export \[A-Z\]*
# Accept --
# Pass the socket to the OBEX::server
proc Accept {fh {class Default} args} {
variable state
dict set state $fh [dict create]
dict set state $fh mtu 255
dict set state $fh class $class
set incoming [lpfn incoming]
fconfigure $fh -translation binary -blocking no
fileevent $fh readable \
[ list [lpfn packet_splitter] $fh [list $incoming $fh] ]
callback $class Init $fh $args
}
proc callback {class method instance args} {
variable hooks
variable state
dict set state thisclass $class
dict set state this $instance
if {[dict exists $hooks $class $method]} {
set r [uplevel #0 [dict get $hooks $class $method] $args]
return $r
}
return
}
proc _method {{ivar {}}} {
variable state
upvar 1 args args this this thisclass thisclass
set this [dict get $state this]
set thisclass [dict get $state thisclass]
flattenargs
uplevel 1 [list upvar #0 ::OBEX::server::IV:$this $ivar]
}
proc Method {name body} {
variable hooks
set upns [uplevel 1 {namespace current}]
DEBUG {method $upns $name}
if {[string match ::OBEX::server::cls* $upns]} {
DEBUG {$upns $name is inline}
dict set hooks [namespace tail $upns] $name ${upns}::$name
}
uplevel 1 [
list proc $name args "[lpfn _method];$body"
]
}
proc Call {method args} {
variable state
upvar 1 this this thisclass thisclass
callback $thisclass $method $this $args
}
proc Class {name inhlist map} {
variable hooks
dict set hooks $name [dict create]
foreach super $inhlist {
dict for {k v} [dict get $hooks $super] {
dict set hooks $name $k $v
}
}
if {[llength $map]==1} {
# Auto-binding commands
if {![string equal [namespace current] \
[uplevel 1 {namespace current}]]} {
uplevel 1 [
list namespace import \
[namespace current]::arg: \
[namespace current]::\[A-Z\]*
]
}
set map [uplevel 1 {namespace current}]::$map
set len [string length $map]
DEBUG {Using $map for defining $name}
DEBUG {having [info commands ${map}*]}
foreach command [info commands ${map}*] {
dict set hooks $name [string range $command $len end] \
$command
}
} else {
namespace eval cls::$name \
[ list namespace import \
[namespace current]::arg: \
[namespace current]::\[A-Z\]*
]
namespace eval cls::$name $map
}
}
proc arg: {key {dv {}}} {
upvar 1 args args
if {[dict exists $args $key]} {
return [dict get $args $key]
} else {
return $dv
}
}
namespace export arg:
proc incoming {fh packet} {
variable state
set class [dict get $state $fh class]
DEBUG {Got packet of length [string length $packet]}
if {![string length $packet]} {
DEBUG {Zero-length packet!}
callback $class Destroy $fh
catch {close $fh}
dict unset state $fh
return
}
set data {}
set resp {}
foreach {resp data} [packet_parse_request $packet] {break}
set hs {}
set rc 0xD0
foreach {rc hs} [callback $class OBEX.$resp $fh $data] {
break
}
DEBUG {About to respond with $rc $hs}
if {[string equal $resp connect]} {
put $fh [fr_connect $hs]
} else {
put $fh [fr_generic $rc $hs]
}
}
# Now let's specify default server...
Method Default.Result.Ok {
return [list 0xA0 ""]
}
Method Default.Result.Error {
return [list 0xD0 ""]
}
Method Default.Result.Continue {
return [list 0x90 ""]
}
Method Default.Result.NotFound {
return [list 0xC4 ""]
}
Method Default.OBEX.connect {
Call SendSuccess
}
Method Default.OBEX.put-final {
foreach {h v} $args {dict set (properties) $h $v}
set (properties) [dict remove $(properties) body eob]
append (body) [arg: body] [arg: eob]
set err [catch {Call Received $(properties) body $(body)} msg]
unset (body)
if {!$err} {
return [Call Result.Ok]
} else {
if {![string length $msg ]} {
return [Call Result.Error]
} else {
return [lindex $msg 0]
}
}
}
Method Default.OBEX.chdir {
Call Result.Continue
}
Method Default.OBEX.get-final {
Call Result.NotFound
}
Method Default.OBEX.get {
Call Result.Continue
}
Method Default.OBEX.put {
foreach {h v} $args {dict set (properties) $h $v}
Call Result.Continue
}
Method Default.OBEX.disconnect {
Call Result.Ok
}
Method Default.Received {
DEBUG {-----------------Received file:}
DEBUG {[arg: body]}
DEBUG {Properties: $(properties)}
}
Class Default {} Default.
Class Push {Default} {
Method Init {
set (options) $args
}
Method Received {
uplevel #0 [list [
dict get $(options) -reader] [arg: name] [arg: body]]
}
}
}
namespace eval client {
namespace import [namespace parent]::_utils::*
# 1. the initial state of socket is idle
# 2. when the client sends async request,
# then it's appended to the socket's queue
# 3. if the queue was empty then queuerunner
# is scheduled [after idle].
# -------------
# The queue element is a list of:
variable state [dict create]
proc Acquire {fh} {
variable state
dict set state $fh [dict create]
dict set state $fh mtu 255
dict set state $fh queue [list]
dict set state $fh qtail 0
dict set state $fh qhead 0
fconfigure $fh -blocking no -translation binary
set incoming [lpfn incoming]
fileevent $fh readable \
[list [lpfn packet_splitter] $fh [list $incoming $fh]]
}
proc qpop {fh} {
variable state
set qhead [dict get $state $fh qhead]
incr qhead
dict set state $fh qhead $qhead
dict set state $fh queue \
[lreplace [dict get $state $fh queue] 0 0]
}
proc qhead {fh args} {
variable state
if {[llength $args]} {
dict set state $fh queue \
[lreplace [dict get $state $fh queue] \
0 0 [lindex $args 0]]
} else {
return [lindex [dict get $state $fh queue] 0]
}
}
proc qptr {ptr fh} {
variable state
switch -exact $ptr {
head {return [dict get $state $fh qhead]}
tail {return [dict get $state $fh qtail]}
}
}
proc qpush {fh data} {
variable state
set qtail [dict get $state $fh qtail]
set quid $qtail
incr qtail
dict set state $fh qtail $qtail
set q [dict get $state $fh queue]
lappend q $data
dict set state $fh queue $q
return $quid
}
proc qlength {fh} {
variable state
return [ llength [ dict get $state $fh queue ] ]
}
proc incoming {fh packet} {
variable state
variable callbacks
variable results
if {![string length $packet ]} {
dict unset state $fh
array unset results $fh,*
array unset callbacks $fh,*
close $fh
return
}
foreach thisop [dict get $state $fh queue] {break}
if {![info exists thisop]} {return}
binary scan $packet cSa* resp _ data
to_byte resp
DEBUG {$resp packet}
set result [eval $thisop [list $fh $resp $data]]
set qh [qptr head $fh]
if {$resp!=0x90} {
DEBUG {Non-intermediate packet $resp}
if {[info exists callbacks($fh,$qh)]} {
DEBUG {Calling back}
after idle $callbacks($fh,$qh) $result
unset callbacks($fh,$qh)
} else {
DEBUG {Setting results $fh,$qh}
set results($fh,$qh) $result
}
qpop $fh
after idle [list [lpfn qrunner] $fh]
} else {
qhead $fh $result
}
}
proc qrunner {fh} {
variable state
if {![qlength $fh]} { return }
qhead $fh [eval [qhead $fh] [list $fh 000 ""]]
}
proc runq {fh} {
if {![qlength $fh]} {
after idle [list [lpfn qrunner] $fh]
}
}
proc schedule {fh script cb} {
variable results
variable callbacks
set id [qpush $fh $script]
if {![string length $cb]} {
DEBUG {Will wait $fh,$id}
set results($fh,$id) {}
vwait OBEX::client::results($fh,$id)
set r $results($fh,$id)
unset results($fh,$id)
} else {
DEBUG {Will not wait: $cb}
set callbacks($fh,$id) $cb
set r $id
}
return $r
}
proc Connect {fh headers {cb {}}} {
variable state
runq $fh
schedule $fh [list do_connect $headers] $cb
}
proc do_connect {headers fh code data} {
variable state
DEBUG {do_connect $headers}
put $fh [f_connect $headers]
return do_connect_confirm
}
proc do_connect_confirm {fh code data} {
variable state
binary scan data ccSa* ver flags mtu rest
to_short mtu
dict set state $fh mtu $mtu
return [parse_headers $rest]
}
proc GetFile {fh headers {cb {}}} {
runq $fh
schedule $fh [list do_get $headers] $cb
}
proc do_get {headers fh code data} {
variable state
variable bodies
DEBUG {do_get $headers $code}
if {$code} {
array set gh [parse_headers $data]
if {[info exists gh(body)]} {
dict append bodies $fh $gh(body)
}
if {[info exists gh(eob)]} {
dict append bodies $fh $gh(eob)
}
if {$code != 0x90} {
set r {}
if {[dict exists $bodies $fh]} {
set r [dict get $bodies $fh]
dict unset bodies $fh
}
return $r
}
}
set limit [dict get $state $fh mtu ]
incr limit -3
set chunk {}
set op get-final
foreach {h v} $headers {
set piece [fh $h $v]
incr limit -[string length $piece]
if {$limit<0} { set op get; break }
lappend chunk $h $v
set headers [lreplace $headers 0 1]
}
put $fh [f_generic $op $chunk]
return [list do_get $headers]
}
proc PutFile {fh headers body {cb {}}} {
runq $fh
schedule $fh [list do_put $headers $body] $cb
}
proc do_put {headers body fh code data} {
variable state
DEBUG {do_put $headers $code}
if {($code) && ($code!=0x90) } {
return [parse_headers $data]
}
set limit [dict get $state $fh mtu ]
incr limit -3
set chunk {}
set op put
set bh body
foreach {h v} $headers {
set piece [fh $h $v]
incr limit -[string length $piece]
if {$limit<0} { break }
lappend chunk $h $v
set headers [lreplace $headers 0 1]
}
incr limit -3
if {$limit>0} {
set bchunk [string range $body 0 [expr {$limit-1}]]
set body [string range $body $limit end]
if {![string length $body]} {
set op put-final
set bh eob
}
}
put $fh [f_generic $op $chunk]
return [list do_put $headers $body]
}
proc Disconnect {fh headers {cb {}}} {
runq $fh
schedule $fh [list do_disconnect $headers] $cb
}
proc do_disconnect {headers fh code data} {
if {$code} { return }
put $fh [f_generic disconnect $headers]
return {do_disconnect {}}
}
}
}And a couple of examples.OBEX client
# OBEX client
# given a mobile phone with IrMC sync support, retrieves the phonebook.
package require irdasock
proc OBEXtest {fh} {
OBEX::client::Acquire $fh
set r [OBEX::client::Connect $fh {target IRMC-SYNC} ]
puts "Connected(hdrs=$r)."
set pb [OBEX::client::GetFile $fh {name telecom/pb.vcf target IRMC-SYNC} ]
puts "Got File "
puts $pb
set fd [open card.vcf w]
puts -nonewline $fd $pb
close $fd
OBEX::client::Disconnect $fh {target IRMC-SYNC}
}
set dev {}
puts "Waiting for some device to be plugged..."
while {$dev eq ""} {
catch {
set dev [lindex [set devs [irda::discover]] 0 0]
}
after 1000
}
foreach {id name hints} [lindex $devs 0] {break}
puts "Device $name ([format 0x%08x $id]): $hints"
set sock [irda::connect $dev IrDA:OBEX]
fconfigure $sock -translation binary
ODBCtest $sockOBEX server
package require irdasock
irda::server IrDA:OBEX ConnectMe
proc ConnectMe {sock id} {
puts "Passing socket to server..."
OBEX::server::Accept $sock Push -reader RecvFile
return
fconfigure $sock -translation binary
foreach dev [irda::discover] {
foreach {did name hints} $dev {
if {$did==$id} {
puts "OBEX connection from $name"
break
}
}
}
foreach {ch cr} [pget $sock] {break}
puts "First operation is $ch"
puts [OBEX::parse_headers [string range $cr 4 end]]
}
proc RecvFile {name body} {
puts "Received $name, body:\n$body\n"
}
vwait foreverSee OBEXTool.
