'From etoys3.0 of 7 March 2008 [latest update: #2020] on 19 June 2008 at 9:57:29 pm'!
"Change Set:		DBus-EtoysScripting-bf
Date:			19 June 2008
Author:			Bert Freudenberg

example DBus service, makes Etoys players scriptable from outside"!

DBusObject subclass: #DBusEtoysPlayer
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'DBus-Etoys Scripting'!

!DBusEtoysPlayer commentStamp: 'bf 6/17/2008 15:15' prior: 0!
I present an Etoys player on the DBus so other systems can send messages to players.!

DBusObject subclass: #DBusEtoysService
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'DBus-Etoys Scripting'!

!DBusEtoysService commentStamp: 'bf 6/17/2008 15:25' prior: 0!
I make available all players in the current World on the DBus.

DBus sessionBus
	registerName: 'org.squeak.etoys';
	export: DBusEtoysService new at: '/org/squeak/etoys'.
!


!DBusEtoysPlayer methodsFor: 'handling' stamp: 'bf 6/19/2008 02:06'!
dbusHandle: aMessage from: aDBus spec: aSpecString selector: aSelector
	"Overridden to have the player perform messages deferred in the Morphic main loop"

	(aSpecString beginsWith: self etoysInterface, '.')
		ifTrue: [WorldState addDeferredUIMessage: [
			self dbusHandle: aMessage from: aDBus spec: aSpecString selector: aSelector in: self player]]
		ifFalse: [super dbusHandle: aMessage from: aDBus spec: aSpecString selector: aSelector].

! !

!DBusEtoysPlayer methodsFor: 'accessing' stamp: 'bf 6/17/2008 13:23'!
dbusMethodSpecsAndSelectorsDo: aBlock
	"Iterate over etoys vocabulary"
	| player vocabulary category args resultType selector returnType |
	super dbusMethodSpecsAndSelectorsDo: aBlock.

	player := self player.
	vocabulary := World currentVocabularyFor: player.

	player categories do: [:catName | 
		category := vocabulary categoryAt: catName.
		category elementsInOrder do: [:slot |
			selector := slot selector.
			resultType := slot resultType.
			args := (1 to: selector numArgs) collect: [:i | 
				[self dbusTypeFor: (slot typeForArgumentNumber: i)] ifError: [nil]]. 
			(resultType notNil and: [resultType ~~ #unknown])
				ifTrue: [
					"variable or function"
					returnType := self dbusTypeFor: resultType.
					returnType ifNotNil: [
						selector numArgs = 0 ifTrue: [
							"variable"
							aBlock value: (self interfaceForCategory: catName), '.',
									selector, '<>', returnType asString
									value: selector.
							selector := slot companionSetterSelector.
							selector ifNotNil: [
								aBlock value: (self interfaceForCategory: catName), '.',
									(selector copyWithout: $:), '<', returnType asString, '>'
									value: selector]]
						ifFalse: [
							"function"
							(args allSatisfy: [:arg | arg notNil])
								ifTrue: [aBlock value: (self interfaceForCategory: catName), '.',
									(selector copyWithout: $:), '<', args, '>', returnType asString
									value: selector]]]
					]
				ifFalse: [
					"command"
					(args allSatisfy: [:arg | arg notNil])
						ifTrue: [aBlock value: (self interfaceForCategory: catName), '.',
							(selector copyWithout: $:), '<', args, '>'
							value: selector]].
		]
	]! !

!DBusEtoysPlayer methodsFor: 'accessing' stamp: 'bf 6/17/2008 15:35'!
etoysInterface
	^dbusParent etoysInterface! !

!DBusEtoysPlayer methodsFor: 'accessing' stamp: 'bf 6/17/2008 15:19'!
player
	^World presenter allExtantPlayers detect: [:each | each knownName = dbusName]! !

!DBusEtoysPlayer methodsFor: 'private' stamp: 'bf 6/17/2008 14:13'!
dbusTypeFor: aSymbol
	"Map Etoys types to DBus types, answer nil for types we do not handle (yet)"
	^#($d $s $b $o) at: (#(Number String Boolean Player) indexOf: aSymbol ifAbsent: [^nil])
! !

!DBusEtoysPlayer methodsFor: 'private' stamp: 'bf 6/17/2008 15:36'!
interfaceForCategory: aString
	"Escape none-alphanumeric characters with _ followed by two hex-digits. Space is __ for better readability."
	^self etoysInterface, '.', (String streamContents: [:s |
		aString do: [:c |
			c isAlphaNumeric ifTrue: [s nextPut: c] ifFalse: [
			c = Character space ifTrue: [s nextPutAll: '__'] ifFalse: [
			s nextPut: $_; nextPut: (c asInteger // 16) asHexDigit; nextPut: (c asInteger \\ 16) asHexDigit]]]])
! !


!DBusEtoysService methodsFor: 'dbus methods' stamp: 'bf 6/17/2008 15:37'!
allPlayers
	self dbusMethod: 'org.squeak.etoys.allPlayers<>ao'.
	^self dbusChildren asArray! !

!DBusEtoysService methodsFor: 'accessing' stamp: 'bf 6/17/2008 15:23'!
dbusChildren
	^(World presenter allExtantPlayers collect: [:each | 
		 each knownName -> (DBusEtoysPlayer parent: self name: each knownName)]
	) as: Dictionary! !

!DBusEtoysService methodsFor: 'accessing' stamp: 'bf 6/17/2008 15:35'!
etoysInterface
	^'org.squeak.etoys'! !


!Player methodsFor: '*dbus-etoys scripting' stamp: 'bf 6/17/2008 17:01'!
asDBusArgumentSignature: aSignature
	"XXX: kludge - cleaner to use a notification to look up the call stack"
	^ DBusArgument
		value: DBusEtoysService someInstance dbusPath, '/', self knownName
		signature: aSignature! !