'From etoys3.0 of 7 March 2008 [latest update: #1914] on 12 March 2008 at 3:55:49 pm'!
"Change Set:		DBus-Core-bf-37
Date:			12 March 2008
Author:			Bert Freudenberg

Name: DBus-Core-bf.37
Author: bf
Time: 7 March 2008, 7:13:27 pm
UUID: 75d3ad5f-5627-42ee-9703-6fae2f25ba06
Ancestors: DBus-Core-bf.36

WARNING: this version needs DBus-Plugin-bf.31 or later, it is incompatible with earlier plugins!!
- sessionBus and systemBus are now singletons
- survives image save and restart
- readSemaphore is handled autimatically 
- pollMessage removed
- default to reply=true when sendign message
- add signature parsing
- remove interface and path validation
- interface can be nil now
- minor cleanups"!

Object subclass: #DBusConnection
	instanceVariableNames: 'handle readSemaphore connectionIndex semaIndex '
	classVariableNames: 'Readers Writers SystemBus SessionBus '
	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.!


!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 2/29/2008 10:59'!
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] ->  ['ArrayOf', (self nameOfType: sig second) capitalized].
				[${] -> [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 2/27/2008 17:26'!
typesAndNames
	^#(
		$a array
		$b bool
		$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 3/7/2008 15:14'!
registerSemaphore
	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 3/7/2008 15:39'!
unregisterSemaphore
	semaIndex ifNotNil: [
		(Smalltalk externalObjects at: semaIndex) == readSemaphore
			ifTrue: [Smalltalk unregisterExternalObject: readSemaphore].
		semaIndex := nil].! !

!DBusConnection methodsFor: 'accessing' stamp: 'bf 3/5/2008 17:28'!
messageNoReply
		
	^ self primMessageGetNoReply! !

!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: '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: 'jaf 5/15/2007 11:12'!
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 newFromType: 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 ! !


!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/7/2008 15:53'!
initialize
	"self initialize"

	"start up before AutoStart".
	Smalltalk addToStartUpList: self after: FileDirectory.

	Readers := {
		$b->#argumentReadBool.
		$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 3/7/2008 16:38'!
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;
		yourself! !

!DBusConnection class methodsFor: 'examples' stamp: 'bf 3/5/2008 17:32'!
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 selector: '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 selector = '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' 
								selector: 'setprocessstatus' )
								addArgument: (DBusArgument bool: false);	
								reply: false)
	"
! !

!DBusConnection class methodsFor: 'start up' stamp: 'bf 3/7/2008 16:49'!
startUp: resuming
	resuming ifFalse: [^self].

	self allBussesDo: [:each| each registerSemaphore]! !


!DBusMessage methodsFor: 'accessing' stamp: 'bf 2/26/2008 11:38'!
arguments: argumentArray

	arguments := argumentArray! !

!DBusMessage methodsFor: 'accessing' stamp: 'bf 2/26/2008 11:39'!
destination: destinationString
	destination := destinationString! !

!DBusMessage methodsFor: 'accessing' stamp: 'bf 2/26/2008 11:45'!
fullSelector
	^interface
		ifNil: [selector]
		ifNotNil: [interface, '.', selector]! !

!DBusMessage methodsFor: 'accessing' stamp: 'bf 2/26/2008 11:38'!
interface: interfaceOrNil
	interface := interfaceOrNil
! !

!DBusMessage methodsFor: 'accessing' stamp: 'bf 2/26/2008 11:38'!
objectPath: pathString
	path := pathString
! !

!DBusMessage methodsFor: 'accessing' stamp: 'bf 2/26/2008 11:42'!
selector: selectorString
	selector := selectorString! !

!DBusMessage methodsFor: 'accessing' stamp: 'bf 2/26/2008 11:42'!
sender: senderString
	sender := senderString! !

!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: 'initialize-release' stamp: 'bf 2/26/2008 11:44'!
initialize

	path := ''.
	interface := nil.
	sender := ''.
	selector := ''.
	destination := ''.
	arguments := OrderedCollection new.
	type := self type.
	serial := 0.
	
	! !

!DBusMessage methodsFor: 'printing' stamp: 'bf 2/26/2008 11:54'!
printOn: aStream	

	aStream nextPutAll: self class name.
	(self serial > 0) 
		ifTrue: [
			aStream nextPut: $(.
			self serial printOn: aStream.
			aStream nextPut: $).			
		].
	aStream nextPut: $[;
		nextPutAll: (self objectPath ifNil: ['?']);
		space;
		nextPutAll: (self fullSelector ifNil: ['?']).
	self printArgumentsOn: aStream.	
	aStream nextPut: $]
	! !


!DBusMessageMethodCall methodsFor: 'initialize-release' stamp: 'bf 2/26/2008 12:01'!
initialize
	super initialize.
	reply := true.
	! !

!DBusMessageMethodCall methodsFor: 'read writing' stamp: 'bf 3/5/2008 17:28'!
readFromConnection: con

	super readFromConnection: con.
	reply := con messageNoReply not.! !


!DBusMessageMethodCall class methodsFor: 'instance creation' stamp: 'bf 2/26/2008 12:00'!
destination: d path: p interface: i selector: t

	^ self destination: d path: p  interface: i  selector: t reply: true ! !

DBusMessage removeSelector: #readMessageFromBus!
DBusMessage removeSelector: #validateInterface:!
DBusMessage removeSelector: #validateMember:!
DBusMessage removeSelector: #validatePath:!
DBusConnection class removeSelector: #connectToSessionBus!
DBusConnection class removeSelector: #connectToSystemBus!
DBusConnection class removeSelector: #examplePolling!
DBusConnection initialize!
DBusConnection class removeSelector: #new!
DBusConnection class removeSelector: #primConnectToSessionBus!
DBusConnection class removeSelector: #primConnectToSystemBus!
DBusConnection removeSelector: #getNoReply!
DBusConnection removeSelector: #handle!
DBusConnection removeSelector: #handle:!
DBusConnection removeSelector: #pollMessage!
DBusConnection removeSelector: #primReadWriteConnection!
DBusConnection removeSelector: #primRegisterSemaphore:!
DBusConnection removeSelector: #primSendMessage!
DBusConnection removeSelector: #primSendMessageWithReply!
DBusConnection removeSelector: #readMessage:!
DBusConnection removeSelector: #readSemaphore:!
DBusConnection removeSelector: #registerSemaphore:!
Object subclass: #DBusConnection
	instanceVariableNames: 'connectionIndex semaIndex readSemaphore'
	classVariableNames: 'Readers SessionBus SystemBus Writers'
	poolDictionaries: ''
	category: 'DBus-Core'!