Tcl DBus Interface

Check-in [78cd7df89f]
Login

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

Overview
Comment:- Adapt the code to changes in dbus-tcl - Add a 'dbif pave' command for creating a path without any specific methods or signals. This may be useful for paths that only contain universal methods and/or signals. - Add a -single option to 'dbif delete' to only delete the specified path and leave the underlying structure in place. - Change the error code for unknown properties from InvalidArgs to the more apt UnknownProperty. - Undefine methods by specifying an empty body. - Pass the msgid to the property body code. - Improve error reporting when property variables are set to a value that doesn't match the signature. - Simplify the generation of xml data for introspection. - Bump version to 1.3
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk | master
Files: files | file ages | folders
SHA3-256:78cd7df89f3d88f39d5fc8fd8ab44f30e5b77e1406760afd7aef91b28186ccfc
User & Date: schelte 2017-06-10 12:51:10
Context
2017-06-10
13:11
- Add information about how to obtain the dbus handle. check-in: 4898c5e31c user: schelte tags: trunk, master
12:51
- Adapt the code to changes in dbus-tcl - Add a 'dbif pave' command for creating a path without any specific methods or signals. This may be useful for paths that only contain universal methods and/or signals. - Add a -single option to 'dbif delete' to only delete the specified path and leave the underlying structure in place. - Change the error code for unknown properties from InvalidArgs to the more apt UnknownProperty. - Undefine methods by specifying an empty body. - Pass the msgid to the property body code. - Improve error reporting when property variables are set to a value that doesn't match the signature. - Simplify the generation of xml data for introspection. - Bump version to 1.3 check-in: 78cd7df89f user: schelte tags: trunk, master
2016-12-06
21:00
- Properly handle complex signatures for properties. check-in: 6eedce8d1b user: schelte tags: trunk, master
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to configure.

1
2
3
4
5
6
7
8
9
10
...
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
....
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
....
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
....
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
....
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
....
3986
3987
3988
3989
3990
3991
3992
3993
3994
3995
3996
3997
3998
3999
4000
....
4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
#! /bin/sh
# Guess values for system-dependent variables and create Makefiles.
# Generated by GNU Autoconf 2.69 for dbif 1.2.
#
#
# Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc.
#
#
# This configure script is free software; the Free Software Foundation
# gives unlimited permission to copy, distribute and modify it.
................................................................................
subdirs=
MFLAGS=
MAKEFLAGS=

# Identity of this package.
PACKAGE_NAME='dbif'
PACKAGE_TARNAME='dbif'
PACKAGE_VERSION='1.2'
PACKAGE_STRING='dbif 1.2'
PACKAGE_BUGREPORT=''
PACKAGE_URL=''

ac_subst_vars='LTLIBOBJS
LIBOBJS
INSTALLDOC
DTPLITE_PROG
................................................................................
#
# Report the --help message.
#
if test "$ac_init_help" = "long"; then
  # Omit some internal or obsolete options to make the list less imposing.
  # This message is too long to be a string in the A/UX 3.1 sh.
  cat <<_ACEOF
\`configure' configures dbif 1.2 to adapt to many kinds of systems.

Usage: $0 [OPTION]... [VAR=VALUE]...

To assign environment variables (e.g., CC, CFLAGS...), specify them as
VAR=VALUE.  See below for descriptions of some of the useful variables.

Defaults for the options are specified in brackets.
................................................................................

  cat <<\_ACEOF
_ACEOF
fi

if test -n "$ac_init_help"; then
  case $ac_init_help in
     short | recursive ) echo "Configuration of dbif 1.2:";;
   esac
  cat <<\_ACEOF

Optional Packages:
  --with-PACKAGE[=ARG]    use PACKAGE [ARG=yes]
  --without-PACKAGE       do not use PACKAGE (same as --with-PACKAGE=no)
  --with-tcl              directory containing tcl configuration
................................................................................
    cd "$ac_pwd" || { ac_status=$?; break; }
  done
fi

test -n "$ac_init_help" && exit $ac_status
if $ac_init_version; then
  cat <<\_ACEOF
dbif configure 1.2
generated by GNU Autoconf 2.69

Copyright (C) 2012 Free Software Foundation, Inc.
This configure script is free software; the Free Software Foundation
gives unlimited permission to copy, distribute and modify it.
_ACEOF
  exit
................................................................................
  as_fn_set_status $ac_retval

} # ac_fn_c_try_compile
cat >config.log <<_ACEOF
This file contains any messages produced by compilers while
running configure, to aid debugging if configure makes a mistake.

It was created by dbif $as_me 1.2, which was
generated by GNU Autoconf 2.69.  Invocation command line was

  $ $0 $@

_ACEOF
exec 5>>config.log
{
................................................................................
test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1

cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
# Save the log message, to keep $0 and so on meaningful, and to
# report actual input values of CONFIG_FILES etc. instead of their
# values after options handling.
ac_log="
This file was extended by dbif $as_me 1.2, which was
generated by GNU Autoconf 2.69.  Invocation command line was

  CONFIG_FILES    = $CONFIG_FILES
  CONFIG_HEADERS  = $CONFIG_HEADERS
  CONFIG_LINKS    = $CONFIG_LINKS
  CONFIG_COMMANDS = $CONFIG_COMMANDS
  $ $0 $@
................................................................................

Report bugs to the package provider."

_ACEOF
cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`"
ac_cs_version="\\
dbif config.status 1.2
configured by $0, generated by GNU Autoconf 2.69,
  with options \\"\$ac_cs_config\\"

Copyright (C) 2012 Free Software Foundation, Inc.
This config.status script is free software; the Free Software Foundation
gives unlimited permission to copy, distribute and modify it."



|







 







|
|







 







|







 







|







 







|







 







|







 







|







 







|







1
2
3
4
5
6
7
8
9
10
...
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
....
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
....
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
....
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
....
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
....
3986
3987
3988
3989
3990
3991
3992
3993
3994
3995
3996
3997
3998
3999
4000
....
4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
#! /bin/sh
# Guess values for system-dependent variables and create Makefiles.
# Generated by GNU Autoconf 2.69 for dbif 1.3.
#
#
# Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc.
#
#
# This configure script is free software; the Free Software Foundation
# gives unlimited permission to copy, distribute and modify it.
................................................................................
subdirs=
MFLAGS=
MAKEFLAGS=

# Identity of this package.
PACKAGE_NAME='dbif'
PACKAGE_TARNAME='dbif'
PACKAGE_VERSION='1.3'
PACKAGE_STRING='dbif 1.3'
PACKAGE_BUGREPORT=''
PACKAGE_URL=''

ac_subst_vars='LTLIBOBJS
LIBOBJS
INSTALLDOC
DTPLITE_PROG
................................................................................
#
# Report the --help message.
#
if test "$ac_init_help" = "long"; then
  # Omit some internal or obsolete options to make the list less imposing.
  # This message is too long to be a string in the A/UX 3.1 sh.
  cat <<_ACEOF
\`configure' configures dbif 1.3 to adapt to many kinds of systems.

Usage: $0 [OPTION]... [VAR=VALUE]...

To assign environment variables (e.g., CC, CFLAGS...), specify them as
VAR=VALUE.  See below for descriptions of some of the useful variables.

Defaults for the options are specified in brackets.
................................................................................

  cat <<\_ACEOF
_ACEOF
fi

if test -n "$ac_init_help"; then
  case $ac_init_help in
     short | recursive ) echo "Configuration of dbif 1.3:";;
   esac
  cat <<\_ACEOF

Optional Packages:
  --with-PACKAGE[=ARG]    use PACKAGE [ARG=yes]
  --without-PACKAGE       do not use PACKAGE (same as --with-PACKAGE=no)
  --with-tcl              directory containing tcl configuration
................................................................................
    cd "$ac_pwd" || { ac_status=$?; break; }
  done
fi

test -n "$ac_init_help" && exit $ac_status
if $ac_init_version; then
  cat <<\_ACEOF
dbif configure 1.3
generated by GNU Autoconf 2.69

Copyright (C) 2012 Free Software Foundation, Inc.
This configure script is free software; the Free Software Foundation
gives unlimited permission to copy, distribute and modify it.
_ACEOF
  exit
................................................................................
  as_fn_set_status $ac_retval

} # ac_fn_c_try_compile
cat >config.log <<_ACEOF
This file contains any messages produced by compilers while
running configure, to aid debugging if configure makes a mistake.

It was created by dbif $as_me 1.3, which was
generated by GNU Autoconf 2.69.  Invocation command line was

  $ $0 $@

_ACEOF
exec 5>>config.log
{
................................................................................
test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1

cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
# Save the log message, to keep $0 and so on meaningful, and to
# report actual input values of CONFIG_FILES etc. instead of their
# values after options handling.
ac_log="
This file was extended by dbif $as_me 1.3, which was
generated by GNU Autoconf 2.69.  Invocation command line was

  CONFIG_FILES    = $CONFIG_FILES
  CONFIG_HEADERS  = $CONFIG_HEADERS
  CONFIG_LINKS    = $CONFIG_LINKS
  CONFIG_COMMANDS = $CONFIG_COMMANDS
  $ $0 $@
................................................................................

Report bugs to the package provider."

_ACEOF
cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`"
ac_cs_version="\\
dbif config.status 1.3
configured by $0, generated by GNU Autoconf 2.69,
  with options \\"\$ac_cs_config\\"

Copyright (C) 2012 Free Software Foundation, Inc.
This config.status script is free software; the Free Software Foundation
gives unlimited permission to copy, distribute and modify it."

Changes to configure.ac.

15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
# This initializes the environment with PACKAGE_NAME and PACKAGE_VERSION
# set as provided.  These will also be added as -D defs in your Makefile
# so you can encode the package version directly into the source files.
# This will also define a special symbol for Windows (BUILD_<PACKAGE_NAME>
# so that we create the export library with the dll.
#-----------------------------------------------------------------------

AC_INIT([dbif], [1.2])

#--------------------------------------------------------------------
# Call TEA_INIT as the first TEA_ macro to set up initial vars.
# This will define a ${TEA_PLATFORM} variable == "unix" or "windows"
# as well as PKG_LIB_FILE and PKG_STUB_LIB_FILE.
#--------------------------------------------------------------------








|







15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
# This initializes the environment with PACKAGE_NAME and PACKAGE_VERSION
# set as provided.  These will also be added as -D defs in your Makefile
# so you can encode the package version directly into the source files.
# This will also define a special symbol for Windows (BUILD_<PACKAGE_NAME>
# so that we create the export library with the dll.
#-----------------------------------------------------------------------

AC_INIT([dbif], [1.3])

#--------------------------------------------------------------------
# Call TEA_INIT as the first TEA_ macro to set up initial vars.
# This will define a ${TEA_PLATFORM} variable == "unix" or "windows"
# as well as PKG_LIB_FILE and PKG_STUB_LIB_FILE.
#--------------------------------------------------------------------

Changes to dbif.tcl.

3
4
5
6
7
8
9
10
11
12
13
14
15



16
17
18
19
20
21
22
..
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
..
50
51
52
53
54
55
56





57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
..
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
...
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
...
145
146
147
148
149
150
151

152
153
154
155
156
157
158
159
160
161








162
163
164
165
166
167
168
...
275
276
277
278
279
280
281

282
283
284
285
286
287
288
...
306
307
308
309
310
311
312













313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
...
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
...
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
...
411
412
413
414
415
416
417

418
419
420
421
422





423


424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
...
456
457
458
459
460
461
462

463
464
465
466
467
468
469

470
471
472
473
474
475
476
477
478
479
480

481
482
483
484
485
486
487
488
489
490
...
495
496
497
498
499
500
501

502
503
504



505
506
507
508
509
510
511
512
513
514
515
516
517

518
519
520
521
522
523
524
525
526














527
528

529
530
531
532
533





534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
...
556
557
558
559
560
561
562

563
564
565
566
567
568
569
...
571
572
573
574
575
576
577





578
579
580
581
582

583

584
585
586
587
588
589
590
...
609
610
611
612
613
614
615
616
617


618
619
620
621
622
623
624
625
626
627
628

629
630
631
632
633
634
635
636
...
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
...
681
682
683
684
685
686
687

688
689
690

691



692

693
694


695


696
697
698
699
700
701
702
















703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734




735





736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
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
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886

887

888
889
890
891
892
893
894
895
896
897
898

899
900
901

902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919






920
921
922
923
924
925






926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941





942
943

944
945
946
947
948


949
950
951
952
953
954
955
956
957
958
959
960
961
962

963







964
965
966





967
968
969
970


971
972
973
974
975
976




977
978
979
980
981
982
983
984





985
986
987

988

989

990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
....
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019

1020



1021



1022

1023
1024
1025
1026
1027
1028
1029
1030





1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
....
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
#
# The following interfaces are supported:
#	org.freedesktop.DBus.Peer
#	org.freedesktop.DBus.Introspectable
#	org.freedesktop.DBus.Properties

package require dbus 2.1
package provide dbif 1.2
package provide dbus-intf 1.2

namespace eval dbus::dbif {
    # Setup some defaults in case the user doesn't specify certain options
    variable defaults [dict create bus session intf com.tclcode.default]




    # Store a copy of the message info of the last received message so it
    # won't be necessary to pass it around all the time
    variable info

    # Information about the available methods, signals and properties is
    # stored in an array of dicts
................................................................................
    # Information about signals is stored for easy access by ID
    variable signal

    # Automatically emit a PropertiesChanged signal when properties change
    variable trace 1
    # PropertiesChanged signal definition to be reused for every path/intf
    set signal(PropertiesChanged) {
	bus ""
	path ""
	interface org.freedesktop.DBus.Properties
	name PropertiesChanged
	signature sa{sv}as
	command ::dbus::dbif::propchanged
	interp {}
	meta {}
................................................................................

    # Various counters for generating unique IDs
    variable msgid 0 sigid 0

    # Expiry time for messages waiting for a response
    variable timeout 25000






    # Create the dbif ensemble command
    namespace ensemble create -command ::dbif -subcommands {
	default connect method signal property generate listen \
	  return error get delete
    } -map {return {respond return} error {respond error}}
}

########################################################################
# Helper procedures
########################################################################

# Procedure for returning error messages to the caller
#
proc dbus::dbif::dbuserr {type bus args} {
    upvar #1 data data
    if {[dict get $data noreply]} {return -level [info level] -async 1}
    set error org.freedesktop.DBus.Error.Failed
    switch -- $type {
	path {
	    lassign $args path
	    set msg "No such object path '$path'"
................................................................................
	    set msg "No such interface '$intf' at object path '$path'"
	    set error org.freedesktop.DBus.Error.UnknownInterface
	}
	property {
	    lassign $args path intf name
	    set msg "No such property '$name' in interface '$intf'\
	      at object path '$path'"
	    set error org.freedesktop.DBus.Error.InvalidArgs
	}
	propunset {
	    lassign $args path intf name
	    set msg "Property '$name' in interface '$intf'\
	      at object path '$path' has currently no value"
	    set error org.freedesktop.DBus.Error.NoValue
	}
................................................................................
	      at object path '$path' does not allow $op access"
	    set error org.freedesktop.DBus.Error.AccessViolation
	}
	default {
	    set msg "Invalid $type"
	}
    }
    dbus error $bus -name $error \
      [dict get $data sender] [dict get $data serial] $msg
    return -level [info level] -async 1
}

# Make sure a new interface on a path has all the necessary parts so it
# doesn't need to be checked every time.
#
proc dbus::dbif::create {bus path intf} {
    variable dbif
    if {![info exists dbif($bus|$path|$intf)]} {
	set dbif($bus|$path|$intf) \
	  [dict create methods {} signals {} properties {}]
    }
}

# Parse a DBus method or signal argument specification list
#
proc dbus::dbif::args {list {thing Argument}} {
................................................................................
	append signature $sig
    }
    return [dict create signature $signature args $args]
}

# Define a method that can be called over the DBus
#

proc dbus::dbif::define {bus path intf name cmd int {in {}} {out {}} {meta {}} {async 0}} {
    variable dbif
    create $bus $path $intf
    set args [args $in]
    dict update args signature sig args inargs {}
    set args [args $out]
    dict update args signature ret args outargs {}
    set dict [dict create command $cmd interp $int signature $ret \
      in $inargs out $outargs meta $meta async $async]
    dict set dbif($bus|$path|$intf) methods $name,$sig $dict








}

# Release the information stored for a message
#
proc dbus::dbif::expire {id} {
    variable info
    if {[info exists info($id)]} {
................................................................................
proc dbus::dbif::namecheck {name {thing Name}} {
    if {[string is wordchar -strict $name]} {return name}
    error "$thing contains invalid characters: \"$name\""
}

proc dbus::dbif::buscheck {name} {
    if {$name in {session system starter}} {return $name}

    if {[regexp {^[a-z]+:([0-9A-Za-z_/.\\,=-]|%[0-9a-fA-F]{2})+$} $name]} {
	set spec [lassign [split $name :,] transport]
	if {[lsearch -not $spec *=*] < 0 && [lsearch $spec *=*=*] < 0} {
	    return $name
	}
    }
    error "Invalid bus: \"$name\"."
................................................................................
proc dbus::dbif::metacheck {data} {
    if {[string is list $data] && ([llength $data] % 2) == 0} {
	# Convert to a dict, removing duplicates (or should they be allowed?)
	return [dict merge {} $data]
    }
    error "Invalid attribute specification. Must be a dict"
}














proc dbus::dbif::async {opts} {
    return [expr {[dict exists $opts -async] && \
      [string is true -strict [dict get $opts -async]]}]
}

proc dbus::dbif::vartrace {op bus path intf name} {
    variable dbif; variable trace
    dict with dbif($bus|$path|$intf) properties $name {
	if {[dict exists $meta Property.EmitsChangedSignal]} {
	    set ecs [dict get $meta Property.EmitsChangedSignal]
	} else {
	    set ecs true
	}
	if {$op eq "add"} {
	    if {!$trace} return
	    if {$access ni {read readwrite}} return
	    if {$ecs ni {true invalidates}} return
	}
	set inv [expr {$ecs eq "invalidates"}]
	set trc [list dbus::dbif::propchg $bus $path $intf $name $inv]
	set cmd [list trace $op variable $variable {write unset} $trc]
	interp eval $interp [list uplevel #0 $cmd]
    }
    return
}

# Needs to be exposed via the regular API?
................................................................................
proc dbus::dbif::changedsignal {state} {
    variable trace
    if {!$state == !$trace} return
    set trace [expr {!!$state}]
    set op [lindex {remove add} $trace]
    variable dbif
    foreach n [array names dbif] {
	lassign [split $n |] bus path intf
	foreach name [dict keys [dict get $dbif($n) properties]] {
	    vartrace $op $bus $path $intf $name
	}
    }
}

# Determine the number of arguments from signatures
proc dbus::dbif::argcount {argspec} {
    set cnt 0
................................................................................
    return $cnt
}

########################################################################
# Ensemble subcommands
########################################################################

# Select which DBus to use (session or system)
#
proc dbus::dbif::default {args} {
    variable defaults
    set opts $defaults
    cmdline opt arg {} $args {
	-bus: {dict set opts bus [buscheck $arg]}
	-interface: {dict set opts intf [intfcheck $arg]}
................................................................................
}

# Connect to the DBus, optionally requesting one or more names to be assigned
# to the current application
#
proc dbus::dbif::connect {args} {
    variable defaults

    set bus [dict get $defaults bus]; set opts {}
    cmdline opt arg args $args {
	-bus: {set bus [buscheck $arg]}
	-yield - -replace - -noqueue {lappend opts $opt}
    }





    dbus connect $bus


    set rc {}; foreach name $args {
    	if {![catch {dbus name $bus {*}$opts $name}]} {
	    lappend rc $name
	}
    }
    if {[dict get $defaults intf] eq "com.tclcode.default" && [llength $args]} {
	dict set defaults intf [lindex $args 0]
	# Path of least surprise. If no defaults have been set up, users will
	# probably expect the bus used for connecting will be the default
	dict set defaults bus $bus
    }
    dbus method $bus {} org.freedesktop.DBus.Peer.Ping dbus::dbif::ping
    dbus method $bus {} org.freedesktop.DBus.Peer.GetMachineId \
      [list dbus::dbif::machineid $bus]
    dbus method $bus {} org.freedesktop.DBus.Introspectable.Introspect \
      [list dbus::dbif::introspect $bus]
    dbus method $bus -details {} org.freedesktop.DBus.Properties.Set \
      [list dbus::dbif::propset $bus]
    dbus method $bus {} org.freedesktop.DBus.Properties.Get \
      [list dbus::dbif::propget $bus]
    dbus method $bus {} org.freedesktop.DBus.Properties.GetAll \
      [list dbus::dbif::propdump $bus]
    # Add the standard interfaces to the API specification
    standard $bus
    return $rc
}

# Define a signal that the application may send
#
proc dbus::dbif::signal {args} {
    variable defaults; variable dbif; variable signal; variable sigid
    dict with defaults {}; set meta {}
................................................................................
    set id ""
    cmdline opt arg {path name {in {}} {opt {}} {arglist {}} {body {}}} $args {
	-id: {set id $arg}
	-bus: {set bus [buscheck $arg]}
	-interface: {set intf [intfcheck $arg]}
	-attributes: {set meta [metacheck $arg]}
    }

    if {$body eq ""} {
	set body $arglist
	set arglist $opt
	set interp ""
    } else {
	set interp $opt
    }

    namecheck $name
    # Signals without a predefined path need a body to provide the path
    if {$path ne "" || $body eq ""} {pathcheck $path}
    create $bus $path $intf
    if {$id eq ""} {set id signal[incr sigid]}
    set dict [dict create \
      bus $bus path $path interface $intf name $name command "" interp $interp]
    if {$body ne ""} {
	set ns [getns $interp]
	dict set dict command [list apply [list $arglist $body $ns]]
    }

    if {[info exists signal($id)]} {
	# Clean up the old signal
	dict update signal($id) bus obus path opath interface ointf {}
	if {$obus eq ""} {
	    # Internal signal present on all buses
	    if {$id eq "PropertiesChanged"} {
		# Stop automatic signalling of changed properties
		changedsignal 0
		# The code may have messed with the path
		set opath ""
................................................................................
	}
	foreach o $old {
	    set sigs [dict get $dbif($o) signals]
    	    dict set dbif($o) signals \
	      [lsearch -all -inline -exact -not $sigs $id]
	}
    }

    set signal($id) [dict merge $dict [args $in] [dict create meta $meta]]
    dict lappend dbif($bus|$path|$intf) signals $id
    return $id



}

# Define a property that may be accessed through the DBus
#
proc dbus::dbif::property {args} {
    variable defaults; variable dbif
    dict with defaults {}; set op readwrite; set meta {}
    cmdline opt arg {path name var args} $args {
	-bus: {set bus [buscheck $arg]}
	-interface: {set intf [intfcheck $arg]}
	-access: {set op [accesscheck $arg]}
	-attributes: {set meta [metacheck $arg]}
    }

    if {[llength $args] <= 2} {
	lassign [lreverse $args] body interp
    } else {
	set cmd {dbif property ?options? path name var ?interp ?body??}
	error [format {wrong # args: should be "%s"} $cmd]
    }
    set args [args [list $name] Property]
    set name [lindex [dict get $args args] 0]
    set sig [lindex [dict get $args signature] 0]














    create $bus $path $intf


    # Remove any old trace
    if {[dict exists $dbif($bus|$path|$intf) properties $name]} {
	vartrace remove $bus $path $intf $name
    }






    if {$body ne ""} {
	set ns [getns $interp]
	set cmd [list apply [list $name $body $ns]]
    } else {
	set cmd ""
    }
    set dict [dict create variable $var access $op signature $sig \
      command $cmd interp $interp meta $meta]
    dict set dbif($bus|$path|$intf) properties $name $dict

    # Setup a variable trace for readable properties
    vartrace add $bus $path $intf $name
    if {$interp ne {}} {
	interp alias $interp ::dbus::dbif::propchg {} ::dbus::dbif::propchg
    }
}

# Define how to handle a method call
#
................................................................................
    cmdline opt arg {path cmd {in ""} {out ""} {interp ""} body} $args {
        -bus: {set bus [buscheck $arg]}
        -interface: {set intf [intfcheck $arg]}
	-attributes: {set meta [metacheck $arg]}
	-async {set async 1}
	-details {lappend opts -details}
    }

    namecheck $cmd
    set args {}
    set info {{}}
    foreach n $in {
	if {[llength $n] == 2 || [llength $info] > 1} {
	    lassign $n arg default
	    lassign [split $arg :] name sig
................................................................................
	    lappend info [linsert [lindex $info end] end $arg]
	} else {
	    lassign [split $n :] name sig
	    lappend args $name
	    lset info 0 [linsert [lindex $info 0] end $n]
	}
    }





    set ns [getns $interp]
    set code [list apply [list [linsert $args 0 msgid] $body $ns]]
    foreach n $info {
	define $bus $path $intf $cmd $code $interp $n $out $meta $async
    }

    dbus method $bus {*}$opts $path $intf.$cmd [list dbus::dbif::methods $bus]

}

# Generate a signal according to an earlier specification
#
proc dbus::dbif::generate {id args} {
    variable signal
    if {![info exists signal($id)]} {
................................................................................
	    } else {
		error "No path specified for the signal"
	    }
	}
	# Don't expect the body to provide a list for single arg signals
	if {[argcount $args] == 1} {set argv [list $argv]}
    }
    dbus signal $bus -signature $signature \
      $path $interface $name {*}$argv


}

# Setup a signal handler for a specific signal
#
proc dbus::dbif::listen {args} {
    variable defaults; variable hear
    dict with defaults {}
    cmdline opt arg {path name {arglist ""} {interp ""} body} $args {
        -bus: {set bus [buscheck $arg]}
        -interface: {set intf [intfcheck $arg]}
    }

    dbus filter $bus add \
      -type signal -path $path -interface $intf -member $name
    set args {}
    set info {{}}
    foreach n $arglist {
	if {[llength $n] == 2 || [llength $info] > 1} {
	    lassign $n arg default
	    lassign [split $arg :] var sig
................................................................................
	    lset info 0 [lindex $info 0]$sig
	}
    }
    set ns [getns $interp]
    set code [list apply [list [linsert $args 0 msgid] $body $ns]]
    foreach n $info {
    	set dict [dict create command $code interp $interp]
    	dict set hear($bus,$path,$intf) $name,$n $dict
    }
    dbus listen $bus $path $intf.$name [list dbus::dbif::signals $bus]
}

# Send a response to a DBus message
#
proc dbus::dbif::respond {response id result {name ""}} {
    variable info
    if {![info exists info($id)]} {
................................................................................
}

# Remove a path from the published DBus interface
#
proc dbus::dbif::delete {args} {
    variable defaults; variable dbif; variable signal
    dict with defaults {}

    cmdline opt arg {path} $args {
	-bus: {set bus [buscheck $arg]}
	-interface: {set intf [intfcheck $arg]}

    }



    pathcheck $path

    if {$path eq "/"} {set pat /*} else {set pat $path/*}
    set paths [array names dbif $bus|$pat|$intf]


    if {[info exists dbif($bus|$path|$intf)]} {lappend paths $bus|$path|$intf}


    foreach n $paths {
	foreach sig [dict get $dbif($n) signals] {
	    unset -nocomplain signal($sig)
	}
	unset dbif($n)
    }
}

















########################################################################
# Property access
########################################################################

# Handle a property set request
#
proc dbus::dbif::propset {bus data intf name arg} {
    variable dbif; variable info
    set path [dict get $data path]
    if {![info exists dbif($bus|$path|$intf)]} {
    	dbuserr interface $bus $path $intf
    }
    if {![dict exists $dbif($bus|$path|$intf) properties $name]} {
    	dbuserr property $bus $path $intf $name
    }
    set dict [dict get $dbif($bus|$path|$intf) properties $name]
    dict with dict {
	if {$access ni {write readwrite}} {
    	    dbuserr access $bus $path $intf $name write
	}
	# Strip off the two string arguments for interface and name
	set sig [dict get $data signature]
	set sig [string range $sig 2 end]
       	if {$sig eq "v"} {
	    lassign $arg sig arg
	}
	if {$sig ne "v" && $sig ne $signature} {
	    dbuserr signature $bus $path $intf $name $sig $signature
    	}
	if {$command ne ""} {
	    # Failures will automatically be reported back to the caller




  	    interp eval $interp [list uplevel #0 [linsert $command end $arg]]





	}
	interp eval $interp [list uplevel #0 [list set $variable $arg]]
    }
    dict with data {
    	dbus return $bus $sender $serial
    }
    return -async 1
}

# Handle a property get request
#
proc dbus::dbif::propget {bus data intf name} {
    variable dbif; variable info
    set path [dict get $data path]
    if {![info exists dbif($bus|$path|$intf)]} {
	dbuserr interface $bus $path $intf
    }
    if {![dict exists $dbif($bus|$path|$intf) properties $name]} {
	dbuserr property $bus $path $intf $name
    }
    set op [dict get $dbif($bus|$path|$intf) properties $name access]
    if {$op ni {read readwrite}} {dbuserr access $bus $path $intf $name read}
    set interp [dict get $dbif($bus|$path|$intf) properties $name interp]
    set var [dict get $dbif($bus|$path|$intf) properties $name variable]
    if {[interp eval $interp [list uplevel #0 [list info exists $var]]]} {
	set sig [dict get $dbif($bus|$path|$intf) properties $name signature]
	set dest [dict get $data sender]
	set serial [dict get $data serial]
	set value [interp eval $interp [list uplevel #0 [list set $var]]]
	if {[argcount [list value $sig]] == 1} {
	    dbus return $bus -signature $sig $dest $serial $value
	} else {
	    dbus return $bus -signature $sig $dest $serial {*}$value
	}
    } else {
	dbuserr propunset $bus $path $intf $name
    }
    return -async 1
}

# Handle a property getall request
#
proc dbus::dbif::propdump {bus data {intf ""} args} {
    variable dbif; variable info
    set path [dict get $data path]
    if {![info exists dbif($bus|$path|$intf)]} {
	dbuserr interface $bus $path $intf
    }
    if {![dict exists $dbif($bus|$path|$intf) properties]} {return {}}
    set rc {}
    dict for {n v} [dict get $dbif($bus|$path|$intf) properties] {
	set interp [dict get $v interp]
	set var [dict get $v variable]
	if {[interp eval $interp [list uplevel #0 [list info exists $var]]]} {
	    set sig [dict get $v signature]
	    set value [interp eval $interp [list uplevel #0 [list set $var]]]
	    lappend rc $n [list $sig $value]
	}
    }
    dict with data {
 	dbus return $bus -signature a{sv} $sender $serial $rc
    }
    return -async 1
}

# Track property changes
proc dbus::dbif::propchg {bus path intf prop inv name1 name2 op} {
    variable propchg
    if {$op eq "unset"} {
	# After an unset trace fires, the trace is removed
	vartrace add $bus $path $intf $prop
    }

    if {$inv} {set op invalid}
    dict set propchg $bus $path $intf $prop $op

    after cancel [namespace code propchgsignal]
    after idle [namespace code propchgsignal]
}

proc dbus::dbif::propchanged {path {intf ""} {bus ""}} {
    variable propchg
    if {$bus eq ""} {
	variable defaults
	set bus [dict get $defaults bus]
	if {$intf eq ""} {set intf [dict get $defaults intf]}
    }
    if {![dict exists $propchg $bus $path $intf]} {
	# Don't generate the signal
	return -code return
    }
    variable dbif
    set change {}
    set invalid {}
    dict for {key op} [dict get $propchg $bus $path $intf] {
	if {$op eq "write"} {
	    set info [dict get $dbif($bus|$path|$intf) properties $key]
	    dict with info {}
	    set value [interp eval $interp \
	      [list uplevel #0 [list set $variable]]]
	    dict set change $key [list $signature $value]
	} else {
	    lappend invalid $key
	}
    }
    dict unset propchg $bus $path $intf
    variable signal
    # Put the details into the signal (not the interface!)
    dict set signal(PropertiesChanged) bus $bus
    dict set signal(PropertiesChanged) path $path
    return [list $intf $change $invalid]
}

# Report changed properties
#
proc dbus::dbif::propchgsignal {} {
    variable propchg
    dict for {bus data} $propchg {
	dict for {path dict} $data {
	    dict for {intf chg} $dict {
		if {[dict size $chg] > 0} {
		    # Ignore values that do not match the signature
		    catch {generate PropertiesChanged $path $intf $bus}









		}
	    }
	}
    }

    # All changes have been reported
    set propchg {}
}

########################################################################
# Introspection procedures
########################################################################

proc dbus::dbif::node {bus path} {
    variable dbif
    set list [array names dbif $bus|$path|*]
    if {[llength $list] == 0} {
	if {$path eq "/"} {set pat /*} else {set pat $path/*}
	if {[llength [array names dbif $bus|$pat|*]] == 0} return
    }
    set rc {
	{<!DOCTYPE node PUBLIC\
	  "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN"}
	{"http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd">}
    }
    lappend rc {<node>}
    set ilist {}
    foreach n $list {
	set i [lindex [split $n |] 2]

	set dict $dbif($n)

	if {[info exists dbif($bus||$i)]} {
	    dict with dict {
		set std $dbif($bus||$i)
		set methods [dict merge [dict get $std methods] $methods]
		set properties \
		  [dict merge [dict get $std properties] $properties]
		foreach n [dict get $std signals] {
		    if {$n ni $signals} {lappend signals $n}
		}
	    }
	}

	lappend rc [interface $i $dict "  "]
	lappend ilist $i
    }

    foreach n [array names dbif $bus||*] {
	set i [lindex [split $n |] 2]
	if {$i ni $ilist} {
	    lappend rc [interface $i $dbif($n) "  "]
	}
    }
    set parent(/) {}
    foreach n [array names dbif $bus|$path*] {
	set p [lindex [split $n |] 1]
	if {$p eq "/"} continue
	set dir /
	foreach d [lrange [split $p /] 1 end] {
	    lappend parent($dir) $d
	    if {$dir eq "/"} {set dir ""}
	    append dir / $d
	    lappend parent($dir)
	}
    }






    foreach n [lsort -unique $parent($path)] {
	lappend rc [format {  <node name="%s"/>} $n]
    }
    lappend rc {</node>} {}
    join $rc \n
}







proc dbus::dbif::interface {intf dict tab} {
    variable signal
    set rc [list [format {%s<interface name="%s">} $tab $intf]]
    if {[dict exists $dict methods]} {
	dict for {n v} [dict get $dict methods] {
	    lassign [split $n ,] name sig
	    lappend rc [format {%s  <method name="%s">} $tab $name]
	    foreach {arg sig} [dict get $dict methods $n in] {
    		lappend rc [format {%s    <arg name="%s" type="%s"\
		  direction="%s"/>} $tab $arg $sig in]
	    }
	    foreach {arg sig} [dict get $dict methods $n out] {
    		lappend rc [format {%s    <arg name="%s" type="%s"\
		  direction="%s"/>} $tab $arg $sig out]
	    }





	    foreach {key value} [dict get $dict methods $n meta] {
		lappend rc [format {%s    <annotation name="%s" value="%s"/>} \

		  $tab org.freedesktop.DBus.$key $value]
	    }
	    lappend rc [format {%s  </method>} $tab]
	}
    }


    if {[dict exists $dict signals]} {
	foreach n [dict get $dict signals] {
	    set name [dict get $signal($n) name]
	    lappend rc [format {%s  <signal name="%s">} $tab $name]
	    foreach {arg sig} [dict get $signal($n) args] {
    		lappend rc [format {%s    <arg name="%s" type="%s"/>} \
		  $tab $arg $sig]
	    }
	    foreach {key value} [dict get $signal($n) meta] {
		lappend rc [format {%s    <annotation name="%s" value="%s"/>} \
		  $tab org.freedesktop.DBus.$key $value]
	    }
	    lappend rc [format {%s  </signal>} $tab]
	}

    }







    if {[dict exists $dict properties]} {
	dict for {name v} [dict get $dict properties] {
	    dict with v {}





	    if {[dict size $meta] == 0} {
		lappend rc [format {%s  <property name="%s" type="%s"\
		  access="%s"/>} $tab $name $signature $access]
		continue


	    }
	    lappend rc [format {%s  <property name="%s" type="%s"\
	      access="%s">} $tab $name $signature $access]
	    foreach {key value} $meta {
		lappend rc [format {%s    <annotation name="%s" value="%s"/>} \
		  $tab org.freedesktop.DBus.$key $value]




	    }
	    lappend rc [format {%s  </property>} $tab]
	}
    }
    lappend rc [format {%s</interface>} $tab]
    return [join $rc \n]
}






proc dbus::dbif::standard {bus} {
    variable dbif
    variable trace

    set arg1 [dict create in {interface_name s property_name s} out {value v} meta {}]

    set arg2 [dict create in {interface_name s property_name s value v} out {} meta {}]

    set arg3 [dict create in {interface_name s} out {values a{sv}} meta {}]
    create $bus "" org.freedesktop.DBus.Properties
    dict set dbif($bus||org.freedesktop.DBus.Properties) methods \
      [dict create Get,ss $arg1 Set,ssv $arg2 GetAll,sa{sv} $arg3]
    if {$trace} {
	dict set dbif($bus||org.freedesktop.DBus.Properties) signals \
	  [list PropertiesChanged]
    }
    create $bus "" org.freedesktop.DBus.Introspectable
    dict set dbif($bus||org.freedesktop.DBus.Introspectable) methods \
      [dict create Introspect, [dict create in {} out {xml_data s} meta {}]]
}

########################################################################
# DBus message handlers
########################################################################

................................................................................
# calls to methods of the supported standard interfaces. Calls to defined
# methods will be handed off to the associated code.
#
proc dbus::dbif::ping {data args} {
    return
}

proc dbus::dbif::machineid {bus data args} {
    return [dbus info $bus machineid]
}

proc dbus::dbif::introspect {bus data args} {

    return [node $bus [dict get $data path]]



}





proc dbus::dbif::methods {bus data args} {
    variable timeout; variable msgid; variable info; variable dbif
    dict with data {}
    if {![info exists dbif($bus|$path|$interface)]} {
	dbuserr interface $bus $path $interface
    }
    if {![dict exists $dbif($bus|$path|$interface) \
      methods $member,$signature]} {





	dbuserr member $bus $path $interface $member $signature
    }
    set dict [dict get $dbif($bus|$path|$interface) methods $member,$signature]

    set id message[incr msgid]
    # Allow 25 seconds for the application to provide a response
    set afterid [after $timeout [list dbus::dbif::expire $id]]
    set info($id) [dict merge $data [dict create bus $bus afterid $afterid]]
    # Store a copy of the information needed to provide a response. This
    # information would otherwise be lost if the code deletes its own path.
    dict set info($id) resp $dict
    dict with dict {
    	if {[catch {interp eval $interp \
	  [list uplevel #0 $command [linsert $args 0 $id]]} result opts]} {
	    respond error $id $result
................................................................................
	} elseif {[info exists info($id)]} {
	    respond return $id $result
	}
    }
    return -async 1
}

proc dbus::dbif::signals {bus data args} {
    variable msgid; variable info; variable hear
    dict with data {}
    # Check that a handler was defined for the member/signature combination
    if {![dict exists $hear($bus,$path,$interface) $member,$signature]} return

    set id message[incr msgid]
    set info($id) [dict merge $data [dict create bus $bus afterid $id]]
    set dict [dict get $hear($bus,$path,$interface) $member,$signature]
    catch {
	dict with dict {
	    interp eval $interp [list uplevel #0 $command [linsert $args 0 $id]]
	}
    }
    # Clean up
    expire $id
}







|
|




>
>
>







 







|







 







>
>
>
>
>



|









|







 







|







 







|







|

|
|







 







>
|

|






|
>
>
>
>
>
>
>
>







 







>







 







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






|

|











|







 







|

|







 







|







 







>





>
>
>
>
>
|
>
>

|



|
|


|

|
|
|
|
|
|
|
|
|
|
|

|
|







 







>







>
|
|
|
|
|
|
|
|
|
|
|
>


|







 







>
|
|
|
>
>
>













>









>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
>

|
|


>
>
>
>
>


|





|


|







 







>







 







>
>
>
>
>
|
|
|
|
|
>
|
>







 







|
|
>
>











>
|







 







|

|







 







>



>

>
>
>
|
>
|
|
>
>
|
>
>







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







|
|

|
|

|
|

|


|








|


|
>
>
>
>
|
>
>
>
>
>




|






|
|

|
|

|
|

|
|
|
|

|



<
|
|
<
<
<
|






|
|

|
|

|

|









|





|



|



|





|

|

|


|






|

|








|


|








|



|
|
>
>
>
>
>
>
>
>
>
|
|
|
|
>








|
|
<
<
<
<
<
|
<
<
<
<
<
|
<
|
>
|
>
|
<
|
|
|
|
|
|
|
|
<
>
|
|
<
>
|
|
|
|
|
|
|
|
|
|
<
<
<
<
<
<
|
|
>
>
>
>
>
>
|
<
|
<
<
|
>
>
>
>
>
>
|
<
<
<
|
|
|
|
<
<
<
|
<
<
<
|
>
>
>
>
>
|
<
>
|
|
<
|
|
>
>
|
|
|
|
|
|
|
|
|
|
|
|
<
|
>
|
>
>
>
>
>
>
>
|
<
<
>
>
>
>
>
|
<
<
<
>
>

<
<
<
<
<
>
>
>
>

<


<
|


>
>
>
>
>
|


>
|
>
|
>
|
|
|


|


|
|







 







|
|


|
>
|
>
>
>
|
>
>
>
|
>
|


|
|
<
|
|
>
>
>
>
>
|

|




|







 







|



|


|
|








3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
..
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
..
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
..
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
...
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
...
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
...
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
...
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
...
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
...
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
...
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
...
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
...
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
...
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
...
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
...
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
...
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
...
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
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
871
872
873
874
875
876
877

878
879



880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991





992





993

994
995
996
997
998

999
1000
1001
1002
1003
1004
1005
1006

1007
1008
1009

1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020






1021
1022
1023
1024
1025
1026
1027
1028
1029

1030


1031
1032
1033
1034
1035
1036
1037
1038



1039
1040
1041
1042



1043



1044
1045
1046
1047
1048
1049
1050

1051
1052
1053

1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069

1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080


1081
1082
1083
1084
1085
1086



1087
1088
1089





1090
1091
1092
1093
1094

1095
1096

1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
....
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158

1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
....
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
#
# The following interfaces are supported:
#	org.freedesktop.DBus.Peer
#	org.freedesktop.DBus.Introspectable
#	org.freedesktop.DBus.Properties

package require dbus 2.1
package provide dbif 1.3
package provide dbus-intf 1.3

namespace eval dbus::dbif {
    # Setup some defaults in case the user doesn't specify certain options
    variable defaults [dict create bus session intf com.tclcode.default]

    # Mapping of bus names to dbus handles
    variable handle {}

    # Store a copy of the message info of the last received message so it
    # won't be necessary to pass it around all the time
    variable info

    # Information about the available methods, signals and properties is
    # stored in an array of dicts
................................................................................
    # Information about signals is stored for easy access by ID
    variable signal

    # Automatically emit a PropertiesChanged signal when properties change
    variable trace 1
    # PropertiesChanged signal definition to be reused for every path/intf
    set signal(PropertiesChanged) {
	dbus ""
	path ""
	interface org.freedesktop.DBus.Properties
	name PropertiesChanged
	signature sa{sv}as
	command ::dbus::dbif::propchanged
	interp {}
	meta {}
................................................................................

    # Various counters for generating unique IDs
    variable msgid 0 sigid 0

    # Expiry time for messages waiting for a response
    variable timeout 25000

    # Introspection
    variable dtd [format "<!DOCTYPE node PUBLIC %s\n%s>" \
      {"-//freedesktop//DTD D-BUS Object Introspection 1.0//EN"} \
      {"http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd"}]

    # Create the dbif ensemble command
    namespace ensemble create -command ::dbif -subcommands {
	default connect method signal property generate listen \
	  return error get delete pave
    } -map {return {respond return} error {respond error}}
}

########################################################################
# Helper procedures
########################################################################

# Procedure for returning error messages to the caller
#
proc dbus::dbif::dbuserr {type dbus args} {
    upvar #1 data data
    if {[dict get $data noreply]} {return -level [info level] -async 1}
    set error org.freedesktop.DBus.Error.Failed
    switch -- $type {
	path {
	    lassign $args path
	    set msg "No such object path '$path'"
................................................................................
	    set msg "No such interface '$intf' at object path '$path'"
	    set error org.freedesktop.DBus.Error.UnknownInterface
	}
	property {
	    lassign $args path intf name
	    set msg "No such property '$name' in interface '$intf'\
	      at object path '$path'"
	    set error org.freedesktop.DBus.Error.UnknownProperty
	}
	propunset {
	    lassign $args path intf name
	    set msg "Property '$name' in interface '$intf'\
	      at object path '$path' has currently no value"
	    set error org.freedesktop.DBus.Error.NoValue
	}
................................................................................
	      at object path '$path' does not allow $op access"
	    set error org.freedesktop.DBus.Error.AccessViolation
	}
	default {
	    set msg "Invalid $type"
	}
    }
    dbus error $dbus -name $error \
      [dict get $data sender] [dict get $data serial] $msg
    return -level [info level] -async 1
}

# Make sure a new interface on a path has all the necessary parts so it
# doesn't need to be checked every time.
#
proc dbus::dbif::create {dbus path intf} {
    variable dbif
    if {![info exists dbif($dbus|$path|$intf)]} {
	set dbif($dbus|$path|$intf) \
	  [dict create methods {} signals {} properties {}]
    }
}

# Parse a DBus method or signal argument specification list
#
proc dbus::dbif::args {list {thing Argument}} {
................................................................................
	append signature $sig
    }
    return [dict create signature $signature args $args]
}

# Define a method that can be called over the DBus
#
proc dbus::dbif::define \
  {dbus path intf name cmd int {in {}} {out {}} {meta {}} {async 0}} {
    variable dbif
    create $dbus $path $intf
    set args [args $in]
    dict update args signature sig args inargs {}
    set args [args $out]
    dict update args signature ret args outargs {}
    set dict [dict create command $cmd interp $int signature $ret \
      in $inargs out $outargs meta $meta async $async]
    dict set dbif($dbus|$path|$intf) methods $name,$sig $dict
}

proc dbus::dbif::undefine {dbus path intf name cmd int {in {}}} {
    variable dbif
    if {![info exists dbif($dbus|$path|$intf)]} return
    set args [args $in]
    dict update args signature sig args inargs {}
    dict unset dbif($dbus|$path|$intf) methods $name,$sig
}

# Release the information stored for a message
#
proc dbus::dbif::expire {id} {
    variable info
    if {[info exists info($id)]} {
................................................................................
proc dbus::dbif::namecheck {name {thing Name}} {
    if {[string is wordchar -strict $name]} {return name}
    error "$thing contains invalid characters: \"$name\""
}

proc dbus::dbif::buscheck {name} {
    if {$name in {session system starter}} {return $name}
    if {[regexp {^dbus\d+$} $name]} {return $name}
    if {[regexp {^[a-z]+:([0-9A-Za-z_/.\\,=-]|%[0-9a-fA-F]{2})+$} $name]} {
	set spec [lassign [split $name :,] transport]
	if {[lsearch -not $spec *=*] < 0 && [lsearch $spec *=*=*] < 0} {
	    return $name
	}
    }
    error "Invalid bus: \"$name\"."
................................................................................
proc dbus::dbif::metacheck {data} {
    if {[string is list $data] && ([llength $data] % 2) == 0} {
	# Convert to a dict, removing duplicates (or should they be allowed?)
	return [dict merge {} $data]
    }
    error "Invalid attribute specification. Must be a dict"
}

proc dbus::dbif::handle {name} {
    variable handle
    if {[dict exists $handle $name]} {
	return [dict get $handle $name]
    } elseif {![catch {dbus info $name name}]} {
	# Appears to be a valid dbus handle
	dict set handle $name $name
	return $name
    } else {
	return -code error "not connected"
    }
}

proc dbus::dbif::async {opts} {
    return [expr {[dict exists $opts -async] && \
      [string is true -strict [dict get $opts -async]]}]
}

proc dbus::dbif::vartrace {op dbus path intf name} {
    variable dbif; variable trace
    dict with dbif($dbus|$path|$intf) properties $name {
	if {[dict exists $meta Property.EmitsChangedSignal]} {
	    set ecs [dict get $meta Property.EmitsChangedSignal]
	} else {
	    set ecs true
	}
	if {$op eq "add"} {
	    if {!$trace} return
	    if {$access ni {read readwrite}} return
	    if {$ecs ni {true invalidates}} return
	}
	set inv [expr {$ecs eq "invalidates"}]
	set trc [list dbus::dbif::propchg $dbus $path $intf $name $inv]
	set cmd [list trace $op variable $variable {write unset} $trc]
	interp eval $interp [list uplevel #0 $cmd]
    }
    return
}

# Needs to be exposed via the regular API?
................................................................................
proc dbus::dbif::changedsignal {state} {
    variable trace
    if {!$state == !$trace} return
    set trace [expr {!!$state}]
    set op [lindex {remove add} $trace]
    variable dbif
    foreach n [array names dbif] {
	lassign [split $n |] dbus path intf
	foreach name [dict keys [dict get $dbif($n) properties]] {
	    vartrace $op $dbus $path $intf $name
	}
    }
}

# Determine the number of arguments from signatures
proc dbus::dbif::argcount {argspec} {
    set cnt 0
................................................................................
    return $cnt
}

########################################################################
# Ensemble subcommands
########################################################################

# Select which DBus and interface to use
#
proc dbus::dbif::default {args} {
    variable defaults
    set opts $defaults
    cmdline opt arg {} $args {
	-bus: {dict set opts bus [buscheck $arg]}
	-interface: {dict set opts intf [intfcheck $arg]}
................................................................................
}

# Connect to the DBus, optionally requesting one or more names to be assigned
# to the current application
#
proc dbus::dbif::connect {args} {
    variable defaults
    variable handle
    set bus [dict get $defaults bus]; set opts {}
    cmdline opt arg args $args {
	-bus: {set bus [buscheck $arg]}
	-yield - -replace - -noqueue {lappend opts $opt}
    }
    if {[dict exists $handle $bus]} {
	set dbus [dict get $handle $bus]
    } elseif {[regexp {^dbus\d+$} $bus]} {
	set dbus $bus
    } else {
	set dbus [dbus connect $bus]
	dict set handle $bus $dbus
    }
    set rc {}; foreach name $args {
    	if {![catch {dbus name $dbus {*}$opts $name}]} {
	    lappend rc $name
	}
    }
    if {[dict get $defaults intf] eq "com.tclcode.default"} {
	if {[llength $rc]} {dict set defaults intf [lindex $rc 0]}
	# Path of least surprise. If no defaults have been set up, users will
	# probably expect the bus used for connecting will be the default
	dict set defaults bus $dbus
    }
    dbus method $dbus {} org.freedesktop.DBus.Peer.Ping dbus::dbif::ping
    dbus method $dbus {} org.freedesktop.DBus.Peer.GetMachineId \
      [list dbus::dbif::machineid $dbus]
    dbus method $dbus {} org.freedesktop.DBus.Introspectable.Introspect \
      [list dbus::dbif::introspect $dbus]
    dbus method $dbus -details {} org.freedesktop.DBus.Properties.Set \
      [list dbus::dbif::propset $dbus]
    dbus method $dbus {} org.freedesktop.DBus.Properties.Get \
      [list dbus::dbif::propget $dbus]
    dbus method $dbus {} org.freedesktop.DBus.Properties.GetAll \
      [list dbus::dbif::propdump $dbus]
    # Add the standard interfaces to the API specification
    standard $dbus
    return -bus $dbus $rc
}

# Define a signal that the application may send
#
proc dbus::dbif::signal {args} {
    variable defaults; variable dbif; variable signal; variable sigid
    dict with defaults {}; set meta {}
................................................................................
    set id ""
    cmdline opt arg {path name {in {}} {opt {}} {arglist {}} {body {}}} $args {
	-id: {set id $arg}
	-bus: {set bus [buscheck $arg]}
	-interface: {set intf [intfcheck $arg]}
	-attributes: {set meta [metacheck $arg]}
    }
    set dbus [handle $bus]
    if {$body eq ""} {
	set body $arglist
	set arglist $opt
	set interp ""
    } else {
	set interp $opt
    }
    if {$name ne ""} {
	namecheck $name
	# Signals without a predefined path need a body to provide the path
	if {$path ne "" || $body eq ""} {pathcheck $path}
	create $dbus $path $intf
	if {$id eq ""} {set id signal[incr sigid]}
	set dict [dict create dbus $dbus path $path \
	  interface $intf name $name command "" interp $interp]
	if {$body ne ""} {
	    set ns [getns $interp]
	    dict set dict command [list apply [list $arglist $body $ns]]
	}
    }
    if {[info exists signal($id)]} {
	# Clean up the old signal
	dict update signal($id) dbus obus path opath interface ointf {}
	if {$obus eq ""} {
	    # Internal signal present on all buses
	    if {$id eq "PropertiesChanged"} {
		# Stop automatic signalling of changed properties
		changedsignal 0
		# The code may have messed with the path
		set opath ""
................................................................................
	}
	foreach o $old {
	    set sigs [dict get $dbif($o) signals]
    	    dict set dbif($o) signals \
	      [lsearch -all -inline -exact -not $sigs $id]
	}
    }
    if {$name ne ""} {
	set signal($id) [dict merge $dict [args $in] [dict create meta $meta]]
	dict lappend dbif($dbus|$path|$intf) signals $id
	return $id
    } else {
	unset -nocomplain signal($id)
    }
}

# Define a property that may be accessed through the DBus
#
proc dbus::dbif::property {args} {
    variable defaults; variable dbif
    dict with defaults {}; set op readwrite; set meta {}
    cmdline opt arg {path name var args} $args {
	-bus: {set bus [buscheck $arg]}
	-interface: {set intf [intfcheck $arg]}
	-access: {set op [accesscheck $arg]}
	-attributes: {set meta [metacheck $arg]}
    }
    set dbus [handle $bus]
    if {[llength $args] <= 2} {
	lassign [lreverse $args] body interp
    } else {
	set cmd {dbif property ?options? path name var ?interp ?body??}
	error [format {wrong # args: should be "%s"} $cmd]
    }
    set args [args [list $name] Property]
    set name [lindex [dict get $args args] 0]
    set sig [lindex [dict get $args signature] 0]
    # Properties should be a single complete type, otherwise
    # GetAll will produce invalid results
    set cnt [argcount [list $name $sig]]
    if {$cnt != 1} {
	if {$cnt < 0} {
	    return -code error [format {invalid signature: %s} $sig]
	} else {
	    return -code error [format {not a single complete type: %s} $sig]
	}
    }

    if {$var eq {}} {
	if {![info exists dbif($dbus|$path|$intf)]} return
    } else {
	create $dbus $path $intf
    }

    # Remove any old trace
    if {[dict exists $dbif($dbus|$path|$intf) properties $name]} {
	vartrace remove $dbus $path $intf $name
    }

    if {$var eq {}} {
	dict unset $dbif($dbus|$path|$intf) properties $name
	return
    }
	
    if {$body ne ""} {
	set ns [getns $interp]
	set cmd [list apply [list [list msgid $name] $body $ns]]
    } else {
	set cmd ""
    }
    set dict [dict create variable $var access $op signature $sig \
      command $cmd interp $interp meta $meta]
    dict set dbif($dbus|$path|$intf) properties $name $dict

    # Setup a variable trace for readable properties
    vartrace add $dbus $path $intf $name
    if {$interp ne {}} {
	interp alias $interp ::dbus::dbif::propchg {} ::dbus::dbif::propchg
    }
}

# Define how to handle a method call
#
................................................................................
    cmdline opt arg {path cmd {in ""} {out ""} {interp ""} body} $args {
        -bus: {set bus [buscheck $arg]}
        -interface: {set intf [intfcheck $arg]}
	-attributes: {set meta [metacheck $arg]}
	-async {set async 1}
	-details {lappend opts -details}
    }
    set dbus [handle $bus]
    namecheck $cmd
    set args {}
    set info {{}}
    foreach n $in {
	if {[llength $n] == 2 || [llength $info] > 1} {
	    lassign $n arg default
	    lassign [split $arg :] name sig
................................................................................
	    lappend info [linsert [lindex $info end] end $arg]
	} else {
	    lassign [split $n :] name sig
	    lappend args $name
	    lset info 0 [linsert [lindex $info 0] end $n]
	}
    }
    if {$body eq {}} {
	foreach n $info {
	    undefine $dbus $path $intf $cmd $interp $n
	}
    } else {
	set ns [getns $interp]
	set code [list apply [list [linsert $args 0 msgid] $body $ns]]
	foreach n $info {
	    define $dbus $path $intf $cmd $code $interp $n $out $meta $async
	}
	dbus method $dbus {*}$opts \
	  $path $intf.$cmd [list dbus::dbif::methods $dbus]
    }
}

# Generate a signal according to an earlier specification
#
proc dbus::dbif::generate {id args} {
    variable signal
    if {![info exists signal($id)]} {
................................................................................
	    } else {
		error "No path specified for the signal"
	    }
	}
	# Don't expect the body to provide a list for single arg signals
	if {[argcount $args] == 1} {set argv [list $argv]}
    }
    if {[catch {dbus signal $dbus -signature $signature \
      $path $interface $name {*}$argv} err opts]} {
	return -code error $err
    }
}

# Setup a signal handler for a specific signal
#
proc dbus::dbif::listen {args} {
    variable defaults; variable hear
    dict with defaults {}
    cmdline opt arg {path name {arglist ""} {interp ""} body} $args {
        -bus: {set bus [buscheck $arg]}
        -interface: {set intf [intfcheck $arg]}
    }
    set dbus [handle $bus]
    dbus filter $dbus add \
      -type signal -path $path -interface $intf -member $name
    set args {}
    set info {{}}
    foreach n $arglist {
	if {[llength $n] == 2 || [llength $info] > 1} {
	    lassign $n arg default
	    lassign [split $arg :] var sig
................................................................................
	    lset info 0 [lindex $info 0]$sig
	}
    }
    set ns [getns $interp]
    set code [list apply [list [linsert $args 0 msgid] $body $ns]]
    foreach n $info {
    	set dict [dict create command $code interp $interp]
    	dict set hear($dbus,$path,$intf) $name,$n $dict
    }
    dbus listen $dbus $path $intf.$name [list dbus::dbif::signals $dbus]
}

# Send a response to a DBus message
#
proc dbus::dbif::respond {response id result {name ""}} {
    variable info
    if {![info exists info($id)]} {
................................................................................
}

# Remove a path from the published DBus interface
#
proc dbus::dbif::delete {args} {
    variable defaults; variable dbif; variable signal
    dict with defaults {}
    set recurse 1
    cmdline opt arg {path} $args {
	-bus: {set bus [buscheck $arg]}
	-interface: {set intf [intfcheck $arg]}
	-single {set recurse 0}
    }
    set dbus [handle $bus]
    set paths {}
    if {$path ne {}} {
	pathcheck $path
	if {$recurse} {
	    if {$path eq "/"} {set pat /*} else {set pat $path/*}
	    set paths [array names dbif $dbus|$pat|$intf]
	}
    }
    if {[info exists dbif($dbus|$path|$intf)]} {
	lappend paths $dbus|$path|$intf
    }
    foreach n $paths {
	foreach sig [dict get $dbif($n) signals] {
	    unset -nocomplain signal($sig)
	}
	unset dbif($n)
    }
}

# Create an object path so it will be listed with introspect
#
proc dbus::dbif::pave {args} {
    variable defaults; variable dbif; variable signal
    dict with defaults {}
    set recurse 1
    cmdline opt arg {path} $args {
	-bus: {set bus [buscheck $arg]}
	-interface: {set intf [intfcheck $arg]}
    }
    set dbus [handle $bus]
    pathcheck $path
    create $dbus $path $intf
    return
}

########################################################################
# Property access
########################################################################

# Handle a property set request
#
proc dbus::dbif::propset {dbus data intf name arg} {
    variable dbif; variable info; variable msgid; variable timeout
    set path [dict get $data path]
    if {![info exists dbif($dbus|$path|$intf)]} {
    	dbuserr interface $dbus $path $intf
    }
    if {![dict exists $dbif($dbus|$path|$intf) properties $name]} {
    	dbuserr property $dbus $path $intf $name
    }
    set dict [dict get $dbif($dbus|$path|$intf) properties $name]
    dict with dict {
	if {$access ni {write readwrite}} {
    	    dbuserr access $dbus $path $intf $name write
	}
	# Strip off the two string arguments for interface and name
	set sig [dict get $data signature]
	set sig [string range $sig 2 end]
       	if {$sig eq "v"} {
	    lassign $arg sig arg
	}
	if {$sig ne "v" && $sig ne $signature} {
	    dbuserr signature $dbus $path $intf $name $sig $signature
    	}
	if {$command ne ""} {
	    set id message[incr msgid]
	    set afterid [after $timeout [list dbus::dbif::expire $id]]
	    set info($id) \
	      [dict merge $data [dict create bus $dbus afterid $afterid]]
	    if {[catch {interp eval $interp \
	      [list uplevel #0 [linsert $command end $id $arg]]} res opts]} {
		expire $id
		# Rethrow the error so it gets reported back to the caller
		return -options [dict incr opts -level] $res
	    }
	    expire $id
	}
	interp eval $interp [list uplevel #0 [list set $variable $arg]]
    }
    dict with data {
    	dbus return $dbus $sender $serial
    }
    return -async 1
}

# Handle a property get request
#
proc dbus::dbif::propget {dbus data intf name} {
    variable dbif
    set path [dict get $data path]
    if {![info exists dbif($dbus|$path|$intf)]} {
	dbuserr interface $dbus $path $intf
    }
    if {![dict exists $dbif($dbus|$path|$intf) properties $name]} {
	dbuserr property $dbus $path $intf $name
    }
    set op [dict get $dbif($dbus|$path|$intf) properties $name access]
    if {$op ni {read readwrite}} {dbuserr access $dbus $path $intf $name read}
    set interp [dict get $dbif($dbus|$path|$intf) properties $name interp]
    set var [dict get $dbif($dbus|$path|$intf) properties $name variable]
    if {[interp eval $interp [list uplevel #0 [list info exists $var]]]} {
	set sig [dict get $dbif($dbus|$path|$intf) properties $name signature]
	set dest [dict get $data sender]
	set serial [dict get $data serial]
	set value [interp eval $interp [list uplevel #0 [list set $var]]]

	dbus return $dbus -signature $sig $dest $serial $value
    } else {



	dbuserr propunset $dbus $path $intf $name
    }
    return -async 1
}

# Handle a property getall request
#
proc dbus::dbif::propdump {dbus data {intf ""} args} {
    variable dbif
    set path [dict get $data path]
    if {![info exists dbif($dbus|$path|$intf)]} {
	dbuserr interface $dbus $path $intf
    }
    if {![dict exists $dbif($dbus|$path|$intf) properties]} {return {}}
    set rc {}
    dict for {n v} [dict get $dbif($dbus|$path|$intf) properties] {
	set interp [dict get $v interp]
	set var [dict get $v variable]
	if {[interp eval $interp [list uplevel #0 [list info exists $var]]]} {
	    set sig [dict get $v signature]
	    set value [interp eval $interp [list uplevel #0 [list set $var]]]
	    lappend rc $n [list $sig $value]
	}
    }
    dict with data {
 	dbus return $dbus -signature a{sv} $sender $serial $rc
    }
    return -async 1
}

# Track property changes
proc dbus::dbif::propchg {dbus path intf prop inv name1 name2 op} {
    variable propchg
    if {$op eq "unset"} {
	# After an unset trace fires, the trace is removed
	vartrace add $dbus $path $intf $prop
    }

    if {$inv} {set op invalid}
    dict set propchg $dbus $path $intf $prop $op

    after cancel [namespace code propchgsignal]
    after idle [namespace code propchgsignal]
}

proc dbus::dbif::propchanged {path {intf ""} {dbus ""}} {
    variable propchg
    if {$dbus eq ""} {
	variable defaults
	set dbus [handle [dict get $defaults bus]]
	if {$intf eq ""} {set intf [dict get $defaults intf]}
    }
    if {![dict exists $propchg $dbus $path $intf]} {
	# Don't generate the signal
	return -code return
    }
    variable dbif
    set change {}
    set invalid {}
    dict for {key op} [dict get $propchg $dbus $path $intf] {
	if {$op eq "write"} {
	    set info [dict get $dbif($dbus|$path|$intf) properties $key]
	    dict with info {}
	    set value [interp eval $interp \
	      [list uplevel #0 [list set $variable]]]
	    dict set change $key [list $signature $value]
	} else {
	    lappend invalid $key
	}
    }
    dict unset propchg $dbus $path $intf
    variable signal
    # Put the details into the signal (not the interface!)
    dict set signal(PropertiesChanged) dbus $dbus
    dict set signal(PropertiesChanged) path $path
    return [list $intf $change $invalid]
}

# Report changed properties
#
proc dbus::dbif::propchgsignal {} {
    variable propchg
    dict for {dbus data} $propchg {
	dict for {path dict} $data {
	    dict for {intf chg} $dict {
		if {[dict size $chg] > 0} {
		    # Report values that do not match the signature
		    if {[catch {generate PropertiesChanged \
		      $path $intf $dbus} msg opts]} {
			set str "failed to generate the PropertiesChanged\
			  dbus signal for interface '$intf' on path '$path'.\
			  Reason: $msg"
			dict set opts -errorinfo $str
			# Get the error reporting command for the interp
			set errcmd [interp bgerror {}]
			# Report the error without throwing an exception
			catch {{*}$errcmd $str $opts}
		    }
		}
	    }
	}
    }
    # All changes have been reported
    set propchg {}
}

########################################################################
# Introspection procedures
########################################################################

proc dbus::dbif::node {dbus path {init {node {{} {interface {}}}}}} {
    variable dbif; variable signal





    set rc $init





    foreach match [array names dbif $dbus|$path|*] {

	set intfname [lindex [split $match |] 2]
	dict with rc node {} {
	    dict update interface $intfname intf {
		# [lappend intf] would shimmer an existing dict to a list
		if {![info exists intf]} {set intf {}}

		# Methods
		dict for {spec dict} [dict get $dbif($match) methods] {
		    if {[dict exists $dict meta Internal.Prune]} {
			if {![dict exists $init node {} interface $intfname]} {
			    set skip [dict get $dict meta Internal.Prune]
			    if {[string is true -strict $skip]} continue
			}
		    }

		    set name [lindex [split $spec ,] 0]
		    if {[dict exists $intf method $name]} continue
		    # In case a method has neither input nor output arguments

		    dict set intf method $name {}
		    foreach n {in out} {
			foreach {arg sig} [dict get $dict $n] {
			    dict set intf method $name arg $arg {} \
			      [dict create type $sig direction $n]
			}
		    }
		    foreach {key value} [dict get $dict meta] {
			if {[string match Internal.* $key]} continue
			dict set intf method $name \
			  annotation org.freedesktop.DBus.$key {} value $value






		    }
		}
		# Signals
		foreach n [dict get $dbif($match) signals] {
		    set name [dict get $signal($n) name]
		    if {[dict exists $signal($n) meta Internal.Prune]} {
			if {![dict exists $init node {} interface $intfname]} {
			    set skip [dict get $signal($n) meta Internal.Prune]
			    if {[string is true -strict $skip]} continue

			}


		    }
		    if {[dict exists $intf signal $name]} continue
		    set args [dict get $signal($n) args]
		    # In case a signal has no arguments
		    dict set intf signal $name {}
		    dict for {arg type} $args {
			dict set intf signal $name arg $arg {} type $type
		    }



		    foreach {key value} [dict get $signal($n) meta] {
			if {[string match Internal.* $key]} continue
			dict set intf signal $name \
			  annotation org.freedesktop.DBus.$key {} value $value



		    }



		}
		# Properties
		dict for {prop dict} [dict get $dbif($match) properties] {
		    dict update dict signature type access access {}
		    dict set intf property $prop {} \
		      [dict create type $type access $access]
		    dict for {key value} [dict get $dict meta] {

			dict set intf property $prop \
			  annotation org.freedesktop.DBus.$key {} value $value
		    }

		}
	    }
	}
    }
    if {$path ne ""} {
	if {$path eq "/"} {
	    set pat /?*
	    set index 1
	} else {
	    set pat $path/*
	    set index [llength [split $path /]]
	}
	foreach n [array names dbif $dbus|$pat|*] {
	    set node [lindex [split [lindex [split $n |] 1] /] $index]
	    dict set rc node {} node $node {}
	}

    }
    return $rc
}

proc dbus::dbif::xmlize {dict} {
    dict for {tag data} $dict {
	dict for {name spec} $data {
	    set str $tag
	    set lines {}
	    if {$name ne {}} {append str [format { name="%s"} $name]}
	    if {[dict exists $spec {}]} {


		dict for {attrib value} [dict get $spec {}] {
		    append str [format { %s="%s"} $attrib $value]
		}
		dict unset spec {}
	    }
	    if {[dict size $spec]} {



		lappend lines \
		  {*}[lmap line [xmlize $spec] {format {  %s} $line}]
	    }





	    if {[llength $lines] > 0} {
		lappend rc <$str> {*}$lines </$tag>
	    } else {
		lappend rc <$str/>
	    }

	}
    }

    return $rc
}

proc dbus::dbif::xml {dict} {
    variable dtd
    return [join [linsert [xmlize $dict] 0 $dtd] \n]
}    

proc dbus::dbif::standard {dbus} {
    variable dbif
    variable trace
    set arg1 [dict create meta {} \
      in {interface_name s property_name s} out {value v}]
    set arg2 [dict create meta {} \
      in {interface_name s property_name s value v} out {}]
    set arg3 [dict create meta {} \
      in {interface_name s} out {values a{sv}}]
    create $dbus "" org.freedesktop.DBus.Properties
    dict set dbif($dbus||org.freedesktop.DBus.Properties) methods \
      [dict create Get,ss $arg1 Set,ssv $arg2 GetAll,sa{sv} $arg3]
    if {$trace} {
	dict set dbif($dbus||org.freedesktop.DBus.Properties) signals \
	  [list PropertiesChanged]
    }
    create $dbus "" org.freedesktop.DBus.Introspectable
    dict set dbif($dbus||org.freedesktop.DBus.Introspectable) methods \
      [dict create Introspect, [dict create in {} out {xml_data s} meta {}]]
}

########################################################################
# DBus message handlers
########################################################################

................................................................................
# calls to methods of the supported standard interfaces. Calls to defined
# methods will be handed off to the associated code.
#
proc dbus::dbif::ping {data args} {
    return
}

proc dbus::dbif::machineid {dbus data args} {
    return [dbus info $dbus machineid]
}

proc dbus::dbif::introspect {dbus data args} {
    # Find all properties, methods and signals with the requested path
    set dict [node $dbus [dict get $data path]]
    if {[dict size [dict get $dict node {} interface]] == 0 && \
      ![dict exists $dict node {} node]} {
	dbuserr path $dbus [dict get $data path]
    }
    # Add methods and signals that do not have a path specified
    set dict [node $dbus {} $dict]
    return [xml $dict]
}

proc dbus::dbif::methods {dbus data args} {
    variable timeout; variable msgid; variable info; variable dbif
    dict with data {}
    if {![info exists dbif($dbus|$path|$interface)]} {
	dbuserr interface $dbus $path $interface

    } elseif {[dict exists \
	  $dbif($dbus|$path|$interface) methods $member,$signature]} {
	set p $path
    } elseif {[info exists dbif($dbus||$interface)] && \
      [dict exists $dbif($dbus||$interface) methods $member,$signature]} {
	set p ""
    } else {
	dbuserr member $dbus $path $interface $member $signature
    }
    set dict [dict get $dbif($dbus|$p|$interface) methods $member,$signature]

    set id message[incr msgid]
    # Allow 25 seconds for the application to provide a response
    set afterid [after $timeout [list dbus::dbif::expire $id]]
    set info($id) [dict merge $data [dict create bus $dbus afterid $afterid]]
    # Store a copy of the information needed to provide a response. This
    # information would otherwise be lost if the code deletes its own path.
    dict set info($id) resp $dict
    dict with dict {
    	if {[catch {interp eval $interp \
	  [list uplevel #0 $command [linsert $args 0 $id]]} result opts]} {
	    respond error $id $result
................................................................................
	} elseif {[info exists info($id)]} {
	    respond return $id $result
	}
    }
    return -async 1
}

proc dbus::dbif::signals {dbus data args} {
    variable msgid; variable info; variable hear
    dict with data {}
    # Check that a handler was defined for the member/signature combination
    if {![dict exists $hear($dbus,$path,$interface) $member,$signature]} return

    set id message[incr msgid]
    set info($id) [dict merge $data [dict create bus $dbus afterid $id]]
    set dict [dict get $hear($dbus,$path,$interface) $member,$signature]
    catch {
	dict with dict {
	    interp eval $interp [list uplevel #0 $command [linsert $args 0 $id]]
	}
    }
    # Clean up
    expire $id
}

Changes to doc/dbif.man.

1
2
3
4
5
6
7
8
9
10
11
12
13
..
93
94
95
96
97
98
99
100

101
102
103
104

105
106
107
108
109
110
111
...
191
192
193
194
195
196
197









198
199
200
201
202
203
204
205
206
207
208
209

210
211
212
213
214
215
216
...
319
320
321
322
323
324
325











326
327
328
329
330
331
332
[comment {-*- tcl -*- doctools manpage}]
[vset libname dbif]
[vset cmdname dbif]
[vset version 1.2]
[manpage_begin [vset libname] n [vset version]]
[copyright {2008-2015 Schelte Bron}]
[moddesc {Tcl D-Bus Interface}]
[titledesc {Application layer around the Tcl D-Bus library}]
[require Tcl 8.5]
[require dbus "2.1"]
[require [vset libname] [vset version]]
[description]

................................................................................
[option -interface] is taken from the first name requested for the
application in a [cmd [vset cmdname]] [method connect] command. If no
name was ever requested with the connect subcommand, it defaults to
"com.tclcode.default".

[call [cmd [vset cmdname]] [method delete] \
  [opt "[option -bus] [arg bustype]"] \
  [opt "[option -interface] [arg interface]"] [arg path]]


While there currently is no way to remove individual signals, methods, or
properties from the published interface, this subcommand allows the removal
of a complete node.


[call [cmd [vset cmdname]] [method error] [arg messageID] \
  [arg errormessage] [opt [arg errorname]]]

Send a D-Bus error message in response to a D-Bus method call. If the
[arg errorname] argument is not specified, it defaults to
"org.freedesktop.DBus.Error.Failed".
................................................................................
The code in [arg body] will be executed in the namespace the
[cmd [vset cmdname]] [method method] command was issued from.

The [arg inputargs] and [arg outputargs] arguments follow the special rules
for [vset cmdname] argument lists.
See [sectref "ARGUMENT LISTS"] below for more information.










[call [cmd [vset cmdname]] [method property] \
  [opt "[option -access] [arg mode]"] \
  [opt "[option -attributes] [arg attributes]"] \
  [opt "[option -bus] [arg bustype]"] \
  [opt "[option -interface] [arg interface]"] \
  [arg path] [arg name]?:[arg signature]? [arg variable] \
  [opt "[opt [arg interp]] [arg body]"]]

Define a property that may be accessed through the D-Bus using methods defined 
by the org.freedesktop.DBus.Properties standard interface. The [arg variable]
argument defines the global variable holding the value of the property.


[para]

The [option -access] option specifies whether the property can be viewed
and/or modified through the D-Bus. Valid access modes are [const read],
[const write], and [const readwrite]. If no access mode is specified, it
defaults to readwrite.

................................................................................
    # Single argument signal bodies are not expected to produce a list
    if {[lb]llength $args[rb] == 1} {set args [lb]lindex $args 0[rb]}
    return -path $path $args
}
[example_end]

[list_end]












[section "VALID NAMES"]

The [vset libname] package enforces some limitations on names used with the
[cmd [vset cmdname]] subcommands. All names must only use the characters
"[lb]A-Z[rb][lb]a-z[rb][lb]0-9[rb]_". This limitation applies to method
names, property names, signal names, and argument names. Out of this group,



|

|







 







|
>



|
>







 







>
>
>
>
>
>
>
>
>












>







 







>
>
>
>
>
>
>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
..
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
...
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
...
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
[comment {-*- tcl -*- doctools manpage}]
[vset libname dbif]
[vset cmdname dbif]
[vset version 1.3]
[manpage_begin [vset libname] n [vset version]]
[copyright {2008-2017 Schelte Bron}]
[moddesc {Tcl D-Bus Interface}]
[titledesc {Application layer around the Tcl D-Bus library}]
[require Tcl 8.5]
[require dbus "2.1"]
[require [vset libname] [vset version]]
[description]

................................................................................
[option -interface] is taken from the first name requested for the
application in a [cmd [vset cmdname]] [method connect] command. If no
name was ever requested with the connect subcommand, it defaults to
"com.tclcode.default".

[call [cmd [vset cmdname]] [method delete] \
  [opt "[option -bus] [arg bustype]"] \
  [opt "[option -interface] [arg interface]"] \
  [opt "[option -single]"] [arg path]]

While there currently is no way to remove individual signals, methods, or
properties from the published interface, this subcommand allows the removal
of a complete node. Unless the [option -single] option is specified, the
command will also recursively delete nodes on all underlying object paths.

[call [cmd [vset cmdname]] [method error] [arg messageID] \
  [arg errormessage] [opt [arg errorname]]]

Send a D-Bus error message in response to a D-Bus method call. If the
[arg errorname] argument is not specified, it defaults to
"org.freedesktop.DBus.Error.Failed".
................................................................................
The code in [arg body] will be executed in the namespace the
[cmd [vset cmdname]] [method method] command was issued from.

The [arg inputargs] and [arg outputargs] arguments follow the special rules
for [vset cmdname] argument lists.
See [sectref "ARGUMENT LISTS"] below for more information.

[call [cmd [vset cmdname]] [method pave] \
  [opt "[option -bus] [arg bustype]"] \
  [opt "[option -interface] [arg interface]"] [arg path]]

Create a path. Normally a path is automatically created when a property,
method, or signal is defined on that path. This command is intended for paths
that only have universal methods and/or signals (i.e. methods and/or signals
that are defined with an empty string as their path).

[call [cmd [vset cmdname]] [method property] \
  [opt "[option -access] [arg mode]"] \
  [opt "[option -attributes] [arg attributes]"] \
  [opt "[option -bus] [arg bustype]"] \
  [opt "[option -interface] [arg interface]"] \
  [arg path] [arg name]?:[arg signature]? [arg variable] \
  [opt "[opt [arg interp]] [arg body]"]]

Define a property that may be accessed through the D-Bus using methods defined 
by the org.freedesktop.DBus.Properties standard interface. The [arg variable]
argument defines the global variable holding the value of the property.

The [arg signature] of a property must be a single complete type.
[para]

The [option -access] option specifies whether the property can be viewed
and/or modified through the D-Bus. Valid access modes are [const read],
[const write], and [const readwrite]. If no access mode is specified, it
defaults to readwrite.

................................................................................
    # Single argument signal bodies are not expected to produce a list
    if {[lb]llength $args[rb] == 1} {set args [lb]lindex $args 0[rb]}
    return -path $path $args
}
[example_end]

[list_end]

[section "BUS TYPES"]
The [option -bus] option of the various subcommands takes a [arg bustype]
value that can take several forms:
[list_begin itemized]
[item]One of the well-known bus names: 'session', 'system', or 'startup'.
[item]A bus address, consisting of a transport name followed by a colon,
and then an optional, comma-separated list of keys and values in the form
key=value.
[item]A handle as returned by the [cmd dbus] [method connect] subcommand.
[list_end]

[section "VALID NAMES"]

The [vset libname] package enforces some limitations on names used with the
[cmd [vset cmdname]] subcommands. All names must only use the characters
"[lb]A-Z[rb][lb]a-z[rb][lb]0-9[rb]_". This limitation applies to method
names, property names, signal names, and argument names. Out of this group,

Changes to examples/hello.tcl.

28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
# Send a response before quitting to keep the caller happy
dbif method / Quit {dbif return $msgid {};exit}

# Define a couple of properties that can be remotely accessed
#
dbif property / Message text
dbif property -access read /Counter Value:i counter
dbif property / BackgroundColor color(bg) {.b configure -background BackgroundColor}
dbif property / ForegroundColor color(fg) {.b configure -foreground ForegroundColor}

# Initialize the variables that hold the properties
set color(bg) [.b cget -background]
set color(fg) [.b cget -foreground]
set text "Hello World!"
set counter 0








|
|







28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
# Send a response before quitting to keep the caller happy
dbif method / Quit {dbif return $msgid {};exit}

# Define a couple of properties that can be remotely accessed
#
dbif property / Message text
dbif property -access read /Counter Value:i counter
dbif property / BackgroundColor color(bg) {.b configure -background $BackgroundColor}
dbif property / ForegroundColor color(fg) {.b configure -foreground $ForegroundColor}

# Initialize the variables that hold the properties
set color(bg) [.b cget -background]
set color(fg) [.b cget -foreground]
set text "Hello World!"
set counter 0