Check-in [5ece104b90]
Not logged in

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Checkpoint on dbusclient package development.
Timelines: family | ancestors | descendants | both | dbusclient-develop
Files: files | file ages | folders
SHA1:5ece104b908066cdde7ef1ece2077ad30cacb045
User & Date: andrewm 2019-02-15 17:18:04
Context
2019-03-01
11:36
Clean up of dbusclient in preparation for 1.0 release. check-in: 35b7b72ecd user: andrewm tags: dbusclient-develop
2019-02-15
17:18
Checkpoint on dbusclient package development. check-in: 5ece104b90 user: andrewm tags: dbusclient-develop
2019-02-09
16:51
Checkpoint on dbusclient package. check-in: eb0d38339a user: andrewm tags: dbusclient-develop
Changes

Changes to dbusclient/src/Makefile.

131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
...
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
...
167
168
169
170
171
172
173



174
175
176
177
178
179
180
181
182
183
184
	$(NULL)

TESTOPTS =\
	-verbose bet\
	-level notice\
	$(NULL)

.PHONY : all doc code test module man clean

all : doc module man

doc : $(PDF)

code : $(CODEFILE)

................................................................................

man : $(MANFILE)

$(MODULEFILE) : $(CODEFILE)
	cd $(CODEDIR) ; mkmodule $(PKGNAME) $(VERSION)\
		-script $(notdir $(CODEFILE))

runtests : $(TESTFILE) code
	cd $(TESTDIR) ; tclsh $(notdir $(TESTFILE)) $(TESTOPTS)

clean :
	$(RM) $(CLEANFILES)

$(DOCSRC) : $(DOCPARTS)

................................................................................

$(CODEFILE) : $(DOCSRC) $(DOCPARTS)
	atangle $(ATANGLEOPTS) -root $(notdir $@) -output $@ $(DOCSRC)

$(TESTFILE) : $(DOCSRC) $(DOCPARTS)
	atangle $(ATANGLEOPTS) -root $(notdir $@) -output $@ $(DOCSRC)




$(MANFILE) : $(DOCSRC) $(DOCPARTS)
	atangle $(ATANGLEOPTS) -root $(notdir $@) -output $@ $(DOCSRC)

$(IMAGEDIR)/%.pdf : %.uxf
	umlet -action=convert -format=pdf\
		-filename=$< -output=$(basename $@)


#
# vim: sw=8 ts=8 sts=8 noexpandtab
#







|







 







|







 







>
>
>











131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
...
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
...
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
	$(NULL)

TESTOPTS =\
	-verbose bet\
	-level notice\
	$(NULL)

.PHONY : all doc code runtests module man clean

all : doc module man

doc : $(PDF)

code : $(CODEFILE)

................................................................................

man : $(MANFILE)

$(MODULEFILE) : $(CODEFILE)
	cd $(CODEDIR) ; mkmodule $(PKGNAME) $(VERSION)\
		-script $(notdir $(CODEFILE))

runtests : $(TESTFILE) code $(TESTDIR)/test-server.tcl
	cd $(TESTDIR) ; tclsh $(notdir $(TESTFILE)) $(TESTOPTS)

clean :
	$(RM) $(CLEANFILES)

$(DOCSRC) : $(DOCPARTS)

................................................................................

$(CODEFILE) : $(DOCSRC) $(DOCPARTS)
	atangle $(ATANGLEOPTS) -root $(notdir $@) -output $@ $(DOCSRC)

$(TESTFILE) : $(DOCSRC) $(DOCPARTS)
	atangle $(ATANGLEOPTS) -root $(notdir $@) -output $@ $(DOCSRC)

$(TESTDIR)/test-server.tcl : $(DOCSRC) $(DOCPARTS)
	atangle $(ATANGLEOPTS) -root $(notdir $@) -output $@ $(DOCSRC)

$(MANFILE) : $(DOCSRC) $(DOCPARTS)
	atangle $(ATANGLEOPTS) -root $(notdir $@) -output $@ $(DOCSRC)

$(IMAGEDIR)/%.pdf : %.uxf
	umlet -action=convert -format=pdf\
		-filename=$< -output=$(basename $@)


#
# vim: sw=8 ts=8 sts=8 noexpandtab
#

Changes to dbusclient/src/codeorg.txt.

62
63
64
65
66
67
68


69
70
71
72
73
74
75
    namespace import ::tcltest::*
    namespace import ::dbusclient::*

    <<test utilities>>

    <<connection tests>>
    <<service tests>>



    cleanupTests
}
----

We collect all the additional packages required for the tests into
one place.







>
>







62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
    namespace import ::tcltest::*
    namespace import ::dbusclient::*

    <<test utilities>>

    <<connection tests>>
    <<service tests>>

    killServer

    cleanupTests
}
----

We collect all the additional packages required for the tests into
one place.

Changes to dbusclient/src/introduction.txt.

6
7
8
9
10
11
12
13
`Dbusclient` is a Tcl package that facilitates interacting with
a DBus daemon to obtain services from other programs on a DBus.

This document is also a
http://www.literateprogramming.com/[literate program]
and contains all the design information and code for the `posixipc` package.
Readers unfamiliar with literate programs should consult the
<<literate-programming,appendix>> for more details.







|
6
7
8
9
10
11
12
13
`Dbusclient` is a Tcl package that facilitates interacting with
a DBus daemon to obtain services from other programs on a DBus.

This document is also a
http://www.literateprogramming.com/[literate program]
and contains all the design information and code for the `posixipc` package.
Readers unfamiliar with literate programs should consult the
<<literate-programming,section below>> for more details.

Changes to dbusclient/src/package.txt.

76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
...
187
188
189
190
191
192
193
194
195
196
197



198
199
200
201
202
203
204
...
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
...
478
479
480
481
482
483
484
485

486
487
488
489
490
491
492
...
522
523
524
525
526
527
528
529


530
531
532
533
534
535
536
...
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
...
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836




837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863












864
865
866
867
868
869
870
....
1060
1061
1062
1063
1064
1065
1066


1067
1068
1069
1070
1071
1072
1073
....
1095
1096
1097
1098
1099
1100
1101


1102
1103
1104
1105
1106
1107
1108


1109
1110
1111
1112
1113
1114
1115
....
1128
1129
1130
1131
1132
1133
1134


1135
1136
1137
1138
1139
1140
1141
....
1191
1192
1193
1194
1195
1196
1197


1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208




1209
1210
1211
1212
1213
1214
1215
....
1245
1246
1247
1248
1249
1250
1251


1252
1253
1254
1255
1256
1257
1258
....
1267
1268
1269
1270
1271
1272
1273


1274
1275
1276
1277
1278
1279
1280
....
1307
1308
1309
1310
1311
1312
1313


1314
1315
1316
1317
1318
1319
1320
....
1344
1345
1346
1347
1348
1349
1350


1351
1352
1353
1354
1355
1356
1357
....
1384
1385
1386
1387
1388
1389
1390


1391
1392
1393
1394
1395
1396
1397
....
1422
1423
1424
1425
1426
1427
1428
























































































1429
1430
1431
1432
1433
1434
1435
....
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764

1765
1766
1767
1768
1769


1770
1771
1772
1773
1774
1775
1776
....
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
....
2040
2041
2042
2043
2044
2045
2046

2047
2048
2049
2050
2051
2052
2053
....
2076
2077
2078
2079
2080
2081
2082

2083
2084
2085
2086
2087

2088
2089
2090
2091
2092

2093
2094






2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105





2106
2107








2108
2109
2110








2111
2112











2113
2114

















2115
2116
2117



2118

































2119
2120
2121
2122
2123
2124
2125
....
2168
2169
2170
2171
2172
2173
2174

2175
2176
2177
2178
2179
2180
2181
....
2218
2219
2220
2221
2222
2223
2224









































2225
2226
2227
2228
2229
2230
2231
....
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260




































2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
....
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
....
2319
2320
2321
2322
2323
2324
2325

2326
2327
2328
2329
2330
2331
2332
}
----
<1> We use the bus identifier in all the methods, so just declare it
a variable and have it automatically imported into each method.

==== Connection constructor

Construction of a `Connection` is a thin veneer on the underlying
`dbus` package command.

[source,tcl]
----
<<connection methods>>=
constructor {address} {
    ::logger::import -all -force -namespace log dbusclient ;        # <1>
................................................................................
In DBus terms,
a method is a member of an interface that is supported by an object
instance.
Calling the method is a request to perform the function of the method.

The only complication here deals with the signature of the method.
The `dbus` package documentation describes the details of signatures in DBus,
but, as you might suspect, it is a means of dealing with DBus typing
semantics in the face of Tcl _everything is a string_ semantics.
We interpret an empty string signature as not wishing to pass in the
signature to the `dbus` command.




[source,tcl]
----
<<connection methods>>=
method call {target path interface method sig args} {
    set cmd [list ::dbus call $busId -dest $target]
    if {$sig ne {}} {
................................................................................
You know the name of the service in which you are interested _a priori_,
although it is possible to get a list of all the bus names on a DBus.

[source,tcl]
----
<<service class>>=
::oo::class create ::dbusclient::Service {

    <<service methods>>
}
----

/////////
----
<<man command synopsis>>=
................................................................................
Constructing a `Service` instance is quite complicated.
The complications arise from the need to use introspection
to discover the object instances and interfaces they support.
Objects are given file system path-like names and we use the term _path_
here to mean an object instance.
During the introspection,
we store the data obtained in the `relvars` shown previously,
effectively caching the introspection data.


[source,tcl]
----
<<service methods>>=
constructor {svc conn} {
    namespace import ::ral::*
    namespace import ::ralutil::*
................................................................................
    foreach rv [lsort [relvar names [namespace current]::*]] {
        log::info "\n[relformat [relvar set $rv] [namespace tail $rv]]"
    }
}
----
<1> Used for identifying trace requests.
<2> Recursively introspect the service starting at the root path.
Note the is done in a relvar transaction.


<3> Fetch the property values for the discovered object.
<4> Set up signal handlers for the internal mechanisms used to keep the
local cache of properties and interfaces up to date.
The DBus standard defines standard interfaces which contain signal members that
can be used to insure that internal data structures are keep up to date.

Each DBus has a service,
................................................................................
----
<<service methods>>=
method Introspect {path}  {
    my variable connId svcName

    set svcxml [$connId call $svcName $path\
            org.freedesktop.DBus.Introspectable Introspect {}]
    log::debug "xml for $path: \"$svcxml\""

    set svcdoc [dom parse -simple $svcxml]
    set svcroot [$svcdoc documentElement]

    try {
        relvar insert Path [list Name $path]
        my CreateInterfaces $path $svcroot
................................................................................
Object instances and their path names are strictly hierarchical
and use file system-like naming for the paths.

[source,tcl]
----
<<service methods>>=
method CreateNodes {path root} {
    set nodeNodes [$root getElementsByTagName node]
    foreach nodeNode $nodeNodes {
        set nodeName [$nodeNode getAttribute name]
        set fullpath [file join $path $nodeName]
        my Introspect $fullpath ;                   # <1>
    }
}
----




<1> Here is the recursive introspection to obtain the information for
child nodes.

Once we know all the paths and interfaces in a service and know
which interfaces are implemented by which paths,
then we can create values for the properties that are associated with
a given path.
At this point,
we don't know the values of the properties.
So, each property value is set to the empty string and marked as invalid.

[source,tcl]
----
<<service methods>>=
method CreatePropertyValues {} {
    pipe {
        relvar set Implementation |
        relation join ~ [relvar set Property] |
        relation project ~ Path Interface Name |
        relation rename ~ Name Property |
        relation extend ~ exTup Value string {""} Valid boolean {"false"} |
        relvar set PropertyValue ~
    }

    return
}
----













After introspection is completed,
we can then request the property values and place those values in
the metadata cache.

[source,tcl]
----
................................................................................
==== Service Introspection

Once we have connected to a service and gone through all the DBus
introspection,
the following methods can be used to obtain access to some of the
service metadata accumulated during construction.



[source,tcl]
----
<<service methods>>=
method connectedTo {} {
    my variable connId
    return $connId
}
................................................................................
} -cleanup {
    sysBus destroy
} -body {
    DBus connectedTo
} -result $conn
----



[source,tcl]
----
<<service methods>>=
method pathList {} {
    return [relation list [relvar set Path] Name]
}
----



/////////
----
<<man service methods>>=
[call [cmd "[arg svcobj] pathList"]]

The [method pathList] method returns a list of object instance path
................................................................................
    Service create DBus org.freedesktop.DBus $conn
} -cleanup {
    sysBus destroy
} -body {
    DBus pathList
} -result {/ /org/freedesktop/DBus} -match set
----



[source,tcl]
----
<<service methods>>=
method findPathsByPropertyValue {interface property expression} {
    set matches [pipe {
        relvar set PropertyValue |
................................................................................
        {"org.freedesktop.DBus.Monitoring" in $Value}
}]

returns the object whose path is [cmd /org/freedesktop/DBus].
----
/////////



[source,tcl]
----
<<service methods>>=
method pathInterfaces {path} {
    return [pipe {
        relvar set Implementation |
        relation restrictwith ~ {$Path eq $path} |
        relation list ~ Interface
    }]
}
----





.Tests

[source,tcl]
----
<<required packages for test>>=
package require struct::set
................................................................................
[call [cmd "[arg svcobj] pathInterfaces"] [arg path]]

The [method pathInterfaces] method returns a list of interfaces that are
implemented for [arg path].
----
/////////



[source,tcl]
----
<<service methods>>=
method pathProperties {path interface} {
    return [pipe {
        relvar set PropertyValue |
        relation restrictwith ~\
................................................................................
<<man service methods>>=
[call [cmd "[arg svcobj] pathProperties"] [arg path] [arg interface]]

The [method pathProperties] method returns a list of property names that are
implemented by [arg interface] for the object specified by [arg path].
----
/////////



[source,tcl]
----
<<service methods>>=
method interfaceMethods {interface} {
    return [pipe {
        relvar set Method |
................................................................................
[call [cmd "[arg svcobj] interfaceMethods"] [arg interface]]

The [method interfaceMethods] method returns a list of methods supported
by the specified [arg interface].
----
/////////



[source,tcl]
----
<<service methods>>=
method methodSignature {interface method} {
    return [pipe {
        relvar restrictone Method Interface $interface Name $method |
        relation extract ~ Signature
................................................................................
<<man service methods>>=
[call [cmd "[arg svcobj] methodSignature"] [arg interface] [arg method]]

The [method methodSignature] method returns the DBus signature
string for the specified [arg interface] and [arg method].
----
/////////



[source,tcl]
----
<<service methods>>=
method interfaceProperties {interface} {
    return [pipe {
        relvar set Property |
................................................................................
[call [cmd "[arg svcobj] interfaceProperties"] [arg interface]]

The [method interfaceProperties] method returns a list of properties defined
by [arg interface].
----
/////////



[source,tcl]
----
<<service methods>>=
method interfaceSignals {interface} {
    return [pipe {
        relvar set Signal |
        relation restrictwith ~ {$Interface eq $interface} |
................................................................................
<<man service methods>>=
[call [cmd "[arg svcobj] interfaceSignals"] [arg interface]]

The [method interfaceSignals] method returns a list of signals defined
by [arg interface].
----
/////////

























































































==== Calling methods

[source,tcl]
----
<<service methods>>=
method call {path interface method args} {
................................................................................
    return $value
}
----

[source,tcl]
----
<<service tests>>=
test network-property-1.0 {
    Get an network manager property
} -setup {
    set conn [Connection create sysBus system]
    Service create net org.freedesktop.NetworkManager $conn
} -cleanup {
    sysBus destroy
} -body {
    set hostname1 [net property /org/freedesktop/NetworkManager/Settings\
        org.freedesktop.NetworkManager.Settings Hostname]
    set hostname2 [exec hostname]
    expr {$hostname1 eq $hostname2}
} -result {1}
----

[source,tcl]
----
<<service tests>>=
test bluez-property-1.0 {
    Set an bluez adapter property
} -setup {
    set conn [Connection create sysBus system]
    Service create bluez org.bluez $conn
} -cleanup {
    bluez waitForProperty org.bluez.Adapter1 DiscoverableTimeout\
        /org/bluez/hci0 {bluez property /org/bluez/hci0 org.bluez.Adapter1\
            DiscoverableTimeout 0}

    sysBus destroy
} -body {
    set chng [bluez waitForProperty org.bluez.Adapter1 DiscoverableTimeout\
        /org/bluez/hci0 {bluez property /org/bluez/hci0 org.bluez.Adapter1\
            DiscoverableTimeout 100}]


    dict get $chng value
} -result {100}
----

/////////
----
<<man service methods>>=
................................................................................
            throw [list TRACE UNKNOWNOP $msg] $msg
        }
    }
    return $result
}
----

[source,tcl]
----
<<service tests>>=
test bluez-property-trace-1.0 {
    set up property trace
} -setup {
    set conn [Connection create sysBus system]
    Service create bluez org.bluez $conn
} -cleanup {
    bluez trace remove $traceid
    sysBus destroy
} -body {
    set traceid [bluez trace add property org.bluez.Adapter1\
            Discovering /org/bluez/hci0 [namespace code propertyChanged]]
    dict get [bluez trace info $traceid] Property
} -result {Discovering}
----

[source,tcl]
----
<<service methods>>=
method AddTrace {argList} {
    if {[llength $argList] < 2} {
        set msg "wrong # of args, expected: trace add tracetype args"
        throw [list TRACE WRONGARGS $msg] $msg
................................................................................
        rvajoin ~ [relvar set PathTrace] Path |
        rvajoin ~ [relvar set SignalTrace] Signal |
        rvajoin ~ [relvar set PropertyTrace] Property
    }]
    if {[relation isnotempty $trace]} {
        relation assign $trace


        relvar eval {
            relvar deleteone Trace TraceId $traceid
            if {[relation isnotempty $Path]} {
                relvar deleteone PathTrace TraceId $traceid
            } elseif {[relation isnotempty $Signal]} {
                relation assign $Signal Interface Signal
                $connId listen {} $Interface.$Signal {} ;           # <1>
................................................................................
    if {[relation isnotempty $trace]} {
        relation assign $trace
        if {[relation isnotempty $Path]} {
            set result [pipe {
                relation project $trace PathMatch CmdPrefix Path |
                relation ungroup ~ Path
            }]

        } elseif {[relation isnotempty $Signal]} {
            set result [pipe {
                relation project $trace PathMatch CmdPrefix Signal |
                relation ungroup ~ Signal
            }]

        } elseif {[relation isnotempty $Property]} {
            set result [pipe {
                relation project $trace PathMatch CmdPrefix Property |
                relation ungroup ~ Property
            }]

        }
        log::debug "Info Trace result:\n[relformat $result]"






    }

    return [lindex [relation body $result] 0]
}
----

/////////
----
<<man service methods>>=
[call [cmd "[arg svcobj] trace"] [arg operation] [arg type] [arg [opt args]]]






[list_begin definitions]
[call [cmd "[arg svcobj] trace add"] [arg type] [arg [opt args]]]









[list_begin definitions]
[call [cmd "[arg svcobj] trace add path"] [arg pathpattern] [arg cmdprefix]]








[call [cmd "[arg svcobj] trace add signal"] [arg interface]\
        [arg signal] [arg pathpattern] [arg cmdprefix]]











[call [cmd "[arg svcobj] trace add property"] [arg interface]\
        [arg property] [arg pathpattern] [arg cmdprefix]]

















[list_end]

[call [cmd "[arg svcobj] trace remove"] [arg traceid]]



[call [cmd "[arg svcobj] trace info"] [arg traceid]]

































[list_end]
----
/////////

==== Synchronizing to traces

[source,tcl]
................................................................................
Then the script specified by [arg trigger] is executed in the
call stack of the caller.
Then the Tcl event loop is entered waiting for the property change
to occur.
If [arg timeout] is specified it is the number of milliseconds to
wait for the property change notification.
A [arg timeout] value of 0 is interpreted to mean to wait forever.

If [arg trigger] executes successfully and the DBus notification is
received before any timeout,
then the return value of the command is a dictionary giving the details
of the property change.
The keys to the dictionary are:

[list_begin definitions]
................................................................................
----
<<service methods>>=
method PropertySyncTimeout {} {
    set [my varname propSync] TIMEOUT
    return
}
----










































[source,tcl]
----
<<service methods>>=
method waitForSignal {interface signal pathpattern trigger {timeout 5000}} {
    set timerid {}
    if {$timeout != 0} {
................................................................................
        set msg "timed out waiting for signal change: $interface $signal\
                $pathpattern $trigger"
        throw [list SIGNAL TIMEOUT $msg] $msg
    }
    return $sigSync
}
----

[source,tcl]
----




































<<service methods>>=
method SignalSync {eventinfo args} {
    set [my varname sigSync] [dict create\
        path [dict get $eventinfo path]\
        interface [dict get $eventinfo interface]\
        signal [dict get $eventInfo member]\
        sender [dict get $eventInfo sender]\
        signature [dict get $eventInfo signature]\
        args $args\
    ]
    return
}
................................................................................
----
<<service methods>>=
method waitForPath {pathpattern trigger {timeout 5000}} {
    set timerid {}
    if {$timeout != 0} {
        set timerid [::after $timeout [mymethod PathSyncTimeout]]
    }
    set traceId [my trace add path {} {} $pathpattern [mymethod PathSync]]
    set result [uplevel 1 $trigger]

    vwait [my varname pathSync]
    if {$timerid ne {}} {
        ::after cancel $timerid
    }

................................................................................
Then the script specified by [arg trigger] is executed in the
call stack of the caller.
Then the Tcl event loop is entered waiting for the path change
to occur.
If [arg timeout] is specified it is the number of milliseconds to
wait for the property change notification.
A [arg timeout] value of 0 is interpreted to mean to wait forever.

If [arg trigger] executes successfully and the DBus notification is
received before any timeout,
then the return value of the command is a dictionary giving the details
of the path change.
The keys to the dictionary are:

[list_begin definitions]







|







 







|
|


>
>
>







 







<







 







|
>







 







|
>
>







 







|







 







|
|
|
|
|



>
>
>
>
|




|


|
|












|




>
>
>
>
>
>
>
>
>
>
>
>







 







>
>







 







>
>




|


>
>







 







>
>







 







>
>











>
>
>
>







 







>
>







 







>
>







 







>
>







 







>
>







 







>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







|
|

|
|

|

|
|
<
<
|





|
|

|
|

|
|
|
>
|

<
|
|
>
>







 







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







 







>







 







>





>





>


>
>
>
>
>
>

<
<








>
>
>
>
>


>
>
>
>
>
>
>
>



>
>
>
>
>
>
>
>


>
>
>
>
>
>
>
>
>
>
>


>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>



>
>
>

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 










>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

|

|
|







 







|







 







>







76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
...
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
...
314
315
316
317
318
319
320

321
322
323
324
325
326
327
...
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
...
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
...
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
...
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
....
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
....
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
....
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
....
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
....
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
....
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
....
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
....
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
....
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
....
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
....
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880


1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898

1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
....
2024
2025
2026
2027
2028
2029
2030


















2031
2032
2033
2034
2035
2036
2037
....
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
....
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220


2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
....
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
....
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
....
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
....
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
....
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
}
----
<1> We use the bus identifier in all the methods, so just declare it
a variable and have it automatically imported into each method.

==== Connection constructor

Construction of a `Connection` is a thin wrapper on the underlying
`dbus` package command.

[source,tcl]
----
<<connection methods>>=
constructor {address} {
    ::logger::import -all -force -namespace log dbusclient ;        # <1>
................................................................................
In DBus terms,
a method is a member of an interface that is supported by an object
instance.
Calling the method is a request to perform the function of the method.

The only complication here deals with the signature of the method.
The `dbus` package documentation describes the details of signatures in DBus,
but, as you might suspect, it is a means of dealing with DBus data typing
in the face of Tcl insisting that_everything is a string_.
We interpret an empty string signature as not wishing to pass in the
signature to the `dbus` command.
Later we will see that internally,
[cmd Service] objects always supply the signature because it is
available from the service introspection.

[source,tcl]
----
<<connection methods>>=
method call {target path interface method sig args} {
    set cmd [list ::dbus call $busId -dest $target]
    if {$sig ne {}} {
................................................................................
You know the name of the service in which you are interested _a priori_,
although it is possible to get a list of all the bus names on a DBus.

[source,tcl]
----
<<service class>>=
::oo::class create ::dbusclient::Service {

    <<service methods>>
}
----

/////////
----
<<man command synopsis>>=
................................................................................
Constructing a `Service` instance is quite complicated.
The complications arise from the need to use introspection
to discover the object instances and interfaces they support.
Objects are given file system path-like names and we use the term _path_
here to mean an object instance.
During the introspection,
we store the data obtained in the `relvars` shown previously,
effectively caching the introspection data in a form that is
easier to query and manipulate.

[source,tcl]
----
<<service methods>>=
constructor {svc conn} {
    namespace import ::ral::*
    namespace import ::ralutil::*
................................................................................
    foreach rv [lsort [relvar names [namespace current]::*]] {
        log::info "\n[relformat [relvar set $rv] [namespace tail $rv]]"
    }
}
----
<1> Used for identifying trace requests.
<2> Recursively introspect the service starting at the root path.
Note the introspection is done in a relvar transaction so we
can defer enforcing the referential integrity until all the introspection
is finished.
<3> Fetch the property values for the discovered object.
<4> Set up signal handlers for the internal mechanisms used to keep the
local cache of properties and interfaces up to date.
The DBus standard defines standard interfaces which contain signal members that
can be used to insure that internal data structures are keep up to date.

Each DBus has a service,
................................................................................
----
<<service methods>>=
method Introspect {path}  {
    my variable connId svcName

    set svcxml [$connId call $svcName $path\
            org.freedesktop.DBus.Introspectable Introspect {}]
    log::debug "xml for $path:\n$svcxml"

    set svcdoc [dom parse -simple $svcxml]
    set svcroot [$svcdoc documentElement]

    try {
        relvar insert Path [list Name $path]
        my CreateInterfaces $path $svcroot
................................................................................
Object instances and their path names are strictly hierarchical
and use file system-like naming for the paths.

[source,tcl]
----
<<service methods>>=
method CreateNodes {path root} {
    set childNodes [$root getElementsByTagName node]
    foreach childNode $childNodes {
        set nodeName [$childNode getAttribute name]
        set fullpath [file join $path $nodeName] ;      # <1>
        my Introspect $fullpath ;                       # <2>
    }
}
----
<1> File join does the right thing here, particularly if `path`
is set to "/".
Better than just sandwiching a "/" between the path and its child node
name using sting concatenation.
<2> Here is the recursive introspection to obtain the information for
child nodes.

Once we know all the paths and interfaces in a service and know
which interfaces are implemented by which paths,
then we can *PropertyValue* tuples for the properties that are associated with
a given path.
At this point,
we don't know the values of the properties,
so each property value is set to the empty string and marked as invalid.

[source,tcl]
----
<<service methods>>=
method CreatePropertyValues {} {
    pipe {
        relvar set Implementation |
        relation join ~ [relvar set Property] |
        relation project ~ Path Interface Name |
        relation rename ~ Name Property |
        relation extend ~ exTup Value string {""} Valid boolean {"false"} |
        relvar set PropertyValue ~
    } ;                                                                 # <1>

    return
}
----
<1> The strategy behind this query starts with realizing that we intend to
set a new value for the *PropertyValue* relvar.
So, we need all the tuples in that value.
Since *PropertyValue* is a correlation between *Property* and *Implementation*,
we can derive a new value by joining the two, projecting the identifiers
and then adding the attributes, by extension,
required for *PropertyValue*.
As long as we get the correct header, then we can set the value of the
relvar just like any other variable.
In this way,
the new value is generated as a complete set and no explicit iteration is
required.

After introspection is completed,
we can then request the property values and place those values in
the metadata cache.

[source,tcl]
----
................................................................................
==== Service Introspection

Once we have connected to a service and gone through all the DBus
introspection,
the following methods can be used to obtain access to some of the
service metadata accumulated during construction.

===== connectedTo method

[source,tcl]
----
<<service methods>>=
method connectedTo {} {
    my variable connId
    return $connId
}
................................................................................
} -cleanup {
    sysBus destroy
} -body {
    DBus connectedTo
} -result $conn
----

===== pathList method

[source,tcl]
----
<<service methods>>=
method pathList {} {
    return [relation list [relvar set Path] Name] ;         # <1>
}
----
<1> Since `Name` is an identifier for *Path*, we are assured that
the returned list is actually a set.

/////////
----
<<man service methods>>=
[call [cmd "[arg svcobj] pathList"]]

The [method pathList] method returns a list of object instance path
................................................................................
    Service create DBus org.freedesktop.DBus $conn
} -cleanup {
    sysBus destroy
} -body {
    DBus pathList
} -result {/ /org/freedesktop/DBus} -match set
----

===== findPathsByPropertyValue method

[source,tcl]
----
<<service methods>>=
method findPathsByPropertyValue {interface property expression} {
    set matches [pipe {
        relvar set PropertyValue |
................................................................................
        {"org.freedesktop.DBus.Monitoring" in $Value}
}]

returns the object whose path is [cmd /org/freedesktop/DBus].
----
/////////

===== pathInterfaces method

[source,tcl]
----
<<service methods>>=
method pathInterfaces {path} {
    return [pipe {
        relvar set Implementation |
        relation restrictwith ~ {$Path eq $path} |
        relation list ~ Interface
    }]
}
----

For these tests, we want to be able to compare sets for equality.
Fortunately, `tcllib` provides all the need commands and
`tcltest` allows us to define custom matching procedures.

.Tests

[source,tcl]
----
<<required packages for test>>=
package require struct::set
................................................................................
[call [cmd "[arg svcobj] pathInterfaces"] [arg path]]

The [method pathInterfaces] method returns a list of interfaces that are
implemented for [arg path].
----
/////////

===== pathProperties method

[source,tcl]
----
<<service methods>>=
method pathProperties {path interface} {
    return [pipe {
        relvar set PropertyValue |
        relation restrictwith ~\
................................................................................
<<man service methods>>=
[call [cmd "[arg svcobj] pathProperties"] [arg path] [arg interface]]

The [method pathProperties] method returns a list of property names that are
implemented by [arg interface] for the object specified by [arg path].
----
/////////

===== interfaceMethods method

[source,tcl]
----
<<service methods>>=
method interfaceMethods {interface} {
    return [pipe {
        relvar set Method |
................................................................................
[call [cmd "[arg svcobj] interfaceMethods"] [arg interface]]

The [method interfaceMethods] method returns a list of methods supported
by the specified [arg interface].
----
/////////

===== methodSignature method

[source,tcl]
----
<<service methods>>=
method methodSignature {interface method} {
    return [pipe {
        relvar restrictone Method Interface $interface Name $method |
        relation extract ~ Signature
................................................................................
<<man service methods>>=
[call [cmd "[arg svcobj] methodSignature"] [arg interface] [arg method]]

The [method methodSignature] method returns the DBus signature
string for the specified [arg interface] and [arg method].
----
/////////

===== interfaceProperties method

[source,tcl]
----
<<service methods>>=
method interfaceProperties {interface} {
    return [pipe {
        relvar set Property |
................................................................................
[call [cmd "[arg svcobj] interfaceProperties"] [arg interface]]

The [method interfaceProperties] method returns a list of properties defined
by [arg interface].
----
/////////

===== interfaceSignals method

[source,tcl]
----
<<service methods>>=
method interfaceSignals {interface} {
    return [pipe {
        relvar set Signal |
        relation restrictwith ~ {$Interface eq $interface} |
................................................................................
<<man service methods>>=
[call [cmd "[arg svcobj] interfaceSignals"] [arg interface]]

The [method interfaceSignals] method returns a list of signals defined
by [arg interface].
----
/////////

==== A test server

It is convenient to put up our own service against which we can test.
Fortunately,
the [package dbif] package, also by Schelte Bron, provides some
convenient commands to do that.
In this section we show a test server build using
the [package dbif] package.
This server is then used for testing other parts of this package.

[source,tcl]
----
<<test-server.tcl>>=
package require dbif

puts stderr "test server starting"

dbif connect -bus session -noqueue -replace com.modelrealization.test

<<test server methods>>
<<test server properties>>
<<test server signals>>

vwait forever
----

[source,tcl]
----
<<test server methods>>=
dbif method /com/modelrealization/test AddToCounter {cnt} {i} {
    incr ::Counter $cnt
    dbif return $msgid $::Counter
}

dbif method /com/modelrealization/test Quit {
    dbif return $msgid {}
    puts stderr "test server exiting"
    exit
}

dbif method /com/modelrealization/test Trigger {
    dbif generate $::AttnSigId
}
----

[source,tcl]
----
<<test server properties>>=
dbif property -attributes {Property.EmitsChangedSignal true}\
        /com/modelrealization/test Counter:i Counter
set ::Counter 0

dbif property /com/modelrealization/test Name:s Name
set ::Name "Test Server"

dbif property -access read\
        /com/modelrealization/test Source:s Source
set ::Source "Model Realization"
----

[source,tcl]
----
<<test server signals>>=
set ::AttnSigId [dbif signal /com/modelrealization/test Attention\
        {Count:i Identity:s} {} {
    return [list $::Counter $::Source]
}]
----

[source,tcl]
----
<<test utilities>>=
exec tclsh test-server.tcl &
----

[source,tcl]
----
<<test utilities>>=
proc killServer {} {
    set conn [Connection create sessionBus session]
    Service create tserver com.modelrealization.test $conn
    tserver call /com/modelrealization/test com.modelrealization.test\
            Quit

    $conn destroy
}
----

==== Calling methods

[source,tcl]
----
<<service methods>>=
method call {path interface method args} {
................................................................................
    return $value
}
----

[source,tcl]
----
<<service tests>>=
test property-1.0 {
    Get a property from the test server
} -setup {
    set conn [Connection create sessionBus session]
    Service create tserver com.modelrealization.test $conn
} -cleanup {
    sessionBus destroy
} -body {
    tserver property\
            /com/modelrealization/test com.modelrealization.test Counter


} -result {0}
----

[source,tcl]
----
<<service tests>>=
test property-2.0 {
    Set an property value
} -setup {
    set conn [Connection create sessionBus session]
    Service create tserver com.modelrealization.test $conn
} -cleanup {
    tserver waitForProperty com.modelrealization.test Counter\
        /com/modelrealization/test\
        {tserver property /com/modelrealization/test\
            com.modelrealization.test Counter 100}
    sessionBus destroy
} -body {

    set chng [tserver waitForProperty com.modelrealization.test Counter\
        /com/modelrealization/test\
        {tserver property /com/modelrealization/test\
            com.modelrealization.test Counter 100}]
    dict get $chng value
} -result {100}
----

/////////
----
<<man service methods>>=
................................................................................
            throw [list TRACE UNKNOWNOP $msg] $msg
        }
    }
    return $result
}
----



















[source,tcl]
----
<<service methods>>=
method AddTrace {argList} {
    if {[llength $argList] < 2} {
        set msg "wrong # of args, expected: trace add tracetype args"
        throw [list TRACE WRONGARGS $msg] $msg
................................................................................
        rvajoin ~ [relvar set PathTrace] Path |
        rvajoin ~ [relvar set SignalTrace] Signal |
        rvajoin ~ [relvar set PropertyTrace] Property
    }]
    if {[relation isnotempty $trace]} {
        relation assign $trace

        variable connId
        relvar eval {
            relvar deleteone Trace TraceId $traceid
            if {[relation isnotempty $Path]} {
                relvar deleteone PathTrace TraceId $traceid
            } elseif {[relation isnotempty $Signal]} {
                relation assign $Signal Interface Signal
                $connId listen {} $Interface.$Signal {} ;           # <1>
................................................................................
    if {[relation isnotempty $trace]} {
        relation assign $trace
        if {[relation isnotempty $Path]} {
            set result [pipe {
                relation project $trace PathMatch CmdPrefix Path |
                relation ungroup ~ Path
            }]
            set tracetype path
        } elseif {[relation isnotempty $Signal]} {
            set result [pipe {
                relation project $trace PathMatch CmdPrefix Signal |
                relation ungroup ~ Signal
            }]
            set tracetype signal
        } elseif {[relation isnotempty $Property]} {
            set result [pipe {
                relation project $trace PathMatch CmdPrefix Property |
                relation ungroup ~ Property
            }]
            set tracetype property
        }
        log::debug "Info Trace result:\n[relformat $result]"
        set result [lindex [relation body $result] 0]
        lappend result Type $tracetype
        return $result
    } else {
        set msg "unknown trace, \"$traceid\""
        throw [list INFO UNKNOWNTRACE $msg] $msg
    }


}
----

/////////
----
<<man service methods>>=
[call [cmd "[arg svcobj] trace"] [arg operation] [arg type] [arg [opt args]]]

The [method trace] method causes Tcl commands to be executed when
certain conditions on the DBus are met.
The interface for this method is modeled after the core [cmd trace] command.
Legal [arg operation] argument values are:

[list_begin definitions]
[call [cmd "[arg svcobj] trace add"] [arg type] [arg [opt args]]]
The legal values for the [arg type] trace type are [var path],
[var signal], or [var property].
The return value of the command is a trace identifier,
which can be used to remove or query the trace.
Multiple traces may be added of any type and the parameters of the
trace may be the same.
Traces are executed in order from youngest (most recently added) to
oldest.

[list_begin definitions]
[call [cmd "[arg svcobj] trace add path"] [arg pathpattern] [arg cmdprefix]]
Arranges for [arg cmdprefix] to be invoked whenever an object instance
whose name matches [arg pathpattern] is added or removed from the service.
The matching against [arg pathpattern] is done in the same manner as
the [cmd "string match"] command.
When invoked, [arg cmdprefix] is supplied with two additional arguments,
a [arg status], which has a value of either [var added] or [var removed],
and the name of the added or removed path.

[call [cmd "[arg svcobj] trace add signal"] [arg interface]\
        [arg signal] [arg pathpattern] [arg cmdprefix]]

Arranges for [arg cmdprefix] to be invoked when the [arg signal] from
[arg interface] on an object instance matching [arg pathpattern]
is detected on the bus.
The matching against [arg pathpattern] is done in the same manner as
the [cmd "string match"] command.
When invoked, [arg cmdprefix] is supplied with additional arguments.
The first argument is a dictionary of event information as described
in the Event Handlers section of the [package dbus] package documentation.
Any arguments of the signal itself follow.

[call [cmd "[arg svcobj] trace add property"] [arg interface]\
        [arg property] [arg pathpattern] [arg cmdprefix]]

Arranges for [arg cmdprefix] to be invoked when the [arg property] associated
with [arg interface] for an object instance matching [arg pathpattern]
is reported.
The matching against [arg pathpattern] is done in the same manner as
the [cmd "string match"] command.
When invoked,
[arg cmdprefix] is supplied with up to five additional arguments.
The first argument is a status value of [var changed] or [var invalidated],
indicating if the property value has changed or is no longer valid.
The second argument is the path name of the object instance whose
property was affected.
The third argument is the name of the interface of which the property was
part.
The fourth argument is the name of the property that was affected.
If the status was [var changed], a fifth argument is supplied giving the
new value of the property.
[list_end]

[call [cmd "[arg svcobj] trace remove"] [arg traceid]]
Removes the trace identified by [arg traceid].
It is not an error to remove a non-existant trace.

[call [cmd "[arg svcobj] trace info"] [arg traceid]]
Returns a dictionary containing information about the trace specified
by [arg traceid].
The keys of the dictionary are:

[list_begin definitions]
[def Type]
Specifies the type of trace as either [var path], [var signal],
or [var property].
[def PathMatch]
Specifies the pattern that object instance path names must match
to trigger the trace.
[def CmdPrefix]
Specifies the command prefix to invoke when the trace performed.
[list_end]

For [var signal] type traces additional keys are:
[list_begin definitions]
[def Interface]
Specifies the interface that will trigger the trace.
[def Signal]
Specifies the name of the signal that will trigger the trace.
[list_end]

For [var property] type traces additional keys are:
[list_begin definitions]
[def Interface]
Specifies the interface that will trigger the trace.
[def Property]
Specifies the name of the property that will trigger the trace.
[list_end]

For [var path] type traces no additional information is provided.

[list_end]
----
/////////

==== Synchronizing to traces

[source,tcl]
................................................................................
Then the script specified by [arg trigger] is executed in the
call stack of the caller.
Then the Tcl event loop is entered waiting for the property change
to occur.
If [arg timeout] is specified it is the number of milliseconds to
wait for the property change notification.
A [arg timeout] value of 0 is interpreted to mean to wait forever.
The default [arg timeout] value is 5000.
If [arg trigger] executes successfully and the DBus notification is
received before any timeout,
then the return value of the command is a dictionary giving the details
of the property change.
The keys to the dictionary are:

[list_begin definitions]
................................................................................
----
<<service methods>>=
method PropertySyncTimeout {} {
    set [my varname propSync] TIMEOUT
    return
}
----

/////////
----
<<man service methods>>=
[call [cmd "[arg svcobj] waitForSignal"] [arg interface] [arg signal]\
    [arg pathpattern] [arg trigger] [arg [opt timeout]]]

The [method waitForSignal] method establishes a signal trace on the
[arg signal] signal in [arg interface] matching [arg pathpattern].
These arguments are interpreted in the same manner as for the
[method "trace add"] method.
Then the script specified by [arg trigger] is executed in the
call stack of the caller.
Then the Tcl event loop is entered waiting for the signal notification
to occur.
If [arg timeout] is specified it is the number of milliseconds to
wait for the property change notification.
A [arg timeout] value of 0 is interpreted to mean to wait forever.
The default [arg timeout] value is 5000.
If [arg trigger] executes successfully and the DBus signal is
received before any timeout,
then the return value of the command is a dictionary giving the details
of the signal.
The keys to the dictionary are:

[list_begin definitions]
[def path]
The path name of the object to which the change occurred.
[def interface]
The interface of the changed property.
[def signal]
The name of the received signal.
[def sender]
The sender of the signal.
[def signature]
The argument signature of the signal.
[def args]
A list of argument values that came with the signal.
[list_end]
----
/////////

[source,tcl]
----
<<service methods>>=
method waitForSignal {interface signal pathpattern trigger {timeout 5000}} {
    set timerid {}
    if {$timeout != 0} {
................................................................................
        set msg "timed out waiting for signal change: $interface $signal\
                $pathpattern $trigger"
        throw [list SIGNAL TIMEOUT $msg] $msg
    }
    return $sigSync
}
----

[source,tcl]
----
<<service tests>>=
test signal-1.0 {
    Wait for a signal
} -setup {
    set conn [Connection create sessionBus session]
    Service create tserver com.modelrealization.test $conn
} -cleanup {
    sessionBus destroy
} -body {
    set chng [tserver waitForSignal com.modelrealization.test Attention\
        /com/modelrealization/test\
        {tserver call /com/modelrealization/test\
            com.modelrealization.test Trigger}]
    dict get $chng args
} -result {100 {Model Realization}}
----

[source,tcl]
----
<<service tests>>=
test signal-2.0 {
    Wait for a signal -- timeout
} -setup {
    set conn [Connection create sessionBus session]
    Service create tserver com.modelrealization.test $conn
} -cleanup {
    sessionBus destroy
} -body {
    tserver waitForSignal com.modelrealization.test Attention\
        /com/modelrealization/test {} 500
} -result {timed out waiting for signal change:*}\
    -match glob -returnCodes error
----

[source,tcl]
----
<<service methods>>=
method SignalSync {eventInfo args} {
    set [my varname sigSync] [dict create\
        path [dict get $eventInfo path]\
        interface [dict get $eventInfo interface]\
        signal [dict get $eventInfo member]\
        sender [dict get $eventInfo sender]\
        signature [dict get $eventInfo signature]\
        args $args\
    ]
    return
}
................................................................................
----
<<service methods>>=
method waitForPath {pathpattern trigger {timeout 5000}} {
    set timerid {}
    if {$timeout != 0} {
        set timerid [::after $timeout [mymethod PathSyncTimeout]]
    }
    set traceId [my trace add path $pathpattern [mymethod PathSync]]
    set result [uplevel 1 $trigger]

    vwait [my varname pathSync]
    if {$timerid ne {}} {
        ::after cancel $timerid
    }

................................................................................
Then the script specified by [arg trigger] is executed in the
call stack of the caller.
Then the Tcl event loop is entered waiting for the path change
to occur.
If [arg timeout] is specified it is the number of milliseconds to
wait for the property change notification.
A [arg timeout] value of 0 is interpreted to mean to wait forever.
The default [arg timeout] value is 5000.
If [arg trigger] executes successfully and the DBus notification is
received before any timeout,
then the return value of the command is a dictionary giving the details
of the path change.
The keys to the dictionary are:

[list_begin definitions]

Changes to dbusclient/test/thunder.test.

49
50
51
52
53
54
55

56
57


58




59
60
61
62
63
64
65
..
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
...
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164

165
166
167
168

169

170
171
172
173
174

175
176

177
178
179


180
181
182
183
184
185
186
187

# source ../code/dbusclient.tcl
package require dbusclient

# Add custom arguments here.
set optlist {
    {level.arg notice {Log debug level}}

    {nodelete {Don't delete Thundersense device when done}}
}


array set options [::cmdline::getKnownOptions argv $optlist]





control::control assert enabled true

logger::setlevel $options(level)
set logger [::logger::init thunder]
::logger::utils::applyAppender -appender colorConsole -serviceCmd $logger\
        -appenderArgs {-conversionPattern {\[%c\] \[%p\] '%m'}}
................................................................................
    log::info "testing dbusclient version: [package require dbusclient]"

    log::info "connecting to org.bluez on the system bus"
    Connection create ::sysBus system
    Service create org.bluez org.bluez ::sysBus

    set path [org.bluez findPathsByPropertyValue org.bluez.Device1\
            Name {[string match Thunder* $Value]}]
    log::debug "paths matching Thunder*: \"$path\""

    if {[llength $path] == 0} {
        log::notice "starting discovery"
        set discovering [org.bluez waitForProperty org.bluez.Adapter1\
                Discovering /org/bluez/hci0\
                {org.bluez call /org/bluez/hci0\
                    org.bluez.Adapter1 StartDiscovery}]
        assert {[dict get $discovering value] == 1} "Discovering property is not 1"

        while {true} {
            try {
                set newName [org.bluez waitForProperty org.bluez.Device1\
                    Name /org/bluez/hci0/dev* {} 10000]
                if {[string match Thunder* [dict get $newName value]]} {
                    set path [dict get $newName path]
                    break
                }
            } on error {result} {
                log::error $result
                return
            } finally {
................................................................................
            log::info "cannot get $prop value"
        }
    }

    set uuids [org.bluez property $path org.bluez.Device1 UUIDs]
    puts "services for $path"
    foreach uuid $uuids {
        set name [pipe {
            relvar restrictone Entity UUID $uuid |
            relation extract ~ Name
        }]
        set svcpath [org.bluez findPathsByPropertyValue org.bluez.GattService1\
                UUID {$uuid eq $Value}]

        puts "Service: $name ==> $uuid, on path $svcpath"

        set charpaths [org.bluez findPathsByPropertyValue org.bluez.GattCharacteristic1\
                Service {$svcpath eq $Value}]
        puts "    Characteristics:"
        foreach charpath $charpaths {
            set cuuid [org.bluez property $charpath org.bluez.GattCharacteristic1 UUID]
            set cname [pipe {
                relvar restrictone Entity UUID $cuuid |

                relation extract ~ Name
            }]

            set flags [org.bluez property $charpath org.bluez.GattCharacteristic1 Flags]

            if {"read" in $flags} {

                set value [org.bluez call $charpath org.bluez.GattCharacteristic1 ReadValue {}]
            } else {
                set value "not readable"
            }
            puts "    $cname ==> $value\n        UUID ==> $cuuid, Path ==> $charpath"


            set descpaths [org.bluez findPathsByPropertyValue org.bluez.GattDescriptor1\

                    Characteristic {$charpath eq $Value}]
            foreach descpath $descpaths {
                set duuid [org.bluez property $descpath org.bluez.GattDescriptor1 UUID]


                set dvalue [org.bluez call $descpath org.bluez.GattDescriptor1 ReadValue {}]

                puts "        Descriptor: UUID = $duuid, Value = $dvalue"
            }
        }
        puts {}
    }








>
|

>
>
|
>
>
>
>







 







|
|













|







 







|
|
|
|










<
|
>
|
<

|
>

>
|



|
>

|
>


|
>
>
|







49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
..
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
...
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169

170
171
172

173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199

# source ../code/dbusclient.tcl
package require dbusclient

# Add custom arguments here.
set optlist {
    {level.arg notice {Log debug level}}
    {name.arg {Thunder*} {Device name to look for}}
    {nodelete {Don't delete device when done}}
}

try {
    array set options [::cmdline::getoptions argv $optlist]
} on error {result} {
    puts -nonewline stderr $result
    exit 1
}

control::control assert enabled true

logger::setlevel $options(level)
set logger [::logger::init thunder]
::logger::utils::applyAppender -appender colorConsole -serviceCmd $logger\
        -appenderArgs {-conversionPattern {\[%c\] \[%p\] '%m'}}
................................................................................
    log::info "testing dbusclient version: [package require dbusclient]"

    log::info "connecting to org.bluez on the system bus"
    Connection create ::sysBus system
    Service create org.bluez org.bluez ::sysBus

    set path [org.bluez findPathsByPropertyValue org.bluez.Device1\
            Name {[string match $::options(name) $Value]}]
    log::debug "paths matching $::options(name) : \"$path\""

    if {[llength $path] == 0} {
        log::notice "starting discovery"
        set discovering [org.bluez waitForProperty org.bluez.Adapter1\
                Discovering /org/bluez/hci0\
                {org.bluez call /org/bluez/hci0\
                    org.bluez.Adapter1 StartDiscovery}]
        assert {[dict get $discovering value] == 1} "Discovering property is not 1"

        while {true} {
            try {
                set newName [org.bluez waitForProperty org.bluez.Device1\
                    Name /org/bluez/hci0/dev* {} 10000]
                if {[string match $::options(name) [dict get $newName value]]} {
                    set path [dict get $newName path]
                    break
                }
            } on error {result} {
                log::error $result
                return
            } finally {
................................................................................
            log::info "cannot get $prop value"
        }
    }

    set uuids [org.bluez property $path org.bluez.Device1 UUIDs]
    puts "services for $path"
    foreach uuid $uuids {
        set svcEntity [relvar restrictone Entity UUID $uuid]
        set name [expr {[relation isempty $svcEntity] ?\
                "unknown" : [relation extract $svcEntity Name]}]

        set svcpath [org.bluez findPathsByPropertyValue org.bluez.GattService1\
                UUID {$uuid eq $Value}]

        puts "Service: $name ==> $uuid, on path $svcpath"

        set charpaths [org.bluez findPathsByPropertyValue org.bluez.GattCharacteristic1\
                Service {$svcpath eq $Value}]
        puts "    Characteristics:"
        foreach charpath $charpaths {
            set cuuid [org.bluez property $charpath org.bluez.GattCharacteristic1 UUID]

            set chEntity [relvar restrictone Entity UUID $cuuid]
            set cname [expr {[relation isempty $chEntity] ?\
                    "unknown" : [relation extract $chEntity Name]}]


            set flags [org.bluez property $charpath\
                    org.bluez.GattCharacteristic1 Flags]
            if {"read" in $flags} {
                set value [org.bluez call $charpath\
                        org.bluez.GattCharacteristic1 ReadValue {}]
            } else {
                set value "not readable"
            }
            puts "    $cname ==> $value\n        UUID ==> $cuuid,\
                    Path ==> $charpath"

            set descpaths [org.bluez findPathsByPropertyValue\
                    org.bluez.GattDescriptor1\
                    Characteristic {$charpath eq $Value}]
            foreach descpath $descpaths {
                set duuid [org.bluez property $descpath\
                        org.bluez.GattDescriptor1 UUID]
                set dvalue [org.bluez call $descpath\
                        org.bluez.GattDescriptor1 ReadValue {}]

                puts "        Descriptor: UUID = $duuid, Value = $dvalue"
            }
        }
        puts {}
    }