scratch team mailing list archive
-
scratch team
-
Mailing list archive
-
Message #00029
Fwd: Re: Scratch in multiverse repository on Ubuntu 10.04 Lucid Lynx
This is the email replying to Bert that I mentioned in my last email and
which I could not locate in archives.
-------- Original Message --------
Subject: Re: [Scratch] Scratch in multiverse repository on Ubuntu 10.04
Lucid Lynx
Date: Tue, 02 Feb 2010 09:34:55 +0000
From: Derek O'Connell <doc@xxxxxxxxxxxxxxxxx>
To: linux <linux@xxxxxxxxxxxxxxx>
On 02/02/2010 04:20, Bert Freudenberg wrote:
> On 01.02.2010, at 16:54, Derek O'Connell wrote:
>
>> Hi Amos,
>>
>> starting Thursday I will be getting back up to speed on sound issues on
>> Linux and the XO. Hope to get something for that next release of Ubuntu.
>>
>> Btw, last night I came across a Scratch image that is almost a year old
>> to the day and in which I had migrated DBus classes to. Worryingly I
>> don't even remember doing it :-S Anyway just had a quick hack-about to
>> see I could get it working. Tried "DBusConnection example" and
>> eventually got the following output which looks promising. I know this
>> is not your thing but included in case anyone else is interested.
>>
>> --- Begin dbus queue processing ---
>> Received message: DBusMessageSignal(2)[/org/freedesktop/DBus
>> org.freedesktop.DBus.NameAcquired(':1.1', )]
>> Received message: DBusMessageSignal(3)[/org/freedesktop/DBus
>> org.freedesktop.DBus.NameAcquired('org.squeak.dbus.example', )]
>>
>> -D
>>
> Nice! Do you possibly have changesets for this to migrate it to a current image?
>
> Also, I just noticed that linux@xxxxxxxxxxxxxxx is an alias for the launchpad list? Had me confused ...
>
> - Bert -
>
>
>
Only spent ~30 mins on it last night and definitely more work needed but
I've attached what I have so far. Since I don't recall doing the
migration I don't know where the DBus classes originally came from,
probably whichever Etoys version was current this time last year.
-D
'From MIT Squeak 0.9.4 (June 1, 2003) [No updates present.] on 2 February 2010 at 9:46:24 am'!
!DBusArgument methodsFor: 'initialize' stamp: 'dmoc 2/2/2010 00:27'!
value: anObject type: aChar
" type := aChar.
value := anObject dbusCoerceTo: type
"
^ anObject! !
!DBusConnection methodsFor: 'private' stamp: 'dmoc 2/2/2010 00:19'!
matchString: anArray
"Construct a dbus match string from anArray"
^String streamContents: [:strm |
anArray pairsDo: [:key :value |
strm position > 0 ifTrue: [strm nextPut: $,].
strm nextPutAll: key;
nextPut: $=;
print: value]]! !
!DBusConnection methodsFor: 'arguments-read' stamp: 'dmoc 2/2/2010 00:23'!
getArgumentType
| byte |
^ (byte _ self primArgumentGetType) ifNotNil: [ byte asCharacter]! !
!DBusConnection methodsFor: 'arguments-write' stamp: 'dmoc 2/2/2010 00:41'!
writeArgument: arg
^self perform: (Writers at: arg "dbusType") with: arg
! !
!DBusMessage methodsFor: 'arguments' stamp: 'dmoc 2/2/2010 00:41'!
addArgument: a
arguments add: a "asDBusArgument"
! !
!DBusMessage methodsFor: 'printing' stamp: 'dmoc 2/2/2010 00:29'!
printArgumentsOn: aStream
aStream nextPut: $(.
arguments ifNotNil: [
arguments
do: [:each |
each printOn: aStream.
aStream nextPutAll: ', '
]
].
aStream nextPut: $).
! !
!String methodsFor: 'converting' stamp: 'dmoc 2/2/2010 00:09'!
squeakToUtf8
^ UTF8 fromMacRoman: self! !
'From MIT Squeak 0.9.4 (June 1, 2003) [No updates present.] on 2 February 2010 at 9:44:57 am'!
Object subclass: #DBusArgument
instanceVariableNames: 'value type signature '
classVariableNames: ''
poolDictionaries: ''
category: 'DBus-Core'!
!DBusArgument commentStamp: '<historical>' prior: 0!
This class is known to the DBus plugin. You must not change the order of instance variables.
I store arguments from a DBusMessage object. My argument can be another instance of me or supported Smalltalk objects like SmallInteger or Array. The signature says which dbus type the argument is. The type can be different from the squeak type. In case of integer ( int or uint ) be aware of number overflows. For every possible dbus type a class selector exist which create a new instance of me with an argument an the correct type signature. Some objects understand #asDBusArgument so for example a String answers direcly an instance of me.
THIS CLASS NEEDS TO BE REFACTORED into type-specific subclasses to get rid of all the type-based cases. We'll need one class for basic types and one for each container type.!
DBusArgument class
instanceVariableNames: ''!
Object subclass: #DBusConnection
instanceVariableNames: 'connectionIndex semaIndex readSemaphore '
classVariableNames: 'Readers SessionBus SystemBus Writers '
poolDictionaries: ''
category: 'DBus-Core'!
!DBusConnection commentStamp: '<historical>' prior: 0!
I represent a connection to the DBus (see http://dbus.freedesktop.org/).
connectionIndex: 0 for session bus, 1 for system bus
semaIndex: index of the read semaphore in the externalObjects array
This class is known to the DBus plugin. The connectionIndex and semaIndex must be the first instance variables in the class.
The plugin automatically connects to the DBus when a primitive of me is called.!
DBusConnection subclass: #DBus
instanceVariableNames: 'exported process replyHandlers matchHandlers accessLock '
classVariableNames: ''
poolDictionaries: ''
category: 'DBus-Objects'!
!DBus commentStamp: '<historical>' prior: 0!
I am a DBus connection. I retrieve messages in a background loop. Messages can be sent through me synchronously (that is, they block until a result comes in). I can export objects on the DBus to provide services for other applications.
FIXME: startup should only happen when I am used first, not at image startup time
(DBus sessionBus getObject: 'org.gnome.ScreenSaver' path: '/') SetActive: true!
DBusConnection class
instanceVariableNames: ''!
nil subclass: #DBusError
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'DBus-Objects'!
nil subclass: #DBusExplorer
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'DBus-Tools'!
!DBusExplorer commentStamp: '<historical>' prior: 0!
Browse DBus services by their introspection data.
!
DBusExplorer class
instanceVariableNames: ''!
nil subclass: #DBusExplorerWrapper
instanceVariableNames: 'connection service path '
classVariableNames: ''
poolDictionaries: ''
category: 'DBus-Tools'!
!DBusExplorerWrapper commentStamp: '<historical>' prior: 0!
service: 'my.service'
path: '/my/path interface.method()'!
DBusExplorerWrapper class
instanceVariableNames: ''!
Object subclass: #DBusHandler
instanceVariableNames: 'onSuccess onError '
classVariableNames: ''
poolDictionaries: ''
category: 'DBus-Objects'!
DBusHandler class
instanceVariableNames: ''!
Object subclass: #DBusMatch
instanceVariableNames: 'matches argMatches '
classVariableNames: ''
poolDictionaries: ''
category: 'DBus-Objects'!
Object subclass: #DBusMessage
instanceVariableNames: 'typeCode path interface member sender destination arguments serial '
classVariableNames: ''
poolDictionaries: ''
category: 'DBus-Core'!
!DBusMessage commentStamp: '<historical>' prior: 0!
I am the super class for messages which can send exchanged over a DBusConnection. For an example look at DBusMessage testMethodCall.
This class is known to the DBus plugin. You must not change the order of instance variables.
!
DBusMessage class
instanceVariableNames: ''!
DBusMessage subclass: #DBusMessageError
instanceVariableNames: 'name replySerial '
classVariableNames: ''
poolDictionaries: ''
category: 'DBus-Core'!
DBusMessageError class
instanceVariableNames: ''!
DBusMessage subclass: #DBusMessageMethodCall
instanceVariableNames: 'reply '
classVariableNames: ''
poolDictionaries: ''
category: 'DBus-Core'!
DBusMessageMethodCall class
instanceVariableNames: ''!
DBusMessage subclass: #DBusMessageMethodReply
instanceVariableNames: 'replySerial '
classVariableNames: ''
poolDictionaries: ''
category: 'DBus-Core'!
DBusMessageMethodReply class
instanceVariableNames: ''!
DBusMessage subclass: #DBusMessageSignal
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'DBus-Core'!
DBusMessageSignal class
instanceVariableNames: ''!
Object subclass: #DBusMethod
instanceVariableNames: 'interface member inSignature outSignature '
classVariableNames: ''
poolDictionaries: ''
category: 'DBus-Objects'!
DBusMethod class
instanceVariableNames: ''!
Object subclass: #DBusObject
instanceVariableNames: 'dbusConnection dbusName dbusParent dbusChildren '
classVariableNames: ''
poolDictionaries: ''
category: 'DBus-Objects'!
!DBusObject commentStamp: '<historical>' prior: 0!
I am an object exposed on the DBus.
Methods that are exported on the DBus are marked in the source using dbusMethod: and a string giving the DBus interface, selector, and signatures ('interface.method<inSignature>outSignature').
Most of my methods are prefixed with 'dbus' to minimize selector space polution for subclasses.
!
DBusObject class
instanceVariableNames: ''!
Object subclass: #DBusProxy
instanceVariableNames: 'connection busName objectPath '
classVariableNames: ''
poolDictionaries: ''
category: 'DBus-Objects'!
!DBusProxy commentStamp: '<historical>' prior: 0!
I am a proxy for an object on the DBus. You can send messages using #dbusPerform: and its variants.
!
DBusProxy subclass: #DBusCompiledProxy
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'DBus-Objects'!
!DBusCompiledProxy commentStamp: '<historical>' prior: 0!
I'm the superclass for a DBus proxy with delegation methods compiled by introspection.
!
DBusCompiledProxy subclass: #DBusDaemon
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'DBus-Objects'!
!DBusDaemon commentStamp: '<historical>' prior: 0!
I am an example compiled proxy for the 'org.freedesktop.DBus' service. My methods were generated like this:
DBusDaemon compileMethodsFrom: DBusDaemon current introspect
I can, e.g., list names on the DBus:
DBusDaemon current listNames!
DBusProxy subclass: #DBusGenericProxy
instanceVariableNames: 'methods '
classVariableNames: ''
poolDictionaries: ''
category: 'DBus-Objects'!
!DBusGenericProxy commentStamp: '<historical>' prior: 0!
I am a generic proxy for an object on the DBus. You can simply send Smalltalk messages to me that I intercept via #doesNotUnderstand: and forward to the DBus.!
DBusProxy class
instanceVariableNames: ''!
DBusCompiledProxy class
instanceVariableNames: 'current '!
DBusDaemon class
instanceVariableNames: ''!
!DBusArgument methodsFor: 'accessing' stamp: 'jf 5/21/2007 15:25'!
asDBusArgument
^ self! !
!DBusArgument methodsFor: 'accessing' stamp: 'bf 11/16/2007 20:06'!
containedDBusArgumentsDo: aBlock
"XXX refactor into subclasses"
type caseOf: {
[DBusArgument struct]
-> [signature
ifNil: [value do: [:each | aBlock value: each asDBusArgument]]
ifNotNil: [
"XXX iterating over chars will fail for contained multi-character signatures"
value with: self containedSignature do: [:v :c |
('a({' includes: c) ifTrue: [^self error: 'containers in structs not implemented yet'].
aBlock value: (DBusArgument value: v type: c)]]].
[DBusArgument dictEntry]
-> [signature
ifNil: [aBlock value: value key asDBusArgument.
aBlock value: value value asDBusArgument]
ifNotNil: [
"XXX wrong if key has a multi-character signature"
('a({' includes: signature second) ifTrue: [^self error: 'containers as dict keys not implemented yet'].
aBlock value: (DBusArgument
value: value key
signature: (signature copyFrom: 2 to: 2)).
aBlock value: (DBusArgument
value: value value
signature: (signature copyFrom: 3 to: signature size - 1))]].
[DBusArgument array]
-> ["this is a bit of a hack - we want to iterate over associations if we contain a dict. Fortunately this works for Arrays too ..."
signature
ifNil: [value associationsDo: [:each | aBlock value: each asDBusArgument]]
ifNotNil: [
| sig |
sig := self containedSignature.
value associationsDo: [:each | aBlock value: (DBusArgument value: each signature: sig)]]].
[DBusArgument variant]
-> [aBlock value: value asDBusArgument]
}
otherwise: [self error: 'only container types may be iterated over'].
! !
!DBusArgument methodsFor: 'accessing' stamp: 'jaf 5/31/2007 22:19'!
containedSignature
^ String streamContents: [:stream| self printContainedSignatureOn: stream]! !
!DBusArgument methodsFor: 'accessing' stamp: 'bf 5/25/2007 20:09'!
dbusType
^type! !
!DBusArgument methodsFor: 'accessing' stamp: 'bf 3/28/2008 16:06'!
fromDBusArgument
"XXX refactor into subclasses"
self isBasicType ifTrue: [^value].
^type caseOf: {
[DBusArgument struct]
-> [value collect: [:ea | ea fromDBusArgument]].
[DBusArgument dictEntry]
-> [value key fromDBusArgument -> value value fromDBusArgument].
[DBusArgument array]
-> [| arr |
signature = 'ay' ifTrue: [^value].
arr := value collect: [:ea | ea fromDBusArgument].
self containedSignature first =${
ifTrue: [arr as: Dictionary]
ifFalse: [arr]].
[DBusArgument variant]
-> [value fromDBusArgument]
}
! !
!DBusArgument methodsFor: 'accessing' stamp: 'jaf 5/26/2007 21:39'!
isBasicType
^('avre' includes: type) not! !
!DBusArgument methodsFor: 'accessing' stamp: 'jaf 5/31/2007 22:18'!
signature
^ String streamContents: [:stream| self printSignatureOn: stream]
! !
!DBusArgument methodsFor: 'accessing' stamp: 'bf 5/25/2007 21:12'!
signature: aString
signature := aString! !
!DBusArgument methodsFor: 'accessing' stamp: 'bf 5/25/2007 21:11'!
type
^type! !
!DBusArgument methodsFor: 'accessing' stamp: 'bf 5/25/2007 18:19'!
value
^value ! !
!DBusArgument methodsFor: 'printing' stamp: 'bf 6/19/2008 20:16'!
printContainedSignatureOn: aStream
"XXX refactor into subclasses"
type = DBusArgument variant
ifTrue: [
"stored signature would be 'v' so ignore, must use actual signature"
^value asDBusArgument printSignatureOn: aStream].
signature ifNotNil: [
^('{(' includes: signature first)
ifTrue: [aStream next: signature size - 2 putAll: signature startingAt: 2]
ifFalse: [aStream next: signature size - 1 putAll: signature startingAt: 2]].
type caseOf: {
[DBusArgument struct]
-> [value do: [:ea| ea asDBusArgument printSignatureOn: aStream]].
[DBusArgument dictEntry]
-> [value key asDBusArgument printSignatureOn: aStream.
value value asDBusArgument printSignatureOn: aStream].
[DBusArgument array]
-> [value class == ByteArray
ifTrue: [aStream nextPut: DBusArgument byte]
ifFalse: [value first asDBusArgument printSignatureOn: aStream]].
}
! !
!DBusArgument methodsFor: 'printing' stamp: 'jaf 5/27/2007 00:00'!
printOn: aStream
aStream nextPutAll: self class name.
aStream nextPut: $(.
self printSignatureOn: aStream.
aStream nextPut: $);
nextPut: $[.
value printOn: aStream.
aStream nextPut: $]! !
!DBusArgument methodsFor: 'printing' stamp: 'bf 7/16/2007 17:17'!
printSignatureOn: aStream
"XXX refactor into subclasses"
signature ifNotNil: [ ^ aStream nextPutAll: signature].
self isBasicType ifTrue: [^aStream nextPut: type].
type caseOf: {
[DBusArgument struct]
-> [aStream nextPut: $(.
self printContainedSignatureOn: aStream.
aStream print: $)].
[DBusArgument dictEntry]
-> [aStream nextPut: ${.
self printContainedSignatureOn: aStream.
aStream nextPut: $}].
[DBusArgument array]
-> [aStream nextPut: $a.
self printContainedSignatureOn: aStream].
[DBusArgument variant]
-> [aStream nextPut: $v]
}
! !
!DBusArgument methodsFor: '*dbus-objects' stamp: 'bf 5/1/2008 20:26'!
fromDBusArgument: sender
"XXX refactor into subclasses"
self isBasicType ifTrue: [
type = DBusArgument objectPath
ifTrue: [^sender dbusObjectForPath: value].
^value].
^type caseOf: {
[DBusArgument struct]
-> [value collect: [:ea | ea fromDBusArgument: sender]].
[DBusArgument dictEntry]
-> [(value key fromDBusArgument: sender) -> (value value fromDBusArgument: sender)].
[DBusArgument array]
-> [| arr |
signature = 'ay' ifTrue: [^value].
arr := value collect: [:ea | ea fromDBusArgument: sender].
self containedSignature first =${
ifTrue: [arr as: Dictionary]
ifFalse: [arr]].
[DBusArgument variant]
-> [value fromDBusArgument: sender]
}
! !
!DBusArgument methodsFor: 'initialize' stamp: 'dmoc 2/2/2010 00:27'!
value: anObject type: aChar
" type := aChar.
value := anObject dbusCoerceTo: type
"
^ anObject! !
!DBusArgument class methodsFor: 'types' stamp: 'jf 5/21/2007 15:34'!
array
^ $a! !
!DBusArgument class methodsFor: 'types' stamp: 'bf 3/27/2008 14:36'!
boolean
^ $b! !
!DBusArgument class methodsFor: 'types' stamp: 'jf 5/21/2007 15:35'!
byte
^ $y! !
!DBusArgument class methodsFor: 'types' stamp: 'jf 5/21/2007 15:34'!
dictEntry
^ $e! !
!DBusArgument class methodsFor: 'types' stamp: 'jf 5/21/2007 15:38'!
double
^ $d! !
!DBusArgument class methodsFor: 'types' stamp: 'jf 5/21/2007 15:36'!
int16
^ $n! !
!DBusArgument class methodsFor: 'types' stamp: 'jf 5/21/2007 15:37'!
int32
^ $i! !
!DBusArgument class methodsFor: 'types' stamp: 'jf 5/21/2007 15:37'!
int64
^ $x! !
!DBusArgument class methodsFor: 'types' stamp: 'jf 5/21/2007 15:38'!
objectPath
^ $o! !
!DBusArgument class methodsFor: 'types' stamp: 'jf 5/21/2007 15:39'!
signature
^ $g! !
!DBusArgument class methodsFor: 'types' stamp: 'jf 5/21/2007 15:38'!
string
^ $s! !
!DBusArgument class methodsFor: 'types' stamp: 'jf 5/21/2007 15:34'!
struct
^ $r! !
!DBusArgument class methodsFor: 'types' stamp: 'jf 5/21/2007 15:36'!
uint16
^ $q! !
!DBusArgument class methodsFor: 'types' stamp: 'jf 5/21/2007 15:37'!
uint32
^ $u! !
!DBusArgument class methodsFor: 'types' stamp: 'jf 5/21/2007 15:37'!
uint64
^ $t! !
!DBusArgument class methodsFor: 'types' stamp: 'jf 5/21/2007 15:34'!
variant
^ $v! !
!DBusArgument class methodsFor: 'instance creation' stamp: 'bf 5/25/2007 20:34'!
array: arg
^ self value: arg type: self array
! !
!DBusArgument class methodsFor: 'instance creation' stamp: 'jaf 5/26/2007 22:51'!
array: arg signature: s
^ self value: arg signature: s
! !
!DBusArgument class methodsFor: 'instance creation' stamp: 'bf 3/27/2008 14:36'!
boolean: arg
^ self value: arg type: self boolean
! !
!DBusArgument class methodsFor: 'instance creation' stamp: 'bf 5/25/2007 20:35'!
byte: arg
^ self value: arg type: self byte.! !
!DBusArgument class methodsFor: 'instance creation' stamp: 'bf 5/25/2007 20:35'!
dictEntry: arg
^ self value: arg type: self dictEntry
! !
!DBusArgument class methodsFor: 'instance creation' stamp: 'bf 5/31/2007 19:04'!
dictEntry: arg signature: sig
^ self value: arg signature: sig
! !
!DBusArgument class methodsFor: 'instance creation' stamp: 'bf 5/25/2007 20:35'!
double: arg
^ self value: arg type: self double.! !
!DBusArgument class methodsFor: 'instance creation' stamp: 'bf 5/25/2007 20:35'!
int16: arg
^ self value: arg type: self int16.! !
!DBusArgument class methodsFor: 'instance creation' stamp: 'bf 5/25/2007 20:35'!
int32: arg
^ self value: arg type: self int32.! !
!DBusArgument class methodsFor: 'instance creation' stamp: 'bf 5/25/2007 20:35'!
int64: arg
^ self value: arg type: self int64.! !
!DBusArgument class methodsFor: 'instance creation' stamp: 'bf 5/25/2007 20:36'!
objectPath: arg
^ self value: arg type: self objectPath! !
!DBusArgument class methodsFor: 'instance creation' stamp: 'bf 5/25/2007 20:36'!
signature: arg
^ self value: arg type: self signature! !
!DBusArgument class methodsFor: 'instance creation' stamp: 'bf 5/25/2007 20:36'!
string: arg
^ self value: arg type: self string! !
!DBusArgument class methodsFor: 'instance creation' stamp: 'bf 5/25/2007 20:36'!
struct: arg
^ self value: arg type: self struct
! !
!DBusArgument class methodsFor: 'instance creation' stamp: 'bf 5/31/2007 19:06'!
struct: arg signature: sig
^ self value: arg signature: sig
! !
!DBusArgument class methodsFor: 'instance creation' stamp: 'bf 5/25/2007 20:36'!
uint16: arg
^ self value: arg type: self uint16.! !
!DBusArgument class methodsFor: 'instance creation' stamp: 'bf 5/25/2007 20:36'!
uint32: arg
^ self value: arg type: self uint32.! !
!DBusArgument class methodsFor: 'instance creation' stamp: 'bf 5/25/2007 20:36'!
uint64: arg
^ self value: arg type: self uint64.! !
!DBusArgument class methodsFor: 'instance creation' stamp: 'bf 6/18/2008 16:45'!
value: value signature: s
| arg |
arg := self value: value type: (
s first caseOf: {
[${] -> [self dictEntry].
[$(] -> [self struct].
} otherwise: [s first]).
arg signature: s.
^arg
! !
!DBusArgument class methodsFor: 'instance creation' stamp: 'bf 6/18/2008 16:47'!
value: value type: t
^ self new value: value type: t
! !
!DBusArgument class methodsFor: 'instance creation' stamp: 'bf 5/25/2007 20:36'!
variant: arg
^ self value: arg type: self variant.! !
!DBusArgument class methodsFor: 'instance creation' stamp: 'jaf 5/26/2007 22:52'!
variant: arg signature: s
^ self value: arg signature: s! !
!DBusArgument class methodsFor: 'utilities' stamp: 'bf 2/29/2008 10:55'!
fullNameOfSignature: aSignature
"Answer a capitalized fully recursive name for this signature"
| entry |
^String streamContents: [:stream |
self signaturesIn: aSignature do: [:sig |
stream nextPutAll: (sig first caseOf: {
[$a] -> ['ArrayOf', (self fullNameOfSignature: sig allButFirst)].
[${] -> [entry := self splitSignature: sig allButFirst allButLast.
'DictEntryMapping', (self fullNameOfSignature: entry first),
'To', (self fullNameOfSignature: entry second)].
[$(] -> [String streamContents: [:s |
s nextPutAll: 'StructWith'.
(self splitSignature: sig allButFirst allButLast)
do: [:each | s nextPutAll: (self fullNameOfSignature: each)]
separatedBy: [s nextPutAll: 'And']]]
}
otherwise: [(self nameOfType: sig first) capitalized])]]
"self fullNameOfSignature: 'a{s(six)}'"! !
!DBusArgument class methodsFor: 'utilities' stamp: 'bf 3/27/2008 16:16'!
nameOfSignature: aSignature
"Answer a capitalized readable name for this signature, including one level of contained types"
| entry |
^String streamContents: [:stream |
self signaturesIn: aSignature do: [:sig |
stream nextPutAll: (sig first caseOf: {
[$a] -> [
sig second caseOf: {
[${] -> ['Dictionary'].
[$a] -> [sig third = ${
ifTrue: ['ArrayOfDictionaries']
ifFalse: ['ArrayOfArrays']]
} otherwise: ['ArrayOf', (self nameOfType: sig second) capitalized, 's']].
[${] -> [entry := self splitSignature: sig allButFirst allButLast.
'DictEntryMapping', (self nameOfType: entry first first) capitalized,
'To', (self nameOfType: entry second first) capitalized].
[$(] -> [String streamContents: [:s |
s nextPutAll: 'StructWith'.
(self splitSignature: sig allButFirst allButLast)
do: [:each | s nextPutAll: (self nameOfType: each) capitalized]
separatedBy: [s nextPutAll: 'And']]]
}
otherwise: [(self nameOfType: sig first) capitalized])]]
"self nameOfSignature: 'a{s(six)}'"! !
!DBusArgument class methodsFor: 'utilities' stamp: 'bf 2/27/2008 17:27'!
nameOfType: aType
self typesAndNames
pairsDo: [:key :value | aType = key ifTrue: [^value]].
^nil! !
!DBusArgument class methodsFor: 'utilities' stamp: 'bf 2/26/2008 16:26'!
readSignature: aStream
"read one (complex) type from a signature stream, answer its signature"
| start |
start := aStream position.
self readType: aStream.
^aStream contents copyFrom: start+1 to: aStream position! !
!DBusArgument class methodsFor: 'utilities' stamp: 'bf 2/27/2008 17:27'!
readType: aStream
"skip one (complex) type from a signature stream, answer its type code"
| type |
type := aStream next.
type caseOf: {
[$a] -> [self readType: aStream].
[$(] -> [[aStream peek = $)] whileFalse: [self readType: aStream].
aStream next = $) ifFalse: [self error: 'malformed signature']].
[${] -> [self readType: aStream; readType: aStream.
aStream next = $} ifFalse: [self error: 'malformed signature']].
}
otherwise: [].
^type! !
!DBusArgument class methodsFor: 'utilities' stamp: 'bf 2/27/2008 17:25'!
signaturesIn: aString do: aBlock
"Evaluate aBlock with all (possibly complex) signatures in aString"
| in |
in := aString readStream.
[in atEnd] whileFalse: [
aBlock value: (self readSignature: in)].
! !
!DBusArgument class methodsFor: 'utilities' stamp: 'bf 2/27/2008 17:26'!
splitSignature: aString
"Answer an array of the signatures in aString"
^Array streamContents: [:out |
self signaturesIn: aString do: [:sig |
out nextPut: sig]].
"(self splitSignature: 'ass') = #('as' 's')"! !
!DBusArgument class methodsFor: 'utilities' stamp: 'bf 3/27/2008 14:35'!
typesAndNames
^#(
$a array
$b boolean
$y byte
$e dictEntry
${ dictEntry
$d double
$n int16
$i int32
$x int64
$o objectPath
$g signature
$s string
$r struct
$( struct
$q uint16
$u uint32
$t uint64
$v variant)! !
!DBusConnection methodsFor: 'initialize-release' stamp: 'bf 3/5/2008 16:27'!
close
"close the connection. The plugin will automatically reopen it on demand"
self primClose.
! !
!DBusConnection methodsFor: 'initialize-release' stamp: 'bf 3/7/2008 16:34'!
destroy
self setConnectionIndex: nil readSemaphore: nil! !
!DBusConnection methodsFor: 'initialize-release' stamp: 'bf 6/20/2008 00:18'!
registerSemaphore
(semaIndex notNil and: [(Smalltalk externalObjects at: semaIndex) == readSemaphore])
ifTrue: [^self].
semaIndex := readSemaphore ifNotNil: [Smalltalk registerExternalObject: readSemaphore]! !
!DBusConnection methodsFor: 'initialize-release' stamp: 'bf 3/7/2008 16:35'!
setConnectionIndex: aConnectionIndex readSemaphore: aSemaphore
connectionIndex ifNotNil: [self close].
connectionIndex := aConnectionIndex.
self unregisterSemaphore.
readSemaphore := aSemaphore.
self registerSemaphore.
! !
!DBusConnection methodsFor: 'initialize-release' stamp: 'bf 5/1/2008 15:57'!
startUp
self registerSemaphore.! !
!DBusConnection methodsFor: 'initialize-release' stamp: 'bf 3/7/2008 15:39'!
unregisterSemaphore
semaIndex ifNotNil: [
(Smalltalk externalObjects at: semaIndex) == readSemaphore
ifTrue: [Smalltalk unregisterExternalObject: readSemaphore].
semaIndex := nil].! !
!DBusConnection methodsFor: 'accessing' stamp: 'jaf 5/13/2007 19:38'!
dataRemains
^ ( self primDispatchStatus = DBusConnection dataRemains )
! !
!DBusConnection methodsFor: 'accessing' stamp: 'jaf 5/13/2007 18:54'!
dispatchStatus
^ self primDispatchStatus ! !
!DBusConnection methodsFor: 'accessing' stamp: 'jaf 4/26/2007 13:04'!
errorName
^ self primMessageGetErrorName! !
!DBusConnection methodsFor: 'accessing' stamp: 'jf 5/21/2007 15:51'!
messageHasArguments
^ self primMessageHasArguments
! !
!DBusConnection methodsFor: 'accessing' stamp: 'jaf 4/26/2007 13:01'!
messageInterface
^ self primMessageGetInterface! !
!DBusConnection methodsFor: 'accessing' stamp: 'bf 6/19/2008 01:23'!
messageMember
^ self primMessageGetMember! !
!DBusConnection methodsFor: 'accessing' stamp: 'bf 3/5/2008 17:28'!
messageNoReply
^ self primMessageGetNoReply! !
!DBusConnection methodsFor: 'accessing' stamp: 'jaf 4/26/2007 13:00'!
messagePath
^ self primMessageGetPath! !
!DBusConnection methodsFor: 'accessing' stamp: 'jaf 5/3/2007 14:05'!
messageReplySerial
^ self primMessageReplySerial! !
!DBusConnection methodsFor: 'accessing' stamp: 'jaf 4/26/2007 13:00'!
messageSender
^ self primMessageGetSender! !
!DBusConnection methodsFor: 'accessing' stamp: 'jaf 4/27/2007 10:02'!
messageSerial
^ self primMessageSerial! !
!DBusConnection methodsFor: 'accessing' stamp: 'jaf 4/26/2007 13:01'!
messageSignature
^ self primMessageGetSignature! !
!DBusConnection methodsFor: 'accessing' stamp: 'jaf 4/26/2007 14:10'!
nextIterator
^ self primNextIterator! !
!DBusConnection methodsFor: 'accessing' stamp: 'jaf 4/26/2007 13:47'!
popIterator
^ self primPopIterator! !
!DBusConnection methodsFor: 'accessing' stamp: 'jaf 5/8/2007 20:42'!
readSemaphore
^readSemaphore ! !
!DBusConnection methodsFor: 'private' stamp: 'jaf 5/27/2007 00:34'!
getArgument
| type |
type := self getArgumentType.
"a hack for dbus_type_invalid"
(type asInteger = 0) ifTrue: [^ nil].
Readers at: type ifPresent: [:sel | ^ self perform: sel].
self error: 'Found no selector for argument type: ', type .! !
!DBusConnection methodsFor: 'private' stamp: 'dmoc 2/2/2010 00:19'!
matchString: anArray
"Construct a dbus match string from anArray"
^String streamContents: [:strm |
anArray pairsDo: [:key :value |
strm position > 0 ifTrue: [strm nextPut: $,].
strm nextPutAll: key;
nextPut: $=;
print: value]]! !
!DBusConnection methodsFor: 'private' stamp: 'jaf 5/26/2007 21:16'!
openContainerOfType: t containedSignature: s
^ self primOpenContainer: t asInteger containedSignature: s! !
!DBusConnection methodsFor: 'primitives' stamp: 'jaf 5/27/2007 00:05'!
primAddMatch: rule
"adds a match rule to recive signals"
<primitive: 'primitiveDBusAddMatch' module: 'DBusPlugin'>
^ self primitiveFailed! !
!DBusConnection methodsFor: 'primitives' stamp: 'jaf 5/27/2007 00:06'!
primAppendBasicArgument: arg ofType: t
"appends a basic type argument like int16 or uint32 of type t to the external message"
<primitive: 'primitiveDBusAppendBasicArgument' module: 'DBusPlugin'>
^ self primitiveFailed
! !
!DBusConnection methodsFor: 'primitives' stamp: 'jaf 4/23/2007 18:44'!
primArgumentGetBool
<primitive: 'primitiveDBusArgumentGetBool' module: 'DBusPlugin'>
^ self primitiveFailed! !
!DBusConnection methodsFor: 'primitives' stamp: 'jf 5/23/2007 19:05'!
primArgumentGetByte
<primitive: 'primitiveDBusArgumentGetByte' module: 'DBusPlugin'>
^ self primitiveFailed! !
!DBusConnection methodsFor: 'primitives' stamp: 'jaf 4/20/2007 11:24'!
primArgumentGetFloat
<primitive: 'primitiveDBusArgumentGetDouble' module: 'DBusPlugin'>
^ self primitiveFailed! !
!DBusConnection methodsFor: 'primitives' stamp: 'jf 5/23/2007 19:05'!
primArgumentGetInt16
<primitive: 'primitiveDBusArgumentGetInt16' module: 'DBusPlugin'>
^ self primitiveFailed! !
!DBusConnection methodsFor: 'primitives' stamp: 'jf 5/23/2007 19:06'!
primArgumentGetInt32
<primitive: 'primitiveDBusArgumentGetInt32' module: 'DBusPlugin'>
^ self primitiveFailed! !
!DBusConnection methodsFor: 'primitives' stamp: 'jf 5/23/2007 19:06'!
primArgumentGetInt64
<primitive: 'primitiveDBusArgumentGetInt64' module: 'DBusPlugin'>
^ self primitiveFailed! !
!DBusConnection methodsFor: 'primitives' stamp: 'bf 5/14/2007 20:53'!
primArgumentGetObjectPath
<primitive: 'primitiveDBusArgumentGetObjectPath' module: 'DBusPlugin'>
^ self primitiveFailed! !
!DBusConnection methodsFor: 'primitives' stamp: 'jf 5/23/2007 19:12'!
primArgumentGetSignature
<primitive: 'primitiveDBusArgumentGetSignature' module: 'DBusPlugin'>
^ self primitiveFailed! !
!DBusConnection methodsFor: 'primitives' stamp: 'jaf 4/20/2007 10:34'!
primArgumentGetString
<primitive: 'primitiveDBusArgumentGetString' module: 'DBusPlugin'>
^ self primitiveFailed! !
!DBusConnection methodsFor: 'primitives' stamp: 'jaf 4/26/2007 11:12'!
primArgumentGetType
<primitive: 'primitiveDBusArgumentGetType' module: 'DBusPlugin'>
^ self primitiveFailed! !
!DBusConnection methodsFor: 'primitives' stamp: 'jf 5/23/2007 19:06'!
primArgumentGetUInt16
<primitive: 'primitiveDBusArgumentGetUInt16' module: 'DBusPlugin'>
^ self primitiveFailed! !
!DBusConnection methodsFor: 'primitives' stamp: 'jf 5/23/2007 19:06'!
primArgumentGetUInt32
<primitive: 'primitiveDBusArgumentGetUInt32' module: 'DBusPlugin'>
^ self primitiveFailed! !
!DBusConnection methodsFor: 'primitives' stamp: 'jf 5/23/2007 19:06'!
primArgumentGetUInt64
<primitive: 'primitiveDBusArgumentGetUInt64' module: 'DBusPlugin'>
^ self primitiveFailed! !
!DBusConnection methodsFor: 'primitives' stamp: 'jaf 5/27/2007 00:07'!
primClose
"close the connection of the receiver and destroy the singleton in the plugin"
<primitive: 'primitiveDBusConnectionClose' module: 'DBusPlugin'>
^ self primitiveFailed! !
!DBusConnection methodsFor: 'primitives' stamp: 'jaf 5/27/2007 00:08'!
primCloseContainer
"close an prevouisly opened container in the plugin"
<primitive: 'primitiveDBusIterCloseContainer' module: 'DBusPlugin'>
^ self primitiveFailed
! !
!DBusConnection methodsFor: 'primitives' stamp: 'jaf 5/27/2007 00:08'!
primCreateMessageFrom: msg
"creates an external messages for the msg object"
<primitive: 'primitiveDBusCreateMessageFrom' module: 'DBusPlugin'>
^ self primitiveFailed! !
!DBusConnection methodsFor: 'primitives' stamp: 'jaf 5/27/2007 00:09'!
primDispatchStatus
"answer the process status of the receivers connection
0 data remains
1 complete
2 need memory"
<primitive: 'primitiveDBusConnectionDispatchStatus' module: 'DBusPlugin'>
^ self primitiveFailed! !
!DBusConnection methodsFor: 'primitives' stamp: 'bf 7/16/2007 16:06'!
primInitializeWriteIterator
"initializes an iterator for the externel messages to add arguments"
<primitive: 'primitiveDBusInitializeWriteIterator' module: 'DBusPlugin'>
^ self primitiveFailed! !
!DBusConnection methodsFor: 'primitives' stamp: 'jaf 5/27/2007 00:10'!
primIteratorSignature
"answer the signature of the currently active iterator"
<primitive: 'primitiveDBusIteratorSignature' module: 'DBusPlugin'>
^ self primitiveFailed! !
!DBusConnection methodsFor: 'primitives' stamp: 'jaf 5/27/2007 00:11'!
primMessageGetDestination
"answers the destination of the received message"
<primitive: 'primitiveDBusMessageGetDestination' module: 'DBusPlugin'>
^ self primitiveFailed! !
!DBusConnection methodsFor: 'primitives' stamp: 'jaf 5/27/2007 00:11'!
primMessageGetErrorName
"answers the name of the received error message"
<primitive: 'primitiveDBusMessageGetErrorName' module: 'DBusPlugin'>
^ self primitiveFailed! !
!DBusConnection methodsFor: 'primitives' stamp: 'jaf 5/27/2007 00:11'!
primMessageGetInterface
"answers the inteface of the received message"
<primitive: 'primitiveDBusMessageGetInterface' module: 'DBusPlugin'>
^ self primitiveFailed! !
!DBusConnection methodsFor: 'primitives' stamp: 'jaf 5/27/2007 00:13'!
primMessageGetMember
"answers the selector of the received message."
<primitive: 'primitiveDBusMessageGetMember' module: 'DBusPlugin'>
^ self primitiveFailed! !
!DBusConnection methodsFor: 'primitives' stamp: 'jaf 5/27/2007 00:14'!
primMessageGetNoReply
"answers true if the received message expects a reply"
<primitive: 'primitiveDBusMessageGetNoReply' module: 'DBusPlugin'>
^ self primitiveFailed! !
!DBusConnection methodsFor: 'primitives' stamp: 'jaf 5/27/2007 00:14'!
primMessageGetPath
"answers the path of the received message"
<primitive: 'primitiveDBusMessageGetPath' module: 'DBusPlugin'>
^ self primitiveFailed! !
!DBusConnection methodsFor: 'primitives' stamp: 'jaf 5/27/2007 00:14'!
primMessageGetSender
"answers the serial for the sender of the received message"
<primitive: 'primitiveDBusMessageGetSender' module: 'DBusPlugin'>
^ self primitiveFailed! !
!DBusConnection methodsFor: 'primitives' stamp: 'jaf 5/27/2007 00:15'!
primMessageGetSignature
"answers the signature of the received message"
<primitive: 'primitiveDBusMessageGetSignature' module: 'DBusPlugin'>
^ self primitiveFailed! !
!DBusConnection methodsFor: 'primitives' stamp: 'jaf 5/27/2007 00:15'!
primMessageHasArguments
"answers true if the received message has arguments to read"
<primitive: 'primitiveDBusMessageHasArguments' module: 'DBusPlugin'>
^ self primitiveFailed! !
!DBusConnection methodsFor: 'primitives' stamp: 'jaf 5/27/2007 00:17'!
primMessageReplySerial
"answers the serial that the received message is a reply to or 0 if none"
<primitive: 'primitiveDBusMessageGetReplySerial' module: 'DBusPlugin'>
^ self primitiveFailed! !
!DBusConnection methodsFor: 'primitives' stamp: 'jaf 5/27/2007 00:17'!
primMessageSerial
"answers the serial of the received message"
<primitive: 'primitiveDBusMessageGetSerial' module: 'DBusPlugin'>
^ self primitiveFailed! !
!DBusConnection methodsFor: 'primitives' stamp: 'jaf 5/27/2007 00:19'!
primNextIterator
"switches the current iterator to his next to read the next argument. it answers true if the current has a next iterator otherwise false"
<primitive: 'primitiveDBusNextIterator' module: 'DBusPlugin'>
^ self primitiveFailed! !
!DBusConnection methodsFor: 'primitives' stamp: 'jaf 5/27/2007 00:23'!
primOpenContainer: t containedSignature: s
"opens a new subcontainer in the plugin to write arrays, structs, variants or dictentries. If you want to open a container to write the elements of an array the containedSignature should be a string of the element signatures. To write an variant containedSignature should be the signature of the value of the variant. It can be nil on structs and dictentries"
<primitive: 'primitiveDBusIterOpenContainerContains' module: 'DBusPlugin'>
^ self primitiveFailed
! !
!DBusConnection methodsFor: 'primitives' stamp: 'jaf 5/27/2007 00:24'!
primPopIterator
"pops an interator from the iterator stack"
<primitive: 'primitiveDBusPopMessageIterator' module: 'DBusPlugin'>
^ self primitiveFailed! !
!DBusConnection methodsFor: 'primitives' stamp: 'jaf 5/27/2007 00:25'!
primPopMessage
"answers and pops a received message from the message queue in the plugin"
<primitive: 'primitiveDBusConnectionPopMessage' module: 'DBusPlugin'>
^ self primitiveFailed! !
!DBusConnection methodsFor: 'primitives' stamp: 'jaf 5/27/2007 00:25'!
primPushIterator
"pushes an iterator to an iterator stack to read container type arguments"
<primitive: 'primitiveDBusPushMessageIterator' module: 'DBusPlugin'>
^ self primitiveFailed! !
!DBusConnection methodsFor: 'primitives' stamp: 'jaf 4/27/2007 13:23'!
primRegisterName: name
"1 Service has become the primary owner of the requested name
2 Service could not become primary owner and has been placed in the queue
3 Service is already in the queue
4 Service is already the primary owner"
<primitive: 'primitiveDBusRegisterName' module: 'DBusPlugin'>
^ self primitiveFailed! !
!DBusConnection methodsFor: 'primitives' stamp: 'jaf 4/27/2007 13:23'!
primReleaseName: name
"1 Service was released from the given name
2 Name does not exist on the bus
3 Service is not owner of the given name"
<primitive: 'primitiveDBusReleaseName' module: 'DBusPlugin'>
^ self primitiveFailed! !
!DBusConnection methodsFor: 'primitives' stamp: 'jaf 5/27/2007 00:27'!
primRemoveMatch: rule
"removes a match rule for a signal"
<primitive: 'primitiveDBusRemoveMatch' module: 'DBusPlugin'>
^ self primitiveFailed! !
!DBusConnection methodsFor: 'primitives' stamp: 'bf 3/5/2008 18:00'!
primSendMessageTimeout: milliseconds
"Send the previously created message and return the serial of the message. If timeout is 0, do not generate a timeout error. If timeout is -1, use a default timeout."
<primitive: 'primitiveDBusSendMessageTimeout' module: 'DBusPlugin'>
^ self primitiveFailed! !
!DBusConnection methodsFor: 'arguments-read' stamp: 'bf 5/8/2008 17:17'!
argumentReadArray
"returns an array"
| arg sig array |
sig := self primIteratorSignature.
sig = 'ay' ifTrue: [
^DBusArgument array: (
ByteArray streamContents: [:strm |
self primPushIterator.
[ arg := [self primArgumentGetByte] ifError: [nil].
"XXX earlier plugins answer signed bytes"
arg ifNotNil: [strm nextPut: (arg bitAnd: 16rFF)].
self nextIterator
] whileTrue.
self popIterator])
signature: sig].
array := Array streamContents: [:strm |
self primPushIterator.
[ arg := self getArgument.
arg ifNotNil: [strm nextPut: arg].
self nextIterator
] whileTrue.
self popIterator].
^ DBusArgument array: array signature: sig
! !
!DBusConnection methodsFor: 'arguments-read' stamp: 'bf 3/27/2008 14:37'!
argumentReadBoolean
^ DBusArgument boolean: self primArgumentGetBool! !
!DBusConnection methodsFor: 'arguments-read' stamp: 'bf 3/27/2008 17:46'!
argumentReadByte
"XXX earlier plugins answer signed bytes"
^ DBusArgument byte: (self primArgumentGetByte bitAnd: 16rFF)! !
!DBusConnection methodsFor: 'arguments-read' stamp: 'bf 5/31/2007 19:08'!
argumentReadDictEntry
| sig key value |
sig := self primIteratorSignature.
self primPushIterator.
key := self getArgument.
self nextIterator.
value := self getArgument.
self popIterator.
^DBusArgument dictEntry: key->value signature: sig.
! !
!DBusConnection methodsFor: 'arguments-read' stamp: 'jaf 5/26/2007 23:47'!
argumentReadDouble
^ DBusArgument double: self primArgumentGetFloat! !
!DBusConnection methodsFor: 'arguments-read' stamp: 'jaf 5/26/2007 23:48'!
argumentReadInt16
^ DBusArgument int16: self primArgumentGetInt16! !
!DBusConnection methodsFor: 'arguments-read' stamp: 'jaf 5/26/2007 23:48'!
argumentReadInt32
^ DBusArgument int32: self primArgumentGetInt32! !
!DBusConnection methodsFor: 'arguments-read' stamp: 'jaf 5/26/2007 23:48'!
argumentReadInt64
^ DBusArgument int64: self primArgumentGetInt64! !
!DBusConnection methodsFor: 'arguments-read' stamp: 'jaf 5/26/2007 23:49'!
argumentReadObjectPath
^ DBusArgument objectPath: self primArgumentGetObjectPath! !
!DBusConnection methodsFor: 'arguments-read' stamp: 'jaf 5/26/2007 23:49'!
argumentReadSignature
^ DBusArgument signature: self primArgumentGetSignature! !
!DBusConnection methodsFor: 'arguments-read' stamp: 'jaf 5/26/2007 23:49'!
argumentReadString
^ DBusArgument string: self primArgumentGetString! !
!DBusConnection methodsFor: 'arguments-read' stamp: 'bf 5/31/2007 19:06'!
argumentReadStruct
"returns an struct"
| sig arr hasArg |
sig := self primIteratorSignature.
arr := OrderedCollection new.
self primPushIterator.
"read the members of the struct"
hasArg := true.
[hasArg]
whileTrue: [
arr add: self getArgument.
hasArg := self nextIterator.
].
self popIterator.
^ DBusArgument struct: arr asArray signature: sig! !
!DBusConnection methodsFor: 'arguments-read' stamp: 'jaf 5/26/2007 23:49'!
argumentReadUInt16
^ DBusArgument uint16: self primArgumentGetUInt16! !
!DBusConnection methodsFor: 'arguments-read' stamp: 'jaf 5/26/2007 23:50'!
argumentReadUInt32
^ DBusArgument uint32: self primArgumentGetUInt32! !
!DBusConnection methodsFor: 'arguments-read' stamp: 'jaf 5/26/2007 23:50'!
argumentReadUInt64
^ DBusArgument uint64: self primArgumentGetUInt64! !
!DBusConnection methodsFor: 'arguments-read' stamp: 'jaf 5/26/2007 23:51'!
argumentReadVariant
"returns a variant"
| variant sig |
sig := self primIteratorSignature.
self primPushIterator.
variant := self getArgument.
self popIterator.
^DBusArgument variant: variant signature: sig! !
!DBusConnection methodsFor: 'arguments-read' stamp: 'dmoc 2/2/2010 00:23'!
getArgumentType
| byte |
^ (byte _ self primArgumentGetType) ifNotNil: [ byte asCharacter]! !
!DBusConnection methodsFor: 'arguments-write' stamp: 'bf 6/19/2008 20:33'!
argumentWriteArray: arg
| sig |
sig := arg containedSignature.
(self openContainerOfType: arg dbusType containedSignature: sig) ifTrue: [
sig = 'y'
ifTrue: [arg value do: [:each | self primAppendBasicArgument: each ofType: 121]]
ifFalse: [arg containedDBusArgumentsDo: [:each| self writeArgument: each]].
self primCloseContainer ].
! !
!DBusConnection methodsFor: 'arguments-write' stamp: 'jaf 5/26/2007 21:15'!
argumentWriteBasicArgument: arg
self primAppendBasicArgument: arg value ofType: arg type asInteger
! !
!DBusConnection methodsFor: 'arguments-write' stamp: 'bf 7/16/2007 17:11'!
argumentWriteDictEntry: arg
(self openContainerOfType: arg dbusType containedSignature: arg containedSignature) ifTrue: [
arg containedDBusArgumentsDo: [:each| self writeArgument: each].
self primCloseContainer].
! !
!DBusConnection methodsFor: 'arguments-write' stamp: 'bf 7/16/2007 17:10'!
argumentWriteStruct: arg
(self openContainerOfType: arg dbusType containedSignature: arg containedSignature) ifTrue: [
arg containedDBusArgumentsDo: [:each| self writeArgument: each].
self primCloseContainer].
! !
!DBusConnection methodsFor: 'arguments-write' stamp: 'bf 7/16/2007 17:11'!
argumentWriteVariant: arg
(self openContainerOfType: arg dbusType containedSignature: arg containedSignature) ifTrue: [
arg containedDBusArgumentsDo: [:each| self writeArgument: each].
self primCloseContainer].
! !
!DBusConnection methodsFor: 'arguments-write' stamp: 'dmoc 2/2/2010 00:41'!
writeArgument: arg
^self perform: (Writers at: arg "dbusType") with: arg
! !
!DBusConnection methodsFor: 'dbus-matches' stamp: 'bf 11/28/2007 15:10'!
addMatch: anArray
"add a match. Keys include type, sender, interface, member, path, destination, arg0, arg1 etc. Only string args can be matched.
E.g. #(type 'signal'
sender 'org.freedesktop.DBus'
interface 'org.freedesktop.DBus'
member 'Foo'
path '/bar/foo'
destination ':452345.34')
"
^ self primAddMatch: (self matchString: anArray)! !
!DBusConnection methodsFor: 'dbus-matches' stamp: 'bf 11/28/2007 15:10'!
removeMatch: anArray
"Remove a match added by addMatch:"
^ self primRemoveMatch: (self matchString: anArray)! !
!DBusConnection methodsFor: 'messages' stamp: 'bf 6/19/2008 01:55'!
popMessage
""
"first read dbus connection"
| type msg |
type := self primPopMessage.
"if there is no new message reveived return"
(type = 0) ifTrue:[^nil].
"create new message"
msg := DBusMessage typeCode: type.
msg ifNil:[^nil].
"read message from the bus"
msg readFromConnection: self.
^msg! !
!DBusConnection methodsFor: 'messages' stamp: 'bf 3/5/2008 17:58'!
sendMessage: msg
"send message with a (system-defined) default timeout"
^self sendMessage: msg timeout: -1! !
!DBusConnection methodsFor: 'messages' stamp: 'bf 3/5/2008 17:59'!
sendMessage: msg timeout: timeoutMilliseconds
"create a new external message"
| serial |
self primCreateMessageFrom: msg.
"add arguments to the message"
msg hasArguments ifTrue: [
"initialize iterator"
self primInitializeWriteIterator.
msg arguments do: [:each| self writeArgument: each]].
"finally send the message"
serial := self primSendMessageTimeout: (msg reply
ifTrue: [timeoutMilliseconds]
ifFalse: [0]).
msg serial: serial.
^serial! !
!DBusConnection methodsFor: 'printing' stamp: 'bf 3/5/2008 17:03'!
printOn: aStream
aStream
nextPutAll: self class name;
nextPutAll: (connectionIndex caseOf: {
[0] -> [' sessionBus'].
[1] -> [' systemBus']
} otherwise: ['(invalid)']).! !
!DBusConnection methodsFor: 'dbus-names' stamp: 'bf 5/31/2007 17:24'!
registerName: name
"1 Service has become the primary owner of the requested name
2 Service could not become primary owner and has been placed in the queue
3 Service is already in the queue
4 Service is already the primary owner"
(#(1 4) includes: (self primRegisterName: name))
ifFalse: [self error: 'DBus: Could not become primary owner of ', name]
! !
!DBusConnection methodsFor: 'dbus-names' stamp: 'jaf 4/27/2007 13:23'!
releaseName: name
self primReleaseName: name ! !
!DBus methodsFor: 'exporting' stamp: 'bf 6/24/2008 18:06'!
export: aDBusObject on: aDBusName at: aPathString
self registerName: aDBusName.
exported ifNil: [exported := DBusObject new dbusConnection: self].
exported dbusAdd: aDBusObject path: (aPathString findTokens: '/').! !
!DBus methodsFor: 'exporting' stamp: 'bf 6/19/2008 14:12'!
exportedAt: aPathString
^exported ifNotNil: [exported dbusChildAtPath: (aPathString findTokens: '/')].! !
!DBus methodsFor: 'importing' stamp: 'bf 4/30/2008 18:11'!
get: aProxyClass
^aProxyClass new
setConnection: self
busName: aProxyClass dbusName
objectPath: aProxyClass dbusPath! !
!DBus methodsFor: 'importing' stamp: 'bf 3/14/2008 19:54'!
getObject: aNameString path: aPathString
^DBusProxy
connection: self
busName: aNameString
objectPath: aPathString! !
!DBus methodsFor: 'mainloop' stamp: 'bf 6/19/2008 14:13'!
dispatchMessage: msg
| object |
object := self exportedAt: msg path.
object ifNil: [
^msg isMethodCall ifTrue: [
self sendMessage: (DBusMessageError newFor: msg
name: DBusMessageError dbusErrorUnknownObject
withMessage: 'Unknown object ', msg path)]].
object dbusHandle: msg from: self! !
!DBus methodsFor: 'mainloop' stamp: 'bf 8/29/2008 16:07'!
handleMessage: msg
| actions |
self logDebug: self asString, ' received ', msg asString.
"take care to not call handlers while accessLock is held, they could block"
actions := OrderedCollection new.
accessLock critical: [
matchHandlers keysAndValuesDo: [:match :handler |
(match matches: msg) ifTrue: [
actions add: [handler copy valueWithArguments: {msg}] fixTemps]].
msg isReplyOrError
ifTrue: [(replyHandlers removeKey: msg replySerial ifAbsent: [])
ifNotNilDo: [:handler | actions add: [handler handleReplyOrError: msg]]]
ifFalse: [actions add: [self dispatchMessage: msg]]].
actions do: [:action | action forkAt: Processor activePriority - 5
named: self printString, ' handler ', msg serial asString]! !
!DBus methodsFor: 'mainloop' stamp: 'bf 6/19/2008 13:55'!
mainloop
[true] whileTrue:
[self processMessages.
readSemaphore wait]
! !
!DBus methodsFor: 'mainloop' stamp: 'bf 6/19/2008 13:55'!
processMessages
[self dataRemains] whileTrue:
[self popMessage ifNotNilDo: [:msg | self handleMessage: msg]].
! !
!DBus methodsFor: 'mainloop' stamp: 'bf 6/19/2008 13:53'!
restartMainloop
process ifNotNil: [process terminate].
process := [self mainloop]
forkAt: Processor userInterruptPriority
named: self printString, ' mainloop'! !
!DBus methodsFor: 'logging' stamp: 'bf 5/1/2008 16:43'!
logDebug: aString
WorldState addDeferredUIMessage: [Transcript cr; show: aString].! !
!DBus methodsFor: 'logging' stamp: 'bf 5/1/2008 16:39'!
logWarning: aString
WorldState addDeferredUIMessage: [Transcript cr; show: aString].! !
!DBus methodsFor: 'matching' stamp: 'bf 8/29/2008 15:55'!
onMatch: aDBusMatch do: aBlockOrMessageSend
accessLock critical: [
self primAddMatch: aDBusMatch matchString squeakToUtf8.
matchHandlers at: aDBusMatch put: aBlockOrMessageSend fixTemps]! !
!DBus methodsFor: 'matching' stamp: 'bf 6/19/2008 14:53'!
removeMatch: aDBusMatch
accessLock critical: [
self primRemoveMatch: aDBusMatch matchString squeakToUtf8.
matchHandlers removeKey: aDBusMatch ifAbsent: []]! !
!DBus methodsFor: 'sending' stamp: 'bf 5/26/2008 17:42'!
sendDBusMessage: aMessage
"send aMessage synchronously, wait until a response comes back. Answer reply message, or raise an error if send failed or timed out"
^self sendDBusMessage: aMessage timeout: -1! !
!DBus methodsFor: 'sending' stamp: 'bf 6/19/2008 12:14'!
sendDBusMessage: aMessage timeout: seconds
"send aMessage synchronously, wait until a response comes back. Answer reply message, or raise an error if send failed or timed out"
| sema reply |
sema := Semaphore new.
self sendDBusMessage: aMessage
timeout: seconds
onSuccess: [:msg | reply := msg. sema signal]
onError: [: msg | reply := msg. sema signal].
sema wait.
reply isError ifTrue: [^DBusError signal: reply message].
^reply! !
!DBus methodsFor: 'sending' stamp: 'bf 6/19/2008 14:11'!
sendDBusMessage: aMessage timeout: seconds onSuccess: successHandler onError: errorHandler
"send aMessage asynchronously, evaluating successHandler or errorHandler when a response or error comes in, or the timeout is over."
| replyCode |
accessLock critical: [
replyCode := self sendMessage: aMessage timeout: seconds.
replyHandlers at: replyCode put: (DBusHandler onSuccess: successHandler onError: errorHandler)
].
! !
!DBus methodsFor: 'private' stamp: 'bf 6/12/2008 16:25'!
sendMessage: msg timeout: seconds
"Low-level send. Use sendDBusMessage:timeout: instead!!"
self logDebug: self asString, ' sent ', msg asString.
^super sendMessage: msg timeout: seconds! !
!DBus methodsFor: 'initialize-release' stamp: 'bf 6/19/2008 14:28'!
startUp
exported := nil.
replyHandlers := Dictionary new.
matchHandlers := Dictionary new.
accessLock := Semaphore forMutualExclusion.
self restartMainloop.
super startUp.
! !
!DBusConnection class methodsFor: 'constants' stamp: 'jaf 5/13/2007 20:07'!
complete
"incoming queue is empty"
^ 1! !
!DBusConnection class methodsFor: 'constants' stamp: 'jaf 5/15/2007 11:00'!
dataRemains
"indicates that the message queue may contain messages"
^ 0! !
!DBusConnection class methodsFor: 'constants' stamp: 'jaf 5/15/2007 11:02'!
needMemory
"indicates that there could be data, but whitout more memory it is not sure"
^ 2! !
!DBusConnection class methodsFor: 'instance creation' stamp: 'bf 3/7/2008 16:38'!
sessionBus
"automatically migrate to a more specific subclass of me"
^SessionBus := self getBus: 0 from: SessionBus! !
!DBusConnection class methodsFor: 'instance creation' stamp: 'bf 3/7/2008 16:40'!
systemBus
"automatically migrate to a more specific subclass of me"
^SystemBus := self getBus: 1 from: SystemBus! !
!DBusConnection class methodsFor: 'class initialization' stamp: 'bf 3/27/2008 14:37'!
initialize
"self initialize"
"start up before AutoStart".
" Smalltalk addToStartUpList: self after: FileDirectory.
"
Readers := {
$b->#argumentReadBoolean.
$d->#argumentReadDouble.
$s->#argumentReadString.
$a->#argumentReadArray.
$e->#argumentReadDictEntry.
$r->#argumentReadStruct.
$o->#argumentReadObjectPath.
$v->#argumentReadVariant.
$y->#argumentReadByte.
$n->#argumentReadInt16.
$q->#argumentReadUInt16.
$i->#argumentReadInt32.
$u->#argumentReadUInt32.
$x->#argumentReadInt64.
$t->#argumentReadUInt64.
$g->#argumentReadSignature.
} as: Dictionary.
Writers := {
$b->#argumentWriteBasicArgument:.
$i->#argumentWriteBasicArgument:.
$d->#argumentWriteBasicArgument:.
$s->#argumentWriteBasicArgument:.
$y->#argumentWriteBasicArgument:.
$n->#argumentWriteBasicArgument:.
$q->#argumentWriteBasicArgument:.
$u->#argumentWriteBasicArgument:.
$x->#argumentWriteBasicArgument:.
$t->#argumentWriteBasicArgument:.
$o->#argumentWriteBasicArgument:.
$g->#argumentWriteBasicArgument:.
$a->#argumentWriteArray:.
$e->#argumentWriteDictEntry:.
$r->#argumentWriteStruct:.
$v->#argumentWriteVariant:.
} as: Dictionary.
! !
!DBusConnection class methodsFor: 'class initialization' stamp: 'bf 3/7/2008 16:49'!
unload
Smalltalk removeFromStartUpList: self.
self allBussesDo: [:each | each destroy]! !
!DBusConnection class methodsFor: 'private' stamp: 'bf 3/7/2008 16:48'!
allBussesDo: aBlock
SessionBus ifNotNilDo: [:bus | aBlock value: bus].
SystemBus ifNotNilDo: [:bus | aBlock value: bus].! !
!DBusConnection class methodsFor: 'private' stamp: 'bf 6/20/2008 00:22'!
getBus: connIndex from: oldBus
"automatically migrate to a more specific subclass of me"
| sema |
(oldBus isKindOf: self) ifTrue: [^oldBus].
oldBus ifNotNil: [
sema := oldBus readSemaphore.
oldBus destroy].
sema ifNil: [sema := Semaphore new].
^self new
setConnectionIndex: connIndex readSemaphore: sema;
startUp;
yourself! !
!DBusConnection class methodsFor: 'examples' stamp: 'bf 6/19/2008 01:09'!
example
"this example show the general low level usage of the dbus plugin"
" to start call
DBusConnection example
to stop the process call
DBusConnection new sendMessage: (DBusMessage testMethodCall member: 'setprocessstatus')
send a signal
DBusConnection new sendMessage: (DBusMessage testSignal)
"
| connection msg process appName |
appName := 'org.squeak.dbus.example'.
"connect tot session bus"
connection := DBusConnection sessionBus.
"request unique name for squeak example at dbus"
connection registerName: appName.
"register a match rule to receive a certain signal"
connection addMatch: #(
type 'signal'
interface 'org.squeak.dbus.testinterface').
process := true.
[
Transcript show: String cr, '--- Begin dbus queue processing ---'; cr.
"step the connection"
[process] whileTrue: [
[connection dataRemains] whileTrue: [
"read messages"
msg := connection popMessage.
msg ifNotNil: [Transcript show: 'Received message: ', msg asString; cr.
"process message"
msg isMethodCall
ifTrue: [ ((msg member = 'setprocessstatus') and: [msg hasArguments])
ifTrue: [ process := (msg arguments at: 1) value ]
ifFalse: [ "answer an error"
connection sendMessage: (DBusMessageError unknownMethod: msg)] ]
].
].
process ifTrue: [connection readSemaphore wait].
].
"release name"
connection releaseName: appName.
"close connection"
connection close.
Transcript show: '--- end ---' , String cr.
] forkAt: Processor userBackgroundPriority.
" send a quit message
DBusConnection new sendMessage:
((DBusMessageMethodCall destination: 'org.squeak.dbus.example'
path: '/org/squeak/dbus/example'
interface: 'org.squeak.dbus.test'
member: 'setprocessstatus' )
addArgument: (DBusArgument bool: false);
reply: false)
"
! !
!DBusConnection class methodsFor: 'start up' stamp: 'bf 5/1/2008 15:58'!
startUp: resuming
resuming ifFalse: [^self].
self allBussesDo: [:each| each startUp]! !
!DBusExplorer methodsFor: 'accessing' stamp: 'bf 6/16/2008 16:28'!
getList
"Get all running DBus services by looking up registered names"
^{DBus systemBus. DBus sessionBus}
collect: [:each | DBusExplorerWrapper connection: each service: '' path: '']
! !
!DBusExplorer methodsFor: 'opening' stamp: 'bf 2/21/2008 11:04'!
inAWindow
| window |
window := (SystemWindow labelled: self class name) model: self.
window
addMorph: self notInAWindow
frame: (0@0 corner: 1@1).
^ window! !
!DBusExplorer methodsFor: 'opening' stamp: 'bf 6/17/2008 17:17'!
notInAWindow
| listMorph |
(listMorph := SimpleHierarchicalListMorph
on: self
list: #getList
selected: #getCurrentSelection
changeSelected: #noteNewSelection:
menu: #genericMenu:
keystroke: #keyStroke:).
listMorph autoDeselect: false.
^ listMorph! !
!DBusExplorer methodsFor: 'menus' stamp: 'bf 7/7/2008 12:48'!
chooseProxyClass
| proxyNames proxyName |
proxyNames := (DBusCompiledProxy allSubclasses collect: [:cls | cls name]) asArray sort.
proxyName := proxyNames at: (PopUpMenu withCaption: 'proxy class' chooseFrom: proxyNames) ifAbsent: [^ nil].
^ Smalltalk classNamed: proxyName! !
!DBusExplorer methodsFor: 'menus' stamp: 'bf 3/3/2008 12:54'!
classTemplateFor: aDBusName
| className |
className := (aDBusName copyReplaceAll: '.' with: ' ') toCamelCase capitalized.
^'DBusCompiledProxy subclass: #', className,'
instanceVariableNames: ''''
classVariableNames: ''''
poolDictionaries: ''''
category: ''DBus-Proxies'''
! !
!DBusExplorer methodsFor: 'menus' stamp: 'bf 7/11/2008 20:10'!
compileDelegationMethods
(DBusCompiledProxy classForName: currentSelection service andPath: currentSelection path)
compileMethodsAndSignalsFrom: currentSelection proxy introspect
! !
!DBusExplorer methodsFor: 'menus' stamp: 'bf 7/11/2008 20:10'!
compileDelegationMethodsIn
(self chooseProxyClass ifNil: [^ nil])
compileMethodsAndSignalsFrom: currentSelection proxy introspect
! !
!DBusExplorer methodsFor: 'menus' stamp: 'bf 3/28/2008 13:04'!
createProxyClass
| template class |
template := FillInTheBlankMorph
request: 'Create DBus Proxy Class'
initialAnswer: (self classTemplateFor: currentSelection service)
centerAt: ActiveHand position
inWorld: World
onCancelReturn: nil
acceptOnCR: true
answerExtent: 600@180.
template ifNil: [^self].
class := Compiler evaluate: template.
class class
compile: 'dbusConnection\ ^' withCRs, currentSelection connection printString classified: 'accessing';
compile: 'dbusName\ ^' withCRs, currentSelection service printString classified: 'accessing';
compile: 'dbusPath\ ^' withCRs, currentSelection path printString classified: 'accessing'! !
!DBusExplorer methodsFor: 'menus' stamp: 'bf 7/7/2008 12:50'!
genericMenu: aMenu
| hasMethods isMethod proxyClass |
currentSelection
ifNil: [aMenu add: '*nothing selected*' target: self selector: #yourself]
ifNotNil: [
proxyClass := DBusCompiledProxy classForName: currentSelection service andPath: currentSelection path.
hasMethods := currentSelection contents anySatisfy: [:each | each hasContents not].
isMethod := currentSelection hasContents not.
isMethod
ifTrue: [aMenu add: 'invoke method' target: self selector: #invokeSelection]
ifFalse: [aMenu add: 'inspect proxy' target: self selector: #inspectSelection].
hasMethods ifTrue:
[proxyClass
ifNil: [aMenu add: 'create proxy class' target: self selector: #createProxyClass;
add: 'compile all in ...' target: self selector: #compileDelegationMethodsIn]
ifNotNil: [aMenu add: 'compile all in class ', proxyClass name target: self selector: #compileDelegationMethods]]].
^aMenu! !
!DBusExplorer methodsFor: 'menus' stamp: 'bf 3/28/2008 13:20'!
inspectSelection
^currentSelection proxy inspect! !
!DBusExplorer methodsFor: 'menus' stamp: 'bf 6/16/2008 16:53'!
invokeSelection
^currentSelection invokeMethod! !
!DBusExplorer methodsFor: 'menus' stamp: 'bf 6/17/2008 17:20'!
keyStroke: aCharacter
({Character space. Character cr} includes: aCharacter)
ifTrue: [self invokeSelection]! !
!DBusExplorer class methodsFor: 'opening' stamp: 'bf 6/17/2008 16:24'!
open
^self new inAWindow openInWorld
! !
!DBusExplorer class methodsFor: 'class initialization' stamp: 'bf 6/17/2008 16:26'!
initialize
" TheWorldMenu registerOpenCommand: {'DBus Explorer'. {self. #open}}
"! !
!DBusExplorer class methodsFor: 'class initialization' stamp: 'bf 6/17/2008 16:28'!
unload
" TheWorldMenu unregisterOpenCommand: 'DBus Explorer'
"! !
!DBusExplorerWrapper methodsFor: 'initialize-release' stamp: 'bf 3/28/2008 13:38'!
connection: aConnection service: serviceName path: pathString
connection := aConnection.
service := serviceName.
path := pathString.! !
!DBusExplorerWrapper methodsFor: 'accessing' stamp: 'bf 6/16/2008 16:34'!
asString
"display only the 'interesting' part of the path"
^self hasContents
ifTrue: [path size <= 1
ifTrue: [service
ifEmpty: [connection asString]
ifNotEmpty: [service]]
ifFalse: [path copyAfterLast: $/]]
ifFalse: [path copyAfter: Character space]! !
!DBusExplorerWrapper methodsFor: 'accessing' stamp: 'bf 3/28/2008 13:38'!
connection
^connection! !
!DBusExplorerWrapper methodsFor: 'accessing' stamp: 'bf 6/16/2008 16:37'!
contents
"introspect the current path, answer children (subnodes of current path) and leafs (methods, signals)"
| node children leafs in out |
self hasContents ifFalse: [^#()].
service isEmpty ifTrue: [
^((connection getObject: 'org.freedesktop.DBus' path: '/') listNames
reject: [:each | each first = $:])
collect: [:each | DBusExplorerWrapper connection: connection service: each path: '/']].
node := (XMLDOMParser parseDocumentFrom: self proxy introspect readStream) firstTagNamed: #node .
children := (node elements select: [:each | each tag = #node])
collect: [:each | DBusExplorerWrapper
connection: connection
service: service
path: (path='/' ifTrue: [path] ifFalse: [path, '/']), (each attributeAt: 'name')].
leafs := Array streamContents: [:strm |
node tagsNamed: #interface do: [:interface |
interface elements do: [:each |
(#(method signal) includes: each tag) ifTrue: [
in := self printParameters: 'in' from: each.
out := each tag = #signal
ifTrue: ['SIGNAL']
ifFalse: [self printParameters: 'out' from: each].
strm nextPut: (DBusExplorerWrapper
connection: connection
service: service
path: path, ' ', (interface attributeAt: 'name'), '.', (each attributeAt: 'name'), in, ' => ', out)]]]].
^children, leafs! !
!DBusExplorerWrapper methodsFor: 'accessing' stamp: 'bf 3/3/2008 18:06'!
fullSelector
^(path copyAfter: Character space)
copyUpTo: $(! !
!DBusExplorerWrapper methodsFor: 'accessing' stamp: 'bf 2/21/2008 12:44'!
hasContents
"If I am a leaf (method, signal) then my path looks like '/my/path interface.method()'."
^(path includes: Character space) not! !
!DBusExplorerWrapper methodsFor: 'accessing' stamp: 'bf 3/3/2008 18:04'!
path
^path copyUpTo: Character space! !
!DBusExplorerWrapper methodsFor: 'accessing' stamp: 'bf 3/28/2008 13:52'!
proxy
^self connection getObject: self service path: self path! !
!DBusExplorerWrapper methodsFor: 'accessing' stamp: 'bf 3/3/2008 12:49'!
service
^service! !
!DBusExplorerWrapper methodsFor: 'private' stamp: 'bf 6/17/2008 19:44'!
invokeMethod
| args result argName argSig argValue |
args := ((path copyAfter: $() copyUpTo: $)) findTokens: $,.
args := args collect: [:each |
argName := each copyUpTo: $:.
argSig := each copyAfter: $:.
argValue := FillInTheBlank request:
argName, ' (', (DBusArgument nameOfSignature: argSig), ')'.
argValue ifNil: [^self].
argValue := argSig = 's'
ifTrue: [argValue]
ifFalse: [Compiler evaluate: argValue].
DBusArgument value: argValue signature: argSig].
"execute in background since the dbus call blocks which might interfere with a synchronous server in this same image"
[
result := self proxy dbusPerform: self fullSelector withArguments: args.
result ifNotNil: [WorldState addDeferredUIMessage: [result inspect]]
] fork! !
!DBusExplorerWrapper methodsFor: 'private' stamp: 'bf 3/27/2008 13:25'!
printParameters: direction from: aNode
"given introspection data for a method or signal node, format a parameter list like (name:type, name:type)"
^String streamContents: [:strm |
strm nextPut: $(.
(aNode elements select: [:each | each tag = #arg and: [(each attributeAt: 'direction' ifAbsent: ['in']) = direction]])
do: [:arg | strm nextPutAll: (arg attributeAt: 'name' ifAbsent: ['']), ':', (arg attributeAt: 'type')]
separatedBy: [strm nextPutAll: ', '].
strm nextPut: $)].! !
!DBusExplorerWrapper class methodsFor: 'instance creation' stamp: 'bf 3/28/2008 13:40'!
connection: aConnection service: serviceName path: pathString
^self new connection: aConnection service: serviceName path: pathString! !
!DBusHandler methodsFor: 'processing' stamp: 'bf 6/18/2008 16:20'!
handleReplyOrError: dbusReplyOrError
(dbusReplyOrError isError ifTrue: [onError] ifFalse: [onSuccess])
valueWithArguments: {dbusReplyOrError}
"#valueWithArguments: works for both Blocks and MessageSends"! !
!DBusHandler methodsFor: 'accessing' stamp: 'bf 6/10/2008 16:22'!
onError
"Answer the value of onError"
^ onError! !
!DBusHandler methodsFor: 'accessing' stamp: 'bf 6/18/2008 16:19'!
onError: aBlockOrMessageSend
onError := aBlockOrMessageSend! !
!DBusHandler methodsFor: 'accessing' stamp: 'bf 6/10/2008 16:22'!
onSuccess
"Answer the value of onSuccess"
^ onSuccess! !
!DBusHandler methodsFor: 'accessing' stamp: 'bf 6/18/2008 16:20'!
onSuccess: aBlockOrMessageSend
onSuccess := aBlockOrMessageSend! !
!DBusHandler class methodsFor: 'instance creation' stamp: 'bf 6/10/2008 17:34'!
onSuccess: successHandler onError: errorHandler
^self new
onSuccess: successHandler;
onError: errorHandler;
yourself! !
!DBusMatch methodsFor: 'private' stamp: 'bf 6/19/2008 14:25'!
argMatches
^argMatches! !
!DBusMatch methodsFor: 'private' stamp: 'bf 6/19/2008 14:25'!
matches
^matches! !
!DBusMatch methodsFor: 'setting' stamp: 'bf 6/18/2008 19:46'!
arg: index is: anObject
argMatches at: index put: anObject asString! !
!DBusMatch methodsFor: 'setting' stamp: 'bf 6/18/2008 18:39'!
destination: aString
matches at: #destination put: aString! !
!DBusMatch methodsFor: 'setting' stamp: 'bf 6/18/2008 18:38'!
interface: aString
matches at: #interface put: aString! !
!DBusMatch methodsFor: 'setting' stamp: 'bf 6/18/2008 18:38'!
member: aString
matches at: #member put: aString! !
!DBusMatch methodsFor: 'setting' stamp: 'bf 6/18/2008 18:39'!
path: aString
matches at: #path put: aString! !
!DBusMatch methodsFor: 'setting' stamp: 'bf 6/18/2008 18:37'!
sender: aString
matches at: #sender put: aString! !
!DBusMatch methodsFor: 'setting' stamp: 'bf 6/18/2008 19:53'!
type: aString
"One of 'signal', 'method_call', 'method_return', 'error'. Defaults to signal"
matches at: #type put: aString! !
!DBusMatch methodsFor: 'setting-args' stamp: 'bf 6/18/2008 19:48'!
firstArg: anObject
self arg: 0 is: anObject! !
!DBusMatch methodsFor: 'setting-args' stamp: 'bf 6/18/2008 19:48'!
secondArg: anObject
self arg: 1 is: anObject! !
!DBusMatch methodsFor: 'setting-args' stamp: 'bf 6/18/2008 19:48'!
thirdArg: anObject
self arg: 2 is: anObject! !
!DBusMatch methodsFor: 'comparing' stamp: 'bf 6/19/2008 15:04'!
= other
(other isKindOf: self class) ifFalse: [^false].
^other matches = matches and: [other argMatches = argMatches]! !
!DBusMatch methodsFor: 'comparing' stamp: 'bf 6/19/2008 14:23'!
hash
^matches hash bitXor: argMatches hash! !
!DBusMatch methodsFor: 'initialize' stamp: 'bf 6/18/2008 22:06'!
initialize
matches := Dictionary new.
argMatches := Dictionary new.
self typeSignal! !
!DBusMatch methodsFor: 'matching' stamp: 'bf 6/18/2008 22:36'!
matches: aDBusMessage
matches keysAndValuesDo: [:selector :value |
(aDBusMessage perform: selector) = value
ifFalse: [^false]].
argMatches keysAndValuesDo: [:index :value |
(aDBusMessage arguments at: index+1 ifAbsent: [^false])
fromDBusArgument asString = value
ifFalse: [^false]].
^true! !
!DBusMatch methodsFor: 'printing' stamp: 'bf 6/18/2008 22:23'!
matchString
^String streamContents: [:stream | self printMatchStringOn: stream]
! !
!DBusMatch methodsFor: 'printing' stamp: 'bf 6/18/2008 22:16'!
printMatchStringOn: aStream
| first |
first := true.
matches keysAndValuesDo: [:selector :string |
first ifTrue: [first := false] ifFalse: [aStream nextPut: $,].
aStream
nextPutAll: selector;
nextPut: $=;
print: string].
argMatches keysAndValuesDo: [:index :string |
first ifTrue: [first := false] ifFalse: [aStream nextPut: $,].
aStream
nextPutAll: 'arg';
print: index;
nextPut: $=;
print: string].
! !
!DBusMatch methodsFor: 'printing' stamp: 'bf 6/18/2008 22:24'!
printOn: aStream
aStream nextPutAll: self class name.
aStream nextPut: $(.
self printMatchStringOn: aStream.
aStream nextPut: $)
! !
!DBusMatch methodsFor: 'setting-types' stamp: 'bf 6/19/2008 01:45'!
typeError
self type: DBusMessageError type! !
!DBusMatch methodsFor: 'setting-types' stamp: 'bf 6/19/2008 01:46'!
typeMethodCall
self type: DBusMessageMethodCall type! !
!DBusMatch methodsFor: 'setting-types' stamp: 'bf 6/19/2008 01:46'!
typeMethodReturn
self type: DBusMessageMethodReply type! !
!DBusMatch methodsFor: 'setting-types' stamp: 'bf 6/19/2008 01:48'!
typeSignal
self type: DBusMessageSignal type! !
!DBusMessage methodsFor: 'arguments' stamp: 'dmoc 2/2/2010 00:41'!
addArgument: a
arguments add: a "asDBusArgument"
! !
!DBusMessage methodsFor: 'arguments' stamp: 'bf 5/25/2007 17:43'!
addArgument: a signature: s
arguments add: (DBusArgument value: a signature: s)! !
!DBusMessage methodsFor: 'arguments' stamp: 'jaf 5/26/2007 22:42'!
addArgument: a type: s
arguments add: (DBusArgument value: a type: s)! !
!DBusMessage methodsFor: 'arguments' stamp: 'jaf 4/27/2007 18:23'!
removeAllArguments
arguments := OrderedCollection new! !
!DBusMessage methodsFor: 'accessing' stamp: 'bf 6/12/2008 16:22'!
arguments
^arguments asArray! !
!DBusMessage methodsFor: 'accessing' stamp: 'bf 2/26/2008 11:38'!
arguments: argumentArray
arguments := argumentArray! !
!DBusMessage methodsFor: 'accessing' stamp: 'jaf 4/19/2007 15:18'!
destination
^destination! !
!DBusMessage methodsFor: 'accessing' stamp: 'bf 2/26/2008 11:39'!
destination: destinationString
destination := destinationString! !
!DBusMessage methodsFor: 'accessing' stamp: 'bf 6/19/2008 01:22'!
fullSelector
^interface
ifNil: [member]
ifNotNil: [interface, '.', member]! !
!DBusMessage methodsFor: 'accessing' stamp: 'jaf 4/19/2007 15:17'!
interface
^interface! !
!DBusMessage methodsFor: 'accessing' stamp: 'bf 2/26/2008 11:38'!
interface: interfaceOrNil
interface := interfaceOrNil
! !
!DBusMessage methodsFor: 'accessing' stamp: 'bf 6/19/2008 01:22'!
member
^member! !
!DBusMessage methodsFor: 'accessing' stamp: 'bf 6/19/2008 01:22'!
member: memberString
member := memberString! !
!DBusMessage methodsFor: 'accessing' stamp: 'bf 6/19/2008 12:03'!
path
^path! !
!DBusMessage methodsFor: 'accessing' stamp: 'bf 6/19/2008 12:04'!
path: pathString
path := pathString
! !
!DBusMessage methodsFor: 'accessing' stamp: 'jaf 4/27/2007 11:32'!
reply
^false! !
!DBusMessage methodsFor: 'accessing' stamp: 'jaf 4/19/2007 15:17'!
sender
^sender! !
!DBusMessage methodsFor: 'accessing' stamp: 'bf 2/26/2008 11:42'!
sender: senderString
sender := senderString! !
!DBusMessage methodsFor: 'accessing' stamp: 'jaf 4/27/2007 10:00'!
serial
^ serial! !
!DBusMessage methodsFor: 'accessing' stamp: 'bf 2/26/2008 11:43'!
serial: serialNumber
serial := serialNumber! !
!DBusMessage methodsFor: 'accessing' stamp: 'bf 2/26/2008 11:43'!
signature
"answer the full signature of the arguments"
^String streamContents: [:strm |
arguments do: [:ea | ea printSignatureOn: strm]].
! !
!DBusMessage methodsFor: 'accessing' stamp: 'bf 6/19/2008 01:54'!
type
^self class typeStrings at: typeCode ifAbsent: [nil]! !
!DBusMessage methodsFor: 'initialize-release' stamp: 'bf 6/19/2008 01:54'!
initialize
path := ''.
interface := nil.
sender := ''.
member := ''.
destination := ''.
arguments := OrderedCollection new.
typeCode := self class typeCode.
serial := 0.
! !
!DBusMessage methodsFor: 'testing' stamp: 'jf 5/21/2007 21:46'!
hasArguments
^ (arguments size > 0)! !
!DBusMessage methodsFor: 'testing' stamp: 'jaf 4/19/2007 15:25'!
isError
^false! !
!DBusMessage methodsFor: 'testing' stamp: 'jaf 4/19/2007 15:25'!
isMethodCall
^false! !
!DBusMessage methodsFor: 'testing' stamp: 'jaf 4/27/2007 10:56'!
isMethodReply
^false! !
!DBusMessage methodsFor: 'testing' stamp: 'bf 7/24/2007 22:08'!
isReplyOrError
^false! !
!DBusMessage methodsFor: 'testing' stamp: 'jaf 4/19/2007 15:25'!
isSignal
^false! !
!DBusMessage methodsFor: 'printing' stamp: 'dmoc 2/2/2010 00:29'!
printArgumentsOn: aStream
aStream nextPut: $(.
arguments ifNotNil: [
arguments
do: [:each |
each printOn: aStream.
aStream nextPutAll: ', '
]
].
aStream nextPut: $).
! !
!DBusMessage methodsFor: 'printing' stamp: 'bf 6/19/2008 12:04'!
printOn: aStream
aStream nextPutAll: self class name.
(self serial > 0)
ifTrue: [
aStream nextPut: $(.
self serial printOn: aStream.
aStream nextPut: $).
].
aStream nextPut: $[;
nextPutAll: (self path ifNil: ['?']);
space;
nextPutAll: (self fullSelector ifNil: ['?']).
self printArgumentsOn: aStream.
aStream nextPut: $]
! !
!DBusMessage methodsFor: 'read writing' stamp: 'jf 5/21/2007 15:51'!
readArgumentsFrom: conn
| hasArg |
arguments := OrderedCollection new.
hasArg := conn messageHasArguments.
[hasArg]
whileTrue: [
arguments add: conn getArgument.
hasArg := conn nextIterator.
]! !
!DBusMessage methodsFor: 'read writing' stamp: 'bf 6/19/2008 12:04'!
readFromConnection: conn
self path: conn messagePath.
self sender: conn messageSender.
self interface: conn messageInterface.
self member: conn messageMember.
self serial: conn messageSerial.
self readArgumentsFrom: conn
! !
!DBusMessage methodsFor: 'read writing' stamp: 'jf 5/21/2007 21:39'!
sendTo: conn
conn sendMessage: self.
! !
!DBusMessage class methodsFor: 'accessing' stamp: 'bf 6/19/2008 01:52'!
type
^self typeStrings at: self typeCode ifAbsent: [nil]! !
!DBusMessage class methodsFor: 'accessing' stamp: 'bf 6/19/2008 01:53'!
typeCode
^0! !
!DBusMessage class methodsFor: 'accessing' stamp: 'bf 6/19/2008 01:44'!
typeStrings
^#('method_call' 'method_return' 'error' 'signal')! !
!DBusMessage class methodsFor: 'instance creation' stamp: 'bf 7/17/2007 11:17'!
newReplyFor: msg
| reply |
(msg isMethodCall and: [msg reply]) ifFalse: [
^self error: 'You can only create a reply for message which require it.'].
reply := DBusMessageMethodReply new.
reply serial: msg serial.
reply destination: msg sender.
^ reply
! !
!DBusMessage class methodsFor: 'instance creation' stamp: 'bf 6/19/2008 01:56'!
typeCode: anInteger
^(self subclasses detect: [:each | each typeCode = anInteger]) new
! !
!DBusMessage class methodsFor: 'examples' stamp: 'bf 6/19/2008 01:12'!
testMethodCall
"create a new method call"
| msg |
msg := DBusMessageMethodCall destination: 'org.squeak.dbus.example'
path: '/org/squeak/dbus/example'
interface: 'org.squeak.dbus.testinterface'
member: 'testmember'.
"add some arguments"
msg addArgument: (DBusArgument boolean: false). "boolean"
msg addArgument: (DBusArgument int32: 125487). "integer 32"
msg addArgument: (DBusArgument array: {'element 0'. 'element 1'. 'element 2'} signature: 'as'). "3 element array of strings"
msg addArgument: (DBusArgument variant: (DBusArgument uint64: 45879245651)). "variant with an unsigned integer 64"
^msg
! !
!DBusMessage class methodsFor: 'examples' stamp: 'jaf 5/26/2007 20:15'!
testSignal
"create a new signal"
| signal |
signal := DBusMessageSignal path: '/org/squeak/dbus/example'
interface: 'org.squeak.dbus.testinterface'
name: 'signalname'.
"add some arguments"
signal addArgument: 'test a signal'. "for some basic types this works to"
^signal
! !
!DBusMessageError methodsFor: 'initialize-release' stamp: 'bf 5/15/2007 15:08'!
initialize
super initialize.
name := ''.
! !
!DBusMessageError methodsFor: 'testing' stamp: 'jaf 4/19/2007 15:26'!
isError
^true! !
!DBusMessageError methodsFor: 'testing' stamp: 'bf 7/24/2007 22:08'!
isReplyOrError
^true! !
!DBusMessageError methodsFor: 'testing' stamp: 'jaf 4/27/2007 18:05'!
printOn: aStream
aStream
nextPutAll: self class name;
nextPut: $[;
print: self name;
nextPut: $(;
print: self message;
nextPut: $);
nextPut: $]! !
!DBusMessageError methodsFor: 'accessing' stamp: 'bf 6/10/2008 18:31'!
message
^arguments first fromDBusArgument! !
!DBusMessageError methodsFor: 'accessing' stamp: 'jaf 4/27/2007 18:24'!
message: m
self removeAllArguments.
self addArgument: m.! !
!DBusMessageError methodsFor: 'accessing' stamp: 'jaf 4/27/2007 17:40'!
name
^ name! !
!DBusMessageError methodsFor: 'accessing' stamp: 'jaf 4/27/2007 17:41'!
name: e
name := e! !
!DBusMessageError methodsFor: 'accessing' stamp: 'bf 7/24/2007 22:07'!
replySerial
^replySerial! !
!DBusMessageError methodsFor: 'read writing' stamp: 'bf 7/24/2007 22:06'!
readFromConnection: con
super readFromConnection: con.
name := con errorName.
replySerial := con messageReplySerial.
! !
!DBusMessageError class methodsFor: 'constants' stamp: 'jaf 4/27/2007 17:54'!
dbusErrorInvalidArgs
^ 'org.freedesktop.DBus.Error.InvalidArgs'! !
!DBusMessageError class methodsFor: 'constants' stamp: 'jaf 4/27/2007 18:03'!
dbusErrorUnknownMethod
^ 'org.freedesktop.DBus.Error.UnknownMethod'! !
!DBusMessageError class methodsFor: 'constants' stamp: 'bf 5/1/2008 19:21'!
dbusErrorUnknownObject
^ 'org.freedesktop.DBus.Error.UnknownObject'! !
!DBusMessageError class methodsFor: 'accessing' stamp: 'bf 6/19/2008 01:53'!
typeCode
^3! !
!DBusMessageError class methodsFor: 'instance creation' stamp: 'jaf 5/31/2007 22:42'!
newFor: msg name: aName withMessage: aMessage
| e |
msg ifNotNil: [
(msg isMethodCall) ifFalse: [self error:'Errors are only for a method call which require a reply.'. ^ nil].
e := DBusMessageError new.
e serial: msg serial;
destination: msg sender.
e name: aName; message: aMessage.
^ e].
^ nil
! !
!DBusMessageError class methodsFor: 'instance creation' stamp: 'jaf 5/26/2007 20:17'!
unknownMethod: msg
^ self newFor: msg name: (self dbusErrorUnknownMethod) withMessage: ''.! !
!DBusMessageMethodCall methodsFor: 'initialize-release' stamp: 'bf 2/26/2008 12:01'!
initialize
super initialize.
reply := true.
! !
!DBusMessageMethodCall methodsFor: 'testing' stamp: 'jaf 4/19/2007 15:26'!
isMethodCall
^true! !
!DBusMessageMethodCall methodsFor: 'read writing' stamp: 'bf 3/5/2008 17:28'!
readFromConnection: con
super readFromConnection: con.
reply := con messageNoReply not.! !
!DBusMessageMethodCall methodsFor: 'accessing' stamp: 'jaf 4/27/2007 10:53'!
reply
^reply! !
!DBusMessageMethodCall methodsFor: 'accessing' stamp: 'jaf 4/27/2007 10:54'!
reply: bool
reply := bool.
! !
!DBusMessageMethodCall class methodsFor: 'instance creation' stamp: 'bf 6/19/2008 01:11'!
destination: d path: p interface: i member: t
^ self destination: d path: p interface: i member: t reply: true ! !
!DBusMessageMethodCall class methodsFor: 'instance creation' stamp: 'bf 6/19/2008 12:05'!
destination: d path: p interface: i member: t reply: b
| msg |
msg := self new.
msg destination: d ; path: p ; interface: i ; member: t; reply: b.
^msg! !
!DBusMessageMethodCall class methodsFor: 'accessing' stamp: 'bf 6/19/2008 01:53'!
typeCode
^1! !
!DBusMessageMethodReply methodsFor: 'testing' stamp: 'jaf 4/27/2007 10:57'!
isMethodReply
^ true! !
!DBusMessageMethodReply methodsFor: 'testing' stamp: 'bf 7/24/2007 22:08'!
isReplyOrError
^true! !
!DBusMessageMethodReply methodsFor: 'printing' stamp: 'jaf 5/3/2007 14:38'!
printOn: aStream
super printOn: aStream.
aStream
space;
nextPutAll: 'to ';
nextPut: $(.
self replySerial printOn: aStream.
aStream nextPut: $).
! !
!DBusMessageMethodReply methodsFor: 'read writing' stamp: 'jaf 5/3/2007 14:11'!
readFromConnection: con
super readFromConnection: con.
"read replyserial"
replySerial := con messageReplySerial.
! !
!DBusMessageMethodReply methodsFor: 'accessing' stamp: 'jaf 5/3/2007 14:10'!
replySerial
^ replySerial! !
!DBusMessageMethodReply class methodsFor: 'accessing' stamp: 'bf 6/19/2008 01:53'!
typeCode
^2! !
!DBusMessageSignal methodsFor: 'testing' stamp: 'jaf 4/19/2007 15:27'!
isSignal
^true! !
!DBusMessageSignal class methodsFor: 'accessing' stamp: 'bf 6/19/2008 01:53'!
typeCode
^4! !
!DBusMessageSignal class methodsFor: 'class initialization' stamp: 'bf 6/19/2008 12:05'!
path: p interface: i name: t
| msg |
msg := self new.
msg path: p ; interface: i ; member: t.
^msg! !
!DBusMethod methodsFor: 'accessing' stamp: 'bf 6/19/2008 01:16'!
fullSelector
^interface, '.', member! !
!DBusMethod methodsFor: 'accessing' stamp: 'bf 2/25/2008 15:25'!
inSignature
^inSignature! !
!DBusMethod methodsFor: 'accessing' stamp: 'bf 2/25/2008 15:24'!
interface
^interface! !
!DBusMethod methodsFor: 'accessing' stamp: 'bf 6/19/2008 01:16'!
member
^member! !
!DBusMethod methodsFor: 'accessing' stamp: 'bf 2/25/2008 15:25'!
outSignature
^outSignature! !
!DBusMethod methodsFor: 'initialize-release' stamp: 'bf 6/19/2008 01:17'!
initializeFromSpecString: aString
| p |
interface := aString copyUpToLast: $..
member := aString copyFrom: interface size+2 to: (p := aString indexOf: $<)-1.
inSignature := aString copyFrom: p+1 to: (p := aString indexOf: $>)-1.
outSignature := aString copyFrom: p+1 to: aString size.! !
!DBusMethod methodsFor: 'initialize-release' stamp: 'bf 6/19/2008 01:17'!
setInterface: anInterface member: aMember in: anInSignature out: anOutSignature
interface := anInterface.
member := aMember.
inSignature := anInSignature.
outSignature := anOutSignature.
! !
!DBusMethod methodsFor: 'printing' stamp: 'bf 6/19/2008 01:18'!
printOn: aStream
aStream
nextPutAll: interface;
nextPut: $.;
nextPutAll: member;
nextPut: $<;
nextPutAll: inSignature;
nextPut: $>;
nextPutAll: outSignature! !
!DBusMethod methodsFor: 'printing' stamp: 'bf 6/19/2008 01:19'!
printXMLOn: xml
xml startTag: 'method'; attribute: 'name' value: member; endTag.
#('in' 'out') with: {inSignature. outSignature} do: [:direction :signature |
DBusArgument signaturesIn: signature do: [:type |
xml startTag: 'arg';
attribute: 'direction' value: direction;
attribute: 'type' value: type asString;
endEmptyTag: 'arg']].
xml endTag: 'method'.! !
!DBusMethod class methodsFor: 'instance creation' stamp: 'bf 5/16/2007 18:27'!
fromSpecString: aString
^self new initializeFromSpecString: aString! !
!DBusMethod class methodsFor: 'instance creation' stamp: 'bf 6/19/2008 01:18'!
interface: anInterface member: aMember in: anInSignature out: anOutSignature
^self new
setInterface: anInterface
member: aMember
in: anInSignature
out: anOutSignature! !
!DBusObject methodsFor: 'accessing' stamp: 'bf 2/21/2008 13:47'!
dbusAdd: aDBusObject path: aPathArray
aPathArray size > 1 ifTrue: [
^(dbusChildren at: aPathArray first ifAbsentPut: [DBusObject parent: self name: aPathArray first])
dbusAdd: aDBusObject path: aPathArray allButFirst].
aDBusObject dbusParent: self name: aPathArray last.
dbusChildren at: aDBusObject dbusName put: aDBusObject! !
!DBusObject methodsFor: 'accessing' stamp: 'bf 6/11/2008 17:30'!
dbusChildAtPath: aPathArray
^aPathArray size = 0
ifTrue: [self]
ifFalse: [(self dbusChildren at: aPathArray first ifAbsent: [^nil])
dbusChildAtPath: aPathArray allButFirst]! !
!DBusObject methodsFor: 'accessing' stamp: 'bf 6/11/2008 17:29'!
dbusChildren
^dbusChildren! !
!DBusObject methodsFor: 'accessing' stamp: 'bf 6/18/2008 16:37'!
dbusCoerceTo: type
^self dbusPath! !
!DBusObject methodsFor: 'accessing' stamp: 'bf 5/21/2007 17:45'!
dbusConnection
^dbusConnection! !
!DBusObject methodsFor: 'accessing' stamp: 'bf 5/21/2007 17:48'!
dbusConnection: aDBusConnection
dbusConnection := aDBusConnection! !
!DBusObject methodsFor: 'accessing' stamp: 'bf 5/16/2007 18:29'!
dbusInterface: interface methodsDo: aBlock
self dbusMethodSpecsAndSelectorsDo: [:spec :selector |
interface = (spec copyUpToLast: $.)
ifTrue: [aBlock value: (DBusMethod fromSpecString: spec)]]
! !
!DBusObject methodsFor: 'accessing' stamp: 'bf 2/29/2008 11:39'!
dbusInterfaces
"self basicNew dbusInterfaces"
| interfaces |
interfaces := Set new.
self dbusMethodSpecsAndSelectorsDo: [:spec :selector |
interfaces add: (spec copyUpToLast: $.)].
^interfaces
! !
!DBusObject methodsFor: 'accessing' stamp: 'bf 6/17/2008 13:01'!
dbusMethodSpecsAndSelectorsDo: aBlock
"Evaluate aBlock with all method specs and corresponding selectors that are to be exposed on the DBus.
By default, this gathers only methods marked as #dbusMethod:."
| cls |
cls := self class.
[cls selectorsAndMethodsDo: [:sel :meth |
(meth numLiterals >= 2 and: [(meth literalAt: 1) == #dbusMethod:])
ifTrue: [aBlock value: (meth literalAt: 2) value: sel]].
cls == DBusObject] whileFalse: [cls := cls superclass].
! !
!DBusObject methodsFor: 'accessing' stamp: 'bf 6/19/2008 01:16'!
dbusMethods
"Answer a Dictionary mapping DBus selectors to DBusMethod instances"
| methods method |
methods := Dictionary new.
self dbusMethodSpecsAndSelectorsDo: [:spec :selector |
method := DBusMethod fromSpecString: spec.
methods at: method member put: method].
^methods
! !
!DBusObject methodsFor: 'accessing' stamp: 'bf 5/16/2007 17:45'!
dbusName
^dbusName! !
!DBusObject methodsFor: 'accessing' stamp: 'bf 6/19/2008 14:13'!
dbusObjectForPath: aString
^(dbusConnection exportedAt: aString) ifNil: [aString]! !
!DBusObject methodsFor: 'accessing' stamp: 'bf 5/21/2007 18:05'!
dbusParent
^dbusParent! !
!DBusObject methodsFor: 'accessing' stamp: 'bf 5/21/2007 18:07'!
dbusPath
^dbusParent
ifNil: ['/']
ifNotNil: [
dbusParent dbusParent
ifNil: ['/', dbusName]
ifNotNil: [dbusParent dbusPath, '/', dbusName]]! !
!DBusObject methodsFor: 'accessing' stamp: 'bf 5/25/2007 21:08'!
dbusType
^DBusArgument objectPath
! !
!DBusObject methodsFor: 'exporting' stamp: 'bf 2/29/2008 11:45'!
dbusMethod: formatString
"This message marks a method to be exported on the DBus. It must be the first message-send in the method.
The format is
'interface.method<inSignature>outSignature'
where both inSignature and outSignature may be empty"
^self
! !
!DBusObject methodsFor: 'initialize-release' stamp: 'bf 5/21/2007 17:53'!
dbusParent: aDBusObject name: aString
dbusConnection := aDBusObject dbusConnection.
dbusParent := aDBusObject.
dbusName := aString.
! !
!DBusObject methodsFor: 'initialize-release' stamp: 'bf 5/21/2007 17:53'!
initialize
dbusName := ''.
dbusParent := nil.
dbusChildren := Dictionary new.
! !
!DBusObject methodsFor: 'printing' stamp: 'bf 5/21/2007 17:56'!
printOn: aStream
aStream
print: self class;
nextPut: $(;
nextPutAll: self dbusPath;
nextPut: $)! !
!DBusObject methodsFor: 'handling' stamp: 'bf 6/19/2008 01:15'!
dbusHandle: aMessage from: aDBus
"aMessage for me was received on the D-Bus. Go through my dbusMethods and dispatch to the right one. Then collect the return values, pack them as DBusArguments and send a reply.".
self dbusMethodSpecsAndSelectorsDo: [:spec :sel |
(aMessage interface
ifNil: [((spec copyUpTo: $<) copyAfterLast: $.) = aMessage member]
ifNotNil: [(spec copyUpTo: $<) = aMessage fullSelector])
ifTrue: [^self dbusHandle: aMessage from: aDBus spec: spec selector: sel]].
"no method found"
aMessage isMethodCall ifTrue: [
aDBus sendMessage: (DBusMessageError newFor: aMessage
name: DBusMessageError dbusErrorUnknownMethod
withMessage: 'Unknown method ', aMessage fullSelector, '()')].
! !
!DBusObject methodsFor: 'handling' stamp: 'bf 6/17/2008 13:57'!
dbusHandle: aMessage from: aDBus spec: aSpecString selector: aSelector
^self dbusHandle: aMessage from: aDBus spec: aSpecString selector: aSelector in: self! !
!DBusObject methodsFor: 'handling' stamp: 'bf 6/17/2008 14:06'!
dbusHandle: aMessage from: aDBus spec: aSpecString selector: aSelector in: anObject
| result |
[
result := anObject perform: aSelector withArguments: (aMessage arguments collect: [:arg | arg fromDBusArgument: self]).
aMessage reply ifTrue: [self dbusSendReply: result for: aMessage from: aDBus spec: aSpecString]
] on: Error do: [:error |
aDBus sendMessage: (DBusMessageError newFor: aMessage
name: 'org.squeak.error.', error class name
withMessage: error messageText).
error pass
]! !
!DBusObject methodsFor: 'handling' stamp: 'bf 6/17/2008 16:02'!
dbusSendReply: anObject for: aMessage from: aDBus spec: aSpecString
| reply signatures |
reply := DBusMessage newReplyFor: aMessage.
signatures := DBusArgument splitSignature: (aSpecString copyAfterLast: $>).
signatures size = 1 ifTrue: [reply addArgument: (anObject asDBusArgumentSignature: signatures first)].
signatures size > 1 ifTrue: [reply with: signatures do: [:val :sig | reply addArgument: (val asDBusArgumentSignature: sig)]].
aDBus sendMessage: reply! !
!DBusObject methodsFor: 'dbus methods' stamp: 'bf 6/16/2008 19:18'!
introspect
self dbusMethod: 'org.freedesktop.DBus.Introspectable.Introspect<>s'.
^String streamContents: [:stream |
| xml |
stream nextPutAll: '<!!DOCTYPE node PUBLIC "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN" "http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd";>'.
xml := XMLWriter on: stream.
xml startTag: 'node'; endTag.
self dbusChildren do: [:child |
xml startTag: 'node'; attribute: 'name' value: child dbusName; endEmptyTag: 'node'].
self dbusInterfaces do: [:interface |
interface = 'org.freedesktop.DBus.Introspectable' ifFalse: [
xml startTag: 'interface'; attribute: 'name' value: interface; endTag.
self dbusInterface: interface methodsDo: [:method |
method printXMLOn: xml].
xml endTag: 'interface' ]].
xml endTag: 'node']! !
!DBusObject class methodsFor: 'instance creation' stamp: 'bf 5/21/2007 17:46'!
parent: aDBusObject name: aString
^self new dbusParent: aDBusObject name: aString! !
!DBusProxy methodsFor: 'accessing' stamp: 'bf 6/18/2008 16:38'!
dbusCoerceTo: type
^ self dbusPath! !
!DBusProxy methodsFor: 'accessing' stamp: 'bf 3/27/2008 17:27'!
dbusConnection
^connection! !
!DBusProxy methodsFor: 'accessing' stamp: 'bf 6/19/2008 01:18'!
dbusMethods
"Answer a Dictionary mapping DBus selectors to DBusMethod instances"
| introspected types |
introspected := Dictionary new.
(XMLDOMParser parseDocumentFrom: self introspect readStream) elements first
tagsNamed: #interface do: [:interface |
interface tagsNamed: #method do: [:method |
types := {'in' -> String new writeStream.
'out' -> String new writeStream} as: Dictionary.
method tagsNamed: #arg do: [:arg |
(types at: (arg attributeAt: 'direction'))
nextPutAll: (arg attributeAt: 'type')].
introspected
at: (method attributeAt: 'name')
put: (DBusMethod
interface: (interface attributeAt: 'name')
member: (method attributeAt: 'name')
in: (types at: 'in') contents
out: (types at: 'out') contents)]].
^introspected
! !
!DBusProxy methodsFor: 'accessing' stamp: 'bf 2/29/2008 11:53'!
dbusName
^busName! !
!DBusProxy methodsFor: 'accessing' stamp: 'bf 5/1/2008 20:27'!
dbusObjectForPath: aPath
^DBusProxy
connection: self dbusConnection
busName: self dbusName
objectPath: aPath! !
!DBusProxy methodsFor: 'accessing' stamp: 'bf 2/29/2008 11:54'!
dbusPath
^objectPath! !
!DBusProxy methodsFor: 'accessing' stamp: 'bf 5/25/2007 20:14'!
dbusType
^DBusArgument objectPath
! !
!DBusProxy methodsFor: 'calling' stamp: 'bf 2/26/2008 11:31'!
dbusPerform: interfaceAndSelector
"interfaceAndSelector is either 'interface.selector' or simply 'selector'. In the latter case, the interface will be inferred by introspection."
^self dbusPerform: interfaceAndSelector withArguments: #()! !
!DBusProxy methodsFor: 'calling' stamp: 'bf 2/25/2008 14:53'!
dbusPerform: selectorString interface: interfaceString
^self dbusPerform: selectorString interface: interfaceString withArguments: #()
! !
!DBusProxy methodsFor: 'calling' stamp: 'bf 6/19/2008 01:12'!
dbusPerform: memberString interface: interfaceString withArguments: argumentArray
| msg reply |
msg := DBusMessageMethodCall
destination: self dbusName
path: self dbusPath
interface: interfaceString
member: memberString.
argumentArray do: [:each | msg addArgument: each].
reply := self dbusConnection sendDBusMessage: msg.
reply arguments size = 0 ifTrue: [^nil].
reply arguments size = 1 ifTrue: [^reply arguments first fromDBusArgument: self].
^reply arguments collect: [:each | each fromDBusArgument: self]! !
!DBusProxy methodsFor: 'calling' stamp: 'bf 2/29/2008 11:48'!
dbusPerform: interfaceAndSelector withArguments: argumentArray
"interfaceAndSelector is either 'interface.selector' or simply 'selector'."
| selector interface dot |
dot := interfaceAndSelector lastIndexOf: $..
dot > 0
ifTrue: [selector := interfaceAndSelector allButFirst: dot.
interface := interfaceAndSelector first: dot-1.
interface isEmpty ifTrue: [interface := nil]]
ifFalse: [
selector := interfaceAndSelector.
interface := nil.
self useIntrospection ifTrue: [
self dbusMethods at: selector
ifPresent: [:method | interface := method interface]]].
^self dbusPerform: selector interface: interface withArguments: argumentArray
! !
!DBusProxy methodsFor: 'calling' stamp: 'bf 6/19/2008 21:12'!
dbusPerformAsync: memberString interface: interfaceString
^self dbusPerformAsync: memberString interface: interfaceString withArguments: #()
! !
!DBusProxy methodsFor: 'calling' stamp: 'bf 6/19/2008 21:14'!
dbusPerformAsync: memberString interface: interfaceString withArguments: argumentArray
| msg |
msg := DBusMessageMethodCall
destination: self dbusName
path: self dbusPath
interface: interfaceString
member: memberString
reply: false.
argumentArray do: [:each | msg addArgument: each].
self dbusConnection sendMessage: msg.
^nil! !
!DBusProxy methodsFor: 'org.freedesktop.DBus.Introspectable' stamp: 'bf 3/27/2008 18:01'!
introspect
"Returns aString 's'."
"Automatically generated - not regenerated in subclasses"
^self dbusPerform: 'Introspect' interface: 'org.freedesktop.DBus.Introspectable'! !
!DBusProxy methodsFor: 'initialize-release' stamp: 'bf 2/25/2008 13:42'!
setConnection: aDBusConnection busName: aNameString objectPath: aPathString
connection := aDBusConnection.
busName := aNameString.
objectPath := aPathString.
! !
!DBusProxy methodsFor: 'testing' stamp: 'bf 2/29/2008 11:29'!
useIntrospection
^false! !
!DBusProxy methodsFor: 'printing' stamp: 'bf 6/19/2008 12:23'!
printOn: aStream
aStream
print: self class;
nextPut: $(;
print: self dbusName;
space;
print: self dbusPath;
nextPut: $)! !
!DBusProxy methodsFor: 'signals' stamp: 'bf 7/7/2008 21:58'!
assertDBusSignature: aString matchesSelector: aSymbol
self assert: [
| argCount |
argCount := aSymbol occurrencesOf: $:.
DBusArgument signaturesIn: aString
do: [:sig | argCount := argCount - 1].
argCount = 0]! !
!DBusProxy methodsFor: 'signals' stamp: 'bf 7/11/2008 19:48'!
onDBusSignal: memberString interface: interfaceString send: aSelector to: anObject
| match |
match := DBusMatch new.
match path: self dbusPath.
memberString ifNotNil: [match member: memberString].
interfaceString ifNotNil: [match interface: interfaceString].
aSelector ifNil: [self dbusConnection removeMatch: match. ^match].
self dbusConnection
onMatch: match
do: [:msg | anObject perform: aSelector
withEnoughArguments:
(msg arguments collect: [:each | each fromDBusArgument: self])].
^match! !
!DBusProxy methodsFor: 'signals' stamp: 'bf 7/11/2008 19:53'!
onDBusSignal: memberString interface: interfaceString signature: signatureString send: aSelector to: anObject
signatureString ifNotNil: [
self assertDBusSignature: signatureString matchesSelector: aSelector].
^self onDBusSignal: memberString interface: interfaceString send: aSelector to: anObject
! !
!DBusProxy methodsFor: 'signals' stamp: 'bf 7/7/2008 21:38'!
onDBusSignal: interfaceAndMember send: aSelector to: anObject
| member interface dot |
dot := interfaceAndMember lastIndexOf: $..
dot > 0
ifTrue: [member := interfaceAndMember allButFirst: dot.
interface := interfaceAndMember first: dot-1]
ifFalse: [member := interfaceAndMember.
interface := nil].
^self onDBusSignal: member
interface: interface
send: aSelector to: anObject ! !
!DBusCompiledProxy methodsFor: 'accessing' stamp: 'bf 3/14/2008 19:27'!
dbusConnection
^super dbusConnection ifNil: [self class dbusConnection]! !
!DBusCompiledProxy methodsFor: 'accessing' stamp: 'bf 3/14/2008 19:25'!
dbusName
^super dbusName ifNil: [self class dbusName]! !
!DBusCompiledProxy methodsFor: 'accessing' stamp: 'bf 3/14/2008 19:26'!
dbusPath
^super dbusPath ifNil: [self class dbusPath]! !
!DBusDaemon methodsFor: 'org.freedesktop.DBus' stamp: 'bf 3/27/2008 15:52'!
addMatch: aString
"Returns nothing."
"Automatically generated"
^self dbusPerform: 'AddMatch' interface: 'org.freedesktop.DBus' withArguments: {
DBusArgument value: aString signature: 's'.}! !
!DBusDaemon methodsFor: 'org.freedesktop.DBus' stamp: 'bf 3/27/2008 16:06'!
getConnectionSELinuxSecurityContext: aString
"Returns anArrayOfBytes 'ay'."
"Automatically generated"
^self dbusPerform: 'GetConnectionSELinuxSecurityContext' interface: 'org.freedesktop.DBus' withArguments: {
DBusArgument value: aString signature: 's'.}! !
!DBusDaemon methodsFor: 'org.freedesktop.DBus' stamp: 'bf 3/27/2008 15:52'!
getConnectionUnixProcessID: aString
"Returns anUint32 'u'."
"Automatically generated"
^self dbusPerform: 'GetConnectionUnixProcessID' interface: 'org.freedesktop.DBus' withArguments: {
DBusArgument value: aString signature: 's'.}! !
!DBusDaemon methodsFor: 'org.freedesktop.DBus' stamp: 'bf 3/27/2008 15:52'!
getConnectionUnixUser: aString
"Returns anUint32 'u'."
"Automatically generated"
^self dbusPerform: 'GetConnectionUnixUser' interface: 'org.freedesktop.DBus' withArguments: {
DBusArgument value: aString signature: 's'.}! !
!DBusDaemon methodsFor: 'org.freedesktop.DBus' stamp: 'bf 3/27/2008 15:52'!
getNameOwner: aString
"Returns aString 's'."
"Automatically generated"
^self dbusPerform: 'GetNameOwner' interface: 'org.freedesktop.DBus' withArguments: {
DBusArgument value: aString signature: 's'.}! !
!DBusDaemon methodsFor: 'org.freedesktop.DBus' stamp: 'bf 3/27/2008 15:52'!
hello
"Returns aString 's'."
"Automatically generated"
^self dbusPerform: 'Hello' interface: 'org.freedesktop.DBus'! !
!DBusDaemon methodsFor: 'org.freedesktop.DBus' stamp: 'bf 3/27/2008 16:06'!
listActivatableNames
"Returns anArrayOfStrings 'as'."
"Automatically generated"
^self dbusPerform: 'ListActivatableNames' interface: 'org.freedesktop.DBus'! !
!DBusDaemon methodsFor: 'org.freedesktop.DBus' stamp: 'bf 3/27/2008 16:06'!
listNames
"Returns anArrayOfStrings 'as'."
"Automatically generated"
^self dbusPerform: 'ListNames' interface: 'org.freedesktop.DBus'! !
!DBusDaemon methodsFor: 'org.freedesktop.DBus' stamp: 'bf 3/27/2008 16:06'!
listQueuedOwners: aString
"Returns anArrayOfStrings 'as'."
"Automatically generated"
^self dbusPerform: 'ListQueuedOwners' interface: 'org.freedesktop.DBus' withArguments: {
DBusArgument value: aString signature: 's'.}! !
!DBusDaemon methodsFor: 'org.freedesktop.DBus' stamp: 'bf 3/27/2008 15:52'!
nameHasOwner: aString
"Returns aBoolean 'b'."
"Automatically generated"
^self dbusPerform: 'NameHasOwner' interface: 'org.freedesktop.DBus' withArguments: {
DBusArgument value: aString signature: 's'.}! !
!DBusDaemon methodsFor: 'org.freedesktop.DBus' stamp: 'bf 3/27/2008 15:52'!
releaseName: aString
"Returns anUint32 'u'."
"Automatically generated"
^self dbusPerform: 'ReleaseName' interface: 'org.freedesktop.DBus' withArguments: {
DBusArgument value: aString signature: 's'.}! !
!DBusDaemon methodsFor: 'org.freedesktop.DBus' stamp: 'bf 3/27/2008 15:52'!
reloadConfig
"Returns nothing."
"Automatically generated"
^self dbusPerform: 'ReloadConfig' interface: 'org.freedesktop.DBus'! !
!DBusDaemon methodsFor: 'org.freedesktop.DBus' stamp: 'bf 3/27/2008 15:52'!
removeMatch: aString
"Returns nothing."
"Automatically generated"
^self dbusPerform: 'RemoveMatch' interface: 'org.freedesktop.DBus' withArguments: {
DBusArgument value: aString signature: 's'.}! !
!DBusDaemon methodsFor: 'org.freedesktop.DBus' stamp: 'bf 3/27/2008 15:52'!
requestName: aString with: anUint32
"Returns anUint32 'u'."
"Automatically generated"
^self dbusPerform: 'RequestName' interface: 'org.freedesktop.DBus' withArguments: {
DBusArgument value: aString signature: 's'.
DBusArgument value: anUint32 signature: 'u'.}! !
!DBusDaemon methodsFor: 'org.freedesktop.DBus' stamp: 'bf 3/27/2008 15:52'!
startServiceByName: aString with: anUint32
"Returns anUint32 'u'."
"Automatically generated"
^self dbusPerform: 'StartServiceByName' interface: 'org.freedesktop.DBus' withArguments: {
DBusArgument value: aString signature: 's'.
DBusArgument value: anUint32 signature: 'u'.}! !
!DBusGenericProxy methodsFor: 'accessing' stamp: 'bf 2/29/2008 11:35'!
dbusMethods
^methods ifNil: [
methods := [super dbusMethods] ifError: [Dictionary new]]! !
!DBusGenericProxy methodsFor: 'calling' stamp: 'bf 2/29/2008 11:20'!
doesNotUnderstand: aMessage
aMessage selector first isLetter ifFalse: [^super doesNotUnderstand: aMessage].
^self dbusPerform: (aMessage selector copyUpTo: $:) withArguments: aMessage arguments
! !
!DBusGenericProxy methodsFor: 'testing' stamp: 'bf 2/29/2008 11:29'!
useIntrospection
^true! !
!DBusProxy class methodsFor: 'instance creation' stamp: 'bf 7/7/2008 15:28'!
connection: aDBusConnection busName: aNameString objectPath: aPathString
"Create a CompiledProxy for the given name and path, or a GenericProxy"
| proxyClass |
proxyClass := self isAbstract
ifFalse: [self]
ifTrue: [(DBusCompiledProxy classForName: aNameString andPath: aPathString)
ifNil: [DBusGenericProxy]].
^proxyClass new
setConnection: aDBusConnection
busName: aNameString
objectPath: aPathString.
! !
!DBusProxy class methodsFor: 'testing' stamp: 'bf 7/7/2008 15:28'!
isAbstract
^self == DBusProxy! !
!DBusCompiledProxy class methodsFor: 'accessing' stamp: 'bf 3/14/2008 19:40'!
classForName: aDBusName andPath: aDBusPath
self allSubclassesDo: [:cls |
(cls handlesDBusName: aDBusName andPath: aDBusPath)
ifTrue: [^cls]].
^nil! !
!DBusCompiledProxy class methodsFor: 'accessing' stamp: 'bf 3/14/2008 19:27'!
dbusConnection
^ self subclassResponsibility ! !
!DBusCompiledProxy class methodsFor: 'accessing' stamp: 'bf 3/3/2008 17:55'!
dbusName
^ self subclassResponsibility ! !
!DBusCompiledProxy class methodsFor: 'accessing' stamp: 'bf 3/3/2008 17:56'!
dbusPath
^ self subclassResponsibility ! !
!DBusCompiledProxy class methodsFor: 'compiling' stamp: 'bf 3/27/2008 15:50'!
compileMethod: memberString interface: interfaceString in: inParams out: outParams
| overwriteOkay newSource oldSource |
overwriteOkay := '"Automatically generated"'.
newSource := String streamContents: [:strm |
strm nextPutAll: (self underscoreToCamelCase: memberString).
inParams withIndexDo: [:param :i |
i=1 ifTrue: [strm nextPutAll: ': ']
ifFalse: [strm nextPutAll: ' with: '].
strm nextPutAll: param key].
strm crtab; nextPutAll: '"Returns '.
outParams
ifEmpty: [strm nextPutAll: 'nothing']
ifNotEmpty: [
outParams do: [:p | strm nextPutAll: p key, ' ''', p value, '''']
separatedBy: [strm nextPutAll: ' and ']].
strm nextPutAll: '."'.
strm crtab; nextPutAll: overwriteOkay.
strm crtab; nextPutAll: '^self dbusPerform: '; print: memberString;
nextPutAll: ' interface: '; print: interfaceString.
inParams isEmpty ifFalse: [
strm nextPutAll: ' withArguments: {'.
inParams do: [:param |
strm crtab: 2;
nextPutAll: 'DBusArgument value: '; nextPutAll: param key;
nextPutAll: ' signature: '; print: param value;
nextPutAll: '.'].
strm nextPutAll: '}']].
oldSource := (self sourceCodeAt: (Parser new parseSelector: newSource) asSymbol
ifAbsent: [overwriteOkay]) asString.
(oldSource ~= newSource and: [oldSource includesSubString: overwriteOkay])
ifTrue: [self compile: newSource classified: interfaceString].! !
!DBusCompiledProxy class methodsFor: 'compiling' stamp: 'bf 7/11/2008 20:10'!
compileMethodsAndSignalsFrom: introspectionString
| node |
node := (XMLDOMParser parseDocumentFrom: introspectionString readStream) elements first.
node tagsNamed: #interface do: [:interface |
(interface attributeAt: 'name') = 'org.freedesktop.DBus.Introspectable' ifFalse: [
interface tagsNamed: #method do: [:method |
self compileMethod: (method attributeAt: 'name')
interface: (interface attributeAt: 'name')
in: (self parameters: 'in' from: method)
out: (self parameters: 'out' from: method)].
interface tagsNamed: #signal do: [:signal |
self compileSignal: (signal attributeAt: 'name')
interface: (interface attributeAt: 'name')
in: (self parameters: 'in' from: signal)]]].
! !
!DBusCompiledProxy class methodsFor: 'compiling' stamp: 'bf 7/11/2008 20:36'!
compileSignal: memberString interface: interfaceString in: inParams
| overwriteOkay newSource oldSource |
overwriteOkay := '"Automatically generated"'.
newSource := String streamContents: [:strm |
strm nextPutAll: 'on', (self underscoreToCamelCase: memberString) capitalized,
'Send: aSelector to: anObject'.
strm crtab; nextPutAll: overwriteOkay.
strm crtab; nextPutAll: '^self onDBusSignal: '; print: memberString;
crtab: 2; nextPutAll: 'interface: '; print: interfaceString;
crtab: 2; nextPutAll: 'signature: '''.
inParams do: [:param | strm nextPutAll: param value].
strm nextPutAll: '''';
crtab: 2; nextPutAll: 'send: aSelector to: anObject'].
oldSource := (self sourceCodeAt: (Parser new parseSelector: newSource) asSymbol
ifAbsent: [overwriteOkay]) asString.
(oldSource ~= newSource and: [oldSource includesSubString: overwriteOkay])
ifTrue: [self compile: newSource classified: interfaceString].! !
!DBusCompiledProxy class methodsFor: 'compiling' stamp: 'bf 3/27/2008 16:16'!
parameterFromSignature: aSignature
| parameter |
parameter := DBusArgument nameOfSignature: aSignature.
^parameter first isVowel
ifTrue: ['an', parameter]
ifFalse: ['a', parameter].! !
!DBusCompiledProxy class methodsFor: 'compiling' stamp: 'bf 3/27/2008 16:16'!
parameters: direction from: aNode
"given introspection data for a method or signal node, format a parameter list like #(nameA->type nameB->type)"
| parameters signatures parameter signature |
parameters := OrderedCollection new.
signatures := OrderedCollection new.
aNode tagsNamed: #arg do: [:arg |
(arg attributeAt: 'direction' ifAbsent: ['in']) = direction ifTrue: [
signature := arg attributeAt: 'type'.
parameter := arg attributeAt: 'name' ifAbsent: [nil].
parameter := parameter
ifNil: [self parameterFromSignature: signature]
ifNotNil: [(self underscoreToCamelCase: parameter),
(DBusArgument nameOfSignature: signature)].
[self allInstVarNames includes: parameter]
whileTrue: [
parameter := parameter first isVowel
ifTrue: ['an', parameter capitalized]
ifFalse: ['a', parameter capitalized]].
signatures add: signature.
parameters add: parameter]].
"Append letter if necessary for uniqueness"
parameters := parameters withIndexCollect: [:param :i |
(parameters occurrencesOf: param) = 1
ifTrue: [param]
ifFalse: [param copyWith: (Character value: $A asInteger+
((parameters first: i) occurrencesOf: param)-1)]].
^parameters with: signatures collect: [:p :s | p -> s]! !
!DBusCompiledProxy class methodsFor: 'compiling' stamp: 'bf 3/28/2008 13:16'!
underscoreToCamelCase: aString
| s |
s := aString.
(s allSatisfy: [:c | c = $_ or: [c isUppercase]])
ifTrue: [s := s asLowercase].
^(s copyReplaceAll: '_' with: ' ')
toCamelCase withFirstCharacterDownshifted! !
!DBusCompiledProxy class methodsFor: 'testing' stamp: 'bf 3/27/2008 12:41'!
handlesDBusName: aDBusName andPath: aDBusPath
^self dbusName = aDBusName and: [self dbusPath match: aDBusPath]! !
!DBusCompiledProxy class methodsFor: 'testing' stamp: 'bf 7/7/2008 15:29'!
isAbstract
^self == DBusCompiledProxy! !
!DBusDaemon class methodsFor: 'accessing' stamp: 'bf 3/27/2008 15:37'!
dbusName
^'org.freedesktop.DBus'! !
!DBusDaemon class methodsFor: 'accessing' stamp: 'bf 3/27/2008 15:37'!
dbusPath
^'/'! !
DBusExplorer initialize!
DBusConnection initialize!
