'From etoys3.0 of 19 February 2008 [latest update: #1902] on 21 February 2008 at 1:10:24 pm'!
"Change Set:		dbusExplorer-bf
Date:			21 February 2008
Author:			Bert Freudenberg

Add a graphical DBusExplorer."!

AbstractHierarchicalList subclass: #DBusExplorer
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'DBus-Tools'!

!DBusExplorer commentStamp: 'bf 2/21/2008 12:58' prior: 0!
Browse DBus services by their introspection data.

FIXME: Currently uses DBus main loop provided by SugarLauncher!

ListItemWrapper subclass: #DBusExplorerWrapper
	instanceVariableNames: 'service path'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'DBus-Tools'!

!DBusExplorerWrapper commentStamp: 'bf 2/21/2008 12:47' prior: 0!
service:	'my.service'
path:	'/my/path interface.method()'!


!DBusExplorer methodsFor: 'accessing' stamp: 'bf 2/21/2008 12:49'!
getList
	"Get all running DBus services by looking up registered names"

	 | reply list |
	reply := self sendDBusMessage:  (DBusMessageMethodCall
			destination: 'org.freedesktop.DBus'
			path: '/'
			interface: 'org.freedesktop.DBus'
			selector: 'ListNames').
	list := reply arguments first fromDBusArgument.
	list := list reject: [:each | each first = $:].
	^list collect: [:each | DBusExplorerWrapper service: each 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 2/20/2008 17:39'!
notInAWindow
	| listMorph |

	(listMorph := SimpleHierarchicalListMorph 
		on: self
		list: #getList
		selected: #getCurrentSelection
		changeSelected: #noteNewSelection:
		menu: #genericMenu:
		keystroke: nil).
	listMorph autoDeselect: false.
     ^ listMorph! !

!DBusExplorer methodsFor: 'FIXME' stamp: 'bf 2/21/2008 12:47'!
sendDBusMessage: aMessage
	"FIXME: provide proper dbus main loop"
	^SugarLauncher current
		ensureDBus;
		sendDBusMessage: aMessage timeout: 3! !


!DBusExplorer class methodsFor: 'opening' stamp: 'bf 2/21/2008 12:56'!
open
	^self new inAWindow openInWorld! !


!DBusExplorerWrapper methodsFor: 'initialize-release' stamp: 'bf 2/21/2008 11:17'!
service: serviceName path: pathString
	service := serviceName.
	path := pathString.! !

!DBusExplorerWrapper methodsFor: 'accessing' stamp: 'bf 2/21/2008 12:42'!
asString
	"display only the 'interesting' part of the path"

	^self hasContents
		ifTrue: [path = '/'
			ifTrue: [service]
			ifFalse: [path copyAfterLast: $/]]
		ifFalse: [path copyAfter: Character space]! !

!DBusExplorerWrapper methodsFor: 'accessing' stamp: 'bf 2/21/2008 12:41'!
contents
	"introspect the current path, answer children (subnodes of current path) and leafs (methods, signals)"

	| introspection node children leafs in out |
	introspection := (self sendDBusMessage:  (DBusMessageMethodCall
			destination: service
			path: path
			interface: 'org.freedesktop.DBus.Introspectable'
			selector: 'Introspect')) arguments first fromDBusArgument.
	node := (XMLDOMParser parseDocumentFrom: introspection readStream) elements first.
	children := (node elements select: [:each | each tag = #node])
		collect: [:each | DBusExplorerWrapper
			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 arguments: 'in' from: each.
				out := each tag = #signal
					ifTrue: ['SIGNAL']
					ifFalse: [self arguments: 'out' from: each].
				strm nextPut: (DBusExplorerWrapper
					service: service
					path: path, ' ', (interface attributeAt: 'name'), '.', (each attributeAt: 'name'), in, ' => ', out)]]]].

	^children, leafs! !

!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: 'FIXME' stamp: 'bf 2/21/2008 12:54'!
sendDBusMessage: aMessage
	"FIXME: provide proper dbus main loop"
	^SugarLauncher current
		ensureDBus;
		sendDBusMessage: aMessage timeout: 3! !

!DBusExplorerWrapper methodsFor: 'private' stamp: 'bf 2/21/2008 12:39'!
arguments: direction from: aNode
	"given introspection data for a method or signal node, format an argument 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 2/21/2008 11:37'!
service: serviceName path: pathString
	^self new service: serviceName path: pathString! !


!SugarLauncher methodsFor: '*dbus-tools' stamp: 'bf 2/21/2008 12:53'!
ensureDBus
	"run a dbus main loop even when not an activity"
	dbus ifNil: [
		process := [self runDBusService: 'org.squeak']
			forkAt: Processor userInterruptPriority named: 'Test DBus service'].! !


!SugarLauncher reorganize!
('*dbus-tools' ensureDBus)
('running' shutDown startUp)
('commands' active: join quit save share takeScreenshot welcome:)
('bundling' bundleIcon bundleIconTemplate bundleInfoTemplate bundleInfoTitle:version:bundle:script:icon: bundleScriptTemplate bundle: bundle:as:title:version:id:icon:)
('accessing' activityId buddies bundleId bundlePath ownerBuddy)
('dbus' dbusMessageRegistry dbusSignalRegistry dispatchDBusMessage: handleActivitySetActive: handleBuddyJoined: handleBuddyLeft: handleDBusIntrospect: handleTakeScreenshot: introspect runDBusService: sendDBusMessage: sendDBusMessage:onSuccess:onError: sendDBusMessage:timeout:)
('events' windowEvent:)
('datastore' createJournalEntryFor:filename:mimetype: findJournalEntries: getFilename: getFile: getProperties: handleStream:mimetype:titled: makeJournalEntryFor:filename:mimetype: propertiesFrom: resumeJournalEntry: titleFromProject: updateJournalEntry: updateJournalEntry:for:filename:mimetype:)
('presence' badgeHolder buddyFromPath: buddyJoined: buddyLeft: enableSharedActivitySignals getSharedActivityBuddies getSharedActivityById: getSharedActivityProperties joinSharedActivity leaveSharedActivity makeBadges ownerFromDBus setSharedActivityProperties: shareActivityId:bundleId:name:properties:)
('telepathy')
('testing' isRunningInRainbow isRunningInSugar isShared)
('chooser')
('as yet unclassified' bundleScript:)
!


!DBusExplorerWrapper class reorganize!
('instance creation' service:path:)
!

DBusExplorerWrapper removeSelector: #initialize!
DBusExplorerWrapper removeSelector: #service:!

!DBusExplorerWrapper reorganize!
('initialize-release' service:path:)
('accessing' asString contents hasContents)
('FIXME' sendDBusMessage:)
('private' arguments:from:)
!


!DBusExplorer class reorganize!
('opening' open)
!


!DBusExplorer reorganize!
('accessing' getList)
('opening' inAWindow notInAWindow)
('FIXME' sendDBusMessage:)
!