****A Tcl binding to OPC/UA****

OPC Unified Architecture (OPC UA) is a machine to machine communication protocol for industrial automation developed by the OPC Foundation. Refer to https://en.wikipedia.org/wiki/OPC_Unified_Architecture for a detailed overview.
 
A proof-of-concept extension called '''topcua''' provides a Tcl binding to a C based OPC UA implementation from https://open62541.org/ and can be found in https://www.androwish.org/index.html/dir?name=jni/topcua

The documentation can be found in https://www.androwish.org/index.html/wiki?name=topcua

The code is very portable and might run on all Tcl supported platforms provided that the platform's C compiler supports C99.

****A short example script****

The source tree contains an example script implementing an OPC/UA server providing a webcam in a few lines of code. The most interesting piece is how variables/data/things can be mapped between Tcl and OPC/UA domains as shown in the '''_lastimg''' and '''_setparm''' procedures and how the corresponding items in the OPC/UA address space are created in the '''opcua add ...''' invocations. This allows to connect from an OPC/UA client tool like https://www.unified-automation.com/products/development-tools/uaexpert.html%|%UAExpert%|% or https://www.prosysopc.com/products/opc-ua-client%|%OPC UA Client%|% and to display the camera image. 

But be aware that this is early alpha quality stuff and may contain memory leaks and all other kinds of serious bugs. Although it might seem to be some kind of Tcl dream in Industry 4.0 and to have the theoretical capability of controlling drilling rigs, nuclear power plants, low earth orbital stations, and so on it is far from being complete, tested, verified, and certified.

======
# A little OPC/UA webcam server in about 100 LOC
#
# Requires Linux, MacOSX, or FreeBSD, due to tcluvc support,
# but can be easily modified for Windows to use tclwmf instead.

package require Tk
package require topcua
package require tcluvc

# hide Tk toplevel
wm withdraw .

# get first available camera
set cam [lindex [uvc devices] 0]
if {$cam eq {}} {
    puts stderr "no camera found"
    exit 1
}

# open camera
if {[catch {uvc open $cam capture} cam]} {
    puts stderr "open failed: $cam"
    exit 1
}

# set format to 320x240
foreach {i fmt} [uvc listformats $cam] {
    if {[dict get $fmt "frame-size"] eq "320x240"} {
        uvc format $cam $i 1
        break
    }
}

# photo image for capture
set img [image create photo]

# image capture callback
proc capture {cam} {
    # limit frame rate, otherwise it consumes too much CPU for
    # image processing and the OPC/UA server part starves
    lassign [uvc counters $cam] all done dropped
    if {$all % 20 == 0} {
        uvc image $cam $::img
        set ::png [$::img data -format png]
    }
}

# create OPC/UA server
opcua new server 4840 S

# implementation of OPC/UA data sources
namespace eval ::opcua::S {
    # data source callback
    proc _lastimg {node op {value {}}} {
        if {$op eq "read"} {
            return [list ByteString $::png]
        }
        # hey, this is a camera, not a screen
        return -code error "write shouldn't happen"
    }
    # data source callback
    proc _setparm {name node op {value {}}} {
        if {$op eq "read"} {
            array set p [uvc parameter $::cam]
            set v 0
            if {[info exists p($name)]} {
                set v $p($name)
            }
            return [list Int32 $v]
        }
        set v [dict get $value "value"]
        catch {uvc parameter $::cam $name $v}
        return {}
    }
}

# create our namespace in OPC/UA land
set ns [opcua add S Namespace LilWebCam]

# get Objects folder
set OF [lindex [opcua translate S [opcua root] / Objects] 0]

# create an object in our namespace in Objects folder
set obj [opcua add S Object "ns=$ns;s=LilWebCam" $OF Organizes "$ns:LilWebCam"]

# create some variables in our folder to deal with camera settings
set att [opcua attrs default VariableAttributes]
dict set att dataType [opcua types nodeid Int32]
dict set att accessLevel 3        ;# writable
foreach name {brightness contrast gain gamma hue saturation} {
    opcua add S Variable "ns=$ns;s=[string totitle $name]" $obj HasComponent "$ns:[string totitle $name]" {} $att [list ::opcua::S::_setparm $name]
}

# get node identifier of Image data type, a subtype of ByteString
set IT [lindex [opcua translate S [opcua root] / Types / DataTypes / BaseDataType / ByteString / Image] 0]

# create variable in our folder to return last photo image
set att [opcua attrs default VariableAttributes]
dict set att dataType $IT        ;# Image data type
dict set att valueRank -1        ;# 1-dimensional array
opcua add S Variable "ns=$ns;s=Image" $obj HasComponent "$ns:Image" {} $att ::opcua::S::_lastimg

# start server using Tk's event loop
opcua start S

# start camera
uvc start $cam 
======

****The client for the short example script****

For the above webcam (the OPC/UA server) a corresponding OPC/UA client can be found in the source tree, too.

======
# A little OPC/UA webcam client example
package require Tk
package require topcua

wm title . "Client of LilWebCam"
set img [image create photo]
label .label -image $img
pack .label

# create client
opcua new client C

# connect to server
opcua connect C opc.tcp://localhost:4840

# get the namespace
set ns [opcua namespace C LilWebCam]

# monitor callback proc
proc monitor {data} {
    $::img configure -format png -data [dict get $data value]
}

# make a subscription with 200 ms rate
set sub [opcua subscription C new 1 200.0]

# make a monitor to the camera image
set mon [opcua monitor C new $sub data monitor "ns=${ns};Image"]

# handle OPC/UA traffic (the subscription/monitor)
proc do_opcua_traffic {} {
    after cancel do_opcua_traffic
    if {[catch {opcua run C 20}]} {
        # this most likely is the server shutting down
        exit
    }
    after 200 do_opcua_traffic
}

do_opcua_traffic
======

****Custom Data Types****

It is possible to define custom data types in the form of data structures and enumerations while the current '''topcua''' extension currently allows only the former. A data structure is expressed as specific nodes in the OPC/UA address space and communicated to the outside world as so called extension object. In order for a generic client to interpret an extension object, a description for (de)serialization is stored as an XML string in another node in the OPC/UA address space. The process of definition of structures and serialization is performed with the '''opcua deftypes''' (structure definition) and '''opcua gentypes''' (generation of supplementary information) subcommands as shown in this example.

======
package require topcua

# create server
opcua new server 4840 S

# create our namespace
set NS http://www.androwish.org/TestNS/
set nsidx [opcua add S Namespace $NS]

# create structs
opcua deftypes S $NS {
    struct KVPair {
        String name
        String value
    }
    struct RGB {
        UInt16 red
        UInt16 green
        UInt16 blue
    }
    struct NamedColor {
        String name
        RGB color
    }
}

# import type defs
opcua gentypes S

# make some variables using the structs from above
set OF [lindex [opcua translate S [opcua root] / Objects] 0]
foreach {name type} {
    X1 KVPair
    X2 RGB
    X3 NamedColor
} {
    set att [opcua attrs default VariableAttributes]
    dict set att dataType [opcua types nodeid S $type]
    dict set att value [list $type [opcua types empty S $type]]
    opcua add S Variable "ns=${nsidx};s=$name" $OF Organizes "${nsidx}:$name" {} $att
}

# start server
opcua start S

# enter event loop
vwait forever
======

****Map OPC/UA Variables To Files Using tcl-fuse****

The following example script uses [tcl-fuse] to read-only map OPC/UA variables to files. The path names within the fuse file system are derived from the browse paths of the variables in the OPC/UA address space.

======
package require topcua
package require fuse

# Names and global variables
#
#  mountpoint   - mountpoint, native directory name
#  url          - OPCUA url to connect to
#  verbose      - flag controlling log output
#  C            - OPCUA client (name, not variable)
#  FS           - fuse filesystem object (name, not variable)
#  T            - array indexed by brpath, values are { nodeid clspath }
#  R            - reverse of T, indexed by nodeid, values are brpath
#  D            - data cache, array indexed by nodeid, values are OPCUA variable Value attributes
#  M            - timestamp of elements in D
#  U            - use (= open) count of elements in D

# Preparation

set mountpoint [lindex $argv 0]
if {$mountpoint eq ""} {
    puts stderr "no mountpoint given"
    exit 1
}
if {![file isdirectory $mountpoint]} {
    puts stderr "invalid mountpoint"
    exit 1
}
set url [lindex $argv 1]
if {$url eq ""} {
    set url opc.tcp://localhost:4840
}
set verbose 0
scan [lindex $argv 2] "%d" verbose

# Logging

proc log {msg} {
    if {$::verbose} {
        set ts [clock format [clock seconds] -format "%Y-%m-%d %H:%M:%S"]
        puts stderr "${ts}: $msg"
    }
}

# OPCUA connect and retrieve tree into variable ::T, key is browse path, value a list of node ID and
# class path, thus variables can be identified with the pattern "*/Variable" on the class path.
# Variable ::R is for reverse mapping node ID to browse path. Namespace prefixes are stripped
# from browse paths, as long as they are unique among the entire address space.

log "starting up"
opcua new client C
log "connecting to $url"
opcua connect C $url
log "connected"

# Fetch custom types, if any

catch {opcua gentypes C}
log "fetched types, if any"

apply {tree {
    foreach {brpath nodeid clspath refid typeid} $tree {
        set short $brpath
        regsub -all -- {/[1-9][0-9]*:} $short {/} short
        incr t($short)
    }
    foreach {brpath nodeid clspath refid typeid} $tree {
        set short $brpath
        regsub -all -- {/[1-9][0-9]*:} $short {/} short
        if {$t($short) == 1} {
            set brpath $short
        }
        set ::T($brpath) [list $nodeid $clspath]
        set ::R($nodeid) $brpath
    }
}} [opcua ptree C]
log "fetched tree"

# Fuse entry points; the "fs_getattr" function fills a cache when an OPCUA variable is referenced.
# Other functions work with cached entries later.

proc fs_getattr {context path} {
    log "getattr $path"
    if {$path eq "/"} {
        return [dict create type directory mode 0755 nlinks 2]
    }
    if {[info exists ::T($path)]} {
        lassign $::T($path) nodeid clspath
        if {[string match "*/Variable" $clspath]} {
            set now [clock seconds]
            # Fetch Value attribute into cache, if cache entry doesn't
            # exist at all, or is not open and older than 10 seconds.
            if {![info exists ::D($nodeid)] ||
                ($::U($nodeid) <= 0 && $now - $::M($nodeid) >= 10)} {
                log "refresh $path"
                if {[catch {set ::D($nodeid) [opcua read C $nodeid]}]} {
                    return -code error -errorcode [list POSIX EIO {}]
                }
                set ::M($nodeid) $now
                set ::U($nodeid) 0
            }
            return [dict create mode 0666 nlinks 1 \
                        mtime $::M($nodeid) \
                        size [string length $::D($nodeid)]]
        }
        return [dict create type directory mode 0755 nlinks 2]
    }
    return -code error -errorcode [list POSIX ENOENT {}]
}

proc fs_open {context path fileinfo} {
    log "open $path"
    if {[info exists ::T($path)]} {
        lassign $::T($path) nodeid clspath
        if {[string match "*/Variable" $clspath]} {
            # Cached Value attribute must exist
            if {"RDONLY" ni [dict get $fileinfo flags] ||
                ![info exists ::D($nodeid)]} {
                return -code error -errorcode [list POSIX EACCES {}]
            }
            # Success, increment use counter and return empty result.
            incr ::U($nodeid)
            return
        }
        return -code error -errorcode [list POSIX EACCES {}]
    }
    return -code error -errorcode [list POSIX ENOENT {}]
}

proc fs_readdir {context path fileinfo} {
    log "readdir $path"
    if {[info exists ::T($path)]} {
        lassign $::T($path) nodeid clspath
        if {[string match "*/Variable" $clspath]} {
            return -code error -errorcode [list POSIX ENOENT {}]
        }
        set pattern ${path}/*
    } elseif {$path eq "/"} {
        set pattern /*
    }
    set nsl [llength [split $pattern "/"]]
    set list [list "." ".."]
    foreach name [array names ::T] {
        if {[string match $pattern $name]} {
            set sl [llength [split $name "/"]]
            if {$sl == $nsl} {
                lappend list [file tail $name]
            }
        }
    }
    return $list
}

proc fs_read {context path fileinfo size offset} {
    log "read $path"
    if {[info exists ::T($path)]} {
        lassign $::T($path) nodeid clspath
        if {[string match "*/Variable" $clspath]} {
            if {![info exists ::D($nodeid)]} {
                # EOF?
                return
            }
            set val $::D($nodeid)
            set len [string length $val]
            if {$offset < $len} {
                if {$offset + $size > $len} {
                    set size $len
                }
                incr size -1
                return [string range $val $offset $size]
            }
            # Success, but nothing read
            return
        }
    }
    return -code error -errorcode [list POSIX ENOENT {}]
}

proc fs_release {context path fileinfo} {
    log "release $path"
    if {[info exists ::T($path)]} {
        lassign $::T($path) nodeid clspath
        # Decrement use counter for cache entry.
        incr ::U($nodeid) -1
    }
    return
}

proc fs_destroy {context} {
    log "shutdown, disconnecting"
    catch {opcua disconnect C}
    log "exiting"
    exit 0
}

# Create and serve fuse file system.

fuse create FS -getattr fs_getattr -readdir fs_readdir -open fs_open \
    -read fs_read -release fs_release -destroy fs_destroy

FS $mountpoint -s -ononempty -ofsname=OPCUA
log "created/mounted file system"

# Remove old cache entries after 60 seconds and do some keep-alive/reconnect handling.

proc fs_cleanup {url} {
    log "cleanup ..."
    set status /Root/Objects/Server/ServerStatus
    if {[info exists ::T($status)]} {
        if {[catch {opcua read C [lindex $::T($status) 0]} error]} {
            log "reading server status: $error"
            catch {opcua disconnect C}
            log "reconnecting to $url"
            if {[catch {opcua connect C $url} error]} {
                log "connect failed: $error"
            }
        }
    }
    set now [clock seconds]
    foreach nodeid [array names ::D] {
        if {$::U($nodeid) <= 0 && $now - $::M($nodeid) >= 60} {
            log "expire $::R($nodeid)"
            unset -nocomplain ::D($nodeid)
            unset -nocomplain ::M($nodeid)
            unset -nocomplain ::U($nodeid)
        }
    }
    after 10000 [list fs_cleanup $url]
}

fs_cleanup $url

# Start event loop

log "enter event loop"
vwait forever
======

****Map OPC/UA Variables To Files Using tclvfs****

Similar to the Fuse example, the following script uses [tclvfs] to read-only map OPC/UA variables to files. The path names within the file system are derived from the browse paths of the variables in the OPC/UA address space. A mount is performed by

   package require vfs::opcua
   vfs::opcua::Mount opc.tcp://localhost:4840 OPCUA

where the OPC/UA address space appears below the local directory OPCUA, or

   package require vfs::urltype
   package require vfs::opcua
   vfs::urltype::Mount opcua

where the mount is automatically performed using an URL like notation, e.g.

   set f [open opcua://localhost:4840/Objects/LilWebCam/Image rb]
   image1 configure -data [read $f]
   close $f

for the webcam example above. Unmounting is done for the first form of mount by

   vfs::unmount OPCUA

and for the URL type form by

   vfs::filesystem unmount opcua://localhost:4840

Here is the implementation of the '''vfs::opcua''' filesystem:

======
package require topcua
package require vfs

package provide vfs::opcua 0.1

namespace eval vfs::opcua {
    variable T        ;# array indexed by brpath, values are { nodeid clspath }
    variable R        ;# reverse of T, indexed by nodeid, values are brpath
    variable D        ;# data cache, array indexed by nodeid, values are
                ;# OPCUA variables' Value attributes
    variable U        ;# array of URLs for reconnect indexed by client handle
    variable M        ;# array for memchans

    array set T {}
    array set R {}
    array set D {}
    array set U {}
    array set M {}

    proc _connect {C url} {
        variable T
        variable R
        variable U
        set U($C) $url
        ::opcua connect $C $url
        catch {::opcua gentypes $C}
        # omit "/Root" and namespace prefixes in method names
        catch {::opcua genstubs $C /Root/ {{/[1-9][0-9]*:} {/}}}
        set root [::opcua root]
        set tree [::opcua ptree $C]
        # omit "/" and "/Root" prefixes in brpath
        foreach {brpath nodeid clspath refid typeid parent} $tree {
            if {$nodeid eq $root} {
                continue
            }
            set brpath [string trimleft $brpath /]
            regsub -all -- {^Root/} $brpath {} brpath
            set short $brpath
            regsub -all -- {/[1-9][0-9]*:} $short {/} short
            incr t($short)
        }
        foreach {brpath nodeid clspath refid typeid parent} $tree {
            if {$nodeid eq $root} {
                continue
            }
            set brpath [string trimleft $brpath /]
            regsub -all -- {^Root/} $brpath {} brpath
            set short $brpath
            regsub -all -- {/[1-9][0-9]*:} $short {/} short
            if {$t($short) == 1} {
                set brpath $short
            }
            set T($C,$brpath) [list $nodeid $clspath]
            set R($C,$nodeid) $brpath
        }
    }

    proc _disconnect {C} {
        variable T
        variable R
        variable D
        variable U
        ::opcua disconnect $C
        array unset T $C,*
        array unset R $C,*
        array unset D $C,*
        unset U($C)
    }

    proc Mount {url local} {
        variable T
        variable R
        variable U
        set urlc $url
        if {[string first opcua:// $urlc] == 0} {
            set urlc opc.tcp://[string range $url 8 end]
        }
        set C [::opcua new]
        if {![catch {vfs::filesystem info $url}]} {
            vfs::unmount $url
        }
        if {[file pathtype $local] ne "absolute"} {
            set local [file normalize $local]
        }
        vfs::filesystem mount $local [list [namespace current]::handler $C]
        vfs::RegisterMount $local [list [namespace current]::Unmount $C]
        _connect $C $urlc
        return $C
    }

    proc _readvar {C nodeid} {
        variable U
        foreach attempt {0 1} {
            if {![catch {::opcua read $C $nodeid} val]} {
                return $val
            }
            if {$attempt < 1} {
                switch -- [lindex $::errorCode 3] {
                    BadSessionIdInvalid -
                    BadConnectionClosed {
                        # try to reconnect
                        set url $U($C)
                        catch {_disconnect $C}
                        catch {_connect $C $url}
                    }
                }
            }
        }
        return -code error $val
    }

    proc Unmount {C local} {
        if {[file pathtype $local] ne "absolute"} {
            set local [file normalize $local]
        }
        vfs::filesystem unmount $local
        _disconnect $C
        ::opcua destroy $C
    }

    proc handler {C cmd root relative actualpath args} {
        if {$cmd eq "matchindirectory"} {
            [namespace current]::$cmd $C $relative $actualpath {*}$args
        } else {
            [namespace current]::$cmd $C $relative {*}$args
        }
    }

    proc attributes {C} {
        return [list "state"]
    }

    proc state {C args} {
        vfs::attributeCantConfigure "state" "readonly" $args
    }

    proc _getdir {C path actualpath {pattern *}} {
        variable R
        variable T
        if {$path eq "." || $path eq ""} {
            set path ""
        }
        if {$pattern eq ""} {
            if {[info exists T($C,$path)]} {
                return [list $path]
            }
            return [list]
        }
        set res [list]
        if {$path eq ""} {
            set sep /
            set strip 0
            set depth 1
        } elseif {[info exists T($C,$path)]} {
            set sep ""
            set strip [string length $path]
            set depth [llength [file split $path]]
            incr depth 1
        }
        if {[info exists depth]} {
            foreach name [array names R $C,*] {
                if {$strip && [string first $path $R($name)] != 0} {
                    continue
                }
                set flist [file split $R($name)]
                if {[llength $flist] != $depth} {
                    continue
                }
                if {[string match $pattern [lindex $flist end]]} {
                    lappend res \
                        $actualpath$sep[string range $R($name) $strip end]
                }
            }
        }
        return $res
    }

    proc matchindirectory {C path actualpath pattern type} {
        variable T
        set res [_getdir $C $path $actualpath $pattern]
        if {![string length $pattern]} {
            if {![info exists T($C,$path)]} {
                return {}
            }
            set res [list $actualpath]
        }
        set actualpath ""
        ::vfs::matchCorrectTypes $type $res $actualpath
    }

    proc stat {C name} {
        variable T
        variable D
        if {$name eq ""} {
            return [list type directory mtime 0 size 0 mode 0555 ino -1 \
                        depth 0 name "" dev -1 uid -1 gid -1 nlink 1]
        }
        if {[info exists T($C,$name)]} {
            lassign $T($C,$name) nodeid clspath
            if {[string match "*/Variable" $clspath]} {
                if {![info exists D($C,$nodeid)]} {
                    if {[catch {set D($C,$nodeid) [_readvar $C $nodeid]}]} {
                        vfs::filesystem posixerror $::vfs::posix(EIO)
                    }
                }
                return [list type file mtime 0 mode 0444 ino -1 \
                            size [string length $D($C,$nodeid)] \
                            atime 0 ctime 0]
            } elseif {[string match "*/Method" $clspath]} {
                return [list type file mtime 0 mode 0666 ino -1 \
                            size 0 atime 0 ctime 0]
            }
            return [list type directory mtime 0 size 0 mode 0555 ino -1 \
                        depth 0 name $name dev -1 uid -1 gid -1 nlink 1]
        }
        vfs::filesystem posixerror $::vfs::posix(ENOENT)
    }

    proc access {C name mode} {
        variable T
        if {$name eq {} && !($mode & 2)} {
            return 1
        }
        if {[info exists T($C,$name)]} {
            lassign $T($C,$name) nodeid clspath
            if {[string match "*/Variable" $clspath]} {
                if {$mode & 2} {
                    vfs::filesystem posixerror $::vfs::posix(EACCES)
                }
                return 1
            }
            if {[string match "*/Method" $clspath]} {
                    return 1
            }
            if {$mode & 2} {
                vfs::filesystem posixerror $::vfs::posix(EACCES)
            }
            return 1
        }
        vfs::filesystem posixerror $::vfs::posix(ENOENT)
    }

    proc open {C name mode permission} {
        variable T
        variable D
        if {![info exists T($C,$name)]} {
            vfs::filesystem posixerror $::vfs::posix(ENOENT)
        }
        switch -glob -- $mode {
            "" - "r" {
                lassign $T($C,$name) nodeid clspath
                if {[string match "*/Method" $clspath]} {
                    vfs::filesystem posixerror $::vfs::posix(EACCES)
                }
                if {![string match "*/Variable" $clspath]} {
                    vfs::filesystem posixerror $::vfs::posix(EISDIR)
                }
                if {[catch {set D($C,$nodeid) [_readvar $C $nodeid]}]} {
                    vfs::filesystem posixerror $::vfs::posix(EACCES)
                }
                return [list [_memchan $C $nodeid 0 $D($C,$nodeid)]]
            }
            "w*" {
                lassign $T($C,$name) nodeid clspath
                if {[string match "*/Variable" $clspath]} {
                    vfs::filesystem posixerror $::vfs::posix(EROFS)
                }
                if {![string match "*/Method" $clspath]} {
                    vfs::filesystem posixerror $::vfs::posix(EISDIR)
                }
                return [list [_memchan $C $nodeid 1]]
            }
            default {
                vfs::filesystem posixerror $::vfs::posix(EROFS)
            }
        }
    }

    proc createdirectory {C name} {
        vfs::filesystem posixerror $::vfs::posix(EROFS)
    }

    proc removedirectory {C name recursive} {
        vfs::filesystem posixerror $::vfs::posix(EROFS)
    }

    proc deletefile {C name} {
        vfs::filesystem posixerror $::vfs::posix(EROFS)
    }

    proc fileattributes {C name args} {
        switch -- [llength $args] {
            0 {
                # list strings
                return [list]
            }
            1 {
                # get value
                return ""
            }
            2 {
                # set value
                vfs::filesystem posixerror $::vfs::posix(EROFS)
            }
        }
    }

    proc utime {C path actime mtime} {
        vfs::filesystem posixerror $::vfs::posix(EROFS)
    }

    # Memory backed channel constructor

    proc _memchan {C nodeid ismeth {data {}}} {
        variable M
        set chan [chan creat {read write} [namespace origin _memchan_handler]]
        set M($chan,C) $C
        set M($chan,nodeid) $nodeid
        set M($chan,ismeth) $ismeth
        set M($chan,buf) $data
        return $chan
    }

    # A seek operation which set the file pointer to offset 0
    # triggers another read or method call.

    proc _memchan_handler {cmd chan args} {
        variable M
        variable R
        variable D
        switch -exact -- $cmd {
            initialize {
                lassign $args mode
                set M($chan,pos) 0
                if {![info exists M(timer)]} {
                    set M(timer) {}
                }
                return {
                    initialize finalize watch read write seek
                    cget cgetall configure truncate
                }
            }
            finalize {
                unset -nocomplain M($chan,buf) M($chan,pos)
                unset -nocomplain M($chan,C) M($chan,nodeid) M($chan,ismeth)
                foreach event {read write} {
                    if {[info exists M($event,watch)]} {
                        [set idx [lsearch -exact M($event,watch) $chan]]
                        if {$idx >= 0} {
                            set M($event,watch) \
                                [lreplace $M($event,watch) $idx $idx]
                        }
                    }
                }
            }
            seek {
                lassign $args offset base
                switch -exact -- $base {
                    current {
                        incr offset $M($chan,pos)
                    }
                    end {
                        incr offset [string length $M($chan,buf)]
                    }
                }
                if {$offset < 0} {
                    return -code error \
                        "error during seek on \"$chan\": invalid argument"
                } elseif {$offset > [string length $M($chan,buf)]} {
                    set extend [expr {$offset - [string length $M($chan,buf)]}]
                    append buf [binary format @$extend]
                }
                set M($chan,pos) $offset
                if {($M($chan,pos) == 0)} {
                    set eio 0
                    set C $M($chan,C)
                    set nodeid $M($chan,nodeid)
                    if {$M($chan,ismeth)} {
                        set meth ::opcua::${C}::$R($C,$nodeid)
                        if {[catch {info args $meth} input]} {
                            vfs::filesystem posixerror $::vfs::posix(ENODEV)
                        }
                        set D($C,$nodeid) {}
                        if {[llength $input] > 1} {
                            if {[catch {
                                set D($C,$nodeid) [$meth {*}$M($chan,buf)]
                            }]} {
                                incr eio
                            }
                        } elseif {[llength $input] == 0} {
                            if {[catch {
                                set D($C,$nodeid) [$meth]
                            }]} {
                                incr eio
                            }
                        } elseif {[catch {
                            set D($C,$nodeid) [$meth $M($chan,buf)]
                        }]} {
                            incr eio
                        }
                    } else {
                        if {[catch {
                            set D($C,$nodeid) [_readvar $C $nodeid]
                        }]} {
                            incr eio
                        }
                    }
                    if {$eio} {
                        vfs::filesystem posixerror $::vfs::posix(EIO)
                    } else {
                        set M($chan,buf) $D($C,$nodeid)
                    }
                }
                return $M($chan,pos)
            }
            read {
                lassign $args count
                set ret [string range $M($chan,buf) $M($chan,pos) \
                           [expr {$M($chan,pos) + $count - 1}]]
                incr M($chan,pos) [string length $ret]
                return $ret
            }
            write {
                lassign $args data
                set count [string length $data]
                if {$M($chan,pos) >= [string length $M($chan,buf)]} {
                    append M($chan,buf) $data
                } else {
                    set last [expr {$M($chan,pos) + $count - 1}]
                    set M($chan,buf) \
                        [string replace $M($chan,buf) $M($chan,pos) $last $data]
                }
                incr M($chan,pos) $count
                return $count
            }
            cget {
                lassign $args option
                switch -exact -- $option {
                    -length {
                        return [string length $M($chan,buf)]
                    }
                    -allocated {
                        return [string length $M($chan,buf)]
                    }
                    -clear {
                        if {$M($chan,buf) eq {}} {
                            return 1
                        }
                        return 0
                    }
                    default {
                        return -code error "bad option \"$option\":\
should be one of -blocking, -buffering, -buffersize, -encoding,\
-eofchar, -translation, -length, -allocated, or -clear"
                    }
                }
            }
            cgetall {
                set len [string length $M($chan,buf)]
                set clr [expr {$len == 0}]
                return [list -length $len -allocated $len -clear $clr]
            }
            configure {
                lassign $args option value
                switch -exact -- $option {
                    -length {
                    }
                    -allocated {
                    }
                    -clear {
                        # use -clear 1 before writing arguments
                        # for next method call
                        if {$value} {
                            set M($chan,buf) {}
                            set M($chan,pos) 0
                        }
                    }
                    default {
                        return -code error "bad option \"$option\":\
should be one of -blocking, -buffering, -buffersize, -encoding,\
-eofchar, -translation, -length, -allocated, or -clear"
                    }
                }
            }
            watch {
                lassign $args eventspec
                after cancel $M(timer)
                foreach event {read write} {
                    if {![info exists M($event,watch)]} {
                        set M($event,watch) {}
                    }
                    set idx [lsearch -exact $M($event,watch) $chan]
                    if {$event in $eventspec} {
                        if {$idx == -1} {
                            lappend M($event,watch) $chan
                        }
                    } elseif {$idx != -1} {
                        set watch [lreplace $M($event,watch) $idx $idx]
                    }
                }
                set M(timer) [after 10 [list ::vfs::opcua::_memchan_timer]]
            }
            truncate {
                lassign $args length
                if {$length < 0} {
                    return -code error \
                        "error during truncate on \"$chan\": invalid argument"
                } elseif {$length > [string length $M($chan,buf)]} {
                    set extend [expr {$length - [string length $M($chan,buf)]}]
                    append buf [binary format @$extend]
                } else {
                    set M($chan,buf) [string range $M($chan,buf) 0 $length-1]
                }
                set length [string length $M($chan,buf)]
                if {$M($chan,pos) > $length} {
                    set M($chan,pos) $length
                }
            }
        }
    }

    # memchan channels are always writable and always readable

    proc _memchan_timer {} {
        variable M
        set more 0
        foreach event {read write} {
            incr more [llength $M($event,watch)]
            foreach chan $M($event,watch) {
                chan postevent $chan $event
            }
        }
        if {$more > 0} {
            set M(timer) [after 10 [info level 0]]
        }
    }
}
======

****Map Augeas tree to OPC/UA****

The following script makes a read-only mapping of the Augeas address space using [tcl-augeas] below a OPC/UA server's folder '''Root/Objects/uageas''' (note the creative misspelling!).

======
package require topcua
package require augeas

# create server
opcua new server 4840 S

# counter for node identifiers
set ::I 10000

# init augeas
set ::A [augeas::init /]

# make namespace
set ::NS [opcua add S Namespace http://augeas.net/UA]

# get Objects folder
set ::OF [lindex [opcua translate S [opcua root] / Objects] 0]

# create new folder
set ::AF [opcua add S Object "ns=${::NS};i=${::I}" $OF Organizes "${::NS}:uageas"]
incr ::I

# create mapping recursively
proc uageas_map {folder path} {
    set att [opcua attrs default VariableAttributes]
    dict set att DataType [opcua types nodeid String]
    set list [lsort -dictionary [augeas::match $::A ${path}/*]]
    set rest {}
    # comments are accumulated for OPC/UA String array
    foreach dir $list {
        if {[string match {*/#comment[[]*} $dir]} {
            lappend comment [augeas::get $::A $dir]
        } else {
            lappend rest $dir
        }
    }
    if {[info exists comment]} {
        set name "#comment"
        set node "ns=${::NS};i=$::I"
        incr ::I
        dict set att ValueRank 0
        dict set att DisplayName text $name
        opcua add S Variable $node $folder HasComponent "${::NS}:$name" {} $att
        opcua write S $node Value *String $comment
    }
    # everything else treated as scalar and traversed for subelements
    dict set att ValueRank -1
    foreach dir $rest {
        set name [lindex [file split $dir] end]
        set node "ns=${::NS};i=$::I"
        incr ::I
        dict set att Value [list String [augeas::get $::A $dir]]
        dict set att DisplayName text $name
        opcua add S Variable $node $folder HasComponent "${::NS}:$name" {} $att
        uageas_map $node $dir
    }
}

uageas_map $::AF {}

# start server
opcua start S

# enter event loop
vwait forever
======

****Simple text based OPC/UA Browser****

Current vanillatclsh binaries have a simple [ck] based OPC/UA browser built in which allows for client and server mode.
In combination with the new topcua::filesystem module I've recorded a short ASCII screen cast to demonstrate it's capabilities,
see http://asciinema.org/a/d4O2RHNjGsEZKWfniq9TgAhFO%|%ASCII Cinema%|%.

======
# start browsing local OPC/UA server on standard port 4840
$ vanillatclsh builtin:ckua

# start browsing remote OPC/UA server on port 10000 on host example.com
$ vanillatclsh builtin:ckua opc.tcp://example.com:10000

# make server on port 9000 and start browsing on it
$ vanillatclsh builtin:ckua 10000

# make server on port 9000, load nodeset, and start browsing on it
$ vanillatclsh builtin:ckua 9000 MyNodes.xml
======


****Exercises for the interested reader****


   * make the camera using the tclwmf extension from http://www.androwish.org to run this on Windows
   * make the camera using the borg extension from http://www.androwish.org to run this on a tablet or smartphone
   * add more camera controls using appropriate mappings between tcluvc parameters and OPC/UA variables
   * use e.g. SQLite as persistent data store for variable values
   * create some methods to query e.g. an SQLite database (and avoid SQL insertion problems for the query's parameters)


<<categories>> Android | Dev. Tools