[Pkg] Bob the Builder: Sake-BobSeaside-kph.1.mcz

[squeak-dev-noreply at lists.squeakfoundation.org]

Keith Hodges uploaded a new version of Sake-BobSeaside to project Bob the Builder:
http://www.squeaksource.com/Bob/Sake-BobSeaside-kph.1.mcz

==================== Summary ====================

Name: Sake-BobSeaside-kph.1
Author: kph
Time: 20 July 2009, 8:06:19 pm
UUID: 2cb25031-a184-4dd5-a3a6-1e84063eaa20
Ancestors: 

First cut of UI

==================== Snapshot ====================

SystemOrganization addCategory: #'Sake-BobSeaside'!

WAComponent subclass: #BobComponent
	instanceVariableNames: 'tasks scheduler'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sake-BobSeaside'!

----- Method: BobComponent class>>canBeRoot (in category 'as yet unclassified') -----
canBeRoot

	^ true!

----- Method: BobComponent class>>initialize (in category 'as yet unclassified') -----
initialize
	self registerAsAuthenticatedApplication: 'bob'!

----- Method: BobComponent>>children (in category 'as yet unclassified') -----
children

	^ Array with: scheduler with: tasks!

----- Method: BobComponent>>initialize (in category 'as yet unclassified') -----
initialize
	super initialize.
	scheduler := SakeSchedulerComponent new.
	tasks := BobTasksComponent new!

----- Method: BobComponent>>renderContentOn: (in category 'as yet unclassified') -----
renderContentOn: html
	html heading
		level: 1;
		with: 'Bob the (Squeak) Builder'.

	html heading
		level: 2;
		with: 'Periodic Services'.
		
	html render: scheduler.
		
	html heading
		level: 2;
		with: 'Build Tasks'.
		
	html render: tasks!

WAComponent subclass: #BobTaskDetailComponent
	instanceVariableNames: 'script task'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sake-BobSeaside'!

----- Method: BobTaskDetailComponent class>>script: (in category 'as yet unclassified') -----
script: aScript

	^ self basicNew
		script: aScript;
		initialize;
		yourself!

----- Method: BobTaskDetailComponent class>>task: (in category 'as yet unclassified') -----
task: aScript

	^ self basicNew
		task: aScript;
		initialize;
		yourself!

----- Method: BobTaskDetailComponent>>renderContentOn: (in category 'as yet unclassified') -----
renderContentOn: html
	
	| s |
	
 	s :=  String new writeStream.
	task info storeOn: s.
	
	html heading
		level: 1;
		with: task name.

	html heading
		level: 2;
		with: 'Build meta data'.
		
	html preformatted: s contents.

	html heading
		level: 2;
		with: 'script.st'.

	html preformatted: task script contents.
	
	html anchor
		callback: [ self answer ];
		with: 'Close'.!

----- Method: BobTaskDetailComponent>>task: (in category 'as yet unclassified') -----
task: t

	task :=t!

WAComponent subclass: #BobTasksComponent
	instanceVariableNames: 'taskList needed uploadNeeded styles'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sake-BobSeaside'!

----- Method: BobTasksComponent>>buildNow: (in category 'as yet unclassified') -----
buildNow: task

	[ (task class taskBuildNow: task selector) run ] fork.!

----- Method: BobTasksComponent>>buildNowStepping: (in category 'as yet unclassified') -----
buildNowStepping: task

	[ ((task class taskBuildNow: task selector)
		stepAction: true;
		stepScript: true;
		yourself) run ] fork.!

----- Method: BobTasksComponent>>buildNowSteppingScript: (in category 'as yet unclassified') -----
buildNowSteppingScript: task

	[ ((task class taskBuildNow: task selector)
		stepScript: true;
		yourself) run ] fork.!

----- Method: BobTasksComponent>>initialize (in category 'as yet unclassified') -----
initialize
	
	super initialize.
	
	needed := Dictionary new.
	uploadNeeded := Dictionary new.
	
	styles := IdentityDictionary new
				at: #unknown put: 'background-color : white ; color : lightgrey';
				at: #notWanted put: 'background-color : white ; color : lightgrey';
				at: #noOutput put: 'background-color : white ; color : lightgrey';
				at: #dont put: 'background-color : white ; color : lightgrey';
				at: #notFound put: 'background-color : white ; color : black';
				at: #inProgress put: 'background-color : yellow ; color : black';
				at: #interactive put: 'background-color : green ; color : white';
				at: #manual put: 'background-color : green ; color : white';
				at: #newStart put: 'background-color : lightgreen ; color : black';
				at: #imageChanged put: 'background-color : lightgreen ; color : black';
				at: #waiting put: 'background-color : grey ; color : green';
				yourself.
				
	self updateStatus.!

----- Method: BobTasksComponent>>reloadTaskList (in category 'as yet unclassified') -----
reloadTaskList

	taskList := BobBuild listAll!

----- Method: BobTasksComponent>>renderContentOn: (in category 'as yet unclassified') -----
renderContentOn: html

	| status  |
	html anchor on: #reloadTaskList of: self.

	html break.
	
	html anchor on: #updateStatus of: self.
	
	html table: [ 
		
		html tableRow: [ 
			html 
				tableHeading: 'Output Name';
				tableHeading: 'Input';
				tableHeading: 'Status';
				tableHeading: 'Latest';
				tableHeading: 'Release';
				yourself				
		].
			
		self taskList keysAndValuesDo: [ :n :aTask |
			status := (needed at: aTask ifAbsent: [ {false. #unknown. 'No Idea'} ]).
			html tableRow
				style: (styles at: status second ifAbsent:[ '' ]);
				id: aTask class name, n asString;
				with: [ self updateTask: aTask status: status on: html ].	
		]
	]!

----- Method: BobTasksComponent>>taskList (in category 'as yet unclassified') -----
taskList

	taskList ifNil: [ self reloadTaskList ].
	
	^ taskList!

----- Method: BobTasksComponent>>updateStatus (in category 'as yet unclassified') -----
updateStatus

	needed := Dictionary new.

	self taskList keysAndValuesDo: [ :n :aTask |
		
		needed at: aTask put: (aTask isBuildWanted ifNil: [ aTask isBuildNeeded ]).
		uploadNeeded at: aTask put: (aTask asTaskUpload isNeeded).
	
	]!

----- Method: BobTasksComponent>>updateTask:status:on: (in category 'as yet unclassified') -----
updateTask: task status: status on: html
		
	| latestInfo releaseInfo |
	html tableData
		title: task class name, '>>',task info build;
		with: [
			html render: task name.
		].
	html tableData
	title: task info image;
	with: [
		html render: task info image asFile fileName.
	].

 	
	html tableData
		title: status third;
		with: [		
			html render: status second asReadableText .
		].

	latestInfo := task infoFileReadRelease.
	latestInfo build = #none ifTrue: [ latestInfo := nil ].

	html tableData: [
		latestInfo
			ifNotNil: [ 
				html anchor
					title: latestInfo printString;
					with: (latestInfo timeStart printYYMMDDHHSS: '-')
			]
	].
	releaseInfo := task infoFileReadRelease.
	releaseInfo build = #none ifTrue: [ releaseInfo := nil ].

	html tableData: [
		releaseInfo
			ifNotNil: [ 
				html anchor
					title: releaseInfo printString;
					with: (releaseInfo timeStart printYYMMDDHHSS: '-')
			]
	].
"	html tableData: [
		html render: task info when.
	].
"		
	html tableData: [	
		html anchor 
				title: 'View Script';
				callback: [ WARenderLoop new call: (BobTaskDetailComponent task: task) ];
				with: 'Script'.
						
		status second = #inProgress
			ifFalse: [
				html space anchor 
					title: 'Build Now';
					callback: [ self buildNow: task ];
					with: 'Build'.
				
				html space anchor 
					title: 'Build Now, halting at each step';
					callback: [ self buildNowStepping: task ];
					with: 'Debug'.
			].
		
			(uploadNeeded at: task ifAbsent: false) ifTrue: [ 
					html space anchor 
						title: 'Upload to: ', task info upload asString;
						callback: [ task asTaskUpload run ];
						with: 'Upload'.
				]
			].		
	!