Squeak-dev June 2015

squeak-dev@lists.squeakfoundation.org

35 participants
162 discussions

Squeak 4.6: SUnitGUI-mt.62.mcz
by commits＠source.squeak.org 05 Jun '15

05 Jun '15

Chris Muller uploaded a new version of SUnitGUI to project Squeak 4.6: http://source.squeak.org/squeak46/SUnitGUI-mt.62.mcz ==================== Summary ==================== Name: SUnitGUI-mt.62 Author: mt Time: 10 May 2015, 12:18:33.708 pm UUID: 23278a70-3219-2542-bdb0-1e42b35989a6 Ancestors: SUnitGUI-topa.61 Upper spacing of button bar in test runner fixed by removing some magic numbers. ==================== Snapshot ==================== SystemOrganization addCategory: #SUnitGUI! ProtoObject subclass: #TestCoverage instanceVariableNames: 'hasRun reference method' classVariableNames: '' poolDictionaries: '' category: 'SUnitGUI'! ----- Method: TestCoverage class>>on: (in category 'instance creation') ----- on: aMethodReference ^ self new initializeOn: aMethodReference! ----- Method: TestCoverage>>doesNotUnderstand: (in category 'private') ----- doesNotUnderstand: aMessage ^ method perform: aMessage selector withArguments: aMessage arguments! ----- Method: TestCoverage>>flushCache (in category 'private') ----- flushCache! ----- Method: TestCoverage>>hasRun (in category 'testing') ----- hasRun ^ hasRun! ----- Method: TestCoverage>>initializeOn: (in category 'initialization') ----- initializeOn: aMethodReference hasRun := false. reference := aMethodReference. method := reference compiledMethod! ----- Method: TestCoverage>>install (in category 'actions') ----- install reference actualClass methodDictionary at: reference methodSymbol put: self! ----- Method: TestCoverage>>mark (in category 'private') ----- mark hasRun := true! ----- Method: TestCoverage>>reference (in category 'private') ----- reference ^ reference! ----- Method: TestCoverage>>run:with:in: (in category 'evaluation') ----- run: aSelector with: anArray in: aReceiver self mark; uninstall. ^ aReceiver withArgs: anArray executeMethod: method! ----- Method: TestCoverage>>uninstall (in category 'actions') ----- uninstall reference actualClass methodDictionary at: reference methodSymbol put: method! ----- Method: TestCase class>>packageNamesUnderTest (in category '*sunitgui') ----- packageNamesUnderTest "Answer a collection of package names under test. This is used by the test runner to automatically instrument the code in these packages when checking for test coverage." ^ #()! Object subclass: #TestRunner instanceVariableNames: 'categories categoriesSelected classes classIndex classesSelected failedList failedSelected errorList errorSelected lastUpdate result previousRun categoryPattern classPattern' classVariableNames: '' poolDictionaries: '' category: 'SUnitGUI'! !TestRunner commentStamp: '<historical>' prior: 0! <lint: #ignore rule: #classNotReferenced rational: 'this view is only accessed from menus'> ! ----- Method: TestRunner class>>build (in category 'instance-creation') ----- build ^ ToolBuilder build: self new.! ----- Method: TestRunner class>>initialize (in category 'initialization') ----- initialize self registerInWorldMenu; registerInToolsFlap.! ----- Method: TestRunner class>>open (in category 'instance-creation') ----- open ^ ToolBuilder open: self new.! ----- Method: TestRunner class>>registerInToolsFlap (in category 'initialization') ----- registerInToolsFlap self environment at: #Flaps ifPresent: [ :class | class registerQuad: #( TestRunner build 'SUnit Runner' 'A production scale test-runner.' ) forFlapNamed: 'Tools'; replaceToolsFlap ].! ----- Method: TestRunner class>>registerInWorldMenu (in category 'initialization') ----- registerInWorldMenu self environment at: #TheWorldMenu ifPresent: [ :class | class registerOpenCommand: (Array with: 'Test Runner' with: (Array with: self with: #open)) ].! ----- Method: TestRunner class>>windowColorSpecification (in category 'window color') ----- windowColorSpecification ^ WindowColorSpec classSymbol: self name wording: 'Test Runner' brightColor: Color orange pastelColor: (Color r: 0.65 g: 0.753 b: 0.976) helpMessage: 'The Camp Smalltalk TestRunner tool for SUnit'! ----- Method: TestRunner>>addDeclaredPackagesUnderTestTo: (in category 'actions') ----- addDeclaredPackagesUnderTestTo: packages classesSelected do: [ :class | (class class includesSelector: #packageNamesUnderTest) ifTrue: [ class packageNamesUnderTest do: [ :name | packages add: (PackageInfo named: name) ] ] ]! ----- Method: TestRunner>>addMethodsUnderTestIn:to: (in category 'actions') ----- addMethodsUnderTestIn: packages to: methods packages do: [:package | package isNil ifFalse: [package methods do: [:method | ((#(#packageNamesUnderTest #classNamesNotUnderTest ) includes: method methodSymbol) or: [method compiledMethod isAbstract or: [method compiledMethod refersToLiteral: #ignoreForCoverage]]) ifFalse: [methods add: method]]]]! ----- Method: TestRunner>>baseClass (in category 'accessing') ----- baseClass ^ TestCase! ----- Method: TestRunner>>basicRunSuite:do: (in category 'processing') ----- basicRunSuite: aTestSuite do: aBlock self basicSetUpSuite: aTestSuite. [ | prefix | prefix := aTestSuite name isEmptyOrNil ifTrue: [ '' ] ifFalse: [ aTestSuite name, ' - ' ]. aTestSuite tests do: aBlock displayingProgress: [ :test | prefix, test printString ] every: 0 "Update the label for all tests" ] ensure: [ self basicTearDownSuite: aTestSuite ]. ! ----- Method: TestRunner>>basicSetUpSuite: (in category 'processing') ----- basicSetUpSuite: aTestSuite aTestSuite resources do: [ :each | each isAvailable ifFalse: [ each signalInitializationError ] ].! ----- Method: TestRunner>>basicTearDownSuite: (in category 'processing') ----- basicTearDownSuite: aTestSuite aTestSuite resources do: [ :each | each reset ].! ----- Method: TestRunner>>browseClass (in category 'accessing-classes') ----- browseClass (classes at: classIndex ifAbsent: [ ^ self ]) browse! ----- Method: TestRunner>>browserEnvironment (in category 'private') ----- browserEnvironment ^ Smalltalk classNamed: #BrowserEnvironment.! ----- Method: TestRunner>>buildButtonsWith: (in category 'building') ----- buildButtonsWith: aBuilder ^ aBuilder pluggablePanelSpec new model: self; layout: #horizontal; children: (self buttons collect: [ :each | aBuilder pluggableButtonSpec new model: self; label: each first; action: each second; enabled: each third; yourself ]); yourself.! ----- Method: TestRunner>>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: TestRunner>>buildClassesWith: (in category 'building') ----- buildClassesWith: aBuilder ^ aBuilder pluggableMultiSelectionListSpec new model: self; list: #classList; menu: #classMenu:; getIndex: #classSelected; setIndex: #classSelected:; getSelectionList: #classAt:; setSelectionList: #classAt:put:; yourself.! ----- Method: TestRunner>>buildErrorListWith: (in category 'building') ----- buildErrorListWith: aBuilder ^ aBuilder pluggableListSpec new model: self; name: 'Error List'; list: #errorList; menu: #errorMenu:; getIndex: #errorSelected; setIndex: #errorSelected:; yourself.! ----- Method: TestRunner>>buildFailureListWith: (in category 'building') ----- buildFailureListWith: aBuilder ^ aBuilder pluggableListSpec new model: self; name: 'Failure List'; list: #failedList; menu: #failureMenu:; getIndex: #failedSelected; setIndex: #failedSelected:; yourself.! ----- Method: TestRunner>>buildStatusWith: (in category 'building') ----- buildStatusWith: aBuilder ^ aBuilder pluggableTextSpec new model: self; menu: #statusMenu:; color: #statusColor; getText: #statusText; yourself.! ----- Method: TestRunner>>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 buildClassesWith: aBuilder) frame: self classesFrame; yourself); add: ((self buildStatusWith: aBuilder) frame: self statusFrame; yourself); add: ((self buildFailureListWith: aBuilder) frame: self failureListFrame; yourself); add: ((self buildErrorListWith: aBuilder) frame: self errorListFrame; yourself); add: ((self buildButtonsWith: aBuilder) frame: self buttonsFrame; yourself); yourself); yourself. ^ aBuilder build: window.! ----- Method: TestRunner>>buttonHeight (in category 'building') ----- buttonHeight ^ Preferences standardButtonFont height * 3! ----- Method: TestRunner>>buttons (in category 'accessing-ui') ----- buttons ^ #(( 'Run Selected' #runAll #hasRunnable ) ( 'Run Profiled' #runProfiled #hasRunnable ) ( 'Run Coverage' #runCoverage #hasRunnable ) ( 'Run Failures' #runFailures #hasFailures ) ( 'Run Errors' #runErrors #hasErrors ))! ----- Method: TestRunner>>buttonsFrame (in category 'building') ----- buttonsFrame ^LayoutFrame new leftFraction: 0 offset: 0; topFraction: 1 offset: self buttonHeight negated; rightFraction: 1 offset: 0; bottomFraction: 1 offset: 0! ----- Method: TestRunner>>categoriesFrame (in category 'building') ----- categoriesFrame ^LayoutFrame new leftFraction: 0 offset: 0; topFraction: 0 offset: 0; rightFraction: 0.25 offset: 0; bottomFraction: 1 offset: self buttonHeight negated! ----- Method: TestRunner>>categoryAt: (in category 'accessing-categories') ----- categoryAt: anIndex ^ categoriesSelected includes: (categories at: anIndex ifAbsent: [ ^ false ]).! ----- Method: TestRunner>>categoryAt:put: (in category 'accessing-categories') ----- categoryAt: anInteger put: aBoolean categoriesSelected := categoriesSelected perform: (aBoolean ifTrue: [ #copyWith: ] ifFalse: [ #copyWithout: ]) with: (categories at: anInteger ifAbsent: [ ^ self ]). self changed: #categorySelected; updateClasses.! ----- Method: TestRunner>>categoryList (in category 'accessing-categories') ----- categoryList ^ categories! ----- Method: TestRunner>>categoryMenu: (in category 'accessing-categories') ----- categoryMenu: aMenu ^ aMenu title: 'Categories'; add: 'Select all' action: #selectAllCategories; add: 'Select inversion' action: #selectInverseCategories; add: 'Select none' action: #selectNoCategories; addLine; add: 'Filter...' action: #filterCategories; addLine; add: 'Refresh' action: #updateCategories; yourself.! ----- Method: TestRunner>>categorySelected (in category 'accessing-categories') ----- categorySelected ^ 0! ----- Method: TestRunner>>categorySelected: (in category 'accessing-categories') ----- categorySelected: anInteger self changed: #categorySelected.! ----- Method: TestRunner>>classAt: (in category 'accessing-classes') ----- classAt: anInteger ^ classesSelected includes: (classes at: anInteger ifAbsent: [ ^ false ]).! ----- Method: TestRunner>>classAt:put: (in category 'accessing-classes') ----- classAt: anInteger put: aBoolean classesSelected := classesSelected perform: (aBoolean ifTrue: [ #copyWith: ] ifFalse: [ #copyWithout: ]) with: (classes at: anInteger ifAbsent: [ ^ self ]). self changed: #classSelected; changed: #hasRunnable.! ----- Method: TestRunner>>classList (in category 'accessing-classes') ----- classList | offset | classes isEmpty ifTrue: [ ^ classes ]. offset := classes first allSuperclasses size. ^ classes collect: [ :each | | ident | ident := String new: 2 * (0 max: each allSuperclasses size - offset) withAll: $ . each isAbstract ifFalse: [ ident , each name ] ifTrue: [ ident asText , each name asText addAttribute: TextEmphasis italic; yourself ] ].! ----- Method: TestRunner>>classMenu: (in category 'accessing-classes') ----- classMenu: aMenu ^ aMenu title: 'Classes'; add: 'Browse' action: #browseClass; addLine; add: 'Select all' action: #selectAllClasses; add: 'Select subclasses' action: #selectSubclasses; add: 'Select inversion' action: #selectInverseClasses; add: 'Select none' action: #selectNoClasses; addLine; add: 'Filter...' action: #filterClasses; addLine; add: 'Refresh' action: #updateClasses; yourself.! ----- Method: TestRunner>>classSelected (in category 'accessing-classes') ----- classSelected ^ classIndex! ----- Method: TestRunner>>classSelected: (in category 'accessing-classes') ----- classSelected: anInteger classIndex := anInteger. self changed: #classSelected! ----- Method: TestRunner>>classesFrame (in category 'building') ----- classesFrame ^LayoutFrame new leftFraction: 0.25 offset: 0; topFraction: 0 offset: 0; rightFraction: 0.5 offset: 0; bottomFraction: 1 offset: self buttonHeight negated! ----- Method: TestRunner>>classesSelected (in category 'accessing') ----- classesSelected ^ classesSelected! ----- Method: TestRunner>>collectCoverageFor: (in category 'actions') ----- collectCoverageFor: methods | wrappers suite | wrappers := methods collect: [ :each | TestCoverage on: each ]. suite := self reset; suiteAll. [ wrappers do: [ :each | each install ]. [ self runSuite: suite ] ensure: [ wrappers do: [ :each | each uninstall ] ] ] valueUnpreemptively. wrappers := wrappers reject: [ :each | each hasRun ]. wrappers isEmpty ifTrue: [ UIManager default inform: 'Congratulations. Your tests cover all code under analysis.' ] ifFalse: [ ToolSet browseMessageSet: (wrappers collect: [ :each | each reference ]) name: 'Not Covered Code (' , (100 - (100 * wrappers size // methods size)) printString , '% Code Coverage)' autoSelect: nil ]. self saveResultInHistory! ----- Method: TestRunner>>debug: (in category 'actions') ----- debug: aTestCase self debugSuite: (TestSuite new addTest: aTestCase; yourself).! ----- Method: TestRunner>>debugSuite: (in category 'actions') ----- debugSuite: aTestSuite self basicRunSuite: aTestSuite do: [ :each | each debug ].! ----- Method: TestRunner>>defaultBackgroundColor (in category 'private') ----- defaultBackgroundColor "<lint: #expect rule: #overridesSuper rational: 'we want a different color than the parent'>" ^ Preferences testRunnerWindowColor! ----- Method: TestRunner>>errorList (in category 'accessing-testing') ----- errorList ^ errorList collect: [ :each | each printString ].! ----- Method: TestRunner>>errorListFrame (in category 'building') ----- errorListFrame ^LayoutFrame new leftFraction: 0.5 offset: 0; topFraction: 0.5 offset: 0; rightFraction: 1 offset: 0; bottomFraction: 1 offset: self buttonHeight negated! ----- Method: TestRunner>>errorMenu: (in category 'accessing-menu') ----- errorMenu: aMenu ^ self statusMenu: aMenu! ----- Method: TestRunner>>errorSelected (in category 'accessing-testing') ----- errorSelected ^ errorList indexOf: errorSelected.! ----- Method: TestRunner>>errorSelected: (in category 'accessing-testing') ----- errorSelected: anInteger errorSelected := errorList at: anInteger ifAbsent: nil. self changed: #errorSelected. errorSelected ifNotNil: [ self debug: errorSelected ].! ----- Method: TestRunner>>excludeClassesNotUnderTestFrom: (in category 'actions') ----- excludeClassesNotUnderTestFrom: methods classesSelected do: [ :class | (class class includesSelector: #classNamesNotUnderTest) ifTrue: [ class classNamesNotUnderTest do: [ :className | | theClass | theClass := Smalltalk classNamed: className. theClass ifNotNil:[ theClass methods do: [ :each | methods remove: each methodReference ifAbsent: [ ] ]. theClass class methods do: [ :each | methods remove: each methodReference ifAbsent: [ ] ]] ] ] ]! ----- Method: TestRunner>>extent (in category 'accessing-ui') ----- extent ^ 640 @ 480! ----- Method: TestRunner>>failedList (in category 'accessing-testing') ----- failedList ^ failedList collect: [ :each | each printString ].! ----- Method: TestRunner>>failedSelected (in category 'accessing-testing') ----- failedSelected ^ failedList indexOf: failedSelected.! ----- Method: TestRunner>>failedSelected: (in category 'accessing-testing') ----- failedSelected: anInteger failedSelected := failedList at: anInteger ifAbsent: nil. self changed: #failedSelected. failedSelected ifNotNil: [ self debug: failedSelected ].! ----- Method: TestRunner>>failureListFrame (in category 'building') ----- failureListFrame ^LayoutFrame new leftFraction: 0.5 offset: 0; topFraction: 0 offset: self statusHeight; rightFraction: 1 offset: 0; bottomFraction: 0.5 offset: 0! ----- Method: TestRunner>>failureMenu: (in category 'accessing-menu') ----- failureMenu: aMenu ^ aMenu! ----- Method: TestRunner>>filterCategories (in category 'accessing-categories') ----- filterCategories | pattern | pattern := UIManager default request: 'Pattern(s) to select categories:\ (separate patterns with '';'')' withCRs initialAnswer: (categoryPattern ifNil: ['*']). (pattern isNil or: [pattern isEmpty]) ifTrue: [^self]. categoriesSelected := ((categoryPattern := pattern) subStrings: ';') inject: Set new into: [:matches :subPattern| matches addAll: (categories select: [ :each | subPattern match: each]); yourself]. self changed: #allSelections; changed: #categorySelected; updateClasses! ----- Method: TestRunner>>filterClasses (in category 'accessing-classes') ----- filterClasses | pattern | pattern := UIManager default request: 'Pattern(s) to select tests:\ (separate patterns with '';'')' withCRs initialAnswer: (classPattern ifNil: '*'). (pattern isNil or: [pattern isEmpty]) ifTrue: [^self]. classesSelected := ((classPattern := pattern) subStrings: ';') inject: Set new into: [:matches :subPattern| matches addAll: (classes select: [ :each | subPattern match: each name]); yourself]. self changed: #allSelections; changed: #classSelected; changed: #hasRunnable! ----- Method: TestRunner>>findCategories (in category 'utilities') ----- findCategories | visible | visible := Set new. self baseClass withAllSubclassesDo: [ :each | each category ifNotNil: [ :category | visible add: category ] ]. ^ Array streamContents: [ :stream | Smalltalk organization categories do: [ :each | (visible includes: each) ifTrue: [ stream nextPut: each ] ] ].! ----- Method: TestRunner>>findClassesForCategories: (in category 'utilities') ----- findClassesForCategories: aCollection | items | aCollection isEmpty ifTrue: [ ^ self baseClass withAllSubclasses asSet ]. items := aCollection gather: [ :category | ((Smalltalk organization listAtCategoryNamed: category) collect: [ :each | Smalltalk at: each ]) select: [ :each | each includesBehavior: self baseClass ] ]. ^ items asSet.! ----- Method: TestRunner>>hasErrors (in category 'testing') ----- hasErrors ^ result hasErrors.! ----- Method: TestRunner>>hasFailures (in category 'testing') ----- hasFailures ^ result hasFailures.! ----- Method: TestRunner>>hasHistory (in category 'history saving') ----- hasHistory self flag: #Useless. "No Senders?" ^ true! ----- Method: TestRunner>>hasProgress (in category 'history saving') ----- hasProgress result classesTested do: [:cls | (cls class methodDictionary includesKey: #lastStoredRun) ifTrue: [^ true]]. ^ false! ----- Method: TestRunner>>hasResults (in category 'history saving') ----- hasResults ^ result notNil! ----- Method: TestRunner>>hasRunnable (in category 'testing') ----- hasRunnable ^ classesSelected notEmpty.! ----- Method: TestRunner>>historyMenuList (in category 'history saving') ----- historyMenuList ^ {'** save current result **'}, (self previousRun collect: [:ts | ts printString])! ----- Method: TestRunner>>initialize (in category 'initialization') ----- initialize super initialize. failedList := errorList := Array new. SystemChangeNotifier uniqueInstance notify: self ofSystemChangesOfItem: #class change: #Added using: #update; notify: self ofSystemChangesOfItem: #category change: #Added using: #update; notify: self ofSystemChangesOfItem: #class change: #Removed using: #update; notify: self ofSystemChangesOfItem: #category change: #Removed using: #update; notify: self ofSystemChangesOfItem: #class change: #Renamed using: #update; notify: self ofSystemChangesOfItem: #category change: #Renamed using: #update; notify: self ofSystemChangesOfItem: #class change: #Recategorized using: #update; notify: self ofSystemChangesOfItem: #category change: #Recategorized using: #update. self update; reset! ----- Method: TestRunner>>label (in category 'accessing-ui') ----- label ^ 'Test Runner' ! ----- Method: TestRunner>>label:forSuite: (in category 'private') ----- label: aString forSuite: aTestSuite ^ String streamContents: [ :stream | stream nextPutAll: 'Running '; print: aTestSuite tests size; space; nextPutAll: aString. aTestSuite tests size > 1 ifTrue: [ stream nextPut: $s ] ]. ! ----- Method: TestRunner>>perform:orSendTo: (in category 'private') ----- perform: selector orSendTo: otherTarget "<lint: #expect rule: #badMessage rational: 'this is a common morphic pattern'>" ^ (self respondsTo: selector) ifTrue: [ self perform: selector ] ifFalse: [ super perform: selector orSendTo: otherTarget ].! ----- Method: TestRunner>>postAcceptBrowseFor: (in category 'accessing-ui') ----- postAcceptBrowseFor: aModel "Nothing to do."! ----- Method: TestRunner>>previousRun (in category 'history saving') ----- previousRun ^ previousRun ifNil: [ previousRun := OrderedCollection new ]! ----- Method: TestRunner>>promptForPackages (in category 'actions') ----- promptForPackages | packages | packages := (PackageOrganizer default packages reject: [:package | (package packageName beginsWith: 'Kernel') or: [(package packageName beginsWith: 'Collections') or: [(package packageName beginsWith: 'Exceptions') or: [(package packageName beginsWith: 'SUnit') or: [(package packageName beginsWith: 'System') or: [package packageName includesSubstring: 'Test' caseSensitive: false]]]]]]) sort: [:a :b | a packageName < b packageName]. packages := Array with: (UIManager default chooseFrom: (packages collect: [:package | package packageName]) values: packages title: 'Select Package'). ^ packages! ----- Method: TestRunner>>representsSameBrowseeAs: (in category 'accessing-ui') ----- representsSameBrowseeAs: anotherModel ^ self class = anotherModel class and: [ classesSelected = anotherModel classesSelected ]! ----- Method: TestRunner>>reset (in category 'actions') ----- reset self result: TestResult new; updateResults.! ----- Method: TestRunner>>result (in category 'accessing-testing') ----- result ^ result! ----- Method: TestRunner>>result: (in category 'accessing-testing') ----- result: aResult result := aResult! ----- Method: TestRunner>>runAll (in category 'actions') ----- runAll self reset; runSuite: self suiteAll. self saveResultInHistory! ----- Method: TestRunner>>runCoverage (in category 'actions') ----- runCoverage | packages methods | packages := Set new. self addDeclaredPackagesUnderTestTo: packages. packages isEmpty ifTrue: [ packages := self promptForPackages ]. methods := OrderedCollection new. self addMethodsUnderTestIn: packages to: methods. self excludeClassesNotUnderTestFrom: methods. methods isEmpty ifTrue: [ ^ UIManager default inform: 'No methods found for coverage analysis.' ]. self collectCoverageFor: methods ! ----- Method: TestRunner>>runErrors (in category 'actions') ----- runErrors self result instVarNamed: 'errors' put: OrderedCollection new. self runSuite: self suiteErrors.! ----- Method: TestRunner>>runFailures (in category 'actions') ----- runFailures self result instVarNamed: 'failures' put: Set new. self runSuite: self suiteFailures.! ----- Method: TestRunner>>runProfiled (in category 'actions') ----- runProfiled MessageTally spyOn: [ self runAll ].! ----- Method: TestRunner>>runSuite: (in category 'actions') ----- runSuite: aTestSuite self basicRunSuite: aTestSuite do: [ :each | self runTest: each ]. self updateResults ! ----- Method: TestRunner>>runTest: (in category 'actions') ----- runTest: aTestCase aTestCase run: result. self updateStatus: true.! ----- Method: TestRunner>>saveResultInHistory (in category 'history saving') ----- saveResultInHistory result dispatchResultsIntoHistory! ----- Method: TestRunner>>selectAllCategories (in category 'accessing-categories') ----- selectAllCategories categoriesSelected := categories asSet. self changed: #allSelections; changed: #categorySelected; updateClasses! ----- Method: TestRunner>>selectAllClasses (in category 'accessing-classes') ----- selectAllClasses "Fixed to update all selections now that the selection invalidation has been optimised." classesSelected := classes asSet. self changed: #allSelections; changed: #classSelected; changed: #hasRunnable! ----- Method: TestRunner>>selectInverseCategories (in category 'accessing-categories') ----- selectInverseCategories categoriesSelected := categories asSet removeAll: categoriesSelected; yourself. self changed: #allSelections; changed: #categorySelected; updateClasses! ----- Method: TestRunner>>selectInverseClasses (in category 'accessing-classes') ----- selectInverseClasses "Fixed to update all selections now that the selection invalidation has been optimised." classesSelected := classes asSet removeAll: classesSelected; yourself. self changed: #allSelections; changed: #classSelected; changed: #hasRunnable! ----- Method: TestRunner>>selectNoCategories (in category 'accessing-categories') ----- selectNoCategories categoriesSelected := Set new. self changed: #allSelections; changed: #categorySelected; updateClasses! ----- Method: TestRunner>>selectNoClasses (in category 'accessing-classes') ----- selectNoClasses "Fixed to update all selections now that the selection invalidation has been optimised." classesSelected := Set new. self changed: #allSelections; changed: #classSelected; changed: #hasRunnable! ----- Method: TestRunner>>selectSubclasses (in category 'accessing-classes') ----- selectSubclasses "Fixed to update all selections now that the selection invalidation has been optimised." | classesForPackages | classesForPackages := self findClassesForCategories: categoriesSelected. classesSelected := (classesSelected gather: [ :class | class withAllSubclasses select: [ :each | classesForPackages includes: each ] ]) asSet. self changed: #allSelections; changed: #classSelected; changed: #hasRunnable! ----- Method: TestRunner>>showDiffWith: (in category 'history saving') ----- showDiffWith: aTestResult | string diff | diff := result diff: aTestResult. string := String streamContents: [:str| str nextPutAll: '----------------'; cr. str nextPutAll: 'Diff between current result with: ', aTestResult asString; cr. str nextPutAll: 'New passed: '. diff first do: [:s| str nextPutAll: s printString, ' ']. str cr. str nextPutAll: 'New failures: '. diff second do: [:s| str nextPutAll: s printString, ' ']. str cr. str nextPutAll: 'New errors: '. diff third do: [:s| str nextPutAll: s printString, ' ']. str cr]. Workspace new contents: string; openLabel: 'SUnit Progress' ! ----- Method: TestRunner>>showHistoryMenu (in category 'history saving') ----- showHistoryMenu | selectionIndex selectedPreviousResult actionIndex | selectionIndex := UIManager default chooseFrom: self historyMenuList title: 'History:'. "We pressed outside the menu" selectionIndex isZero ifTrue: [ ^ self ]. "save current result is selected" selectionIndex = 1 ifTrue: [ self previousRun addFirst: result. ^ self ]. selectedPreviousResult := self previousRun at: (selectionIndex - 1). actionIndex := (UIManager default chooseFrom: #('delete' 'show diff') title: 'Action:'). actionIndex = 1 ifTrue: [ self previousRun remove: selectedPreviousResult. ^ self ]. actionIndex = 2 ifTrue: [ self showDiffWith: selectedPreviousResult]. ! ----- Method: TestRunner>>showProgress (in category 'history saving') ----- showProgress | testCaseClasses d string | testCaseClasses := (self suiteAll tests collect: [:testCase | testCase class]) asSet. "At the end of the algorithm, d will contains all the diff between what was saved and the current result" d := Dictionary new. d at: #passed put: OrderedCollection new. d at: #failures put: OrderedCollection new. d at: #errors put: OrderedCollection new. testCaseClasses do: [ :cls | | t | (cls class methodDict includesKey: #lastStoredRun) ifTrue: [t := cls lastStoredRun. (t at: #passed) do: [:s | (result isErrorFor: cls selector: s) ifTrue: [(d at: #errors) add: {cls . s}]. (result isFailureFor: cls selector: s) ifTrue: [(d at: #failures) add: {cls . s}] ]. (t at: #failures) do: [:s | (result isPassedFor: cls selector: s) ifTrue: [(d at: #passed) add: {cls . s}]. (result isErrorFor: cls selector: s) ifTrue: [(d at: #errors) add: {cls . s}]]. (t at: #errors) do: [:s | (result isPassedFor: cls selector: s) ifTrue: [(d at: #passed) add: {cls . s}]. (result isFailureFor: cls selector: s) ifTrue: [(d at: #failures) add: {cls . s}]]]]. string := String streamContents: [:str| str nextPutAll: '----------------'; cr. str nextPutAll: 'Diff between current result and saved result'; cr. str nextPutAll: 'New passed: '. (d at: #passed) do: [:s| str nextPutAll: s printString, ' ']. str cr. str nextPutAll: 'New failures: '. (d at: #failures) do: [:s| str nextPutAll: s printString, ' ']. str cr. str nextPutAll: 'New errors: '. (d at: #errors) do: [:s| str nextPutAll: s printString, ' ']. str cr]. Workspace new contents: string; openLabel: 'SUnit Progress' string. ! ----- Method: TestRunner>>sortClass:before: (in category 'utilities') ----- sortClass: aFirstClass before: aSecondClass | first second | first := aFirstClass withAllSuperclasses reversed. second := aSecondClass withAllSuperclasses reversed. 1 to: (first size min: second size) do: [ :index | (first at: index) == (second at: index) ifFalse: [ ^ (first at: index) name <= (second at: index) name ] ]. ^ second includes: aFirstClass.! ----- Method: TestRunner>>statusColor (in category 'accessing-testing') ----- statusColor result hasErrors ifTrue: [ ^ Color red ]. result hasFailures ifTrue:[ ^ Color yellow ]. ^ Color green! ----- Method: TestRunner>>statusFrame (in category 'building') ----- statusFrame ^LayoutFrame new leftFraction: 0.5 offset: 0; topFraction: 0 offset: 0; rightFraction: 1 offset: 0; bottomFraction: 0 offset: self statusHeight! ----- Method: TestRunner>>statusHeight (in category 'building') ----- statusHeight ^Preferences standardCodeFont height * 2 + 12! ----- Method: TestRunner>>statusMenu: (in category 'accessing-menu') ----- statusMenu: aMenu ^ aMenu add: 'History' action: #showHistoryMenu; add: 'Store result as progress reference' action: #storeResultIntoTestCases; add: 'Show progress' action: #showProgress; yourself! ----- Method: TestRunner>>statusText (in category 'accessing-testing') ----- statusText ^ result printString.! ----- Method: TestRunner>>storeResultIntoTestCases (in category 'history saving') ----- storeResultIntoTestCases result classesTested do: [:testCaseCls | testCaseCls generateLastStoredRunMethod ] ! ----- Method: TestRunner>>suiteAll (in category 'accessing') ----- suiteAll ^ TestSuite new in: [ :suite | classesSelected do: [ :each | each isAbstract ifFalse: [ each addToSuiteFromSelectors: suite ] ]. suite name: (self label: 'Test' forSuite: suite) ].! ----- Method: TestRunner>>suiteErrors (in category 'accessing') ----- suiteErrors ^ TestSuite new in: [ :suite | suite addTests: errorList; name: (self label: 'Error' forSuite: suite) ].! ----- Method: TestRunner>>suiteFailures (in category 'accessing') ----- suiteFailures ^ TestSuite new in: [ :suite | suite addTests: failedList; name: (self label: 'Failure' forSuite: suite) ].! ----- Method: TestRunner>>update (in category 'updating') ----- update self updateCategories; updateClasses! ----- Method: TestRunner>>updateCategories (in category 'updating') ----- updateCategories categories := self findCategories. categoriesSelected := categoriesSelected isNil ifTrue: [ Set new ] ifFalse: [ categoriesSelected select: [ :each | categories includes: each ] ]. self changed: #categoryList; changed: #categorySelected.! ----- Method: TestRunner>>updateClasses (in category 'updating') ----- updateClasses | classesForCategories | classesForCategories := self findClassesForCategories: categoriesSelected. classes := classesForCategories asArray sort: [ :a :b | self sortClass: a before: b ]. classIndex := 0. classesSelected := classesSelected isNil ifTrue: [ classesForCategories ] ifFalse: [ classesSelected select: [ :each | classesForCategories includes: each ] ]. self changed: #classList; changed: #classSelected; changed: #hasRunnable.! ----- Method: TestRunner>>updateResults (in category 'updating') ----- updateResults "<lint: #expect rule: #guardingClause>" "<lint: #expect rule: #longMethods>" self updateStatus: false. failedList size = result failures size ifFalse: [ failedList := result failures asArray sort: [ :a :b | a printString <= b printString ]. failedSelected := nil. self changed: #failedList; changed: #failedSelected; changed: #hasFailures; changed: #hasProgress ]. errorList size = result errors size ifFalse: [ errorList := result errors asArray sort: [ :a :b | a printString <= b printString ]. errorSelected := nil. self changed: #errorList; changed: #errorSelected; changed: #hasErrors; changed: #hasProgress ].! ----- Method: TestRunner>>updateStatus: (in category 'updating') ----- updateStatus: aBoolean "Update the status display, at most once a second if aBoolean is true." (aBoolean and: [ lastUpdate = Time totalSeconds ]) ifTrue: [ ^ self ]. self changed: #statusText; changed: #statusColor. lastUpdate := Time totalSeconds.! ----- Method: TestRunner>>windowIsClosing (in category 'private') ----- windowIsClosing SystemChangeNotifier uniqueInstance noMoreNotificationsFor: self!

1 0

Squeak 4.6: BalloonTests-egp.2.mcz
by commits＠source.squeak.org 05 Jun '15

05 Jun '15

Chris Muller uploaded a new version of BalloonTests to project Squeak 4.6: http://source.squeak.org/squeak46/BalloonTests-egp.2.mcz ==================== Summary ==================== Name: BalloonTests-egp.2 Author: egp Time: 6 March 2011, 3:52:10.157 pm UUID: a8206c39-12ee-4222-a29a-caa537e037c4 Ancestors: BalloonTests-egp.1 Test of the GradientFillStyle LRUCache false hits bug. ==================== Snapshot ==================== SystemOrganization addCategory: #'BalloonTests-Fills'! ClassTestCase subclass: #GradientFillStyleTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'BalloonTests-Fills'! !GradientFillStyleTest commentStamp: 'egp 3/6/2011 15:10' prior: 0! This tests the LRUCache operation.! ----- Method: GradientFillStyleTest>>testLRUCacheHits (in category 'tests') ----- testLRUCacheHits | gradient greenWhiteRamp redWhiteRamp | "This test proves the bug fix where modifing the LRUCache key resulted in false cache hits. The affect was that a gradient could not be modifed from the user interface." GradientFillStyle cleanUp. gradient := GradientFillStyle new colorRamp: {0.0->Color red. 1.0->Color white}. redWhiteRamp := gradient pixelRamp. "Change the first color in colorRamp" gradient firstColor: Color green forMorph: nil hand: nil. greenWhiteRamp := gradient pixelRamp. "Ensure the pixelRamp has changed" self assert: (redWhiteRamp ~= greenWhiteRamp).!

1 0

Squeak 4.6: SqueakSSL-SMTP-ar.1.mcz
by commits＠source.squeak.org 05 Jun '15

05 Jun '15

Chris Muller uploaded a new version of SqueakSSL-SMTP to project Squeak 4.6: http://source.squeak.org/squeak46/SqueakSSL-SMTP-ar.1.mcz ==================== Summary ==================== Name: SqueakSSL-SMTP-ar.1 Author: ar Time: 27 November 2011, 11:40:06.998 am UUID: e091f7d9-2e75-f547-94e7-043537eb417e Ancestors: SecureSMTPClient for sending email via SSL. ==================== Snapshot ==================== SystemOrganization addCategory: #'SqueakSSL-SMTP'! SMTPClient subclass: #SecureSMTPClient instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'SqueakSSL-SMTP'! ----- Method: SecureSMTPClient class>>exampleGMailFrom:to:password: (in category 'example') ----- exampleGMailFrom: gmailAddress to: rcvrAddress password: pw "Sends email via secure smtp through GMail" | message smtpClient | smtpClient := self new. smtpClient user: gmailAddress. smtpClient password: pw. smtpClient openOnHost: (NetNameResolver addressForName: 'smtp.gmail.com') port: 465. message := MailMessage empty. message setField: 'from' toString: gmailAddress. message setField: 'to' toString: rcvrAddress. message setField: 'subject' toString: 'Hello World'. message body: (MIMEDocument contentType: 'text/plain' content: 'bla bla bla'). smtpClient mailFrom: gmailAddress to: {rcvrAddress} text: message text. smtpClient quit. ! ----- Method: SecureSMTPClient>>ensureConnection (in category 'private') ----- ensureConnection self isConnected ifTrue: [^self]. self stream ifNotNil: [self stream close]. self stream: (SecureSocketStream openConnectionToHost: self host port: self port timeout: self standardTimeout). self stream sslConnect. self checkResponse. self login!

1 0

Squeak 4.6: XML-Parser-bf.37.mcz
by commits＠source.squeak.org 05 Jun '15

05 Jun '15

Chris Muller uploaded a new version of XML-Parser to project Squeak 4.6: http://source.squeak.org/squeak46/XML-Parser-bf.37.mcz ==================== Summary ==================== Name: XML-Parser-bf.37 Author: bf Time: 8 December 2014, 2:16:57.135 am UUID: 47f3a2f8-de17-43b8-96f8-beef7a7c8200 Ancestors: XML-Parser-fbs.36 Restore timestamps lost in assignment conversion. ==================== Snapshot ==================== SystemOrganization addCategory: #'XML-Parser'! ----- Method: String>>applyLanguageInfomation: (in category '*xml-parser') ----- applyLanguageInfomation: languageEnvironment | leadingChar | leadingChar := languageEnvironment leadingChar. self withIndexDo: [:each :idx | each asciiValue > 255 ifTrue: [self at: idx put: (Character leadingChar: leadingChar code: each asUnicode)]]! Error subclass: #SAXException instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'XML-Parser'! SAXException subclass: #SAXMalformedException instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'XML-Parser'! SAXException subclass: #SAXParseException instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'XML-Parser'! Error subclass: #XMLException instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'XML-Parser'! XMLException subclass: #XMLInvalidException instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'XML-Parser'! XMLException subclass: #XMLMalformedException instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'XML-Parser'! XMLException subclass: #XMLWarningException instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'XML-Parser'! Object subclass: #DTDEntityDeclaration instanceVariableNames: 'name value ndata' classVariableNames: '' poolDictionaries: '' category: 'XML-Parser'! DTDEntityDeclaration class instanceVariableNames: 'contextBehavior'! DTDEntityDeclaration class instanceVariableNames: 'contextBehavior'! ----- Method: DTDEntityDeclaration class>>behaviorForContext: (in category 'accessing') ----- behaviorForContext: aContext ^self contextBehavior at: aContext! ----- Method: DTDEntityDeclaration class>>contextBehavior (in category 'accessing') ----- contextBehavior ^contextBehavior! ----- Method: DTDEntityDeclaration class>>initialize (in category 'class initialization') ----- initialize "DTDEntityDeclaration initialize" contextBehavior := Dictionary new. contextBehavior at: #content put: #include ; at: #attributeValueContent put: #includedInLiteral ; at: #attributeValue put: #forbidden ; at: #entityValue put: #bypass ; at: #dtd put: #forbidden ! ----- Method: DTDEntityDeclaration class>>leadIn (in category 'accessing') ----- leadIn ^'&'! ----- Method: DTDEntityDeclaration class>>name:value: (in category 'instance creation') ----- name: aString value: aValueString ^self new name: aString; value: aValueString! ----- Method: DTDEntityDeclaration>>bypass (in category 'behaviors') ----- bypass "Return my reference as is." ^self reference! ----- Method: DTDEntityDeclaration>>forbidden (in category 'behaviors') ----- forbidden self error: 'Forbidden reference usage'! ----- Method: DTDEntityDeclaration>>include (in category 'behaviors') ----- include "Return my expanded value." ^value ifNil: [SAXWarning signal: 'XML undefined entity ' , name printString]! ----- Method: DTDEntityDeclaration>>includedInLiteral (in category 'behaviors') ----- includedInLiteral "Return my expanded value." ^self include! ----- Method: DTDEntityDeclaration>>name (in category 'accessing') ----- name ^name! ----- Method: DTDEntityDeclaration>>name: (in category 'accessing') ----- name: aString name := aString asSymbol! ----- Method: DTDEntityDeclaration>>ndata (in category 'accessing') ----- ndata ^ndata! ----- Method: DTDEntityDeclaration>>ndata: (in category 'accessing') ----- ndata: aString ndata := aString! ----- Method: DTDEntityDeclaration>>reference (in category 'behaviors') ----- reference "Return my reference as is." ^self class leadIn , self name , ';'! ----- Method: DTDEntityDeclaration>>registerIn: (in category 'invocation') ----- registerIn: aParser aParser entity: self name put: self! ----- Method: DTDEntityDeclaration>>value (in category 'accessing') ----- value ^value! ----- Method: DTDEntityDeclaration>>value: (in category 'accessing') ----- value: aString value := aString! ----- Method: DTDEntityDeclaration>>valueForContext: (in category 'invocation') ----- valueForContext: aContext ^self perform: (self class behaviorForContext: aContext)! DTDEntityDeclaration subclass: #DTDExternalEntityDeclaration instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'XML-Parser'! ----- Method: DTDExternalEntityDeclaration class>>initialize (in category 'class initialization') ----- initialize "DTDExternalEntityDeclaration initialize" contextBehavior := Dictionary new. contextBehavior at: #content put: #include ; at: #attributeValueContent put: #includedInLiteral ; at: #attributeValue put: #forbidden ; at: #entityValue put: #bypass ; at: #dtd put: #forbidden ! DTDEntityDeclaration subclass: #DTDParameterEntityDeclaration instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'XML-Parser'! ----- Method: DTDParameterEntityDeclaration class>>initialize (in category 'class initialization') ----- initialize "DTDParameterEntityDeclaration initialize" contextBehavior := Dictionary new. contextBehavior at: #content put: #notRecognized: ; at: #attributeValueContent put: #notRecognized: ; at: #attributeValue put: #notRecognized: ; at: #entityValue put: #include: ; at: #dtd put: #includePE:! ----- Method: DTDParameterEntityDeclaration class>>leadIn (in category 'accessing') ----- leadIn ^'%'! ----- Method: DTDParameterEntityDeclaration>>includePE (in category 'behaviors') ----- includePE "Return my expanded value." ^self include! ----- Method: DTDParameterEntityDeclaration>>notRecognized (in category 'behaviors') ----- notRecognized SAXMalformedException signal: 'Malformed entity.'! ----- Method: DTDParameterEntityDeclaration>>registerIn: (in category 'invocation') ----- registerIn: aParser aParser parameterEntity: self name put: self! Object subclass: #SAXHandler instanceVariableNames: 'document driver eod' classVariableNames: '' poolDictionaries: '' category: 'XML-Parser'! ----- Method: SAXHandler class>>on: (in category 'instance creation') ----- on: aStream | driver parser | driver := SAXDriver on: aStream. driver validating: true. parser := self new driver: driver. ^parser! ----- Method: SAXHandler class>>parseDTDFrom: (in category 'instance creation') ----- parseDTDFrom: aStream | driver parser | driver := SAXDriver on: aStream. driver validating: true. driver startParsingMarkup. parser := self new driver: driver. parser startDocument. parser parseDocument. ^parser! ----- Method: SAXHandler class>>parseDocumentFrom: (in category 'instance creation') ----- parseDocumentFrom: aStream ^self parseDocumentFrom: aStream useNamespaces: false! ----- Method: SAXHandler class>>parseDocumentFrom:useNamespaces: (in category 'instance creation') ----- parseDocumentFrom: aStream useNamespaces: aBoolean | parser | parser := self on: aStream. parser useNamespaces: aBoolean. parser startDocument. parser parseDocument. ^parser! ----- Method: SAXHandler class>>parseDocumentFromFileNamed: (in category 'instance creation') ----- parseDocumentFromFileNamed: fileName ^self parseDocumentFromFileNamed: fileName readIntoMemory: false! ----- Method: SAXHandler class>>parseDocumentFromFileNamed:readIntoMemory: (in category 'instance creation') ----- parseDocumentFromFileNamed: fileName readIntoMemory: readIntoMemory | stream xmlDoc | stream := FileDirectory default readOnlyFileNamed: fileName. readIntoMemory ifTrue: [stream := stream contentsOfEntireFile readStream]. xmlDoc := [self parseDocumentFrom: stream] ensure: [stream close]. ^xmlDoc! ----- Method: SAXHandler class>>parserOnFileNamed: (in category 'instance creation') ----- parserOnFileNamed: fileName ^self parserOnFileNamed: fileName readIntoMemory: false! ----- Method: SAXHandler class>>parserOnFileNamed:readIntoMemory: (in category 'instance creation') ----- parserOnFileNamed: fileName readIntoMemory: readIntoMemory | stream | stream := FileDirectory default readOnlyFileNamed: fileName. readIntoMemory ifTrue: [stream := stream contentsOfEntireFile readStream]. ^self on: stream! ----- Method: SAXHandler>>characters: (in category 'content') ----- characters: aString "This call corresponds to the Java SAX call characters(char[] ch, int start, int length)."! ----- Method: SAXHandler>>checkEOD (in category 'content') ----- checkEOD "Check if the document shouldn't be ended already" self eod ifTrue: [self driver errorExpected: 'No more data expected,']! ----- Method: SAXHandler>>comment: (in category 'lexical') ----- comment: commentString "This call corresponds to the Java SAX ext call comment(char[] ch, int start, int length)."! ----- Method: SAXHandler>>document (in category 'accessing') ----- document ^document! ----- Method: SAXHandler>>document: (in category 'accessing') ----- document: aDocument document := aDocument! ----- Method: SAXHandler>>documentAttributes: (in category 'content') ----- documentAttributes: attributeList! ----- Method: SAXHandler>>driver (in category 'accessing') ----- driver ^driver! ----- Method: SAXHandler>>driver: (in category 'accessing') ----- driver: aDriver driver := aDriver. driver saxHandler: self! ----- Method: SAXHandler>>endDocument (in category 'content') ----- endDocument "This call corresponds to the Java SAX call endDocument()." eod := true! ----- Method: SAXHandler>>endElement: (in category 'content') ----- endElement: elementName ! ----- Method: SAXHandler>>endElement:namespace:namespaceURI:qualifiedName: (in category 'content') ----- endElement: elementName namespace: namespace namespaceURI: namespaceURI qualifiedName: qualifiedName "This call corresponds to the Java SAX call endElement(java.lang.String namespaceURI, java.lang.String localName, java.lang.String qName). By default this call is mapped to the following more convenient call:" self endElement: elementName! ----- Method: SAXHandler>>endEntity: (in category 'lexical') ----- endEntity: entityName "This call corresponds to the Java SAX ext call endEntity(java.lang.String name)."! ----- Method: SAXHandler>>endPrefixMapping: (in category 'content') ----- endPrefixMapping: prefix "This call corresonds to the Java SAX call endPrefixMapping(java.lang.String prefix)."! ----- Method: SAXHandler>>eod (in category 'accessing') ----- eod ^eod! ----- Method: SAXHandler>>ignorableWhitespace: (in category 'content') ----- ignorableWhitespace: aString "This call corresonds to the Java SAX call ignorableWhitespace(char[] ch, int start, int length)."! ----- Method: SAXHandler>>initialize (in category 'initialize') ----- initialize eod := false! ----- Method: SAXHandler>>parseDocument (in category 'parsing') ----- parseDocument [self driver nextEntity isNil or: [self eod]] whileFalse! ----- Method: SAXHandler>>processingInstruction:data: (in category 'content') ----- processingInstruction: piName data: dataString "This call corresonds to the Java SAX call processingInstruction(java.lang.String target, java.lang.String data)."! ----- Method: SAXHandler>>resolveEntity:systemID: (in category 'entity') ----- resolveEntity: publicID systemID: systemID "This call corresonds to the Java SAX call resolveEntity(java.lang.String publicId, java.lang.String systemId)."! ----- Method: SAXHandler>>skippedEntity: (in category 'content') ----- skippedEntity: aString "This call corresonds to the Java SAX call skippedEntity(java.lang.String name)."! ----- Method: SAXHandler>>startCData (in category 'lexical') ----- startCData "This call corresponds to the Java SAX ext call startCData()."! ----- Method: SAXHandler>>startDTD:publicID:systemID: (in category 'lexical') ----- startDTD: declName publicID: publicID systemID: systemID "This call corresponds to the Java SAX ext call startDTD(java.lang.String name, java.lang.String publicId, java.lang.String systemId)."! ----- Method: SAXHandler>>startDocument (in category 'content') ----- startDocument "This call corresonds to the Java SAX call startDocument()."! ----- Method: SAXHandler>>startElement:attributeList: (in category 'content') ----- startElement: elementName attributeList: attributeList ! ----- Method: SAXHandler>>startElement:namespaceURI:namespace:attributeList: (in category 'content') ----- startElement: localName namespaceURI: namespaceUri namespace: namespace attributeList: attributeList "This call corresonds to the Java SAX call startElement(java.lang.String namespaceURI, java.lang.String localName, java.lang.String qName, Attributes atts). By default this call is mapped to the following more convenient call:" self startElement: localName attributeList: attributeList! ----- Method: SAXHandler>>startEntity: (in category 'lexical') ----- startEntity: entityName "This call corresponds to the Java SAX ext call startEntity(java.lang.String name)."! ----- Method: SAXHandler>>startPrefixMapping:uri: (in category 'content') ----- startPrefixMapping: prefix uri: uri "This call corresonds to the Java SAX call startPrefixMapping(java.lang.String prefix, java.lang.String uri)."! ----- Method: SAXHandler>>useNamespaces: (in category 'accessing') ----- useNamespaces: aBoolean self driver useNamespaces: aBoolean! SAXHandler subclass: #XMLDOMParser instanceVariableNames: 'entity stack incremental' classVariableNames: '' poolDictionaries: '' category: 'XML-Parser'! ----- Method: XMLDOMParser class>>addressBookXMLWithDTD (in category 'examples') ----- addressBookXMLWithDTD "XMLDOMParser addressBookXMLWithDTD" ^self parseDocumentFrom: XMLTokenizer addressBookXMLWithDTD readStream useNamespaces: true! ----- Method: XMLDOMParser class>>parseDocumentFrom: (in category 'instance creation') ----- parseDocumentFrom: aStream ^self parseDocumentFrom: aStream useNamespaces: false! ----- Method: XMLDOMParser class>>parseDocumentFrom:useNamespaces: (in category 'instance creation') ----- parseDocumentFrom: aStream useNamespaces: aBoolean ^(super parseDocumentFrom: aStream useNamespaces: aBoolean) document! ----- Method: XMLDOMParser>>characters: (in category 'content') ----- characters: aString | newElement | newElement := XMLStringNode string: aString. self top addContent: newElement. ! ----- Method: XMLDOMParser>>defaultNamespace (in category 'private') ----- defaultNamespace ^self top ifNotNil: [self top namespace]! ----- Method: XMLDOMParser>>documentAttributes: (in category 'content') ----- documentAttributes: attributeList self document version: (attributeList at: 'version' ifAbsent: [nil]). self document encoding: (attributeList at: 'encoding' ifAbsent: [nil]). self document requiredMarkup: (attributeList at: 'requiredMarkup' ifAbsent: [nil]). ! ----- Method: XMLDOMParser>>domDocument (in category 'parsing') ----- domDocument [self startDocument; parseDocument] ensure: [self driver stream close]. ^document! ----- Method: XMLDOMParser>>endDocument (in category 'content') ----- endDocument self pop. super endDocument! ----- Method: XMLDOMParser>>endElement: (in category 'content') ----- endElement: elementName | currentElement | currentElement := self pop. currentElement name = elementName ifFalse: [self driver errorExpected: 'End tag "', elementName , '" doesn''t match "' , currentElement name , '".']! ----- Method: XMLDOMParser>>endElement:namespace:namespaceURI:qualifiedName: (in category 'content') ----- endElement: localName namespace: namespace namespaceURI: uri qualifiedName: qualifiedName | currentElement | currentElement := self pop. (currentElement namespace isNil or: [currentElement namespace = self defaultNamespace]) ifTrue: [ currentElement localName = localName ifFalse: [self driver errorExpected: 'End tag "', localName , '" doesn''t match "' , currentElement localName , '".']] ifFalse: [ currentElement qualifiedName = qualifiedName ifFalse: [self driver errorExpected: 'End tag "', qualifiedName , '" doesn''t match "' , currentElement qualifiedName , '".']]! ----- Method: XMLDOMParser>>incremental (in category 'accessing') ----- incremental ^incremental! ----- Method: XMLDOMParser>>incremental: (in category 'accessing') ----- incremental: aBoolean incremental := aBoolean! ----- Method: XMLDOMParser>>initialize (in category 'initialize') ----- initialize super initialize. stack := OrderedCollection new. incremental := false! ----- Method: XMLDOMParser>>nextEntity (in category 'parsing') ----- nextEntity | currentTop | currentTop := self top. [self driver nextEntity isNil or: [self top ~~ currentTop]] whileTrue. ^entity! ----- Method: XMLDOMParser>>nextEntityStart (in category 'parsing') ----- nextEntityStart [self driver nextEntity. self stack isEmpty] whileTrue. ^entity! ----- Method: XMLDOMParser>>pop (in category 'private') ----- pop | oldTop | oldTop := self stack removeLast. entity := oldTop. ^oldTop! ----- Method: XMLDOMParser>>processingInstruction:data: (in category 'content') ----- processingInstruction: piName data: dataString | newElement | newElement := XMLPI target: piName data: dataString. self top addElement: newElement! ----- Method: XMLDOMParser>>push: (in category 'private') ----- push: anObject self stack add: anObject. entity := anObject ! ----- Method: XMLDOMParser>>stack (in category 'private') ----- stack ^stack! ----- Method: XMLDOMParser>>startDocument (in category 'content') ----- startDocument self document: XMLDocument new. self push: self document ! ----- Method: XMLDOMParser>>startElement:attributeList: (in category 'content') ----- startElement: elementName attributeList: attributeList | newElement | newElement := XMLElement named: elementName attributes: attributeList. self incremental ifFalse: [self stack isEmpty ifFalse: [self top addElement: newElement]]. self push: newElement! ----- Method: XMLDOMParser>>startElement:namespaceURI:namespace:attributeList: (in category 'content') ----- startElement: localName namespaceURI: namespaceUri namespace: namespace attributeList: attributeList | newElement | "newElement := namespace = self defaultNamespace ifTrue: [XMLElement named: localName namespace: nil uri: nil attributes: attributeList] ifFalse: [XMLElement named: localName namespace: namespace uri: namespaceUri attributes: attributeList]." newElement := XMLElement named: localName namespace: namespace uri: namespaceUri attributes: attributeList. self incremental ifFalse: [self stack isEmpty ifFalse: [self top addElement: newElement]]. self push: newElement! ----- Method: XMLDOMParser>>top (in category 'private') ----- top ^self stack isEmpty ifTrue: [nil] ifFalse: [self stack last]! Object subclass: #XMLNamespaceScope instanceVariableNames: 'scope currentBindings useNamespaces validateAttributes' classVariableNames: '' poolDictionaries: '' category: 'XML-Parser'! ----- Method: XMLNamespaceScope>>currentScope (in category 'private') ----- currentScope ^self scope last! ----- Method: XMLNamespaceScope>>declareNamespace:uri: (in category 'scope') ----- declareNamespace: ns uri: uri "Declare the given name space prefix with the given URL" ns = 'xmlns' ifTrue: [^self defaultNamespace: uri]. self establishLocalBindings. currentBindings removeKey: ns ifAbsent: []. currentBindings at: ns put: uri! ----- Method: XMLNamespaceScope>>defaultNamespace (in category 'accessing') ----- defaultNamespace ^self currentScope first! ----- Method: XMLNamespaceScope>>defaultNamespace: (in category 'accessing') ----- defaultNamespace: ns "Declare the default namespace." self currentScope at: 1 put: ns! ----- Method: XMLNamespaceScope>>enterScope (in category 'scope') ----- enterScope self scope addLast: { self defaultNamespace. nil. currentBindings. }! ----- Method: XMLNamespaceScope>>establishLocalBindings (in category 'private') ----- establishLocalBindings (self currentScope at: 2) ifNil: [ currentBindings := currentBindings copy. self currentScope at: 2 put: currentBindings]! ----- Method: XMLNamespaceScope>>initScope (in category 'private') ----- initScope scope := OrderedCollection new: 20. currentBindings := Dictionary new. scope addLast: {'http://www.w3.org/TR/REC-xml-names'. currentBindings. nil. }. ! ----- Method: XMLNamespaceScope>>leaveScope (in category 'scope') ----- leaveScope | leftScope | leftScope := self scope removeLast. currentBindings := (self currentScope at: 2) ifNil: [leftScope at: 3]! ----- Method: XMLNamespaceScope>>namespaceAliases: (in category 'private') ----- namespaceAliases: namespace "Locate all namespaces that are aliases of the given URI." | aliases uri | aliases := Set new. uri := self namespaceURIOf: namespace ifAbsent: [self parseError: 'Attribute refers to undefined namespace ' , namespace asString ]. currentBindings keysAndValuesDo: [:ns :u | (u = uri and: [ns ~= namespace]) ifTrue: [aliases add: ns]]. ^ aliases! ----- Method: XMLNamespaceScope>>namespaceURIOf: (in category 'accessing') ----- namespaceURIOf: ns "Retrieve the URI of the given namespace prefix, if it is defined. A nil namespace returns the global namespace" ^ self namespaceURIOf: ns ifAbsent: [ nil ]! ----- Method: XMLNamespaceScope>>namespaceURIOf:ifAbsent: (in category 'accessing') ----- namespaceURIOf: ns ifAbsent: aBlock "Retrieve the URI of the given namespace prefix, if it is defined. A nil namespace returns the default namespace. If no namespace can be found the value of the block is returned" ^ns ifNil: [self defaultNamespace] ifNotNil: [currentBindings at: ns ifAbsent: aBlock]! ----- Method: XMLNamespaceScope>>namespaces (in category 'accessing') ----- namespaces ^currentBindings! ----- Method: XMLNamespaceScope>>scope (in category 'private') ----- scope scope ifNil: [self initScope]. ^scope! ----- Method: XMLNamespaceScope>>validateAttributes: (in category 'validation') ----- validateAttributes: attributeList "check all attribute namespaces are defined and not duplicated by aliasing" attributeList keysDo: [:attrName | | namespace localName | self splitName: attrName into: [:ns :ln | namespace := ns. localName := ln]. namespace ifNotNil: [ (self namespaceAliases: namespace) do: [:alias | (attributeList includesKey: alias , ':' , localName) ifTrue: [self parseError: 'Attributes ' , attrName , ' and ' , alias , ':' , localName , ' are aliased to namespace ' , (self namespaceURIOf: namespace) ]]]]! Object subclass: #XMLNode instanceVariableNames: '' classVariableNames: 'CanonicalTable' poolDictionaries: '' category: 'XML-Parser'! ----- Method: XMLNode>>addContent: (in category 'accessing') ----- addContent: contentString SAXParseException signal: 'Illegal string data.'! ----- Method: XMLNode>>contentsDo: (in category 'enumerating') ----- contentsDo: aBlock! ----- Method: XMLNode>>elementsAndContentsDo: (in category 'enumerating') ----- elementsAndContentsDo: aBlock self elementsDo: aBlock! ----- Method: XMLNode>>elementsDo: (in category 'enumerating') ----- elementsDo: aBlock! ----- Method: XMLNode>>firstTagNamed: (in category 'searching') ----- firstTagNamed: aSymbol "Return the first encountered node with the specified tag. Pass the message on" self elementsDo: [:node | | answer | (answer := node firstTagNamed: aSymbol) ifNotNil: [^answer]]. ^nil! ----- Method: XMLNode>>firstTagNamed:with: (in category 'searching') ----- firstTagNamed: aSymbol with: aBlock "Return the first encountered node with the specified tag that allows the block to evaluate to true. Pass the message on" self elementsDo: [:node | | answer | (answer := node firstTagNamed: aSymbol with: aBlock) ifNotNil: [^answer]]. ^nil! ----- Method: XMLNode>>isProcessingInstruction (in category 'testing') ----- isProcessingInstruction ^false! ----- Method: XMLNode>>isTag (in category 'testing') ----- isTag ^false! ----- Method: XMLNode>>isText (in category 'testing') ----- isText ^false! ----- Method: XMLNode>>printOn: (in category 'printing') ----- printOn: stream self printXMLOn: (XMLWriter on: stream)! ----- Method: XMLNode>>printXMLOn: (in category 'printing') ----- printXMLOn: writer self subclassResponsibility! ----- Method: XMLNode>>tagsNamed:childrenDo: (in category 'searching') ----- tagsNamed: aSymbol childrenDo: aOneArgumentBlock "Evaluate aOneArgumentBlock for all children who match" self elementsDo: [:each | each tagsNamed: aSymbol ifReceiverDo: aOneArgumentBlock]! ----- Method: XMLNode>>tagsNamed:childrenDoAndRecurse: (in category 'searching') ----- tagsNamed: aSymbol childrenDoAndRecurse: aOneArgumentBlock "Evaluate aOneArgumentBlock for all children who match and recurse" self elementsDo: [:each | each tagsNamed: aSymbol ifReceiverDoAndRecurse: aOneArgumentBlock]! ----- Method: XMLNode>>tagsNamed:contentsDo: (in category 'searching') ----- tagsNamed: aSymbol contentsDo: aBlock "Evaluate aBlock for all of the contents of the receiver. The receiver has no tag, so pass the message on" self elementsDo: [:each | each tagsNamed: aSymbol contentsDo: aBlock]! ----- Method: XMLNode>>tagsNamed:do: (in category 'searching') ----- tagsNamed: aSymbol do: aOneArgumentBlock "Search for nodes with tag aSymbol. When encountered evaluate aOneArgumentBlock" self elementsDo: [:each | each tagsNamed: aSymbol do: aOneArgumentBlock]! ----- Method: XMLNode>>tagsNamed:ifReceiverDo: (in category 'searching') ----- tagsNamed: aSymbol ifReceiverDo: aOneArgumentBlock "Handled only by XMLElement subclass" ! ----- Method: XMLNode>>tagsNamed:ifReceiverDoAndRecurse: (in category 'searching') ----- tagsNamed: aSymbol ifReceiverDoAndRecurse: aOneArgumentBlock "Recurse all children" self elementsDo: [:each | each tagsNamed: aSymbol ifReceiverDoAndRecurse: aOneArgumentBlock]! ----- Method: XMLNode>>tagsNamed:ifReceiverOrChildDo: (in category 'searching') ----- tagsNamed: aSymbol ifReceiverOrChildDo: aOneArgumentBlock "Recurse all children" self elementsDo: [:each | each tagsNamed: aSymbol ifReceiverDo: aOneArgumentBlock]! XMLNode subclass: #XMLNodeWithElements instanceVariableNames: 'elementsAndContents uri namespace parent' classVariableNames: '' poolDictionaries: '' category: 'XML-Parser'! XMLNodeWithElements subclass: #XMLDocument instanceVariableNames: 'dtd version encoding requiredMarkup' classVariableNames: '' poolDictionaries: '' category: 'XML-Parser'! ----- Method: XMLDocument>>dtd (in category 'accessing') ----- dtd ^dtd! ----- Method: XMLDocument>>dtd: (in category 'accessing') ----- dtd: aDTD dtd := aDTD! ----- Method: XMLDocument>>encoding (in category 'accessing') ----- encoding ^encoding ifNil: ['UTF-8']! ----- Method: XMLDocument>>encoding: (in category 'accessing') ----- encoding: aString encoding := aString! ----- Method: XMLDocument>>printCanonicalOn: (in category 'printing') ----- printCanonicalOn: aStream | writer | writer := XMLWriter on: aStream. writer canonical: true. self printXMLOn: writer! ----- Method: XMLDocument>>printXMLOn: (in category 'printing') ----- printXMLOn: writer version ifNotNil: [writer xmlDeclaration: self version encoding: self encoding]. super printXMLOn: writer! ----- Method: XMLDocument>>requiredMarkup (in category 'accessing') ----- requiredMarkup ^requiredMarkup! ----- Method: XMLDocument>>requiredMarkup: (in category 'accessing') ----- requiredMarkup: aString requiredMarkup := aString! ----- Method: XMLDocument>>root (in category 'accessing') ----- root "return my root element" ^ self topElement ! ----- Method: XMLDocument>>version (in category 'accessing') ----- version ^version! ----- Method: XMLDocument>>version: (in category 'accessing') ----- version: aString version := aString! XMLNodeWithElements subclass: #XMLElement instanceVariableNames: 'name attributes' classVariableNames: '' poolDictionaries: '' category: 'XML-Parser'! ----- Method: XMLElement class>>named: (in category 'instance creation') ----- named: aString ^self new name: aString! ----- Method: XMLElement class>>named:attributes: (in category 'instance creation') ----- named: aString attributes: attributeList ^self new name: aString; setAttributes: attributeList! ----- Method: XMLElement class>>named:namespace:uri:attributes: (in category 'instance creation') ----- named: aString namespace: ns uri: uri attributes: attributeList ^self new name: aString; namespace: ns uri: uri; setAttributes: attributeList! ----- Method: XMLElement>>@ (in category 'accessing') ----- @ aSymbol "shorthand form" ^ self at: aSymbol ! ----- Method: XMLElement>>addContent: (in category 'initialize') ----- addContent: contentString self addElement: contentString! ----- Method: XMLElement>>allAttributes (in category 'accessing') ----- allAttributes ^ self attributes asOrderedCollection! ----- Method: XMLElement>>at: (in category 'accessing') ----- at: aSymbol ^ self attributeAt: aSymbol ifAbsent: [''] ! ----- Method: XMLElement>>attributeAt: (in category 'accessing') ----- attributeAt: attributeName ^self attributeAt: attributeName ifAbsent: [nil]! ----- Method: XMLElement>>attributeAt:ifAbsent: (in category 'accessing') ----- attributeAt: attributeName ifAbsent: aBlock ^self attributes at: attributeName ifAbsent: [^aBlock value]! ----- Method: XMLElement>>attributeAt:put: (in category 'accessing') ----- attributeAt: attributeName put: attributeValue self attributes at: attributeName asSymbol put: attributeValue! ----- Method: XMLElement>>attributes (in category 'accessing') ----- attributes ^attributes ifNil: [attributes := Dictionary new]! ----- Method: XMLElement>>characterData (in category 'accessing') ----- characterData ^self contentString! ----- Method: XMLElement>>contentString (in category 'accessing') ----- contentString | contentElements | contentElements := self elementsAndContents. ^(contentElements size > 0 and: [contentElements first isText]) ifTrue: [contentElements first string] ifFalse: ['']! ----- Method: XMLElement>>contentStringAt: (in category 'accessing') ----- contentStringAt: entityName ^(self elementAt: entityName ifAbsent: [^'']) contentString! ----- Method: XMLElement>>contents (in category 'accessing') ----- contents ^self elementsAndContents select: [:each | each isText]! ----- Method: XMLElement>>contentsDo: (in category 'enumerating') ----- contentsDo: aBlock self elementsAndContentsDo: [:each | each isText ifTrue: [aBlock value: each]]! ----- Method: XMLElement>>elements (in category 'accessing') ----- elements ^self elementsAndContents select: [:each | each isText not]! ----- Method: XMLElement>>elementsAndContentsDo: (in category 'enumerating') ----- elementsAndContentsDo: aBlock self elementsAndContents do: aBlock! ----- Method: XMLElement>>elementsDo: (in category 'enumerating') ----- elementsDo: aBlock self elementsAndContentsDo: [:each | each isText ifFalse: [aBlock value: each]]! ----- Method: XMLElement>>firstTagNamed: (in category 'searching') ----- firstTagNamed: aSymbol "Return the first encountered node with the specified tag. If it is not the receiver, pass the message on" (self localName == aSymbol or: [self tag == aSymbol]) ifTrue: [^self]. ^super firstTagNamed: aSymbol ! ----- Method: XMLElement>>firstTagNamed:with: (in category 'searching') ----- firstTagNamed: aSymbol with: aBlock "Return the first encountered node with the specified tag that allows the block to evaluate to true. Pass the message on" ((self localName == aSymbol or: [self tag == aSymbol]) and: [aBlock value: self]) ifTrue: [^self]. ^super firstTagNamed: aSymbol with: aBlock.! ----- Method: XMLElement>>isEmpty (in category 'testing') ----- isEmpty "Answer true if the receiver is empty" ^self elementsAndContents isEmpty! ----- Method: XMLElement>>isTag (in category 'testing') ----- isTag ^true! ----- Method: XMLElement>>localName (in category 'name space') ----- localName ^ name! ----- Method: XMLElement>>name (in category 'accessing') ----- name ^ self qualifiedName! ----- Method: XMLElement>>name: (in category 'initialize') ----- name: aString name := aString asSymbol! ----- Method: XMLElement>>parent (in category 'accessing') ----- parent ^ parent! ----- Method: XMLElement>>parent: (in category 'accessing') ----- parent: anXMLElement parent := anXMLElement ! ----- Method: XMLElement>>printXMLOn: (in category 'printing') ----- printXMLOn: writer "Print the receiver in XML form" writer startElement: self name attributeList: self attributes. (writer canonical not and: [self isEmpty]) ifTrue: [writer endEmptyTag: self name] ifFalse: [ writer endTag. self elementsAndContentsDo: [:content | content printXMLOn: writer]. writer endTag: self name]! ----- Method: XMLElement>>qualifiedName (in category 'name space') ----- qualifiedName ^self namespace ifNil: [self localName] ifNotNil: [self namespace , ':' , self localName]! ----- Method: XMLElement>>setAttributes: (in category 'initialize') ----- setAttributes: newAttributes attributes := newAttributes! ----- Method: XMLElement>>tag (in category 'accessing') ----- tag ^ self name asSymbol! ----- Method: XMLElement>>tagsNamed:contentsDo: (in category 'searching') ----- tagsNamed: aSymbol contentsDo: aBlock "Evaluate aBlock for all of the contents of the receiver if the receiver tag equals aSymbol. Pass the message on" (self localName == aSymbol or: [self tag == aSymbol]) ifTrue: [self contentsDo: aBlock]. super tagsNamed: aSymbol contentsDo: aBlock! ----- Method: XMLElement>>tagsNamed:do: (in category 'searching') ----- tagsNamed: aSymbol do: aOneArgumentBlock "If the receiver tag equals aSymbol, evaluate aOneArgumentBlock with the receiver. Continue the search" (self localName == aSymbol or: [self tag == aSymbol]) ifTrue: [aOneArgumentBlock value: self]. super tagsNamed: aSymbol do: aOneArgumentBlock! ----- Method: XMLElement>>tagsNamed:ifReceiverDo: (in category 'searching') ----- tagsNamed: aSymbol ifReceiverDo: aOneArgumentBlock "If the receiver tag equals aSymbol, evaluate aOneArgumentBlock with the receiver" (self localName == aSymbol or: [self tag == aSymbol]) ifTrue: [aOneArgumentBlock value: self] ! ----- Method: XMLElement>>tagsNamed:ifReceiverDoAndRecurse: (in category 'searching') ----- tagsNamed: aSymbol ifReceiverDoAndRecurse: aOneArgumentBlock "If the receiver tag equals aSymbol, evaluate aOneArgumentBlock with the receiver. Then recurse through all the children" (self localName == aSymbol or: [self tag == aSymbol]) ifTrue: [aOneArgumentBlock value: self]. super tagsNamed: aSymbol ifReceiverDoAndRecurse: aOneArgumentBlock! ----- Method: XMLElement>>tagsNamed:ifReceiverOrChildDo: (in category 'searching') ----- tagsNamed: aSymbol ifReceiverOrChildDo: aOneArgumentBlock "If the receiver tag equals aSymbol, evaluate aOneArgumentBlock with the receiver. For each of the receivers children do the same. Do not go beyond direct children" (self localName == aSymbol or: [self tag == aSymbol]) ifTrue: [aOneArgumentBlock value: self]. super tagsNamed: aSymbol ifReceiverDo: aOneArgumentBlock! ----- Method: XMLElement>>valueFor: (in category 'accessing') ----- valueFor: aSymbol ^self valueFor: aSymbol ifAbsent: ['']! ----- Method: XMLElement>>valueFor:ifAbsent: (in category 'accessing') ----- valueFor: aSymbol ifAbsent: aBlock ^self attributes at: aSymbol ifAbsent: aBlock! ----- Method: XMLNodeWithElements>>addElement: (in category 'accessing') ----- addElement: element self elementsAndContents add: element! ----- Method: XMLNodeWithElements>>addEntity:value: (in category 'accessing') ----- addEntity: entityName value: entityValue self entities add: entityName->entityValue! ----- Method: XMLNodeWithElements>>elementAt: (in category 'accessing') ----- elementAt: entityName ^self elementAt: entityName ifAbsent: [nil]! ----- Method: XMLNodeWithElements>>elementAt:ifAbsent: (in category 'accessing') ----- elementAt: entityName ifAbsent: aBlock elementsAndContents ifNil: [^aBlock value]. ^self elements detect: [:each | each isProcessingInstruction not and: [each name = entityName or: [each localName = entityName]]] ifNone: [^aBlock value]! ----- Method: XMLNodeWithElements>>elementUnqualifiedAt: (in category 'accessing') ----- elementUnqualifiedAt: entityName ^self elementUnqualifiedAt: entityName ifAbsent: [nil]! ----- Method: XMLNodeWithElements>>elementUnqualifiedAt:ifAbsent: (in category 'accessing') ----- elementUnqualifiedAt: entityName ifAbsent: aBlock elementsAndContents ifNil: [^aBlock value]. ^self elements detect: [:each | each localName = entityName] ifNone: [^aBlock value]! ----- Method: XMLNodeWithElements>>elements (in category 'accessing') ----- elements ^self elementsAndContents! ----- Method: XMLNodeWithElements>>elementsAndContents (in category 'accessing') ----- elementsAndContents elementsAndContents ifNil: [elementsAndContents := OrderedCollection new]. ^elementsAndContents! ----- Method: XMLNodeWithElements>>elementsDo: (in category 'enumerating') ----- elementsDo: aBlock self elements do: aBlock! ----- Method: XMLNodeWithElements>>namespace (in category 'name space') ----- namespace ^ namespace! ----- Method: XMLNodeWithElements>>namespace:uri: (in category 'name space') ----- namespace: ns uri: u namespace := ns. uri := u! ----- Method: XMLNodeWithElements>>namespaceURI (in category 'name space') ----- namespaceURI ^ uri! ----- Method: XMLNodeWithElements>>printXMLOn: (in category 'printing') ----- printXMLOn: writer self elementsDo: [:element | element printXMLOn: writer]! ----- Method: XMLNodeWithElements>>removeElement: (in category 'accessing') ----- removeElement: element "Used to purge certain elements from a document after parsing." self elementsAndContents remove: element ifAbsent: []! ----- Method: XMLNodeWithElements>>topElement (in category 'accessing') ----- topElement ^self elements first! XMLNode subclass: #XMLPI instanceVariableNames: 'target data' classVariableNames: '' poolDictionaries: '' category: 'XML-Parser'! ----- Method: XMLPI class>>target:data: (in category 'instance creation') ----- target: targetName data: aString ^self new target: targetName; data: aString! ----- Method: XMLPI>>data (in category 'accessing') ----- data ^data! ----- Method: XMLPI>>data: (in category 'accessing') ----- data: aString data := aString! ----- Method: XMLPI>>isProcessingInstruction (in category 'testing') ----- isProcessingInstruction ^true! ----- Method: XMLPI>>printXMLOn: (in category 'printing') ----- printXMLOn: writer writer pi: self target data: self data! ----- Method: XMLPI>>target (in category 'accessing') ----- target ^target! ----- Method: XMLPI>>target: (in category 'accessing') ----- target: aString target := aString! XMLNode subclass: #XMLStringNode instanceVariableNames: 'string' classVariableNames: '' poolDictionaries: '' category: 'XML-Parser'! ----- Method: XMLStringNode class>>string: (in category 'instance creation') ----- string: aString ^self new string: aString! ----- Method: XMLStringNode>>characterData (in category 'accessing') ----- characterData ^self string! ----- Method: XMLStringNode>>isText (in category 'testing') ----- isText ^true! ----- Method: XMLStringNode>>printXMLOn: (in category 'printing') ----- printXMLOn: writer writer pcData: self string! ----- Method: XMLStringNode>>string (in category 'accessing') ----- string ^string ifNil: ['']! ----- Method: XMLStringNode>>string: (in category 'accessing') ----- string: aString string := aString! Object subclass: #XMLTokenizer instanceVariableNames: 'stream nestedStreams entities externalEntities parameterEntities parsingMarkup markedPosition peekChar validating nameBuffer attributeBuffer' classVariableNames: 'CharEscapes DigitTable LiteralChars NameDelimiters SeparatorTable' poolDictionaries: '' category: 'XML-Parser'! !XMLTokenizer commentStamp: '<historical>' prior: 0! XMLTokenizer bolot(a)cc.gatech.edu breaks the stream of characters into a stream of XMLnodes (aka token stream) token stream is used by XMLparser to generate XMLdocument tree! XMLTokenizer subclass: #SAXDriver instanceVariableNames: 'saxHandler scope useNamespaces validateAttributes languageEnvironment' classVariableNames: '' poolDictionaries: '' category: 'XML-Parser'! ----- Method: SAXDriver>>handleCData: (in category 'handling tokens') ----- handleCData: aString self saxHandler checkEOD; characters: aString! ----- Method: SAXDriver>>handleComment: (in category 'handling tokens') ----- handleComment: aString self saxHandler checkEOD; comment: aString! ----- Method: SAXDriver>>handleEndDocument (in category 'handling tokens') ----- handleEndDocument self saxHandler endDocument! ----- Method: SAXDriver>>handleEndTag: (in category 'handling tokens') ----- handleEndTag: elementName | namespace localName namespaceURI qualifiedName | self usesNamespaces ifTrue: [ self splitName: elementName into: [:ns :ln | namespace := ns. localName := ln]. "ensure our namespace is defined" namespace ifNil: [ namespace := self scope defaultNamespace. qualifiedName := namespace , ':' , elementName] ifNotNil: [ namespaceURI := self scope namespaceURIOf: namespace. namespaceURI ifNil: [self parseError: 'Start tag ' , elementName , ' refers to undefined namespace ' , namespace asString]. qualifiedName := elementName]. "call the handler" self saxHandler checkEOD; endElement: localName namespace: namespace namespaceURI: namespaceURI qualifiedName: qualifiedName. self scope leaveScope] ifFalse: [ "call the handler" self saxHandler checkEOD; endElement: elementName namespace: nil namespaceURI: nil qualifiedName: elementName]! ----- Method: SAXDriver>>handlePCData: (in category 'handling tokens') ----- handlePCData: aString self languageEnvironment ifNotNil: [aString applyLanguageInfomation: self languageEnvironment]. self saxHandler checkEOD; characters: aString! ----- Method: SAXDriver>>handlePI:data: (in category 'handling tokens') ----- handlePI: piTarget data: piData self saxHandler checkEOD; processingInstruction: piTarget data: piData! ----- Method: SAXDriver>>handleStartDocument (in category 'handling tokens') ----- handleStartDocument self saxHandler startDocument! ----- Method: SAXDriver>>handleStartTag:attributes:namespaces: (in category 'handling tokens') ----- handleStartTag: elementName attributes: attributeList namespaces: namespaces | localName namespace namespaceURI | (attributeList includesKey: 'xml:lang') ifTrue: [languageEnvironment := LanguageEnvironment localeID: (LocaleID isoString: (attributeList at: 'xml:lang'))]. self usesNamespaces ifTrue: [ self scope enterScope. "declare any namespaces" namespaces keysAndValuesDo: [:ns :uri | self scope declareNamespace: ns uri: uri]. self splitName: elementName into: [:ns :ln | namespace := ns. localName := ln]. "ensure our namespace is defined" namespace ifNil: [namespace := self scope defaultNamespace] ifNotNil: [ namespaceURI := self scope namespaceURIOf: namespace. namespaceURI ifNil: [self parseError: 'Start tag ' , elementName , ' refers to undefined namespace ' , namespace asString]]. self validatesAttributes ifTrue: [self scope validateAttributes: attributeList]. "call the handler" self saxHandler checkEOD; startElement: localName namespaceURI: namespaceURI namespace: namespace attributeList: attributeList] ifFalse: [ "call the handler" self saxHandler checkEOD; startElement: elementName namespaceURI: nil namespace: nil attributeList: attributeList]! ----- Method: SAXDriver>>handleWhitespace: (in category 'handling tokens') ----- handleWhitespace: aString self saxHandler checkEOD; ignorableWhitespace: aString! ----- Method: SAXDriver>>handleXMLDecl:namespaces: (in category 'handling tokens') ----- handleXMLDecl: attributes namespaces: namespaces self saxHandler checkEOD; documentAttributes: attributes. self usesNamespaces ifTrue: [ namespaces keysAndValuesDo: [:ns :uri | self scope declareNamespace: ns uri: uri]]! ----- Method: SAXDriver>>initialize (in category 'initialization') ----- initialize super initialize. useNamespaces := false. validateAttributes := false! ----- Method: SAXDriver>>languageEnvironment (in category 'accessing') ----- languageEnvironment ^languageEnvironment! ----- Method: SAXDriver>>saxHandler (in category 'accessing') ----- saxHandler ^saxHandler! ----- Method: SAXDriver>>saxHandler: (in category 'accessing') ----- saxHandler: aHandler saxHandler := aHandler! ----- Method: SAXDriver>>scope (in category 'namespaces') ----- scope scope ifNil: [scope := XMLNamespaceScope new]. ^scope! ----- Method: SAXDriver>>splitName:into: (in category 'namespaces') ----- splitName: aName into: twoArgsBlock "Split the name into namespace and local name (the block arguments). Handle both qualified and unqualified names using the default name space" | i ns ln | i := aName lastIndexOf: $:. i = 0 ifTrue: [ ns := nil. ln := aName] ifFalse: [ ns := aName copyFrom: 1 to: (i - 1). ln := aName copyFrom: i+1 to: aName size]. twoArgsBlock value: ns value: ln! ----- Method: SAXDriver>>useNamespaces: (in category 'accessing') ----- useNamespaces: aBoolean useNamespaces := aBoolean! ----- Method: SAXDriver>>usesNamespaces (in category 'testing') ----- usesNamespaces ^useNamespaces! ----- Method: SAXDriver>>validatesAttributes (in category 'testing') ----- validatesAttributes ^validateAttributes! XMLTokenizer subclass: #XMLParser instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'XML-Parser'! !XMLParser commentStamp: 'Alexandre.Bergel 6/1/2009 10:03' prior: 0! This is a generic parser. There is two ways to parse XML files, either using SAX, or using DOM. Both ways are supported in the XML-Parser package. SAX is event-based while DOM is tree-based. Ask google for more information! ----- Method: XMLParser>>attribute:value: (in category 'callbacks') ----- attribute: aSymbol value: aString "This method is called for each attribute/value pair in a start tag" ^self subclassResponsibility! ----- Method: XMLParser>>beginStartTag:asPI: (in category 'callbacks') ----- beginStartTag: aSymbol asPI: aBoolean "This method is called for at the beginning of a start tag. The asPI parameter defines whether or not the tag is a 'processing instruction' rather than a 'normal' tag." ^self subclassResponsibility! ----- Method: XMLParser>>endStartTag: (in category 'callbacks') ----- endStartTag: aSymbol "This method is called at the end of the start tag after all of the attributes have been processed" ^self subclassResponsibility! ----- Method: XMLParser>>endTag: (in category 'callbacks') ----- endTag: aSymbol "This method is called when the parser encounters either an end tag or the end of a unary tag" ^self subclassResponsibility! ----- Method: XMLParser>>handleCData: (in category 'handling tokens') ----- handleCData: aString self text: aString! ----- Method: XMLParser>>handleEndTag: (in category 'handling tokens') ----- handleEndTag: aString self endTag: aString! ----- Method: XMLParser>>handlePCData: (in category 'handling tokens') ----- handlePCData: aString self text: aString! ----- Method: XMLParser>>handleStartTag:attributes: (in category 'handling tokens') ----- handleStartTag: tagName attributes: attributes self beginStartTag: tagName asPI: false. attributes keysAndValuesDo: [:key :value | self attribute: key value: value]. self endStartTag: tagName! ----- Method: XMLParser>>text: (in category 'callbacks') ----- text: aString "This method is called for the blocks of text between tags. It preserves whitespace, but has all of the enclosed entities expanded" ^self subclassResponsibility! ----- Method: XMLTokenizer class>>addressBookXML (in category 'examples') ----- addressBookXML ^'<addressbook> <person employee-number="A0000" family-name="Gates" first-name="Bob"> <contact-info><!!--Confidential--></contact-info> <address city="Los Angeles" number="1239" state="CA" street="Pine Rd."/> <job-info employee-type="Full-Time" is-manager="no" job-description="Manager"/> <manager employee-number="A0000"/> </person> <person employee-number="A7000" family-name="Brown" first-name="Robert" middle-initial="L."> <contact-info> <email address="robb(a)iro.ibm.com"/> <home-phone number="03-3987873"/> </contact-info> <address city="New York" number="344" state="NY" street="118 St."/> <job-info employee-type="Full-Time" is-manager="yes" job-description="Group Leader"/> <manager employee-number="A0000"/> </person> <person employee-number="A7890" family-name="DePaiva" first-name="Kassie" middle-initial="W."> <contact-info><!!-- Kassie''s agent phone: 03-987654 --></contact-info> <address city="Los Angeles" number="1234" state="CA" street="Pine Rd."/> <job-info employee-type="Full-Time" is-manager="no" job-description="Actor"/> <manager employee-number="A0000"/> <misc-info>One of the most talented actresses on Daytime. Kassie plays the devious and beautiful Blair Cramer on ABC's "One Life To Live."</misc-info> </person> <person employee-number="A7987" family-name="Smith" first-name="Joe"> <contact-info> <email address="joes(a)iro.ibm.com"/> <mobile-phone number="888-7657765"/> <home-phone number="03-8767898"/> <home-phone number="03-8767871"/> </contact-info> <address city="New York" number="12789" state="NY" street="W. 15th Ave."/> <job-info employee-type="Part-Time" is-manager="no" job-description="Hacker"/> <manager employee-number="A7000"/> </person> </addressbook> '! ----- Method: XMLTokenizer class>>addressBookXMLWithDTD (in category 'examples') ----- addressBookXMLWithDTD ^'<?xml version="1.0" encoding="UTF-8"?> <!!DOCTYPE addressbook SYSTEM "addressbook.dtd"> <?xml-stylesheet type="text/xsl" href="demo.xsl"?> <addressbook> <person employee-number="A0000" family-name="Gates" first-name="Bob"> <contact-info><!!--Confidential--></contact-info> <address city="Los Angeles" number="1239" state="CA" street="Pine Rd."/> <job-info employee-type="Full-Time" is-manager="no" job-description="Manager"/> <manager employee-number="A0000"/> </person> <person employee-number="A7000" family-name="Brown" first-name="Robert" middle-initial="L."> <contact-info> <email address="robb(a)iro.ibm.com"/> <home-phone number="03-3987873"/> </contact-info> <address city="New York" number="344" state="NY" street="118 St."/> <job-info employee-type="Full-Time" is-manager="yes" job-description="Group Leader"/> <manager employee-number="A0000"/> </person> <person employee-number="A7890" family-name="DePaiva" first-name="Kassie" middle-initial="W."> <contact-info><!!-- Kassie''s agent phone: 03-987654 --></contact-info> <address city="Los Angeles" number="1234" state="CA" street="Pine Rd."/> <job-info employee-type="Full-Time" is-manager="no" job-description="Actor"/> <manager employee-number="A0000"/> <misc-info>One of the most talented actresses on Daytime. Kassie plays the devious and beautiful Blair Cramer on ABC's "One Life To Live."</misc-info> </person> <person employee-number="A7987" family-name="Smith" first-name="Joe"> <contact-info> <email address="joes(a)iro.ibm.com"/> <mobile-phone number="888-7657765"/> <home-phone number="03-8767898"/> <home-phone number="03-8767871"/> </contact-info> <address city="New York" number="12789" state="NY" street="W. 15th Ave."/> <job-info employee-type="Part-Time" is-manager="no" job-description="Hacker"/> <manager employee-number="A7000"/> </person> </addressbook> '! ----- Method: XMLTokenizer class>>exampleAddressBook (in category 'examples') ----- exampleAddressBook | tokenizer | "XMLTokenizer exampleAddressBook" tokenizer := XMLTokenizer on: self addressBookXML readStream. [tokenizer next notNil] whileTrue: []! ----- Method: XMLTokenizer class>>exampleAddressBookWithDTD (in category 'examples') ----- exampleAddressBookWithDTD | tokenizer | "XMLTokenizer exampleAddressBookWithDTD" tokenizer := XMLTokenizer on: self addressBookXMLWithDTD readStream. [tokenizer next notNil] whileTrue: []! ----- Method: XMLTokenizer class>>initialize (in category 'class initialization') ----- initialize "XMLTokenizer initialize" CharEscapes := CharacterSet newFrom: #( $& $" $' $> $< ). SeparatorTable := CharacterSet new. #(9 10 12 13 32) do: [:each | SeparatorTable add: each asCharacter]. LiteralChars := CharacterSet newFrom: #( $: $- $_ $= $.). 0 to: 255 do: [:i | | char | char := i asCharacter. (char isDigit or: [char isLetter]) ifTrue: [LiteralChars add: char]]. NameDelimiters := CharacterSet new. #(9 10 12 13 32 61 "$= asInteger 61" 62 "$> asInteger" 47 "$/ asInteger") do: [:each | NameDelimiters add: each asCharacter]. DigitTable := Array new: 256. DigitTable atAllPut: -1. ($0 to: $9) do: [:each | DigitTable at: each asciiValue put: each digitValue]. ($a to: $f) do: [:each | DigitTable at: each asciiValue put: each digitValue]. ($A to: $F) do: [:each | DigitTable at: each asciiValue put: each digitValue]. ! ----- Method: XMLTokenizer class>>isCharEscape: (in category 'accessing') ----- isCharEscape: entityValue ^entityValue size = 1 and: [CharEscapes includes: entityValue first]! ----- Method: XMLTokenizer class>>on: (in category 'instance creation') ----- on: aStream ^self new parseStream: aStream! ----- Method: XMLTokenizer>>atEnd (in category 'streaming') ----- atEnd nestedStreams == nil ifTrue: [^peekChar == nil and: [stream atEnd]]. ^stream atEnd ifTrue: [ self popNestingLevel. self atEnd] ifFalse: [false]! ----- Method: XMLTokenizer>>checkAndExpandReference: (in category 'tokenizing') ----- checkAndExpandReference: parsingContext | referenceString nextChar | nextChar := self peek. self validating ifFalse: [^nil]. nextChar == $& ifTrue: [ self next. self peek == $# ifTrue: [^self pushStream: (ReadStream on: self nextCharReference asString)]. referenceString := self nextLiteral. self next == $; ifFalse: [self errorExpected: ';']. self handleEntity: referenceString in: parsingContext ] ifFalse: [ ((nextChar == $% and: [self parsingMarkup]) and: [parsingContext == #entityValue]) ifTrue: [ self skipSeparators. referenceString := self nextLiteral. self handleEntity: referenceString in: parsingContext]]. self atEnd ifTrue: [self errorExpected: 'Character expected.']. ^nextChar! ----- Method: XMLTokenizer>>checkNestedStream (in category 'streaming') ----- checkNestedStream nestedStreams == nil ifFalse: [(peekChar == nil and: [self stream atEnd]) ifTrue: [ self popNestingLevel. self checkNestedStream]] ! ----- Method: XMLTokenizer>>conditionalInclude: (in category 'tokenizing') ----- conditionalInclude: conditionalKeyword conditionalKeyword = 'INCLUDE' ifTrue: [^true]. conditionalKeyword = 'IGNORE' ifTrue: [^false]. ^self conditionalInclude: (self parameterEntity: conditionalKeyword) value! ----- Method: XMLTokenizer>>endDocTypeDecl (in category 'tokenizing dtd') ----- endDocTypeDecl "Skip ]>" self next; next. ^nil! ----- Method: XMLTokenizer>>endParsingMarkup (in category 'private') ----- endParsingMarkup parsingMarkup := false! ----- Method: XMLTokenizer>>entities (in category 'entities') ----- entities entities ifNil: [entities := self initEntities]. ^entities! ----- Method: XMLTokenizer>>entity: (in category 'entities') ----- entity: refName ^self validating ifTrue: [self entities at: refName ifAbsentPut: [self parseError: 'XML undefined entity ' , refName printString]] ifFalse: [DTDEntityDeclaration name: refName value: ''] ! ----- Method: XMLTokenizer>>entity:put: (in category 'entities') ----- entity: refName put: aReference "Only the first declaration of an entity is valid so if there is already one don't register the new value." self entities at: refName ifAbsentPut: [aReference]! ----- Method: XMLTokenizer>>errorExpected: (in category 'errors') ----- errorExpected: expectedString | actualString | actualString := ''. self atEnd ifFalse: [ actualString := [self next: 20] on: Error do: ['']]. self parseError: 'XML expected ' , expectedString printString , ': ' , actualString! ----- Method: XMLTokenizer>>externalEntities (in category 'entities') ----- externalEntities externalEntities ifNil: [externalEntities := Dictionary new]. ^externalEntities! ----- Method: XMLTokenizer>>externalEntity: (in category 'entities') ----- externalEntity: refName ^self entities at: refName ifAbsentPut: ['']! ----- Method: XMLTokenizer>>fastStreamStringContents: (in category 'private') ----- fastStreamStringContents: writeStream | newSize | newSize := writeStream position. ^(String new: newSize) replaceFrom: 1 to: newSize with: writeStream originalContents startingAt: 1! ----- Method: XMLTokenizer>>handleCData: (in category 'handling tokens') ----- handleCData: aString self log: 'CData: ' , aString! ----- Method: XMLTokenizer>>handleComment: (in category 'handling tokens') ----- handleComment: aString self log: 'Comment: ' , aString! ----- Method: XMLTokenizer>>handleEndDocument (in category 'handling tokens') ----- handleEndDocument self log: 'End Doc '! ----- Method: XMLTokenizer>>handleEndTag: (in category 'handling tokens') ----- handleEndTag: aString self log: 'End tag: ' , aString! ----- Method: XMLTokenizer>>handleEntity:in: (in category 'entities') ----- handleEntity: referenceString in: parsingContext | entity entityValue | entity := self entity: referenceString. entityValue := entity valueForContext: parsingContext. (self class isCharEscape: entityValue) ifTrue: [entityValue := entity reference]. self pushStream: (ReadStream on: entityValue asString)! ----- Method: XMLTokenizer>>handlePCData: (in category 'handling tokens') ----- handlePCData: aString self log: 'PCData: ' , aString! ----- Method: XMLTokenizer>>handlePI:data: (in category 'handling tokens') ----- handlePI: piTarget data: piData self log: 'PI: ' , piTarget , ' data ' , piData! ----- Method: XMLTokenizer>>handleStartDocument (in category 'handling tokens') ----- handleStartDocument self log: 'Start Doc'! ----- Method: XMLTokenizer>>handleStartTag:attributes: (in category 'handling tokens') ----- handleStartTag: tagName attributes: attributes self log: 'Start tag: ' , tagName. attributes keysAndValuesDo: [:key :value | self log: key , '->' , value]! ----- Method: XMLTokenizer>>handleWhitespace: (in category 'handling tokens') ----- handleWhitespace: aString self log: 'Whitespace: ' , aString! ----- Method: XMLTokenizer>>handleXMLDecl:namespaces: (in category 'handling tokens') ----- handleXMLDecl: attributes namespaces: namespaces attributes keysAndValuesDo: [:key :value | self log: key , '->' , value]! ----- Method: XMLTokenizer>>hasNestedStreams (in category 'streaming') ----- hasNestedStreams ^nestedStreams notNil! ----- Method: XMLTokenizer>>initEntities (in category 'entities') ----- initEntities | ents | ents := Dictionary new. ents at: 'amp' put: (DTDEntityDeclaration name: 'amp' value: '&'); at: 'quot' put: (DTDEntityDeclaration name: 'quot' value: '"'); at: 'apos' put: (DTDEntityDeclaration name: 'apos' value: ''''); at: 'gt' put: (DTDEntityDeclaration name: 'gt' value: '>'); at: 'lt' put: (DTDEntityDeclaration name: 'lt' value: '<'). ^ents! ----- Method: XMLTokenizer>>initialize (in category 'initialize') ----- initialize parsingMarkup := false. validating := false. attributeBuffer := WriteStream on: (String new: 128). nameBuffer := WriteStream on: (String new: 128)! ----- Method: XMLTokenizer>>log: (in category 'private') ----- log: aString "Transcript show: aString; cr"! ----- Method: XMLTokenizer>>malformedError: (in category 'errors') ----- malformedError: errorString SAXMalformedException signal: errorString! ----- Method: XMLTokenizer>>match:into: (in category 'streaming') ----- match: subCollection into: resultStream "Set the access position of the receiver to be past the next occurrence of the subCollection. Answer whether subCollection is found. No wildcards, and case does matter." | pattern startMatch | pattern := ReadStream on: subCollection. startMatch := nil. [pattern atEnd] whileFalse: [self atEnd ifTrue: [^ false]. (self next) = (pattern next) ifTrue: [pattern position = 1 ifTrue: [startMatch := self position]] ifFalse: [pattern position: 0. startMatch ifNotNil: [ self position: startMatch. startMatch := nil]]]. ^ true ! ----- Method: XMLTokenizer>>nestedStreams (in category 'private') ----- nestedStreams nestedStreams ifNil: [nestedStreams := OrderedCollection new]. ^nestedStreams! ----- Method: XMLTokenizer>>next (in category 'streaming') ----- next "Return the next character from the current input stream. If the current stream is at end pop to next nesting level if there is one. Due to the potential nesting of original document, included documents and replacment texts the streams are held in a stack representing the nested streams. The current stream is the top one." | nextChar | peekChar ifNil: [ nestedStreams ifNotNil: [self checkNestedStream]. ^nextChar := stream next] ifNotNil: [ nextChar := peekChar. peekChar := nil. ^nextChar]. ! ----- Method: XMLTokenizer>>nextAttributeInto:namespaces: (in category 'tokenizing') ----- nextAttributeInto: attributes namespaces: namespaces | attrName attrValue | attrName := self nextName. self skipSeparators. self next == $= ifFalse: [self errorExpected: '=']. self skipSeparators. attrValue := self nextAttributeValue. (self usesNamespaces and: [(attrName findString: 'xmlns') = 1]) ifTrue: [attrName size > 6 ifTrue: [namespaces at: (attrName copyFrom: 7 to: attrName size) put: attrValue] ifFalse: [namespaces at: attrName put: attrValue]] ifFalse: [attributes at: attrName put: attrValue]! ----- Method: XMLTokenizer>>nextAttributeValue (in category 'tokenizing') ----- nextAttributeValue | delimiterChar attributeValueStream nextChar nextPeek referenceString entity entityValue | delimiterChar := self next. (delimiterChar == $" or: [delimiterChar == $']) ifFalse: [self errorExpected: 'Attribute value delimiter expected.']. attributeValueStream := attributeBuffer reset. [ nextPeek := nextChar := self next. nextChar ifNil: [self errorExpected: 'Character expected.']. nextChar == $& ifTrue: [ self peek == $# ifTrue: [ nextPeek := nil. nextChar := self nextCharReference] ifFalse: [ referenceString := self nextLiteral. self next == $; ifFalse: [self errorExpected: ';']. entity := self entity: referenceString. entityValue := entity valueForContext: #content. (self class isCharEscape: entityValue) ifTrue: [ nextPeek := nil. nextChar := entityValue first] ifFalse: [ entityValue := entityValue asString. entityValue isEmpty ifTrue: [nextPeek := nextChar := nil] ifFalse: [ self pushStream: (ReadStream on: entityValue asString). nextPeek := nextChar := self next]]]]. nextPeek == delimiterChar] whileFalse: [ nextChar ifNotNil: [attributeValueStream nextPut: nextChar]]. ^self fastStreamStringContents: attributeValueStream " ^attributeValueStream contents"! ----- Method: XMLTokenizer>>nextCDataContent (in category 'tokenizing') ----- nextCDataContent | cdata | "Skip $[ " self next. cdata := self nextUpToAll: ']]>'. self handleCData: cdata ! ----- Method: XMLTokenizer>>nextCDataOrConditional (in category 'tokenizing') ----- nextCDataOrConditional | nextChar conditionalKeyword | "Skip [" self next. self skipSeparators. nextChar := self peek. nextChar == $% ifTrue: [ self checkAndExpandReference: (self parsingMarkup ifTrue: [#dtd] ifFalse: [#content]). conditionalKeyword := self nextLiteral. self skipSeparators. ^self next == $[ ifTrue: [ self skipSeparators. self nextIncludeSection: (self conditionalInclude: conditionalKeyword)] ifFalse: [self errorExpected: '[' ]]. nextChar == $C ifTrue: [ ^self nextLiteral = 'CDATA' ifTrue: [self peek == $[ ifTrue: [self nextCDataContent] ifFalse: [self errorExpected: '[' ]] ifFalse: [self errorExpected: 'CData']]. self errorExpected: 'CData or declaration' ! ----- Method: XMLTokenizer>>nextCharReference (in category 'tokenizing') ----- nextCharReference | base charValue | self next == $# ifFalse: [self errorExpected: 'character reference']. base := self peek == $x ifTrue: [ self next. 16] ifFalse: [10]. charValue := [self readNumberBase: base] on: Error do: [:ex | self errorExpected: 'Number.']. (self next) == $; ifFalse: [self errorExpected: '";"']. ^Unicode value: charValue! ----- Method: XMLTokenizer>>nextComment (in category 'tokenizing') ----- nextComment | string | "Skip first -" self next. self next == $- ifFalse: [self errorExpected: 'second comment $-']. string := self nextUpToAll: '-->'. self handleComment: string! ----- Method: XMLTokenizer>>nextDocType (in category 'tokenizing dtd') ----- nextDocType | declType | declType := self nextLiteral. declType = 'DOCTYPE' ifTrue: [ self startParsingMarkup. ^self nextDocTypeDecl]. self errorExpected: 'markup declaration, not ' , declType printString! ----- Method: XMLTokenizer>>nextDocTypeDecl (in category 'tokenizing dtd') ----- nextDocTypeDecl | nextChar | self skipSeparators. self nextLiteral. self skipSeparators. self peek == $[ ifFalse: [[nextChar := self peek. nextChar == $> or: [nextChar == $[ ]] whileFalse: [self next]]. self peek == $[ ifTrue: [ self next. [self skipSeparators. self peek == $]] whileFalse: [ self checkAndExpandReference: #dtd. self nextNode]. self next == $] ifFalse: [self errorExpected: ']' ]]. self skipSeparators. self next == $> ifFalse: [self errorExpected: '>' ]. self endParsingMarkup! ----- Method: XMLTokenizer>>nextEndTag (in category 'tokenizing') ----- nextEndTag | tagName | "Skip /" self next. tagName := self nextName. self skipSeparators. (self nextTrimmedBlanksUpTo: $>) ifNotEmpty: [self parseError: 'XML invalid end tag ' , tagName]. self handleEndTag: tagName! ----- Method: XMLTokenizer>>nextEntity (in category 'tokenizing') ----- nextEntity "return the next XMLnode, or nil if there are no more. Fixed to retain leading whitespace when PCDATA is detected." |whitespace| "branch, depending on what the first character is" whitespace := self nextWhitespace. self atEnd ifTrue: [self handleEndDocument. ^ nil]. self checkAndExpandReference: (self parsingMarkup ifTrue: [#dtd] ifFalse: [#content]). ^self peek = $< ifTrue: [self nextNode] ifFalse: [whitespace isEmpty ifFalse: [self pushBack: whitespace]. self nextPCData]! ----- Method: XMLTokenizer>>nextEntityDeclaration (in category 'tokenizing dtd') ----- nextEntityDeclaration | entityName entityDef referenceClass reference | self skipSeparators. referenceClass := self peek == $% ifTrue: [ self next. self skipSeparators. DTDParameterEntityDeclaration] ifFalse: [DTDEntityDeclaration]. entityName := self nextLiteral. self skipSeparators. entityDef := (self peek == $" or: [self peek == $']) ifTrue: [self nextEntityValue] ifFalse: [self nextExternalId]. self skipUpTo: $>. reference := referenceClass name: entityName value: entityDef. reference registerIn: self. ^reference! ----- Method: XMLTokenizer>>nextEntityValue (in category 'tokenizing') ----- nextEntityValue | delimiterChar entityValueStream nextChar nextPeek referenceString entity entityValue | delimiterChar := self next. (delimiterChar == $" or: [delimiterChar == $']) ifFalse: [self errorExpected: 'Entity value delimiter expected.']. entityValueStream := WriteStream on: (String new). [ nextPeek := nextChar := self peek. nextChar ifNil: [self errorExpected: 'Character expected.']. nextChar == $& ifTrue: [ self next. self peek == $# ifTrue: [ nextPeek := nil. nextChar := self nextCharReference] ifFalse: [ referenceString := self nextLiteral. self next == $; ifFalse: [self errorExpected: ';']. entity := self entity: referenceString. entityValue := entity valueForContext: #entityValue. self pushStream: (ReadStream on: entityValue asString). nextPeek := nextChar := self next]] ifFalse: [ nextChar == $% ifTrue: [ self skipSeparators. referenceString := self nextLiteral. nextChar := self handleEntity: referenceString in: #entityValue. nextPeek := nextChar := self next] ifFalse: [self next]]. nextPeek == delimiterChar] whileFalse: [ nextChar ifNotNil: [entityValueStream nextPut: nextChar]]. ^entityValueStream contents! ----- Method: XMLTokenizer>>nextExternalId (in category 'tokenizing dtd') ----- nextExternalId | extDefType systemId dir | extDefType := self nextLiteral. extDefType = 'PUBLIC' ifTrue: [ self skipSeparators. self nextPubidLiteral. self skipSeparators. self peek == $> ifFalse: [ systemId := self nextSystemLiteral]]. extDefType = 'SYSTEM' ifTrue: [ self skipSeparators. systemId := self nextSystemLiteral]. systemId ifNil: [^nil]. "The rest of this method only applies if we're reading aFileStream" (self topStream isKindOf: FileStream) ifFalse: [^'']. dir := self topStream directory. ^(dir fileExists: systemId) ifTrue: [(dir readOnlyFileNamed: systemId) contentsOfEntireFile] ifFalse: ['']! ----- Method: XMLTokenizer>>nextIncludeSection: (in category 'tokenizing') ----- nextIncludeSection: parseSection | section | "Read the file up to the next include section delimiter and parse it if parseSection is true" section := self nextUpToAll: ']]>'. parseSection ifTrue: [ self pushStream: (ReadStream on: section)]! ----- Method: XMLTokenizer>>nextLiteral (in category 'tokenizing') ----- nextLiteral | resultStream nextChar | resultStream := (String new: 10) writeStream. ((nextChar := self peek) isLetter or: [nextChar == $_]) ifFalse: [self errorExpected: 'Name literal.']. [ | resultString | nextChar := self peek. (LiteralChars includes: nextChar) ifTrue: [ nextChar == $& ifTrue: [ nextChar := self next. resultStream nextPut: (self peek == $# ifTrue: [self nextCharReference] ifFalse: [^resultStream contents])] ifFalse: [ resultStream nextPut: self next]] ifFalse: [resultString := resultStream contents. resultString isEmpty ifTrue: [self errorExpected: 'Name literal'] ifFalse: [^resultString]]] repeat! ----- Method: XMLTokenizer>>nextMarkupDeclaration (in category 'tokenizing dtd') ----- nextMarkupDeclaration | declType | declType := self nextLiteral. self validating ifFalse: [^self skipMarkupDeclaration]. declType = 'ENTITY' ifTrue: [self nextEntityDeclaration] ifFalse: [self skipMarkupDeclaration]! ----- Method: XMLTokenizer>>nextName (in category 'tokenizing') ----- nextName | nextChar | nameBuffer reset. self peek == $. ifTrue: [self malformedError: 'Character expected.']. [(nextChar := self peek) ifNil: [self errorExpected: 'Character expected.']. NameDelimiters includes: nextChar] whileFalse: [ nameBuffer nextPut: self next]. ^self fastStreamStringContents: nameBuffer! ----- Method: XMLTokenizer>>nextNode (in category 'tokenizing') ----- nextNode | nextChar | "Skip < " self next. nextChar := self peek. nextChar == $!! ifTrue: [ "Skip !!" self next. nextChar := self peek. nextChar == $- ifTrue: [^self nextComment]. nextChar == $[ ifTrue: [^self nextCDataOrConditional]. ^self parsingMarkup ifTrue: [self nextMarkupDeclaration] ifFalse: [self nextDocType]]. nextChar == $? ifTrue: [^self nextPI]. ^self nextTag! ----- Method: XMLTokenizer>>nextPCData (in category 'tokenizing') ----- nextPCData | resultStream nextChar referenceString entity entityValue nextPeek | resultStream := (String new: 10) writeStream. self validating ifFalse: [ [self peek == $<] whileFalse: [resultStream nextPut: self next]. ^self handlePCData: resultStream contents]. [ nextPeek := nextChar := self peek. nextChar ifNil: [self errorExpected: 'Character expected.']. nextChar == $& ifTrue: [ self next. self peek == $# ifTrue: [ nextPeek := nil. nextChar := self nextCharReference] ifFalse: [ referenceString := self nextLiteral. self next == $; ifFalse: [self errorExpected: ';']. entity := self entity: referenceString. entityValue := entity valueForContext: #content. (self class isCharEscape: entityValue) ifTrue: [ nextPeek := nil. nextChar := entityValue first] ifFalse: [ entityValue := entityValue asString. entityValue isEmpty ifTrue: [nextPeek := nextChar := nil] ifFalse: [ self pushStream: (ReadStream on: entityValue asString). nextPeek := nextChar := self peek]]]] ifFalse: [nextPeek == $< ifFalse: [self next]]. nextPeek == $<] whileFalse: [ nextChar ifNotNil: [resultStream nextPut: nextChar]]. self handlePCData: resultStream contents! ----- Method: XMLTokenizer>>nextPI (in category 'tokenizing') ----- nextPI | piTarget piData | "Skip ?" self next. piTarget := self nextLiteral. piTarget asUppercase = 'XML' ifTrue: [^self nextXMLDecl]. self skipSeparators. piData := self nextUpToAll: '?>'. self handlePI: piTarget data: piData! ----- Method: XMLTokenizer>>nextPubidLiteral (in category 'tokenizing') ----- nextPubidLiteral ^self nextAttributeValue! ----- Method: XMLTokenizer>>nextSystemLiteral (in category 'tokenizing') ----- nextSystemLiteral ^self nextAttributeValue! ----- Method: XMLTokenizer>>nextTag (in category 'tokenizing') ----- nextTag | tagName attributes nextChar namespaces | (self peek = $/) ifTrue: [^self nextEndTag]. tagName := self nextName. self skipSeparators. attributes := Dictionary new: 33. namespaces := Dictionary new: 5. [(nextChar := self peek) == $> or: [nextChar == $/]] whileFalse: [ self checkAndExpandReference: #content. self nextAttributeInto: attributes namespaces: namespaces. self skipSeparators.]. self handleStartTag: tagName attributes: attributes namespaces: namespaces. self next == $/ ifTrue: [ self handleEndTag: tagName. self next]. ! ----- Method: XMLTokenizer>>nextTrimmedBlanksUpTo: (in category 'streaming') ----- nextTrimmedBlanksUpTo: delimiter | resultStream nextChar | resultStream := WriteStream on: (String new: 10). nextChar := nil. [(nextChar := self next) == delimiter] whileFalse: [ nextChar == $ ifFalse: [ resultStream nextPut: nextChar]]. nextChar == delimiter ifFalse: [self parseError: 'XML no delimiting ' , delimiter printString , ' found']. ^resultStream contents ! ----- Method: XMLTokenizer>>nextUpTo: (in category 'streaming') ----- nextUpTo: delimiter | resultStream nextChar | resultStream := WriteStream on: (String new: 10). [self atEnd or: [(nextChar := self next) == delimiter]] whileFalse: [resultStream nextPut: nextChar]. nextChar == delimiter ifFalse: [self parseError: 'XML no delimiting ' , delimiter printString , ' found']. ^resultStream contents ! ----- Method: XMLTokenizer>>nextUpToAll: (in category 'streaming') ----- nextUpToAll: delimitingString | string | self unpeek. string := self upToAll: delimitingString. string ifNil: [self parseError: 'XML no delimiting ' , delimitingString printString , ' found']. ^string! ----- Method: XMLTokenizer>>nextWhitespace (in category 'tokenizing') ----- nextWhitespace | nextChar resultStream resultString| resultStream := (String new: 10) writeStream. [((nextChar := self peek) ~~ nil) and: [SeparatorTable includes: nextChar]] whileTrue: [resultStream nextPut: nextChar. self next]. (nestedStreams == nil or: [self atEnd not]) ifFalse: [self checkNestedStream. self nextWhitespace]. resultString := resultStream contents. resultString isEmpty ifFalse: [self handleWhitespace: resultString]. ^resultString! ----- Method: XMLTokenizer>>nextXMLDecl (in category 'tokenizing') ----- nextXMLDecl | attributes nextChar namespaces | self skipSeparators. attributes := Dictionary new. namespaces := Dictionary new. [(nextChar := self peek) == $?] whileFalse: [ self nextAttributeInto: attributes namespaces: namespaces. self skipSeparators.]. self next. self next == $> ifFalse: [self errorExpected: '> expected.']. (attributes includesKey: 'encoding') ifTrue: [self streamEncoding: (attributes at: 'encoding')]. self handleXMLDecl: attributes namespaces: namespaces ! ----- Method: XMLTokenizer>>parameterEntities (in category 'entities') ----- parameterEntities parameterEntities ifNil: [parameterEntities := Dictionary new]. ^parameterEntities! ----- Method: XMLTokenizer>>parameterEntity: (in category 'entities') ----- parameterEntity: refName ^self parameterEntities at: refName ifAbsent: [self parseError: 'XML undefined parameter entity ' , refName printString]! ----- Method: XMLTokenizer>>parameterEntity:put: (in category 'entities') ----- parameterEntity: refName put: aReference "Only the first declaration of an entity is valid so if there is already one don't register the new value." self parameterEntities at: refName ifAbsentPut: [aReference]! ----- Method: XMLTokenizer>>parseError: (in category 'errors') ----- parseError: errorString SAXParseException signal: errorString! ----- Method: XMLTokenizer>>parseStream: (in category 'accessing') ----- parseStream: aStream self stream: aStream! ----- Method: XMLTokenizer>>parsingMarkup (in category 'private') ----- parsingMarkup ^parsingMarkup! ----- Method: XMLTokenizer>>peek (in category 'streaming') ----- peek "Return the next character from the current input stream. If the current stream poop to next nesting level if there is one. Due to the potential nesting of original document, included documents and replacment texts the streams are held in a stack representing the nested streams. The current stream is the top one." peekChar ifNil: [ nestedStreams ifNotNil: [self checkNestedStream]. ^peekChar := stream next] ifNotNil: [^peekChar]! ----- Method: XMLTokenizer>>popNestingLevel (in category 'streaming') ----- popNestingLevel self hasNestedStreams ifTrue: [ self stream close. self stream: self nestedStreams removeLast. self nestedStreams size > 0 ifFalse: [nestedStreams := nil]]! ----- Method: XMLTokenizer>>pushBack: (in category 'streaming') ----- pushBack: aString "Fixed to push the string before the peek char (if any)." | pushBackString | pushBackString := peekChar ifNil: [aString] ifNotNil: [aString, peekChar asString]. peekChar := nil. self pushStream: (ReadStream on: pushBackString)! ----- Method: XMLTokenizer>>pushStream: (in category 'streaming') ----- pushStream: newStream "Continue parsing from the new nested stream." self unpeek. self nestedStreams addLast: self stream. self stream: newStream! ----- Method: XMLTokenizer>>readNumberBase: (in category 'private') ----- readNumberBase: base "Read a hex number from stream until encountering $; " | value digit | base = 10 ifFalse: [ | numberString | numberString := self nextUpTo: $;. self stream skip: -1. ^Integer readFrom: numberString asUppercase readStream base: base. ]. value := 0. digit := DigitTable at: self peek asciiValue. digit < 0 ifTrue: [self error: 'At least one digit expected here']. self next. value := digit. [digit := DigitTable at: self peek asciiValue. digit < 0 ifTrue: [^value] ifFalse: [ self next. value := value * base + digit] ] repeat. ^ value! ----- Method: XMLTokenizer>>skipMarkupDeclaration (in category 'tokenizing dtd') ----- skipMarkupDeclaration self skipUpTo: $>! ----- Method: XMLTokenizer>>skipSeparators (in category 'streaming') ----- skipSeparators | nextChar | [((nextChar := self peek) ~~ nil) and: [SeparatorTable includes: nextChar]] whileTrue: [self next]. (nestedStreams == nil or: [self atEnd not]) ifFalse: [ self checkNestedStream. self skipSeparators]! ----- Method: XMLTokenizer>>skipUpTo: (in category 'streaming') ----- skipUpTo: delimiter | nextChar | self unpeek. [self atEnd or: [(nextChar := self next) == delimiter]] whileFalse: []. nextChar == delimiter ifFalse: [self parseError: 'XML no delimiting ' , delimiter printString , ' found'] ! ----- Method: XMLTokenizer>>startParsingMarkup (in category 'private') ----- startParsingMarkup parsingMarkup := true! ----- Method: XMLTokenizer>>stream (in category 'private') ----- stream ^stream! ----- Method: XMLTokenizer>>stream: (in category 'private') ----- stream: newStream "Continue parsing from the new nested stream." stream := newStream! ----- Method: XMLTokenizer>>stream:upToAll: (in category 'streaming') ----- stream: aStream upToAll: aCollection "Answer a subcollection from the current access position to the occurrence (not inclusive) of aCollection. If aCollection is not in the stream, answer nil." | startPos endMatch result | startPos := aStream position. (aStream match: aCollection) ifTrue: [endMatch := aStream position. aStream position: startPos. result := aStream next: endMatch - startPos - aCollection size. aStream position: endMatch. ^ result] ifFalse: [ aStream position: startPos. ^nil]! ----- Method: XMLTokenizer>>streamEncoding: (in category 'streaming') ----- streamEncoding: encodingString Smalltalk at: #TextConverter ifPresent: [:tc | (stream respondsTo: #converter:) ifTrue: [ | converterClass | converterClass := tc defaultConverterClassForEncoding: encodingString asLowercase. converterClass ifNotNil: [stream converter: converterClass new]]]! ----- Method: XMLTokenizer>>topStream (in category 'streaming') ----- topStream ^self hasNestedStreams ifTrue: [self nestedStreams first] ifFalse: [self stream]! ----- Method: XMLTokenizer>>unpeek (in category 'streaming') ----- unpeek "Fixed to use nested stream since multi-byte streams do not properly override pushBack: to deal with multi-byte characters." peekChar ifNotNil: [self pushBack: '']! ----- Method: XMLTokenizer>>upToAll: (in category 'streaming') ----- upToAll: delimitingString "Answer a subcollection from the current access position to the occurrence (if any, but not inclusive) of delimitingString. If delimitingString is not in the stream, answer the entire rest of the stream." | result | self hasNestedStreams ifFalse: [ result := self stream: self stream upToAll: delimitingString. result ifNil: [self parseError: 'XML no delimiting ' , delimitingString printString , ' found']. ^result]. result := self stream: self stream upToAll: delimitingString. result ifNotNil: [^result]. result := String streamContents: [:resultStream | resultStream nextPutAll: self stream upToEnd. self atEnd ifTrue: [self parseError: 'XML no delimiting ' , delimitingString printString , ' found']. self stream position timesRepeat: [ self atEnd ifFalse: [ resultStream nextPut: self next]]]. self pushBack: result. ^self upToAll: delimitingString! ----- Method: XMLTokenizer>>usesNamespaces (in category 'testing') ----- usesNamespaces ^false! ----- Method: XMLTokenizer>>validating (in category 'testing') ----- validating ^validating! ----- Method: XMLTokenizer>>validating: (in category 'accessing') ----- validating: aBoolean validating := aBoolean! Object subclass: #XMLWriter instanceVariableNames: 'stream stack scope scanner canonical currentIndent indentString' classVariableNames: 'XMLTranslation XMLTranslationMap' poolDictionaries: '' category: 'XML-Parser'! ----- Method: XMLWriter class>>initialize (in category 'class initialization') ----- initialize "XMLWriter initialize" XMLTranslation := Dictionary new. XMLTranslation at: Character cr put: ''; at: Character lf put: '
'; at: Character tab put: '	'; at: $& put: '&'; at: $< put: '<'; at: $> put: '>'; " at: $' put: '''; " at: $" put: '"'. XMLTranslationMap := ByteArray new: 256. XMLTranslation keysDo:[:ch| XMLTranslationMap at: ch asciiValue+1 put: 1]. ! ----- Method: XMLWriter class>>on: (in category 'instance creation') ----- on: aStream ^self basicNew initialize stream: aStream! ----- Method: XMLWriter>>attribute:value: (in category 'writing xml') ----- attribute: attributeName value: attributeValue self stream space; nextPutAll: attributeName. self eq; putAsXMLString: attributeValue! ----- Method: XMLWriter>>canonical (in category 'accessing') ----- canonical ^canonical! ----- Method: XMLWriter>>canonical: (in category 'accessing') ----- canonical: aBoolean canonical := aBoolean! ----- Method: XMLWriter>>cdata: (in category 'writing xml') ----- cdata: aString self startCData. self stream nextPutAll: aString. self endCData! ----- Method: XMLWriter>>comment: (in category 'writing xml') ----- comment: aString self startComment. self stream nextPutAll: aString. self endComment! ----- Method: XMLWriter>>declareNamespace:uri: (in category 'namespaces') ----- declareNamespace: ns uri: uri self scope declareNamespace: ns uri: uri! ----- Method: XMLWriter>>defaultNamespace (in category 'namespaces') ----- defaultNamespace ^self scope defaultNamespace! ----- Method: XMLWriter>>defaultNamespace: (in category 'namespaces') ----- defaultNamespace: ns "Declare the default namespace." self scope defaultNamespace: ns! ----- Method: XMLWriter>>endCData (in category 'private tags') ----- endCData self stream nextPutAll: ']]>'! ----- Method: XMLWriter>>endComment (in category 'private tags') ----- endComment self stream nextPutAll: ' -->'! ----- Method: XMLWriter>>endDecl: (in category 'writing dtd') ----- endDecl: type self endTag! ----- Method: XMLWriter>>endDeclaration (in category 'writing dtd') ----- endDeclaration self stream cr; nextPut: $]. self endTag! ----- Method: XMLWriter>>endEmptyTag: (in category 'writing xml') ----- endEmptyTag: tagName self popTag: tagName. self stream nextPutAll: '/>'. self canonical ifFalse: [self stream space]! ----- Method: XMLWriter>>endPI (in category 'private tags') ----- endPI self stream nextPutAll: ' ?>'! ----- Method: XMLWriter>>endTag (in category 'writing xml') ----- endTag self stream nextPutAll: '>'. self indent. "self canonical ifFalse: [self stream space]"! ----- Method: XMLWriter>>endTag: (in category 'writing xml') ----- endTag: tagName self outdent. self endTag: tagName xmlns: nil! ----- Method: XMLWriter>>endTag:xmlns: (in category 'writing xml') ----- endTag: tagName xmlns: xmlns self popTag: tagName. self stream nextPutAll: '</'. (xmlns notNil and: [xmlns ~= self defaultNamespace]) ifTrue: [self stream nextPutAll: xmlns; nextPut: $:]. stream nextPutAll: tagName. self endTag. ! ----- Method: XMLWriter>>enterScope (in category 'namespaces') ----- enterScope self scope enterScope! ----- Method: XMLWriter>>eq (in category 'private') ----- eq self stream nextPut: $=! ----- Method: XMLWriter>>flush (in category 'writing xml') ----- flush self stream flush! ----- Method: XMLWriter>>indent (in category 'private') ----- indent currentIndent ifNotNil: [currentIndent := currentIndent +1]! ----- Method: XMLWriter>>indentString: (in category 'accessing') ----- indentString: aString currentIndent := 0. indentString := aString! ----- Method: XMLWriter>>indentTab (in category 'accessing') ----- indentTab self indentString: (String with: Character tab)! ----- Method: XMLWriter>>initialize (in category 'initialize') ----- initialize stack := OrderedCollection new. canonical := false. scope := XMLNamespaceScope new! ----- Method: XMLWriter>>leaveScope (in category 'namespaces') ----- leaveScope self scope leaveScope! ----- Method: XMLWriter>>outdent (in category 'private') ----- outdent currentIndent ifNotNil: [ stream cr. currentIndent := currentIndent-1. self writeIndent. currentIndent := currentIndent-1.]! ----- Method: XMLWriter>>pcData: (in category 'writing xml') ----- pcData: aString | lastIndex nextIndex | lastIndex := 1. "Unroll the first search to avoid copying" nextIndex := aString class findFirstInString: aString inSet: XMLTranslationMap startingAt: lastIndex. nextIndex = 0 ifTrue:[^self stream nextPutAll: aString]. [self stream nextPutAll: (aString copyFrom: lastIndex to: nextIndex-1). self stream nextPutAll: (XMLTranslation at: (aString at: nextIndex)). lastIndex := nextIndex + 1. nextIndex := aString class findFirstInString: aString inSet: XMLTranslationMap startingAt: lastIndex. nextIndex = 0] whileFalse. self stream nextPutAll: (aString copyFrom: lastIndex to: aString size).! ----- Method: XMLWriter>>pi:data: (in category 'writing xml') ----- pi: piTarget data: piData self startPI: piTarget. self stream nextPutAll: piData. self endPI! ----- Method: XMLWriter>>popTag: (in category 'private') ----- popTag: tagName | stackTop | stackTop := self stack isEmpty ifTrue: ['<empty>'] ifFalse: [self stack last]. ^stackTop = tagName ifTrue: [self stack removeLast] ifFalse: [self error: 'Closing tag "' , tagName , '" does not match "' , stackTop]! ----- Method: XMLWriter>>pushTag: (in category 'private') ----- pushTag: tagName self stack add: tagName! ----- Method: XMLWriter>>putAsXMLString: (in category 'private') ----- putAsXMLString: aValue self stream nextPut: $". self pcData: aValue. self stream nextPut: $"! ----- Method: XMLWriter>>scope (in category 'private') ----- scope ^scope! ----- Method: XMLWriter>>stack (in category 'private') ----- stack ^stack! ----- Method: XMLWriter>>startCData (in category 'private tags') ----- startCData self stream nextPutAll: '<!![CDATA['! ----- Method: XMLWriter>>startComment (in category 'private tags') ----- startComment self stream nextPutAll: '<-- '! ----- Method: XMLWriter>>startDecl: (in category 'writing dtd') ----- startDecl: type self stream nextPutAll: '<!!'; nextPutAll: type asUppercase; space! ----- Method: XMLWriter>>startDecl:named: (in category 'writing dtd') ----- startDecl: type named: aString self stream nextPutAll: '<!!'; nextPutAll: type asUppercase; space; nextPutAll: aString; space! ----- Method: XMLWriter>>startDeclaration: (in category 'writing dtd') ----- startDeclaration: dtdName self startDecl: 'DOCTYPE' named: dtdName. self stream nextPut: $[; cr! ----- Method: XMLWriter>>startElement:attributeList: (in category 'writing xml') ----- startElement: elementName attributeList: attributeList self canonical ifFalse: [self stream cr]. self startTag: elementName. attributeList keys asArray sort do: [:key | self attribute: key value: (attributeList at: key)]! ----- Method: XMLWriter>>startPI: (in category 'private tags') ----- startPI: identifier self stream nextPutAll: '<?'; nextPutAll: identifier; space! ----- Method: XMLWriter>>startTag: (in category 'writing xml') ----- startTag: tagName self writeIndent. self startTag: tagName xmlns: nil! ----- Method: XMLWriter>>startTag:xmlns: (in category 'writing xml') ----- startTag: tagName xmlns: xmlns self stream nextPut: $<. (xmlns notNil and: [xmlns ~= self scope defaultNamespace]) ifTrue: [self stream nextPutAll: xmlns; nextPut: $:]. self stream nextPutAll: tagName. "self canonical ifFalse: [self stream space]." self pushTag: tagName! ----- Method: XMLWriter>>stream (in category 'accessing') ----- stream ^stream! ----- Method: XMLWriter>>stream: (in category 'accessing') ----- stream: aStream stream := aStream! ----- Method: XMLWriter>>writeIndent (in category 'private') ----- writeIndent currentIndent ifNotNil: [ currentIndent timesRepeat: [self stream nextPutAll: indentString]]! ----- Method: XMLWriter>>xmlDeclaration: (in category 'writing xml') ----- xmlDeclaration: versionString self canonical ifFalse: [ self startPI: 'xml'; attribute: 'version' value: versionString; endPI]! ----- Method: XMLWriter>>xmlDeclaration:encoding: (in category 'writing xml') ----- xmlDeclaration: versionString encoding: encodingString self canonical ifFalse: [ self startPI: 'xml'; attribute: 'version' value: versionString; attribute: 'encoding' value: encodingString; endPI. self stream flush]! ----- Method: ByteString>>applyLanguageInfomation: (in category '*xml-parser') ----- applyLanguageInfomation: languageEnvironment ! Warning subclass: #SAXWarning instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'XML-Parser'! ClassTestCase subclass: #XMLParserTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'XML-Parser'! ----- Method: XMLParserTest>>addressBookXML (in category 'source') ----- addressBookXML ^'<addressbook> <person employee-number="A0000" family-name="Gates" first-name="Bob"> <contact-info><!!--Confidential--></contact-info> <address city="Los Angeles" number="1239" state="CA" street="Pine Rd."/> <job-info employee-type="Full-Time" is-manager="no" job-description="Manager"/> <manager employee-number="A0000"/> </person> <person employee-number="A7000" family-name="Brown" first-name="Robert" middle-initial="L."> <contact-info> <email address="robb(a)iro.ibm.com"/> <home-phone number="03-3987873"/> </contact-info> <address city="New York" number="344" state="NY" street="118 St."/> <job-info employee-type="Full-Time" is-manager="yes" job-description="Group Leader"/> <manager employee-number="A0000"/> </person> <person employee-number="A7890" family-name="DePaiva" first-name="Kassie" middle-initial="W."> <contact-info><!!-- Kassie''s agent phone: 03-987654 --></contact-info> <address city="Los Angeles" number="1234" state="CA" street="Pine Rd."/> <job-info employee-type="Full-Time" is-manager="no" job-description="Actor"/> <manager employee-number="A0000"/> <misc-info>One of the most talented actresses on Daytime. Kassie plays the devious and beautiful Blair Cramer on ABC's "One Life To Live."</misc-info> </person> <person employee-number="A7987" family-name="Smith" first-name="Joe"> <contact-info> <email address="joes(a)iro.ibm.com"/> <mobile-phone number="888-7657765"/> <home-phone number="03-8767898"/> <home-phone number="03-8767871"/> </contact-info> <address city="New York" number="12789" state="NY" street="W. 15th Ave."/> <job-info employee-type="Part-Time" is-manager="no" job-description="Hacker"/> <manager employee-number="A7000"/> </person> </addressbook> '! ----- Method: XMLParserTest>>addressBookXMLWithDTD (in category 'source') ----- addressBookXMLWithDTD ^'<?xml version="1.0" encoding="UTF-8"?> <!!DOCTYPE addressbook SYSTEM "addressbook.dtd"> <?xml-stylesheet type="text/xsl" href="demo.xsl"?> <addressbook> <person employee-number="A0000" family-name="Gates" first-name="Bob"> <contact-info><!!--Confidential--></contact-info> <address city="Los Angeles" number="1239" state="CA" street="Pine Rd."/> <job-info employee-type="Full-Time" is-manager="no" job-description="Manager"/> <manager employee-number="A0000"/> </person> <person employee-number="A7000" family-name="Brown" first-name="Robert" middle-initial="L."> <contact-info> <email address="robb(a)iro.ibm.com"/> <home-phone number="03-3987873"/> </contact-info> <address city="New York" number="344" state="NY" street="118 St."/> <job-info employee-type="Full-Time" is-manager="yes" job-description="Group Leader"/> <manager employee-number="A0000"/> </person> <person employee-number="A7890" family-name="DePaiva" first-name="Kassie" middle-initial="W."> <contact-info><!!-- Kassie''s agent phone: 03-987654 --></contact-info> <address city="Los Angeles" number="1234" state="CA" street="Pine Rd."/> <job-info employee-type="Full-Time" is-manager="no" job-description="Actor"/> <manager employee-number="A0000"/> <misc-info>One of the most talented actresses on Daytime. Kassie plays the devious and beautiful Blair Cramer on ABC's "One Life To Live."</misc-info> </person> <person employee-number="A7987" family-name="Smith" first-name="Joe"> <contact-info> <email address="joes(a)iro.ibm.com"/> <mobile-phone number="888-7657765"/> <home-phone number="03-8767898"/> <home-phone number="03-8767871"/> </contact-info> <address city="New York" number="12789" state="NY" street="W. 15th Ave."/> <job-info employee-type="Part-Time" is-manager="no" job-description="Hacker"/> <manager employee-number="A7000"/> </person> </addressbook> '! ----- Method: XMLParserTest>>testExampleAddressBook (in category 'tests') ----- testExampleAddressBook | tokenizer | "self debug: #testExampleAddressBook" tokenizer := XMLTokenizer on: self addressBookXML readStream. "We enumerate the first characters of the addressbook example. The file being parsed begins with <addressbook" self assert: tokenizer next = $<. self assert: tokenizer next = $a. self assert: tokenizer next = $d. self assert: tokenizer next = $d. self assert: tokenizer next = $r. "This should not raise an exception." [tokenizer next notNil] whileTrue: [].! ----- Method: XMLParserTest>>testExampleAddressBookWithDTD (in category 'tests') ----- testExampleAddressBookWithDTD | tokenizer | "XMLTokenizer exampleAddressBookWithDTD" tokenizer := XMLTokenizer on: self addressBookXMLWithDTD readStream. "This should not raise an exception." [tokenizer next notNil] whileTrue: [].! ----- Method: XMLParserTest>>testParsing (in category 'tests') ----- testParsing | xmlDocument root firstPerson numberOfPersons | "self debug: #testParsing" xmlDocument := XMLDOMParser parseDocumentFrom: self addressBookXML readStream. self assert: (xmlDocument isKindOf: XMLDocument). root := xmlDocument root. self assert: (root class == XMLElement). "the tag has to be a symbol!!" self assert: (root firstTagNamed: 'person') isNil. self assert: (root firstTagNamed: 'addressbook') isNil. self assert: (root firstTagNamed: #addressbook) == root. numberOfPersons := 0. root tagsNamed: #person do: [:p | numberOfPersons := numberOfPersons + 1]. self assert: numberOfPersons = 4. firstPerson := root firstTagNamed: #person. self assert: (firstPerson attributeAt: #'employee-number') = 'A0000'. self assert: (firstPerson attributeAt: #'family-name') = 'Gates'. self assert: (firstPerson attributeAt: #'first-name') = 'Bob'.! ----- Method: XMLParserTest>>testParsingCharacters (in category 'tests') ----- testParsingCharacters | parser | "This test is actually not that useful. This is not the proper way of using the parser. This test is here just for specification purpose" "self debug: #testParsingCharacters" parser := XMLParser on: self addressBookXML readStream. self assert: parser next = $<. self assert: parser next = $a. self assert: parser next = $d. self assert: parser next = $d. self assert: parser next = $r.! ----- Method: XMLParserTest>>testPrintElements (in category 'tests') ----- testPrintElements | node | node:= (XMLElement new) name: 'foo'; setAttributes: (Dictionary new); yourself. self assert: node asString withBlanksTrimmed = '<foo/>'. node:= (XMLElement new) name: 'foo'; setAttributes: (Dictionary newFromPairs: {'id'. '123'}); yourself. self assert: node asString withBlanksTrimmed = '<foo id="123"/>'. node:= (XMLElement new) name: 'foo'; addContent: (XMLStringNode string: 'Hello World'); setAttributes: (Dictionary new); yourself. self assert: node asString withBlanksTrimmed = '<foo>Hello World</foo>'. node:= (XMLElement new) name: 'foo'; addContent: (XMLStringNode string: 'Hello World'); setAttributes: (Dictionary newFromPairs: {'id'. '123'}); yourself. self assert: node asString withBlanksTrimmed = '<foo id="123">Hello World</foo>'. !

1 0

Squeak 4.6: SqueakSSL-Tests-ul.18.mcz
by commits＠source.squeak.org 05 Jun '15

05 Jun '15

Chris Muller uploaded a new version of SqueakSSL-Tests to project Squeak 4.6: http://source.squeak.org/squeak46/SqueakSSL-Tests-ul.18.mcz ==================== Summary ==================== Name: SqueakSSL-Tests-ul.18 Author: ul Time: 15 October 2014, 9:14:41.944 pm UUID: 3a075d4b-2fd5-4b84-9f84-ffd8f5a95a50 Ancestors: SqueakSSL-Tests-ar.17 Yahoo OpenID uses yahoo.com instead of yahooapis.com. ==================== Snapshot ==================== SystemOrganization addCategory: #'SqueakSSL-Tests'! TestCase subclass: #SqueakSSLTest instanceVariableNames: 'clientReadQueue serverWriteQueue serverReadQueue clientWriteQueue sslClient sslServer clientProcess serverProcess' classVariableNames: 'CertName' poolDictionaries: '' category: 'SqueakSSL-Tests'! ----- Method: SqueakSSLTest class>>certName (in category 'accessing') ----- certName "The name of the cert to use for the test" ^CertName! ----- Method: SqueakSSLTest class>>certName: (in category 'accessing') ----- certName: aString "The name of the cert to use for the test. SqueakSSLTest certName: nil. SqueakSSLTest certName: 'Internet Widgits Pty'. SqueakSSLTest certName: '/home/andreas/certs/testcert.pem'. " CertName := aString! ----- Method: SqueakSSLTest class>>ensureValidCert (in category 'utilities') ----- ensureValidCert "Ensure that we have a valid certificate for the tests" CertName := SqueakSSL ensureSampleCert. ! ----- Method: SqueakSSLTest>>certName (in category 'setup') ----- certName "Answer the name of the cert to use in tests" ^self class certName! ----- Method: SqueakSSLTest>>expectedFailures (in category 'setup') ----- expectedFailures "If we don't have a cert all the tests fail" SqueakSSL platformName = 'Mac OS' ifTrue:[ "The following tests all need certificate selection to work properly." ^#( testConnectAccept testEncryptDecrypt testMultiFrameDecrypt testSingleByteDecrypt testSplitTlsFrameRead testStreamAccept testStreamConnect testStreamTransfer ) ] ifFalse:[^#()].! ----- Method: SqueakSSLTest>>hasCertInfo (in category 'setup') ----- hasCertInfo "Returns true if we have cert information available" ^self class certName notNil! ----- Method: SqueakSSLTest>>port (in category 'setup') ----- port ^8844! ----- Method: SqueakSSLTest>>secureSocket (in category 'setup') ----- secureSocket ^SqueakSSL secureSocket! ----- Method: SqueakSSLTest>>secureSocketStream (in category 'setup') ----- secureSocketStream ^SqueakSSL secureSocketStream! ----- Method: SqueakSSLTest>>setUp (in category 'setup') ----- setUp "The default setUp" self class ensureValidCert. clientReadQueue := serverWriteQueue := SharedQueue new. serverReadQueue := clientWriteQueue := SharedQueue new. sslClient := SqueakSSL new. sslClient readBlock:[:buffer| | inbuf | inbuf := clientReadQueue next. buffer replaceFrom: 1 to: inbuf size with: inbuf startingAt: 1. inbuf size. ]. sslClient writeBlock:[:buffer :count| clientWriteQueue nextPut: (buffer copyFrom: 1 to: count) ]. sslServer := SqueakSSL new. sslServer certName: self certName. sslServer readBlock:[:buffer| | inbuf | inbuf := serverReadQueue next. buffer replaceFrom: 1 to: inbuf size with: inbuf startingAt: 1. inbuf size. ]. sslServer writeBlock:[:buffer :count| serverWriteQueue nextPut: (buffer copyFrom: 1 to: count) ]. ! ----- Method: SqueakSSLTest>>tearDown (in category 'setup') ----- tearDown "Shut down everything" clientProcess ifNotNil:[clientProcess terminate]. serverProcess ifNotNil:[serverProcess]. sslClient ifNotNil:[sslClient destroy]. sslServer ifNotNil:[sslServer destroy]. ! ----- Method: SqueakSSLTest>>testConnectAccept (in category 'tests') ----- testConnectAccept "Tests the SqueakSSL server and client handshake. " | buf process | process := Processor activeProcess. "Separate queues so we can watch the handshake" clientReadQueue := SharedQueue new. serverWriteQueue := SharedQueue new. serverReadQueue := SharedQueue new. clientWriteQueue := SharedQueue new. "Start the connect and accept loop" clientProcess := [ [sslClient connect] on: Error do:[:ex| process signalException: ex]. "uncomment for debugging" ] forkAt: Processor activePriority + 1. serverProcess := [ [sslServer accept] on: Error do:[:ex| process signalException: ex]. "uncomment for debugging" ] forkAt: Processor activePriority + 1. "Do the handshake" buf := clientWriteQueue next. serverReadQueue nextPut: buf. buf := serverWriteQueue next. clientReadQueue nextPut: buf. buf := clientWriteQueue next. serverReadQueue nextPut: buf. buf := serverWriteQueue next. clientReadQueue nextPut: buf. "Both client and server should now be connected" self assert:(clientProcess isTerminated). self assert:(serverProcess isTerminated). self assert: sslClient isConnected. self assert: sslServer isConnected. ! ----- Method: SqueakSSLTest>>testEncryptDecrypt (in category 'tests') ----- testEncryptDecrypt "Simple encrypt/decrypt test with a single frame of data. Ensures that the common case works properly." | encrypted decrypted | self testConnectAccept. encrypted := sslClient encrypt: 'Client to Server'. decrypted := sslServer decrypt: encrypted. self assert: decrypted = 'Client to Server'. encrypted := sslServer encrypt: 'Server to Client'. decrypted := sslClient decrypt: encrypted. self assert: decrypted = 'Server to Client'. ! ----- Method: SqueakSSLTest>>testFaceBookAPI (in category 'tests') ----- testFaceBookAPI "Facebook sends incomplete data during SSL handshake. Useful for testing an edge condition in SqueakSSL." Smalltalk at: #WebClient ifPresent:[:webClient| self shouldnt:[ [webClient httpGet: 'https://graph.facebook.com/oauth/access_token'] "Allow certificate errors on the Mac since cert validation isn't implemented yet." on: SqueakSSLCertificateError do:[:ex| SqueakSSL platformName = 'Mac OS' ifTrue:[ex resume] ifFalse:[ex pass]]. ] raise: Error. ].. ! ----- Method: SqueakSSLTest>>testGooglePopStream (in category 'tests') ----- testGooglePopStream "This tests the dreaded data-in-last-handshake problem that some people have been seeing. Google mail (at times) sends the first data chunk together with the last handshake and the Windows SSL code did not handle that correctly" "self run: #testGooglePopStream" | hostName address socket response stream | hostName := 'pop.gmail.com'. address := NetNameResolver addressForName: hostName. socket := Socket newTCP. socket connectTo: address port: 995. socket waitForConnectionFor: 10. stream := self secureSocketStream on: socket. [ stream sslConnect. response := stream upToAll: String crlf. self assert: response notEmpty. ] ensure:[stream destroy]. ! ----- Method: SqueakSSLTest>>testMultiFrameDecrypt (in category 'tests') ----- testMultiFrameDecrypt "A test verifying that even if we feed multiple encrypted frames at once we get them one-by-one out of the decryptor. Mainly a test to ensure consistent plugin behavior." | encrypted decrypted | "Also does setup" self testConnectAccept. "Encrypt the text" encrypted := #( 'Hello World' 'This is a test' 'How do you do' ) collect:[:each| sslClient encrypt: each]. "Now feed the the encrypted contents at once to the decryptor" decrypted := sslServer decrypt: (encrypted inject:'' into:[:a :b| a, b]). "This should only decrypt the first frame" self assert: decrypted = 'Hello World'. "The second time (with no input) we should get the second piece." decrypted := sslServer decrypt: ''. self assert: decrypted = 'This is a test'. "The third time (with extra input) we should get the last piece from the first round." encrypted := sslClient encrypt: 'More data is coming'. decrypted := sslServer decrypt: encrypted. self assert: decrypted = 'How do you do'. "And finally the last piece" decrypted := sslServer decrypt: ''. self assert: decrypted = 'More data is coming'. ! ----- Method: SqueakSSLTest>>testSSLSockets (in category 'tests') ----- testSSLSockets "Connect client and server" | client listener server sema | [listener := SecureSocket newTCP. listener listenOn: self port backlogSize: 4. client := SecureSocket newTCP. client connectTo: #[127 0 0 1] port: self port. server := listener waitForAcceptFor: 1. "Perform SSL handshake" sema := Semaphore new. [client sslConnect. sema signal] fork. server sslAccept: self certName. sema wait. "Send data" client sendData: 'Hello World'. server waitForDataFor: 1. self assert: server receiveData = 'Hello World'. ] ensure:[ listener ifNotNil:[listener destroy]. client ifNotNil:[client destroy]. server ifNotNil:[server destroy]. ].! ----- Method: SqueakSSLTest>>testSingleByteDecrypt (in category 'tests') ----- testSingleByteDecrypt "A test verifying that even if we feed the decryptor with single bytes it produces the correct output. Mainly a test that the underlying plugin deals with corner cases correctly." | encrypted decrypted | "Also does setup" self testConnectAccept. "Encrypt the text" encrypted := sslClient encrypt: 'Hello World'. "Now feed the encrypted contents byte-by-byte into the decryptor" 1 to: encrypted size-1 do:[:i| decrypted := sslServer decrypt: (encrypted copyFrom: i to: i). self assert: decrypted isEmpty. ]. "And upon feeding the last byte we expect the result" decrypted := sslServer decrypt: (encrypted last: 1). self assert: decrypted = 'Hello World'.! ----- Method: SqueakSSLTest>>testSocketAccept (in category 'tests') ----- testSocketAccept "Tests the SecureSocketStream server handshake. " | process listener clientSocket serverSocket | process := Processor activeProcess. [listener := self secureSocket newTCP. listener listenOn: self port backlogSize: 4. clientSocket := Socket newTCP. clientSocket connectTo: #[127 0 0 1] port: self port. clientSocket waitForConnectionFor: 1. serverSocket := listener waitForAcceptFor: 1. self assert: clientSocket isConnected. self assert: serverSocket notNil. self assert: serverSocket isConnected. "Set up the client for the handshake" sslClient on: clientSocket. clientProcess := [ [sslClient connect] on: Error do:[:ex| process signalException: ex]. ] forkAt: Processor activePriority + 1. "Set up the server" serverSocket sslAccept: self certName. self assert: serverSocket isConnected. ] ensure:[ listener ifNotNil:[listener destroy]. clientSocket ifNotNil:[clientSocket destroy]. serverSocket ifNotNil:[serverSocket destroy]. ].! ----- Method: SqueakSSLTest>>testSocketConnect (in category 'tests') ----- testSocketConnect "Tests the SecureSocket client handshake. " | process listener clientSocket serverSocket | process := Processor activeProcess. [listener := Socket newTCP. listener listenOn: self port backlogSize: 4. clientSocket := self secureSocket newTCP. clientSocket connectTo: #[127 0 0 1] port: self port. clientSocket waitForConnectionFor: 1. serverSocket := listener waitForAcceptFor: 1. self assert: clientSocket isConnected. self assert: serverSocket notNil. self assert: serverSocket isConnected. "Set up the server for the handshake" sslServer on: serverSocket. serverProcess := [ [sslServer accept] on: Error do:[:ex| process signalException: ex]. "uncomment for debugging" ] forkAt: Processor activePriority + 1. "Set up the client using SecureSocketStream" clientSocket sslConnect. clientSocket isConnected. ] ensure:[ listener ifNotNil:[listener destroy]. clientSocket ifNotNil:[clientSocket destroy]. serverSocket ifNotNil:[serverSocket destroy]. ].! ----- Method: SqueakSSLTest>>testSplitTlsFrameRead (in category 'tests') ----- testSplitTlsFrameRead "Tests the SecureSocketStream client handshake. " | process listener clientSocket serverSocket secureStream char | process := Processor activeProcess. [listener := Socket newTCP. listener listenOn: self port backlogSize: 4. clientSocket := Socket newTCP. clientSocket connectTo: #[127 0 0 1] port: self port. clientSocket waitForConnectionFor: 1. serverSocket := listener waitForAcceptFor: 1. self assert: clientSocket isConnected. self assert: serverSocket notNil. self assert: serverSocket isConnected. "Set up the server for the handshake" sslServer on: serverSocket. serverProcess := [ | encrypted | [sslServer accept. encrypted := sslServer encrypt: 'Hello World'. 1 to: encrypted size do:[:i| sslServer writeData: (encrypted copyFrom: i to: i) count: 1. (Delay forMilliseconds: 10) wait. ]. ] on: Error do:[:ex| process signalException: ex]. "uncomment for debugging" ] forkAt: Processor activePriority + 1. "Set up the client using SecureSocketStream" secureStream := SecureSocketStream on: clientSocket. secureStream sslConnect. self assert: secureStream isConnected. char := secureStream next. self assert: char = $H. ] ensure:[ listener ifNotNil:[listener destroy]. clientSocket ifNotNil:[clientSocket destroy]. serverSocket ifNotNil:[serverSocket destroy]. secureStream ifNotNil:[secureStream destroy]. ].! ----- Method: SqueakSSLTest>>testStreamAccept (in category 'tests') ----- testStreamAccept "Tests the SecureSocketStream server handshake. " | process listener clientSocket serverSocket secureStream | process := Processor activeProcess. [listener := Socket newTCP. listener listenOn: self port backlogSize: 4. clientSocket := Socket newTCP. clientSocket connectTo: #[127 0 0 1] port: self port. clientSocket waitForConnectionFor: 1. serverSocket := listener waitForAcceptFor: 1. self assert: clientSocket isConnected. self assert: serverSocket notNil. self assert: serverSocket isConnected. "Set up the client for the handshake" sslClient on: clientSocket. clientProcess := [ [sslClient connect] on: Error do:[:ex| process signalException: ex]. ] forkAt: Processor activePriority + 1. "Set up the client using SecureSocketStream" secureStream := SecureSocketStream on: serverSocket. secureStream sslAccept: self certName. self assert: secureStream isConnected. ] ensure:[ listener ifNotNil:[listener destroy]. clientSocket ifNotNil:[clientSocket destroy]. serverSocket ifNotNil:[serverSocket destroy]. secureStream ifNotNil:[secureStream destroy]. ].! ----- Method: SqueakSSLTest>>testStreamConnect (in category 'tests') ----- testStreamConnect "Tests the SecureSocketStream client handshake. " | process listener clientSocket serverSocket secureStream | process := Processor activeProcess. [listener := Socket newTCP. listener listenOn: self port backlogSize: 4. clientSocket := Socket newTCP. clientSocket connectTo: #[127 0 0 1] port: self port. clientSocket waitForConnectionFor: 1. serverSocket := listener waitForAcceptFor: 1. self assert: clientSocket isConnected. self assert: serverSocket notNil. self assert: serverSocket isConnected. "Set up the server for the handshake" sslServer on: serverSocket. serverProcess := [ [sslServer accept] on: Error do:[:ex| process signalException: ex]. "uncomment for debugging" ] forkAt: Processor activePriority + 1. "Set up the client using SecureSocketStream" secureStream := SecureSocketStream on: clientSocket. secureStream sslConnect. self assert: secureStream isConnected. ] ensure:[ listener ifNotNil:[listener destroy]. clientSocket ifNotNil:[clientSocket destroy]. serverSocket ifNotNil:[serverSocket destroy]. secureStream ifNotNil:[secureStream destroy]. ].! ----- Method: SqueakSSLTest>>testStreamTransfer (in category 'tests') ----- testStreamTransfer "Tests the SecureSocketStream data transfer" | listener clientSocket serverSocket serverStream clientStream | [listener := Socket newTCP. listener listenOn: self port backlogSize: 4. clientSocket := Socket newTCP. clientSocket connectTo: #[127 0 0 1] port: self port. clientSocket waitForConnectionFor: 1. serverSocket := listener waitForAcceptFor: 1. self assert: clientSocket isConnected. self assert: serverSocket notNil. self assert: serverSocket isConnected. "Set up client and server streams" serverStream := self secureSocketStream on: serverSocket. serverProcess := [ [serverStream sslAccept: self certName] on: Error do:[:ex| serverStream destroy]. ] forkAt: Processor activePriority + 1. clientStream := self secureSocketStream on: clientSocket. clientStream sslConnect. self assert: clientStream isConnected. self assert: serverStream isConnected. clientStream nextPutAll: 'Hello World'; flush. self assert: (serverStream next: 11) = 'Hello World'. serverStream nextPutAll: 'The other way'; flush. self assert: (clientStream next: 13) = 'The other way'. ] ensure:[ listener ifNotNil:[listener destroy]. clientSocket ifNotNil:[clientSocket destroy]. serverSocket ifNotNil:[serverSocket destroy]. clientStream ifNotNil:[clientStream destroy]. serverStream ifNotNil:[serverStream destroy]. ].! ----- Method: SqueakSSLTest>>testYahooOpenID (in category 'tests') ----- testYahooOpenID "Yahoo sends an SSL shutdown sequence which we didn't handle in the past. Also, there were some issues with SecureSocketStream that were unearthed by using it via WebClient's chunking method (not easy to reproduce without WC)." Smalltalk at: #WebClient ifPresent:[:webClient| self shouldnt:[ [webClient httpGet: 'https://open.login.yahoo.com/openid/op/auth'] "Allow certificate errors on the Mac since cert validation isn't implemented yet." on: SqueakSSLCertificateError do:[:ex| SqueakSSL platformName = 'Mac OS' ifTrue:[ex resume] ifFalse:[ex pass]]. ] raise: Error. ].. !

1 0

Squeak 4.6: Installer-Core-cmm.397.mcz
by commits＠source.squeak.org 05 Jun '15

05 Jun '15

Chris Muller uploaded a new version of Installer-Core to project Squeak 4.6: http://source.squeak.org/squeak46/Installer-Core-cmm.397.mcz ==================== Summary ==================== Name: Installer-Core-cmm.397 Author: cmm Time: 13 April 2015, 8:28:57.87 pm UUID: e3825d75-2e08-4420-b2d0-25d7946a4371 Ancestors: Installer-Core-cmm.396 SqueakSource employs server-specific versions of OSProcess and RFB. ==================== Snapshot ==================== SystemOrganization addCategory: #'Installer-Core'! Object subclass: #Installer instanceVariableNames: 'answers packages messagesToSuppress useFileIn noiseLevel currentRepository' classVariableNames: 'InstallerBindings IsSetToTrapErrors Repositories SkipLoadingTests ValidationBlock' poolDictionaries: '' category: 'Installer-Core'! !Installer commentStamp: 'kph 3/30/2009 01:29' prior: 0! Documentation now available at http://installer.pbwiki.com/Installer useFileIn - flag to load source.st rather than using Monticello! ----- Method: Installer class>>actionMatch:reportOn:ifNoMatch: (in category 'action report') ----- actionMatch: theLine reportOn: report ifNoMatch: aBlock | line | line := theLine withBlanksCondensed. self allSubclassesDo: [:class | (class canReportLine: line) ifTrue: [ ^ class new action: theLine reportOn: report ]]. ^ aBlock value! ----- Method: Installer class>>airplaneMode (in category 'repository-overrides') ----- airplaneMode "Override all remote repositories with the package cache." self overrideRemoteRepostoriesWith: MCCacheRepository default! ----- Method: Installer class>>bootstrapTheRestOfInstaller (in category 'action report') ----- bootstrapTheRestOfInstaller (Installer url: 'www.squeaksource.com/Installer/Installer-Scripts') fileInSource; logCR: 'installer bootstrap - loaded'.! ----- Method: Installer class>>bug:fix: (in category 'mantis') ----- bug: n fix: filename Transcript cr; show: 'Code script in Mantis:', n asString, ' should read Installer mantis bug: ',n asString, ' fix: ', filename printString,'.'. ^ self mantis bug: n fix: filename! ----- Method: Installer class>>cache (in category 'monticello') ----- cache ^ self monticello cache! ----- Method: Installer class>>canReportLine: (in category 'action report') ----- canReportLine: line ^ false! ----- Method: Installer class>>cancelSkipLoadingTests (in category 'accessing') ----- cancelSkipLoadingTests "sets a flag to un-ignore loading of the testing portion of scripts embedded in pages" SkipLoadingTests := false. ! ----- Method: Installer class>>clearOverrides (in category 'repository-overrides') ----- clearOverrides "Remove all repository overrides and load everthing from the specified default repositories when using #merge:." Repositories := Dictionary new! ----- Method: Installer class>>cobalt (in category 'repositories') ----- cobalt ^ self monticello http: 'http://croquet-src-01.oit.duke.edu:8886'! ----- Method: Installer class>>debug (in category 'debug') ----- debug IsSetToTrapErrors := false! ----- Method: Installer class>>defaultRepositoryFor: (in category 'private') ----- defaultRepositoryFor: anAssociation "private -- answer the MC repository specified by anAssociation." ^ (self perform: anAssociation key) project: anAssociation value ; mc! ----- Method: Installer class>>do: (in category 'launcher support') ----- do: webPageName | rs | rs := webPageName readStream. [ rs atEnd ] whileFalse: [ self install: (rs upTo: $;) ]. ! ----- Method: Installer class>>file (in category 'file') ----- file ^ InstallerFile new! ----- Method: Installer class>>file: (in category 'file') ----- file: fileName ^ InstallerFile new file: fileName; yourself ! ----- Method: Installer class>>fromUrl: (in category 'url') ----- fromUrl: aUrl "try and pick an Installer appropriate for the Url" | inst | ((aUrl endsWith: '.mcz') or: [ aUrl endsWith: '.mcm' ]) ifTrue: [ inst := Installer mc fromUrl: aUrl. inst packages isEmpty ifFalse: [ ^ inst ] ] . ^ Installer url: aUrl ! ----- Method: Installer class>>gemsource (in category 'repositories') ----- gemsource ^ self monticello http: 'http://seaside.gemstone.com/ss'! ----- Method: Installer class>>goran (in category 'repositories') ----- goran ^ self monticello http: 'squeak.krampe.se'; project: ''! ----- Method: Installer class>>gs (in category 'repositories') ----- gs ^ self gemsource! ----- Method: Installer class>>impara (in category 'repositories') ----- impara ^ self monticello http: 'source.impara.de'! ----- Method: Installer class>>install: (in category 'action report') ----- install: scriptName ^ (self scripts install: scriptName) ifNil:[ self web install: scriptName ] ! ----- Method: Installer class>>installFile: (in category 'file') ----- installFile: fileName ^ (self file: fileName) install. ! ----- Method: Installer class>>installSilentlyUrl: (in category 'url') ----- installSilentlyUrl: urlString ^ SystemChangeNotifier uniqueInstance doSilently: [ self url url: urlString; install ]. ! ----- Method: Installer class>>installUrl: (in category 'url') ----- installUrl: urlString ^ self url url: urlString; install. ! ----- Method: Installer class>>keith (in category 'repositories') ----- keith ^ self monticello ftp: 'squeak.warwick.st' directory: 'mc' user: 'squeak' password: 'viewpoints'! ----- Method: Installer class>>krestianstvo (in category 'repositories') ----- krestianstvo "Krestianstvo SDK code repository." ^ self monticello http: 'http://sdk.krestianstvo.org/sdk/'! ----- Method: Installer class>>launchFrom: (in category 'launcher support') ----- launchFrom: launcher ^self launchWith: launcher getParameters! ----- Method: Installer class>>launchHelp (in category 'launcher support') ----- launchHelp ^'path=/dir/*.txt Specify a search path for the item to install p=/dir1/*.txt;<url2>/ Multiple items delimited by ; The page name is typically appended to the path string, or if a "*" is present, it will be replaced by the page name. in,i,install=<page> Page appended to the path to begin the install process url,u=<url> Install using an explicit url from which to obtain a script or file file=<url> Install using a local file +debug Do not trap errors view=<page> Print the script that would have been installed. For more options use Script eval="Installer ... " ' ! ----- Method: Installer class>>launchWith: (in category 'launcher support') ----- launchWith: params params at: 'P' ifPresent: [ :v | params at: 'PATH' put: v ]. params at: 'I' ifPresent: [ :v | params at: 'INSTALL' put: v ]. params at: 'IN' ifPresent: [ :v | params at: 'INSTALL' put: v ]. params at: 'U' ifPresent: [ :v | params at: 'URL' put: v ]. params at: 'PATH' ifPresent: [ :v | self webSearchPathFrom: v. ]. params at: 'USER' ifPresent: [ :v | Utilities setAuthorInitials: v ]. params at: 'VERSION' ifPresent: [ :v | SystemVersion current version: v ]. params at: 'VIEW' ifPresent: [ :v | self view: v ]. IsSetToTrapErrors := true. params at: 'DEBUG' ifPresent: [ :v | IsSetToTrapErrors := (v == true) not ]. params at: 'URL' ifPresent: [ :v | self installUrl: v ]. params at: 'FILE' ifPresent: [ :v | self installFile: v ]. params at: 'INSTALL' ifPresent: [ :v | self do: v ]. params at: 'DO' ifPresent: [ :v | self do: v ]. ^true ! ----- Method: Installer class>>log: (in category 'logging') ----- log: aString Transcript show: aString; cr.! ----- Method: Installer class>>lukas (in category 'repositories') ----- lukas ^ self monticello http: 'http://source.lukas-renggli.ch'! ----- Method: Installer class>>mantis (in category 'mantis') ----- mantis ^ self mantis: 'http://bugs.squeak.org/'! ----- Method: Installer class>>mantis: (in category 'mantis') ----- mantis: host ^ InstallerMantis host: host! ----- Method: Installer class>>mc (in category 'monticello') ----- mc ^ self monticello! ----- Method: Installer class>>monticello (in category 'monticello') ----- monticello ^ InstallerMonticello new! ----- Method: Installer class>>noDebug (in category 'debug') ----- noDebug IsSetToTrapErrors := true! ----- Method: Installer class>>noProgressDuring: (in category 'during') ----- noProgressDuring: block [ block value: self ] on: ProgressInitiationException do: [ : note | note sendNotificationsTo: [ :min :max :curr | "ignore" ] ]! ----- Method: Installer class>>overrideRemoteRepostoriesWith: (in category 'repository-overrides') ----- overrideRemoteRepostoriesWith: aMCRepositoryOrGroup self remoteRepositories do: [ : each | self overrideRepository: each with: aMCRepositoryOrGroup ]! ----- Method: Installer class>>overrideRepository:with: (in category 'repository-overrides') ----- overrideRepository: scope with: anMCRepository "When configuring the image with #merge:, override the standard repository specified by scope with anMCRepository." "Installer override: #ss3->'htmlcssparser' with: (MCDirectoryRepository directory: (FileDirectory default / 'mc'))." "Installer override: #ss with: #ssMirror." self repositories at: scope put: anMCRepository! ----- Method: Installer class>>packageCache (in category 'repositories') ----- packageCache ^ MCCacheRepository default! ----- Method: Installer class>>path: (in category 'web') ----- path: aString "convenience abbreviation" self webSearchPathFrom: aString! ----- Method: Installer class>>privateUpgradeTheRest (in category 'instanciation') ----- privateUpgradeTheRest Installer ss project: 'Installer'; installQuietly: 'Installer-Scripts'; installQuietly: 'Installer-Formats'.. ^ self! ----- Method: Installer class>>remoteRepositories (in category 'repository-overrides') ----- remoteRepositories ^ #(#ss #ss3 #cobalt #gemsource #goran #gs #impara #keith #krestianstvo #lukas #saltypickle #sophie #squeak #squeakfoundation #squeaksource #squeaksource3 #ss #ss3 #swa #swasource #wiresong )! ----- Method: Installer class>>removeOverride: (in category 'repository-overrides') ----- removeOverride: scope "Remove override specified by scope and return to using the default repository for packages within that scope." ^ self repositories removeKey: scope ifAbsent: [ ]! ----- Method: Installer class>>repositories (in category 'accessing') ----- repositories ^ Repositories ifNil: [ Repositories := Dictionary new ]! ----- Method: Installer class>>repository: (in category 'monticello') ----- repository: host ^self monticello http: host ! ----- Method: Installer class>>repositoryFor: (in category 'private') ----- repositoryFor: anAssociation "private -- anAssociation key is the repository selector Symbol understood by Intsaller class. It's value is the project name within that HTTP repository." | rep | rep := self repositories at: anAssociation "<-- check for #rep->project overrides first" ifAbsent: [ self repositories at: anAssociation key "<-- override an entire repository." ifAbsent: [ ^ self defaultRepositoryFor: anAssociation ] ]. ^ rep isSymbol ifTrue: [ self defaultRepositoryFor: rep -> anAssociation value ] ifFalse: [ rep ]! ----- Method: Installer class>>sake (in category 'sake') ----- sake ^ self sake: InstallerSake sake! ----- Method: Installer class>>sake: (in category 'sake') ----- sake: aSakePackagesClass ^ InstallerSake new sake: aSakePackagesClass! ----- Method: Installer class>>saltypickle (in category 'repositories') ----- saltypickle ^ self monticello http: 'squeak.saltypickle.com'! ----- Method: Installer class>>setSakeToUse: (in category 'sake') ----- setSakeToUse: aClass InstallerSake sake: aClass! ----- Method: Installer class>>sf (in category 'documentation') ----- sf ^ self squeakfoundation ! ----- Method: Installer class>>skipLoadingTests (in category 'accessing') ----- skipLoadingTests "sets a flag to ignore loading of the testing portion of scripts embedded in pages" SkipLoadingTests := true. ! ----- Method: Installer class>>skipLoadingTestsDuring: (in category 'during') ----- skipLoadingTestsDuring: block | oldValue | oldValue := SkipLoadingTests. SkipLoadingTests := true. [ block value: self ] ensure:[ SkipLoadingTests := oldValue ].! ----- Method: Installer class>>sm (in category 'squeakmap') ----- sm ^ self squeakmap! ----- Method: Installer class>>sophie (in category 'repositories') ----- sophie ^ self monticello http: 'source.sophieproject.org' ! ----- Method: Installer class>>squeak (in category 'repositories') ----- squeak ^self monticello http: 'source.squeak.org'! ----- Method: Installer class>>squeakInbox (in category 'repositories') ----- squeakInbox ^self squeak project: 'inbox'! ----- Method: Installer class>>squeakTrunk (in category 'repositories') ----- squeakTrunk ^self squeak project: 'trunk'! ----- Method: Installer class>>squeakfoundation (in category 'repositories') ----- squeakfoundation ^ self monticello http: 'source.squeakfoundation.org'! ----- Method: Installer class>>squeakmap (in category 'squeakmap') ----- squeakmap ^ InstallerSqueakMap new sm: true; yourself! ----- Method: Installer class>>squeaksource (in category 'repositories') ----- squeaksource ^ self monticello http: 'http://www.squeaksource.com'! ----- Method: Installer class>>squeaksource3 (in category 'repositories') ----- squeaksource3 ^ self monticello http: 'http://ss3.gemtalksystems.com/ss/'! ----- Method: Installer class>>ss (in category 'repositories') ----- ss ^ self squeaksource ! ----- Method: Installer class>>ss3 (in category 'repositories') ----- ss3 ^ self squeaksource3.! ----- Method: Installer class>>ssMirror (in category 'repositories') ----- ssMirror "The Chilean mirror for the original SqueakSource." ^ self monticello http: 'http://dsal.cl/squeaksource/'! ----- Method: Installer class>>swa (in category 'repositories') ----- swa ^ self swasource! ----- Method: Installer class>>swasource (in category 'repositories') ----- swasource ^ self monticello http: 'http://www.hpi.uni-potsdam.de/hirschfeld/squeaksource'! ----- Method: Installer class>>universe (in category 'universe') ----- universe ^ InstallerUniverse default! ----- Method: Installer class>>upgrade (in category 'instanciation') ----- upgrade Installer ss project: 'Installer'; installQuietly: 'Installer-Core'. self privateUpgradeTheRest. ^ self! ----- Method: Installer class>>url (in category 'url') ----- url ^ InstallerUrl new url: ''! ----- Method: Installer class>>url: (in category 'url') ----- url: urlString ^self url url: urlString; yourself! ----- Method: Installer class>>validationBlock (in category 'accessing') ----- validationBlock ^ ValidationBlock! ----- Method: Installer class>>validationBlock: (in category 'accessing') ----- validationBlock: aBlock ValidationBlock := aBlock! ----- Method: Installer class>>view: (in category 'instanciation') ----- view: webPageNameOrUrl | theReport | theReport := String streamContents: [ :report | (webPageNameOrUrl beginsWith: 'http://') ifTrue: [ self actionMatch: ('Installer installUrl: ', (webPageNameOrUrl printString),'.') reportOn: report ifNoMatch: [] ] ifFalse: [ self actionMatch: ('Installer install: ', (webPageNameOrUrl printString),'.') reportOn: report ifNoMatch: [] ]]. Workspace new contents: (theReport contents); openLabel: webPageNameOrUrl. ^theReport contents ! ----- Method: Installer class>>web (in category 'web') ----- web ^ InstallerWeb! ----- Method: Installer class>>webInstall: (in category 'web') ----- webInstall: webPageName ^ self web install: webPageName ! ----- Method: Installer class>>webSearchPath (in category 'web') ----- webSearchPath "a search path item, has the following format. prefix*suffix" ^ self web searchPath! ----- Method: Installer class>>webSearchPathFrom: (in category 'web') ----- webSearchPathFrom: string | reader wsp path | reader := string readStream. wsp := self webSearchPath. [ reader atEnd ] whileFalse: [ path := reader upTo: $;. (wsp includes: wsp) ifFalse: [ wsp addFirst: path ]]. ! ----- Method: Installer class>>websqueakmap (in category 'websqueakmap') ----- websqueakmap ^ InstallerWebSqueakMap new wsm: 'http://map.squeak.org'; yourself! ----- Method: Installer class>>websqueakmap: (in category 'websqueakmap') ----- websqueakmap: host ^ InstallerWebSqueakMap new wsm: host; yourself! ----- Method: Installer class>>wiresong (in category 'repositories') ----- wiresong ^ self monticello http: 'http://source.wiresong.ca'! ----- Method: Installer class>>wsm (in category 'websqueakmap') ----- wsm ^ self websqueakmap! ----- Method: Installer>>addPackage: (in category 'public interface') ----- addPackage: anObject self packages add: anObject! ----- Method: Installer>>allPackages (in category 'accessing') ----- allPackages ^ (self class withAllSuperclasses inject: OrderedCollection new into: [ : coll : each | coll addAll: (each methodsInCategory: 'package-definitions') ; yourself ]) sort! ----- Method: Installer>>answer:with: (in category 'auto answering') ----- answer: aString with: anAnswer ^self answers add: ( Array with: aString with: anAnswer )! ----- Method: Installer>>answers (in category 'accessing') ----- answers ^ answers ifNil: [ answers := OrderedCollection new ]! ----- Method: Installer>>answers: (in category 'accessing') ----- answers: anObject answers := anObject! ----- Method: Installer>>availablePackages (in category 'public interface') ----- availablePackages ^ self basicAvailablePackages! ----- Method: Installer>>basicAvailablePackages (in category 'basic interface') ----- basicAvailablePackages! ----- Method: Installer>>basicBrowse (in category 'basic interface') ----- basicBrowse! ----- Method: Installer>>basicInstall (in category 'basic interface') ----- basicInstall! ----- Method: Installer>>basicVersions (in category 'basic interface') ----- basicVersions! ----- Method: Installer>>basicView (in category 'basic interface') ----- basicView! ----- Method: Installer>>bindingOf: (in category 'script bindings') ----- bindingOf: aString self isThisEverCalled: 'Want to get rid of this and the class-var'. InstallerBindings isNil ifTrue: [ InstallerBindings := Dictionary new]. (InstallerBindings includesKey: aString) ifFalse: [InstallerBindings at: aString put: nil]. ^ InstallerBindings associationAt: aString.! ----- Method: Installer>>bootstrap (in category 'public interface') ----- bootstrap "keep for compatability" self deprecatedApi. useFileIn := true. self install.! ----- Method: Installer>>broomMorphsBase (in category 'package-definitions') ----- broomMorphsBase "Morph alignment user-interface tool." ^ { #ss3 -> 'Connectors'. 'BroomMorphs-Base' }! ----- Method: Installer>>browse (in category 'public interface') ----- browse self logErrorDuring: [self basicBrowse]! ----- Method: Installer>>browse: (in category 'public interface') ----- browse: packageNameCollectionOrDetectBlock self package: packageNameCollectionOrDetectBlock. self browse! ----- Method: Installer>>browse:from: (in category 'mantis') ----- browse: aFileName from: stream | mcThing ext browseSelector | self log: ' browsing...'. mcThing := self classMCReader ifNotNil: [ self mcThing: aFileName from: stream ]. mcThing ifNotNil: [ (mcThing respondsTo: #snapshot) ifTrue: [ mcThing browse ] ifFalse: [ (MCSnapshotBrowser forSnapshot: mcThing) showLabelled: 'Browsing ', aFileName ] ] ifNil: [ ext := aFileName copyAfterLast: $.. browseSelector := ('browse', ext asUppercase, ':from:') asSymbol. (self respondsTo: browseSelector) ifTrue: [ self perform: browseSelector with: aFileName with: stream ] ifFalse: [ self browseDefault: aFileName from: stream ]. ]! ----- Method: Installer>>browseCS:from: (in category 'mantis') ----- browseCS: aFileName from: stream | list | list := self classChangeList new scanFile: stream from: 1 to: stream size. self classChangeList open: list name: aFileName multiSelect: true. ! ----- Method: Installer>>browseDefault:from: (in category 'mantis') ----- browseDefault: aFileName from: stream self view: aFileName from: stream! ----- Method: Installer>>browseGZ:from: (in category 'mantis') ----- browseGZ: aFileName from: stream "FileIn the contents of a gzipped stream" | zipped unzipped | zipped := self classGZipReadStream on: stream. unzipped := MultiByteBinaryOrTextStream with: zipped contents asString. unzipped reset. ChangeList browseStream: unzipped ! ----- Method: Installer>>changeSetNamed: (in category 'utils') ----- changeSetNamed: aName (ChangeSet respondsTo: #named:) ifTrue: [ ^ ChangeSet named: aName ]. ^ ChangeSorter changeSetNamed: aName.! ----- Method: Installer>>classChangeList (in category 'class references') ----- classChangeList ^Smalltalk at: #ChangeList ifAbsent: [ self error: 'ChangeList not present' ]! ----- Method: Installer>>classChangeSet (in category 'class references') ----- classChangeSet ^Smalltalk at: #ChangeSet ifAbsent: [ self error: 'ChangeSet not present' ]! ----- Method: Installer>>classChangeSorter (in category 'class references') ----- classChangeSorter ^Smalltalk at: #ChangeSorter ifAbsent: [ self error: 'ChangeSorter not present' ]! ----- Method: Installer>>classGZipReadStream (in category 'class references') ----- classGZipReadStream ^Smalltalk at: #GZipReadStream ifAbsent: [ self error: 'Compression not present' ]! ----- Method: Installer>>classMCReader (in category 'class references') ----- classMCReader ^Smalltalk at: #MCReader ifAbsent: [ nil ] ! ----- Method: Installer>>classMczInstaller (in category 'class references') ----- classMczInstaller ^Smalltalk at: #MczInstaller ifAbsent: [ nil ] ! ----- Method: Installer>>classMultiByteBinaryOrTextStream (in category 'class references') ----- classMultiByteBinaryOrTextStream ^Smalltalk at: #MultiByteBinaryOrTextStream ifAbsent: [ self error: 'MultiByteBinaryOrTextStream not present' ]! ----- Method: Installer>>classSARInstaller (in category 'class references') ----- classSARInstaller ^Smalltalk at: #SARInstaller ifAbsent: [ self error: 'SARInstaller not present' ]! ----- Method: Installer>>connectors (in category 'package-definitions') ----- connectors "Connect Morphs together. Make diagrams." ^ { self broomMorphsBase. 'CGPrereqs'. 'FSM'. 'Connectors'. 'ConnectorsText'. 'ConnectorsShapes'. 'ConnectorsTools'. 'ConnectorsGraphLayout'. 'BroomMorphs-Connectors' }! ----- Method: Installer>>core (in category 'package-definitions') ----- core "A minimum core capable of expanding itself." ^ { #squeak -> MCMcmUpdater defaultUpdateURL asUrl path last. 'Kernel'. 'Collections'. 'Exceptions'. 'Files'. 'Network'. 'Monticello'. 'MonticelloConfigurations'. 'Installer-Core' }! ----- Method: Installer>>curvedSpaceExplorer (in category 'package-definitions') ----- curvedSpaceExplorer "Explore curved 3D spaces." ^ { self openGL. 'CCSpaceExplorer' }! ----- Method: Installer>>depthFirstOf:do: (in category 'private') ----- depthFirstOf: structure do: oneArgBlock self depthFirstOf: structure do: oneArgBlock ifNotIn: Set new! ----- Method: Installer>>depthFirstOf:do:ifNotIn: (in category 'private') ----- depthFirstOf: structure do: oneArgBlock ifNotIn: aSet (aSet includes: structure) ifTrue: [ ^ self ]. "Respect all repository directives even if encountered more than once." (structure isVariableBinding) ifFalse: [ aSet add: structure ]. structure isArray ifTrue: [ structure do: [ : each | self depthFirstOf: each do: oneArgBlock ifNotIn: aSet ] ] ifFalse: [ oneArgBlock value: structure ]! ----- Method: Installer>>ditchOldChangeSetFor: (in category 'utils') ----- ditchOldChangeSetFor: aFileName | changeSetName changeSet | changeSetName := (self validChangeSetName: aFileName) sansPeriodSuffix. changeSet := self changeSetNamed: changeSetName. changeSet ifNotNil: [ (self logCR:'Removing old change set ', changeSetName) cr. self removeChangeSet: changeSet ].! ----- Method: Installer>>ffi (in category 'package-definitions') ----- ffi "Foreign Function Interface." ^ { #squeak -> 'FFI'. 'FFI-Pools'. 'FFI-Kernel' }! ----- Method: Installer>>ffiTests (in category 'package-definitions') ----- ffiTests "Tests for Foreign Function Interface." ^ { self ffi. 'FFI-Tests' }! ----- Method: Installer>>fileInSource (in category 'public interface') ----- fileInSource useFileIn := true. self install.! ----- Method: Installer>>fuel (in category 'package-definitions') ----- fuel "Serialization package." ^ { #ss3 -> 'Fuel'. 'ConfigurationOfFuel' }! ----- Method: Installer>>htmlValidator (in category 'package-definitions') ----- htmlValidator "Validates HTML and CSS pages against W3C DTD." ^ { #ss3 -> 'htmlcssparser'. 'HTML' }! ----- Method: Installer>>initialize (in category 'public interface') ----- initialize useFileIn := false..! ----- Method: Installer>>install (in category 'public interface') ----- install noiseLevel = #quiet ifTrue: [ ^ self installQuietly ]. noiseLevel = #silent ifTrue: [ ^ self installSilently ]. ^ self installLogging! ----- Method: Installer>>install: (in category 'public interface') ----- install: packageNameCollectionOrDetectBlock "The parameter specifies the package to be installed in one of the following ways: - By Name e.g. install: 'Kernel' - Acceptable Versions e.g. install: #('Comet-lr' 'Comet-pmm') i.e. either of these - Specific version e.g. install: 'Scriptaculous-lr.148' - By Predicate e.g. install: [ :packageName | packageName beginsWith: 'Dynamic' ]" self addPackage: packageNameCollectionOrDetectBlock. self install! ----- Method: Installer>>install:from: (in category 'mantis') ----- install: aFileName from: stream self log: ' installing...'. self withAnswersDo: [ | ext installSelector mcThing | mcThing := self classMCReader ifNotNil: [ self mcThing: aFileName from: stream ]. mcThing ifNotNil: [ (mcThing respondsTo: #install) ifTrue: [ mcThing install ] ifFalse: [ (mcThing respondsTo: #load) ifTrue: [ mcThing load ] ] ] ifNil: [ ext := (aFileName copyAfterLast: $/) in: [ :path | path isEmpty ifTrue: [ aFileName ] ifFalse: [ path ] ]. ext := ext copyAfterLast: $.. ext = '' ifTrue: [ ext := 'st' ]. installSelector := ('install', ext asUppercase, ':from:') asSymbol. useFileIn ifTrue: [ [ SystemChangeNotifier uniqueInstance doSilently: [self install: aFileName from: stream using: installSelector ]] on: Warning do: [ :ex | ex resume: true ]. ] ifFalse: [ self install: aFileName from: stream using: installSelector. ] ] ]. self log: ' done.' ! ----- Method: Installer>>install:from:using: (in category 'mantis') ----- install: aFileName from: stream using: installSelector (self respondsTo: installSelector) ifTrue: [ self perform: installSelector with: aFileName with: stream ] ifFalse: [ self installDefault: aFileName from: stream ]. ! ----- Method: Installer>>installCS:from: (in category 'mantis') ----- installCS: aFileName from: stream self ditchOldChangeSetFor: aFileName. self newChangeSetFromStream: stream named: (self validChangeSetName: aFileName). ! ----- Method: Installer>>installDefault:from: (in category 'mantis') ----- installDefault: aFileName from: stream "Check for UTF-8 input before filing it in" | pos | pos := stream position. (stream next: 3) asByteArray = #[16rEF 16rBB 16rBF] "BOM" ifTrue: [(RWBinaryOrTextStream on: stream upToEnd utf8ToSqueak) fileIn] ifFalse: [stream position: pos; fileIn] ! ----- Method: Installer>>installGZ:from: (in category 'mantis') ----- installGZ: aFileName from: stream "FileIn the contents of a gzipped stream" | zipped unzipped | zipped := self classGZipReadStream on: stream. unzipped := MultiByteBinaryOrTextStream with: zipped contents asString. unzipped reset. self newChangeSetFromStream: unzipped named: (FileDirectory localNameFor: aFileName)! ----- Method: Installer>>installLogging (in category 'public interface') ----- installLogging self logErrorDuring: [ self basicInstall. packages := nil]. ! ----- Method: Installer>>installMCZ:from: (in category 'mantis') ----- installMCZ: aFileName from: stream | source pkg wc | pkg := aFileName copyUpToLast: $-. wc := Smalltalk at: #MCWorkingCopy ifAbsent: [ nil ]. wc ifNotNil: [ (wc allManagers select: [:each | each packageName = pkg ]) do: [ :ea | ea unregister ] ]. self classMczInstaller ifNotNil: [^ self classMczInstaller install: aFileName stream: stream]. source := ((ZipArchive new readFrom:stream) memberNamed: 'snapshot/source.st') contents. [ SystemChangeNotifier uniqueInstance doSilently: [ source readStream fileInAnnouncing: 'Booting ' , aFileName. ] ] on: Warning do: [ :ex | ex resume: true ].! ----- Method: Installer>>installMCZBasic:from: (in category 'mantis') ----- installMCZBasic: aFileName from: stream | source | self classMczInstaller ifNotNil: [^ self classMczInstaller install: aFileName stream: stream]. source := ((ZipArchive new readFrom:stream) memberNamed: 'snapshot/source.st') contents. [ SystemChangeNotifier uniqueInstance doSilently: [ source readStream fileInAnnouncing: 'Booting ' , aFileName. ] ] on: Warning do: [ :ex | ex resume: true ].! ----- Method: Installer>>installMCcs:from: (in category 'mantis') ----- installMCcs: aFileName from: stream | reader | reader := Smalltalk at: #MCCsReader ifPresent: [:class | class on: stream].! ----- Method: Installer>>installQuietly (in category 'public interface') ----- installQuietly [ self installLogging ] on: Warning do: [ :ex | ex resume: true ].! ----- Method: Installer>>installQuietly: (in category 'public interface') ----- installQuietly: packageNameCollectionOrDetectBlock self quietly install: packageNameCollectionOrDetectBlock. ! ----- Method: Installer>>installSAR:from: (in category 'mantis') ----- installSAR: aFileName from: stream | newCS | newCS := self classSARInstaller withCurrentChangeSetNamed: aFileName do: [:cs | self classSARInstaller new fileInFrom: stream]. newCS isEmpty ifTrue: [ self removeChangeSet: newCS ]! ----- Method: Installer>>installSilently (in category 'public interface') ----- installSilently SystemChangeNotifier uniqueInstance doSilently: [ self installLogging ] ! ----- Method: Installer>>isSkipLoadingTestsSet (in category 'accessing') ----- isSkipLoadingTestsSet ^SkipLoadingTests ifNil: [ false ]! ----- Method: Installer>>log: (in category 'logging') ----- log: text ^Transcript show: text.! ----- Method: Installer>>logCR: (in category 'logging') ----- logCR: text self validate. ^ Transcript show: text; cr! ----- Method: Installer>>logErrorDuring: (in category 'logging') ----- logErrorDuring: block (IsSetToTrapErrors = true) ifFalse: [ ^ block value ]. block on: Error do: [ :e | self halt. self logCR: '****', e class name, ': ', (e messageText ifNil: [ '']). (e isKindOf: MessageNotUnderstood) ifTrue: [ e pass ] ifFalse: [ e isResumable ifTrue:[ e resume: true ]]]! ----- Method: Installer>>maInstaller (in category 'package-definitions') ----- maInstaller "Select from a family of related packages for application development." ^ { #ss3 -> 'Ma-Installer'. 'Ma-Installer-Core' }! ----- Method: Installer>>match: (in category 'searching') ----- match: aMatch ^self packagesMatching: aMatch! ----- Method: Installer>>mathMorphs (in category 'package-definitions') ----- mathMorphs "MathMorphs is a project that combines mathematics and Smalltalk. See http://www.dm.uba.ar/MathMorphs/ and chapter 10 of the 'new blue book'." ^ { self morphicWrappers. 'Functions' }! ----- Method: Installer>>mcThing:from: (in category 'mantis') ----- mcThing: aFileName from: stream "dont use monticello for .cs or for .st use monticello for .mcs" | reader | useFileIn ifTrue: [ ^ nil ]. reader := self classMCReader readerClassForFileNamed: aFileName. reader name = 'MCStReader' ifTrue: [ ^ nil ]. reader ifNil: [ ^ nil ]. (reader respondsTo: #on:fileName:) ifTrue: [ reader := reader on: stream fileName: aFileName. ^ reader version ] ifFalse: [ reader := reader on: stream. ^ reader snapshot ].! ----- Method: Installer>>merge: (in category 'public interface') ----- merge: structureOrSymbol | toUncache | toUncache := Set new. structureOrSymbol isSymbol ifTrue: [ self merge: (self perform: structureOrSymbol) ] ifFalse: [ self depthFirstOf: structureOrSymbol do: [ : each | each isVariableBinding ifTrue: [ currentRepository := self class repositoryFor: each. currentRepository cacheAllFilenames. toUncache add: currentRepository ] ifFalse: [ each isString ifTrue: [ self primMerge: each ] ifFalse: [ self error: 'invalid specification' ] ] ] ]. toUncache do: [ : each | each flushAllFilenames ]! ----- Method: Installer>>messagesToSuppress (in category 'accessing') ----- messagesToSuppress ^ messagesToSuppress ifNil: [ messagesToSuppress := OrderedCollection new ]! ----- Method: Installer>>messagesToSuppress: (in category 'accessing') ----- messagesToSuppress: anObject messagesToSuppress := anObject! ----- Method: Installer>>morphicWrappers (in category 'package-definitions') ----- morphicWrappers "Provides 'type on air' workspaces. Results of evaluated expressions are represented as domain objects in the world." ^ { #ss -> 'MathMorphsRevival'. 'MorphicWrappers' }! ----- Method: Installer>>newChangeSetFromStream:named: (in category 'mantis') ----- newChangeSetFromStream: aStream named: aName "This code is based upon ChangeSet-c-#newChangesFromStream:named: which is in 3.9, implemented here for previous versions. The second branch is for 3.8, where ChangeSets are loaded by ChangeSorter. " | oldChanges newName newSet | (self classChangeSet respondsTo: #newChangesFromStream:named:) ifTrue: [ ^self classChangeSet newChangesFromStream: aStream named:aName ]. (self classChangeSorter respondsTo: #newChangesFromStream:named:) ifTrue: [ ^self classChangeSorter newChangesFromStream: aStream named: aName ]. oldChanges := ChangeSet current. "so a Bumper update can find it" newName := aName sansPeriodSuffix. newSet := self classChangeSet basicNewNamed: newName. [ | newStream | newSet ifNotNil: [(aStream respondsTo: #converter:) ifTrue: [newStream := aStream] ifFalse: [newStream := self classMultiByteBinaryOrTextStream with: aStream contentsOfEntireFile. newStream reset]. self classChangeSet newChanges: newSet. newStream setConverterForCode. newStream fileInAnnouncing: 'Loading ' , newName , '...'. Transcript cr; show: 'File ' , aName , ' successfully filed in to change set ' , newName]. aStream close] ensure: [self classChangeSet newChanges: oldChanges]. ^ newSet! ----- Method: Installer>>open (in category 'public interface') ----- open! ----- Method: Installer>>openGL (in category 'package-definitions') ----- openGL "3D library." ^ { self threeDtransform. #krestianstvo -> 'ccse'. 'OpenGL-Pools'. 'OpenGL-Core'. 'OpenGL-NameManager' }! ----- Method: Installer>>osProcess (in category 'package-definitions') ----- osProcess "Launch external executable programs." ^ { #ss -> 'OSProcess'. 'OSProcess' }! ----- Method: Installer>>package (in category 'accessing') ----- package ^ self packages isEmpty ifTrue: [ nil ] ifFalse: [ self packages last ]! ----- Method: Installer>>package: (in category 'accessing') ----- package: anObject self addPackage: anObject.! ----- Method: Installer>>packageAndVersionFrom: (in category 'squeakmap') ----- packageAndVersionFrom: pkg | p | p := ReadStream on: pkg . ^{(p upTo: $(). p upTo: $)} collect: [:s | s withBlanksTrimmed].! ----- Method: Installer>>packages (in category 'accessing') ----- packages ^ packages ifNil: [ packages := OrderedCollection new ]! ----- Method: Installer>>packages: (in category 'accessing') ----- packages: aCollection packages := aCollection! ----- Method: Installer>>packagesMatching: (in category 'searching') ----- packagesMatching: aMatch ^'search type not supported'! ----- Method: Installer>>primMerge: (in category 'private') ----- primMerge: packageName | version | version := (currentRepository includesVersionNamed: packageName) ifTrue: [ currentRepository versionNamed: packageName ] ifFalse: [ currentRepository highestNumberedVersionForPackageNamed: packageName ]. [ version shouldMerge ifTrue: [ version merge ] ifFalse: [ version load ] ] on: MCNoChangesException do: [ : req | req resume ] on: MCMergeResolutionRequest do: [ : request | request merger conflicts isEmpty ifTrue: [ request resume: true ] ifFalse: [ request pass ] ]. version workingCopy repositoryGroup addRepository: currentRepository! ----- Method: Installer>>quietly (in category 'public interface') ----- quietly noiseLevel := #quiet! ----- Method: Installer>>removeChangeSet: (in category 'utils') ----- removeChangeSet: cs (self classChangeSet respondsTo: #removeChangeSet:) ifTrue: [ ^ChangeSet removeChangeSet: cs ]. ^ self classChangeSorter removeChangeSet: cs .! ----- Method: Installer>>reportFor:page:on: (in category 'action report') ----- reportFor: theLine page: thePage on: report [ thePage atEnd ] whileFalse: [ | line | line := thePage nextLine. Installer actionMatch: line reportOn: report ifNoMatch: [ report nextPutAll: line; cr. ]].! ----- Method: Installer>>reportSection:on: (in category 'action report') ----- reportSection: line on: report report isEmpty ifFalse: [ report cr ]. report nextPutAll: '">>>> ' ; nextPutAll: (line copyWithout: $"); nextPut: $"; cr. ! ----- Method: Installer>>search: (in category 'searching') ----- search: aMatch ^'search type not supported'! ----- Method: Installer>>silently (in category 'public interface') ----- silently noiseLevel := #silent! ----- Method: Installer>>squeakRelease (in category 'package-definitions') ----- squeakRelease ^ { self system. '311Deprecated'. '39Deprecated'. '45Deprecated'. 'Nebraska'. 'SmallLand-ColorTheme'. 'ST80'. 'ST80Tools'. 'SystemReporter'. 'Universes'. 'XML-Parser' }! ----- Method: Installer>>squeakSslCore (in category 'package-definitions') ----- squeakSslCore "SSL implementation on top of WebClient. Requires the SqueakSSL VM plugin." ^ { self webClientCore. #ss -> 'SqueakSSL'. 'SqueakSSL-Core' }! ----- Method: Installer>>squeakSslTests (in category 'package-definitions') ----- squeakSslTests "SqueakSSL test package." ^ { self webClientTests. self squeakSslCore. 'SqueakSSL-Tests' }! ----- Method: Installer>>squeaksource (in category 'package-definitions') ----- squeaksource "A source code repository." ^ { #squeak -> 'ss'. 'OSProcess'. 'RFB'. 'SmaCC'. 'DynamicBindings'. 'KomServices'. 'KomHttpServer'. 'Seaside2'. 'Mewa'. 'TinyWiki'. 'SqueakSource' }! ----- Method: Installer>>suppress: (in category 'auto answering') ----- suppress: aMessage messagesToSuppress add: aMessage! ----- Method: Installer>>system (in category 'package-definitions') ----- system "Packages forming the Smalltalk development system." ^ { self core. 'System' }! ----- Method: Installer>>threeDtransform (in category 'package-definitions') ----- threeDtransform ^ { self ffiTests. #ss -> 'CroquetGL'. '3DTransform' }! ----- Method: Installer>>tools (in category 'package-definitions') ----- tools "A minimum core capable of expanding itself." ^ { self core. 'ToolBuilder-Kernel'. 'Tools' }! ----- Method: Installer>>updateStream (in category 'package-definitions') ----- updateStream ^ { self tools. 'UpdateStream' }! ----- Method: Installer>>validChangeSetName: (in category 'url') ----- validChangeSetName: aFileName " dots in the url confuses the changeset loader. I replace them with dashes" (aFileName beginsWith:'http:') ifTrue: [ | asUrl | asUrl := Url absoluteFromText: aFileName. ^String streamContents: [:stream | stream nextPutAll: (asUrl authority copyReplaceAll: '.' with: '-'). asUrl path allButLastDo: [:each | stream nextPutAll: '/'; nextPutAll: (each copyReplaceAll: '.' with: '-') ]. stream nextPutAll: '/'; nextPutAll: asUrl path last ] ]. ^aFileName! ----- Method: Installer>>validate (in category 'logging') ----- validate ValidationBlock value = false ifTrue: [ self error: 'Validation failed' ].! ----- Method: Installer>>versions (in category 'public interface') ----- versions ^ self basicVersions! ----- Method: Installer>>view (in category 'public interface') ----- view self logErrorDuring: [self basicView]! ----- Method: Installer>>view: (in category 'public interface') ----- view: packageNameCollectionOrDetectBlock self package: packageNameCollectionOrDetectBlock. self view! ----- Method: Installer>>view:from: (in category 'mantis') ----- view: aFileName from: stream self log: ' viewing...'. Workspace new contents: (stream contents); openLabel: aFileName. ! ----- Method: Installer>>webClientCore (in category 'package-definitions') ----- webClientCore "Simple, compact, and easy to use HTTP client implementation from Andreas Raab." ^ { #ss3 -> 'WebClient'. 'WebClient-Core' }! ----- Method: Installer>>webClientSsp (in category 'package-definitions') ----- webClientSsp "WebClient supports NTLM/SPNEGO authentication via the Microsoft SSP interface (Windows only)." ^ { self ffiTests. self webClientTests. 'WebClient-SSP' }! ----- Method: Installer>>webClientTests (in category 'package-definitions') ----- webClientTests "Help documentation and tests for Web Client." ^ { self webClientCore. 'WebClient-Tests'. 'WebClient-Help' }! ----- Method: Installer>>withAnswersDo: (in category 'auto answering') ----- withAnswersDo: aBlock (aBlock respondsTo: #valueSuppressingMessages:supplyingAnswers: ) ifTrue: [aBlock valueSuppressingMessages: self messagesToSuppress supplyingAnswers: self answers.] ifFalse: [ aBlock value ] ! Installer subclass: #InstallerFile instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Installer-Core'! ----- Method: InstallerFile>>basicBrowse (in category 'basic interface') ----- basicBrowse self browse: self file from: (FileDirectory readOnlyFileNamed: self file). ! ----- Method: InstallerFile>>basicInstall (in category 'basic interface') ----- basicInstall self install: self file from: (FileDirectory default readOnlyFileNamed: self file) ! ----- Method: InstallerFile>>basicView (in category 'basic interface') ----- basicView self view: self file from: (FileDirectory readOnlyFileNamed: self file). ! ----- Method: InstallerFile>>file (in category 'accessing') ----- file ^ self package! ----- Method: InstallerFile>>file: (in category 'accessing') ----- file: f self package: f! Installer subclass: #InstallerInternetBased instanceVariableNames: 'url pageDataStream markers' classVariableNames: 'Entities' poolDictionaries: '' category: 'Installer-Core'! ----- Method: InstallerInternetBased class>>entities (in category 'accessing') ----- entities ^ Entities ifNil: [ Entities := "enough entities to be going on with" Dictionary new. Entities at: 'lt' put: '<'; at: 'gt' put: '>'; at: 'amp' put: '&'; at: 'star' put: '*'; at: 'quot' put: '"'; at: 'nbsp' put: ' '; yourself ] ! ----- Method: InstallerInternetBased>>classHTTPSocket (in category 'class references') ----- classHTTPSocket ^Smalltalk at: #HTTPSocket ifAbsent: [ self error: 'Network package not present' ]! ----- Method: InstallerInternetBased>>extractFromHtml:option: (in category 'as yet unclassified') ----- extractFromHtml: html option: allOrLast | start stop test in | start := self markersBegin. stop := self markersEnd. test := self markersTest. in := WriteStream with: String new. [ html upToAll: start; atEnd ] whileFalse: [ | chunk | (allOrLast == #last) ifTrue: [ in resetToStart ]. chunk := html upToAll: stop. self isSkipLoadingTestsSet ifTrue: [ chunk := chunk readStream upToAll: test ]. in nextPutAll: chunk. ]. ^self removeHtmlMarkupFrom: in readStream ! ----- Method: InstallerInternetBased>>hasPage (in category 'url') ----- hasPage ^ pageDataStream notNil and: [ pageDataStream size > 0 ] ! ----- Method: InstallerInternetBased>>httpGet: (in category 'utils') ----- httpGet: aUrl | page | page := self classHTTPSocket httpGet: aUrl accept: 'application/octet-stream'. (page respondsTo: #reset) ifFalse: [ self error: 'unable to contact web site' ]. ^ page ! ----- Method: InstallerInternetBased>>isHtmlStream: (in category 'url') ----- isHtmlStream: page "matches '<!!DOCTYPE HTML', and <html>' " | first | first := (page next: 14) asUppercase. ^ (first = '<!!DOCTYPE HTML') | (first beginsWith: '<HTML>') ! ----- Method: InstallerInternetBased>>markers (in category 'as yet unclassified') ----- markers ^ markers ifNil: [ '<code st>..."test ...</code st>' ]! ----- Method: InstallerInternetBased>>markers: (in category 'as yet unclassified') ----- markers: anObject markers := anObject! ----- Method: InstallerInternetBased>>markersBegin (in category 'as yet unclassified') ----- markersBegin ^ self markers copyUpTo: $.! ----- Method: InstallerInternetBased>>markersEnd (in category 'as yet unclassified') ----- markersEnd "return the third marker or the second if there are only two" | str a | str := self markers readStream. a := str upToAll: '...'; upToAll: '...'. str atEnd ifTrue: [ ^a ] ifFalse: [ ^str upToEnd ] ! ----- Method: InstallerInternetBased>>markersTest (in category 'as yet unclassified') ----- markersTest ^ self markers readStream upToAll: '...'; upToAll: '...'! ----- Method: InstallerInternetBased>>removeHtmlMarkupFrom: (in category 'as yet unclassified') ----- removeHtmlMarkupFrom: in | out | out := WriteStream on: (String new: 100). [ in atEnd ] whileFalse: [ out nextPutAll: (in upTo: $<). (((in upTo: $>) asLowercase beginsWith: 'br') and: [ (in peek = Character cr) ]) ifTrue: [ in next ]. ]. ^self replaceEntitiesIn: out readStream. ! ----- Method: InstallerInternetBased>>replaceEntitiesIn: (in category 'url') ----- replaceEntitiesIn: in | out | out := WriteStream on: (String new: 100). [ in atEnd ] whileFalse: [ out nextPutAll: ((in upTo: $&) replaceAll: Character lf with: Character cr). in atEnd ifFalse: [ out nextPutAll: (self class entities at: (in upTo: $;) ifAbsent: '?') ]. ]. ^out readStream! ----- Method: InstallerInternetBased>>url (in category 'accessing') ----- url ^url! ----- Method: InstallerInternetBased>>url: (in category 'accessing') ----- url: aUrl url := aUrl! ----- Method: InstallerInternetBased>>urlGet (in category 'url') ----- urlGet ^ self urlGet: self urlToDownload! ----- Method: InstallerInternetBased>>urlGet: (in category 'url') ----- urlGet: aUrl | page | page := HTTPSocket httpGet: aUrl accept: 'application/octet-stream'. (page respondsTo: #reset) ifFalse: [ ^ nil ]. (self isHtmlStream: page) ifTrue: [ page := self extractFromHtml: page option: nil ]. ^ page reset ! ----- Method: InstallerInternetBased>>wasPbwikiSpeedWarning (in category 'url') ----- wasPbwikiSpeedWarning ^ self hasPage and: [pageDataStream contents includesSubString: 'Please slow down a bit' ] ! InstallerInternetBased subclass: #InstallerUrl instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Installer-Core'! ----- Method: InstallerUrl class>>canReportLine: (in category 'action report') ----- canReportLine: line ^ ((line beginsWith: 'Installer installUrl:') and: [ | ext | ext := (line readStream upToAll: '''.') copyAfterLast: $.. (#( 'cs' 'st' 'mcz' 'sar') includes: ext) not ])! ----- Method: InstallerUrl>>action:reportOn: (in category 'action report') ----- action: line reportOn: report url := line readStream upTo: $' ; upTo: $'. self reportSection: line on: report. (pageDataStream := self urlGet: self urlToDownload) ifNil: [ self error: 'unable to contact host' ]. self reportFor: line page: pageDataStream on: report ! ----- Method: InstallerUrl>>addPackage: (in category 'as yet unclassified') ----- addPackage: aPackageName super addPackage: aPackageName. (self url endsWith: '/') ifFalse: [self url: self url, '/'].! ----- Method: InstallerUrl>>basicBrowse (in category 'basic interface') ----- basicBrowse "(Installer debug url: 'http://installer.pbwiki.com/f/Installer.st') browse.". self browse: self urlToDownload from: self urlThing. ! ----- Method: InstallerUrl>>basicInstall (in category 'basic interface') ----- basicInstall self install: self urlToDownload from: self urlThing. ^ pageDataStream ! ----- Method: InstallerUrl>>basicView (in category 'basic interface') ----- basicView "(Installer debug url: 'http://installer.pbwiki.com/f/Installer.st') view.". self view: self urlToDownload from: self urlThing. ! ----- Method: InstallerUrl>>fileInSource (in category 'accessing') ----- fileInSource " (Installer url: 'http://www.squeaksource.com/Sake/Sake-Core-kph.47.mcz') bootstrap. " | pkg splitPos repo getFileName fileName | useFileIn := true. splitPos := url lastIndexOf: $/. pkg := url copyFrom: splitPos + 1 to: url size. repo := url copyFrom: 1 to: splitPos. getFileName := [ :pkgName | pkgName , ((HTTPSocket httpGet: repo) upToAll: pkgName; upTo: $") ]. fileName := getFileName value: pkg. url := repo,fileName. self install! ----- Method: InstallerUrl>>urlThing (in category 'url') ----- urlThing | retry delay | self logCR: 'retrieving ', self urlToDownload , ' ...'. delay := 0. [retry := false. pageDataStream := self urlGet: self urlToDownload. self wasPbwikiSpeedWarning ifTrue: [ retry := true. delay := delay + 5. self logCR: 'PBWiki speed warning. Retrying in ', delay printString, ' seconds'. (Delay forSeconds: delay) wait ]. retry ] whileTrue. pageDataStream ifNil: [ self error: 'unable to contact host' ]. ^ pageDataStream ! ----- Method: InstallerUrl>>urlToDownload (in category 'url') ----- urlToDownload ^ (self url, (self package ifNil: [ '' ])) asUrl asString. ! InstallerInternetBased subclass: #InstallerWebBased instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Installer-Core'! InstallerWebBased subclass: #InstallerMantis instanceVariableNames: 'ma bug desc date array data status' classVariableNames: 'Fixes Status' poolDictionaries: '' category: 'Installer-Core'! !InstallerMantis commentStamp: 'test 1/14/2009 00:11' prior: 0! Search feature is based upon a custom mantis query ceveloped and maintained by Ken Causey <ken(a)kencausey.com> Installer mantis bugsAll select: [ :ea | ea status = 'testing' ].! ----- Method: InstallerMantis class>>canReportLine: (in category 'action report') ----- canReportLine: line ^ line beginsWith: 'Installer mantis fixBug:'! ----- Method: InstallerMantis class>>fixesApplied (in category 'accessing') ----- fixesApplied ^ Fixes ifNil: [ Fixes := OrderedCollection new ].! ----- Method: InstallerMantis class>>host: (in category 'instance creation') ----- host: host ^self new ma: host; markers: '"fix begin"..."fix test"..."fix end"'; yourself. ! ----- Method: InstallerMantis class>>initialize (in category 'instance creation') ----- initialize Status := Dictionary new at: '10' put: 'new'; at: '20' put: 'feedback'; at: '30' put: 'acknowledged'; at: '40' put: 'confirmed'; at: '50' put: 'assigned'; at: '60' put: 'pending'; at: '70' put: 'testing'; at: '80' put: 'resolved'; at: '90' put: 'closed'; yourself ! ----- Method: InstallerMantis>>= (in category 'accessing') ----- = other self == other ifTrue: [ ^ true ]. self species = other species ifFalse: [ ^ false ]. ^ array = other array! ----- Method: InstallerMantis>>action:reportOn: (in category 'action report') ----- action: line reportOn: report | param mantis | mantis := Installer mantis. param := line readStream upTo: $: ; upTo: $.. mantis setBug: ((param readStream upTo: $'; atEnd) ifTrue: [ param ] ifFalse: [ param readStream upTo: $'; upTo: $' ]). self reportSection: line on: report. report nextPutAll: (mantis replaceEntitiesIn: mantis markersBegin readStream). self reportFor: line page: mantis maScript on: report. report nextPutAll: (mantis replaceEntitiesIn: mantis markersEnd readStream); cr. ! ----- Method: InstallerMantis>>array (in category 'accessing') ----- array ^ array! ----- Method: InstallerMantis>>browseFile: (in category 'public interface') ----- browseFile: aFileName ^ self browse: aFileName from: (self maThing: aFileName date: nil)! ----- Method: InstallerMantis>>bug (in category 'accessing') ----- bug ^ bug ifNil: [ date := ((self dataAtName: 'Updated') replaceAll: $ with: $T) asDateAndTime. desc := (self dataAtName: 'Summary'). bug := (self dataAtName: 'Id'). self statusInit. ]! ----- Method: InstallerMantis>>bug: (in category 'public interface') ----- bug: aBugNo | page | self setBug: aBugNo. page := self maPage. date := ((self maRead: page field: 'Date Updated') value replaceAll: $ with: $T) asDateAndTime. status := (self maRead: page field: 'Status') value. " Installer mantis bug: 7235 "! ----- Method: InstallerMantis>>bug:browse: (in category 'public interface') ----- bug: aBugNo browse: aFileName self setBug: aBugNo. ^ self browseFile: aFileName! ----- Method: InstallerMantis>>bug:fix: (in category 'public interface') ----- bug: aBugNo fix: aFileName ^ self bug: aBugNo fix: aFileName date: nil! ----- Method: InstallerMantis>>bug:fix:date: (in category 'public interface') ----- bug: aBugNo fix: aFileName date: aDate | | self setBug: aBugNo. self ditchOldChangeSetFor: aFileName. self install: aFileName from: (self maThing: aFileName date: aDate). ^ date! ----- Method: InstallerMantis>>bug:retrieve: (in category 'public interface') ----- bug: aBugNo retrieve: aFileName self setBug: aBugNo. ^ (self maStreamForFile: aFileName) contents! ----- Method: InstallerMantis>>bug:view: (in category 'public interface') ----- bug: aBugNo view: aFileName "Installer mantis bug: 6089 browse: 'TTFSpeedUp-dgd.1.cs'" self setBug: aBugNo. ^ self view: aFileName from: (self maThing: aFileName date: nil)! ----- Method: InstallerMantis>>bugFiles: (in category 'public interface') ----- bugFiles: aBugNo "provide a list of files associated with the bug in id order" " Installer mantis bugFiles: 6660. " self setBug: aBugNo; files! ----- Method: InstallerMantis>>bugFilesView: (in category 'public interface') ----- bugFilesView: aBugNo "provide a list of files associated with the bug in id order" " Installer mantis bugFiles: 6660. " self setBug: aBugNo; viewFiles! ----- Method: InstallerMantis>>bugScript: (in category 'public interface') ----- bugScript: aBugNo ^ (self setBug: aBugNo) script ! ----- Method: InstallerMantis>>bugsAll (in category 'action report') ----- bugsAll ^ array ifNil: [ array := ( self bugsSqueak , (self dataGetFrom: '/installer_export.php') ) asSet asSortedCollection: [ :a :b | a date > b date ] ]. " Installer mantis bugsAll " ! ----- Method: InstallerMantis>>bugsClosed (in category 'search') ----- bugsClosed ^ array ifNil: [ array := self dataGetFrom: '/installer_export.php?closed' ]! ----- Method: InstallerMantis>>bugsRelease: (in category 'search') ----- bugsRelease: version ^self bugsAll select: [ :ea | (ea status = 'resolved') and: [ ea fixedIn = version ]]! ----- Method: InstallerMantis>>bugsSqueak (in category 'search') ----- bugsSqueak ^ array ifNil: [ array := self dataGetFrom: '/installer_export.php?project=Squeak' ] " Installer mantis bugsSqueak. Installer mantis bugsAll. Installer mantis bugsClosed. "! ----- Method: InstallerMantis>>bugsTesting: (in category 'search') ----- bugsTesting: version ^self bugsAll select: [ :ea | ea status = 'testing' and: [ ea fixedIn = version ]]! ----- Method: InstallerMantis>>category (in category 'search') ----- category ^ self dataAtName: 'Category' " s bugs collect: [ :ea | ea category ] "! ----- Method: InstallerMantis>>dataAtName: (in category 'search') ----- dataAtName: key ^ array at: (self dataNames indexOf: key)! ----- Method: InstallerMantis>>dataAtName:put: (in category 'search') ----- dataAtName: key put: v ^ array at: (self dataNames indexOf: key) put: v! ----- Method: InstallerMantis>>dataClosed (in category 'search') ----- dataClosed ^ array ifNil: [ array := self dataGetFrom: '/installer_export.php?closed' ]! ----- Method: InstallerMantis>>dataGetFrom: (in category 'public interface') ----- dataGetFrom: aPath | rs line first col row out | rs := HTTPSocket httpGet: ma, aPath. rs isString ifTrue: [ ^ ProtocolClientError signal: 'notFound' ]. first := true. out := OrderedCollection new. [ rs atEnd ] whileFalse: [ line := rs nextLine readStream. col := 1. row := Array new: 9. [ (line atEnd or: [ col > 9 ]) ] whileFalse: [ row at: col put: (line upTo: $|). col := col + 1 ]. rs next. [ out add: (self class new in: self row: row) ] ifError: [] ]. ^ out " self reset. self getBugsList "! ----- Method: InstallerMantis>>dataNames (in category 'public interface') ----- dataNames ^ #(Id Project Category Assigned Updated Status Severity FixedIn Summary)! ----- Method: InstallerMantis>>date (in category 'accessing') ----- date ^ date ! ----- Method: InstallerMantis>>date: (in category 'accessing') ----- date: anObject date := anObject ifNotNil: [anObject asDate ]! ----- Method: InstallerMantis>>desc (in category 'accessing') ----- desc ^ desc! ----- Method: InstallerMantis>>desc: (in category 'accessing') ----- desc: anObject desc := anObject! ----- Method: InstallerMantis>>ensureFix (in category 'public interface') ----- ensureFix | fixesAppliedNumbers | fixesAppliedNumbers := self fixesApplied collect: [ :fixDesc | fixDesc asInteger ]. (fixesAppliedNumbers includes: bug) ifFalse: [ self fixBug ]! ----- Method: InstallerMantis>>ensureFix: (in category 'public interface') ----- ensureFix: aBugNo ^self ensureFix: aBugNo date: nil! ----- Method: InstallerMantis>>ensureFix:date: (in category 'public interface') ----- ensureFix: aBugNo date: aDate self setBug: aBugNo. self date: aDate. self ensureFix.! ----- Method: InstallerMantis>>ensureFixes: (in category 'public interface') ----- ensureFixes: aBugNos aBugNos do: [ :bugNo | self ensureFix: bugNo ].! ----- Method: InstallerMantis>>files (in category 'public interface') ----- files "provide a list of files associated with the bug in id order" " Installer mantis bugFiles: 6660. " ^ (self maFiles associations asSortedCollection: [ :a :b | a value asInteger < b value asInteger ]) collect: [ :a | a key ]! ----- Method: InstallerMantis>>fixBug (in category 'public interface') ----- fixBug self install: self maUrl from: self maScript. self maCheckDateAgainst: date. self fixesAppliedNumbers in: [ :fixed | (fixed isEmpty or: [ (fixed includes: bug asInteger) not]) ifTrue: [ self fixesApplied add: (bug asString, ' ', desc) ]]. ! ----- Method: InstallerMantis>>fixBug: (in category 'public interface') ----- fixBug: aBugNo ^ self fixBug: aBugNo date: nil. ! ----- Method: InstallerMantis>>fixBug:date: (in category 'public interface') ----- fixBug: aBugNo date: aDate self setBug: aBugNo. self date: aDate. self fixBug. ! ----- Method: InstallerMantis>>fixedIn (in category 'search') ----- fixedIn ^ self dataAtName: 'FixedIn' ! ----- Method: InstallerMantis>>fixesApplied (in category 'public interface') ----- fixesApplied ^ Fixes ifNil: [ Fixes := OrderedCollection new ].! ----- Method: InstallerMantis>>fixesAppliedNumbers (in category 'public interface') ----- fixesAppliedNumbers ^ self fixesApplied collect: [ :fixDesc | fixDesc asInteger ]. ! ----- Method: InstallerMantis>>getView (in category 'accessing') ----- getView "Installer mantis viewBug: 5639." | page text | page := self maPage. text := String streamContents: [ :str | #('Bug ID' 'Category' 'Severity' 'Reproducibility' 'Date Submitted' 'Date Updated' 'Reporter' 'View Status' 'Handler' 'Priority' 'Resolution' 'Status' 'Product Version' 'Summary' 'Description' 'Additional Information' ) do: [ :field | | f | f := self maRead: page field: field. str nextPutAll: f key; nextPutAll: ': '; nextPutAll: f value; cr. ]. str nextPutAll: 'Notes: '; cr. (self maReadNotes: page) do: [ :note | str nextPutAll: note; cr; cr ]. str nextPutAll: 'Files: '; nextPutAll: self maFiles keys asArray printString. ]. ^ text ! ----- Method: InstallerMantis>>hash (in category 'accessing') ----- hash ^ array hash! ----- Method: InstallerMantis>>in:row: (in category 'public interface') ----- in: parent row: dataRow self ma: parent ma. self markers: parent markers. self setArray: dataRow.! ----- Method: InstallerMantis>>justFixBug: (in category 'public interface') ----- justFixBug: aBugNo ^self class skipLoadingTests: true during: [ self fixBug: aBugNo date: nil ]! ----- Method: InstallerMantis>>justFixBug:date: (in category 'public interface') ----- justFixBug: aBugNo date: d ^self class skipLoadingTests: true during: [ self fixBug: aBugNo date: d ]! ----- Method: InstallerMantis>>ma (in category 'accessing') ----- ma ^ ma! ----- Method: InstallerMantis>>ma: (in category 'accessing') ----- ma: aUrl ma := aUrl last = $/ ifTrue: [ aUrl ] ifFalse: [ aUrl, '/' ]! ----- Method: InstallerMantis>>maCheckDateAgainst: (in category 'utils') ----- maCheckDateAgainst: okDate (okDate notNil and: [date < okDate asDate ]) ifTrue: [ self notify: 'bug ', self bug asString, ' updated on ', date printString ]. ! ----- Method: InstallerMantis>>maFiles (in category 'mantis') ----- maFiles | file files bugPage id | files := Dictionary new. bugPage := self maPage. [ id := bugPage upToAll: 'href="file_download.php?file_id='; upTo: $&. file := bugPage upToAll: 'amp;type=bug"' ; upTo: $<. ((file size > 1) and: [file first = $>]) ifTrue: [ files at: file copyWithoutFirst put: id ]. id notEmpty ] whileTrue. ^files ! ----- Method: InstallerMantis>>maPage (in category 'mantis') ----- maPage " self mantis bug: 5251." | page | page := self httpGet: self maUrl. date := ((self maRead: page field: 'Date Updated') value copyUpTo: $ ). date isEmpty ifTrue: [ ^self error: bug asString, ' not found' ]. date := date asDate. ^page reset! ----- Method: InstallerMantis>>maRead:field: (in category 'mantis') ----- maRead: page field: fieldKey | value | value := page upToAll: ('!!-- ', fieldKey, ' -->'); upToAll: '<td'; upTo: $>; upToAll: '</td>'. page upTo: $<. page peek = $t ifTrue: [ value := page upToAll: 'td'; upTo: $>; upToAll: '</td>' ]. ^Association key: fieldKey value: (self removeHtmlMarkupFrom: value withBlanksTrimmed readStream) contents! ----- Method: InstallerMantis>>maReadNotes: (in category 'mantis') ----- maReadNotes: page | notes note | notes := OrderedCollection new. [ page upToAll: 'tr class="bugnote"'; upTo: $>. page atEnd ] whileFalse: [ note := (self removeHtmlMarkupFrom: (page upToAll: '</tr>') readStream) contents. note := note withBlanksCondensed. note replaceAll: Character lf with: Character cr. notes add: note ]. ^notes! ----- Method: InstallerMantis>>maScript (in category 'mantis') ----- maScript ^self extractFromHtml: self maPage option: #last ! ----- Method: InstallerMantis>>maStreamForFile: (in category 'mantis') ----- maStreamForFile: aFileName | fileId | fileId := self maFiles at: aFileName ifAbsent: [ self error: aFileName, ' not found' ]. ^ self httpGet: (self ma, 'file_download.php?file_id=' , fileId , '&type=bug'). ! ----- Method: InstallerMantis>>maThing:date: (in category 'mantis') ----- maThing: aFileName date: aDate self logCR: 'obtaining ', aFileName, '...'. pageDataStream := self maStreamForFile: aFileName. self maCheckDateAgainst: aDate. ^ pageDataStream ! ----- Method: InstallerMantis>>maUrl (in category 'mantis') ----- maUrl ^ url := self ma, 'view.php?id=', bug asString ! ----- Method: InstallerMantis>>maUrlFor: (in category 'mantis') ----- maUrlFor: maBugNo ^ url := self ma, 'view.php?id=', maBugNo asString ! ----- Method: InstallerMantis>>printOn: (in category 'accessing') ----- printOn: stream super printOn: stream. (array ifNil: [ ^ self ]) printOn: stream.! ----- Method: InstallerMantis>>project (in category 'search') ----- project ^ self dataAtName: 'Project' ! ----- Method: InstallerMantis>>report (in category 'public interface') ----- report "Installer mantis viewBug: 5639." | page text | page := self maPage. text := String streamContents: [ :str | #('Bug ID' 'Category' 'Severity' 'Reproducibility' 'Date Submitted' 'Date Updated' 'Reporter' 'View Status' 'Handler' 'Priority' 'Resolution' 'Status' 'Product Version' 'Summary' 'Description' 'Additional Information' ) do: [ :field | | f | f := self maRead: page field: field. str nextPutAll: f key; nextPutAll: ': '; nextPutAll: f value; cr. ]. str nextPutAll: 'Notes: '; cr. (self maReadNotes: page) do: [ :note | str nextPutAll: note; cr; cr ]. str nextPutAll: 'Files: '; nextPutAll: self maFiles keys asArray printString. ]. ^ text ! ----- Method: InstallerMantis>>script (in category 'public interface') ----- script ^ self maScript contents. ! ----- Method: InstallerMantis>>selectCategoryCollections (in category 'public interface') ----- selectCategoryCollections ^ self select: [ :ea | ea category = 'Collections' ]! ----- Method: InstallerMantis>>setArray: (in category 'public interface') ----- setArray: dataRow (array := dataRow) ifNotNil: [ self bug ].! ----- Method: InstallerMantis>>setBug: (in category 'mantis') ----- setBug: stringOrNumber | newBug | (newBug := stringOrNumber asInteger) = bug ifTrue: [ ^ self ]. self logCR: 'Installer accessing bug: ' , stringOrNumber asString. bug := newBug. stringOrNumber = bug ifTrue: [ desc := ''. ^ self ]. desc := stringOrNumber withoutLeadingDigits ! ----- Method: InstallerMantis>>status (in category 'accessing') ----- status ^ status! ----- Method: InstallerMantis>>statusInit (in category 'accessing') ----- statusInit status ifNil: [ status := Status at: (self dataAtName: 'Status'). self dataAtName:'Status' put: status. ]. ! ----- Method: InstallerMantis>>summary (in category 'search') ----- summary ^ self dataAtName: 'Summary'! ----- Method: InstallerMantis>>validChangeSetName: (in category 'action report') ----- validChangeSetName: aFileName | csn prefix | csn := super validChangeSetName: aFileName. prefix := 'M' , self bug asInteger asString. csn := csn replaceAll: ('-', prefix) with: ''. csn := csn replaceAll: (prefix,'-') with: ''. csn := csn replaceAll: prefix with: ''. ^ prefix, '-', csn ! ----- Method: InstallerMantis>>view (in category 'public interface') ----- view ^ Workspace new contents: self report; openLabel: ('Mantis ', bug printString). ! ----- Method: InstallerMantis>>viewBug: (in category 'public interface') ----- viewBug: aBugNo self setBug: aBugNo; view! ----- Method: InstallerMantis>>viewFile: (in category 'public interface') ----- viewFile: aFileName "Installer mantis bug: 6089 browse: 'TTFSpeedUp-dgd.1.cs'" ^ self view: aFileName from: (self maThing: aFileName date: nil)! ----- Method: InstallerMantis>>viewFiles (in category 'public interface') ----- viewFiles ^ self files do: [ :ea | self viewFile: ea ].! InstallerWebBased subclass: #InstallerWeb instanceVariableNames: '' classVariableNames: 'WebSearchPath' poolDictionaries: '' category: 'Installer-Core'! ----- Method: InstallerWeb class>>canReportLine: (in category 'action report') ----- canReportLine: line ^ ((line beginsWith: 'Installer install:') | (line beginsWith: 'Installer do:'))! ----- Method: InstallerWeb class>>initialize (in category 'instanciation') ----- initialize WebSearchPath := nil! ----- Method: InstallerWeb class>>install: (in category 'compatability') ----- install: webPageName "This keeps the syntax Installer web install: working" ^ self new install: webPageName! ----- Method: InstallerWeb class>>searchPath (in category 'accessing') ----- searchPath "a search path item, has the following format. prefix*suffix" ^ WebSearchPath ifNil: [ WebSearchPath := OrderedCollection new ].! ----- Method: InstallerWeb>>action:reportOn: (in category 'action report') ----- action: line reportOn: report self package: (line readStream upTo: $' ; upTo: $'). self reportSection: line on: report. url := self urlToDownload. self reportFor: line page: pageDataStream on: report ! ----- Method: InstallerWeb>>basicBrowse (in category 'basic interface') ----- basicBrowse self thing size > 0 ifTrue: [ self browse: url from: pageDataStream ] ifFalse: [ self logCR: 'NO DATA ',url,' was empty' ]. ! ----- Method: InstallerWeb>>basicInstall (in category 'basic interface') ----- basicInstall self thing size > 0 ifTrue: [ self install: url from: pageDataStream ] ifFalse: [ url ifNil: [ ^ self logCR: self package, ' not found on webSearchPath' ]. self logCR: '...',url,' was empty' ]. ! ----- Method: InstallerWeb>>basicView (in category 'basic interface') ----- basicView self thing size > 0 ifTrue: [ self view: url from: pageDataStream ] ifFalse: [ self logCR: 'NO DATA ',url,' was empty' ]. ! ----- Method: InstallerWeb>>thing (in category 'web install') ----- thing self logCR: 'searching for web package ''', self package, ''''. url := self urlToDownload. url ifNil: [ self logCR: 'page ', self package, ' not found on path' ] ifNotNil: [ self logCR: 'found ', url, ' ...'. ]. ^ pageDataStream! ----- Method: InstallerWeb>>urlToDownload (in category 'web install') ----- urlToDownload "while we look for a url which returns what we are looking for, we get the data anyway" | delay | delay := 0. self class webSearchPath do: [ :pathSpec | | potentialUrl readPathSpec retry | readPathSpec := pathSpec value readStream. potentialUrl := (readPathSpec upTo: $*), self package, (readPathSpec upToEnd ifNil: [ '' ]). [retry := false. pageDataStream := self urlGet: potentialUrl. self wasPbwikiSpeedWarning ifTrue: [ retry := true. delay := delay + 5. self logCR: 'PBWiki speed warning. Retrying in ', delay printString, ' seconds'. (Delay forSeconds: delay) wait] ifFalse: [ self hasPage ifTrue: [ pageDataStream reset. ^ potentialUrl ] ]. retry ] whileTrue ]. ^nil ! InstallerWebBased subclass: #InstallerWebSqueakMap instanceVariableNames: 'wsm' classVariableNames: '' poolDictionaries: '' category: 'Installer-Core'! ----- Method: InstallerWebSqueakMap>>basicAvailablePackages (in category 'websqueakmap') ----- basicAvailablePackages | html id name pkgs | pkgs := Dictionary new. html := self httpGet: (self wsm, 'packagesbyname'). [ id := html upToAll: '/package/'; upToAll: '">'. name := html upTo: $<. (id notEmpty and: [ name notEmpty ])] whileTrue: [ pkgs at: name put: id ]. ^ pkgs ! ----- Method: InstallerWebSqueakMap>>basicInstall (in category 'basic interface') ----- basicInstall | it | it := self wsmThing. self install: it from: it asUrl retrieveContents contentStream. ! ----- Method: InstallerWebSqueakMap>>basicVersions (in category 'basic interface') ----- basicVersions | pkgAndVersion packageId packageName packageVersion versions | pkgAndVersion := self packageAndVersionFrom: self package . packageName := pkgAndVersion first. packageVersion := pkgAndVersion last. packageVersion isEmpty ifTrue: [ packageVersion := #latest ]. packageId := self availablePackages at: packageName. versions := (self wsmReleasesFor: packageId) keys asSet. versions remove: #latest. ^ versions collect: [ :version | self copy package: (packageName,'(', version ,')'); yourself ]. ! ----- Method: InstallerWebSqueakMap>>basicView (in category 'basic interface') ----- basicView | it | it := self wsmThing. self view: it from: (self httpGet: it). ! ----- Method: InstallerWebSqueakMap>>packagesMatching: (in category 'searching') ----- packagesMatching: aMatch ^ (self availablePackages select: [ :p | ( aMatch) match: p ]) collect: [ :p | self copy package: p ; yourself ]! ----- Method: InstallerWebSqueakMap>>wsm (in category 'websqueakmap') ----- wsm ^ wsm! ----- Method: InstallerWebSqueakMap>>wsm: (in category 'websqueakmap') ----- wsm: aUrl wsm := aUrl last = $/ ifTrue: [ aUrl ] ifFalse: [ aUrl, '/' ]! ----- Method: InstallerWebSqueakMap>>wsmDownloadUrl (in category 'websqueakmap') ----- wsmDownloadUrl | pkgAndVersion packageId packageName packageVersion releaseAutoVersion downloadPage | pkgAndVersion := self packageAndVersionFrom: self package. packageName := pkgAndVersion first. packageVersion := pkgAndVersion last. packageVersion isEmpty ifTrue: [ packageVersion := #latest ]. packageId := self availablePackages at: packageName. releaseAutoVersion := (self wsmReleasesFor: packageId) at: packageVersion. downloadPage := self httpGet: (self wsm,'packagebyname/', packageName,'/autoversion/', releaseAutoVersion,'/downloadurl') asUrl asString. ^ downloadPage contents ! ----- Method: InstallerWebSqueakMap>>wsmReleasesFor: (in category 'websqueakmap') ----- wsmReleasesFor: packageId | html autoVersion version releases | releases := Dictionary new. html := self httpGet: (self wsm, '/package/', packageId ). [releases at: #latest put: autoVersion. autoVersion := html upToAll: '/autoversion/'; upTo: $". version := html upTo: $-; upTo: $<. (autoVersion notEmpty and: [version notEmpty ])] whileTrue: [ releases at: version put: autoVersion ]. ^ releases ! ----- Method: InstallerWebSqueakMap>>wsmThing (in category 'websqueakmap') ----- wsmThing | downloadUrl | self logCR: 'finding ', self package, ' from websqueakmap(', self wsm, ') ...'. downloadUrl := self wsmDownloadUrl. self logCR: 'found at ', downloadUrl asString, ' ...'. ^ downloadUrl ! Installer subclass: #InstallerMonticello instanceVariableNames: 'mc root project' classVariableNames: '' poolDictionaries: '' category: 'Installer-Core'! ----- Method: InstallerMonticello>>basicAvailablePackages (in category 'basic interface') ----- basicAvailablePackages ^ self mc allPackageNames! ----- Method: InstallerMonticello>>basicBrowse (in category 'basic interface') ----- basicBrowse "Installer ss project: 'Installer'; browse: 'Installer-Core'." | it | it := self mcThing. (it class includesSelector: #browse) ifTrue: [ ^ it browse ]. (it instVarNamed: 'versions') do: [ :each | each browse ].! ----- Method: InstallerMonticello>>basicInstall (in category 'basic interface') ----- basicInstall self withAnswersDo: [ self mcThing load ]. self logCR: 'loaded'. ! ----- Method: InstallerMonticello>>basicVersions (in category 'basic interface') ----- basicVersions ^ (self availablePackages select: [ :p | ( self package,'-*.mcz' ) match: p ]) collect: [ :p | self copy package: p ; yourself ]. ! ----- Method: InstallerMonticello>>basicView (in category 'basic interface') ----- basicView "Installer ss project: 'Installer'; view: 'Installer-Core'. " | it | packages isEmptyOrNil ifTrue: [ self mc morphicOpen: nil ]. it := self mcThing. (it respondsTo: #open) ifTrue: [ ^ it open ]. "in case an old mc doesnt have #open" (it instVarNamed: 'versions') do: [ :each | each open ]. ! ----- Method: InstallerMonticello>>cache (in category 'instance creation') ----- cache mc := self classMCCacheRepository default. root := mc directory localName ! ----- Method: InstallerMonticello>>classMCCacheRepository (in category 'class references') ----- classMCCacheRepository ^Smalltalk at: #MCCacheRepository ifAbsent: [ self error: 'Monticello not present' ] ! ----- Method: InstallerMonticello>>classMCDirectoryRepository (in category 'class references') ----- classMCDirectoryRepository ^Smalltalk at: #MCDirectoryRepository ifAbsent: [ self error: 'Monticello not present' ] ! ----- Method: InstallerMonticello>>classMCFtpRepository (in category 'class references') ----- classMCFtpRepository ^Smalltalk at: #MCFtpRepository ifAbsent: [ self error: 'Monticello not present' ] ! ----- Method: InstallerMonticello>>classMCGOODSRepository (in category 'class references') ----- classMCGOODSRepository ^Smalltalk at: #MCGOODSRepository ifAbsent: [ self error: 'Monticello not present' ] ! ----- Method: InstallerMonticello>>classMCHttpRepository (in category 'class references') ----- classMCHttpRepository ^Smalltalk at: #MCHttpRepository ifAbsent: [ self error: 'Monticello not present' ] ! ----- Method: InstallerMonticello>>classMCMagmaRepository (in category 'class references') ----- classMCMagmaRepository ^Smalltalk at: #MCMagmaRepository ifAbsent: [ self error: 'Magma not present' ] ! ----- Method: InstallerMonticello>>classMCSmtpRepository (in category 'class references') ----- classMCSmtpRepository ^Smalltalk at: #MCSmtpRepository ifAbsent: [ self error: 'Monticello not present' ] ! ----- Method: InstallerMonticello>>classMCVersionLoader (in category 'class references') ----- classMCVersionLoader ^Smalltalk at: #MCVersionLoader ifAbsent: [ self error: 'Monticello not present' ]! ----- Method: InstallerMonticello>>directory: (in category 'instance creation') ----- directory: dir | directory | directory := dir isString ifTrue: [ FileDirectory on: (FileDirectory default fullNameFor: dir) ] ifFalse: [ dir ]. mc := self classMCDirectoryRepository new directory: directory; yourself. root := dir ! ----- Method: InstallerMonticello>>fromUrl: (in category 'accessing') ----- fromUrl: aUrl | url path | url := aUrl asUrl. self http: url authority. path := url path. path size = 2 ifTrue: [ self project: path first. path removeFirst. ]. path size = 1 ifTrue: [ self package: path first ].! ----- Method: InstallerMonticello>>ftp:directory:user:password: (in category 'instance creation') ----- ftp: host directory: dir user: name password: secret "Installer mc ftp: 'mc.gjallar.se' directory: '' user: 'gjallar' password: secret." mc := self classMCFtpRepository host: host directory: dir user: name password: secret. root := dir. ! ----- Method: InstallerMonticello>>goods:port: (in category 'instance creation') ----- goods: host port: aport mc := (self classMCGOODSRepository new) host: host port: aport; yourself ! ----- Method: InstallerMonticello>>http: (in category 'instance creation') ----- http: aUrl self http: aUrl user: '' password: '' ! ----- Method: InstallerMonticello>>http:user:password: (in category 'instance creation') ----- http: aUrl user: name password: secret | url | url := (aUrl includesSubString: '://') ifTrue: [aUrl] ifFalse: ['http://', aUrl]. mc := self classMCHttpRepository location: url user: name password: secret. root := mc locationWithTrailingSlash ! ----- Method: InstallerMonticello>>initialize (in category 'public interface') ----- initialize super initialize. mc := MCRepositoryGroup default! ----- Method: InstallerMonticello>>latest (in category 'accessing') ----- latest | newPackage | newPackage := self package copyUpToLast: $-. self packages removeLast. self package: newPackage " Installer mc fromUrl: 'http://www.squeaksource.com/Installer/Installer-Core-kph.100.mcz'. "! ----- Method: InstallerMonticello>>latestFromUsers: (in category 'accessing') ----- latestFromUsers: list | newPackage | newPackage := self package copyUpToLast: $-. self packages removeLast. self package: (list collect: [ :ea | newPackage, '-', ea ])! ----- Method: InstallerMonticello>>magma:port: (in category 'instance creation') ----- magma: host port: aport mc := (self classMCMagmaRepository new) host: host port: aport; yourself ! ----- Method: InstallerMonticello>>mc (in category 'accessing') ----- mc ^ mc! ----- Method: InstallerMonticello>>mc: (in category 'accessing') ----- mc: aRepo mc := aRepo! ----- Method: InstallerMonticello>>mcDetectFileBlock: (in category 'monticello') ----- mcDetectFileBlock: pkg pkg isString ifTrue: [ ^ [ :aMCVersionName | (pkg beginsWith: aMCVersionName packageAndBranchName) and: [aMCVersionName beginsWith: pkg ] ] ]. (pkg isKindOf: Array) ifTrue: [ ^ [ :aMCVersionName | pkg anySatisfy: [ :item | (item beginsWith: aMCVersionName packageAndBranchName) and: [aMCVersionName beginsWith: item ] ] ] ]. pkg isBlock ifTrue: [ ^ pkg ]. ! ----- Method: InstallerMonticello>>mcSortFileBlock (in category 'monticello') ----- mcSortFileBlock ^ [:a :b | [(a findBetweenSubStrs: #($.)) allButLast last asInteger > (b findBetweenSubStrs: #($.)) allButLast last asInteger] on: Error do: [:ex | false]].! ----- Method: InstallerMonticello>>mcThing (in category 'monticello') ----- mcThing | loader | loader := self classMCVersionLoader new. "several attempts to read files - repository readableFileNames sometimes fails" self packages do: [:pkg | | versionNames fileToLoad version | versionNames := mc versionNamesForPackageNamed: (pkg asMCVersionName versionNumber = 0 ifTrue: [ "Just a package name specified, use it whole." pkg ] ifFalse: [pkg asMCVersionName packageName]). fileToLoad := (versionNames sorted: self mcSortFileBlock) detect: (self mcDetectFileBlock: pkg) ifNone: [ nil ]. fileToLoad ifNotNil: [version := mc versionNamed: fileToLoad. (version isKindOf: MCConfiguration) ifTrue: [^ version] ifFalse: [self normalizedRepositories do: [:repo | MCRepositoryGroup default addRepository: repo]. self normalizedRepositories do: [:repo | version workingCopy repositoryGroup addRepository: repo]. loader addVersion: version]. self logCR: ' found ' , version fileName , '...']]. ^ loader! ----- Method: InstallerMonticello>>mcUrl (in category 'monticello') ----- mcUrl ^ self mc description ! ----- Method: InstallerMonticello>>normalizedRepositories (in category 'monticello') ----- normalizedRepositories "Find an existing instance of any active repository so that we use whatever name and password the user usually uses. If not found, answer a copy" ^ mc repositories replace: [:repo | (MCRepositoryGroup default repositories includes: repo) ifTrue: [repo] ifFalse: [repo copy]]! ----- Method: InstallerMonticello>>open (in category 'public interface') ----- open self mc morphicOpen: nil! ----- Method: InstallerMonticello>>packagesMatching: (in category 'searching') ----- packagesMatching: aMatch ^ (self availablePackages select: [:p | ( aMatch , '.mcz' ) match: p]) collect: [:p | self copy package: p ; yourself]! ----- Method: InstallerMonticello>>project (in category 'accessing') ----- project ^ project! ----- Method: InstallerMonticello>>project: (in category 'accessing') ----- project: name project := name. packages := nil. (mc respondsTo: #location:) ifTrue:[ mc := mc copy location: root , name ]. (mc respondsTo: #directory:) ifTrue: [ mc := mc copy directory: root / name ]. ^self copy.! ----- Method: InstallerMonticello>>unload (in category 'public interface') ----- unload (MCWorkingCopy allManagers select: [ : each | self package match: each package name ]) do: [ : each | self logCR: 'Unloading ' , each package name. each unload. MCMcmUpdater disableUpdatesOfPackage: each package name ]. self unloadCleanUp! ----- Method: InstallerMonticello>>unload: (in category 'public interface') ----- unload: match self addPackage: match. self unload.! ----- Method: InstallerMonticello>>unloadCleanUp (in category 'public interface') ----- unloadCleanUp SystemOrganization removeEmptyCategories. "Until Mantis 5718 is addressed" Smalltalk at: #PackagePaneBrowser ifPresent: [ :ppbClass | ppbClass allInstancesDo: [ :ppb | ppb updatePackages ] ]. Smalltalk at: #Browser ifPresent: [ :bClass | bClass allInstancesDo: [ :b | b updateSystemCategories ] ]. Smalltalk fixObsoleteReferences.! Installer subclass: #InstallerSake instanceVariableNames: 'sake' classVariableNames: 'Sake' poolDictionaries: '' category: 'Installer-Core'! ----- Method: InstallerSake class>>classPackages (in category 'accessing system') ----- classPackages ^Smalltalk at: #Packages ifAbsent: [ self error: 'Sake Packages code not present' ]! ----- Method: InstallerSake class>>sake (in category 'accessing') ----- sake ^ Sake ifNil: [ self classPackages current ]! ----- Method: InstallerSake class>>sake: (in category 'accessing') ----- sake: aClass Sake := aClass! ----- Method: InstallerSake>>basicInstall (in category 'basic interface') ----- basicInstall self withAnswersDo: [ (self packages collect: [ :packageName | sake named: packageName ]) asTask run ]. ! ----- Method: InstallerSake>>sake (in category 'websqueakmap') ----- sake ^ sake ! ----- Method: InstallerSake>>sake: (in category 'websqueakmap') ----- sake: aSakePackagesClass sake := aSakePackagesClass! Installer subclass: #InstallerSqueakMap instanceVariableNames: 'sm' classVariableNames: '' poolDictionaries: '' category: 'Installer-Core'! ----- Method: InstallerSqueakMap>>basicAvailablePackages (in category 'basic interface') ----- basicAvailablePackages ^self classSMSqueakMap default packagesByName! ----- Method: InstallerSqueakMap>>basicBrowse (in category 'basic interface') ----- basicBrowse self smThing explore! ----- Method: InstallerSqueakMap>>basicInstall (in category 'basic interface') ----- basicInstall self log: ' installing '. self withAnswersDo: [ self smThing install ]. self log: ' done'. ! ----- Method: InstallerSqueakMap>>basicVersions (in category 'basic interface') ----- basicVersions ^ (self smReleasesForPackage: self package) collect: [ :v | self copy package: (v package name,'(',v version,')'); yourself. ] ! ----- Method: InstallerSqueakMap>>basicView (in category 'basic interface') ----- basicView self smThing explore! ----- Method: InstallerSqueakMap>>classSMLoader (in category 'class references') ----- classSMLoader ^Smalltalk at: #SMLoader ifAbsent: [ self error: 'SqueakMap Loader not present' ]! ----- Method: InstallerSqueakMap>>classSMSqueakMap (in category 'class references') ----- classSMSqueakMap ^Smalltalk at: #SMSqueakMap ifAbsent: [ self error: 'SqueakMap not present' ]! ----- Method: InstallerSqueakMap>>open (in category 'public interface') ----- open self classSMLoader open! ----- Method: InstallerSqueakMap>>packagesMatching: (in category 'searching') ----- packagesMatching: aMatch ^ (self availablePackages select: [ :p | aMatch match: p name ]) collect: [ :p | self copy package: p name; yourself ]! ----- Method: InstallerSqueakMap>>search: (in category 'searching') ----- search: aMatch | results | results := Set new. self availablePackages do: [ :pkg | ({ 'name:',pkg name. 'summary:', pkg summary. 'description:', pkg description. 'author:', pkg author. } anySatisfy: [ :field | aMatch match: field ]) ifTrue: [ results add: (self copy package: pkg name) ]. ]. ^results ! ----- Method: InstallerSqueakMap>>sm (in category 'accessing') ----- sm ^ sm ifNil: [ false ]! ----- Method: InstallerSqueakMap>>sm: (in category 'accessing') ----- sm: anObject sm := anObject! ----- Method: InstallerSqueakMap>>smPackageAndVersion (in category 'squeakmap') ----- smPackageAndVersion ^ self packageAndVersionFrom: self package.! ----- Method: InstallerSqueakMap>>smReleasesForPackage: (in category 'squeakmap') ----- smReleasesForPackage: name ^(self classSMSqueakMap default packageWithName: name) releases! ----- Method: InstallerSqueakMap>>smThing (in category 'squeakmap') ----- smThing | pkgAndVersion releases release | pkgAndVersion := self packageAndVersionFrom: self package. self logCR: 'retrieving ', self package, ' from SqueakMap...'. releases := self smReleasesForPackage: pkgAndVersion first. release := pkgAndVersion last isEmpty ifTrue: [ releases last ] ifFalse:[ releases detect: [ :rel | rel version = pkgAndVersion last ] ]. ^ release ! ----- Method: InstallerSqueakMap>>update (in category 'squeakmap') ----- update "Updates the local map for SqueakMap, upgrading SqueakMap to the latest version if necessary. When SqueakMap is old and needs to be upgraded, it does four things that mostly make sense in the interactive world SM was built for, but are totally evil here in the world of automatic scripting: 1. It asks the user if she wants to upgrade, in the form of a pop-up (see SMSqueakMap >> #checkVersion:). 2. It terminates its own process. 3. It creates a new UI process. (see the last line of the SqueakMap upgrade file-in: ''Project spawnNewProcessAndTerminateOld: true'', from http://map.squeak.org/accountbyid/9bdedc18-1525-44a6-9b79-db5d4a87f6f8/file… 4. It opens a SqueakMap window We work around these three problems seperately: 1. We use #answer:with: and #withAnswersDo: to automatically answer ''Yes'' when asked if we want to upgrade 2. We don't want this process to be terminated, so we run the update in a forked process and wait for it to finish, using #fork, #ensure:, and a Semaphore 3. We keep track of the UI process before updating, and if it changes, we terminate the new UI process and reinstall the old one using Project >> #resumeProcess: 4. We don't bother with the newly opened window. The other three problems are much worse. We do all this in a new process, since it is not unlikely that this method is executing in the UI process" | oldUIProcess doneSema | self answer: 'You need to upgrade the SqueakMap package' with: true. oldUIProcess := Project uiProcess. doneSema := Semaphore new. [[self withAnswersDo: [self classSMSqueakMap default loadUpdates]] ensure: [ | newUIProcess | newUIProcess := Project uiProcess. (oldUIProcess ~~ newUIProcess and: [oldUIProcess notNil and: [oldUIProcess isTerminated not]]) ifTrue: [ newUIProcess ifNotNil: [newUIProcess terminate]. oldUIProcess suspend. Project resumeProcess: oldUIProcess.]. doneSema signal]] fork. doneSema wait! Installer subclass: #InstallerUniverse instanceVariableNames: 'universe' classVariableNames: 'LastUniUpdate' poolDictionaries: '' category: 'Installer-Core'! ----- Method: InstallerUniverse class>>classUGlobalInstaller (in category 'accessing system') ----- classUGlobalInstaller ^Smalltalk at: #UGlobalInstaller ifAbsent: [ self error: 'Universes code not present' ]! ----- Method: InstallerUniverse class>>classUUniverse (in category 'accessing system') ----- classUUniverse ^Smalltalk at: #UUniverse ifAbsent: [ self error: 'Universes code not present' ]! ----- Method: InstallerUniverse class>>default (in category 'instance creation') ----- default ^ self universe: (self classUGlobalInstaller universe: self classUUniverse systemUniverse)! ----- Method: InstallerUniverse class>>universe: (in category 'instance creation') ----- universe: u ^ self new universe: u! ----- Method: InstallerUniverse>>basicInstall (in category 'basic interface') ----- basicInstall self packages do: [ :packageName | | potentials pkg pkgAndVersion version | pkgAndVersion := self packageAndVersionFrom: packageName. pkg := pkgAndVersion first. version := pkgAndVersion last. potentials := universe packageVersionsForPackage: pkg. pkg := version isEmpty ifTrue: [ potentials last ] ifFalse: [ version := self classUVersion readFrom: version readStream. (potentials anySatisfy: [ :p | p version = version]) ifFalse: [ ^ self error: 'version not found'] ]. universe planToInstallPackage: pkg. ]. self uniDoInstall! ----- Method: InstallerUniverse>>classUVersion (in category 'class references') ----- classUVersion ^Smalltalk at: #UVersion ifAbsent: [ self error: 'Universes code not present' ]! ----- Method: InstallerUniverse>>uniDoInstall (in category 'universes') ----- uniDoInstall self withAnswersDo: [ self universe doInstall ] ! ----- Method: InstallerUniverse>>universe (in category 'universes') ----- universe ^ universe! ----- Method: InstallerUniverse>>universe: (in category 'universes') ----- universe: u universe := u. self update.! ----- Method: InstallerUniverse>>update (in category 'public interface') ----- update (LastUniUpdate isNil or:[ (DateAndTime now - LastUniUpdate) > 600 seconds ]) ifTrue: [universe requestPackageList. LastUniUpdate := DateAndTime now]! Installer subclass: #InstallerUpdateStream instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Installer-Core'! ----- Method: InstallerUpdateStream>>changesetNamesFromUpdates:through: (in category 'updates') ----- changesetNamesFromUpdates: startNumber through: stopNumber "Answer the concatenation of summary strings for updates numbered in the given range" "self new changesetNamesFromUpdates: 7059 through: 7061" ^ String streamContents: [:aStream | ((ChangeSet changeSetsNamedSuchThat: [:aName | aName first isDigit and: [aName initialIntegerOrNil >= startNumber and: [aName initialIntegerOrNil <= stopNumber]]]) asArray sort: [:a :b | a name < b name]) do: [:aChangeSet | aStream cr; nextPutAll: aChangeSet summaryString]] ! ----- Method: InstallerUpdateStream>>loadUpdatesFromDisk (in category 'updates') ----- loadUpdatesFromDisk | updateDirectory updateNumbers | updateDirectory := self updateDirectoryOrNil. updateDirectory ifNil: [^ self]. updateNumbers := updateDirectory fileNames collect: [:fn | fn initialIntegerOrNil] thenSelect: [:fn | fn notNil]. self loadUpdatesFromDiskToUpdateNumber: updateNumbers max stopIfGap: false ! ----- Method: InstallerUpdateStream>>loadUpdatesFromDiskToUpdateNumber:stopIfGap: (in category 'updates') ----- loadUpdatesFromDiskToUpdateNumber: lastUpdateNumber stopIfGap: stopIfGapFlag "To use this mechanism, be sure all updates you want to have considered are in a folder named 'updates' which resides in the same directory as your image. Having done that, simply evaluate: Installer new loadUpdatesFromDiskToUpdateNumber: 100020 stopIfGap: false and all numbered updates <= lastUpdateNumber not yet in the image will be loaded in numerical order." "apparently does not use the updatelist too bad!! and to rewrite - sd 7 March 2008" | previousHighest currentUpdateNumber done fileNames aMessage updateDirectory loaded | updateDirectory := self updateDirectoryOrNil. updateDirectory ifNil: [^ self]. previousHighest := SystemVersion current highestUpdate. currentUpdateNumber := previousHighest. done := false. loaded := 0. [done] whileFalse: [currentUpdateNumber := currentUpdateNumber + 1. currentUpdateNumber > lastUpdateNumber ifTrue: [done := true] ifFalse: [fileNames := updateDirectory fileNamesMatching: currentUpdateNumber printString , '*'. fileNames size > 1 ifTrue: [^ self inform: 'ambiguity -- two files both start with ' , currentUpdateNumber printString , ' (at this point it is probably best to remedy the situation on disk, then try again.)']. fileNames size = 0 ifTrue: [Transcript cr; show: 'gap in updates from disk for update number '; print: currentUpdateNumber; show: ' found...'. done := stopIfGapFlag] ifFalse: [ChangeSet newChangesFromStream: (updateDirectory readOnlyFileNamed: fileNames first) named: fileNames first. SystemVersion current registerUpdate: currentUpdateNumber. loaded := loaded + 1]]]. aMessage := loaded = 0 ifTrue: ['No new updates found.'] ifFalse: [loaded printString , ' update(s) loaded.']. self inform: aMessage , ' Highest numbered update is now ' , (currentUpdateNumber - 1) printString , '.'! ----- Method: InstallerUpdateStream>>parseUpdateListContents: (in category 'updates') ----- parseUpdateListContents: listContentString "Parse the contents of an updates.list into {{releaseTag. {fileNames*}}*}, and return it." | sections releaseTag strm line fileNames | sections := OrderedCollection new. fileNames := OrderedCollection new: 1000. releaseTag := nil. strm := ReadStream on: listContentString. [strm atEnd] whileFalse: [line := strm nextLine. line size > 0 ifTrue: [line first = $# ifTrue: [releaseTag ifNotNil: [sections addLast: {releaseTag. fileNames asArray}]. releaseTag := line allButFirst. fileNames resetTo: 1] ifFalse: [line first = $* ifFalse: [fileNames addLast: line]]]]. releaseTag ifNotNil: [sections addLast: {releaseTag. fileNames asArray}]. ^ sections asArray ! ----- Method: InstallerUpdateStream>>updateDirectoryOrNil (in category 'updates') ----- updateDirectoryOrNil ^ (FileDirectory default directoryNames includes: 'updates') ifTrue: [FileDirectory default directoryNamed: 'updates'] ifFalse: [self inform: 'Error: cannot find "updates" folder'. nil]! ----- Method: InstallerUpdateStream>>writeList:toStream: (in category 'updates') ----- writeList: listContents toStream: strm "Write a parsed updates.list out as text. This is the inverse of parseUpdateListContents:" strm reset. listContents do: [:pair | | releaseTag fileNames | releaseTag := pair first. fileNames := pair last. strm nextPut: $#; nextPutAll: releaseTag; cr. fileNames do: [:fileName | strm nextPutAll: fileName; cr]]. strm close!

1 0

Squeak 4.6: Exceptions-cmm.49.mcz
by commits＠source.squeak.org 05 Jun '15

05 Jun '15

Chris Muller uploaded a new version of Exceptions to project Squeak 4.6: http://source.squeak.org/squeak46/Exceptions-cmm.49.mcz ==================== Summary ==================== Name: Exceptions-cmm.49 Author: cmm Time: 23 January 2014, 10:54:37.468 am UUID: 6cede9fe-b13d-481a-b8de-bb004ece1145 Ancestors: Exceptions-fbs.48 Remove unused categories. ==================== Snapshot ====================

1 0

Squeak 4.6: WebClient-Help-ar.10.mcz
by commits＠source.squeak.org 05 Jun '15

05 Jun '15

Chris Muller uploaded a new version of WebClient-Help to project Squeak 4.6: http://source.squeak.org/squeak46/WebClient-Help-ar.10.mcz ==================== Summary ==================== Name: WebClient-Help-ar.10 Author: ar Time: 31 August 2010, 11:09:04.966 pm UUID: 4c7a5c81-01c4-fc4d-a98e-1271bbd0c47d Ancestors: WebClient-Help-ar.9 Update change log for WebClient and WebServer 1.4. ==================== Snapshot ==================== SystemOrganization addCategory: #'WebClient-Help'! CustomHelp subclass: #WebClientHelp instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'WebClient-Help'! ----- Method: WebClientHelp class>>authentication (in category 'pages') ----- authentication "This method was automatically generated. Edit it using:" "WebClientHelp edit: #authentication" ^HelpTopic title: 'Authentication' contents: 'WebClient supports basic and digest authentication by default. WebClient delegates the retrieval of username/password to WebUtils which prompts the user for credentials. WebClient can either be supplied with specific credentials to be used or custom credentials handlers, for example: | client | client := WebClient new. client username: ''squeak''. client password: ''squeak''. client httpGet: ''http://www.squeak.org/protected''. Proxy authentication works the same way as authentication but operates on a different authentication context to allow different sets of credentials to work. !! ]style[(288 1 1 1 6 1 1 2 6 1 2 11 3 3 6 1 9 1 8 3 6 1 9 1 8 3 6 1 8 1 33 2 158),cblack;,cgray;,cblack;,c107107107,cblack;,cgray;,cblack;,c107107107,cblack;,b,cblack;,c000000127,cblack;,c107107107,cblack;,c000000127,cblack;,c127000127,cblack;,c107107107,cblack;,c000000127,cblack;,c127000127,cblack;,c107107107,cblack;,c000000127,cblack;,c127000127,cblack;,!!' readStream nextChunkText! ----- Method: WebClientHelp class>>bookName (in category 'accessing') ----- bookName "Returns the name of the custom help book" ^'WebClient'! ----- Method: WebClientHelp class>>changeLog (in category 'pages') ----- changeLog "This method was automatically generated. Edit it using:" "WebClientHelp edit: #changeLog" ^HelpTopic title: 'Version History' contents: 'WebClient 1.4: * Fixes cookie handling to be in line with RFC 2109 * Provide the final redirect url in requests * OAuth support via WebUtils. * Support for POST using chunked transfer-encoding WebClient 1.3: * Added logging in common log format * Added support for SSL/TLS via SqueakSSL. WebClient 1.2: * Added support for multipart/form-data posts * Added WebSocket support WebClient 1.1: * Added support for HEAD, TRACE, OPTIONS, and PUT methods WebClient 1.0: * Initial release. !!' readStream nextChunkText! ----- Method: WebClientHelp class>>cookieSupport (in category 'pages') ----- cookieSupport "This method was automatically generated. Edit it using:" "WebClientHelp edit: #cookieSupport" ^HelpTopic title: 'Cookie Support' contents: 'WebClient supports session cookies. Cookies are preserved within one WebClient session but not across multiple session (cookies can be copied or shared between WebClients which makes it easy to support where needed). Support for cookies can be disabled via WebClient''s #acceptCookies: property. !!' readStream nextChunkText! ----- Method: WebClientHelp class>>introduction (in category 'pages') ----- introduction "This method was automatically generated. Edit it using:" "WebClientHelp edit: #introduction" ^HelpTopic title: 'Introduction' contents: 'WebClient is a simple, yet reasonably complete HTTP client. WebClient uses HTTP 1.1, supports proxies (both authenticating and not), redirect support and authentication. WebClient comes with WebServer, an HTTP server implementation with a similarly simple yet reasonably complete approach.!!' readStream nextChunkText! ----- Method: WebClientHelp class>>multipleRequests (in category 'pages') ----- multipleRequests "This method was automatically generated. Edit it using:" "WebClientHelp edit: #multipleRequests" ^HelpTopic title: 'Multiple Requests' contents: 'WebClient can and should be used for multiple requests to the same host. This will ensure persistent connections as well as having cookies processed properly within one session: | client resp | client := WebClient new. resp := client httpGet: ''http://www.squeak.org/''. resp := client httpGet: ''http://www.squeak.org/Download''. resp := client httpGet: ''http://www.squeak.org/Features''. client close. One important issue to keep in mind is that because WebClient is optimized for persistent connections, you need to close it when you are done. That is not true for WebClient''s class-side convenience APIs, which prefetch the response and close the socket. Generally speaking, whenever you say ''WebClient new'' you need to close the client when you''re done (however, you can do so by sending #close to a response you''ve received). For example: "Convenience API. Don''t need to close, but prefetches result." WebClient httpGet: ''http://www.squeak.org''. | client resp | "Regular use. Create WebClient, return after header is read ..." client := WebClient new. [response := client httpGet: ''http://www.squeak.org/''. "... then fetch (or stream) the content ..." response content. ] ensure:[ "... and close the client when done." client close. ].!! ]style[(179 1 1 1 6 1 4 1 1 2 6 1 2 11 3 3 4 1 2 1 6 1 8 1 24 3 4 1 2 1 6 1 8 1 32 3 4 1 2 1 6 1 8 1 32 3 6 1 5 2 443 1 62 12 8 1 23 4 1 1 6 1 4 1 1 2 64 1 1 6 1 2 11 3 4 8 1 2 1 6 1 8 1 24 3 44 2 8 1 7 5 7 4 37 3 6 1 5 5),cblack;,cgray;,cblack;,c107107107,cblack;,c107107107,cblack;,cgray;,cblack;,c107107107,cblack;,b,cblack;,c000000127,cblack;,c107107107,cblack;,b,cblack;,c107107107,cblack;,c000000127,cblack;,c127000127,cblack;,c107107107,cblack;,b,cblack;,c107107107,cblack;,c000000127,cblack;,c127000127,cblack;,c107107107,cblack;,b,cblack;,c107107107,cblack;,c000000127,cblack;,c127000127,cblack;,c107107107,cblack;,c000000127,cblack;,,cblack;,c000127127,cblack;,c000000127,cblack;,c127000127,cblack;,cgray;,cblack;,c107107107,cblack;,c107107107,cblack;,cgray;,cblack;,c000127127,,cblack;,c107107107,cblack;,b,cblack;,c000000127,cblack;,c107107107,cblack;,b,cblack;,c107107107,cblack;,c000000127,cblack;,c127000127,cblack;,c000127127,cblack;,c107107107,cblack;,c000000127,cblack;,c000000127,cblack;,c000127127,cblack;,c107107107,cblack;,c000000127,cblack;!!' readStream nextChunkText! ----- Method: WebClientHelp class>>pages (in category 'accessing') ----- pages "Returns a collection of method selectors to return the pages of the custom help book" ^#(introduction webClientRequests webClientResponses multipleRequests authentication redirectSupport proxySupport cookieSupport changeLog)! ----- Method: WebClientHelp class>>proxySupport (in category 'pages') ----- proxySupport "This method was automatically generated. Edit it using:" "WebClientHelp edit: #proxySupport" ^HelpTopic title: 'Proxy Support' contents: 'WebClient supports connecting via http proxies, including authenticating proxies. WebClient delegates proxy detection to its ProxyHandler which is responsible for performing the proper actions. Proxy authentication is handled in a similar way as regular authentication. The defaults are implemented in WebUtils. !!' readStream nextChunkText! ----- Method: WebClientHelp class>>redirectSupport (in category 'pages') ----- redirectSupport "This method was automatically generated. Edit it using:" "WebClientHelp edit: #redirectSupport" ^HelpTopic title: 'Redirect Handling' contents: 'WebClient handles http redirect requests (3xx) transparently. WebClient detects infinite redirect loops and gives up after a certain number of attempts, returning the redirect (3xx) response which caused it to give up. Users of WebClient will only see 3xx responses if WebClient has given up (i.e., returning a 3xx should be considered an error). Redirect handling can be disabled by setting #allowRedirect property to the desired value. When disabled, WebClient will not attempt to perform any redirect handling.!!' readStream nextChunkText! ----- Method: WebClientHelp class>>webClientRequests (in category 'pages') ----- webClientRequests "This method was automatically generated. Edit it using:" "WebClientHelp edit: #webClientRequests" ^HelpTopic title: 'Using WebClient' contents: 'The simplest form to use WebClient is by one of its convenience APIs: WebClient httpGet: ''http://www.squeak.org/''. WebClient httpPost: ''http://www.squeak.org/'' content:''Hello Squeak'' type: ''text/plain''. For more elaborate use of headers and some other options in the request, a client can utilize modified variants: WebClient new httpGet: ''http://www.squeak.org/'' do:[:req| "Set an if-modified-since header" req headerAt: ''If-Modified-Since'' put: ''Sat, 29 Oct 1994 19:43:31 GMT''. "Add several accept headers" req addHeader: ''Accept'' value: ''text/plain''. req addHeader: ''Accept'' value: ''application/x-foo-bar''. req addHeader: ''Accept'' value: ''image/jpg''. ]. The set of utility methods is limited to a few useful ones but it is easy to do the setup on your own: | url client request data | data := ''Hello Squeak''. "POST data" url := ''http://www.squeak.org/''. "POST url" client := WebClient new initializeFromUrl: url. "sets host etc" request := client requestWithUrl: url. "sets path etc" request method: ''POST''. "sets method" request headerAt: ''Content-Length'' put: data size. request headerAt: ''Content-Type'' put: ''text/plain''. "... any other headers required ..." ^client sendRequest: request content: data readStream size: data size. The utility methods like httpGet: etc. are similarly simple requests. !! ]style[(71 11 8 1 24 13 9 1 24 1 8 14 1 5 1 12 2 115 11 3 1 8 1 24 1 3 2 3 1 3 33 3 3 1 9 1 19 1 4 1 31 4 28 3 3 1 10 1 8 1 6 1 12 4 3 1 10 1 8 1 6 1 23 4 3 1 10 1 8 1 6 1 11 6 105 1 1 1 3 1 6 1 7 1 4 1 1 2 4 1 2 1 14 9 11 2 3 1 2 1 24 7 10 2 6 1 2 11 3 1 18 1 3 4 15 2 7 1 2 1 6 1 15 1 3 6 15 2 7 1 7 1 6 8 13 2 7 1 9 1 16 1 4 1 4 1 4 3 7 1 9 1 14 1 4 1 12 3 36 2 1 6 1 12 1 7 4 8 1 4 1 10 3 5 1 4 1 4 2 71),cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,c127000127,cblack;,c000000127,cblack;,c127000127,cblack;,,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c000000127,cgray;,cblack;,c000127127,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000127127,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c127000127,cblack;,,cblack;,cgray;,cblack;,c107107107,cblack;,c107107107,cblack;,c107107107,cblack;,c107107107,cblack;,cgray;,cblack;,c107107107,cblack;,b,cblack;,c127000127,cblack;,c000127127,cblack;,c107107107,cblack;,b,cblack;,c127000127,cblack;,c000127127,cblack;,c107107107,cblack;,b,cblack;,c000000127,cblack;,c000000127,cblack;,c107107107,cblack;,c000127127,cblack;,c107107107,cblack;,b,cblack;,c107107107,cblack;,c000000127,cblack;,c107107107,cblack;,c000127127,cblack;,c107107107,cblack;,c000000127,cblack;,c127000127,cblack;,c000127127,cblack;,c107107107,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c107107107,cblack;,c000000127,cblack;,c107107107,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000127127,cblack;,c127000000,c107107107,cblack;,c000000127,cblack;,c107107107,cblack;,c000000127,cblack;,c107107107,cblack;,c000000127,cblack;,c000000127,cblack;,c107107107,cblack;,c000000127,cblack;,!!' readStream nextChunkText! ----- Method: WebClientHelp class>>webClientResponses (in category 'pages') ----- webClientResponses "This method was automatically generated. Edit it using:" "WebClientHelp edit: #webClientResponses" ^HelpTopic title: 'Responses' contents: 'The WebClient request methods return a WebResponse that the client can process: | resp | resp := WebClient httpGet: ''http://www.squeak.org/''. resp isSuccess ifFalse:[^self error: resp status]. "Process the content from the response" ^resp content In addition, content can be streamed from the response so that it does not need to be downloaded all at once: | client resp file | client := WebClient new. [resp := client httpGet: ''http://www.squeak.org/''. resp isSuccess ifFalse:[^self error: resp status]. "Stream the content from the response" file := FileStream newFileNamed: ''page.html''. resp streamTo: file size: resp contentLength progress:[:total :amount]. file close] ensure:[client close]. The progress block in the above can be omitted but has been included in this example to illustrate its usage. The block takes a total length (which can be nil if the length is not known) and the amount that has been loaded. !! ]style[(81 1 1 1 4 1 1 2 4 1 2 11 8 1 24 3 4 1 9 1 8 1 5 1 6 1 4 1 6 4 39 2 1 4 1 7 1 112 1 1 1 6 1 4 1 4 1 1 2 6 1 2 11 3 4 4 1 2 1 6 1 8 1 24 3 4 1 9 1 8 1 5 1 6 1 4 1 6 1 3 38 2 4 1 2 12 13 1 11 3 4 1 9 1 4 5 5 1 4 1 13 4 9 1 1 5 2 6 1 3 4 1 5 2 7 1 6 1 5 3 225),cblack;,cgray;,cblack;,c107107107,cblack;,cgray;,cblack;,c107107107,cblack;,b,cblack;,c000000127,cblack;,c127000127,cblack;,c107107107,cblack;,c000000127,cblack;,c000000127,cblack;,c127000000,cblack;,c000000127,cblack;,c107107107,cblack;,c000000127,cblack;,c000127127,cblack;,c127000000,c107107107,cblack;,c000000127,cblack;,,cblack;,cgray;,cblack;,c107107107,cblack;,c107107107,cblack;,c107107107,cblack;,cgray;,cblack;,c107107107,cblack;,b,cblack;,c000000127,cblack;,c107107107,cblack;,b,cblack;,c107107107,cblack;,c000000127,cblack;,c127000127,cblack;,c107107107,cblack;,c000000127,cblack;,c000000127,c000127000,c127000000,cblack;,c000000127,cblack;,c107107107,cblack;,c000000127,c000127000,cblack;,c000127127,cblack;,c107107107,cblack;,b,cblack;,c000000127,cblack;,c127000127,cblack;,c107107107,cblack;,c000000127,cblack;,c107107107,cblack;,c000000127,cblack;,c107107107,cblack;,c000000127,cblack;,c000000127,c000127000,cblack;,c000000127,cblack;,c000000127,c000127000,cblack;,c107107107,cblack;,c000000127,cblack;,c000000127,cblack;,c107107107,cblack;,c000000127,cblack;,!!' readStream nextChunkText! WebClientHelp subclass: #WebClientReference instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'WebClient-Help'! ----- Method: WebClientReference class>>bookName (in category 'accessing') ----- bookName ^'Reference'! ----- Method: WebClientReference class>>builder (in category 'accessing') ----- builder ^PackageAPIHelpBuilder! ----- Method: WebClientReference class>>packages (in category 'accessing') ----- packages ^#('WebClient-Core')! CustomHelp subclass: #WebServerHelp instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'WebClient-Help'! ----- Method: WebServerHelp class>>addingActions (in category 'pages') ----- addingActions "This method was automatically generated. Edit it using:" "WebServerHelp edit: #addingActions" ^HelpTopic title: 'Adding Actions' contents: 'Let''s add some real stuff that might be useful on a server: WebServer default addService: ''/smalltalk'' action:[:req| | action | action := (req fields at: ''get'' ifAbsent:['''']) asSymbol. req send200Response: (Smalltalk perform: action) asString ]. We can now request some interesting things like: (WebClient httpGet:''http://localhost:8080/smalltalk?get=systemInformationString'') content. (WebClient httpGet:''http://localhost:8080/smalltalk?get=platformName'') content. Obviously, this poses quite a risk for abuse. One way to limit this risk is to expose specific actions, such as here: #(systemInformationString platformName) do:[:symbol| WebServer default addService: ''/info/'', symbol action:[:req| req send200Response: (Smalltalk perform: symbol) asString]]. (WebClient httpGet:''http://localhost:8080/info/systemInformationString'') content. (WebClient httpGet:''http://localhost:8080/info/platformName'') content. Alternatively, authentication can be used to limit access to exposed resources. !! ]style[(61 11 7 1 11 1 12 1 7 2 3 1 1 1 1 6 1 1 3 6 1 2 1 1 3 1 6 1 3 1 5 1 9 4 1 1 8 4 3 1 16 1 1 10 8 1 6 1 1 8 5 51 12 8 61 2 7 14 8 50 2 7 2 121 3 23 1 12 2 3 2 6 1 13 7 1 11 1 8 1 1 6 1 7 1 1 3 1 4 3 1 16 1 1 10 8 1 6 1 1 8 1 3 1 12 8 52 2 7 14 8 41 2 7 2 82),cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c000000127,cgray;,cblack;,cgray;,cblack;,cgray;,cblack;,cgray;,cblack;,cgray;,cblack;,b,cblack;,c000127000,c000000127,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,c127000127,c000127000,cblack;,c000000127,cblack;,c000000127,cblack;,c000000127,cblack;,c000127000,cblack;,c000000127,cblack;,cgray;,c000127000,cblack;,c000000127,cblack;,,cblack;,c000000127,c127000127,cblack;,c000000127,cblack;,c000000127,c127000127,cblack;,c000000127,cblack;,,cblack;,c000000127,cblack;,c000000127,cblack;,c000000127,cblack;,c000000127,cgray;,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,c000000127,cblack;,c000000127,cblack;,c000000127,c000127000,cblack;,c000000127,cgray;,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c000000127,c127000127,cblack;,c000000127,c000127000,cblack;,,cblack;,c000000127,c127000127,cblack;,c000000127,cblack;,c000000127,c127000127,cblack;,c000000127,cblack;,!!' readStream nextChunkText! ----- Method: WebServerHelp class>>addingServices (in category 'pages') ----- addingServices "This method was automatically generated. Edit it using:" "WebServerHelp edit: #addingServices" ^HelpTopic title: 'Adding Services' contents: 'Once the server is running, you can point your browser to http://localhost:8080 but since we haven''t told WebServer what we''d like to do all we get is a 404 (not found) response. To tell WebServer what to do we need to register a service: WebServer default addService: ''/hello'' action:[:req| req send200Response: ''Hello World''. ]. The service takes a path (/hello) and an action to perform for any request that maps to this path. We can now fetch the response in a browser by going to http://localhost:8080/hello or directly using WebClient: (WebClient httpGet:''http://localhost:8080/hello'') content. (WebClient httpGet:''http://localhost:8080/hello/squeak'') content. !! ]style[(240 11 7 1 11 1 8 1 7 2 3 1 3 3 1 16 1 13 6 213 12 8 29 2 7 14 8 36 2 7 2),cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c000000127,cgray;,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,,cblack;,c000000127,c127000127,cblack;,c000000127,cblack;,c000000127,c127000127,cblack;,c000000127,cblack;!!' readStream nextChunkText! ----- Method: WebServerHelp class>>authentication (in category 'pages') ----- authentication "This method was automatically generated. Edit it using:" "WebServerHelp edit: #authentication" ^HelpTopic title: 'Authentication' contents: 'To add authentication you can use web server as follows: WebServer default addService: ''/smalltalk'' action:[:req| | action | WebServer default authenticate: req realm: ''squeak'' methods: #(digest basic) do:[ action := (req fields at: ''get'' ifAbsent:['''']) asSymbol. req send200Response: (Smalltalk perform: action) asString. ]. ]. The above supports both digest as well as basic authentication for accessing the /smalltalk service. Let''s add a user so that we can access it: WebServer default passwordAt: ''squeak'' realm: ''squeak'' put: ''squeak''. The server does NOT store plain text passwords, but rather hashes. To be precise, it stores the ha1 term used in digest authentication which is the same hash produced by htdigest. We can now access the /smalltalk service by providing user name ''squeak'' and password ''squeak''. (WebClient httpGet:''http://localhost:8080/smalltalk?get=platformName'') content. Unfortunately, digest authentication can be slow since our MD5 implementation is rather pathetic. !! ]style[(58 11 7 1 11 1 12 1 7 2 3 1 1 1 1 6 1 1 13 7 1 13 1 3 1 6 1 8 1 8 3 6 1 5 2 3 1 4 6 1 2 1 1 3 1 6 1 3 1 5 1 9 1 2 1 1 1 8 5 3 1 16 1 1 10 8 1 6 1 1 8 4 1 6 146 11 7 1 11 1 8 1 6 1 8 1 4 1 8 2 278 12 8 50 2 7 2 100),cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c000000127,cgray;,cblack;,cgray;,cblack;,cgray;,cblack;,cgray;,cblack;,c000000127,cblack;,c000000127,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c000000127,cblack;,c000000127,cblack;,c000000127,c000127000,cblack;,cgray;,cblack;,b,cblack;,c127000127,c000000127,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,c127000000,c127000127,c127000000,c127000127,cblack;,c000000127,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,cgray;,c127000127,cblack;,c000000127,cblack;,c000127000,cblack;,,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c127000127,cblack;,,cblack;,c000000127,c127000127,cblack;,c000000127,cblack;,!!' readStream nextChunkText! ----- Method: WebServerHelp class>>bookName (in category 'accessing') ----- bookName "Returns the name of the custom help book" ^'WebServer'! ----- Method: WebServerHelp class>>changeLog (in category 'pages') ----- changeLog "This method was automatically generated. Edit it using:" "WebServerHelp edit: #changeLog" ^HelpTopic title: 'Versions' contents: 'WebServer 1.4: * Fixes cookie handling to be in line with RFC 2109 * Support for responses using chunked transfer-encoding WebServer 1.3: * Added logging in common log format * Added support for SSL/TLS via SqueakSSL. WebServer 1.2: * Added support for multipart/form-data posts * Added WebSocket support WebServer 1.1: * Added support for specific request methods * Implement HEAD, TRACE, and OPTIONS in WebServer WebServer 1.0: * Initial release. !!' readStream nextChunkText! ----- Method: WebServerHelp class>>cookies (in category 'pages') ----- cookies "This method was automatically generated. Edit it using:" "WebServerHelp edit: #cookies" ^HelpTopic title: 'Cookies' contents: 'Because of the performance issues with authentication, we''d like to avoid authentication for each request and instead authenticate once and use some persistent session state (cookies). So let''s do that: WebServer default addService: ''/smalltalk'' action:[:req| | session | session := WebServer default sessionAt: (req cookieAt: ''session''). session ifNil:[ "no session, reguire login" req send302Response: ''/login?url='', req rawUrl encodeForHTTP. ] ifNotNil:[ | target action | action := (req fields at: ''get'' ifAbsent:['''']) asSymbol. req send200Response: (Smalltalk perform: action) asString. ]. ]. And of course we now need a login service The service will require authentication and provide a session identifier for the client. It then redirects back to where the request was originally made from: WebServer default addService: ''/login'' action:[:req| | session | WebServer default authenticate: req realm: ''squeak'' methods: #(digest) do:[ | id | "We have no session state for now, just remember the session id" WebServer default sessionAt: (id := UUID new hex) put: ''''. "Send a redirect back to where we came from with a cookie" req send302Response: (req fields at: ''url'' ifAbsent:[''/'']) do:[:reply| reply setCookie: ''session'' value: id path: ''/smalltalk'']]]. !! ]style[(204 11 7 1 11 1 12 1 7 2 3 1 1 1 1 7 1 1 3 7 1 2 11 7 1 10 1 1 3 1 9 1 9 1 4 7 1 6 1 1 27 4 3 1 16 1 13 1 1 3 1 6 1 13 4 1 1 9 1 1 1 1 6 1 6 1 1 4 6 1 2 1 1 3 1 6 1 3 1 5 1 9 1 2 1 1 1 8 5 3 1 16 1 1 10 8 1 6 1 1 8 4 1 6 203 11 7 1 11 1 8 1 7 2 3 1 1 1 1 7 1 1 13 7 1 13 1 3 1 6 1 8 1 8 3 6 2 3 1 1 1 1 2 1 1 4 64 14 7 1 10 1 1 2 1 2 6 3 1 3 1 1 4 1 2 5 58 4 3 1 16 1 1 3 1 6 1 3 1 5 1 9 1 3 1 1 6 3 1 1 5 1 1 5 1 10 1 9 1 6 1 2 1 5 1 13 1 3),cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c000000127,cgray;,cblack;,cgray;,cblack;,cgray;,cblack;,cgray;,cblack;,cgray;,cblack;,b,cblack;,c000000127,cblack;,c000000127,cblack;,c000127000,c000000127,cblack;,c000000127,cblack;,c127000127,c000127000,cblack;,cgray;,cblack;,c000000127,c000127000,cblack;,c000127127,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,c000000127,cblack;,c000000127,cblack;,c000000127,cblack;,c000000127,cblack;,c000127000,cblack;,c000000127,c000127000,cblack;,cgray;,cblack;,cgray;,cblack;,cgray;,cblack;,cgray;,cblack;,cgray;,cblack;,b,cblack;,c127000127,c000000127,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,c127000000,c127000127,c127000000,c127000127,cblack;,c000000127,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,cgray;,c127000127,cblack;,c000000127,cblack;,c000127000,cblack;,,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c000000127,cgray;,cblack;,cgray;,cblack;,cgray;,cblack;,cgray;,cblack;,c000000127,cblack;,c000000127,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c000000127,cblack;,c000000127,c000127000,cblack;,cgray;,cblack;,cgray;,cblack;,cgray;,cblack;,c000127127,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cgray;,cblack;,b,cblack;,c000000127,cblack;,c000000127,c127000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000127127,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,c000000127,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,c127000000,c127000127,c127000000,c127000127,cblack;,c000000127,c127000127,cblack;,c000000127,cgray;,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,cgray;,cblack;,c000000127,cblack;,c127000127,c000127000,cblack;!!' readStream nextChunkText! ----- Method: WebServerHelp class>>errorHandling (in category 'pages') ----- errorHandling "This method was automatically generated. Edit it using:" "WebServerHelp edit: #errorHandling" ^HelpTopic title: 'Error Handling' contents: 'By default WebServer will send a 500 response with a full debug stack when an error occurs. This may not be appropriate in production environments and consequently, the error handler can be customized. Typically, the error handler will perform one of the following actions: * Pass the error through. This is useful for debugging, when an error in WebServer should raise a notifier: webServer errorHandler:[:err :socket| err pass]. * Send the ''standard'' 500 response (including the full stack): You can simply use WebServer''s default action for this: webServer errorHandler:[:err :socket| webServer handleError: err socket: socket.]. * Send a custom 500 response, or perform a redirect, for example: webServer errorHandler:[:err :socket| [socket sendData: ''HTTP/1.0 302 Temporary redirect'', String crlf, ''Location: /error.html'', String crlf, String crlf. socket close] on: Error do:[ "Ignore errors in error handling" ]. ]. Of course, you can use any possible combination; including the ability to turn error handling on and off via WebServer http requests.!! ]style[(384 11 13 2 3 2 6 1 1 3 1 4 2 123 10 13 2 3 2 6 1 11 12 1 3 1 7 1 6 3 69 11 13 2 3 2 6 1 3 1 6 1 9 4 33 1 8 5 4 23 1 8 5 11 4 4 6 1 5 1 1 3 7 3 1 4 33 3 1 5 135),cblack;,c000000126,cblack;,c000000126,cblack;,c000000126,cgray;,cblack;,c000000126,cblack;,c000000126,cblack;,,cblack;,c000000126,cblack;,c000000126,cblack;,c000000126,cgray;,cblack;,c000000126,cblack;,c000000126,cblack;,c000000126,cblack;,c000000126,cblack;,,cblack;,c000000126,cblack;,c000000126,cblack;,c000000126,cgray;,cblack;,c000126000,c000000126,cblack;,c000000126,cblack;,c126000126,c000000126,cblack;,c000000126,cblack;,c126000126,c000000126,cblack;,c000000126,cblack;,c000000126,cblack;,c000000126,cblack;,c000000126,c000126000,cblack;,c000000126,cblack;,c000000126,c000126000,cblack;,c000126126,cblack;,c000126000,cblack;,!!' readStream nextChunkText! ----- Method: WebServerHelp class>>introduction (in category 'pages') ----- introduction "This method was automatically generated. Edit it using:" "WebServerHelp edit: #introduction" ^HelpTopic title: 'Introduction' contents: 'WebServer is a simple, yet reasonably complete HTTP server implementation. WebServer supports streaming, authentication, cookies, and session handling in a compact and easy to use form. The primary goal for WebServer is for command-and-control style interfaces. If you would like to add some web-based remote control facility without much fuzz and html goodness around it, WebServer is for you. WebServer comes together with WebClient which provides a similarly complete and simple HTTP client implementation.!!' readStream nextChunkText! ----- Method: WebServerHelp class>>logging (in category 'pages') ----- logging "This method was automatically generated. Edit it using:" "WebServerHelp edit: #logging" ^HelpTopic title: 'Logging' contents: 'WebServer supports logging in common log format. In order to tell WebServer where to log to you can either give it a stream: WebServer default accessLog: Transcript. or alternatively a file name, for example: WebServer default accessLog: ''/var/log/wsd/access_log''. When used in the latter form, WebServer opens and closes the file for each log entry which provides additional robustness at the cost of some performance. !! ]style[(126 11 7 1 10 12 46 11 7 1 10 1 25 1 157),cblack;,c000000127,cblack;,c000000127,cblack;,,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,!!' readStream nextChunkText! ----- Method: WebServerHelp class>>pages (in category 'accessing') ----- pages "Returns a collection of method selectors to return the pages of the custom help book" ^#(introduction startingWebServer addingServices serviceHierarchies errorHandling addingActions authentication cookies summary logging sslSupport changeLog)! ----- Method: WebServerHelp class>>serviceHierarchies (in category 'pages') ----- serviceHierarchies "This method was automatically generated. Edit it using:" "WebServerHelp edit: #serviceHierarchies" ^HelpTopic title: 'Service Hierarchies' contents: 'More specific services are preferred over more general services. In addition to the /hello service, we can provide a handler for /hello/squeak by adding the following service: WebServer default addService: ''/hello/squeak'' action:[:req| req send200Response: ''Hello to you too, Squeak!!!!''. ]. (WebClient httpGet:''http://localhost:8080/hello'') content. (WebClient httpGet:''http://localhost:8080/hello/squeak'') content. A default handler for any kind of request can installed by using the ''/'' path: WebServer default addService: ''/'' action:[:req| req send302Response: ''/hello''. "temporary redirect" ]. This will make any request that isn''t handled by an explicit action redirect to /hello where it will be handled by the handler established earlier, for example: (WebClient httpGet:''http://localhost:8080/foobar'') content. !! ]style[(178 11 7 1 11 1 15 1 7 2 3 1 3 3 1 16 1 27 6 1 12 8 29 2 7 14 8 36 2 7 2 81 11 7 1 11 1 3 1 7 2 3 1 3 3 1 16 1 8 2 20 5 163 12 8 30 2 7 1 1),cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c000000127,cgray;,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,,cblack;,c000000127,c127000127,cblack;,c000000127,cblack;,c000000127,c127000127,cblack;,c000000127,cblack;,,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c000000127,cgray;,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000127127,cblack;,,cblack;,c000000127,c127000127,cblack;,c000000127,cblack;,!!' readStream nextChunkText! ----- Method: WebServerHelp class>>sslSupport (in category 'pages') ----- sslSupport "This method was automatically generated. Edit it using:" "WebServerHelp edit: #sslSupport" ^HelpTopic title: 'SSL/TLS Support' contents: 'WebServer supports secure connections over SSL/TLS via SqueakSSL. To install SqueakSSL, execute the following: (Installer ss project: ''SqueakSSL'') install: ''SqueakSSL-Core''; install: ''SqueakSSL-Tests''. If you have SqueakSSL installed, you can tell WebServer to use a particular cert which puts WebServer into secure mode. The certName itself is platform dependent. On Unix, the cert name is the path to the .pem file with BOTH the cert and the private key, for example: WebServer default certName: ''/home/user/certs/testcert.pem''. On Windows, the cert name is a string that is matched against the certificate subject. Usually, the certificate subject includes your host name so that you would use: WebServer default certName: ''secure.domain.com''. Client certificate handling is currently not supported. !! ]style[(112 12 2 1 8 1 11 4 8 1 16 4 8 1 17 1 272 11 7 1 9 1 31 1 170 11 7 1 9 1 19 1 58),cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c127000127,cblack;,,cblack;,c000000125,cblack;,c000000125,cblack;,c125000125,cblack;,,cblack;,c000000125,cblack;,c000000125,cblack;,c125000125,cblack;,!!' readStream nextChunkText! ----- Method: WebServerHelp class>>startingWebServer (in category 'pages') ----- startingWebServer "This method was automatically generated. Edit it using:" "WebServerHelp edit: #startingWebServer" ^HelpTopic title: 'Starting WebServer' contents: 'A WebServer is started by listening on a particular port. The examples below use ''WebServer reset default'' for convenience; specific applications should have their own registry for accessing various WebServer instances. (WebServer reset default) listenOn: 8080. The server will persist when the image is restarted and must be stopped explicitly by sending it the #destroy message. !! ]style[(221 12 5 1 7 4 9 1 4 2 120),cblack;,c000000127,cblack;,c000000127,cblack;,c000000127,cblack;,c127000000,cblack;,!!' readStream nextChunkText! ----- Method: WebServerHelp class>>summary (in category 'pages') ----- summary "This method was automatically generated. Edit it using:" "WebServerHelp edit: #summary" ^HelpTopic title: 'Summary' contents: 'At this point, making a request like the following: (WebClient httpGet: ''http://localhost:8080/smalltalk?get=platformName'') content. requires several roundtrips: 1) The first GET request is redirected from /smalltalk to /login 2) The request to /login is responded to with an authentication challenge 3) The request to /login is authenticated and a session cookie is established 4) The request is redirected back to /smalltalk where it is finally handled. More examples for using WebServer can be found in class WebServer itself. Here is an overview: * exampleDoIt - the simplest possible RPC interface to Squeak. * exampleBrowse - browse the files on your local disk * exampleSession - a simple session example * exampleAuth - a simple authentication example !! ]style[(53 12 8 1 50 2 7 2 639),cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,!!' readStream nextChunkText! WebServerHelp subclass: #WebServerReference instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'WebClient-Help'! ----- Method: WebServerReference class>>bookName (in category 'accessing') ----- bookName ^'Reference'! ----- Method: WebServerReference class>>builder (in category 'accessing') ----- builder ^PackageAPIHelpBuilder! ----- Method: WebServerReference class>>packages (in category 'accessing') ----- packages ^#('WebClient-Core')!

1 0

Squeak 4.6: ST80Tests-nice.2.mcz
by commits＠source.squeak.org 05 Jun '15

05 Jun '15

Chris Muller uploaded a new version of ST80Tests to project Squeak 4.6: http://source.squeak.org/squeak46/ST80Tests-nice.2.mcz ==================== Summary ==================== Name: ST80Tests-nice.2 Author: nice Time: 16 December 2013, 5:30:14.254 pm UUID: 7ee5426b-73f1-48ac-8ec4-3943dc452cb6 Ancestors: ST80Tests-fbs.1 MVCToolBuilderTests are kind of TestCase and belong to ST80Tests ==================== Snapshot ==================== SystemOrganization addCategory: #ST80Tests! ToolBuilderTests subclass: #MVCToolBuilderTests instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ST80Tests'! !MVCToolBuilderTests commentStamp: 'ar 2/11/2005 15:02' prior: 0! Tests for the MVC tool builder.! ----- Method: MVCToolBuilderTests>>acceptWidgetText (in category 'support') ----- acceptWidgetText widget hasUnacceptedEdits: true. widget controller accept.! ----- Method: MVCToolBuilderTests>>changeListWidget (in category 'support') ----- changeListWidget widget changeModelSelection: widget getCurrentSelectionIndex + 1.! ----- Method: MVCToolBuilderTests>>expectedButtonSideEffects (in category 'support') ----- expectedButtonSideEffects ^#(getState)! ----- Method: MVCToolBuilderTests>>fireButtonWidget (in category 'support') ----- fireButtonWidget widget performAction.! ----- Method: MVCToolBuilderTests>>setUp (in category 'support') ----- setUp super setUp. builder := MVCToolBuilder new.! ----- Method: MVCToolBuilderTests>>tearDown (in category 'support') ----- tearDown ScreenController new restoreDisplay. super tearDown! ----- Method: MVCToolBuilderTests>>testAddAction (in category 'tests-not applicable') ----- testAddAction "MVCToolBuilder does not implement #buildPluggableMenu:"! ----- Method: MVCToolBuilderTests>>testAddTargetSelectorArgumentList (in category 'tests-not applicable') ----- testAddTargetSelectorArgumentList "MVCToolBuilder does not implement #buildPluggableMenu:"! ----- Method: MVCToolBuilderTests>>testButtonFiresBlock (in category 'tests-not applicable') ----- testButtonFiresBlock "MVC buttons only support action Symbols"! ----- Method: MVCToolBuilderTests>>testButtonFiresMessage (in category 'tests-not applicable') ----- testButtonFiresMessage "MVC buttons only support action Symbols, not MessageSends"! ----- Method: MVCToolBuilderTests>>testButtonInitiallyDisabled (in category 'tests-not applicable') ----- testButtonInitiallyDisabled "MVC does not have button enablement"! ----- Method: MVCToolBuilderTests>>testButtonInitiallyDisabledSelector (in category 'tests-not applicable') ----- testButtonInitiallyDisabledSelector "MVC does not have button enablement"! ----- Method: MVCToolBuilderTests>>testGetButtonColor (in category 'tests-not applicable') ----- testGetButtonColor "MVC buttons do not have color"! ----- Method: MVCToolBuilderTests>>testGetButtonEnabled (in category 'tests-not applicable') ----- testGetButtonEnabled "MVC does not have button enablement"! ----- Method: MVCToolBuilderTests>>testGetInputFieldColor (in category 'tests-not applicable') ----- testGetInputFieldColor "MVC input fields do not have color"! ----- Method: MVCToolBuilderTests>>testGetPanelChildren (in category 'tests-not applicable') ----- testGetPanelChildren "MVC panels do not allow changing children"! ----- Method: MVCToolBuilderTests>>testGetTextColor (in category 'tests-not applicable') ----- testGetTextColor "not supported in MVC"! ----- Method: MVCToolBuilderTests>>testGetWindowChildren (in category 'tests-not applicable') ----- testGetWindowChildren "not supported in MVC"! ----- Method: MVCToolBuilderTests>>testGetWindowLabel (in category 'tests-not applicable') ----- testGetWindowLabel "not supported in MVC"! ----- Method: MVCToolBuilderTests>>testTreeExpandPath (in category 'tests-not applicable') ----- testTreeExpandPath "MVCToollBuilder does not implement trees"! ----- Method: MVCToolBuilderTests>>testTreeExpandPathFirst (in category 'tests-not applicable') ----- testTreeExpandPathFirst "MVCToollBuilder does not implement trees"! ----- Method: MVCToolBuilderTests>>testTreeGetSelectionPath (in category 'tests-not applicable') ----- testTreeGetSelectionPath "MVCToollBuilder does not implement trees"! ----- Method: MVCToolBuilderTests>>testTreeRoots (in category 'tests-not applicable') ----- testTreeRoots "MVCToollBuilder does not implement trees"! ----- Method: MVCToolBuilderTests>>testTreeWidgetID (in category 'tests-not applicable') ----- testTreeWidgetID "MVCToollBuilder does not implement trees"! ----- Method: MVCToolBuilderTests>>testWindowCloseAction (in category 'tests-not applicable') ----- testWindowCloseAction "This can only work if we're actually run in MVC" World isNil ifTrue: [super testWindowCloseAction]! TestCase subclass: #ST80PackageDependencyTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ST80Tests'! ----- Method: ST80PackageDependencyTest>>testPackage:dependsExactlyOn: (in category 'as yet unclassified') ----- testPackage: pkgName dependsExactlyOn: pkgList "Ensure that the package with the given name depends only on the packages in pkgList. NOTE: If you use this for fixing dependencies, classDeps includes the classes and users from the package(s) not declared as dependents. Basically, you need to fix all the references in classDeps to make the test pass." | classDeps pi pkgDeps | classDeps := IdentityDictionary new. pi := PackageOrganizer default packageNamed: pkgName ifAbsent:[^self]. "unloaded" pi classes do:[:pkgClass| (classDeps at: (pkgClass superclass ifNil:[ProtoObject]) ifAbsentPut:[OrderedCollection new]) add: pkgClass name, ' superclass'. ]. pi methods do:[:mref| | cm | cm := mref compiledMethod. 1 to: cm numLiterals do:[:i| | lit | ((lit := cm literalAt: i) isVariableBinding and:[lit value isBehavior]) ifTrue:[(classDeps at: lit value ifAbsentPut:[OrderedCollection new]) add: cm methodClass asString, '>>', cm selector]]]. pkgDeps := Dictionary new. classDeps keys do:[:aClass| | pkg | pkg := PackageOrganizer default packageOfClass: aClass ifNone:[nil]. pkg ifNil:[ Transcript cr; show: 'WARNING: No package for ', aClass. (classDeps removeKey: aClass) do:[:each| Transcript crtab; show: each]. ] ifNotNil:[ (pkgDeps at: pkg name ifAbsentPut:[OrderedCollection new]) add: aClass. ]. ]. (pkgDeps removeKey: pkgName ifAbsent:[#()]) do:[:aClass| classDeps removeKey: aClass ifAbsent:[]]. pkgList do:[:pkg| self assert: (pkgDeps includesKey: pkg) description: pkgName, ' no longer depends on ', pkg. (pkgDeps removeKey: pkg ifAbsent: [#()]) do:[:aClass| classDeps removeKey: aClass ifAbsent:[]]. ]. classDeps keysAndValuesDo:[:class :deps| Transcript cr; show: class name, ' dependencies:'. deps do:[:each| Transcript crtab; show: each]. ]. self assert: pkgDeps isEmpty description: pkgName, ' now depends on ', pkgDeps. ! ----- Method: ST80PackageDependencyTest>>testST80 (in category 'as yet unclassified') ----- testST80 self testPackage: 'ST80' dependsExactlyOn: #( Collections Compiler Files Graphics Kernel Morphic Multilingual Network SUnit System 'ToolBuilder-Kernel' Tools ).!

1 0

Squeak 4.6: SUnit-mt.102.mcz
by commits＠source.squeak.org 05 Jun '15

05 Jun '15

Chris Muller uploaded a new version of SUnit to project Squeak 4.6: http://source.squeak.org/squeak46/SUnit-mt.102.mcz ==================== Summary ==================== Name: SUnit-mt.102 Author: mt Time: 19 April 2015, 7:24:35.203 am UUID: 3e115dcf-b404-3043-814e-ecb6f43f9192 Ancestors: SUnit-bf.101 Extracted logic of being a test method to be easier reusable in extensions and tools. Moved test-class-check from SUnitTools to here. ==================== Snapshot ==================== SystemOrganization addCategory: #'SUnit-Extensions'! SystemOrganization addCategory: #'SUnit-Kernel'! SystemOrganization addCategory: #'SUnit-Tests'! ----- Method: CompiledMethod>>isTestMethod (in category '*SUnit-testing') ----- isTestMethod ^ self methodClass isTestClass and: [self selector isTestSelector]! Exception subclass: #TestFailure instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Kernel'! !TestFailure commentStamp: '<historical>' prior: 0! Signaled in case of a failed test (failure). The test framework distinguishes between failures and errors. A failure is anticipated and checked for with assertions. Errors are unanticipated problems like a division by 0 or an index out of bounds ...! TestFailure subclass: #ResumableTestFailure instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Kernel'! !ResumableTestFailure commentStamp: '<historical>' prior: 0! A ResumableTestFailure triggers a TestFailure, but lets execution of the TestCase continue. this is useful when iterating through collections, and #assert: ing on each element. in combination with methods like testcase>>#assert:description:, this lets you run through a whole collection and note which tests pass. here''s an example: (1 to: 30) do: [ :each | self assert: each odd description: each printString, ' is even' resumable: true] for each element where #odd returns <false>, the element will be printed to the Transcript. ! ----- Method: ResumableTestFailure>>isResumable (in category 'camp smalltalk') ----- isResumable "Of course a ResumableTestFailure is resumable ;-)" ^true! ----- Method: ResumableTestFailure>>sunitExitWith: (in category 'camp smalltalk') ----- sunitExitWith: aValue self resume: aValue! ----- Method: TestFailure>>defaultAction (in category 'camp smalltalk') ----- defaultAction Processor activeProcess debug: self signalerContext title: self description! ----- Method: TestFailure>>isResumable (in category 'camp smalltalk') ----- isResumable ^ false! ----- Method: MethodReference>>isTestMethod (in category '*SUnit-testing') ----- isTestMethod ^ self compiledMethod isTestMethod! ----- Method: Symbol>>isTestSelector (in category '*SUnit-testing') ----- isTestSelector ^ self beginsWith: 'test'! Object subclass: #ClassFactoryForTestCase instanceVariableNames: 'createdClasses' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Extensions'! ----- Method: ClassFactoryForTestCase>>cleanUp (in category 'cleaning') ----- cleanUp | createdClassNames | createdClassNames := self createdClassNames. self deleteClasses. self deletePackage. self cleanUpChangeSetForClassNames: createdClassNames. self createdClasses: IdentitySet new! ----- Method: ClassFactoryForTestCase>>cleanUpChangeSetForClassNames: (in category 'cleaning') ----- cleanUpChangeSetForClassNames: classeNames | changeSet | changeSet := ChangeSet current. classeNames do: [:name| changeSet removeClassChanges: name; removeClassChanges: name, ' class']. ! ----- Method: ClassFactoryForTestCase>>createdClassNames (in category 'accessing') ----- createdClassNames ^self createdClasses collect: [:class| class name]! ----- Method: ClassFactoryForTestCase>>createdClasses (in category 'accessing') ----- createdClasses ^createdClasses! ----- Method: ClassFactoryForTestCase>>createdClasses: (in category 'accessing') ----- createdClasses: classes createdClasses := classes asIdentitySet ! ----- Method: ClassFactoryForTestCase>>defaultCategory (in category 'accessing') ----- defaultCategory ^ (self packageName , '-', self defaultCategoryPostfix) asSymbol! ----- Method: ClassFactoryForTestCase>>defaultCategoryPostfix (in category 'accessing') ----- defaultCategoryPostfix ^ #Default! ----- Method: ClassFactoryForTestCase>>delete: (in category 'cleaning') ----- delete: aClass aClass isObsolete ifTrue: [^self]. aClass removeFromChanges. aClass removeFromSystemUnlogged ! ----- Method: ClassFactoryForTestCase>>deleteClasses (in category 'cleaning') ----- deleteClasses self createdClasses do: [:class| self delete: class]! ----- Method: ClassFactoryForTestCase>>deletePackage (in category 'cleaning') ----- deletePackage | categoriesMatchString | categoriesMatchString := self packageName, '-*'. SystemOrganization removeCategoriesMatching: categoriesMatchString! ----- Method: ClassFactoryForTestCase>>initialize (in category 'cleaning') ----- initialize super initialize. self createdClasses: IdentitySet new! ----- Method: ClassFactoryForTestCase>>newClass (in category 'creating') ----- newClass ^self newSubclassOf: Object instanceVariableNames: '' classVariableNames: ''! ----- Method: ClassFactoryForTestCase>>newClassInCategory: (in category 'creating') ----- newClassInCategory: category ^self newSubclassOf: Object instanceVariableNames: '' classVariableNames: '' category: category! ----- Method: ClassFactoryForTestCase>>newName (in category 'creating') ----- newName | postFix | postFix := (self createdClasses size + 1) printString. ^#ClassForTestToBeDeleted, postFix! ----- Method: ClassFactoryForTestCase>>newSubclassOf:instanceVariableNames:classVariableNames: (in category 'creating') ----- newSubclassOf: aClass instanceVariableNames: ivNamesString classVariableNames: classVarsString ^self newSubclassOf: aClass instanceVariableNames: ivNamesString classVariableNames: classVarsString category: self defaultCategoryPostfix! ----- Method: ClassFactoryForTestCase>>newSubclassOf:instanceVariableNames:classVariableNames:category: (in category 'creating') ----- newSubclassOf: aClass instanceVariableNames: ivNamesString classVariableNames: classVarsString category: category | newClass | newClass := aClass subclass: self newName asSymbol instanceVariableNames: ivNamesString classVariableNames: classVarsString poolDictionaries: '' category: (self packageName, '-', category) asSymbol. self createdClasses add: newClass. ^newClass! ----- Method: ClassFactoryForTestCase>>packageName (in category 'accessing') ----- packageName ^#CategoryForTestToBeDeleted! ----- Method: Object>>isTestClass (in category '*SUnit-testing') ----- isTestClass ^ false! Object subclass: #TestCase instanceVariableNames: 'testSelector timeout' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Kernel'! TestCase class instanceVariableNames: 'history'! !TestCase commentStamp: '<historical>' prior: 0! A TestCase is a Command representing the future running of a test case. Create one with the class method #selector: aSymbol, passing the name of the method to be run when the test case runs. When you discover a new fixture, subclass TestCase, declare instance variables for the objects in the fixture, override #setUp to initialize the variables, and possibly override# tearDown to deallocate any external resources allocated in #setUp. When you are writing a test case method, send #assert: aBoolean when you want to check for an expected value. For example, you might say "self assert: socket isOpen" to test whether or not a socket is open at a point in a test.! TestCase class instanceVariableNames: 'history'! TestCase subclass: #ClassFactoryForTestCaseTest instanceVariableNames: 'factory' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Tests'! ----- Method: ClassFactoryForTestCaseTest class>>lastStoredRun (in category 'history') ----- lastStoredRun ^ ((Dictionary new) add: (#passed->((Set new) add: #testDefaultCategoryCleanUp; add: #testPackageCleanUp; add: #testSingleClassCreation; add: #testClassCreationInDifferentCategories; add: #testClassFastCreationInDifferentCategories; add: #testMultipleClassCreation; add: #testSingleClassFastCreation; yourself)); add: (#timeStamp->'22 November 2008 10:11:35 pm'); add: (#failures->((Set new))); add: (#errors->((Set new))); yourself)! ----- Method: ClassFactoryForTestCaseTest>>setUp (in category 'setUp-tearDown') ----- setUp super setUp. factory := ClassFactoryForTestCase new! ----- Method: ClassFactoryForTestCaseTest>>tearDown (in category 'setUp-tearDown') ----- tearDown super tearDown. factory cleanUp! ----- Method: ClassFactoryForTestCaseTest>>testClassCreationInDifferentCategories (in category 'testing') ----- testClassCreationInDifferentCategories | firstThreeClasses lastTwoClasses | 3 timesRepeat: [ factory newSubclassOf: Object instanceVariableNames: '' classVariableNames: '' category: #One]. firstThreeClasses := factory createdClasses copy. 2 timesRepeat: [ factory newSubclassOf: Object instanceVariableNames: '' classVariableNames: '' category: #Two]. lastTwoClasses := factory createdClasses copyWithoutAll: firstThreeClasses. self assert: (firstThreeClasses allSatisfy: [:class| class category = (factory packageName, '-', #One) asSymbol]). self assert: (lastTwoClasses allSatisfy: [:class| class category = (factory packageName, '-', #Two) asSymbol]).! ----- Method: ClassFactoryForTestCaseTest>>testClassFastCreationInDifferentCategories (in category 'testing') ----- testClassFastCreationInDifferentCategories | firstThreeClasses lastTwoClasses | 3 timesRepeat: [ factory newClassInCategory: #One]. firstThreeClasses := factory createdClasses copy. 2 timesRepeat: [ factory newClassInCategory: #Two]. lastTwoClasses := factory createdClasses copyWithoutAll: firstThreeClasses. self assert: (firstThreeClasses allSatisfy: [:class| class category = (factory packageName, '-', #One) asSymbol]). self assert: (lastTwoClasses allSatisfy: [:class| class category = (factory packageName, '-', #Two) asSymbol]).! ----- Method: ClassFactoryForTestCaseTest>>testDefaultCategoryCleanUp (in category 'testing') ----- testDefaultCategoryCleanUp | createdClassNames allClasses | 3 timesRepeat: [ factory newClass]. createdClassNames := factory createdClassNames. factory cleanUp. self assert: (factory createdClasses allSatisfy: [:class| class isObsolete]). allClasses := SystemNavigation new allClasses. self assert: (factory createdClasses noneSatisfy: [:class| allClasses includes: class]). self deny: (SystemOrganization categories includes: factory defaultCategory). self deny: (ChangeSet current changedClassNames includesAnyOf: createdClassNames) ! ----- Method: ClassFactoryForTestCaseTest>>testMultipleClassCreation (in category 'testing') ----- testMultipleClassCreation 5 timesRepeat: [ factory newClass]. self assert: (SystemNavigation new allClasses includesAllOf: factory createdClasses). self assert: factory createdClassNames asSet size = 5. self assert: (SystemOrganization listAtCategoryNamed: factory defaultCategory) asSet = factory createdClassNames asSet! ----- Method: ClassFactoryForTestCaseTest>>testPackageCleanUp (in category 'testing') ----- testPackageCleanUp | createdClassNames allClasses | 3 timesRepeat: [ factory newClassInCategory: #One]. 2 timesRepeat: [ factory newClassInCategory: #Two]. createdClassNames := factory createdClassNames. factory cleanUp. self assert: (factory createdClasses allSatisfy: [:class| class isObsolete]). allClasses := SystemNavigation new allClasses. self assert: (factory createdClasses noneSatisfy: [:class| allClasses includes: class]). self assert: (SystemOrganization categoriesMatching: factory packageName, '*') isEmpty. self deny: (ChangeSet current changedClassNames includesAnyOf: createdClassNames) ! ----- Method: ClassFactoryForTestCaseTest>>testSingleClassCreation (in category 'testing') ----- testSingleClassCreation |class elementsInCategoryForTest | class := factory newSubclassOf: Object instanceVariableNames: 'a b c' classVariableNames: 'X Y'. self assert: (SystemNavigation new allClasses includes: class). elementsInCategoryForTest := SystemOrganization listAtCategoryNamed: factory defaultCategory. self assert: elementsInCategoryForTest = {class name}. self assert: class instVarNames = #(a b c). self assert: class classPool keys asSet = #(X Y) asSet! ----- Method: ClassFactoryForTestCaseTest>>testSingleClassFastCreation (in category 'testing') ----- testSingleClassFastCreation |class elementsInCategoryForTest | class := factory newClass. self assert: (SystemNavigation new allClasses includes: class). elementsInCategoryForTest := SystemOrganization listAtCategoryNamed: factory defaultCategory. self assert: elementsInCategoryForTest = {class name}. self assert: class instVarNames isEmpty. self assert: class classPool isEmpty! TestCase subclass: #ClassTestCase instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Extensions'! !ClassTestCase commentStamp: 'brp 7/26/2003 16:57' prior: 0! This class is intended for unit tests of individual classes and their metaclasses. It provides methods to determine the coverage of the unit tests. Subclasses are expected to re-implement #classesToBeTested and #selectorsToBeIgnored. They should also implement to confirm that all methods have been tested. #testCoverage super testCoverage. ! ----- Method: ClassTestCase class>>isAbstract (in category 'Testing') ----- isAbstract "Override to true if a TestCase subclass is Abstract and should not have TestCase instances built from it" ^self name = #ClassTestCase ! ----- Method: ClassTestCase class>>mustTestCoverage (in category 'Testing') ----- mustTestCoverage ^ false! ----- Method: ClassTestCase>>categoriesForClass: (in category 'private') ----- categoriesForClass: aClass ^ aClass organization allMethodSelectors collect: [:each | aClass organization categoryOfElement: each]. ! ----- Method: ClassTestCase>>classToBeTested (in category 'coverage') ----- classToBeTested self subclassResponsibility! ----- Method: ClassTestCase>>selectorsNotTested (in category 'coverage') ----- selectorsNotTested ^ self selectorsToBeTested difference: self selectorsTested. ! ----- Method: ClassTestCase>>selectorsTested (in category 'Coverage') ----- selectorsTested | literals | literals := Set new. self class selectorsAndMethodsDo: [ :s :m | (s beginsWith: 'test') ifTrue: [ literals addAll: (m messages)] ]. ^ literals asSortedArray! ----- Method: ClassTestCase>>selectorsToBeIgnored (in category 'coverage') ----- selectorsToBeIgnored ^ #(#DoIt #DoItIn:)! ----- Method: ClassTestCase>>selectorsToBeTested (in category 'coverage') ----- selectorsToBeTested ^ ( { self classToBeTested. self classToBeTested class } gather: [:c | c selectors]) difference: self selectorsToBeIgnored! ----- Method: ClassTestCase>>targetClass (in category 'private') ----- targetClass |className| className := self class name asText copyFrom: 0 to: self class name size - 4. ^ Smalltalk at: (className asString asSymbol). ! ----- Method: ClassTestCase>>testClassComment (in category 'tests') ----- testClassComment self shouldnt: [self targetClass organization hasNoComment].! ----- Method: ClassTestCase>>testCoverage (in category 'tests') ----- testCoverage | untested | self class mustTestCoverage ifTrue: [ untested := self selectorsNotTested. self assert: untested isEmpty description: untested size asString, ' selectors are not covered' ]! ----- Method: ClassTestCase>>testNew (in category 'tests') ----- testNew "This should not throw an exception." self targetClass new.! ----- Method: ClassTestCase>>testUnCategorizedMethods (in category 'tests') ----- testUnCategorizedMethods | categories slips uncategorisedMethods | categories := self categoriesForClass: self targetClass. slips := categories select: [:each | each = #'as yet unclassified']. uncategorisedMethods := self targetClass organization listAtCategoryNamed: #'as yet unclassified'. self assert: slips isEmpty description: ('{1} has uncategorised methods: {2}' format: {self targetClass. (uncategorisedMethods collect: #printString) asCommaString}).! TestCase subclass: #LongTestCase instanceVariableNames: '' classVariableNames: 'ShouldRun' poolDictionaries: '' category: 'SUnit-Extensions'! !LongTestCase commentStamp: 'ul 12/15/2009 13:06' prior: 0! A LongTestCase is a TestCase that usually takes a long time to run. Because of this users can decide if they want to execute these or not, by changing the "Run long test cases" preference.! ----- Method: LongTestCase class>>allTestSelectors (in category 'accessing') ----- allTestSelectors self shouldRun ifTrue: [ ^super testSelectors ]. ^#().! ----- Method: LongTestCase class>>buildSuite (in category 'instance creation') ----- buildSuite self shouldRun ifTrue: [ ^super buildSuite ]. ^self suiteClass new! ----- Method: LongTestCase class>>doNotRunLongTestCases (in category 'accessing') ----- doNotRunLongTestCases self shouldRun: false! ----- Method: LongTestCase class>>isAbstract (in category 'testing') ----- isAbstract "Override to true if a TestCase subclass is Abstract and should not have TestCase instances built from it" ^self name == #LongTestCase ! ----- Method: LongTestCase class>>runLongTestCases (in category 'accessing') ----- runLongTestCases self shouldRun: true! ----- Method: LongTestCase class>>shouldRun (in category 'accessing') ----- shouldRun <preference: 'Run long test cases' category: 'SUnit' description: 'If true, the tests defined in subclasses of LongTestCase will run, if they are selected in the Test Runner, otherwise not. As the name suggests, running these tests can take a long time.' type: #Boolean> ^ShouldRun ifNil: [ true ]! ----- Method: LongTestCase class>>shouldRun: (in category 'accessing') ----- shouldRun: aBoolean ShouldRun := aBoolean! ----- Method: LongTestCase>>defaultTimeout (in category 'as yet unclassified') ----- defaultTimeout "Answer the default timeout to use for tests in this test case. The timeout is a value in seconds." ^super defaultTimeout * 10! LongTestCase subclass: #LongTestCaseTestUnderTest instanceVariableNames: '' classVariableNames: 'RunStatus' poolDictionaries: '' category: 'SUnit-Extensions'! ----- Method: LongTestCaseTestUnderTest class>>hasRun (in category 'accessing') ----- hasRun ^ RunStatus! ----- Method: LongTestCaseTestUnderTest class>>markAsNotRun (in category 'accessing') ----- markAsNotRun ^ RunStatus := false! ----- Method: LongTestCaseTestUnderTest>>testWhenRunMarkTestedToTrue (in category 'testing') ----- testWhenRunMarkTestedToTrue RunStatus := true.! TestCase subclass: #LongTestCaseTest instanceVariableNames: 'preferenceValue' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Extensions'! ----- Method: LongTestCaseTest>>setUp (in category 'as yet unclassified') ----- setUp preferenceValue := LongTestCase shouldRun! ----- Method: LongTestCaseTest>>tearDown (in category 'as yet unclassified') ----- tearDown LongTestCase shouldRun: preferenceValue! ----- Method: LongTestCaseTest>>testLongTestCaseDoNotRun (in category 'testing') ----- testLongTestCaseDoNotRun "self debug: #testLongTestCaseDoNotRun" "self run: #testLongTestCaseDoNotRun" LongTestCase doNotRunLongTestCases. LongTestCaseTestUnderTest markAsNotRun. self deny: LongTestCaseTestUnderTest hasRun. LongTestCaseTestUnderTest suite run. self deny: LongTestCaseTestUnderTest hasRun. ! ----- Method: LongTestCaseTest>>testLongTestCaseRun (in category 'testing') ----- testLongTestCaseRun "self debug: #testLongTestCaseRun" "self run: #testLongTestCaseRun" LongTestCase runLongTestCases. LongTestCaseTestUnderTest markAsNotRun. self deny: LongTestCaseTestUnderTest hasRun. LongTestCaseTestUnderTest suite run. self assert: LongTestCaseTestUnderTest hasRun. LongTestCase doNotRunLongTestCases. ! TestCase subclass: #ResumableTestFailureTestCase instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Tests'! ----- Method: ResumableTestFailureTestCase class>>lastStoredRun (in category 'history') ----- lastStoredRun ^ ((Dictionary new) add: (#passed->((Set new) add: #testResumable; yourself)); add: (#timeStamp->'22 November 2008 10:11:35 pm'); add: (#failures->((Set new))); add: (#errors->((Set new))); yourself)! ----- Method: ResumableTestFailureTestCase>>errorTest (in category 'not categorized') ----- errorTest 1 zork ! ----- Method: ResumableTestFailureTestCase>>failureTest (in category 'not categorized') ----- failureTest self assert: false description: 'You should see me' resumable: true; assert: false description: 'You should see me too' resumable: true; assert: false description: 'You should see me last' resumable: false; assert: false description: 'You should not see me' resumable: true ! ----- Method: ResumableTestFailureTestCase>>okTest (in category 'not categorized') ----- okTest self assert: true ! ----- Method: ResumableTestFailureTestCase>>regularTestFailureTest (in category 'not categorized') ----- regularTestFailureTest self assert: false description: 'You should see me' ! ----- Method: ResumableTestFailureTestCase>>resumableTestFailureTest (in category 'not categorized') ----- resumableTestFailureTest self assert: false description: 'You should see me' resumable: true; assert: false description: 'You should see me too' resumable: true; assert: false description: 'You should see me last' resumable: false; assert: false description: 'You should not see me' resumable: true ! ----- Method: ResumableTestFailureTestCase>>testResumable (in category 'not categorized') ----- testResumable | result suite | suite := TestSuite new. suite addTest: (self class selector: #errorTest). suite addTest: (self class selector: #regularTestFailureTest). suite addTest: (self class selector: #resumableTestFailureTest). suite addTest: (self class selector: #okTest). result := suite run. self assert: result failures size = 2; assert: result errors size = 1 ! TestCase subclass: #SUnitExtensionsTest instanceVariableNames: 'stream' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Tests'! ----- Method: SUnitExtensionsTest class>>lastStoredRun (in category 'history') ----- lastStoredRun ^ ((Dictionary new) add: (#passed->((Set new) add: #testNoExceptionWithMatchingString; add: #testNoExceptionWithNoMatchingString; add: #testExceptionWithMatchingString; add: #testExceptionWithoutMatchingString; add: #testValidShouldNotTakeMoreThan; add: #testInvalidShouldNotTakeMoreThanMilliseconds; add: #testDifferentExceptionInShouldRaiseWithExceptionDo; add: #testShouldRaiseWithExceptionDo; add: #testShouldFix; add: #testAssertionFailedInRaiseWithExceptionDo; add: #testAutoDenyFalse; add: #testAutoDenyTrue; add: #testAutoAssertFalse; add: #testAutoAssertTrue; add: #testValidShouldNotTakeMoreThanMilliseconds; add: #testErrorInRaiseWithExceptionDo; add: #testNoExceptionInShouldRaiseWithExceptionDo; add: #testInvalidShouldNotTakeMoreThan; yourself)); add: (#timeStamp->'22 November 2008 10:11:35 pm'); add: (#failures->((Set new))); add: (#errors->((Set new))); yourself)! ----- Method: SUnitExtensionsTest>>assertionFailedInRaiseWithExceptionDoTest (in category 'real tests') ----- assertionFailedInRaiseWithExceptionDoTest self should: [ Error signal ] raise: Error withExceptionDo: [ :anException | self assert: false ]! ----- Method: SUnitExtensionsTest>>differentExceptionInShouldRaiseWithExceptionDoTest (in category 'real tests') ----- differentExceptionInShouldRaiseWithExceptionDoTest [ self should: [ Error signal ] raise: Halt withExceptionDo: [ :anException | self assert: false description: 'should:raise:withExceptionDo: handled an exception that should not handle'] ] on: Error do: [ :anException | anException return: nil ]! ----- Method: SUnitExtensionsTest>>errorInRaiseWithExceptionDoTest (in category 'real tests') ----- errorInRaiseWithExceptionDoTest self should: [ Error signal ] raise: Error withExceptionDo: [ :anException | Error signal: 'A forced error' ]! ----- Method: SUnitExtensionsTest>>failureLog (in category 'test support') ----- failureLog ^self stream! ----- Method: SUnitExtensionsTest>>invalidShouldNotTakeMoreThan (in category 'real tests') ----- invalidShouldNotTakeMoreThan self should: [(Delay forMilliseconds: 100) wait] notTakeMoreThan: 50 milliSeconds.! ----- Method: SUnitExtensionsTest>>invalidShouldNotTakeMoreThanMilliseconds (in category 'real tests') ----- invalidShouldNotTakeMoreThanMilliseconds self should: [(Delay forMilliseconds: 100) wait] notTakeMoreThanMilliseconds: 50! ----- Method: SUnitExtensionsTest>>isLogging (in category 'testing') ----- isLogging ^true! ----- Method: SUnitExtensionsTest>>noExceptionInShouldRaiseWithExceptionDoTest (in category 'real tests') ----- noExceptionInShouldRaiseWithExceptionDoTest self should: [ ] raise: Error withExceptionDo: [ :anException | Error signal: 'Should not get here' ]! ----- Method: SUnitExtensionsTest>>shouldFixTest (in category 'real tests') ----- shouldFixTest self shouldFix: [ Error signal: 'any kind of error' ] ! ----- Method: SUnitExtensionsTest>>shouldRaiseWithExceptionDoTest (in category 'real tests') ----- shouldRaiseWithExceptionDoTest self should: [ Error signal: '1' ] raise: Error withExceptionDo: [ :anException | self assert: anException messageText = '1' ]! ----- Method: SUnitExtensionsTest>>shouldRaiseWithSignalDoTest (in category 'real tests') ----- shouldRaiseWithSignalDoTest self should: [ Error signal: '1' ] raise: Error withExceptionDo: [ :anException | self assert: anException messageText = '1' ]! ----- Method: SUnitExtensionsTest>>stream (in category 'accessing') ----- stream ^stream ifNil: [stream := WriteStream on: String new]! ----- Method: SUnitExtensionsTest>>testAssertionFailedInRaiseWithExceptionDo (in category 'test') ----- testAssertionFailedInRaiseWithExceptionDo | testCase testResult | testCase := self class selector: #assertionFailedInRaiseWithExceptionDoTest. testResult := testCase run. self assert: (testResult failures includes: testCase). self assert: testResult failures size=1. self assert: testResult passed isEmpty. self assert: testResult errors isEmpty. ! ----- Method: SUnitExtensionsTest>>testAutoAssertFalse (in category 'test') ----- testAutoAssertFalse | booleanCondition | self assert: self isLogging. self should: [ self assert: 1 = 2 description: 'self assert: 1 = 2' ] raise: TestResult failure. booleanCondition := (self stream contents subStrings: {Character cr}) last = 'self assert: 1 = 2'. self assert: booleanCondition! ----- Method: SUnitExtensionsTest>>testAutoAssertTrue (in category 'test') ----- testAutoAssertTrue self assert: 1 = 1. self assert: true! ----- Method: SUnitExtensionsTest>>testAutoDenyFalse (in category 'test') ----- testAutoDenyFalse | booleanCondition | self assert: self isLogging. self should: [ self deny: 1 = 1 description: 'self deny: 1 = 1'.] raise: TestResult failure. booleanCondition := (self stream contents subStrings: {Character cr}) last = 'self deny: 1 = 1'. self assert: booleanCondition! ----- Method: SUnitExtensionsTest>>testAutoDenyTrue (in category 'test') ----- testAutoDenyTrue self deny: 1 = 2. self deny: false! ----- Method: SUnitExtensionsTest>>testDifferentExceptionInShouldRaiseWithExceptionDo (in category 'test') ----- testDifferentExceptionInShouldRaiseWithExceptionDo | testCase testResult | testCase := self class selector: #differentExceptionInShouldRaiseWithExceptionDoTest. testResult := testCase run. self assert: (testResult passed includes: testCase). self assert: testResult errors isEmpty. self assert: testResult failures isEmpty. self assert: testResult passed size=1! ----- Method: SUnitExtensionsTest>>testErrorInRaiseWithExceptionDo (in category 'test') ----- testErrorInRaiseWithExceptionDo | testCase testResult | testCase := self class selector: #errorInRaiseWithExceptionDoTest. testResult := testCase run. self assert: (testResult errors includes: testCase). self assert: testResult errors size=1. self assert: testResult failures isEmpty. self assert: testResult passed isEmpty. ! ----- Method: SUnitExtensionsTest>>testExceptionWithMatchingString (in category 'as yet unclassified') ----- testExceptionWithMatchingString self should: [ Object obsolete ] raise: Error whoseDescriptionIncludes: 'NOT obsolete' description: 'tested obsoleting Object'! ----- Method: SUnitExtensionsTest>>testExceptionWithoutMatchingString (in category 'as yet unclassified') ----- testExceptionWithoutMatchingString self should: [ Object obsolete ] raise: Error whoseDescriptionDoesNotInclude: 'Zero' description: 'tested obsoleting Object'! ----- Method: SUnitExtensionsTest>>testInvalidShouldNotTakeMoreThan (in category 'test') ----- testInvalidShouldNotTakeMoreThan | testCase testResult | testCase := self class selector: #invalidShouldNotTakeMoreThan. testResult := testCase run. self assert: testResult passed isEmpty. self assert: testResult failures size = 1. self assert: (testResult failures includes: testCase). self assert: testResult errors isEmpty ! ----- Method: SUnitExtensionsTest>>testInvalidShouldNotTakeMoreThanMilliseconds (in category 'test') ----- testInvalidShouldNotTakeMoreThanMilliseconds | testCase testResult | testCase := self class selector: #invalidShouldNotTakeMoreThanMilliseconds. testResult := testCase run. self assert: testResult passed isEmpty. self assert: testResult failures size = 1. self assert: (testResult failures includes: testCase). self assert: testResult errors isEmpty ! ----- Method: SUnitExtensionsTest>>testNoExceptionInShouldRaiseWithExceptionDo (in category 'test') ----- testNoExceptionInShouldRaiseWithExceptionDo | testCase testResult | testCase := self class selector: #noExceptionInShouldRaiseWithExceptionDoTest. testResult := testCase run. self assert: (testResult failures includes: testCase). self assert: testResult failures size=1. self assert: testResult passed isEmpty. self assert: testResult errors isEmpty. ! ----- Method: SUnitExtensionsTest>>testNoExceptionWithMatchingString (in category 'as yet unclassified') ----- testNoExceptionWithMatchingString self shouldnt: [ Object obsolete ] raise: Error whoseDescriptionIncludes: 'Zero' description: 'tested obsoleting Object'! ----- Method: SUnitExtensionsTest>>testNoExceptionWithNoMatchingString (in category 'as yet unclassified') ----- testNoExceptionWithNoMatchingString self shouldnt: [ Object obsolete ] raise: Error whoseDescriptionDoesNotInclude: 'NOT' description: 'tested obsoleting Object'! ----- Method: SUnitExtensionsTest>>testShouldFix (in category 'test') ----- testShouldFix | testCase testResult | testCase := self class selector: #shouldFixTest. testResult := testCase run. self assert: (testResult passed includes: testCase). self assert: testResult passed size=1. self assert: testResult failures isEmpty. self assert: testResult errors isEmpty. ! ----- Method: SUnitExtensionsTest>>testShouldRaiseWithExceptionDo (in category 'test') ----- testShouldRaiseWithExceptionDo | testCase testResult | testCase := self class selector: #shouldRaiseWithExceptionDoTest. testResult := testCase run. self assert: (testResult passed includes: testCase). self assert: testResult passed size=1. self assert: testResult failures isEmpty. self assert: testResult errors isEmpty. ! ----- Method: SUnitExtensionsTest>>testValidShouldNotTakeMoreThan (in category 'test') ----- testValidShouldNotTakeMoreThan | testCase testResult | testCase := self class selector: #validShouldNotTakeMoreThan. testResult := testCase run. self assert: (testResult passed includes: testCase). self assert: testResult passed size = 1. self assert: testResult failures isEmpty. self assert: testResult errors isEmpty ! ----- Method: SUnitExtensionsTest>>testValidShouldNotTakeMoreThanMilliseconds (in category 'test') ----- testValidShouldNotTakeMoreThanMilliseconds | testCase testResult | testCase := self class selector: #validShouldNotTakeMoreThanMilliseconds. testResult := testCase run. self assert: (testResult passed includes: testCase). self assert: testResult passed size = 1. self assert: testResult failures isEmpty. self assert: testResult errors isEmpty ! ----- Method: SUnitExtensionsTest>>validShouldNotTakeMoreThan (in category 'real tests') ----- validShouldNotTakeMoreThan self should: [(Delay forMilliseconds: 100) wait] notTakeMoreThan: 200 milliSeconds.! ----- Method: SUnitExtensionsTest>>validShouldNotTakeMoreThanMilliseconds (in category 'real tests') ----- validShouldNotTakeMoreThanMilliseconds self should: [(Delay forMilliseconds: 100) wait] notTakeMoreThanMilliseconds: 200! TestCase subclass: #SUnitTest instanceVariableNames: 'hasRun hasSetup hasRanOnce' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Tests'! !SUnitTest commentStamp: '<historical>' prior: 0! This is both an example of writing tests and a self test for the SUnit. The tests here are pretty strange, since you want to make sure things blow up. You should not generally have to write tests this complicated in structure, although they will be far more complicated in terms of your own objects- more assertions, more complicated setup. Kent says: "Never forget, however, that if the tests are hard to write, something is probably wrong with the design".! ----- Method: SUnitTest class>>lastStoredRun (in category 'history') ----- lastStoredRun ^ ((Dictionary new) add: (#passed->((Set new) add: #testWithExceptionDo; add: #testRan; add: #testAssert; add: #testRanOnlyOnce; add: #testDialectLocalizedException; add: #testFail; add: #testDefects; add: #testIsNotRerunOnDebug; add: #testResult; add: #testRunning; add: #testError; add: #testException; add: #testShould; add: #testSuite; yourself)); add: (#timeStamp->'22 November 2008 10:11:35 pm'); add: (#failures->((Set new))); add: (#errors->((Set new))); yourself)! ----- Method: SUnitTest>>assertForTestResult:runCount:passed:failed:errors: (in category 'private') ----- assertForTestResult: aResult runCount: aRunCount passed: aPassedCount failed: aFailureCount errors: anErrorCount self assert: aResult runCount = aRunCount; assert: aResult passedCount = aPassedCount; assert: aResult failureCount = aFailureCount; assert: aResult errorCount = anErrorCount ! ----- Method: SUnitTest>>error (in category 'private') ----- error 3 zork ! ----- Method: SUnitTest>>errorShouldntRaise (in category 'testing') ----- errorShouldntRaise self shouldnt: [self someMessageThatIsntUnderstood] raise: Notification new ! ----- Method: SUnitTest>>fail (in category 'private') ----- fail self assert: false ! ----- Method: SUnitTest>>hasRun (in category 'accessing') ----- hasRun ^hasRun ! ----- Method: SUnitTest>>hasSetup (in category 'accessing') ----- hasSetup ^hasSetup ! ----- Method: SUnitTest>>noop (in category 'private') ----- noop ! ----- Method: SUnitTest>>setRun (in category 'private') ----- setRun hasRun := true ! ----- Method: SUnitTest>>setUp (in category 'running') ----- setUp hasSetup := true ! ----- Method: SUnitTest>>testAssert (in category 'testing') ----- testAssert self assert: true. self deny: false ! ----- Method: SUnitTest>>testAssertIdentical (in category 'testing') ----- testAssertIdentical | a b | a := 'foo'. b := 'bar'. self should: [self assert: a identical: b] raise: TestFailure. [self assert: a identical: b] on: TestFailure do: [:e | |error| error := e messageText. self assert: (error includesSubString: a) description: 'Error message doesn''t include the expected value'. self assert: (error includesSubString: b) description: 'Error message doesn''t include the expected value'].! ----- Method: SUnitTest>>testAssertIdenticalDescription (in category 'testing') ----- testAssertIdenticalDescription | a b | a := 'foo'. b := a copy. self should: [self assert: a identical: b description: 'A desciption'] raise: TestFailure. [self assert: a identical: b description: 'A desciption'] on: TestFailure do: [:e | |error| error := e messageText. self assert: (error includesSubString: 'A desciption') description: 'Error message doesn''t give you the description'].! ----- Method: SUnitTest>>testAssertIdenticalWithEqualObjects (in category 'testing') ----- testAssertIdenticalWithEqualObjects | a b | a := 'foo'. b := a copy. self should: [self assert: a identical: b] raise: TestFailure. [self assert: a identical: b] on: TestFailure do: [:e | |error| error := e messageText. self assert: (error includesSubString: 'not identical') description: 'Error message doesn''t say the two things aren''t identical'].! ----- Method: SUnitTest>>testDefects (in category 'testing') ----- testDefects | result suite error failure | suite := TestSuite new. suite addTest: (error := self class selector: #error). suite addTest: (failure := self class selector: #fail). result := suite run. self assert: result defects asArray = (Array with: error with: failure). self assertForTestResult: result runCount: 2 passed: 0 failed: 1 errors: 1 ! ----- Method: SUnitTest>>testDialectLocalizedException (in category 'testing') ----- testDialectLocalizedException self should: [TestResult signalFailureWith: 'Foo'] raise: TestResult failure. self should: [TestResult signalErrorWith: 'Foo'] raise: TestResult error. ! ----- Method: SUnitTest>>testError (in category 'testing') ----- testError | case result | case := self class selector: #error. result := case run. self assertForTestResult: result runCount: 1 passed: 0 failed: 0 errors: 1. case := self class selector: #errorShouldntRaise. result := case run. self assertForTestResult: result runCount: 1 passed: 0 failed: 0 errors: 1 ! ----- Method: SUnitTest>>testException (in category 'testing') ----- testException self should: [self error: 'foo'] raise: TestResult error ! ----- Method: SUnitTest>>testFail (in category 'testing') ----- testFail | case result | case := self class selector: #fail. result := case run. self assertForTestResult: result runCount: 1 passed: 0 failed: 1 errors: 0 ! ----- Method: SUnitTest>>testRan (in category 'testing') ----- testRan | case | case := self class selector: #setRun. case run. self assert: case hasSetup. self assert: case hasRun ! ----- Method: SUnitTest>>testRanOnlyOnce (in category 'testing') ----- testRanOnlyOnce self assert: hasRanOnce ~= true. hasRanOnce := true ! ----- Method: SUnitTest>>testResult (in category 'testing') ----- testResult | case result | case := self class selector: #noop. result := case run. self assertForTestResult: result runCount: 1 passed: 1 failed: 0 errors: 0 ! ----- Method: SUnitTest>>testRunning (in category 'testing') ----- testRunning (Delay forSeconds: 2) wait ! ----- Method: SUnitTest>>testSelectorWithArg: (in category 'testing') ----- testSelectorWithArg: anObject "should not result in error"! ----- Method: SUnitTest>>testShould (in category 'testing') ----- testShould self should: [true]; shouldnt: [false] ! ----- Method: SUnitTest>>testSuite (in category 'testing') ----- testSuite | suite result | suite := TestSuite new. suite addTest: (self class selector: #noop); addTest: (self class selector: #fail); addTest: (self class selector: #error). result := suite run. self assertForTestResult: result runCount: 3 passed: 1 failed: 1 errors: 1 ! ----- Method: SUnitTest>>testTestTimeout (in category 'testing') ----- testTestTimeout self should:[(Delay forSeconds: 6) wait] raise: TestFailure. ! ----- Method: SUnitTest>>testTestTimeoutLoop (in category 'testing') ----- testTestTimeoutLoop <timeout: 1> self should:[[] repeat] raise: TestFailure. ! ----- Method: SUnitTest>>testTestTimeoutTag (in category 'testing') ----- testTestTimeoutTag <timeout: 1> self should:[(Delay forSeconds: 3) wait] raise: TestFailure. ! ----- Method: SUnitTest>>testWithExceptionDo (in category 'testing') ----- testWithExceptionDo self should: [self error: 'foo'] raise: TestResult error withExceptionDo: [:exception | self assert: (exception description includesSubString: 'foo') ] ! TestCase subclass: #SimpleTestResourceTestCase instanceVariableNames: 'resource' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Tests'! ----- Method: SimpleTestResourceTestCase class>>lastStoredRun (in category 'history') ----- lastStoredRun ^ ((Dictionary new) add: (#passed->((Set new) add: #testResourceInitRelease; add: #testResourcesCollection; add: #testRan; yourself)); add: (#timeStamp->'22 November 2008 10:11:35 pm'); add: (#failures->((Set new))); add: (#errors->((Set new))); yourself)! ----- Method: SimpleTestResourceTestCase class>>resources (in category 'not categorized') ----- resources ^Set new add: SimpleTestResource; yourself ! ----- Method: SimpleTestResourceTestCase>>dummy (in category 'not categorized') ----- dummy self assert: true ! ----- Method: SimpleTestResourceTestCase>>error (in category 'not categorized') ----- error 'foo' odd ! ----- Method: SimpleTestResourceTestCase>>fail (in category 'not categorized') ----- fail self assert: false ! ----- Method: SimpleTestResourceTestCase>>setRun (in category 'not categorized') ----- setRun resource setRun ! ----- Method: SimpleTestResourceTestCase>>setUp (in category 'not categorized') ----- setUp resource := SimpleTestResource current ! ----- Method: SimpleTestResourceTestCase>>testRan (in category 'not categorized') ----- testRan | case | case := self class selector: #setRun. case run. self assert: resource hasSetup. self assert: resource hasRun ! ----- Method: SimpleTestResourceTestCase>>testResourceInitRelease (in category 'not categorized') ----- testResourceInitRelease | result suite error failure | suite := TestSuite new. suite addTest: (error := self class selector: #error). suite addTest: (failure := self class selector: #fail). suite addTest: (self class selector: #dummy). result := suite run. self assert: resource hasSetup ! ----- Method: SimpleTestResourceTestCase>>testResourcesCollection (in category 'not categorized') ----- testResourcesCollection | collection | collection := self resources. self assert: collection size = 1 ! ----- Method: TestCase class>>addTestsFor:toSuite: (in category 'building suites') ----- addTestsFor: classNameString toSuite: suite | cls | cls := Smalltalk at: classNameString ifAbsent: [ ^suite ]. ^cls isAbstract ifTrue: [ cls allSubclasses do: [ :each | each isAbstract ifFalse: [ each addToSuiteFromSelectors: suite ] ]. suite] ifFalse: [ cls addToSuiteFromSelectors: suite ] ! ----- Method: TestCase class>>addToSuite:fromMethods: (in category 'building suites') ----- addToSuite: suite fromMethods: testMethods testMethods do: [ :selector | suite addTest: (self selector: selector) ]. ^suite! ----- Method: TestCase class>>addToSuiteFromSelectors: (in category 'building suites') ----- addToSuiteFromSelectors: suite ^self addToSuite: suite fromMethods: (self shouldInheritSelectors ifTrue: [ self allTestSelectors ] ifFalse: [self testSelectors ])! ----- Method: TestCase class>>allTestSelectors (in category 'accessing') ----- allTestSelectors ^(self allSelectors asArray select: [ :each | each isTestSelector and: [ each numArgs isZero ] ]) sort ! ----- Method: TestCase class>>buildSuite (in category 'building suites') ----- buildSuite | suite | suite := self suiteClass new. ^ self isAbstract ifTrue: [ suite name: self name asString. self allSubclasses do: [:each | each isAbstract ifFalse: [each addToSuiteFromSelectors: suite]]. suite] ifFalse: [self addToSuiteFromSelectors: suite]! ----- Method: TestCase class>>buildSuiteFromAllSelectors (in category 'building suites') ----- buildSuiteFromAllSelectors ^self buildSuiteFromMethods: self allTestSelectors ! ----- Method: TestCase class>>buildSuiteFromLocalSelectors (in category 'building suites') ----- buildSuiteFromLocalSelectors ^self buildSuiteFromMethods: self testSelectors ! ----- Method: TestCase class>>buildSuiteFromMethods: (in category 'building suites') ----- buildSuiteFromMethods: testMethods | suite | suite := (self suiteClass new) name: self name asString; yourself. ^self addToSuite: suite fromMethods: testMethods! ----- Method: TestCase class>>buildSuiteFromSelectors (in category 'building suites') ----- buildSuiteFromSelectors ^self shouldInheritSelectors ifTrue: [self buildSuiteFromAllSelectors] ifFalse: [self buildSuiteFromLocalSelectors] ! ----- Method: TestCase class>>coverage (in category 'coverage') ----- coverage "returns the coverage determined by a simple static analysis of test coverage made by the receiver on a class that is identified by the name of the receiver. We assume that SetTest test Set." | cls className | (self name endsWith: 'Test') ifFalse: [self error: 'Please, use #coverageForClass: instead']. className := self name copyFrom: 1 to: (self name size - 'Test' size). cls := Smalltalk at: className asSymbol ifAbsent: [self error: 'Please, use #coverageForClass: instead']. "May happen with Transcript" cls isBehavior ifFalse: [cls := cls class]. ^ self coverageForClass: cls! ----- Method: TestCase class>>coverageAsString (in category 'coverage') ----- coverageAsString | cov className | cov := self coverage first asInteger. "coverage already checks that the name is ends with 'Test' and if the class tested exists" className := self name copyFrom: 1 to: (self name size - 'Test' size). ^ self name asString, ' covers ', cov asString, '% of ', className.! ----- Method: TestCase class>>coverageForClass: (in category 'coverage') ----- coverageForClass: cls "returns the test coverage of all the methods included inherited ones" ^ self coverageForClass: cls until: ProtoObject! ----- Method: TestCase class>>coverageForClass:until: (in category 'coverage') ----- coverageForClass: cls until: aRootClass "returns the test coverage of all the methods included inherited ones but stopping at aRootClass included" | definedMethods testedMethods untestedMethods | definedMethods := cls allSelectorsAboveUntil: aRootClass. definedMethods size = 0 ifTrue: [^ {0. Set new}]. testedMethods := self methodDictionary inject: Set new into: [:sums :cm | sums union: cm messages]. testedMethods := testedMethods reject: [:sel | (definedMethods includes: sel) not]. untestedMethods := definedMethods select: [:selector | (testedMethods includes: selector) not]. ^ { (testedMethods size * 100 / definedMethods size) asFloat . untestedMethods} ! ----- Method: TestCase class>>coveragePercentage (in category 'coverage') ----- coveragePercentage ^ self coverage first! ----- Method: TestCase class>>debug: (in category 'instance creation') ----- debug: aSymbol ^(self selector: aSymbol) debug ! ----- Method: TestCase class>>generateLastStoredRunMethod (in category 'history') ----- generateLastStoredRunMethod self shouldGenerateLastStoredRunMethod ifTrue: [ self class compile: (self lastRunMethodNamed: #lastStoredRun) classified: 'history' ]! ----- Method: TestCase class>>hasMethodBeenRun: (in category 'testing') ----- hasMethodBeenRun: aSelector ^ ((self lastRun at: #errors), (self lastRun at: #failures), (self lastRun at: #passed)) includes: aSelector! ----- Method: TestCase class>>history (in category 'history') ----- history ^ history ifNil: [ history := self newTestDictionary ]! ----- Method: TestCase class>>history: (in category 'history') ----- history: aDictionary history := aDictionary! ----- Method: TestCase class>>initialize (in category 'initialize - event') ----- initialize super initialize. SystemChangeNotifier uniqueInstance notify: self ofSystemChangesOfItem: #method using: #methodChanged:.! ----- Method: TestCase class>>isAbstract (in category 'testing') ----- isAbstract "Override to true if a TestCase subclass is Abstract and should not have TestCase instances built from it" ^self name = #TestCase ! ----- Method: TestCase class>>isTestClass (in category 'testing') ----- isTestClass ^ true! ----- Method: TestCase class>>lastRun (in category 'history') ----- lastRun ^ TestResult historyFor: self! ----- Method: TestCase class>>lastRunMethodNamed: (in category 'history') ----- lastRunMethodNamed: aSelector ^ String streamContents: [:str | str nextPutAll: aSelector asString ;cr. str tab; nextPutAll: '^ ', (self lastRun) storeString] ! ----- Method: TestCase class>>lastStoredRun (in category 'history') ----- lastStoredRun ^ ((Dictionary new) add: (#failures->#()); add: (#passed->#()); add: (#errors->#()); yourself)! ----- Method: TestCase class>>localCoverage (in category 'coverage') ----- localCoverage "returns the coverage determined by a simple static analysis of test coverage made by the receiver on a class that is identified by the name of the receiver. We assume that SetTest test Set. The computation of the coverage takes only into account the methods defined locally in the tested class. See coverage for a more global coverage" | cls className | (self name endsWith: 'Test') ifFalse: [self error: 'Please, use #localCoverageForClass: instead']. className := self name copyFrom: 1 to: (self name size - 'Test' size). cls := Smalltalk at: className asSymbol ifAbsent: [self error: 'Please, use #localCoverageForClass: instead']. cls isBehavior ifFalse: [cls := cls class]. ^ self localCoverageForClass: cls! ----- Method: TestCase class>>localCoverageAsString (in category 'coverage') ----- localCoverageAsString | cov className | cov := self localCoverage first asInteger. "coverage already checks that the name is ends with 'Test' and if the class tested exists" className := self name copyFrom: 1 to: (self name size - 'Test' size). ^ self name asString, ' covers ', cov asString, '% of ', className.! ----- Method: TestCase class>>localCoverageForClass: (in category 'coverage') ----- localCoverageForClass: cls | definedMethods testedMethods untestedMethods | definedMethods := cls selectors asSet. "It happens for IdentityBag / IdentityBagTest" definedMethods size = 0 ifTrue: [^ {0. Set new}]. testedMethods := self methodDictionary inject: Set new into: [:sums :cm | sums union: cm messages]. "testedMethods contains all the methods send in test methods, which probably contains methods that have nothign to do with collection" testedMethods := testedMethods reject: [:sel | (definedMethods includes: sel) not]. untestedMethods := definedMethods select: [:selector | (testedMethods includes: selector) not]. ^ { (testedMethods size * 100 / definedMethods size) asFloat . untestedMethods} ! ----- Method: TestCase class>>localCoveragePercentage (in category 'coverage') ----- localCoveragePercentage ^ self localCoverage first! ----- Method: TestCase class>>methodChanged: (in category 'initialize - event') ----- methodChanged: anEvent "Remove the changed method from the known test results." | cls sel | anEvent item isCompiledMethod ifFalse: [ ^ self ]. cls := anEvent item methodClass. (cls inheritsFrom: TestCase) ifFalse: [^ self]. sel := anEvent item selector. (sel beginsWith: 'test') ifFalse: [^ self]. TestResult removeFromTestHistory: sel in: cls. ! ----- Method: TestCase class>>methodFailed: (in category 'testing') ----- methodFailed: aSelector ^ (self lastRun at: #failures) includes: aSelector! ----- Method: TestCase class>>methodPassed: (in category 'testing') ----- methodPassed: aSelector ^ (self lastRun at: #passed) includes: aSelector! ----- Method: TestCase class>>methodProgressed: (in category 'testing') ----- methodProgressed: aSelector ^ ((self storedMethodRaisedError: aSelector) or: [self storedMethodFailed: aSelector]) and: [self methodPassed: aSelector] ! ----- Method: TestCase class>>methodRaisedError: (in category 'testing') ----- methodRaisedError: aSelector ^ (self lastRun at: #errors) includes: aSelector! ----- Method: TestCase class>>methodRegressed: (in category 'testing') ----- methodRegressed: aSelector ^ (self storedMethodPassed: aSelector) and: [(self methodFailed: aSelector) or: [self methodRaisedError: aSelector]]! ----- Method: TestCase class>>newTestDictionary (in category 'history') ----- newTestDictionary ^ Dictionary new at: #timeStamp put: TimeStamp now; at: #passed put: Set new; at: #failures put: Set new; at: #errors put: Set new; yourself ! ----- Method: TestCase class>>resetHistory (in category 'history') ----- resetHistory history := nil! ----- Method: TestCase class>>resources (in category 'accessing') ----- resources ^#() ! ----- Method: TestCase class>>run: (in category 'instance creation') ----- run: aSymbol ^(self selector: aSymbol) run ! ----- Method: TestCase class>>selector: (in category 'instance creation') ----- selector: aSymbol ^self new setTestSelector: aSymbol ! ----- Method: TestCase class>>shouldGenerateLastStoredRunMethod (in category 'history') ----- shouldGenerateLastStoredRunMethod | sameRun | (self class methodDictionary includesKey: #lastStoredRun) ifFalse: [^ true]. sameRun := #(#passed #failures #errors) inject: true into: [ :ok :set | ok and: [(self lastRun at: set) = (self lastStoredRun at: set) ]]. ^ sameRun not ! ----- Method: TestCase class>>shouldInheritSelectors (in category 'testing') ----- shouldInheritSelectors "I should inherit from an Abstract superclass but not from a concrete one by default, unless I have no testSelectors in which case I must be expecting to inherit them from my superclass. If a test case with selectors wants to inherit selectors from a concrete superclass, override this to true in that subclass." ^self superclass isAbstract or: [self testSelectors isEmpty] "$QA Ignore:Sends system method(superclass)$" ! ----- Method: TestCase class>>storedMethodFailed: (in category 'testing') ----- storedMethodFailed: aSelector ^ (self lastStoredRun at: #failures) includes: aSelector! ----- Method: TestCase class>>storedMethodPassed: (in category 'testing') ----- storedMethodPassed: aSelector ^ (self lastStoredRun at: #passed) includes: aSelector! ----- Method: TestCase class>>storedMethodRaisedError: (in category 'testing') ----- storedMethodRaisedError: aSelector ^ (self lastStoredRun at: #errors) includes: aSelector! ----- Method: TestCase class>>suite (in category 'instance creation') ----- suite ^self buildSuite ! ----- Method: TestCase class>>suiteClass (in category 'building suites') ----- suiteClass ^TestSuite ! ----- Method: TestCase class>>sunitVersion (in category 'accessing') ----- sunitVersion ^'3.1' ! ----- Method: TestCase class>>testSelectors (in category 'Accessing') ----- testSelectors ^(self selectors asArray select: [ :each | (each beginsWith: 'test') and: [ each numArgs isZero ] ]) sort! ----- Method: TestCase>>addDependentToHierachy: (in category 'dependencies') ----- addDependentToHierachy: anObject "an empty method. for Composite compability with TestSuite" ! ----- Method: TestCase>>assert: (in category 'accessing') ----- assert: aBooleanOrBlock aBooleanOrBlock value ifFalse: [self signalFailure: 'Assertion failed'] ! ----- Method: TestCase>>assert:description: (in category 'accessing') ----- assert: aBooleanOrBlock description: aStringOrBlock aBooleanOrBlock value ifFalse: [ | description | description := aStringOrBlock value. self logFailure: description. TestResult failure signal: description ] ! ----- Method: TestCase>>assert:description:resumable: (in category 'accessing') ----- assert: aBooleanOrBlock description: aString resumable: resumableBoolean | exception | aBooleanOrBlock value ifFalse: [self logFailure: aString. exception := resumableBoolean ifTrue: [TestResult resumableFailure] ifFalse: [TestResult failure]. exception signal: aString] ! ----- Method: TestCase>>assert:equals: (in category 'accessing') ----- assert: expected equals: actual ^self assert: expected = actual description: [ self comparingStringBetween: expected and: actual ] ! ----- Method: TestCase>>assert:equals:description: (in category 'accessing') ----- assert: expected equals: actual description: aString ^self assert: expected = actual description: [ aString , ': ', (self comparingStringBetween: expected and: actual) ]! ----- Method: TestCase>>assert:identical: (in category 'accessing') ----- assert: expected identical: actual ^self assert: expected == actual description: [ self comparingStringBetweenIdentical: expected and: actual ] ! ----- Method: TestCase>>assert:identical:description: (in category 'accessing') ----- assert: expected identical: actual description: aString ^self assert: expected == actual description: [ aString , ': ', (self comparingStringBetweenIdentical: expected and: actual) ]! ----- Method: TestCase>>comparingStringBetween:and: (in category 'private') ----- comparingStringBetween: expected and: actual ^ String streamContents: [:stream | stream nextPutAll: 'Expected '; nextPutAll: (expected printStringLimitedTo: 10); nextPutAll: ' but was '; nextPutAll: (actual printStringLimitedTo: 10); nextPutAll: '.' ]! ----- Method: TestCase>>comparingStringBetweenIdentical:and: (in category 'private') ----- comparingStringBetweenIdentical: expected and: actual ^ 'Expected {1} and actual {2} are not identical.' format: { expected printStringLimitedTo: 10. actual printStringLimitedTo: 10. }! ----- Method: TestCase>>debug (in category 'running') ----- debug self resources do: [ : res | res isAvailable ifFalse: [ ^ res signalInitializationError ] ]. [ self runCase ] ensure: [ self resources do: [ : each | each reset ] ]! ----- Method: TestCase>>debugAsFailure (in category 'running') ----- debugAsFailure | semaphore | semaphore := Semaphore new. self resources do: [:res | res isAvailable ifFalse: [^res signalInitializationError]]. [semaphore wait. self resources do: [:each | each reset]] fork. (self class selector: testSelector) runCaseAsFailure: semaphore.! ----- Method: TestCase>>defaultTimeout (in category 'accessing') ----- defaultTimeout "Answer the default timeout to use for tests in this test case. The timeout is a value in seconds." ^5 "seconds"! ----- Method: TestCase>>deny: (in category 'accessing') ----- deny: aBooleanOrBlock self assert: aBooleanOrBlock value not ! ----- Method: TestCase>>deny:description: (in category 'accessing') ----- deny: aBooleanOrBlock description: aString self assert: aBooleanOrBlock value not description: aString ! ----- Method: TestCase>>deny:description:resumable: (in category 'accessing') ----- deny: aBooleanOrBlock description: aString resumable: resumableBoolean self assert: aBooleanOrBlock value not description: aString resumable: resumableBoolean ! ----- Method: TestCase>>executeShould:inScopeOf: (in category 'private') ----- executeShould: aBlock inScopeOf: anExceptionalEvent ^[aBlock value. false] on: anExceptionalEvent do: [:ex | ex return: true] ! ----- Method: TestCase>>executeShould:inScopeOf:withDescriptionContaining: (in category 'private') ----- executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionContaining: aString ^[aBlock value. false] on: anExceptionalEvent do: [:ex | ex return: (ex description includesSubString: aString) ] ! ----- Method: TestCase>>executeShould:inScopeOf:withDescriptionNotContaining: (in category 'private') ----- executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionNotContaining: aString ^[aBlock value. false] on: anExceptionalEvent do: [:ex | ex return: (ex description includesSubString: aString) not ] ! ----- Method: TestCase>>executeShould:inScopeOf:withExceptionDo: (in category 'extensions') ----- executeShould: aBlock inScopeOf: anException withExceptionDo: anotherBlock ^[aBlock value. false] on: anException do: [:exception | anotherBlock value: exception. exception return: true]! ----- Method: TestCase>>expectedFailures (in category 'testing') ----- expectedFailures ^ Array new! ----- Method: TestCase>>fail (in category 'extensions') ----- fail ^self assert: false! ----- Method: TestCase>>fail: (in category 'extensions') ----- fail: aString ^self assert: false description: aString.! ----- Method: TestCase>>failureLog (in category 'running') ----- failureLog ^Transcript ! ----- Method: TestCase>>isLogging (in category 'running') ----- isLogging "By default, we're not logging failures. If you override this in a subclass, make sure that you override #failureLog" ^false ! ----- Method: TestCase>>logFailure: (in category 'running') ----- logFailure: aString self isLogging ifTrue: [ self failureLog cr; nextPutAll: aString; flush] ! ----- Method: TestCase>>openDebuggerOnFailingTestMethod (in category 'running') ----- openDebuggerOnFailingTestMethod "SUnit has halted one step in front of the failing test method. Step over the 'self halt' and send into 'self perform: testSelector' to see the failure from the beginning" self halt; performTest! ----- Method: TestCase>>performTest (in category 'private') ----- performTest self perform: testSelector asSymbol ! ----- Method: TestCase>>printOn: (in category 'printing') ----- printOn: aStream testSelector ifNil: [super printOn: aStream] ifNotNil: [aStream nextPutAll: self class printString; nextPutAll: '>>#'; nextPutAll: testSelector] ! ----- Method: TestCase>>removeDependentFromHierachy: (in category 'dependencies') ----- removeDependentFromHierachy: anObject "an empty method. for Composite compability with TestSuite" ! ----- Method: TestCase>>resources (in category 'accessing') ----- resources | allResources resourceQueue | allResources := Set new. resourceQueue := OrderedCollection new. resourceQueue addAll: self class resources. [resourceQueue isEmpty] whileFalse: [ | next | next := resourceQueue removeFirst. allResources add: next. resourceQueue addAll: next resources]. ^allResources ! ----- Method: TestCase>>run (in category 'running') ----- run | result | result := TestResult new. self run: result. ^result ! ----- Method: TestCase>>run: (in category 'running') ----- run: aResult aResult runCase: self. ! ----- Method: TestCase>>runCase (in category 'running') ----- runCase "Run this TestCase. Time out if the test takes too long." [self timeout: [self setUp] after: self timeoutForSetUp. self timeout: [self performTest] after: self timeoutForTest] ensure: [self tearDown]! ----- Method: TestCase>>runCaseAsFailure: (in category 'running') ----- runCaseAsFailure: aSemaphore [self setUp. self openDebuggerOnFailingTestMethod] ensure: [ self tearDown. aSemaphore signal]! ----- Method: TestCase>>selector (in category 'accessing') ----- selector ^testSelector ! ----- Method: TestCase>>setTestSelector: (in category 'private') ----- setTestSelector: aSymbol testSelector := aSymbol ! ----- Method: TestCase>>setUp (in category 'running') ----- setUp! ----- Method: TestCase>>should: (in category 'accessing') ----- should: aBlock self assert: aBlock value ! ----- Method: TestCase>>should:description: (in category 'accessing') ----- should: aBlock description: aString self assert: aBlock value description: aString ! ----- Method: TestCase>>should:notTakeMoreThan: (in category 'extensions') ----- should: aBlock notTakeMoreThan: aDuration "Evaluate aBlock in a forked process and if it takes more than anInteger milliseconds to run we terminate the process and report a test failure. It'' important to use the active process for the test failure so that the failure reporting works correctly in the context of the exception handlers." | evaluated evaluationProcess result delay testProcess | evaluated := false. delay := Delay forDuration: aDuration. testProcess := Processor activeProcess. "Create a new process to evaluate aBlock" evaluationProcess := [ result := aBlock value. evaluated := true. delay unschedule. testProcess resume ] forkNamed: 'Process to evaluate should: notTakeMoreThanMilliseconds:'. "Wait the milliseconds they asked me to" delay wait. "After this point either aBlock was evaluated or not..." evaluated ifFalse: [ evaluationProcess terminate. self assert: false description: ('Block evaluation took more than the expected <1p>' expandMacrosWith: aDuration)]. ^result! ----- Method: TestCase>>should:notTakeMoreThanMilliseconds: (in category 'extensions') ----- should: aBlock notTakeMoreThanMilliseconds: anInteger "For compatibility with other Smalltalks" self should: aBlock notTakeMoreThan: (Duration milliSeconds: anInteger).! ----- Method: TestCase>>should:raise: (in category 'accessing') ----- should: aBlock raise: anExceptionalEvent ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent) ! ----- Method: TestCase>>should:raise:description: (in category 'accessing') ----- should: aBlock raise: anExceptionalEvent description: aString ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent) description: aString ! ----- Method: TestCase>>should:raise:whoseDescriptionDoesNotInclude:description: (in category 'accessing') ----- should: aBlock raise: anExceptionalEvent whoseDescriptionDoesNotInclude: subString description: aString ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionNotContaining: subString) description: aString ! ----- Method: TestCase>>should:raise:whoseDescriptionIncludes:description: (in category 'accessing') ----- should: aBlock raise: anExceptionalEvent whoseDescriptionIncludes: subString description: aString ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionContaining: subString) description: aString ! ----- Method: TestCase>>should:raise:withExceptionDo: (in category 'extensions') ----- should: aBlock raise: anException withExceptionDo: anotherBlock ^self assert: (self executeShould: aBlock inScopeOf: anException withExceptionDo: anotherBlock)! ----- Method: TestCase>>shouldFix: (in category 'extensions') ----- shouldFix: aBlock ^self should: aBlock raise: Exception! ----- Method: TestCase>>shouldPass (in category 'testing') ----- shouldPass "Unless the selector is in the list we get from #expectedFailures, we expect it to pass" ^ (self expectedFailures includes: testSelector) not! ----- Method: TestCase>>shouldnt: (in category 'accessing') ----- shouldnt: aBlock self deny: aBlock value ! ----- Method: TestCase>>shouldnt:description: (in category 'accessing') ----- shouldnt: aBlock description: aString self deny: aBlock value description: aString ! ----- Method: TestCase>>shouldnt:raise: (in category 'accessing') ----- shouldnt: aBlock raise: anExceptionalEvent ^ [ aBlock value ] on: anExceptionalEvent do: [:e | self fail: 'Block raised ', e className, ': ', e messageText].! ----- Method: TestCase>>shouldnt:raise:description: (in category 'accessing') ----- shouldnt: aBlock raise: anExceptionalEvent description: aString ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent) not description: aString ! ----- Method: TestCase>>shouldnt:raise:whoseDescriptionDoesNotInclude:description: (in category 'accessing') ----- shouldnt: aBlock raise: anExceptionalEvent whoseDescriptionDoesNotInclude: subString description: aString ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionNotContaining: subString) not description: aString ! ----- Method: TestCase>>shouldnt:raise:whoseDescriptionIncludes:description: (in category 'accessing') ----- shouldnt: aBlock raise: anExceptionalEvent whoseDescriptionIncludes: subString description: aString ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionContaining: subString) not description: aString ! ----- Method: TestCase>>signalFailure: (in category 'accessing') ----- signalFailure: aString TestResult failure signal: aString! ----- Method: TestCase>>tearDown (in category 'running') ----- tearDown! ----- Method: TestCase>>timeout: (in category 'accessing') ----- timeout: seconds "The timeout for a test should normally be set with a method annotation. However, for tests that are expected to run in images that do not support method annotations, the value may be set by setting the value from the #setUp method (i.e. prior to running the test method)." timeout := seconds! ----- Method: TestCase>>timeout:after: (in category 'running') ----- timeout: aBlock after: seconds "Evaluate the argument block. Time out if the evaluation is not complete after the given number of seconds. Handle the situation that a timeout may occur after a failure (during debug)" | theProcess delay watchdog | "the block will be executed in the current process" theProcess := Processor activeProcess. delay := Delay forSeconds: seconds. "make a watchdog process" watchdog := [ delay wait. "wait for timeout or completion" theProcess ifNotNil:[ theProcess signalException: (TestFailure new messageText: 'Test timed out') ] ] newProcess. "Watchdog needs to run at high priority to do its job (but not at timing priority)" watchdog priority: Processor timingPriority-1. "catch the timeout signal" watchdog resume. "start up the watchdog" ^[aBlock on: TestFailure, Error, Halt do:[:ex| theProcess := nil. ex pass. ]] ensure:[ "evaluate the receiver" theProcess := nil. "it has completed, so ..." delay delaySemaphore signal. "arrange for the watchdog to exit" ]! ----- Method: TestCase>>timeoutForSetUp (in category 'accessing') ----- timeoutForSetUp "Answer the timeout to use for setUp" | method | method := self class lookupSelector: testSelector asSymbol. (method pragmaAt: #timeout:) ifNotNil:[:tag| ^tag arguments first]. ^self defaultTimeout! ----- Method: TestCase>>timeoutForTest (in category 'accessing') ----- timeoutForTest "Answer the timeout to use for this test" | method | method := self class lookupSelector: testSelector asSymbol. (method pragmaAt: #timeout:) ifNotNil:[:tag| ^tag arguments first]. ^timeout ifNil: [self defaultTimeout]! Object subclass: #TestResource instanceVariableNames: 'name description' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Kernel'! TestResource class instanceVariableNames: 'current'! TestResource class instanceVariableNames: 'current'! TestResource subclass: #SimpleTestResource instanceVariableNames: 'runningState hasRun hasSetup hasRanOnce' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Tests'! ----- Method: SimpleTestResource>>hasRun (in category 'testing') ----- hasRun ^hasRun ! ----- Method: SimpleTestResource>>hasSetup (in category 'testing') ----- hasSetup ^hasSetup ! ----- Method: SimpleTestResource>>isAvailable (in category 'testing') ----- isAvailable ^self runningState == self startedStateSymbol ! ----- Method: SimpleTestResource>>runningState (in category 'accessing') ----- runningState ^runningState ! ----- Method: SimpleTestResource>>runningState: (in category 'accessing') ----- runningState: aSymbol runningState := aSymbol ! ----- Method: SimpleTestResource>>setRun (in category 'running') ----- setRun hasRun := true ! ----- Method: SimpleTestResource>>setUp (in category 'running') ----- setUp self runningState: self startedStateSymbol. hasSetup := true ! ----- Method: SimpleTestResource>>startedStateSymbol (in category 'running') ----- startedStateSymbol ^#started ! ----- Method: SimpleTestResource>>stoppedStateSymbol (in category 'running') ----- stoppedStateSymbol ^#stopped ! ----- Method: SimpleTestResource>>tearDown (in category 'running') ----- tearDown self runningState: self stoppedStateSymbol ! ----- Method: TestResource class>>current (in category 'accessing') ----- current ^ current ifNil: [ current := self new] ! ----- Method: TestResource class>>current: (in category 'accessing') ----- current: aTestResource current := aTestResource ! ----- Method: TestResource class>>isAbstract (in category 'testing') ----- isAbstract "Override to true if a TestResource subclass is Abstract and should not have TestCase instances built from it" ^self name = #TestResource ! ----- Method: TestResource class>>isAvailable (in category 'testing') ----- isAvailable ^self current notNil and: [self current isAvailable] ! ----- Method: TestResource class>>isUnavailable (in category 'testing') ----- isUnavailable ^self isAvailable not ! ----- Method: TestResource class>>reset (in category 'Creation') ----- reset current ifNotNil: [:oldCurrent | current := nil. oldCurrent tearDown]! ----- Method: TestResource class>>resources (in category 'accessing') ----- resources ^#() ! ----- Method: TestResource class>>signalInitializationError (in category 'creation') ----- signalInitializationError ^TestResult signalErrorWith: 'Resource ' , self name , ' could not be initialized' ! ----- Method: TestResource>>description (in category 'accessing') ----- description ^description ifNil: [ '' ]! ----- Method: TestResource>>description: (in category 'accessing') ----- description: aString description := aString ! ----- Method: TestResource>>initialize (in category 'initializing') ----- initialize super initialize. self setUp ! ----- Method: TestResource>>isAvailable (in category 'testing') ----- isAvailable "override to provide information on the readiness of the resource" ^true ! ----- Method: TestResource>>isUnavailable (in category 'testing') ----- isUnavailable "override to provide information on the readiness of the resource" ^self isAvailable not ! ----- Method: TestResource>>name (in category 'accessing') ----- name ^name ifNil: [ self printString]! ----- Method: TestResource>>name: (in category 'accessing') ----- name: aString name := aString ! ----- Method: TestResource>>printOn: (in category 'printing') ----- printOn: aStream aStream nextPutAll: self class printString ! ----- Method: TestResource>>resources (in category 'accessing') ----- resources ^self class resources ! ----- Method: TestResource>>setUp (in category 'running') ----- setUp "Does nothing. Subclasses should override this to initialize their resource" ! ----- Method: TestResource>>signalInitializationError (in category 'running') ----- signalInitializationError ^self class signalInitializationError ! ----- Method: TestResource>>tearDown (in category 'running') ----- tearDown "Does nothing. Subclasses should override this to tear down their resource" ! Object subclass: #TestResult instanceVariableNames: 'timeStamp failures errors passed' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Kernel'! !TestResult commentStamp: '<historical>' prior: 0! This is a Collecting Parameter for the running of a bunch of tests. TestResult is an interesting object to subclass or substitute. #runCase: is the external protocol you need to reproduce. Kent has seen TestResults that recorded coverage information and that sent email when they were done.! ----- Method: TestResult class>>error (in category 'exceptions') ----- error ^self exError ! ----- Method: TestResult class>>exError (in category 'exceptions') ----- exError ^Error ! ----- Method: TestResult class>>failure (in category 'exceptions') ----- failure ^TestFailure ! ----- Method: TestResult class>>historyAt: (in category 'history') ----- historyAt: aTestCaseClass "I will return the last test dictionary for aTestCaseClass. If none found, I will create a new empty one and link it in the history." ^ aTestCaseClass history ! ----- Method: TestResult class>>historyAt:put: (in category 'history') ----- historyAt: aTestCaseClass put: aDictionary aTestCaseClass history: aDictionary "^ self history at: aTestCaseClass put: aDictionary "! ----- Method: TestResult class>>historyFor: (in category 'history') ----- historyFor: aTestCaseClass "I return the last test dictionary for aTestCaseClass. If none found, I return an empty dictionary but will not link it to the class in the history." | history | history := aTestCaseClass history. history ifNil: [ ^ self newTestDictionary ]. ^ history " ^ self history at: aTestCaseClass ifAbsent: [ self newTestDictionary ]"! ----- Method: TestResult class>>newTestDictionary (in category 'history') ----- newTestDictionary ^ Dictionary new at: #timeStamp put: TimeStamp now; at: #passed put: Set new; at: #failures put: Set new; at: #errors put: Set new; yourself ! ----- Method: TestResult class>>removeFromTestHistory:in: (in category 'history') ----- removeFromTestHistory: aSelector in: aTestCaseClass | lastRun | lastRun := self historyFor: aTestCaseClass. #(#passed #failures #errors) do: [ :set | (lastRun at: set) remove: aSelector ifAbsent: []]. ! ----- Method: TestResult class>>resumableFailure (in category 'exceptions') ----- resumableFailure ^ResumableTestFailure ! ----- Method: TestResult class>>signalErrorWith: (in category 'exceptions') ----- signalErrorWith: aString self error signal: aString ! ----- Method: TestResult class>>signalFailureWith: (in category 'exceptions') ----- signalFailureWith: aString self failure signal: aString ! ----- Method: TestResult class>>updateTestHistoryFor:status: (in category 'history') ----- updateTestHistoryFor: aTestCase status: aSymbol | cls sel | cls := aTestCase class. sel := aTestCase selector. self removeFromTestHistory: sel in: cls. ((self historyAt: cls) at: aSymbol ) add: sel! ----- Method: TestResult>>classesTested (in category 'accessing') ----- classesTested ^ (self tests collect: [ :testCase | testCase class ]) asSet! ----- Method: TestResult>>correctCount (in category 'accessing') ----- correctCount "depreciated - use #passedCount" ^self passedCount ! ----- Method: TestResult>>defects (in category 'accessing') ----- defects ^OrderedCollection new addAll: self errors; addAll: self failures; yourself ! ----- Method: TestResult>>diff: (in category 'diff') ----- diff: aTestResult "Return a collection that contains differences" | passed1Selectors failed1Selectors errors1Selectors passed2Selectors failed2Selectors errors2Selectors | passed1Selectors := self passed collect: [:testCase | testCase selector]. failed1Selectors := self failures collect: [:testCase | testCase selector]. errors1Selectors := self errors collect: [:testCase | testCase selector]. passed2Selectors := aTestResult passed collect: [:testCase | testCase selector]. failed2Selectors := aTestResult failures collect: [:testCase | testCase selector]. errors2Selectors := aTestResult errors collect: [:testCase | testCase selector]. ^ {passed1Selectors copyWithoutAll: passed2Selectors . failed1Selectors copyWithoutAll: failed2Selectors . errors1Selectors copyWithoutAll: errors2Selectors}! ----- Method: TestResult>>dispatchResultsIntoHistory (in category 'history') ----- dispatchResultsIntoHistory self classesTested do: [ :testClass | self class historyAt: testClass put: (self selectResultsForTestCase: testClass) ]. ! ----- Method: TestResult>>errorCount (in category 'accessing') ----- errorCount ^self errors size ! ----- Method: TestResult>>errors (in category 'compatibility') ----- errors ^ self unexpectedErrors! ----- Method: TestResult>>expectedDefectCount (in category 'accessing') ----- expectedDefectCount ^ self expectedDefects size! ----- Method: TestResult>>expectedDefects (in category 'accessing') ----- expectedDefects ^ (errors, failures asOrderedCollection) select: [:each | each shouldPass not] ! ----- Method: TestResult>>expectedPassCount (in category 'accessing') ----- expectedPassCount ^ self expectedPasses size! ----- Method: TestResult>>expectedPasses (in category 'accessing') ----- expectedPasses ^ passed select: [:each | each shouldPass] ! ----- Method: TestResult>>failureCount (in category 'accessing') ----- failureCount ^self failures size ! ----- Method: TestResult>>failures (in category 'compatibility') ----- failures ^ self unexpectedFailures, self unexpectedPasses ! ----- Method: TestResult>>hasErrors (in category 'testing') ----- hasErrors ^self errors size > 0 ! ----- Method: TestResult>>hasFailures (in category 'testing') ----- hasFailures ^self failures size > 0 ! ----- Method: TestResult>>hasPassed (in category 'testing') ----- hasPassed ^ self hasErrors not and: [ self hasFailures not ]! ----- Method: TestResult>>initialize (in category 'initialization') ----- initialize super initialize. passed := OrderedCollection new. failures := Set new. errors := OrderedCollection new. timeStamp := TimeStamp now! ----- Method: TestResult>>isError: (in category 'testing') ----- isError: aTestCase ^self errors includes: aTestCase ! ----- Method: TestResult>>isErrorFor:selector: (in category 'querying') ----- isErrorFor: class selector: selector ^ self errors anySatisfy: [:testCase | testCase class == class and: [testCase selector == selector]]! ----- Method: TestResult>>isFailure: (in category 'testing') ----- isFailure: aTestCase ^self failures includes: aTestCase ! ----- Method: TestResult>>isFailureFor:selector: (in category 'querying') ----- isFailureFor: class selector: selector ^ self failures anySatisfy: [:testCase | testCase class == class and: [testCase selector == selector]]! ----- Method: TestResult>>isPassed: (in category 'testing') ----- isPassed: aTestCase ^self passed includes: aTestCase ! ----- Method: TestResult>>isPassedFor:selector: (in category 'querying') ----- isPassedFor: class selector: selector ^ self passed anySatisfy: [:testCase | testCase class == class and: [testCase selector == selector]]! ----- Method: TestResult>>passed (in category 'compatibility') ----- passed ^ self expectedPasses, self expectedDefects! ----- Method: TestResult>>passedCount (in category 'accessing') ----- passedCount ^self passed size ! ----- Method: TestResult>>printOn: (in category 'printing') ----- printOn: aStream aStream nextPutAll: self runCount printString; nextPutAll: ' run, '; nextPutAll: self expectedPassCount printString; nextPutAll: ' passes, '; nextPutAll: self expectedDefectCount printString; nextPutAll:' expected failures, '; nextPutAll: self unexpectedFailureCount printString; nextPutAll: ' failures, '; nextPutAll: self unexpectedErrorCount printString; nextPutAll:' errors, '; nextPutAll: self unexpectedPassCount printString; nextPutAll:' unexpected passes'.! ----- Method: TestResult>>runCase: (in category 'running') ----- runCase: aTestCase | testCasePassed | testCasePassed := true. [[aTestCase runCase] on: self class failure do: [:signal | failures add: aTestCase. testCasePassed := false. signal return: false]] on: self class error do: [:signal | errors add: aTestCase. testCasePassed := false. signal return: false]. testCasePassed ifTrue: [passed add: aTestCase]! ----- Method: TestResult>>runCount (in category 'accessing') ----- runCount ^ passed size + failures size + errors size! ----- Method: TestResult>>selectResultsForTestCase: (in category 'history') ----- selectResultsForTestCase: aTestCaseClass | passedSelectors errorsSelectors failuresSelectors | passedSelectors := self passed select: [:testCase | testCase class == aTestCaseClass ] thenCollect: [:testCase | testCase selector]. errorsSelectors := self errors select: [:testCase | testCase class == aTestCaseClass ] thenCollect: [:testCase | testCase selector]. failuresSelectors := self failures select: [:testCase | testCase class == aTestCaseClass ] thenCollect: [:testCase | testCase selector]. ^ self class newTestDictionary at: #passed put: passedSelectors asSet; at: #failures put: failuresSelectors asSet; at: #errors put: errorsSelectors asSet; yourself ! ----- Method: TestResult>>tests (in category 'accessing') ----- tests ^(OrderedCollection new: self runCount) addAll: passed; addAll: failures; addAll: errors; yourself! ----- Method: TestResult>>timeStamp (in category 'accessing') ----- timeStamp ^ timeStamp! ----- Method: TestResult>>timeStamp: (in category 'accessing') ----- timeStamp: anObject timeStamp := anObject! ----- Method: TestResult>>unexpectedErrorCount (in category 'accessing') ----- unexpectedErrorCount ^ self unexpectedErrors size! ----- Method: TestResult>>unexpectedErrors (in category 'accessing') ----- unexpectedErrors ^ errors select: [:each | each shouldPass] ! ----- Method: TestResult>>unexpectedFailureCount (in category 'accessing') ----- unexpectedFailureCount ^ self unexpectedFailures size! ----- Method: TestResult>>unexpectedFailures (in category 'accessing') ----- unexpectedFailures ^ failures select: [:each | each shouldPass] ! ----- Method: TestResult>>unexpectedPassCount (in category 'accessing') ----- unexpectedPassCount ^ self unexpectedPasses size! ----- Method: TestResult>>unexpectedPasses (in category 'accessing') ----- unexpectedPasses ^ passed select: [:each | each shouldPass not] ! ----- Method: TestResult>>updateResultsInHistory (in category 'history') ----- updateResultsInHistory #(#passed #failures #errors) do: [ :status | (self perform: status) do: [ :testCase | self class updateTestHistoryFor: testCase status: status ] ]! Object subclass: #TestSuite instanceVariableNames: 'tests resources name' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Kernel'! !TestSuite commentStamp: '<historical>' prior: 0! This is a Composite of Tests, either TestCases or other TestSuites. The common protocol is #run: aTestResult and the dependencies protocol! ----- Method: TestSuite class>>named: (in category 'instance creation') ----- named: aString ^self new name: aString; yourself ! ----- Method: TestSuite>>addDependentToHierachy: (in category 'dependencies') ----- addDependentToHierachy: anObject self addDependent: anObject. self tests do: [ :each | each addDependentToHierachy: anObject] ! ----- Method: TestSuite>>addTest: (in category 'accessing') ----- addTest: aTest self tests add: aTest ! ----- Method: TestSuite>>addTests: (in category 'accessing') ----- addTests: aCollection aCollection do: [:eachTest | self addTest: eachTest] ! ----- Method: TestSuite>>debug (in category 'running') ----- debug self tests do: [ : each | self changed: each. each debug ]! ----- Method: TestSuite>>defaultResources (in category 'accessing') ----- defaultResources ^self tests inject: Set new into: [:coll :testCase | coll addAll: testCase resources; yourself] ! ----- Method: TestSuite>>name (in category 'accessing') ----- name ^name ! ----- Method: TestSuite>>name: (in category 'accessing') ----- name: aString name := aString ! ----- Method: TestSuite>>removeDependentFromHierachy: (in category 'dependencies') ----- removeDependentFromHierachy: anObject self removeDependent: anObject. self tests do: [ :each | each removeDependentFromHierachy: anObject] ! ----- Method: TestSuite>>resources (in category 'accessing') ----- resources ^ resources ifNil: [resources := self defaultResources] ! ----- Method: TestSuite>>resources: (in category 'accessing') ----- resources: anObject resources := anObject ! ----- Method: TestSuite>>resultClass (in category 'private') ----- resultClass ^ TestResult.! ----- Method: TestSuite>>run (in category 'running') ----- run | result | result := self resultClass new. self resources do: [ :res | res isAvailable ifFalse: [^res signalInitializationError]]. [self run: result] ensure: [self resources do: [:each | each reset]]. ^result ! ----- Method: TestSuite>>run: (in category 'running') ----- run: aResult self tests do: [:each | self changed: each. each run: aResult]. ! ----- Method: TestSuite>>tests (in category 'accessing') ----- tests ^ tests ifNil: [tests := OrderedCollection new] !

1 0

← Newer
1
...
10
11
12
13
14
15
16
17
Older →

Jump to page: