[squeak-dev] Squeak 4.5: SystemReporter-ul.21.mcz

commits at source.squeak.org commits at source.squeak.org
Fri Jan 24 20:15:53 UTC 2014


Chris Muller uploaded a new version of SystemReporter to project Squeak 4.5:
http://source.squeak.org/squeak45/SystemReporter-ul.21.mcz

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

Name: SystemReporter-ul.21
Author: ul
Time: 27 April 2013, 10:50:30.431 pm
UUID: 34c5c48c-e7cc-4dfe-8133-6dec3bc63ff7
Ancestors: SystemReporter-dtl.20

- addedd SpaceTally to SystemReporter

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

SystemOrganization addCategory: #SystemReporter!

Object subclass: #SystemReporter
	instanceVariableNames: 'categories categoriesSelected report tinyBenchmarksResult categoryList testRunner spaceAnalysisResult'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SystemReporter'!

!SystemReporter commentStamp: 'laza 1/18/2011 12:04' prior: 0!
SystemReporter offers a window where information about the system is gathered. This can be easily copied to the clipboard and be attached to a bug report for better identification of the context the bug occured in.

To extend the SystemReporter:
	- add a method
		reportXYZ: aStream
	  to the reporting category
	- insert a line
		add: #XYZ method: #reportXYZ
	  to the initialize method
!

----- Method: SystemReporter class>>open (in category 'instance creation') -----
open
	^ ToolBuilder open: self new.!

----- Method: SystemReporter>>add:method: (in category 'accessing-categories') -----
add: category method: aSymbol
	^self categoryList add: (self categories add: category -> aSymbol) key!

----- Method: SystemReporter>>buildCategoriesWith: (in category 'building') -----
buildCategoriesWith: aBuilder
	^ aBuilder pluggableMultiSelectionListSpec new
		model: self;
		list: #categoryList;
		menu: #categoryMenu:;
		getIndex: #categorySelected;
		setIndex: #categorySelected:;
		getSelectionList: #categoryAt:;
		setSelectionList: #categoryAt:put:;
		yourself.!

----- Method: SystemReporter>>buildReportWith: (in category 'building') -----
buildReportWith: aBuilder
	^ aBuilder pluggableTextSpec new
		model: self;
		menu: #reportMenu:;
		getText: #reportText;
		yourself.!

----- Method: SystemReporter>>buildWith: (in category 'building') -----
buildWith: aBuilder
	| window |
	window := aBuilder pluggableWindowSpec new
		model: self; label: self label; extent: self extent;
		children: (OrderedCollection new 
			add: ((self buildCategoriesWith: aBuilder)
				frame: self categoriesFrame;
				yourself);
			add: ((self buildReportWith: aBuilder)
				frame: self reportFrame;
				yourself);
			yourself);
		yourself.
	^ aBuilder build: window.!

----- Method: SystemReporter>>categories (in category 'accessing-categories') -----
categories
	^ categories ifNil: [categories := IdentityDictionary new]!

----- Method: SystemReporter>>categoriesFrame (in category 'building') -----
categoriesFrame
	^LayoutFrame new
		leftFraction: 0 offset: 0;
		topFraction: 0 offset: 0;
		rightFraction: 0.25 offset: 0;
		bottomFraction: 1 offset: 0!

----- Method: SystemReporter>>categoryAt: (in category 'accessing-categories') -----
categoryAt: anIndex
	^ categoriesSelected includes: (self categoryList at: anIndex ifAbsent: [ ^ false ]).!

----- Method: SystemReporter>>categoryAt:put: (in category 'accessing-categories') -----
categoryAt: anInteger put: aBoolean
	categoriesSelected := categoriesSelected
		perform: (aBoolean ifTrue: [ #copyWith: ] ifFalse: [ #copyWithout: ])
		with: (self categoryList at: anInteger ifAbsent: [ ^ self ]).
	self updateReport!

----- Method: SystemReporter>>categoryList (in category 'accessing-categories') -----
categoryList
	^ categoryList ifNil: [categoryList := OrderedCollection new]!

----- Method: SystemReporter>>categoryMenu: (in category 'accessing-categories') -----
categoryMenu: aMenu
	^ aMenu
		title: 'Categories';
		add: 'Select all' action: #selectAllCategories;
		add: 'Select none' action: #selectNoCategories;
		addLine;
		add: 'Refresh' action: #refresh;
		yourself.!

----- Method: SystemReporter>>categorySelected (in category 'accessing-categories') -----
categorySelected
	^ 0!

----- Method: SystemReporter>>categorySelected: (in category 'accessing-categories') -----
categorySelected: anInteger
	self changed: #categorySelected.!

----- Method: SystemReporter>>copyReportToClipboard (in category 'accessing-report') -----
copyReportToClipboard
	Clipboard clipboardText: self reportText.
	UIManager default inform: 'Copied Report to Clipboard'!

----- Method: SystemReporter>>enumerate:on: (in category 'private') -----
enumerate: aBlock on: aStream
	self enumerate: aBlock startAt: 0 on: aStream!

----- Method: SystemReporter>>enumerate:startAt:on: (in category 'private') -----
enumerate: aBlock startAt: first on: aStream
	"Utilitymethod to enumerate Options or Parameters from first to 1000"
	| idx value |
	idx := first.
	[value := aBlock value: idx.
	value = nil or: [idx > 1000]] whileFalse: [
		aStream
			nextPut: $#;
			nextPutAll: idx printString;
			tab;
			nextPutAll: value; cr.
		idx := idx + 1
	].
	idx = first ifTrue: [aStream nextPutAll: 'none'; cr]!

----- Method: SystemReporter>>extent (in category 'accessing-ui') -----
extent
	^ 640 @ 480!

----- Method: SystemReporter>>header:on: (in category 'printing-report') -----
header: aString on: aStream
	aStream withAttribute: TextEmphasis bold do: [	
		aStream nextPutAll: aString; cr.
		aString size timesRepeat: [aStream nextPut: $-].
		aStream cr]!

----- Method: SystemReporter>>initialize (in category 'initialize-release') -----
initialize
	self
		add: #Image method: #reportImage;
		add: #'Image Parameters' method: #reportImageParameters;
		add: #'Image Sources' method: #reportSources;
		add: #'Image Preferences' method: #reportPreferences;
		add: #'MC Repositories' method: #reportRepositories;
		add: #'MC Working Copies' method: #reportWorkingCopies;
		add: #'VM General' method: #reportVM;
		add: #'VM Options' method: #reportVMOptions;
		add: #'VM Modules' method: #reportModules;
		add: #'VM Parameters' method: #reportVMParameters;
		add: #'VM Stats' method: #reportVMStats.
	Smalltalk os platformName = 'Win32' ifTrue: [
		self
			add: #'VM Configuration' method: #reportWin32VMConfig.
		].
	self
		add: #'OS General' method: #reportOS.
	Smalltalk os platformName = 'Win32' ifTrue: [
		self
			add: #'OS Details' method: #reportWin32OSDetails;
			add: #'Hardware Details' method: #reportWin32HardwareDetails;
			add: #'GFX Hardware Details' method: #reportWin32GFXDetails.
		].
	Smalltalk os osVersion = 'linux' ifTrue: [
		self
			add: #'OS Details' method: #reportLinuxOSDetails
	].
	self
		add: #'Tiny Benchmarks' method: #reportTinyBenchmarks;
		add: #'Space Analysis' method: #reportSpaceAnalysis;
		add: #'SUnit' method: #reportTestRunner;
		add: #'Debug Log' method: #reportDebugLog.
	categoriesSelected := Set with: #Image with: #'VM General'.
	self updateReport
!

----- Method: SystemReporter>>label (in category 'accessing-ui') -----
label
	^ 'System Reporter' !

----- Method: SystemReporter>>printDebugExpressionFor:on: (in category 'private') -----
printDebugExpressionFor: methodSignature on: aStream 
	| compiledMethod |
	compiledMethod := Compiler evaluate: methodSignature.
	aStream
		 nextPut: $( ;
		 nextPutAll: compiledMethod methodClass name ;
		 nextPutAll: ' selector: #' ;
		 nextPutAll: compiledMethod selector ;
		 nextPutAll: ') debug.'!

----- Method: SystemReporter>>refresh (in category 'accessing-categories') -----
refresh
	spaceAnalysisResult := tinyBenchmarksResult := testRunner := nil.
	self updateReport!

----- Method: SystemReporter>>reportDebugLog: (in category 'reporting') -----
reportDebugLog: aStream
	| logFilename logStream contents |
	self header: 'Debug Logfile' on: aStream.
	logFilename := Smalltalk image squeakErrorFileName.
	logStream := nil.
	[
		[
			logStream := FileStream readOnlyFileNamed: logFilename.
			aStream nextPutAll: logStream name; cr; cr.
			contents := logStream contents.
			aStream
				nextPutAll: 
					((contents isNil or: [contents size = 0])
						ifTrue: ['<empty>']
						ifFalse: [contents]);
				cr
		] on: Error do: [:ex |
			aStream
				nextPutAll: (
					ex class = FileDoesNotExistException
						ifTrue: [logFilename, ' not found']
						ifFalse: [ex description]);
				cr
		]
	] ensure: [
		logStream ifNotNil: [logStream close]
	]!

----- Method: SystemReporter>>reportFrame (in category 'building') -----
reportFrame
	^LayoutFrame new
		leftFraction: 0.25 offset: 0;
		topFraction: 0 offset: 0;
		rightFraction: 1 offset: 0;
		bottomFraction: 1 offset: 0!

----- Method: SystemReporter>>reportImage: (in category 'reporting') -----
reportImage: aStream
	self header: 'Image' on: aStream.
	aStream 
		nextPutAll: Smalltalk image imageName; cr;
		nextPutAll: SystemVersion current version; cr;
		nextPutAll: Smalltalk image lastUpdateString; cr;
		nextPutAll: Smalltalk image currentChangeSetString; cr.
	[ | imageFormat bitsPerWord |
	imageFormat := Smalltalk image imageFormatVersion.
	bitsPerWord := Smalltalk image wordSize * 8.
	aStream nextPutAll: 'Image format ';
			nextPutAll: imageFormat asString;
			nextPutAll: ' (';
			nextPutAll: bitsPerWord asString;
			nextPutAll: ' bit)'; cr]
		on: Warning
		do: ["primitive not present in VM"].
!

----- Method: SystemReporter>>reportImageParameters: (in category 'reporting') -----
reportImageParameters: aStream
	self header: 'Image Commandline Parameters' on: aStream.
	self enumerate: [:idx | Smalltalk image argumentAt: idx] on: aStream.!

----- Method: SystemReporter>>reportLinuxOSDetails: (in category 'reporting') -----
reportLinuxOSDetails: aStream
	self header: 'Operating System Details' on: aStream.
	#(
		'/etc/issue'
		'/etc/lsb-release'
		'/proc/version'
	) do: [:path|
		self writeContentsSafelyFromFile: path on: aStream]!

----- Method: SystemReporter>>reportMenu: (in category 'accessing-report') -----
reportMenu: aMenu
	^ aMenu
		title: 'Report';
		add: 'Copy to Clipboard' action: #copyReportToClipboard;
		yourself.!

----- Method: SystemReporter>>reportModules: (in category 'reporting') -----
reportModules: aStream
	self header: 'Loaded VM Modules' on: aStream.
	SmalltalkImage current listLoadedModules asSortedCollection do: [:each | aStream nextPutAll: each; cr].

!

----- Method: SystemReporter>>reportOS: (in category 'reporting') -----
reportOS: aStream
	self header: 'Operating System/Hardware' on: aStream.
	aStream
		nextPutAll: Smalltalk os platformName; space;
		nextPutAll: Smalltalk os osVersion; space;
		nextPutAll: Smalltalk os platformSubtype; cr
!

----- Method: SystemReporter>>reportPreferences: (in category 'reporting') -----
reportPreferences: aStream
	| booleanPrefs prefs valuePrefs attribute falseTA trueTA |
	prefs := Preferences dictionaryOfPreferences.
	booleanPrefs := prefs select: [:each | each type = #Boolean].
	valuePrefs := prefs select: [:each | each type = #Number or: [each type = #String]].
	trueTA := TextColor black.
	falseTA := TextColor gray.
	booleanPrefs := booleanPrefs asSortedCollection: [:a :b | a name <= b name].  
	self header: 'Boolean Preferences' on: aStream.
	booleanPrefs do: [:each |
		attribute := each preferenceValue ifTrue: [trueTA] ifFalse: [falseTA].
		aStream withAttribute: attribute do: [	
		aStream
			nextPutAll: each name;
			tab;  
			nextPutAll: each preferenceValue printString;
			cr]].
	aStream cr.
	self header: 'Value Preferences' on: aStream.
	valuePrefs do: [:each |
		aStream
			nextPutAll: each name;
			tab;  
			nextPutAll: each preferenceValue printString;
			cr].
!

----- Method: SystemReporter>>reportRepositories: (in category 'reporting') -----
reportRepositories: aStream
	self header: 'Monticello Repositories' on: aStream.
	MCRepositoryGroup default repositories do: [:each | aStream nextPutAll: each description; cr]!

----- Method: SystemReporter>>reportSources: (in category 'reporting') -----
reportSources: aStream
	self header: 'Image Sources' on: aStream.
	aStream nextPutAll: SourceFiles class printString; cr.
	SourceFiles do: [:each |
		each ifNotNil: [aStream nextPutAll: each printString; cr]]!

----- Method: SystemReporter>>reportSpaceAnalysis: (in category 'reporting') -----
reportSpaceAnalysis: aStream

	spaceAnalysisResult ifNil: [
		UIManager inform: 'Running the Space Analysis\will take a few seconds' withCRs.
		spaceAnalysisResult := String streamContents: [ :stream |
			SpaceTally new printSpaceAnalysis: 1 onStream: stream ] ].
	self header: 'Space Analysis' on: aStream.
	aStream nextPutAll: spaceAnalysisResult; cr!

----- Method: SystemReporter>>reportTestRunner: (in category 'reporting') -----
reportTestRunner: aStream 
	testRunner ifNil:
		[ | runAllTests |
		runAllTests := UIManager confirm: 'Running all Tests\will take long time' withCRs.
		runAllTests
			ifTrue: [ testRunner := TestRunner new runAll ]
			ifFalse:
				[ categoriesSelected remove: #SUnit.
				^ self changed: #categorySelected ] ].
	self
		header: 'SUnit Results'
		on: aStream.
	aStream nextPutAll: testRunner statusText ; cr ; cr.
	self
		header: 'Failed Tests'
		on: aStream.
	testRunner failedList do:
		[ : each | self
			printDebugExpressionFor: each
			on: aStream.
		aStream cr ].
	aStream cr.
	self
		header: 'Errors'
		on: aStream.
	testRunner errorList do:
		[ : each | self
			printDebugExpressionFor: each
			on: aStream.
		aStream cr ]!

----- Method: SystemReporter>>reportText (in category 'accessing-report') -----
reportText
	^ (report isNil or: [categoriesSelected isEmpty])
		ifTrue: ['-- Choose any category on the left --']
		ifFalse: [report]!

----- Method: SystemReporter>>reportTinyBenchmarks: (in category 'reporting') -----
reportTinyBenchmarks: aStream
	tinyBenchmarksResult ifNil: [
		UIManager inform: 'Running the Benchmarks\will take a few seconds' withCRs.
		tinyBenchmarksResult := 0 tinyBenchmarks].
	self header: 'Tiny Benchmarks' on: aStream.
	aStream nextPutAll: tinyBenchmarksResult; cr!

----- Method: SystemReporter>>reportVM: (in category 'reporting') -----
reportVM: aStream
	self header: 'Virtual Machine' on: aStream.
	aStream
		nextPutAll: (Smalltalk vm vmFileName); cr;
		nextPutAll: (Smalltalk vm vmVersion); cr.
	Smalltalk vm buildDate
		ifNotNilDo: [:string | aStream nextPutAll: string; cr].
	[Smalltalk vm platformSourceVersion
		ifNotNilDo: [:v | aStream nextPutAll: 'platform sources revision ', v; cr]]
			on: Warning do: ["unsupported primitive"].
	[Smalltalk vm interpreterSourceVersion
		ifNotNilDo: [:v | aStream nextPutAll: 'VMMaker versionString ', v; cr]]
			on: Warning do: ["unsupported primitive"].
	[Smalltalk vm interpreterClass
		ifNotNilDo: [:string | aStream nextPutAll: string; cr].
	Smalltalk vm cogitClass
		ifNotNilDo: [:string | aStream nextPutAll: string; cr]
	] on: Error do: ["unsupported primitives"]
!

----- Method: SystemReporter>>reportVMOptions: (in category 'reporting') -----
reportVMOptions: aStream
	self header: 'Virtual Machine Commandline Options' on: aStream.
	self enumerate: [:idx | Smalltalk vm optionAt: idx] startAt: 1 on: aStream!

----- Method: SystemReporter>>reportVMParameters: (in category 'reporting') -----
reportVMParameters: aStream
	| vmParameters |
	self header: 'Virtual Machine Parameters' on: aStream.
	vmParameters := Smalltalk vm getVMParameters.
	#(
		1	'end of old-space (0-based, read-only)'
		2	'end of young-space (read-only)'
		3	'end of memory (read-only)'
		4	'allocationCount (read-only)'
		5	'allocations between GCs (read-write)'
		6	'survivor count tenuring threshold (read-write)'
		7	'full GCs since startup (read-only)'
		8	'total milliseconds in full GCs since startup (read-only)'
		9	'incremental GCs since startup (read-only)'
		10	'total milliseconds in incremental GCs since startup (read-only)'
		11	'tenures of surving objects since startup (read-only)'
		12	'specific to the translating VM'
		13  'specific to the translating VM'
		14  'specific to the translating VM'
		15  'specific to the translating VM'
		16  'specific to the translating VM'
		17  'specific to the translating VM'
		18  'specific to the translating VM'
		19  'specific to the translating VM'
		20  'specific to the translating VM'
		21	'root table size (read-only)'
		22	'root table overflows since startup (read-only)'
		23	'bytes of extra memory to reserve for VM buffers, plugins, etc.'
		24	'memory threshold above which shrinking object memory (rw)'
		25	'memory headroom when growing object memory (rw)'
		26  'interruptChecksEveryNms - force an ioProcessEvents every N milliseconds, in case the image  is not calling getNextEvent often (rw)'
		27	'number of times mark loop iterated for current IGC/FGC (read-only) includes ALL marking'
		28	'number of times sweep loop iterated  for current IGC/FGC (read-only)'
		29	'number of times make forward loop iterated for current IGC/FGC (read-only)'
		30	'number of times compact move loop iterated for current IGC/FGC (read-only)'
		31	'number of grow memory requests (read-only)'
		32	'number of shrink memory requests (read-only)'
		33	'number of root table entries used for current IGC/FGC (read-only)'
		34	'number of allocations done before current IGC/FGC (read-only)'
		35	'number of survivor objects after current IGC/FGC (read-only)'
		36  'millisecond clock when current IGC/FGC completed (read-only)'
		37  'number of marked objects for Roots of the world, not including Root Table entries for current IGC/FGC (read-only)'
		38  'milliseconds taken by current IGC  (read-only)'
		39  'Number of finalization signals for Weak Objects pending when current IGC/FGC completed (read-only)'
		40  'VM word size - 4 or 8 (read-only)'
	) pairsDo: [:idx :desc |
		aStream
			nextPut: $#;
			nextPutAll: idx printString;
			tab;
			nextPutAll: (vmParameters at: idx) printString;
			tab;
			nextPutAll: desc;
			cr]!

----- Method: SystemReporter>>reportVMStats: (in category 'reporting') -----
reportVMStats: aStream
	self header: 'Virtual Machine Statistics' on: aStream.
	aStream
		nextPutAll: Smalltalk vm vmStatisticsReportString!

----- Method: SystemReporter>>reportWin32GFXDetails: (in category 'reporting') -----
reportWin32GFXDetails: aStream
	self header: 'Graphics Hardware Details' on: aStream.
	aStream nextPutAll: (SmalltalkImage current getSystemAttribute: 10003)!

----- Method: SystemReporter>>reportWin32HardwareDetails: (in category 'reporting') -----
reportWin32HardwareDetails: aStream
	self header: 'Hardware Details' on: aStream.
	aStream nextPutAll: (SmalltalkImage current getSystemAttribute: 10001)!

----- Method: SystemReporter>>reportWin32OSDetails: (in category 'reporting') -----
reportWin32OSDetails: aStream
	self header: 'Operating System Details' on: aStream.
	aStream nextPutAll: (SmalltalkImage current getSystemAttribute: 10002)!

----- Method: SystemReporter>>reportWin32VMConfig: (in category 'reporting') -----
reportWin32VMConfig: aStream
	| exePath iniPath |
	self header: 'VM Configuration' on: aStream.
	exePath := Smalltalk vm vmFileName.
	iniPath := (exePath copyUpToLast: $.), '.ini'.
	aStream nextPutAll: iniPath; cr.
	self writeContentsSafelyFromFile: iniPath on: aStream.
!

----- Method: SystemReporter>>reportWorkingCopies: (in category 'reporting') -----
reportWorkingCopies: aStream
	| list |
	self header: 'Monticello Working Copies' on: aStream.
	list := MCWorkingCopy allManagers asSortedCollection: [:a :b | a name <= b name]  .
	list do: [:each | aStream nextPutAll: each description; cr]!

----- Method: SystemReporter>>selectAllCategories (in category 'accessing-categories') -----
selectAllCategories
	categoriesSelected addAll: categoryList.
	self changed: #categorySelected.
	self updateReport!

----- Method: SystemReporter>>selectNoCategories (in category 'accessing-categories') -----
selectNoCategories
	categoriesSelected removeAll.
	self changed: #categorySelected.
	self updateReport!

----- Method: SystemReporter>>updateReport (in category 'updating') -----
updateReport
	report := Text streamContents: [:stream | 
		stream 
			withAttribute: (TextFontReference toFont: ((TextStyle named: 'BitstreamVeraSansMono') fontOfSize: 16))
			do: [
				self categoryList do: [:each |
					(categoriesSelected includes: each) ifTrue: [
						self perform: ((categories at: each), ':') asSymbol with: stream.
						stream cr]]]].
	self changed: #reportText!

----- Method: SystemReporter>>writeContentsSafelyFromFile:on: (in category 'private') -----
writeContentsSafelyFromFile: osPath on: aStream
	aStream nextPutAll:
		([
			(FileStream readOnlyFileNamed: osPath) upToEnd
		 ] on: Error do: [:ex| ex return: ex printString])!



More information about the Squeak-dev mailing list