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.
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 UAExpert or 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 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_trafficIt 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 foreverThe 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 foreverSimilar 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 M($event,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]]
}
}
}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 foreverCurrent 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 ASCII Cinema .
For further vanillatclsh information refer to the LUCK page.
# 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 10000 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