[Anton Kovalenko]: 
OBEX is a shorthand for IrDA OBject EXchange protocol. Here is an implementation of OBEX client/server, pure tclish. It needs my [infrared] extension to work with IrDA stack, and, in case of tcl 8.4, [forward-compatible dict].

There may be a lot of bad things to say about this package. It doesn't include any manual, it uses its own ad-hoc [OOP] ([SNIT] would be more reasonable here). I don't have any spare time to polish it now. This extension may be useful for someone as a starting point for a nice OBEX package.


    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 $sock

'''OBEX 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 forever