#
# DO NOT EDIT THIS FILE!
# THIS FILE IS AUTOMATICALLY EXTRACTED FROM A LITERATE PROGRAM SOURCE FILE.
#
# This software is copyrighted 2019 by G. Andrew Mangogna.
# The following terms apply to all files associated with the software unless
# explicitly disclaimed in individual files.
# 
# The authors hereby grant permission to use, copy, modify, distribute,
# and license this software and its documentation for any purpose, provided
# that existing copyright notices are retained in all copies and that this
# notice is included verbatim in any distributions. No written agreement,
# license, or royalty fee is required for any of the authorized uses.
# Modifications to this software may be copyrighted by their authors and
# need not follow the licensing terms described here, provided that the
# new terms are clearly indicated on the first page of each file where
# they apply.
# 
# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY FOR
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING
# OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY DERIVATIVES
# THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE POSSIBILITY OF
# SUCH DAMAGE.
# 
# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT.  THIS SOFTWARE
# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS,
# OR MODIFICATIONS.
# 
# GOVERNMENT USE: If you are acquiring this software on behalf of the
# U.S. government, the Government shall have only "Restricted Rights"
# in the software and related documentation as defined in the Federal
# Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2).  If you
# are acquiring the software on behalf of the Department of Defense,
# the software shall be classified as "Commercial Computer Software"
# and the Government shall have only "Restricted Rights" as defined in
# Clause 252.227-7013 (c) (1) of DFARs.  Notwithstanding the foregoing,
# the authors grant the U.S. Government and others acting in its behalf
# permission to use and distribute the software in accordance with the
# terms specified in this license.

package require Tcl 8.6
package require dbus
package require ral
package require ralutil
package require tdom
package require oo::util
package require logger
package require logger::utils
package require logger::appender

namespace eval ::dbusclient {
    set logger [::logger::init dbusclient]
    set appenderType [expr {[dict exist [fconfigure stdout] -mode] ?\
            "colorConsole" : "console"}]
    ::logger::utils::applyAppender -appender $appenderType -serviceCmd $logger\
            -appenderArgs {-conversionPattern {\[%c\] \[%p\] '%m'}}
    ::logger::import -all -force -namespace log dbusclient

    namespace export Connection
    namespace export Service
    namespace ensemble create
}

::oo::class create ::dbusclient::Connection {
    variable busId ;                # <1>

    constructor {address} {
        ::logger::import -all -force -namespace log dbusclient ;        # <1>
    
        set busId [::dbus connect $address]
        log::info "connected to dbus version = [::dbus info $busId version]"
    }
    destructor {
        try {
            foreach service [my FindConnectedServices] {
                $service destroy
            }
        } finally {
            ::dbus close $busId
        }
    }
    method FindConnectedServices {} {
        set connected [list]
        set me [self]
    
        set services [info class instances ::dbusclient::Service]
        foreach service $services {
            if {[$service connectedTo] eq $me} {
                lappend connected $service
            }
        }
    
        log::debug "services connected to $me : \"[join $connected {, }]\""
    
        return $connected
    }
    method call {target path interface method sig args} {
        set cmd [list ::dbus call $busId -dest $target]
        if {$sig ne {}} {
            lappend cmd -signature $sig
        }
        lappend cmd $path $interface $method
    
        log::debug "calling method $cmd $args"
        tailcall {*}$cmd {*}$args
    }
    method listen {path member args} {
        log::debug "setting listen for \"$path\" $member $args"
        set nargs [llength $args]
        if {$nargs > 1} {
            set msg "wrong # of args: expected listen path member ?script?"
            throw [list CONNECTION WRONGARGS $msg] $msg
        }
    
        set cmd [list ::dbus listen $busId $path $member]
        if {$nargs == 1} {
            lappend cmd [lindex $args 0]
        }
        tailcall {*}$cmd
    }
    method filter {subcmd args} {
        log::debug "filter $subcmd $args"
        tailcall ::dbus filter $busId $subcmd {*}$args
    }
}
::oo::class create ::dbusclient::Service {
    constructor {svc conn} {
        namespace import ::ral::*
        namespace import ::ralutil::*
    
        ::logger::import -all -force -namespace log dbusclient
    
        my variable svcName
        set svcName $svc
        if {![::dbus validate interface $svcName]} {
            set msg "Invalid service name syntax"
            throw [list CONSTRUCTOR BADSERVICE $msg] $msg
        }
    
        my variable connId
        set connId $conn
    
        my variable traceNumber ;                   # <1>
        set traceNumber 0
    
        relvar create Path {
            Name string
        } Name
        
        relvar create Interface {
            Name string
        } Name
        
        relvar create Implementation {
            Path string
            Interface string
        } {Path Interface}
        
        relvar create Member {
            Interface string
            Name string
        } {Interface Name}
        
        relvar create Method {
            Interface string
            Name string
            Signature string
        } {Interface Name}
        
        relvar create Property {
            Interface string
            Name string
            Type string
            Access string
        } {Interface Name}
        
        relvar create Signal {
            Interface string
            Name string
            Signature string
        } {Interface Name}
        
        relvar create Argument {
            Interface string
            Method string
            Name string
            Type string
        } {Interface Method Name}
        
        relvar create PropertyValue {
            Path string
            Interface string
            Property string
            Value string
            Valid boolean
        } {Path Interface Property}
        
        relvar create Annotation {
            Interface string
            Member string
            Name string
            Value string
        } {Member Name}
        
        relvar correlation R1 Implementation\
                Path * Path Name\
                Interface * Interface Name
        relvar association R2\
                Member Interface +\
                Interface Name 1
        relvar partition R3 Member {Interface Name}\
                Method {Interface Name}\
                Property {Interface Name}\
                Signal {Interface Name}
        relvar association R4\
                Argument {Interface Method} *\
                Method {Interface Name} 1
        relvar correlation R5 PropertyValue\
                {Path Interface} * Implementation {Path Interface}\
                {Interface Property} * Property {Interface Name}
        relvar association R6\
                Annotation {Interface Member} *\
                Member {Interface Name} 1
        relvar create Trace {
            TraceId int
            PathMatch string
            CmdPrefix string
        } TraceId
        
        relvar create PathTrace {
            TraceId int
        } TraceId
        
        relvar create SignalTrace {
            TraceId int
            Interface string
            Signal string
        } TraceId
        
        relvar create PropertyTrace {
            TraceId int
            Interface string
            Property string
        } TraceId
        
        relvar partition R7 Trace TraceId\
                PathTrace TraceId\
                SignalTrace TraceId\
                PropertyTrace TraceId
        
        relvar association R8\
                SignalTrace {Interface Signal} *\
                Signal {Interface Name} 1
        
        relvar association R9\
                PropertyTrace {Interface Property} *\
                Property {Interface Name} 1
    
        relvar eval {
            my Introspect /     ;                   # <2>
            my CreatePropertyValues
        }
    
        my InitializeProperties ;                   # <3>
    
        my SetupStdSignals ;                        # <4>
    
        # It can be useful to see the service metadata when exploring
        # new servers.
        foreach rv [lsort [relvar names [namespace current]::*]] {
            log::info "\n[relformat [relvar set $rv] [namespace tail $rv]]"
        }
    }
    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
            my CreateNodes $path $svcroot
        } finally {
            $svcdoc delete
        }
    
        return
    }
    method CreateInterfaces {path root} {
        set intfnodes [$root getElementsByTagName interface]
    
        foreach intfnode $intfnodes {
            set intfname [$intfnode getAttribute name]
    
            set intfMissing [relation isempty \
                    [relvar restrictone Interface Name $intfname]\
            ]
    
            if {$intfMissing} {
                relvar insert Interface [list Name $intfname]
    
                my CreateMethods $intfnode
                my CreateProperties $intfnode
                my CreateSignals $intfnode
            }
            relvar insert Implementation [list\
                Path $path\
                Interface $intfname\
            ] ;                                                     # <1>
        }
    
        return
    }
    method CreateMethods {intfnode} {
        set intfName [$intfnode getAttribute name]
        set methNodes [$intfnode getElementsByTagName method]
        foreach methNode $methNodes {
            set methName [$methNode getAttribute name]
            set haveMeth [pipe {
                relvar restrictone Method Interface $intfName Name $methName |
                relation isnotempty ~
            }]
            if {$haveMeth} {  #                               <1>
                continue
            }
            set methSig {}
            set argCounter -1
    
            set argNodes [$methNode getElementsByTagName arg]
            foreach argNode $argNodes {
                set argName [expr {[$argNode hasAttribute name] ?\
                        [$argNode getAttribute name] :\
                        "arg_[incr argCounter]"}]
                set argDir [expr {[$argNode hasAttribute direction] ?\
                        [$argNode getAttribute direction] : "in"}]
                set argType [$argNode getAttribute type]
                if {$argDir eq "in"} {
                    append methSig $argType
                    set ainserted [relvar insert Argument [list\
                        Interface $intfName\
                        Method $methName\
                        Name $argName\
                        Type $argType\
                    ]]
                }
            }
    
            set memTuple [list Interface $intfName Name $methName]
            relvar insert Member $memTuple
            relvar insert Method [list\
                {*}$memTuple\
                Signature $methSig\
            ]
    
            my CreateAnnotations $methNode $intfName $methName
        }
    
        return
    }
    method CreateAnnotations {node interface member} {
        set noteNodes [$node getElementsByTagName annotation]
        foreach noteNode $noteNodes {
            set noteName [$noteNode getAttribute name]
            set noteValue [$noteNode getAttribute value]
            relvar insert Annotation [list\
                Interface $interface\
                Member $member\
                Name $noteName\
                Value $noteValue\
            ]
        }
    }
    method CreateProperties {intfnode} {
        set intfName [$intfnode getAttribute name]
        set propNodes [$intfnode getElementsByTagName property]
        foreach propNode $propNodes {
            set propName [$propNode getAttribute name]
            set haveProp [pipe {
                relvar restrictone Property Interface $intfName Name $propName |
                relation isnotempty ~
            }]
            if {$haveProp} {
                continue
            }
            set propType [$propNode getAttribute type]
            set propAccess [$propNode getAttribute access]
    
            set memTuple [list Interface $intfName Name $propName]
            relvar insert Member $memTuple
            relvar insert Property [list\
                {*}$memTuple\
                Type $propType\
                Access $propAccess\
            ]
    
            my CreateAnnotations $propNode $intfName $propName
        }
    
        return
    }
    method CreateSignals {intfnode} {
        set intfName [$intfnode getAttribute name]
    
        set sigNodes [$intfnode getElementsByTagName signal]
        foreach sigNode $sigNodes {
            set sigName [$sigNode getAttribute name]
            set haveSig [pipe {
                relvar restrictone Signal Interface $intfName Name $sigName |
                relation isnotempty ~
            }]
            if {$haveSig} {
                continue
            }
            set sigSig [list]
    
            set argCounter -1
            set argNodes [$sigNode getElementsByTagName arg]
            foreach argNode $argNodes {
                set argName [expr {[$argNode hasAttribute name] ?\
                        [$argNode getAttribute name] :\
                        "arg_[incr argCounter]"}]
                set argType [$argNode getAttribute type]
                append sigSig $argType
            }
    
            set memTuple [list Interface $intfName Name $sigName]
            relvar insert Member $memTuple
            relvar insert Signal [list\
                {*}$memTuple\
                Signature $sigSig\
            ]
    
            my CreateAnnotations $sigNode $intfName $sigName
        }
    }
    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>
        }
    }
    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
    }
    method InitializeProperties {} {
        my variable connId svcName
    
        # check if there is an object manager, we can get the properties
        # from it and set up listening for future changes.
        set objMgrPaths [pipe {
            relvar set Implementation |
            relation restrictwith ~\
                {$Interface eq "org.freedesktop.DBus.ObjectManager"} |
            relation list ~ Path
        }]
    
        foreach path $objMgrPaths {
            set managed [$connId call $svcName $path\
                    org.freedesktop.DBus.ObjectManager GetManagedObjects {}]
            log::debug "managed objects = $managed"
    
            dict for {objPath objDesc} $managed {
                dict for {intf props} $objDesc {
                    dict for {propName propValue} $props {
                        my UpdatePropertyValue $objPath $intf $propName $propValue
                    }
                }
            }
    
            # Add signal traces for the signals in ObjectManager that
            # let us know when interfaces have changed.
            my trace add signal org.freedesktop.DBus.ObjectManager\
                    InterfacesAdded ${path}* [mymethod InterfacesAdded]
            my trace add signal org.freedesktop.DBus.ObjectManager\
                    InterfacesRemoved ${path}* [mymethod InterfacesRemoved]
        }
    
        # Check for paths that implement org.freedesktop.DBus.Properties
        # We can then invoke the GetAll method using the property
        # interface to get the set of valid values.
        set propPaths [pipe {
            relvar set Implementation |
            relation restrictwith ~\
                    {$Interface eq "org.freedesktop.DBus.Properties"} |
            relation project ~ Path |
            relation join ~ [relvar set PropertyValue] |
            relation project ~ Path Interface
        }]
    
        relation foreach propPath $propPaths {
            relation assign $propPath
            set values [$connId call $svcName $Path org.freedesktop.DBus.Properties\
                    GetAll {} $Interface]
            dict for {propName propValue} $values {
                my UpdatePropertyValue $Path $Interface $propName $propValue
            }
        }
        # Add signal traces for the signals in Properties that
        # let us know when property values have changed.
        if {[relation isnotempty $propPaths]} {
            set svcroot /[string map {. /} $svcName]
            my trace add signal org.freedesktop.DBus.Properties\
                    PropertiesChanged ${svcroot}* [mymethod PropertiesChanged]
        }
    }
    method UpdatePropertyValue {path interface property value} {
        log::debug "updating property value: $path $interface.$property $value"
        relvar updateone PropertyValue propTup [list\
            Path $path Interface $interface Property $property] {
                tuple update $propTup Value $value Valid true
            }
    }
    method InvalidatePropertyValue {path interface property} {
        log::debug "invalidating property value: $path $interface.$property"
        relvar updateone PropertyValue propTup [list\
            Path $path Interface $interface Property $property] {
                tuple update $propTup Valid false
            }
    }
    method SetupStdSignals {} {
        my variable connId svcName
    
        set stdSignals [my QueryStdSignals]
        foreach stdSignal $stdSignals {
            $connId listen {} $stdSignal [mymethod HandleSignals]
        }
        if {[llength $stdSignals] != 0} {
            $connId filter add -type signal -sender $svcName
        }
    
        return
    }
    method QueryStdSignals {} {
        set stdInterfaces {
            PropertiesChanged
            InterfacesAdded
            InterfacesRemoved
        }
    
        return [pipe {
            relvar set Signal |
            relation restrictwith ~ {$Name in $stdInterfaces} |
            relation list ~ Name
        }]
    }
    method TakeDownStdSignals {} {
        my variable connId svcName
    
        set stdSignals [my QueryStdSignals]
        foreach stdSignal $stdSignals {
            $connId listen {} $stdSignal {}
        }
        if {[llength $stdSignals] != 0} {
            $connId filter remove -type signal -sender $svcName
        }
    
        return
    }
    destructor {
        my TakeDownStdSignals
    
        relvar constraint delete {*}[relvar constraint names [namespace current]::*]
        relvar unset {*}[relvar names [namespace current]::*]
    }
    method connectedTo {} {
        my variable connId
        return $connId
    }
    method pathList {} {
        return [relation list [relvar set Path] Name] ;         # <1>
    }
    method findPathsByPropertyValue {interface property expression} {
        set matches [pipe {
            relvar set PropertyValue |
            relation restrictwith ~ {$Interface eq $interface &&\
                    $Property eq $property && $Valid}
        }]
        set qualified [uplevel 1\
                [list ::ral relation restrictwith $matches $expression]]
        return [relation list $qualified Path]
    }
    method pathInterfaces {path} {
        return [pipe {
            relvar set Implementation |
            relation restrictwith ~ {$Path eq $path} |
            relation list ~ Interface
        }]
    }
    method pathProperties {path interface} {
        return [pipe {
            relvar set PropertyValue |
            relation restrictwith ~\
                {$Path eq $path && $Interface eq $interface && $Valid} |
            relation list ~ Property
        }]
    }
    method interfaceMethods {interface} {
        return [pipe {
            relvar set Method |
            relation restrictwith ~ {$Interface eq $interface} |
            relation list ~ Name
        }]
    }
    method methodSignature {interface method} {
        return [pipe {
            relvar restrictone Method Interface $interface Name $method |
            relation extract ~ Signature
        }]
    }
    method interfaceProperties {interface} {
        return [pipe {
            relvar set Property |
            relation restrictwith ~ {$Interface eq $interface} |
            relation list ~ Name
        }]
    }
    method interfaceSignals {interface} {
        return [pipe {
            relvar set Signal |
            relation restrictwith ~ {$Interface eq $interface} |
            relation list ~ Name
        }]
    }
    method call {path interface method args} {
        my ValidateCall $path $interface $method $args
        my variable connId svcName
        tailcall $connId call $svcName $path $interface $method\
            [my methodSignature $interface $method] {*}$args
    }
    method ValidateCall {path interface method arglist} {
        my ValidatePath $path
        my ValidateInterface $path $interface
        my ValidateMethod $interface $method $arglist
        my CheckAnnotations $interface $method
        return
    }
    method ValidatePath {path} {
        if {![::dbus validate path $path]} {
            set msg "invalid path name: \"$path\""
            throw [list PATH INVALID $msg] $msg
        }
        set pathFound [pipe {
            relvar restrictone Path Name $path |
            relation isnotempty
        }]
        if {!$pathFound} {
            set msg "unknown path, \"$path\""
            throw [list PATH UNKNOWN $msg] $msg
        }
        return
    }
    method ValidateInterface {path interface} {
        if {![::dbus validate interface $interface]} {
            set msg "invalid interface name: \"$interface\""
            throw [list INTERFACE INVALID $msg] $msg
        }
        set intfFound [pipe {
            relvar restrictone Interface Name $interface |
            relation isnotempty
        }]
        if {!$intfFound} {
            set msg "unknown interface, \"$interface\""
            throw [list INTERFACE UNKNOWN $msg] $msg
        }
        set isImplemented [pipe {
            relvar restrictone Implementation Path $path Interface $interface |
            relation isnotempty
        }]
        if {!$isImplemented} {
            set msg "path, \"$path\", does not implement\
                    interface, \"$interface\""
            throw [list INTERFACE NOTIMPLEMENTED $msg] $msg
        }
        return
    }
    method ValidateMethod {interface method arglist} {
        if {![::dbus validate member $method]} {
            set msg "invalid method name: \"$method\""
            throw [list METHOD INVALID $msg] $msg
        }
        set methRel [relvar restrictone Method\
                Interface $interface Name $method]
        if {[relation isempty $methRel]} {
            set msg "interface, \"$interface\", does not have a method named,\
                    \"$method\""
            throw [list METHOD UNKNOWN $msg] $msg
        }
    
        set args [pipe {
            relvar set Argument |
            relation semijoin $methRel ~\
                -using {Interface Interface Name Method}
        }]
        if {[relation cardinality $args] != [llength $arglist]} {
            set expectArgs [relation list $args Name]
            set msg "wrong # args: expected $method [join $expectArgs ,]:\
                    got: [join $arglist ,]"
            throw [list METHOD WRONGARGS $msg] $msg
        }
        return
    }
    method CheckAnnotations {interface member} {
        set notes [pipe {
            relvar set Annotation |
            relation restrictwith ~\
                    {$Interface eq $interface && $Member eq $member}
        }]
    
        relation foreach note $notes {
            relation assign $note
            log::notice "member, $Interface.$Member,\
                is annotated as, $Name = $Value"
        }
    }
    method property {path interface property args} {
        if {[llength $args] > 1} {
            set msg "wrong # args:\
                    expected, \"property path interface property ?value?\""
            throw [list PROPERTY WRONGARGS $msg] $msg
        }
    
        set prop [relvar restrictone Property\
                Interface $interface Name $property]
        if {[relation isempty $prop]} {
            set msg "unknown property, \"$interface.$property\""
            throw [list PROPERTY UNKNOWN $msg] $msg
        }
        relation assign $prop {Access propAccess} {Type propType}
                
        set propValue [relvar restrictone PropertyValue\
                Path $path Interface $interface Property $property]
        if {[relation isempty $propValue]} {
            set msg "property, \"$interface.$property\", is not implemented\
                    for path, \"$path\""
            throw [list PROPERTY NOTIMPLEMENTED $msg] $msg
        }
    
        if {[llength $args] == 1} {
            if {![string match *write* $propAccess]} {
                set msg "property, $interface.$property cannot be updated"
                throw [list PROPERTY NOWRITE $msg] $msg
            }
            set value [lindex $args 0]
            my call $path org.freedesktop.DBus.Properties Set\
                    $interface $property [list $propType $value]
        } else {
            if {![string match *read* $propAccess]} {
                set msg "property, $interface.$property cannot be read"
                throw [list PROPERTY NOREAD $msg] $msg
            }
            relation assign $propValue {Value value} Valid
            if {!$Valid} {
                my variable connId svcName
                set value [$connId call $svcName $path\
                        org.freedesktop.DBus.Properties Get {} $interface $property]
                my UpdatePropertyValue $path $interface $property $value
            }
        }
        return $value
    }
    method trace {operation args} {
        switch -exact $operation {
            add {
                set result [my AddTrace $args]
            }
            remove {
                set result [my RmTrace {*}$args]
            }
            info {
                set result [my InfoTrace {*}$args]
            }
            default {
                set msg "unknown trace operation, \"$operation\":\
                    expected add, remove or info"
                throw [list TRACE UNKNOWNOP $msg] $msg
            }
        }
        return $result
    }
    method AddTrace {argList} {
        if {[llength $argList] < 2} {
            set msg "wrong # of args, expected: trace add tracetype args"
            throw [list TRACE WRONGARGS $msg] $msg
        }
    
        set argList [lassign $argList tracetype]
        switch -exact -- $tracetype {
            path {
                set traceid [my AddPathTrace $argList]
            }
            signal {
                set traceid [my AddSignalTrace $argList]
            }
            property {
                set traceid [my AddPropertyTrace $argList]
            }
            default {
                set msg "unknown trace type, \"$tracetype\", expected:\
                    path, signal, or property"
                throw [list TRACE UNKNOWNTYPE $msg] $msg
            }
        }
    
        return $traceid
    }
    method AddPathTrace {argList} {
        if {[llength $argList] != 2} {
            set msg "wrong # of args, expected: trace add path\
                pathpattern cmdprefix"
            throw [list TRACE WRONGARGS $msg] $msg
        }
        lassign $argList pathpattern cmdprefix
        my variable traceNumber
        incr traceNumber
    
        relvar eval {
            relvar insert Trace [list\
                TraceId $traceNumber\
                PathMatch $pathpattern\
                CmdPrefix $cmdprefix\
            ]
            relvar insert PathTrace [list\
                TraceId $traceNumber\
            ]
        }
    
        return $traceNumber
    }
    method AddSignalTrace {argList} {
        if {[llength $argList] != 4} {
            set msg "wrong # of args, expected:\
                trace add signal interface signal pathpattern cmdprefix"
            throw [list TRACE WRONGARGS $msg] $msg
        }
        lassign $argList interface signal pathpattern cmdprefix
        my variable traceNumber
        incr traceNumber
        relvar eval {
            relvar insert Trace [list\
                TraceId $traceNumber\
                PathMatch $pathpattern\
                CmdPrefix $cmdprefix\
            ]
            relvar insert SignalTrace [list\
                TraceId $traceNumber\
                Interface $interface\
                Signal $signal\
            ]
        }
        my variable connId
        $connId listen {} $interface.$signal [mymethod HandleSignals]
    
        return $traceNumber
    }
    method AddPropertyTrace {argList} {
        if {[llength $argList] != 4} {
            set msg "wrong # of args, expected:\
                trace add signal interface property pathpattern cmdprefix"
            throw [list TRACE WRONGARGS $msg] $msg
        }
        lassign $argList interface property pathpattern cmdprefix
        my variable traceNumber
        incr traceNumber
        relvar eval {
            relvar insert Trace [list\
                TraceId $traceNumber\
                PathMatch $pathpattern\
                CmdPrefix $cmdprefix\
            ]
            relvar insert PropertyTrace [list\
                TraceId $traceNumber\
                Interface $interface\
                Property $property\
            ]
        }
    
        return $traceNumber
    }
    method RmTrace {traceid} {
        set trace [pipe {
            relvar restrictone Trace TraceId $traceid |
            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>
                    relvar deleteone SignalTrace TraceId $traceid
                } elseif {[relation isnotempty $Property]} {
                    relvar deleteone PropertyTrace TraceId $traceid
                }
            }
        }
        return
    }
    method InfoTrace {traceid} {
        set trace [pipe {
            relvar restrictone Trace TraceId $traceid |
            rvajoin ~ [relvar set PathTrace] Path |
            rvajoin ~ [relvar set SignalTrace] Signal |
            rvajoin ~ [relvar set PropertyTrace] Property
        }]
    
        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
        }
    }
    method waitForProperty {interface property pathpattern trigger {timeout 5000}} {
        set timerid {}
        if {$timeout != 0} {
            set timerid [::after $timeout [mymethod PropertySyncTimeout]]
        }
        set traceId [my trace add property $interface $property $pathpattern\
                [mymethod PropertySync]]
        try {
            set result [uplevel 1 $trigger]
    
            vwait [my varname propSync]
            if {$timerid ne {}} {
                ::after cancel $timerid
            }
        } on error {result opts} {
            return -options $opts $result
        } finally {
            my trace remove $traceId
        }
    
        variable propSync
        if {$propSync eq "TIMEOUT"} {
            set msg "timed out waiting for property change: $interface $property\
                    $pathpattern $trigger"
            throw [list PROPERTY TIMEOUT $msg] $msg
        }
        return $propSync
    }
    method PropertySync {status path interface property value} {
        set [my varname propSync] [dict create\
            status $status\
            path $path\
            interface $interface\
            property $property\
            value $value\
        ]
        return
    }
    method PropertySyncTimeout {} {
        set [my varname propSync] TIMEOUT
        return
    }
    method waitForSignal {interface signal pathpattern trigger {timeout 5000}} {
        set timerid {}
        if {$timeout != 0} {
            set timerid [::after $timeout [mymethod SignalSyncTimeout]]
        }
        set traceId [my trace add signal $interface $signal $pathpattern\
                [mymethod SignalSync]]
        try {
            set result [uplevel 1 $trigger]
    
            vwait [my varname sigSync]
            if {$timerid ne {}} {
                ::after cancel $timerid
            }
        } on error {result opts} {
            return -options $opts $result
        } finally {
            my trace remove $traceId
        }
    
        variable sigSync
        if {$sigSync eq "TIMEOUT"} {
            set msg "timed out waiting for signal change: $interface $signal\
                    $pathpattern $trigger"
            throw [list SIGNAL TIMEOUT $msg] $msg
        }
        return $sigSync
    }
    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
    }
    method SignalSyncTimeout {} {
        set [my varname sigSync] TIMEOUT
        return
    }
    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
        }
    
        my trace remove $traceId
    
        variable pathSync
        if {$pathSync eq "TIMEOUT"} {
            set msg "timed out waiting for path change"
            throw [list PROPERTY TIMEOUT $msg] $msg
        }
        return $pathSync
    }
    method PathSync {status path} {
        set [my varname pathSync] [dict create\
            status $status\
            path $path\
        ]
        return
    }
    method PathSyncTimeout {} {
        set [my varname pathSync] TIMEOUT
        return
    }
    method HandleSignals {eventInfo args} {
        log::debug [info level 0]
        set interface [dict get $eventInfo interface]
        set signal [dict get $eventInfo member]
        set path [dict get $eventInfo path]
    
        my EvalTrace signal {$Interface eq $interface &&\
                $Signal eq $signal &&\
                [string match $PathMatch $path]} $eventInfo {*}$args
    }
    method EvalTrace {tracetype predicate args} {
        set typeMap [dict create\
            path PathTrace\
            signal SignalTrace\
            property PropertyTrace\
        ]
        set trace [pipe {
            relvar set Trace |
            relation join ~ [relvar set [dict get $typeMap $tracetype]]
        }]
        set matches [uplevel 1 [list ::ral relation restrictwith $trace $predicate]]
    
        log::debug "$tracetype traces:\n[relformat $matches MatchingTrace]"
    
        relation foreach trace $matches -descending TraceId {
            relation assign $trace CmdPrefix TraceId
            set cmd [list {*}$CmdPrefix {*}$args]
    
            try {
                eval $cmd
            } on continue {} {
                continue
            } on break {} {
                break
            } on error {result opts} {
                log::error $::errorInfo
                log::error "error executing $tracetype trace command,\
                        \"$cmd\": $result"
                my RmTrace $TraceId
                break
            }
        }
    }
    method TracePropertyValue {status path interface property args} {
        my EvalTrace property {$Interface eq $interface &&\
                $Property eq $property && [string match $PathMatch $path]}\
                $status $path $interface $property {*}$args
    }
    method TracePath {status path} {
        my EvalTrace path {[string match $PathMatch $path]} $status $path
    }
    method InterfacesAdded {eventInfo path interfaces} {
        relvar eval {
            dict for {interface properties} $interfaces {
                set added [my AddNewInterface $interface $path]
                if {!$added} {
                    # At this point we failed to find the interface
                    # in the introspection XML. The best we can do
                    # is just add it with the properties we have
                    # and just ignore any methods or signals.
                    relvar insert Interface [list Name $interface]
                    foreach propName [dict keys $properties] {
                        relvar insert Member [list\
                            Interface $interface\
                            Name $propName\
                        ]
                        relvar insert Property [list\
                            Interface $interface\
                            Name $propName\
                            Type {}\
                            Access read\
                        ]
                    }
                }
    
                dict for {propName propValue} $properties {
                    relvar insert PropertyValue [list\
                        Path $path\
                        Interface $interface\
                        Property $propName\
                        Value $propValue\
                        Valid true\
                    ]
                    my TracePropertyValue changed $path $interface $propName\
                            $propValue
                }
            }
            my AddNewPath $path [dict keys $interfaces]
        }
    
        return
    }
    method AddNewInterface {interface path} {
        set intf [relvar restrictone Interface Name $interface]
        if {[relation isempty $intf]} {
            my variable connId svcName
    
            set svcxml [$connId call $svcName $path\
                    org.freedesktop.DBus.Introspectable Introspect {}]
            log::debug "new interface xml = \"$svcxml\""
            set svcdoc [dom parse -simple $svcxml]
            set svcroot [$svcdoc documentElement]
            set intfNode [$svcroot selectNodes {/node/interface[@name=$interface]}]
            log::debug "intfNode = $intfNode"
            if {$intfNode eq {}} {
                log::notice "failed to find interface, \"$interface\",\
                    in introspection XML for path, \"$path\""
                return false
            }
    
            try {
                set intf [relvar insert Interface [list Name $interface]]
                my CreateMethods $intfNode
                my CreateProperties $intfNode
                my CreateSignals $intfNode
            } finally {
                $svcdoc delete
            }
        }
        return true
    }
    method AddNewPath {path interfaces} {
        foreach interface $interfaces {
            relvar uinsert Implementation [list Path $path Interface $interface]
        }
    
        set pathRel [relvar restrictone Path Name $path]
        if {[relation isempty $pathRel]} {
            relvar insert Path [list Name $path]
            my TracePath added $path
        }
    }
    method InterfacesRemoved {eventInfo path interfaces} {
        relvar eval {
            foreach interface $interfaces {
                relvar deleteone Implementation Path $path Interface $interface
                relvar delete PropertyValue pvTup {
                    [tuple extract $pvTup Path] eq $path &&\
                    [tuple extract $pvTup Interface] eq $interface}
            }
            set noImplRemain [pipe {
                relvar set Implementation |
                relation restrictwith ~ {$Path eq $path} |
                relation isempty
            }]
            if {$noImplRemain} {
                relvar deleteone Path Name $path
                my TracePath removed $path
            }
        }
    }
    method PropertiesChanged {eventInfo intfName changed invalidated} {
        set path [dict get $eventInfo path]
        dict for {propName propValue} $changed {
            my UpdatePropertyValue $path $intfName $propName $propValue
            my TracePropertyValue changed $path $intfName $propName $propValue
        }
        foreach invalProp $invalidated {
            my InvalidatePropertyValue $path $intfName $invalProp
            my TracePropertyValue invalidated $path $intfName $invalProp
        }
    }
}

package provide dbusclient 1.0
