├── README ├── LICENSE ├── tosqueak.sh ├── package.xml ├── auth.st ├── xml.st ├── hacks.st ├── parser.st ├── pretty.st ├── server.st ├── responses.st ├── docs └── xml-protocol.org ├── requests.st └── tests.st /README: -------------------------------------------------------------------------------- 1 | This is a Shampoo implementation for GNU Smalltalk 2 | -------------------------------------------------- 3 | 4 | Installation: 5 | 6 | $ gst-package -t ~/.st package.xml 7 | 8 | Do not forget to run tests to check if all is ok: 9 | 10 | $ gst-sunit -p Shampoo 11 | 12 | To create and run a basic Shampoo image, invoke: 13 | 14 | $ gst-load -iI shampoo.im Shampoo 15 | $ gst-remote -I shampoo.im --daemon 16 | $ gst-remote -e "Shampoo.ShampooServer startOn: 9092 login: 'login' pass: '1234'" 17 | 18 | Shampoo project homepage: 19 | 20 | http://dmitrymatveev.co.uk/shampoo 21 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (C) 2010 - 2012 Dmitry Matveev 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | 22 | -------------------------------------------------------------------------------- /tosqueak.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | FILES=$(grep filein package.xml | sed 's/<[/a-z]*>//g') 4 | OUTPUT=shampoo-squeak-$(git rev-parse --short HEAD).st 5 | TRANSCRIPT=ShampooTranscript 6 | XMLNODE=ShNode 7 | XMLTEXT=ShText 8 | 9 | gst-convert -v \ 10 | -f gst \ 11 | -F squeak \ 12 | -C -$TRANSCRIPT -C -$XMLNODE -C -$XMLTEXT \ 13 | -o $OUTPUT \ 14 | $FILES 15 | 16 | if [ "$?" -ne "0" ]; then 17 | echo "Fatal error, exiting" 18 | exit 1 19 | fi 20 | 21 | sed -i \ 22 | -e 's/ShampooXML\.ShNode/ShampooXMLNode/g' \ 23 | -e 's/ShampooXML\.ShText/ShampooXMLText/g' \ 24 | -e 's/ShNode/ShampooXMLNode/g' \ 25 | -e 's/ShText/ShampooXMLText/g' \ 26 | -e 's/Shampoo.ShampooTranscript install\!//g' \ 27 | -e "s/methodsFor: nil/methodsFor: 'as yet unclassified'/g" \ 28 | -e 's/LoginTest/ShampooLoginTest/g' \ 29 | -e 's/NamespacesTest/ShampooNamespacesTest/g' \ 30 | -e 's/ClassesTest/ShampooClassesTest/g' \ 31 | -e 's/ClassTest/ShampooClassTest/g' \ 32 | -e 's/CatsTest/ShampooCatsTest/g' \ 33 | -e 's/MethodsTest/ShampooMethodsTest/g' \ 34 | -e 's/MethodTest/ShampooMethodTest/g' \ 35 | -e 's/CompileClassTest/ShampooCompileClassTest/g' \ 36 | -e 's/CompileClassSideTest/ShampooCompileClassSideTest/g' \ 37 | -e 's/CompileMethodTest/ShampooCompileMethodTest/g' \ 38 | -e 's/DoItTest/ShampooDoItTest/g' \ 39 | -e 's/PrintItTest/ShampooPrintItTest/g' \ 40 | $OUTPUT 41 | -------------------------------------------------------------------------------- /package.xml: -------------------------------------------------------------------------------- 1 | 2 | Shampoo 3 | 4 | TCP 5 | XML 6 | XML-PullParser 7 | Digest 8 | 9 | Shampoo 10 | 11 | 12 | %1 isNil ifTrue: 13 | [^Shampoo.ShampooServer startOn: 9090 login: 'user' pass: '1234']. 14 | 15 | %1 =~ '^([A-z0-9]+)\:([A-z0-9]+):([0-9]+)' ifMatched: 16 | [:m | ^Shampoo.ShampooServer 17 | startOn: (m at: 3) asNumber login: (m at: 1) pass: (m at: 2)]. 18 | 19 | 20 | 21 | %1 isNil ifTrue: 22 | [^Shampoo.ShampooServer closeAll]. 23 | 24 | %1 ~ '^([0-9]+)' ifTrue: 25 | [^Shampoo.ShampooServer closeOn: %1 asNumber] 26 | 27 | 28 | xml.st 29 | hacks.st 30 | auth.st 31 | requests.st 32 | responses.st 33 | server.st 34 | parser.st 35 | pretty.st 36 | 37 | xml.st 38 | hacks.st 39 | auth.st 40 | requests.st 41 | responses.st 42 | server.st 43 | parser.st 44 | pretty.st 45 | 46 | 47 | Shampoo.LoginTest 48 | Shampoo.NamespacesTest 49 | Shampoo.ClassesTest 50 | Shampoo.ClassTest 51 | Shampoo.CatsTest 52 | Shampoo.MethodsTest 53 | Shampoo.MethodTest 54 | Shampoo.CompileClassTest 55 | Shampoo.CompileClassSideTest 56 | Shampoo.CompileMethodTest 57 | Shampoo.DoItTest 58 | Shampoo.PrintItTest 59 | Shampoo.OperationalResponseTest 60 | Shampoo.MessageParserTest 61 | Shampoo.ShampooNotAuthStateTest 62 | Shampoo.ShampooConnectionTest 63 | Shampoo.ShampooRemoveClassTest 64 | Shampoo.ShampooRemoveMethodTest 65 | Shampoo.ShampooChangeCategoryTest 66 | Shampoo.ShampooRemoveCategoryTest 67 | Shampoo.RenameCategoryTest 68 | Shampoo.MethodSourcePrettifierTest 69 | Shampoo.ShampooFileOutClassTest 70 | Shampoo.ShampooFileOutClassCategoryTest 71 | Shampoo.ShampooFileOutNamespaceTest 72 | tests.st 73 | 74 | 75 | -------------------------------------------------------------------------------- /auth.st: -------------------------------------------------------------------------------- 1 | Namespace current: Shampoo [ 2 | 3 | Object subclass: AuthInfo [ 4 | | login passHash | 5 | 6 | 7 | >startOn:login:pass:). Obviously the same login and password 14 | should be specified by a client then. 15 | 16 | When a client connects to the server, the server generates a pseudo-random magic 17 | string (a number) and sends it to the client. The client then should calculate 18 | an MD5 hash of a password, concatenate it with the magic string and then take 19 | a hash of the concatenation again. This hash is then sent back to the server. 20 | 21 | Server performs the same operations and then compares the hashes. So the password 22 | is not transmitted across the network, and the server also does not store it 23 | in the plain form in the memory.'> 24 | 25 | AuthInfo class >> login: aLogin pass: aPass [ 26 | 27 | ^(self new) 28 | login: aLogin pass: aPass; 29 | yourself 30 | ] 31 | 32 | login: aLogin pass: aPass [ 33 | 34 | login := aLogin. 35 | passHash := (MD5 new: aPass) hexDigest 36 | ] 37 | 38 | with: aMagic [ 39 | 40 | ^(LoginInfo new) 41 | login: login 42 | magicHash: (MD5 new: (aMagic printString, passHash)) hexDigest 43 | ] 44 | ] 45 | 46 | Object subclass: LoginInfo [ 47 | | login magicHash | 48 | 49 | 50 | 53 | 54 | LoginInfo class >> fromXML: anXML [ 55 | 56 | ^(self new) 57 | login: (anXML attrMap at: 'login') 58 | magicHash: (anXML attrMap at: 'magic'); 59 | yourself 60 | ] 61 | 62 | login: aString magicHash: aHash [ 63 | 64 | login := aString. 65 | magicHash := aHash 66 | ] 67 | 68 | = aLoginInfo [ 69 | 70 | ^(aLoginInfo class = self class) and: [self hash = aLoginInfo hash] 71 | ] 72 | 73 | hash [ 74 | 75 | ^login hash bitXor: magicHash hash 76 | ] 77 | ] 78 | ] 79 | -------------------------------------------------------------------------------- /xml.st: -------------------------------------------------------------------------------- 1 | Namespace current: Smalltalk [ 2 | Namespace current: ShampooXML [ 3 | Exception subclass: Malformed [ 4 | 5 | ] 6 | 7 | Object subclass: ShNode [ 8 | 9 | 11 | 12 | | underlyingXML | 13 | 14 | ShNode class >> tagname: aString [ 15 | 16 | ^(self new) 17 | underlyingXML: (XML.Element tag: aString); 18 | yourself 19 | ] 20 | 21 | ShNode class >> from: aString [ 22 | 23 | [| doc | 24 | doc := XML.XMLParser processDocumentString: aString 25 | beforeScanDo: [:p | p validate: false]. 26 | ^(self new) 27 | underlyingXML: doc root; 28 | yourself 29 | ] on: XML.MalformedSignal 30 | do: [:e | Malformed new signal] 31 | ] 32 | 33 | underlyingXML: anObject [ 34 | 35 | underlyingXML := anObject 36 | ] 37 | 38 | underlyingXML [ 39 | 40 | ^underlyingXML 41 | ] 42 | 43 | attrMap [ 44 | 45 | ^Dictionary from: 46 | (underlyingXML attributes collect: 47 | [:each | each key type -> each value]) 48 | ] 49 | 50 | addAttribute: anAttrName value: aValueString [ 51 | 52 | | attr | 53 | attr := XML.Attribute name: anAttrName value: aValueString. 54 | underlyingXML addAttribute: attr 55 | ] 56 | 57 | addNode: aNode [ 58 | 59 | underlyingXML addNode: aNode underlyingXML 60 | ] 61 | 62 | elementsNamed: aString [ 63 | 64 | ^(underlyingXML elementsNamed: aString) collect: 65 | [:each | ShNode new underlyingXML: each] 66 | ] 67 | 68 | text [ 69 | 70 | ^underlyingXML characterData 71 | ] 72 | 73 | printOn: aStream [ 74 | 75 | underlyingXML printOn: aStream 76 | ] 77 | ] 78 | 79 | ShNode subclass: ShText [ 80 | 81 | 83 | 84 | ShText class >> text: aString [ 85 | ^(self new) 86 | underlyingXML: (XML.Text text: aString); 87 | yourself 88 | ] 89 | ] 90 | ] 91 | ] 92 | -------------------------------------------------------------------------------- /hacks.st: -------------------------------------------------------------------------------- 1 | Object extend [ 2 | namespaceChain [ 3 | 4 | | ns chain | 5 | ns := self environment. 6 | chain := OrderedCollection new. 7 | [ns ~= Smalltalk] whileTrue: 8 | [chain add: ns. ns := ns environment]. 9 | ^chain reverse 10 | ] 11 | ] 12 | 13 | Collection extend [ 14 | elementsString [ 15 | 16 | ^String join: self separatedBy: ' ' 17 | ] 18 | 19 | asStringArray [ 20 | 21 | "Many reflection methods return different results in various dialects. 22 | #instVarNames in GNU Smalltalk returns an IdentitySet of Symbols, the 23 | same method returns an Array of Strings in Squeak. 24 | 25 | This kludge works as an abstraction over it all" 26 | ^(self collect: [:each | each asString]) asArray 27 | ] 28 | 29 | or [ 30 | 31 | self isEmpty ifTrue: [^false]. 32 | ^self fold: [:a :b | a | b] 33 | ] 34 | 35 | and [ 36 | 37 | self isEmpty ifTrue: [^true]. 38 | ^self fold: [:a :b | a & b] 39 | ] 40 | ] 41 | 42 | BlockClosure extend [ 43 | not [ 44 | 45 | self numArgs ~= 1 ifTrue: 46 | [^self error: '#not is for single argument blocks only']. 47 | 48 | ^[:value | (self value: value) not] 49 | ] 50 | ] 51 | 52 | PositionableStream extend [ 53 | forwardWhile: aBlock [ 54 | 55 | [self atEnd not and: [aBlock value: self peek]] 56 | whileTrue: [self next] 57 | ] 58 | ] 59 | 60 | SequenceableCollection extend [ 61 | drop: anInteger [ 62 | 63 | anInteger > self size ifTrue: [^self class new]. 64 | ^self copyFrom: anInteger + 1 65 | ] 66 | 67 | take: anInteger [ 68 | 69 | anInteger > self size ifTrue: [^self copy]. 70 | anInteger = 0 ifTrue: [^self class new]. 71 | ^self copyFrom: 1 to: anInteger 72 | ] 73 | 74 | breakIf: aBlock [ 75 | 76 | | r | 77 | r := ReadStream on: self. 78 | r forwardWhile: aBlock not. 79 | ^{ self copyFrom: 1 to: r position. 80 | r upToEnd } 81 | ] 82 | 83 | dropWhile: aBlock [ 84 | 85 | | r | 86 | r := ReadStream on: self. 87 | r forwardWhile: aBlock. 88 | ^self copyFrom: r position + 1 89 | ] 90 | 91 | takeWhile: aBlock [ 92 | 93 | | r | 94 | r := ReadStream on: self. 95 | r forwardWhile: aBlock. 96 | ^self copyFrom: 1 to: r position 97 | ] 98 | ] 99 | 100 | String class extend [ 101 | crlf [ 102 | 103 | ^String new writeStream 104 | nextPut: Character cr; 105 | nextPut: Character lf; 106 | contents 107 | ] 108 | ] 109 | 110 | String extend [ 111 | isClosingBracket [ 112 | 113 | ^self trimSeparators = ']' 114 | ] 115 | ] 116 | 117 | PackageLoader class extend [ 118 | reloadPackage: aPackageName [ 119 | 120 | | base | 121 | base := PackageLoader directoryFor: aPackageName. 122 | (PackageLoader fileInsFor: aPackageName) do: 123 | [:e | FileStream fileIn: (base / e) file name]. 124 | ] 125 | ] 126 | 127 | Namespace current: Sockets [ 128 | StreamSocket extend [ 129 | crlf [ 130 | 131 | self nextPutAll: String crlf 132 | ] 133 | ] 134 | ] 135 | 136 | Object subclass: Decorator [ 137 | | underlyingObject | 138 | 139 | Decorator class >> on: anObject [ 140 | 141 | ^self new 142 | underlyingObject: anObject; 143 | yourself 144 | ] 145 | 146 | underlyingObject: anObject [ 147 | 148 | underlyingObject := anObject 149 | ] 150 | 151 | underlyingObject [ 152 | 153 | ^underlyingObject 154 | ] 155 | 156 | doesNotUnderstand: aMessage [ 157 | 158 | "Proxy an unknown message to an underlying object" 159 | ^underlyingObject 160 | perform: aMessage selector 161 | withArguments: aMessage arguments 162 | ] 163 | ] 164 | -------------------------------------------------------------------------------- /parser.st: -------------------------------------------------------------------------------- 1 | Namespace current: Shampoo [ 2 | 3 | Object subclass: MessageParserState [ 4 | 5 | 8 | 9 | | parser buffer | 10 | 11 | MessageParserState class >> new: aString [ 12 | 13 | ^self basicNew 14 | initialize: aString; 15 | yourself 16 | ] 17 | 18 | initialize: aString [ 19 | 20 | buffer := aString 21 | ] 22 | 23 | invalidateBuffer [ 24 | 25 | buffer := String new. 26 | ] 27 | 28 | parser: aParser [ 29 | 30 | parser := aParser. 31 | ] 32 | 33 | consume: aString [ 34 | 35 | buffer := buffer, aString 36 | ] 37 | 38 | canProcess [ 39 | 40 | self subclassResponsibility 41 | ] 42 | 43 | processInto: aCollection [ 44 | 45 | [self tryParse: buffer readStream into: aCollection 46 | ] on: Error do: [:e | e inspect. self handleFail] 47 | ] 48 | 49 | switchToContent: aLength rest: aString [ 50 | 51 | | st | 52 | st := ParseContentState buffer: aString length: aLength. 53 | parser switchTo: st 54 | ] 55 | 56 | switchToHeader: aString [ 57 | 58 | parser switchTo: (ParseHeaderState buffer: aString) 59 | ] 60 | 61 | tryParse: aStream into: aCollection [ 62 | 63 | self subclassResponsibility 64 | ] 65 | 66 | fail [ 67 | 68 | self error: 'Error occured during parsing' 69 | ] 70 | 71 | handleFail [ 72 | 73 | self subclassResponsibility 74 | ] 75 | ] 76 | 77 | MessageParserState subclass: ParseHeaderState [ 78 | 79 | 83 | 84 | ParseHeaderState class >> buffer: aString [ 85 | 86 | ^(self new: aString) 87 | yourself 88 | ] 89 | 90 | canProcess [ 91 | 92 | ^buffer lines size >= 2 93 | ] 94 | 95 | tryParse: aStream into: aCollection [ 96 | 97 | | sz | 98 | aStream upToAll: 'Content-Length: '. 99 | aStream atEnd ifTrue: [self fail]. 100 | sz := Integer readFrom: aStream. 101 | sz = 0 ifTrue: [self fail]. 102 | 2 timesRepeat: 103 | [(aStream next: 2) = String crlf ifFalse: [self fail]]. 104 | self switchToContent: sz rest: aStream upToEnd 105 | ] 106 | 107 | handleFail [ 108 | 109 | self invalidateBuffer 110 | ] 111 | ] 112 | 113 | MessageParserState subclass: ParseContentState [ 114 | 115 | 119 | 120 | | expected | 121 | 122 | ParseContentState class >> buffer: aString length: anInteger [ 123 | 124 | ^(self new: aString) 125 | expected: anInteger; 126 | yourself 127 | ] 128 | 129 | expected: anInteger [ 130 | 131 | expected := anInteger 132 | ] 133 | 134 | canProcess [ 135 | 136 | ^buffer size >= expected 137 | ] 138 | 139 | tryParse: aStream into: aCollection [ 140 | 141 | aCollection add: (aStream next: expected). 142 | self switchToHeader: aStream upToEnd 143 | ] 144 | 145 | handleFail [ 146 | 147 | "Do nothing" 148 | ] 149 | ] 150 | 151 | Object subclass: MessageParser [ 152 | 153 | 155 | 156 | | state | 157 | 158 | MessageParser class >> new [ 159 | 160 | ^(self basicNew) 161 | initialize; 162 | yourself 163 | ] 164 | 165 | initialize [ 166 | 167 | self switchTo: (ParseHeaderState buffer: '') 168 | ] 169 | 170 | process: aString [ 171 | 172 | | results | 173 | results := OrderedCollection new. 174 | state consume: aString. 175 | [state canProcess] whileTrue: 176 | [state processInto: results]. 177 | ^results 178 | ] 179 | 180 | switchTo: aState [ 181 | 182 | state := aState. 183 | state parser: self. 184 | ] 185 | ] 186 | ] 187 | -------------------------------------------------------------------------------- /pretty.st: -------------------------------------------------------------------------------- 1 | Namespace current: Shampoo [ 2 | Object subclass: MethodSource [ 3 | 4 | 5 | | selectorWithArguments body | 6 | 7 | MethodSource class >> from: aString [ 8 | 9 | ^(self new) 10 | init: aString; 11 | yourself 12 | ] 13 | 14 | MethodSource >> init: aString [ 15 | 16 | | r | 17 | r := ReadStream on: aString. 18 | selectorWithArguments := (r upTo: $[) trimSeparators. 19 | body := ((r upToEnd) copyUpToLast: $]) lines. 20 | ] 21 | 22 | selectorWithArguments [ 23 | 24 | ^selectorWithArguments 25 | ] 26 | 27 | body [ 28 | 29 | ^body 30 | ] 31 | 32 | methodIndent [ 33 | 34 | | notEmpty spaceLens | 35 | 36 | "At first, drop all empty strings" 37 | notEmpty := body select: 38 | [:each | each trimSeparators isEmpty not]. 39 | 40 | spaceLens := notEmpty collect: 41 | [:each | (each takeWhile: [:c | c isSeparator]) size]. 42 | 43 | ^spaceLens isEmpty 44 | ifTrue: [0] 45 | ifFalse: [spaceLens fold: [:a :b | a min: b]] 46 | ] 47 | 48 | compact [ 49 | 50 | | r fst | 51 | 52 | "Remove empty lines from the beginning, if any" 53 | r := ReadStream on: body. 54 | r forwardWhile: [:line | line trimSeparators isEmpty]. 55 | body := body drop: r position. 56 | body isEmpty ifTrue: [^self]. 57 | 58 | "Remove newline characters from the beginning of the 59 | first line" 60 | fst := body first breakIf: [:c | c isSeparator not]. 61 | fst := (fst first copyWithout: Character nl), fst second. 62 | body at: 1 put: fst. 63 | 64 | "Remove empty lines from the end, if any" 65 | r := ReadStream on: body reverse. 66 | r forwardWhile: [:line | line trimSeparators isEmpty]. 67 | body := body take: body size - r position. 68 | ] 69 | 70 | stripIndent [ 71 | 72 | | indent | 73 | indent := self methodIndent. 74 | body := body collect: [:each | each drop: indent]. 75 | ] 76 | 77 | indentWith: aString [ 78 | 79 | body := body collect: [:each | aString, each]. 80 | ] 81 | 82 | printOn: aStream [ 83 | aStream 84 | nextPutAll: selectorWithArguments; 85 | space; 86 | nextPut: $[; 87 | nl. 88 | body do: [:line | aStream nextPutAll: line; nl]. 89 | aStream nextPut: $]; nl. 90 | ] 91 | 92 | sourceString [ 93 | 94 | | w | 95 | w := WriteStream on: String new. 96 | self printOn: w. 97 | ^w contents 98 | ] 99 | ] 100 | 101 | Object subclass: ClassSource [ 102 | 103 | 104 | | printedClass namespaces | 105 | 106 | ClassSource class >> of: aClass [ 107 | 108 | ^self new 109 | printedClass: aClass; 110 | yourself 111 | ] 112 | 113 | printedClass: aClass [ 114 | 115 | printedClass := aClass. 116 | namespaces := printedClass namespaceChain. 117 | ] 118 | 119 | enclosingNamespaces: aStream do: aBlock [ 120 | 121 | namespaces do: 122 | [:ns | aStream 123 | nextPutAll: 'Namespace current:'; 124 | space; 125 | nextPutAll: ns name asString; 126 | space; 127 | nextPut: $[; 128 | space]. 129 | aStream nl. 130 | aBlock value. 131 | namespaces size timesRepeat: [aStream nextPut: $]]. 132 | aStream nl 133 | ] 134 | 135 | enclosingClassDefinition: aStream do: aBlock [ 136 | 137 | | superName | 138 | superName := printedClass superclass 139 | ifNil: ['nil'] 140 | ifNotNil: [printedClass superclass name asString]. 141 | aStream 142 | nextPutAll: superName; 143 | space; 144 | nextPutAll: 'subclass:'; 145 | space; 146 | nextPutAll: printedClass name asString; 147 | space; 148 | nextPut: $[; 149 | nl. 150 | aStream increasingIndent: [aBlock value]. 151 | aStream nextPut: $]; nl 152 | ] 153 | 154 | writePragma: aPragmaName value: aString on: aStream [ 155 | 156 | aStream 157 | nextPut: $<; 158 | nextPutAll: aPragmaName; 159 | nextPut: $:; 160 | space; 161 | nextPutAll: aString printString; 162 | nextPut: $> 163 | ] 164 | 165 | writeCommentsOn: aStream [ 166 | 167 | printedClass category isNil ifFalse: 168 | [self writePragma: 'category' 169 | value: printedClass category 170 | on: aStream. 171 | aStream nl]. 172 | printedClass comment isNil ifFalse: 173 | [self writePragma: 'comment' 174 | value: printedClass comment 175 | on: aStream. 176 | aStream nl] 177 | ] 178 | 179 | writeInstVarsOn: aStream [ 180 | 181 | | instvars | 182 | instvars := printedClass instVarNames asStringArray. 183 | instvars isEmpty ifFalse: 184 | [aStream 185 | nl; 186 | nextPut: $|; 187 | space; 188 | nextPutAll: instvars elementsString; 189 | space; 190 | nextPut: $|; 191 | nl] 192 | ] 193 | 194 | writeClassVarsOn: aStream [ 195 | 196 | printedClass classVarNames asStringArray do: 197 | [:each | aStream 198 | nextPutAll: each; 199 | space; 200 | nextPutAll: ':= nil.'; 201 | nl] 202 | ] 203 | 204 | writeMethod: aMethod on: aStream [ 205 | 206 | | ms | 207 | ms := MethodSource from: aMethod methodSourceString. 208 | ms compact; stripIndent. 209 | aStream nl. 210 | ms printOn: aStream. 211 | ] 212 | 213 | writeClassMethod: aMethod on: aStream [ 214 | 215 | | ms start | 216 | ms := MethodSource from: aMethod methodSourceString. 217 | ms compact; stripIndent. 218 | aStream nl. 219 | start := aStream position. 220 | aStream 221 | nextPutAll: printedClass name asString; 222 | space; 223 | nextPutAll: 'class >> '. 224 | aStream position + ms selectorWithArguments size - start 225 | >= 67 ifTrue: [aStream nl]. 226 | ms printOn: aStream. 227 | ] 228 | 229 | writeMethodsOn: aStream [ 230 | 231 | printedClass methodDictionary ifNotNil: 232 | [printedClass methodDictionary values do: 233 | [:each | self writeMethod: each on: aStream]] 234 | ] 235 | 236 | writeClassMethodsOn: aStream [ 237 | 238 | printedClass class methodDictionary ifNotNil: 239 | [printedClass class methodDictionary values do: 240 | [:each | self writeClassMethod: each on: aStream]] 241 | ] 242 | 243 | sourceString [ 244 | 245 | | w is ns | 246 | w := WriteStream on: String new. 247 | is := IndentedStreamDecorator on: w. 248 | self enclosingNamespaces: is do: 249 | [self enclosingClassDefinition: is do: 250 | [self 251 | writeCommentsOn: is; 252 | writeInstVarsOn: is; 253 | writeClassVarsOn: is; 254 | writeClassMethodsOn: is; 255 | writeMethodsOn: is 256 | ]]. 257 | ^is contents. 258 | ] 259 | ] 260 | 261 | Object subclass: PrettyPrinter [ 262 | 263 | 264 | PrettyPrinter class >> prettifyMethod: aSourceString [ 265 | 266 | ^(MethodSource from: aSourceString) 267 | compact; 268 | stripIndent; 269 | indentWith: ' '; 270 | sourceString 271 | ] 272 | 273 | PrettyPrinter class >> prettifyClass: aClass [ 274 | 275 | ^(ClassSource of: aClass) 276 | sourceString 277 | ] 278 | 279 | PrettyPrinter class >> prettifyClasses: aCollectionOfClasses [ 280 | 281 | | prettified | 282 | prettified := aCollectionOfClasses collect: 283 | [:each | self prettifyClass: each]. 284 | 285 | ^String join: prettified 286 | ] 287 | ] 288 | 289 | Decorator subclass: IndentedStreamDecorator [ 290 | 291 | 292 | | state indentLevel levelSpaces | 293 | 294 | prepareIndent [ 295 | 296 | state := #preparingToIndent 297 | ] 298 | 299 | tryIndent [ 300 | 301 | self state = #preparingToIndent ifTrue: [self indent] 302 | ] 303 | 304 | increasingIndent: aBlock [ 305 | 306 | indentLevel := self indentLevel + 1. 307 | [aBlock value] ensure: 308 | [indentLevel := self indentLevel - 1] 309 | ] 310 | 311 | indent [ 312 | 313 | self indentLevel * self levelSpaces timesRepeat: 314 | [self underlyingObject space]. 315 | state := #indented 316 | ] 317 | 318 | nl [ 319 | 320 | self prepareIndent. 321 | self underlyingObject nl 322 | ] 323 | 324 | nextPut: anObject [ 325 | 326 | anObject = Character nl 327 | ifTrue: [self prepareIndent] 328 | ifFalse: [self tryIndent]. 329 | self underlyingObject nextPut: anObject. 330 | ] 331 | 332 | nextPutAll: aCollection [ 333 | 334 | aCollection do: [:each | self nextPut: each] 335 | ] 336 | 337 | state [ 338 | 339 | ^state ifNil: [state := #preparingToIndent] 340 | ] 341 | 342 | indentLevel [ 343 | 344 | ^indentLevel ifNil: [indentLevel := 0] 345 | ] 346 | 347 | levelSpaces [ 348 | 349 | ^levelSpaces ifNil: [levelSpaces := 4] 350 | ] 351 | ] 352 | ] 353 | -------------------------------------------------------------------------------- /server.st: -------------------------------------------------------------------------------- 1 | Namespace current: Shampoo [ 2 | 3 | Error subclass: ClientDisconnected [ 4 | 5 | 7 | ] 8 | 9 | Error subclass: FatalError [ 10 | 11 | 13 | ] 14 | 15 | Object subclass: ShampooTranscript [ 16 | 17 | 20 | 21 | servers := Set new. 22 | serversMutex := Semaphore forMutualExclusion. 23 | oldAssoc := nil. 24 | 25 | ShampooTranscript class >> initialize [ 26 | 27 | self install 28 | ] 29 | 30 | ShampooTranscript class >> message: aString [ 31 | 32 | self fallback: aString. 33 | serversMutex critical: [servers do: [:each | each echo: aString]] 34 | ] 35 | 36 | ShampooTranscript class >> fallback: aString [ 37 | 38 | oldAssoc ifNotNil: 39 | [oldAssoc key perform: oldAssoc value with: aString] 40 | ] 41 | 42 | ShampooTranscript class >> add: aServer [ 43 | 44 | serversMutex critical: [servers add: aServer] 45 | ] 46 | 47 | ShampooTranscript class >> remove: aServer [ 48 | 49 | serversMutex critical: 50 | [servers remove: aServer ifAbsent: []] 51 | ] 52 | 53 | ShampooTranscript class >> install [ 54 | 55 | | message | 56 | message := Transcript message. 57 | (message key = ShampooTranscript and: [message value = #message:]) 58 | ifFalse: [oldAssoc := message. 59 | Transcript message: (ShampooTranscript -> #message:)] 60 | ] 61 | ] 62 | 63 | Object subclass: ConnectionState [ 64 | 65 | 67 | 68 | | connection | 69 | 70 | ConnectionState class >> of: aConnection [ 71 | 72 | ^(self new) 73 | connection: aConnection; 74 | yourself 75 | ] 76 | 77 | connection: aConnection [ 78 | 79 | connection := aConnection 80 | ] 81 | 82 | switchTo: aConnectionStateClass [ 83 | 84 | connection state: (aConnectionStateClass of: connection) 85 | ] 86 | 87 | process: aRequest [ 88 | 89 | self subclassResponsibility 90 | ] 91 | 92 | echo: aString [ 93 | 94 | "Do nothing by default. 'self subclassResponsibility' would be better?" 95 | ] 96 | ] 97 | 98 | ConnectionState subclass: NotAuthorizedState [ 99 | 100 | 103 | | magic | 104 | 105 | register [ 106 | 107 | "Send a magic number to a client" 108 | connection send: (MagicResponse number: self magic) 109 | ] 110 | 111 | process: aRequest [ 112 | 113 | "Anti-If campaign probably hates me." 114 | aRequest class == LoginRequest 115 | ifTrue: [^self checkLogin: aRequest] 116 | ifFalse: [FatalError new signal] 117 | ] 118 | 119 | checkLogin: aRequest [ 120 | 121 | "Really hates." 122 | (connection server authenticates: aRequest creds with: self magic) 123 | ifTrue: [self switchTo: AuthorizedState. 124 | ^ServerInfoResponse id: aRequest id] 125 | ifFalse: [FatalError new signal] 126 | ] 127 | 128 | magic [ 129 | 130 | ^magic ifNil: [magic := Random between: 0 and: 16rFFFF] 131 | ] 132 | ] 133 | 134 | ConnectionState subclass: AuthorizedState [ 135 | 136 | 139 | 140 | process: aRequest [ 141 | 142 | ^aRequest execute 143 | ] 144 | 145 | echo: aString [ 146 | 147 | connection send: (EchoResponse id: -1 text: aString) 148 | ] 149 | ] 150 | 151 | Object subclass: ProcessObject [ 152 | 153 | 156 | 157 | | process | 158 | 159 | proc: aProcess [ 160 | 161 | process := aProcess 162 | ] 163 | 164 | suspend [ 165 | 166 | process ifNotNil: [process suspend] 167 | ] 168 | 169 | resume [ 170 | 171 | process ifNotNil: [process resume] 172 | ] 173 | ] 174 | 175 | Object subclass: ClientConnection [ 176 | 177 | 179 | 180 | | sock server disconnectedHandler state parser | 181 | 182 | ClientConnection class >> on: aSocket onDisconnect: aBlock parent: aServer [ 183 | 184 | ^aSocket 185 | ifNil: [nil] 186 | ifNotNil: [self new on: aSocket onDisconnect: aBlock parent: aServer] 187 | ] 188 | 189 | on: aSocket onDisconnect: aBlock parent: aServer [ 190 | 191 | sock := aSocket. 192 | server := aServer. 193 | disconnectedHandler := aBlock. 194 | state := NotAuthorizedState of: self. 195 | state register. 196 | parser := MessageParser new. 197 | ] 198 | 199 | go [ 200 | 201 | [sock isPeerAlive] whileTrue: 202 | [[self fetchMessages do: [:m | self process: m]] 203 | on: ClientDisconnected 204 | do: [:e | ^self signalDisconnected]]. 205 | self signalDisconnected 206 | ] 207 | 208 | fetchMessages [ 209 | 210 | [sock ensureReadable] ifError: [ClientDisconnected new signal]. 211 | ^parser process: (sock next: sock availableBytes) 212 | ] 213 | 214 | signalDisconnected [ 215 | 216 | disconnectedHandler ifNotNil: [:handler | handler value: self] 217 | ] 218 | 219 | process: anXMLRequest [ 220 | 221 | | r xml | 222 | [xml := ShampooXML.ShNode from: anXMLRequest] 223 | ifError: 224 | [^server inform: 225 | 'Shampoo: failed to parse ', anXMLRequest printString]. 226 | r := Request from: xml. 227 | [(self state process: r) do: [:resp | self send: resp]] 228 | on: FatalError do: [:e | self close] 229 | ] 230 | 231 | state: aClientConnectionState [ 232 | 233 | state := aClientConnectionState 234 | ] 235 | 236 | state [ 237 | 238 | ^state 239 | ] 240 | 241 | echo: aString [ 242 | 243 | self state echo: aString 244 | ] 245 | 246 | send: aPacket [ 247 | 248 | | msg | 249 | msg := aPacket asXML printString. 250 | sock 251 | nextPutAll: 'Content-Length: ', msg size printString; 252 | crlf; 253 | crlf; 254 | nextPutAll: msg; 255 | crlf. 256 | sock flush 257 | ] 258 | 259 | close [ 260 | 261 | sock close 262 | ] 263 | 264 | server [ 265 | 266 | ^server 267 | ] 268 | ] 269 | 270 | ProcessObject subclass: ShampooServer [ 271 | 272 | 274 | 275 | | server clients clientsMutex creds | 276 | 277 | servers := Dictionary new. 278 | serversMutex := Semaphore forMutualExclusion. 279 | 280 | clients [ 281 | 282 | ^clients ifNil: [clients := OrderedCollection new] 283 | ] 284 | 285 | acceptedClient [ 286 | 287 | | client | 288 | client := ClientConnection 289 | on: server accept 290 | onDisconnect: [:cl | self handleDisconnected: cl] 291 | parent: self. 292 | ^client 293 | ] 294 | 295 | authenticates: aCreds with: aMagic [ 296 | 297 | ^(creds with: aMagic) = aCreds 298 | ] 299 | 300 | handleDisconnected: aClient [ 301 | 302 | "This method is delegated to a client session in a block" 303 | clientsMutex critical: [self clients remove: aClient] 304 | ] 305 | 306 | startOn: aPort creds: aCreds [ 307 | 308 | clientsMutex := Semaphore forMutualExclusion. 309 | server := TCP.ServerSocket port: aPort. 310 | creds := aCreds. 311 | 312 | ShampooTranscript add: self. 313 | 314 | [server isOpen] whileTrue: 315 | [| conn | 316 | [server waitForConnection] 317 | ifError: [^self inform: 318 | 'Shampoo: failed to listen for incoming connections']. 319 | conn := self acceptedClient. 320 | conn ifNotNil: 321 | [clientsMutex critical: [self clients add: conn]. 322 | [conn go] fork]] 323 | ] 324 | 325 | echo: aString [ 326 | 327 | clientsMutex critical: 328 | [self clients do: [:each | each echo: aString]] 329 | ] 330 | 331 | ShampooServer class >> startOn: aPort login: aLogin pass: aPass [ 332 | 333 | ^self startOn: aPort creds: (AuthInfo login: aLogin pass: aPass) 334 | ] 335 | 336 | ShampooServer class >> closeAll [ 337 | 338 | serversMutex critical: 339 | [servers values do: [:each | each close]. 340 | servers empty] 341 | ] 342 | 343 | ShampooServer class >> closeOn: aPort [ 344 | 345 | serversMutex critical: 346 | [| srv | 347 | srv := servers at: aPort ifAbsent: [^nil]. 348 | servers removeKey: aPort. 349 | srv close] 350 | ] 351 | 352 | ShampooServer class >> startOn: aPort creds: aCreds [ 353 | 354 | serversMutex critical: 355 | [(servers includesKey: aPort) ifFalse: 356 | [| srv | 357 | srv := self new. 358 | servers at: aPort put: srv. 359 | srv proc: [srv startOn: aPort creds: aCreds] fork]] 360 | ] 361 | 362 | ShampooServer class >> update: aspect [ 363 | 364 | aspect == #aboutToSnapshot ifTrue: [^self broadcast: #suspend ]. 365 | aspect == #finishedSnapshot ifTrue: [^self broadcast: #resume ]. 366 | aspect == #returnFromSnapshot ifTrue: [^self broadcast: #restart ]. 367 | ] 368 | 369 | ShampooServer class >> initialize [ 370 | 371 | ObjectMemory addDependent: self 372 | ] 373 | 374 | ShampooServer class >> broadcast: aMessage [ 375 | 376 | serversMutex critical: 377 | [servers values do: [:srv | srv perform: aMessage]] 378 | ] 379 | 380 | suspend [ 381 | 382 | self closeConnections. 383 | super suspend. 384 | ] 385 | 386 | restart [ 387 | 388 | self close. 389 | self proc: [self startOn: server port creds: creds] fork. 390 | ] 391 | 392 | closeConnections [ 393 | 394 | clientsMutex critical: 395 | [self clients copy do: [:cl | cl close]]. 396 | "And that's all. Every client connection 397 | will be removed from the set in the 398 | ShampooServer>>handleDisconnected:." 399 | ] 400 | 401 | close [ 402 | 403 | [server close] ifError: []. 404 | self closeConnections. 405 | ShampooTranscript remove: self 406 | ] 407 | 408 | inform: aMessage [ 409 | 410 | ShampooTranscript fallback: aMessage. 411 | ^nil 412 | ] 413 | ] 414 | ] 415 | 416 | Eval [ 417 | Shampoo.ShampooTranscript initialize. 418 | Shampoo.ShampooServer initialize. 419 | ] 420 | -------------------------------------------------------------------------------- /responses.st: -------------------------------------------------------------------------------- 1 | Namespace current: Shampoo [ 2 | 3 | Object subclass: Response [ 4 | 5 | 8 | 9 | | id | 10 | 11 | Response class >> id: anInteger [ 12 | 13 | ^(self new) 14 | id: anInteger; 15 | yourself 16 | ] 17 | 18 | id: anInteger [ 19 | 20 | id := anInteger 21 | ] 22 | 23 | type [ 24 | 25 | ^self shouldNotImplement 26 | ] 27 | 28 | do: aBlock [ 29 | "Evaluate a one-argument block, pass self to it. 30 | This method is actually a kludge and it will be probably 31 | removed later" 32 | 33 | 34 | ^aBlock value: self 35 | ] 36 | 37 | asXML [ 38 | 39 | ^(ShampooXML.ShNode tagname: 'response') 40 | addAttribute: 'id' value: id asString; 41 | addAttribute: 'type' value: self type; 42 | yourself 43 | ] 44 | ] 45 | 46 | Response subclass: ServerInfoResponse [ 47 | 48 | 50 | 51 | type [ 52 | 53 | ^'Info' 54 | ] 55 | 56 | asXML [ 57 | 58 | ^(super asXML) 59 | addNode: (ShampooXML.ShText text: Smalltalk version); 60 | yourself 61 | ] 62 | ] 63 | 64 | Response subclass: OperationalResponse [ 65 | 66 | 68 | 69 | | success message | 70 | 71 | OperationalResponse class >> success: anInteger [ 72 | 73 | ^(OperationalResponse id: anInteger) 74 | success: true; 75 | yourself 76 | ] 77 | 78 | OperationalResponse class >> failure: anInteger [ 79 | 80 | ^(OperationalResponse id: anInteger) 81 | success: false; 82 | yourself 83 | ] 84 | 85 | OperationalResponse class >> failure: anInteger with: anError [ 86 | 87 | ^self failure: anInteger text: anError messageText 88 | ] 89 | 90 | OperationalResponse class >> failure: anInteger text: aString [ 91 | 92 | ^(OperationalResponse id: anInteger) 93 | success: false; 94 | message: aString; 95 | yourself 96 | ] 97 | 98 | statusString [ 99 | 100 | ^success ifTrue: ['success'] ifFalse: ['failure'] 101 | ] 102 | 103 | success: aBoolean [ 104 | 105 | success := aBoolean 106 | ] 107 | 108 | message: aString [ 109 | 110 | message := aString 111 | ] 112 | 113 | type [ 114 | 115 | ^'OperationalResponse' 116 | ] 117 | 118 | asXML [ 119 | 120 | | r | 121 | r := super asXML. 122 | r addAttribute: 'status' value: self statusString. 123 | message ifNotNil: 124 | [r addNode: (ShampooXML.ShText text: message)]. 125 | ^r 126 | ] 127 | ] 128 | 129 | Decorator subclass: CollectionResponseDecorator [ 130 | 131 | 137 | 138 | | items | 139 | 140 | items [ 141 | 142 | ^items ifNil: [items := Dictionary new] 143 | ] 144 | 145 | itemsAt: itemTypeString put: anArray [ 146 | 147 | self items at: itemTypeString put: anArray copy 148 | ] 149 | 150 | asXML [ 151 | 152 | | root | 153 | root := self underlyingObject asXML. 154 | 155 | self items keysAndValuesDo: 156 | [:key :values | values do: [:each | 157 | root addNode: ((ShampooXML.ShNode tagname: key asString) 158 | addNode: (ShampooXML.ShText text: each); 159 | yourself)]]. 160 | 161 | ^root 162 | ] 163 | 164 | do: aBlock [ 165 | "CollectionResponseDecorator usually wraps Response objects. 166 | Response objects partly understand the collection protocol, 167 | especially a #do: message. This wrapper does not proxy this 168 | message to the underlying object." 169 | 170 | ^aBlock value: self 171 | ] 172 | ] 173 | 174 | Response subclass: NamespacesResponse [ 175 | 176 | 177 | 178 | NamespacesResponse class >> id: anInteger names: anArray [ 179 | 180 | ^(CollectionResponseDecorator on: (self id: anInteger)) 181 | itemsAt: 'namespace' put: anArray; 182 | yourself 183 | ] 184 | 185 | type [ 186 | 187 | ^'Namespaces' 188 | ] 189 | ] 190 | 191 | Response subclass: ClassesResponse [ 192 | 193 | 195 | 196 | ClassesResponse class >> id: anInteger names: anArray [ 197 | 198 | ^(CollectionResponseDecorator on: (self id: anInteger)) 199 | itemsAt: 'class' put: anArray; 200 | yourself 201 | ] 202 | 203 | type [ 204 | 205 | ^'Classes' 206 | ] 207 | ] 208 | 209 | Response subclass: ClassInfoResponse [ 210 | 211 | 213 | 214 | | class attrs | 215 | 216 | ClassInfoResponse class >> id: anInteger class: aClass [ 217 | 218 | ^self id: anInteger class: aClass attrs: nil 219 | ] 220 | 221 | ClassInfoResponse class >> id: anInteger class: aClass attrs: anArray [ 222 | 223 | ^(self id: anInteger) 224 | class: aClass attrs: anArray 225 | yourself 226 | ] 227 | 228 | class: aClass attrs: anArray [ 229 | 230 | class := aClass. 231 | anArray isNil ifFalse: [attrs := Dictionary from: anArray]. 232 | ] 233 | 234 | asXML [ 235 | 236 | | r | 237 | r := super asXML. 238 | r addAttribute: 'class' value: class. 239 | attrs ifNotNil: 240 | [:dict | 241 | dict keysAndValuesDo: 242 | [:key :value | r addAttribute: key value: value]]. 243 | ^r 244 | ] 245 | ] 246 | 247 | ClassInfoResponse subclass: ClassResponse [ 248 | 249 | 250 | 251 | ClassResponse class >> 252 | id: anInteger class: aClass superclass: aSuperClass 253 | instvars: anInstVars classvars: aClassVars poolvars: aPoolDicts 254 | category: aString [ 255 | 256 | | obj | 257 | obj := self 258 | id: anInteger 259 | class: aClass 260 | attrs: {'superclass' -> aSuperClass. 261 | 'category' -> aString}. 262 | ^(CollectionResponseDecorator on: obj) 263 | itemsAt: 'instvar' put: anInstVars; 264 | itemsAt: 'classvar' put: aClassVars; 265 | itemsAt: 'poolvar' put: aPoolDicts; 266 | yourself 267 | ] 268 | 269 | type [ 270 | 271 | ^'Class' 272 | ] 273 | ] 274 | 275 | ClassInfoResponse subclass: MethodCategoriesResponse [ 276 | 277 | 278 | 279 | MethodCategoriesResponse class >> id: anInteger class: aClass categories: anArray [ 280 | 281 | ^(CollectionResponseDecorator on: (self id: anInteger class: aClass)) 282 | itemsAt: 'category' put: anArray; 283 | yourself 284 | ] 285 | 286 | type [ 287 | 288 | ^'Categories' 289 | ] 290 | ] 291 | 292 | ClassInfoResponse subclass: MethodsResponse [ 293 | 294 | 296 | 297 | MethodsResponse class >> id: anInteger class: aClass methods: anArray [ 298 | 299 | ^(CollectionResponseDecorator on: (self id: anInteger class: aClass)) 300 | itemsAt: 'method' put: anArray; 301 | yourself 302 | ] 303 | 304 | type [ 305 | 306 | ^'Methods' 307 | ] 308 | ] 309 | 310 | ClassInfoResponse subclass: MethodResponse [ 311 | 312 | 314 | 315 | | methodName methodSource | 316 | 317 | MethodResponse class >> id: anInteger class: aClass method: aNameString source: aSourceString [ 318 | 319 | ^(self id: anInteger class: aClass) 320 | method: aNameString methodSource: aSourceString; 321 | yourself 322 | ] 323 | 324 | method: aNameString methodSource: aSourceString [ 325 | 326 | methodName := aNameString. 327 | methodSource := PrettyPrinter prettifyMethod: aSourceString 328 | ] 329 | 330 | type [ 331 | 332 | ^'MethodSource' 333 | ] 334 | 335 | asXML [ 336 | 337 | ^(super asXML) 338 | addAttribute: 'method' value: methodName; 339 | addNode: (ShampooXML.ShText text: methodSource); 340 | yourself 341 | ] 342 | ] 343 | 344 | Response subclass: PrintItResponse [ 345 | 346 | 347 | 348 | | value | 349 | 350 | PrintItResponse class >> id: anInteger value: anObject [ 351 | 352 | ^(self id: anInteger) 353 | value: anObject; 354 | yourself 355 | ] 356 | 357 | value: anObject [ 358 | 359 | value := anObject 360 | ] 361 | 362 | value [ 363 | 364 | ^value 365 | ] 366 | 367 | type [ 368 | 369 | ^'PrintIt' 370 | ] 371 | 372 | asXML [ 373 | 374 | ^(super asXML) 375 | addNode: (ShampooXML.ShText text: value printString); 376 | yourself 377 | ] 378 | ] 379 | 380 | Response subclass: EchoResponse [ 381 | 382 | 385 | 386 | | text | 387 | 388 | EchoResponse class >> id: anInteger text: aString [ 389 | 390 | ^(self id: anInteger) 391 | text: aString; 392 | yourself 393 | ] 394 | 395 | text: aString [ 396 | 397 | text := aString 398 | ] 399 | 400 | type [ 401 | 402 | ^'Echo' 403 | ] 404 | 405 | asXML [ 406 | 407 | ^(super asXML) 408 | addNode: (ShampooXML.ShText text: text); 409 | yourself 410 | ] 411 | ] 412 | 413 | Response subclass: MagicResponse [ 414 | 415 | 418 | 419 | | number | 420 | 421 | MagicResponse class >> number: anInteger [ 422 | 423 | ^(self id: 0) 424 | number: anInteger; 425 | yourself 426 | ] 427 | 428 | number: anInteger [ 429 | 430 | number := anInteger 431 | ] 432 | 433 | type [ 434 | 435 | ^'Magic' 436 | ] 437 | 438 | asXML [ 439 | 440 | ^(super asXML) 441 | addNode: (ShampooXML.ShText text: number printString); 442 | yourself 443 | ] 444 | ] 445 | 446 | Response subclass: FileOutResponse [ 447 | | isLast xml | 448 | 449 | FileOutResponse class >> 450 | id: anInteger class: aClassName source: aString [ 451 | 452 | ^(self id: anInteger) 453 | class: aClassName source: aString; 454 | yourself 455 | ] 456 | 457 | FileOutResponse class >> 458 | id: anInteger category: aCategory source: aString [ 459 | 460 | ^(self id: anInteger) 461 | category: aCategory source: aString; 462 | yourself 463 | ] 464 | 465 | class: aClassName source: aString [ 466 | 467 | xml := super asXML. 468 | xml addAttribute: 'class' value: aClassName; 469 | addNode: (ShampooXML.ShText text: aString) 470 | ] 471 | 472 | category: aCategory source: aString [ 473 | 474 | xml := super asXML. 475 | xml addAttribute: 'category' value: aCategory; 476 | addNode: (ShampooXML.ShText text: aString) 477 | ] 478 | 479 | isLast [ 480 | 481 | ^isLast ifNil: [isLast := false] 482 | ] 483 | 484 | isLast: aBoolean [ 485 | 486 | isLast := aBoolean 487 | ] 488 | 489 | type [ 490 | 491 | ^'FileOut' 492 | ] 493 | 494 | asXML [ 495 | 496 | | r | 497 | r := xml copy. 498 | self isLast ifTrue: 499 | [r addAttribute: 'last' value: 'true']. 500 | ^r 501 | ] 502 | ] 503 | ] 504 | -------------------------------------------------------------------------------- /docs/xml-protocol.org: -------------------------------------------------------------------------------- 1 | #+TITLE Shampoo XML protocol description 2 | 3 | | Date | Author | Whats changed | 4 | |-------------+----------------+---------------------------------------------------------------------| 5 | | 11 Dec 2010 | Dmitry Matveev | Original version | 6 | | 21 Apr 2011 | Dmitry Matveev | A critical fix in protocol | 7 | | 23 Apr 2011 | Dmitry Matveev | Added "namespace" parameter to all class-related requests | 8 | | | | Added "super" and "superspace" parameters to "CompileClass" request | 9 | | 25 Apr 2011 | Dmitry Matveev | Added "classvar" and "poolvar" subnodes to "Class"/"CompileClass" | 10 | | 27 Apr 2011 | Dmitry Matveev | New format for aggregated responses and requests, etc | 11 | | 13 May 2011 | Dmitry Matveev | Added "superclass" attribute to "Class" response | 12 | | 28 May 2011 | Dmitry Matveev | Added "side" attribute to "Class" request | 13 | | 01 Jun 2011 | Dmitry Matveev | Added "side" attribute to "CompileClass" request + details | 14 | | 09 Jun 2011 | Dmitry Matveev | Authorization & server info requests/responses | 15 | | 12 Jun 2011 | Dmitry Matveev | Added '*' support for Method request | 16 | | 24 Sep 2011 | Dmitry Matveev | Added a section about authentication mechanism | 17 | | 23 Oct 2012 | Dmitry Matveev | Added a note about the "Content-Length:" header | 18 | | | | Added "RemoveClass" and "RemoveMethod" messages | 19 | | 25 Oct 2012 | Dmitry Matveev | More on categories (changes in "CompileMethod" request, added | 20 | | | | "ChangeCategory" and "RemoveCategory" requests | 21 | | 28 Oct 2012 | Dmitry Matveev | Added "RenameCategory" request | 22 | | 09 Nov 2012 | Dmitry Matveev | Added "FileOut" request and response | 23 | | 13 Nov 2012 | Dmitry Matveev | Added "category" option to "CompileClass" request and "Class" | 24 | | | | response | 25 | 26 | * Overview 27 | 28 | Shampoo-XML is a protocol for remote Smalltalk image control & development. It 29 | provides a set of commands that allow to... 30 | - get a list of namespaces; 31 | - get a list of classes in namespace; 32 | - get a list of methods in class (instance side or class side); 33 | - register a new class with the supplied description (comment, instance/class 34 | variable names, etc); 35 | - remove a class; 36 | - get a source string of a concrete method in a concrete class; 37 | - compile a supplied source string for a concrete method in a concrete class; 38 | - evaluate an expression and to get the result. 39 | 40 | Shampoo is functioning in a request/response scheme. Client sends a request to 41 | the server and server replies with a response. There are some messages that can 42 | be sent by a server outside of this scheme, i.e. without an appropriate request. 43 | Also, a single request can cause multiple responses. 44 | 45 | * Authentication 46 | 47 | Authentication is mandatory. Shampoo does not allow to request info about/modify 48 | the image without an authentication. 49 | 50 | Currently Shampoo uses the classical Pre-Shared Key (PSK) scheme. It means that 51 | an authentication key (a login/password pair) is pre-configured on the server side. 52 | 53 | When a client connects to the Shampoo server, the server first sends an *Magic* 54 | message to the client. This message contains a random session-local magic string 55 | (usually a number). Client has to: 56 | 1. Calculate an MD5 checksum of the user's password; 57 | 2. Concatenate the magic string with the checksum; 58 | 3. Calculate an MD5 checksum of this concatenation; 59 | 4. Send it back to the server as well with the login in the *Login* message. 60 | 61 | Why do we have step 1? Because server does not store the password in the plain 62 | text form, it stores only an MD5 checksum too. 63 | 64 | 65 | * Basics 66 | 67 | ** Message structure 68 | 69 | Every message sent from or to Shampoo begins a line: 70 | #+BEGIN_EXAMPLE 71 | Content-Length: XXXX 72 | #+END_EXAMPLE 73 | where XXXX is the length of the message payload. The line is followed with 74 | "\r\n\r\n" characters (i.e. two CRLFs). Then there is the payload data, XXXX bytes 75 | long, followed by CRLF. 76 | 77 | ** Request structure 78 | 79 | #+BEGIN_EXAMPLE 80 | 84 | <...> (3) 85 | 86 | #+END_EXAMPLE 87 | 88 | OR 89 | 90 | #+BEGIN_EXAMPLE 91 | 92 | #+END_EXAMPLE 93 | 94 | ID (1) is a numeric value showing the number of the request in the sequence. When 95 | client sends a request with some ID, server should respond with a response of the 96 | same ID. 97 | 98 | TYPE (2) identifies a type of a message (see *Requests*). TYPE determines what 99 | will be included into the body of a request (3). 100 | 101 | ** Response structure 102 | 103 | #+BEGIN_EXAMPLE 104 | 108 | <...> (3) 109 | 110 | #+END_EXAMPLE 111 | 112 | OR 113 | 114 | #+BEGIN_EXAMPLE 115 | 116 | #+END_EXAMPLE 117 | 118 | The response structure is similar to a request structure. Response ID (1) must 119 | always match the appropriate request ID, and the response body (3) is determined 120 | by response type (2). 121 | 122 | 123 | * Requests 124 | 125 | ** Login 126 | 127 | *** Description 128 | Provide credentials to server for authorization. 129 | 130 | *** Syntax 131 | 132 | #+BEGIN_EXAMPLE 133 | 134 | 135 | 136 | #+END_EXAMPLE 137 | 138 | Magic field is described in the *Authentication* section. 139 | 140 | *** Response 141 | In the case of successful authorization server will reply with *Info* response. 142 | The connection will be closed otherwise. 143 | 144 | ** Namespaces 145 | 146 | *** Description 147 | Ask server to send us a list of all the available namespaces in the image 148 | 149 | *** Syntax 150 | 151 | #+BEGIN_EXAMPLE 152 | 153 | #+END_EXAMPLE 154 | 155 | *** Response 156 | See *Namespaces* 157 | 158 | ** Classes 159 | 160 | *** Description 161 | Ask server to send us a list of all the classes in the concrete namespace 162 | 163 | *** Syntax 164 | 165 | #+BEGIN_EXAMPLE 166 | 167 | #+END_EXAMPLE 168 | 169 | *** Response 170 | See *Classes* 171 | 172 | ** Class 173 | 174 | *** Description 175 | Ask server to send us a class description from a concrete namespace 176 | 177 | *** Syntax 178 | 179 | #+BEGIN_EXAMPLE 180 | 181 | #+END_EXAMPLE 182 | 183 | SIDE option can have two possible values: 184 | - "instance" - request for instance-side class information 185 | - "class" - the same for the class side. 186 | 187 | *** Response 188 | See *Class* 189 | 190 | ** Categories 191 | 192 | *** Description 193 | Ask server to send us a list of all the method categories in the concrete class 194 | 195 | *** Syntax 196 | 197 | #+BEGIN_EXAMPLE 198 | 204 | #+END_EXAMPLE 205 | 206 | SIDE option may have two possible values: 207 | - "instance" - enumerate categories for the instance-side methods of a class; 208 | - "class" - the same for the class side. 209 | 210 | *** Response 211 | See *Categories* 212 | 213 | ** Methods 214 | 215 | *** Description 216 | Ask server to send us a list of all the methods of the concrete category in the 217 | concrete class. 218 | 219 | *** Syntax 220 | 221 | #+BEGIN_EXAMPLE 222 | 229 | #+END_EXAMPLE 230 | 231 | SIDE option may have two possible values: 232 | - "instance" - enumerate categories for the instance-side methods of a class; 233 | - "class" - the same for the class side. 234 | 235 | CATEGORY option value should exist in the list of categories obtained from 236 | Categories message. CATEGORY also may be '*', in this case server should return 237 | all the available methods. 238 | 239 | *** Response 240 | See *Methods* 241 | 242 | ** MethodSource 243 | 244 | *** Description 245 | Ask server to send us a source code stirng for a specified method. Method should exist 246 | in the class. 247 | 248 | *** Syntax 249 | 250 | #+BEGIN_EXAMPLE 251 | 259 | #+END_EXAMPLE 260 | 261 | *** Response 262 | See *MethodSource* 263 | 264 | ** CompileClass 265 | 266 | *** Description 267 | Compile a new class. Or recompile it, if the class is already exist. 268 | 269 | *** Syntax 270 | 271 | #+BEGIN_EXAMPLE 272 | 279 | one 280 | two 281 | three 282 | classOne 283 | classTwo 284 | classThree 285 | poolOne 286 | poolTwo 287 | poolThree 288 | 289 | #+END_EXAMPLE 290 | 291 | Instance variables must be registered in the class in the order specified by 292 | message. 293 | 294 | A class side can also be "compiled", but it is actually a modification, not a 295 | creation of a new class. So some parameters should be omitted in this case: 296 | 297 | #+BEGIN_EXAMPLE 298 | 299 | one 300 | two 301 | three 302 | 303 | #+END_EXAMPLE 304 | 305 | The side argument is optional, if not specified, the request will be considered 306 | as an "instance" one. 307 | 308 | *** Response 309 | See *OperationalResoponse* 310 | 311 | ** CompileMethod 312 | 313 | *** Description 314 | Ask server to compile a string of code to the specified class. 315 | 316 | *** Syntax 317 | 318 | #+BEGIN_EXAMPLE 319 | 326 | sampleCompare: anInteger with: anotherInteger [ 327 | ^ anInteger > anotherInteger 328 | ] 329 | 330 | #+END_EXAMPLE 331 | 332 | To preserve XML parser from going crazy, all suspicious symbols (such as &, >, < 333 | and others) must be escaped before sending (to & < > etc). 334 | 335 | CATEGORY parameter specifies the method's category. If a method has no category, 336 | the CATEGORY value is set to "*". 337 | 338 | In GNU Smalltalk, the method's category can be specified in the method's source using 339 | the pragma. Actually, it is the only way to specify the method's category 340 | with the 3.x syntax. If the method source contains a pragma and its value 341 | differs from the CATEGORY value, the pragma's value will be used. 342 | 343 | *** Response 344 | See *OperationalResponse* 345 | 346 | ** ChangeCategory 347 | 348 | *** Description 349 | Change the category of the selected method. 350 | 351 | *** Syntax 352 | 353 | #+BEGIN_EXAMPLE 354 | 363 | #+END_EXAMPLE 364 | 365 | *** Response 366 | See *OperationalResponse* 367 | 368 | ** RenameCategory 369 | 370 | *** Description 371 | Rename a category in the class. 372 | 373 | *** Syntax 374 | 375 | #+BEGIN_EXAMPLE 376 | 385 | #+END_EXAMPLE 386 | 387 | *** Response 388 | See *OperationalResponse* 389 | 390 | ** RemoveCategory 391 | 392 | *** Description 393 | Remove the specified category, mark all methods belonging to the category as 394 | 'uncategorized'. 395 | 396 | *** Syntax 397 | 398 | #+BEGIN_EXAMPLE 399 | 407 | #+END_EXAMPLE 408 | 409 | *** Response 410 | See *OperationalResponse* 411 | 412 | ** RemoveClass 413 | 414 | *** Description 415 | Unregister the specified class from the system. 416 | 417 | *** Syntax 418 | 419 | #+BEGIN_EXAMPLE 420 | 421 | 422 | 423 | #+END_EXAMPLE 424 | 425 | *** Response 426 | See *OperationalResponse* 427 | 428 | ** RemoveMethod 429 | 430 | *** Description 431 | Remove a method from a class. 432 | 433 | *** Syntax 434 | 435 | #+BEGIN_EXAMPLE 436 | 444 | #+END_EXAMPLE 445 | 446 | *** Response 447 | See *OperationalResponse* 448 | 449 | ** DoIt 450 | 451 | *** Description 452 | Ask server to evaluate an expression. 453 | 454 | *** Syntax 455 | 456 | #+BEGIN_EXAMPLE 457 | 458 | Transcript show: 'Hello world' 459 | 460 | #+END_EXAMPLE 461 | 462 | *** Response 463 | See *OperationalResponse* 464 | 465 | ** PrintIt 466 | 467 | *** Description 468 | Ask server to evaluate an expression and to send the result back to us. 469 | 470 | *** Syntax 471 | 472 | #+BEGIN_EXAMPLE 473 | 474 | Transcript show: 'Hello world' 475 | 476 | #+END_EXAMPLE 477 | 478 | *** Response 479 | See *PrintIt* 480 | 481 | ** FileOut 482 | 483 | *** Description 484 | Ask server to send a complete source for a class, classes in a category, or classes in a namespace. 485 | 486 | *** Syntax 487 | 488 | File out a particular class: 489 | 490 | #+BEGIN_EXAMPLE 491 | 495 | #+END_EXAMPLE 496 | 497 | File out all classes of a particular category from a namespace: 498 | 499 | #+BEGIN_EXAMPLE 500 | 505 | #+END_EXAMPLE 506 | 507 | File out all classes from a namespace: 508 | 509 | #+BEGIN_EXAMPLE 510 | 514 | #+END_EXAMPLE 515 | 516 | If request have both CLASS and CATEGORY options, a class fileout case will be performed. 517 | 518 | SPLITBY option determines how the fileout will be splitted. It can have two possible values: 519 | - category -- group sources by class categories, send a separate source file for each category. 520 | - class -- send a separate source file for each exported class. 521 | 522 | SPLITBY option has no effect for a CLASS option case. 523 | 524 | *** Response 525 | See *FileOut* 526 | 527 | * Responses 528 | 529 | ** OperationalResponse 530 | 531 | *** Description 532 | OperationalResponse is a generic response from a server that indicates success or failure. 533 | 534 | *** Syntax 535 | 536 | #+BEGIN_EXAMPLE 537 | 538 | #+END_EXAMPLE 539 | 540 | STATUS can be "success" or "failure". In the case of failure, an OperationalResponse may also 541 | contain a textual description of the error occured: 542 | 543 | #+BEGIN_EXAMPLE 544 | 545 | An exceptional condition has occurred, and has prevented normal 546 | continuation of processing. 547 | 548 | #+END_EXAMPLE 549 | 550 | ** Namespaces 551 | 552 | *** Description 553 | The list of all available namespaces. 554 | 555 | *** Syntax 556 | 557 | #+BEGIN_EXAMPLE 558 | 559 | CSymbols 560 | Kernel 561 | ... 562 | 563 | #+END_EXAMPLE 564 | 565 | *** TODO subspaces 566 | 567 | ** Classes 568 | 569 | *** Description 570 | The list of all available classes in the namespace. 571 | 572 | *** Syntax 573 | 574 | #+BEGIN_EXAMPLE 575 | 576 | Object 577 | SmallInteger 578 | ... 579 | 580 | #+END_EXAMPLE 581 | 582 | ** Class 583 | 584 | *** Description 585 | A class description. 586 | 587 | *** Syntax 588 | 589 | #+BEGIN_EXAMPLE 590 | 594 | one 595 | two 596 | three 597 | classOne 598 | classTwo 599 | classThree 600 | poolOne 601 | poolTwo 602 | poolThree 603 | 604 | #+END_EXAMPLE 605 | 606 | Almost exactly matches CompileClass request. 607 | 608 | ** Categories 609 | 610 | *** Description 611 | The list of all available categories for a concrete class. 612 | 613 | *** Syntax 614 | 615 | #+BEGIN_EXAMPLE 616 | 617 | private 618 | accessors 619 | ... 620 | 621 | #+END_EXAMPLE 622 | 623 | ** Methods 624 | 625 | *** Description 626 | The list of all available methods in a concrete category for a concrete class. 627 | 628 | *** Syntax 629 | 630 | #+BEGIN_EXAMPLE 631 | 632 | do: 633 | inject:into: 634 | ... 635 | 636 | #+END_EXAMPLE 637 | 638 | ** MethodSource 639 | 640 | *** Description 641 | A source string for a concrete method in a concrete class. 642 | 643 | *** Syntax 644 | 645 | #+BEGIN_EXAMPLE 646 | 647 | someMethod [ 648 | ^100 factorial 649 | ] 650 | 651 | #+END_EXAMPLE 652 | 653 | As for CompileMethod request, to preserve XML parser from being broken, all 654 | suspicious symbols (such as &, >, < and others) must be escaped before 655 | sending (to & < > etc). 656 | 657 | ** Info 658 | 659 | *** Description 660 | A string with server information. The information contents is backend-dependent, but 661 | usually it is an image/system version. 662 | 663 | *** Syntax 664 | 665 | #+BEGIN_EXAMPLE 666 | 667 | GNU Smalltalk version 3.2.3-4f40165 668 | 669 | #+END_EXAMPLE 670 | 671 | ** Echo 672 | 673 | *** Description 674 | This message contains an output that is being printed on the Transcript. These 675 | notifications are sent to all the connected clients, not only to the one that 676 | has initiated the printing. 677 | 678 | *** Syntax 679 | 680 | #+BEGIN_EXAMPLE 681 | 682 | Some text here 683 | 684 | #+END_EXAMPLE 685 | 686 | ** PrintIt 687 | 688 | *** Description 689 | This message contains an output of an expression evaluation. 690 | 691 | *** Syntax 692 | 693 | #+BEGIN_EXAMPLE 694 | 695 | Some text here 696 | 697 | #+END_EXAMPLE 698 | 699 | ** FileOut 700 | 701 | *** Description 702 | FileOut message contains a source code exported from the system. A single message 703 | may contain multiple classes inside, depending on the parameters of the request. 704 | 705 | The response's source code must be ready for saving to disk as is, i.e. it 706 | should not require any client post-processing. 707 | 708 | A single FileOut request can produce multiple FileOut responses with the same id. 709 | The last FileOut response it the sequence will contain a special mark. 710 | 711 | *** Syntax 712 | 713 | Sample response for a request with SPLITBY option "category": 714 | 715 | #+BEGIN_EXAMPLE 716 | 717 | (Source code of all classes in a category) 718 | 719 | #+END_EXAMPLE 720 | 721 | Sample response for a request with SPLITBY option "class": 722 | 723 | #+BEGIN_EXAMPLE 724 | 725 | (Source code for a particular class) 726 | 727 | #+END_EXAMPLE 728 | 729 | Sample last response in a sequence of responses: 730 | 731 | #+BEGIN_EXAMPLE 732 | 733 | (Source code for a particular class) 734 | 735 | #+END_EXAMPLE 736 | -------------------------------------------------------------------------------- /requests.st: -------------------------------------------------------------------------------- 1 | Namespace current: Shampoo [ 2 | 3 | Object subclass: Request [ 4 | 5 | 9 | 10 | | id | 11 | 12 | Request class >> from: anXML [ 13 | 14 | | attrs class | 15 | attrs := anXML attrMap. 16 | class := Request allSubclasses detect: 17 | [:each | (each respondsTo: #is:) and: [each is: (attrs at: 'type')]]. 18 | ^(class new: (attrs at: 'id') asInteger) 19 | init: anXML; 20 | yourself 21 | ] 22 | 23 | Request class >> new: anInteger [ 24 | 25 | ^(self new) 26 | id: anInteger; 27 | yourself 28 | ] 29 | 30 | id: anInteger [ 31 | 32 | id := anInteger 33 | ] 34 | 35 | id [ 36 | 37 | ^id 38 | ] 39 | 40 | init: anXML [ 41 | 42 | "Default implementation, do nothing" 43 | ] 44 | 45 | execute [ 46 | 47 | ^self subclassResponsibility 48 | ] 49 | 50 | failSafe: aBlock [ 51 | 52 | aBlock 53 | on: Error 54 | do: [:err | ^OperationalResponse failure: id with: err]. 55 | ^OperationalResponse success: id 56 | ] 57 | ] 58 | 59 | Request subclass: LoginRequest [ 60 | 61 | 64 | 65 | | creds | 66 | 67 | LoginRequest class >> is: aString [ 68 | 69 | ^aString = 'Login' 70 | ] 71 | 72 | init: anXML [ 73 | 74 | creds := LoginInfo fromXML: (anXML elementsNamed: 'creds') first. 75 | ] 76 | 77 | creds [ 78 | 79 | ^creds 80 | ] 81 | ] 82 | 83 | Request subclass: NamespacesRequest [ 84 | 85 | 87 | 88 | NamespacesRequest class >> is: aString [ 89 | 90 | ^aString = 'Namespaces' 91 | ] 92 | 93 | execute [ 94 | 95 | | names | 96 | names := ((Namespace allInstances select: [:each | each environment = Smalltalk]) 97 | collect: [:each | each name asString]) asSet asSortedCollection. 98 | ^NamespacesResponse id: id names: (#('Smalltalk'), names) 99 | ] 100 | ] 101 | 102 | Request subclass: ClassesRequest [ 103 | 104 | 106 | 107 | | namespace | 108 | 109 | ClassesRequest class >> is: aString [ 110 | 111 | ^aString = 'Classes' 112 | ] 113 | 114 | init: anXML [ 115 | 116 | namespace := anXML attrMap at: 'namespace' 117 | ] 118 | 119 | execute [ 120 | 121 | | space names | 122 | names := SortedCollection new. 123 | space := Smalltalk at: namespace asSymbol. 124 | space allClassesDo: [:each | names add: each name asString]. 125 | ^ClassesResponse id: id names: names 126 | ] 127 | ] 128 | 129 | Request subclass: ClassRequest [ 130 | 131 | 133 | 134 | | className spaceName side | 135 | 136 | ClassRequest class >> is: aString [ 137 | 138 | ^aString = 'Class' 139 | ] 140 | 141 | init: anXML [ 142 | 143 | | attrs | 144 | attrs := anXML attrMap. 145 | className := attrs at: 'class'. 146 | spaceName := attrs at: 'namespace'. 147 | side := (attrs at: 'side') asSymbol. 148 | ] 149 | 150 | execute [ 151 | 152 | | class | 153 | class := (Smalltalk at: spaceName asSymbol) at: className asSymbol. 154 | (side = #class) ifTrue: [class := class class]. 155 | ^ClassResponse 156 | id: id 157 | class: className 158 | superclass: class superclass printString 159 | instvars: class instVarNames asStringArray 160 | classvars: class classVarNames asStringArray 161 | poolvars: class sharedPools asStringArray 162 | category: class category 163 | ] 164 | ] 165 | 166 | Request subclass: CategoriesRequest [ 167 | 168 | 170 | 171 | | className spaceName side | 172 | 173 | CategoriesRequest class >> is: aString [ 174 | 175 | ^aString = 'Categories' 176 | ] 177 | 178 | init: anXML [ 179 | 180 | | attrs | 181 | attrs := anXML attrMap. 182 | className := attrs at: 'class'. 183 | spaceName := attrs at: 'namespace'. 184 | side := (attrs at: 'side') asSymbol 185 | ] 186 | 187 | execute [ 188 | 189 | | class cats | 190 | class := (Smalltalk at: spaceName asSymbol) at: className asSymbol. 191 | (side = #class) ifTrue: [class := class class]. 192 | 193 | cats := Set new. 194 | class methodDictionary ifNotNil: [:d | d values do: 195 | [:each | cats add: each descriptor category]]. 196 | 197 | ^MethodCategoriesResponse 198 | id: id 199 | class: className 200 | categories: cats asSortedCollection 201 | ] 202 | ] 203 | 204 | Request subclass: MethodsRequest [ 205 | 206 | 208 | 209 | | className spaceName side cat | 210 | 211 | MethodsRequest class >> is: aString [ 212 | 213 | ^aString = 'Methods' 214 | ] 215 | 216 | init: anXML [ 217 | 218 | | attrs | 219 | attrs := anXML attrMap. 220 | className := attrs at: 'class'. 221 | spaceName := attrs at: 'namespace'. 222 | side := (attrs at: 'side') asSymbol. 223 | cat := attrs at: 'category' 224 | ] 225 | 226 | execute [ 227 | 228 | | class methods allMethods | 229 | class := (Smalltalk at: spaceName asSymbol) at: className asSymbol. 230 | (side = #class) ifTrue: [class := class class]. 231 | 232 | allMethods := class methodDictionary ifNil: [#()] ifNotNil: [:x | x associations]. 233 | 234 | methods := (cat = '*' 235 | ifTrue: [allMethods] 236 | ifFalse: [allMethods select: [:e | e value descriptor category = cat]]). 237 | 238 | ^MethodsResponse 239 | id: id 240 | class: className 241 | methods: (methods collect: [:each | each key asString]) asSortedCollection 242 | ] 243 | ] 244 | 245 | Request subclass: MethodSourceRequest [ 246 | 247 | 249 | 250 | | className spaceName side name | 251 | 252 | MethodSourceRequest class >> is: aString [ 253 | 254 | ^aString = 'MethodSource' 255 | ] 256 | 257 | init: anXML [ 258 | 259 | | attrs | 260 | attrs := anXML attrMap. 261 | className := attrs at: 'class'. 262 | spaceName := attrs at: 'namespace'. 263 | side := (attrs at: 'side') asSymbol. 264 | name := attrs at: 'method' 265 | ] 266 | 267 | execute [ 268 | 269 | | class method | 270 | class := (Smalltalk at: spaceName asSymbol) at: className asSymbol. 271 | (side = #class) ifTrue: [class := class class]. 272 | 273 | method := class methodDictionary at: name asSymbol. 274 | 275 | ^MethodResponse 276 | id: id 277 | class: className 278 | method: name 279 | source: method methodSourceString 280 | ] 281 | ] 282 | 283 | Request subclass: CompileClassRequest [ 284 | 285 | 286 | 287 | | className superName superSpace spaceName instvars classvars poolvars side category | 288 | 289 | CompileClassRequest class >> is: aString [ 290 | 291 | ^aString = 'CompileClass' 292 | ] 293 | 294 | init: anXML [ 295 | 296 | | attrs fetchBlock | 297 | attrs := anXML attrMap. 298 | side := (attrs at: 'side' ifAbsent: ['instance']) asSymbol. 299 | 300 | side == #instance ifTrue: 301 | [category := (attrs at: 'category' ifAbsent: ['Uncategorized'])]. 302 | 303 | fetchBlock := [:type | (anXML elementsNamed: type) collect: 304 | [:each | each text]]. 305 | 306 | "This data is common for both 'instance' and 'class' sides" 307 | className := attrs at: 'class'. 308 | spaceName := attrs at: 'namespace'. 309 | instvars := fetchBlock value: 'instvar'. 310 | 311 | side = #instance 312 | ifTrue: [superName := attrs at: 'super'. 313 | superSpace := attrs at: 'superspace'. 314 | classvars := fetchBlock value: 'classvar'. 315 | poolvars := fetchBlock value: 'poolvar'] 316 | ] 317 | 318 | execute [ 319 | 320 | | parent class currentSpace targetSpace error | 321 | 322 | targetSpace := Smalltalk at: spaceName asSymbol. 323 | class := targetSpace at: className asSymbol ifAbsent: [nil]. 324 | 325 | side = #instance 326 | ifTrue: ["Looks a bit kludgy, but currently I dont know how to make it better 327 | TODO: refactor" 328 | parent := (Smalltalk at: superSpace asSymbol) at: superName asSymbol. 329 | currentSpace := Namespace current. 330 | Namespace current: targetSpace. 331 | 332 | [class := parent 333 | subclass: className asSymbol 334 | instanceVariableNames: instvars elementsString 335 | classVariableNames: classvars elementsString 336 | poolDictionaries: '' " poolvars elementsString " 337 | category: category. 338 | ] on: Error do: [:err | error := err]. 339 | 340 | Namespace current: currentSpace] 341 | 342 | ifFalse: [class := targetSpace at: className asSymbol ifAbsent: [nil]. 343 | [class class instanceVariableNames: instvars elementsString] 344 | on: Error do: [:err | error := err]]. 345 | 346 | error isNil 347 | ifTrue: [^OperationalResponse success: id] 348 | ifFalse: [^OperationalResponse failure: id with: error] 349 | ] 350 | ] 351 | 352 | Request subclass: CompileMethodRequest [ 353 | 354 | 356 | 357 | | className spaceName side source cat | 358 | 359 | CompileMethodRequest class >> is: aString [ 360 | 361 | ^aString = 'CompileMethod' 362 | ] 363 | 364 | init: anXML [ 365 | 366 | | attrs | 367 | attrs := anXML attrMap. 368 | className := attrs at: 'class'. 369 | spaceName := attrs at: 'namespace'. 370 | side := (attrs at: 'side') asSymbol. 371 | cat := attrs at: 'category'. 372 | source := anXML text 373 | ] 374 | 375 | execute [ 376 | 377 | | class method | 378 | class := (Smalltalk at: spaceName asSymbol) at: className asSymbol. 379 | (side = #class) ifTrue: [class := class class]. 380 | 381 | method := class compile: source ifError: 382 | [:filename :linenum :errdesc | ^self failWith: errdesc]. 383 | 384 | (cat ~= '*') 385 | & (method descriptor category ~= cat) 386 | & (method descriptor category = 'still unclassified') 387 | ifTrue: [method descriptor category: cat]. 388 | 389 | ^OperationalResponse success: id 390 | ] 391 | 392 | failWith: aString [ 393 | 394 | | err | 395 | err := Error new. 396 | err messageText: aString. 397 | ^self fail: err 398 | ] 399 | 400 | fail: anError [ 401 | 402 | ^OperationalResponse failure: id with: anError 403 | ] 404 | ] 405 | 406 | Request subclass: EvalRequest [ 407 | 408 | 413 | | code | 414 | 415 | init: anXML [ 416 | 417 | code := '[', anXML text, '] value' 418 | ] 419 | 420 | execute [ 421 | 422 | ^Behavior evaluate: code 423 | ] 424 | ] 425 | 426 | EvalRequest subclass: DoItRequest [ 427 | 428 | 431 | 432 | DoItRequest class >> is: aString [ 433 | 434 | ^aString = 'DoIt' 435 | ] 436 | 437 | execute [ 438 | 439 | [super execute] 440 | on: Error 441 | do: [:err | ^OperationalResponse failure: id with: err]. 442 | ^OperationalResponse success: id 443 | ] 444 | ] 445 | 446 | EvalRequest subclass: PrintItRequest [ 447 | 448 | 450 | 451 | PrintItRequest class >> is: aString [ 452 | 453 | ^aString = 'PrintIt' 454 | ] 455 | 456 | execute [ 457 | 458 | | s | 459 | [s := super execute] 460 | on: Error 461 | do: [:err | ^OperationalResponse failure: id with: err]. 462 | ^PrintItResponse id: id value: s 463 | ] 464 | ] 465 | 466 | Request subclass: RemoveClassRequest [ 467 | 468 | 469 | 470 | | spaceName className | 471 | 472 | RemoveClassRequest class >> is: aString [ 473 | 474 | ^aString = 'RemoveClass' 475 | ] 476 | 477 | init: anXML [ 478 | 479 | | attrs | 480 | attrs := anXML attrMap. 481 | spaceName := attrs at: 'namespace'. 482 | className := attrs at: 'class' 483 | ] 484 | 485 | execute [ 486 | 487 | ^self failSafe: 488 | [| namespace parent class | 489 | namespace := Smalltalk at: spaceName asSymbol. 490 | class := namespace classAt: className asSymbol. 491 | 492 | class subclasses isEmpty ifFalse: 493 | [^OperationalResponse 494 | failure: id 495 | text: 'failed to remove class ', className, ', it has subclasses.']. 496 | 497 | parent := class superclass. 498 | parent removeSubclass: class. 499 | parent class removeSubclass: class class. 500 | namespace removeKey: className asSymbol ifAbsent: []] 501 | ] 502 | ] 503 | 504 | Request subclass: RemoveMethodRequest [ 505 | 506 | 507 | 508 | | spaceName className side selector | 509 | 510 | RemoveMethodRequest class >> is: aString [ 511 | 512 | ^aString = 'RemoveMethod' 513 | ] 514 | 515 | init: anXML [ 516 | 517 | | attrs | 518 | attrs := anXML attrMap. 519 | spaceName := attrs at: 'namespace'. 520 | className := attrs at: 'class'. 521 | side := (attrs at: 'side') asSymbol. 522 | selector := (attrs at: 'method') asSymbol. 523 | ] 524 | 525 | execute [ 526 | 527 | ^self failSafe: 528 | [| namespace class | 529 | namespace := Smalltalk at: spaceName asSymbol. 530 | class := namespace classAt: className asSymbol. 531 | (side = #class) ifTrue: [class := class class]. 532 | class removeSelector: selector] 533 | ] 534 | ] 535 | 536 | Request subclass: ChangeCategoryRequest [ 537 | 538 | 539 | 540 | | spaceName className side cat selector | 541 | 542 | ChangeCategoryRequest class >> is: aString [ 543 | 544 | ^aString = 'ChangeCategory' 545 | ] 546 | 547 | init: anXML [ 548 | 549 | | attrs | 550 | attrs := anXML attrMap. 551 | spaceName := attrs at: 'namespace'. 552 | className := attrs at: 'class'. 553 | side := (attrs at: 'side') asSymbol. 554 | cat := (attrs at: 'category'). 555 | selector := (attrs at: 'method') asSymbol. 556 | ] 557 | 558 | execute [ 559 | 560 | ^self failSafe: 561 | [| namespace class method | 562 | namespace := Smalltalk at: spaceName asSymbol. 563 | class := namespace classAt: className asSymbol. 564 | (side = #class) ifTrue: [class := class class]. 565 | 566 | method := class methodDictionary at: selector. 567 | method descriptor category: 568 | (cat = '*' ifTrue: [nil] ifFalse: [cat])] 569 | ] 570 | ] 571 | 572 | Request subclass: RemoveCategoryRequest [ 573 | 574 | 576 | 577 | | spaceName className side cat | 578 | 579 | RemoveCategoryRequest class >> is: aString [ 580 | 581 | ^aString = 'RemoveCategory' 582 | ] 583 | 584 | init: anXML [ 585 | 586 | | attrs | 587 | attrs := anXML attrMap. 588 | spaceName := attrs at: 'namespace'. 589 | className := attrs at: 'class'. 590 | side := (attrs at: 'side') asSymbol. 591 | cat := (attrs at: 'category'). 592 | ] 593 | 594 | execute [ 595 | 596 | ^self failSafe: 597 | [| namespace class method | 598 | namespace := Smalltalk at: spaceName asSymbol. 599 | class := namespace classAt: className asSymbol. 600 | (side = #class) ifTrue: [class := class class]. 601 | 602 | class methodDictionary values do: 603 | [:method | method descriptor category = cat 604 | ifTrue: [method descriptor category: nil]]] 605 | ] 606 | ] 607 | 608 | Request subclass: RenameCategoryRequest [ 609 | 610 | 611 | 612 | | spaceName className side cat from to| 613 | 614 | RenameCategoryRequest class >> is: aString [ 615 | 616 | ^aString = 'RenameCategory' 617 | ] 618 | 619 | init: anXML [ 620 | 621 | | attrs | 622 | attrs := anXML attrMap. 623 | spaceName := attrs at: 'namespace'. 624 | className := attrs at: 'class'. 625 | side := (attrs at: 'side') asSymbol. 626 | from := attrs at: 'from'. 627 | to := attrs at: 'to'. 628 | ] 629 | 630 | execute [ 631 | 632 | ^self failSafe: 633 | [| namespace class method | 634 | namespace := Smalltalk at: spaceName asSymbol. 635 | class := namespace classAt: className asSymbol. 636 | (side = #class) ifTrue: [class := class class]. 637 | 638 | class methodDictionary values do: 639 | [:method | method descriptor category = from 640 | ifTrue: [method descriptor category: to]]] 641 | ] 642 | ] 643 | 644 | Request subclass: FileOutRequest [ 645 | 646 | 650 | 651 | | worker | 652 | 653 | FileOutRequest class >> is: aString [ 654 | 655 | ^aString = 'FileOut' 656 | ] 657 | 658 | init: anXML [ 659 | 660 | worker := self workerFor: anXML 661 | ] 662 | 663 | workerFor: anXML [ 664 | 665 | | attrs | 666 | attrs := anXML attrMap. 667 | (attrs includesKey: 'class') 668 | ifTrue: [^ClassFileOutWorker on: anXML parent: self]. 669 | 670 | (attrs includesKey: 'category') 671 | ifTrue: [^CategoryFileOutWorker on: anXML parent: self]. 672 | 673 | ^NamespaceFileOutWorker on: anXML parent: self 674 | ] 675 | 676 | execute [ 677 | 678 | [^worker execute] on: Error do: 679 | [:err | ^OperationalResponse failure: id with: err] 680 | ] 681 | ] 682 | 683 | Object subclass: FileOutWorker [ 684 | 685 | 686 | | namespace request splitter | 687 | 688 | FileOutWorker class >> on: anXML parent: aRequest [ 689 | 690 | ^self new 691 | parent: aRequest; 692 | init: anXML; 693 | yourself 694 | ] 695 | 696 | parent: aRequest [ 697 | 698 | request := aRequest. 699 | ] 700 | 701 | init: anXML [ 702 | 703 | | attrs | 704 | attrs := anXML attrMap. 705 | namespace := attrs at: 'namespace'. 706 | splitter := self splitterFor: anXML. 707 | ] 708 | 709 | parent [ 710 | 711 | ^request 712 | ] 713 | 714 | namespace [ 715 | 716 | ^namespace 717 | ] 718 | 719 | splitter [ 720 | 721 | ^splitter 722 | ] 723 | 724 | splitterFor: anXML [ 725 | 726 | | option | 727 | option := anXML attrMap at: 'splitby' ifAbsent: ['class']. 728 | option = 'category' ifTrue: 729 | [^ByCategoryFileOutSplitter parent: self parent]. 730 | ^ByClassFileOutSplitter parent: self parent 731 | ] 732 | 733 | execute [ 734 | 735 | ^Array new 736 | ] 737 | 738 | buildResponses: aCollectionOfClasses [ 739 | | organized prettified responses | 740 | organized := self splitter organize: aCollectionOfClasses. 741 | 742 | prettified := organized collect: 743 | [:classes | PrettyPrinter prettifyClasses: classes]. 744 | 745 | responses := prettified associations collect: 746 | [:assoc | self splitter buildResponseFor: assoc value 747 | in: assoc key]. 748 | 749 | responses isEmpty ifTrue: 750 | [self error: 'No classes found for fileout']. 751 | 752 | responses last isLast: true. 753 | ^responses 754 | ] 755 | ] 756 | 757 | FileOutWorker subclass: ClassFileOutWorker [ 758 | 759 | 760 | | className | 761 | 762 | init: anXML [ 763 | 764 | super init: anXML. 765 | className := anXML attrMap at: 'class'. 766 | ] 767 | 768 | splitterFor: anXML [ 769 | 770 | ^ByClassFileOutSplitter parent: self parent 771 | ] 772 | 773 | execute [ 774 | 775 | | ns class | 776 | ns := Smalltalk at: self namespace asSymbol. 777 | class := ns at: className asSymbol. 778 | ^self buildResponses: (Array with: class) 779 | ] 780 | ] 781 | 782 | FileOutWorker subclass: NamespaceFileOutWorker [ 783 | 784 | 785 | accepts: aClass [ 786 | 787 | ^true 788 | ] 789 | 790 | execute [ 791 | 792 | | ns cs | 793 | ns := Smalltalk at: self namespace asSymbol. 794 | cs := OrderedCollection new. 795 | ns allClassesDo: 796 | [:each | (self accepts: each) ifTrue: [cs add: each]]. 797 | ^self buildResponses: cs 798 | ] 799 | ] 800 | 801 | NamespaceFileOutWorker subclass: CategoryFileOutWorker [ 802 | 803 | 804 | | catName | 805 | 806 | init: anXML [ 807 | 808 | super init: anXML. 809 | catName := anXML attrMap at: 'category'. 810 | ] 811 | 812 | accepts: aClass [ 813 | 814 | ^aClass category = catName 815 | ] 816 | ] 817 | 818 | Object subclass: FileOutSplitter [ 819 | | request | 820 | 821 | FileOutSplitter class >> parent: aRequest [ 822 | 823 | ^(self new) 824 | parent: aRequest; 825 | yourself 826 | ] 827 | 828 | parent: aRequest [ 829 | 830 | request := aRequest 831 | ] 832 | 833 | parent [ 834 | 835 | ^request 836 | ] 837 | 838 | organize: aCollectionOfClasses [ 839 | 840 | ^self subclassResponsibility 841 | ] 842 | 843 | buildResponseFor: aSourceCode in: aGroup [ 844 | 845 | ^self subclassResponsibility 846 | ] 847 | ] 848 | 849 | FileOutSplitter subclass: ByClassFileOutSplitter [ 850 | 851 | 852 | organize: aCollectionOfClasses [ 853 | 854 | ^Dictionary from: 855 | (aCollectionOfClasses collect: 856 | [:each | each name asString -> (Array with: each)]) 857 | ] 858 | 859 | buildResponseFor: aSourceCode in: aGroup [ 860 | 861 | ^FileOutResponse 862 | id: self parent id 863 | class: aGroup 864 | source: aSourceCode 865 | ] 866 | ] 867 | 868 | FileOutSplitter subclass: ByCategoryFileOutSplitter [ 869 | 870 | 871 | organize: aCollectionOfClasses [ 872 | 873 | | dict | 874 | dict := Dictionary new. 875 | aCollectionOfClasses do: 876 | [:class | 877 | (dict at: class category ifPresent: [:c | c add: class]) 878 | isNil ifTrue: 879 | [dict at: class category put: 880 | (OrderedCollection with: class)]]. 881 | ^dict 882 | ] 883 | 884 | buildResponseFor: aSourceCode in: aGroup [ 885 | 886 | ^FileOutResponse 887 | id: self parent id 888 | category: aGroup 889 | source: aSourceCode 890 | ] 891 | ] 892 | ] 893 | -------------------------------------------------------------------------------- /tests.st: -------------------------------------------------------------------------------- 1 | Namespace current: Smalltalk [ 2 | Namespace current: ShampooSamples [ 3 | Object subclass: SampleClassA [ 4 | 5 | | a b c | 6 | 7 | one := 1. 8 | two := 2. 9 | three := 3. 10 | ] 11 | 12 | SampleClassA class extend [ 13 | | d | 14 | ] 15 | 16 | Object subclass: SampleClassB [ 17 | 18 | doSomething [ 19 | 20 | ^42 21 | ] 22 | 23 | doSomethingElse: something withArg: anArg [ 24 | 25 | ^something + anArg 26 | ] 27 | 28 | aMethodWithoutCategory [ 29 | ^self class name 30 | ] 31 | 32 | foo [ 33 | 34 | ^1337 35 | ] 36 | 37 | bar [ 38 | 39 | ^'Smalltalk is cool!' 40 | ] 41 | ] 42 | 43 | Object subclass: SampleClassD [ 44 | 45 | 46 | methodWithExistingCategory [ 47 | 48 | ] 49 | 50 | myCategoryWillBeRemoved1 [ 51 | 52 | ] 53 | 54 | myCategoryWillBeRemoved2 [ 55 | 56 | ] 57 | 58 | myCategoryWillBeRemoved3 [ 59 | 60 | ] 61 | ] 62 | 63 | nil subclass: SampleClassE [ 64 | 65 | ] 66 | 67 | Object subclass: SampleClassF [ 68 | 69 | ] 70 | 71 | Object subclass: SampleClassG [ 72 | 73 | 74 | foo [ 75 | 76 | ] 77 | 78 | bar [ 79 | 80 | ] 81 | 82 | baz [ 83 | 84 | ] 85 | ] 86 | 87 | Object subclass: SampleClassSide [ 88 | 89 | ] 90 | 91 | Object subclass: SampleClassWithoutCategory [ 92 | ] 93 | ] 94 | ] 95 | 96 | Namespace current: Shampoo [ 97 | "We do not need these methods in the original implementation but 98 | do need it for tests" 99 | 100 | Response extend [ 101 | id [ 102 | 103 | ^id 104 | ] 105 | ] 106 | 107 | MagicResponse extend [ 108 | magic [ 109 | 110 | ^number 111 | ] 112 | ] 113 | 114 | OperationalResponse extend [ 115 | success [ 116 | 117 | ^success 118 | ] 119 | ] 120 | 121 | ClassInfoResponse extend [ 122 | className [ 123 | 124 | ^class 125 | ] 126 | 127 | attrs [ 128 | 129 | ^attrs 130 | ] 131 | ] 132 | 133 | MethodResponse extend [ 134 | methodName [ 135 | 136 | ^methodName 137 | ] 138 | 139 | methodSource [ 140 | 141 | ^methodSource 142 | ] 143 | ] 144 | 145 | TestCase subclass: ShampooTestCase [ 146 | 147 | 148 | defaultLogPolicyClass [ 149 | 150 | ^TestVerboseLog 151 | ] 152 | 153 | execute: aSelector [ 154 | ^(self requestFrom: (self perform: aSelector)) execute 155 | ] 156 | 157 | requestFrom: aString [ 158 | ^Request from: (ShampooXML.ShNode from: aString) 159 | ] 160 | ] 161 | 162 | ShampooTestCase subclass: LoginTest [ 163 | 164 | 165 | | login server info | 166 | 167 | setUp [ 168 | "Magic is 1337" 169 | info := LoginTest authInfoSample. 170 | login := self requestFrom: LoginTest loginSample. 171 | ] 172 | 173 | testCreds [ 174 | self should: 175 | [login creds = (info with: LoginTest magicSample)] 176 | ] 177 | 178 | LoginTest class >> loginSample [ 179 | ^ 180 | ' 181 | 182 | ' 183 | ] 184 | 185 | LoginTest class >> authInfoSample [ 186 | ^AuthInfo login: 'dmitry' pass: 'pass'. 187 | ] 188 | 189 | LoginTest class >> magicSample [ 190 | ^1337 191 | ] 192 | ] 193 | 194 | ShampooTestCase subclass: NamespacesTest [ 195 | 196 | 197 | | namespaces r items | 198 | 199 | setUp [ 200 | namespaces := self requestFrom: self namespacesSample. 201 | r := namespaces execute. 202 | items := r items at: 'namespace' 203 | ] 204 | 205 | testNamespaces [ 206 | self should: [items includes: 'Shampoo']; 207 | should: [items includes: 'ShampooSamples'] 208 | ] 209 | 210 | testIndirectSubspaces [ 211 | "Currently Shampoo supports only 'root' namespaces. 212 | Indirect ones should not be included in the response" 213 | | indirect | 214 | indirect := [Namespace allInstances detect: 215 | [:each | each environment ~= Smalltalk]] 216 | ifError: [nil]. 217 | indirect ifNotNil: 218 | [self shouldnt: [items includes: indirect name]] 219 | ] 220 | 221 | namespacesSample [ 222 | ^'' 223 | ] 224 | ] 225 | 226 | ShampooTestCase subclass: ClassesTest [ 227 | 228 | 229 | | classes | 230 | 231 | setUp [ 232 | classes := self requestFrom: self classesSample 233 | ] 234 | 235 | testClasses [ 236 | | r items | 237 | r := classes execute. 238 | items := r items at: 'class'. 239 | self should: [items includes: 'SampleClassA']; 240 | should: [items includes: 'SampleClassB'] 241 | ] 242 | 243 | classesSample [ 244 | ^ 245 | '' 246 | ] 247 | ] 248 | 249 | ShampooTestCase subclass: ClassTest [ 250 | 251 | 252 | | class nilSubclass classSide r nilr classr | 253 | 254 | setUp [ 255 | class := self requestFrom: self classSample. 256 | nilSubclass := self requestFrom: self nilSubclassSample. 257 | classSide := self requestFrom: self classSideSample. 258 | r := class execute. 259 | nilr := nilSubclass execute. 260 | classr := classSide execute 261 | ] 262 | 263 | testSuperclass [ 264 | self should: [(r attrs at: 'superclass') = 'Object']; 265 | should: [(nilr attrs at: 'superclass') = 'nil'] 266 | ] 267 | 268 | testInstvars [ 269 | | vars | 270 | vars := r items at: 'instvar'. 271 | self should: [vars includes: 'a']; 272 | should: [vars includes: 'b']; 273 | should: [vars includes: 'c'] 274 | ] 275 | 276 | performClassVarsTestFor: aResponse [ 277 | | vars | 278 | vars := aResponse items at: 'classvar'. 279 | self should: [vars includes: 'one']; 280 | should: [vars includes: 'two']; 281 | should: [vars includes: 'three'] 282 | ] 283 | 284 | testClassvars [ 285 | self performClassVarsTestFor: r 286 | ] 287 | 288 | testClassSideInstvars [ 289 | | vars | 290 | vars := classr items at: 'instvar'. 291 | self should: [vars includes: 'd']; 292 | shouldnt: [vars includes: 'a']; 293 | shouldnt: [vars includes: 'b']; 294 | shouldnt: [vars includes: 'c'] 295 | ] 296 | 297 | testClassSideClassvars [ 298 | self performClassVarsTestFor: classr 299 | ] 300 | 301 | classSample [ 302 | ^ 303 | '' 305 | ] 306 | 307 | nilSubclassSample [ 308 | ^ 309 | '' 311 | ] 312 | 313 | classSideSample [ 314 | ^ 315 | '' 317 | ] 318 | ] 319 | 320 | ShampooTestCase subclass: CatsTest [ 321 | 322 | 323 | | cats emptyCats | 324 | 325 | setUp [ 326 | cats := self requestFrom: self catsSample. 327 | emptyCats := self requestFrom: self emptyCatsSample. 328 | ] 329 | 330 | testCats [ 331 | | r items | 332 | r := cats execute. 333 | items := r items at: 'category'. 334 | self should: [items includes: 'sample-category']; 335 | should: [items includes: 'accessors'] 336 | ] 337 | 338 | testEmptyCats [ 339 | | r items | 340 | r := emptyCats execute. 341 | items := r items at: 'category'. 342 | self should: [items isEmpty] 343 | ] 344 | 345 | catsSample [ 346 | ^ 347 | '' 349 | ] 350 | 351 | emptyCatsSample [ 352 | ^ 353 | '' 355 | ] 356 | ] 357 | 358 | ShampooTestCase subclass: MethodsTest [ 359 | 360 | 361 | | methods asterisk | 362 | 363 | setUp [ 364 | methods := self requestFrom: self methodsSample. 365 | asterisk := self requestFrom: self asteriskSample. 366 | ] 367 | 368 | testMethods [ 369 | | r items | 370 | r := methods execute. 371 | items := r items at: 'method'. 372 | self should: [items includes: 'doSomethingElse:withArg:']; 373 | should: [items includes: 'doSomething']; 374 | shouldnt: [items includes: 'foo']; 375 | shouldnt: [items includes: 'bar'] 376 | ] 377 | 378 | testAsterisk [ 379 | | r items | 380 | r := asterisk execute. 381 | items := r items at: 'method'. 382 | self should: [items includes: 'doSomethingElse:withArg:']; 383 | should: [items includes: 'doSomething']; 384 | should: [items includes: 'foo']; 385 | should: [items includes: 'bar'] 386 | ] 387 | 388 | methodsSample [ 389 | ^ 390 | '' 392 | ] 393 | 394 | asteriskSample [ 395 | ^ 396 | '' 398 | ] 399 | ] 400 | 401 | ShampooTestCase subclass: MethodTest [ 402 | 403 | 404 | | method | 405 | 406 | setUp [ 407 | method := self requestFrom: self methodSample 408 | ] 409 | 410 | testMethod [ 411 | | r | 412 | "I am not sure about this test" 413 | r := method execute. 414 | self should: [r methodName = 'doSomethingElse:withArg:'] 415 | ] 416 | 417 | methodSample [ 418 | ^ 419 | '' 422 | ] 423 | ] 424 | 425 | ShampooTestCase subclass: CompileClassTest [ 426 | 427 | 428 | | compileClass r compiledClass | 429 | 430 | setUp [ 431 | compileClass := self requestFrom: self compileClassSample. 432 | r := compileClass execute. 433 | compiledClass := ShampooSamples at: #SampleClassC. 434 | ] 435 | 436 | testCompiledClass [ 437 | self should: [compiledClass ~= nil] 438 | ] 439 | 440 | testInstvars [ 441 | | vars | 442 | vars := compiledClass instVarNames asStringArray. 443 | self should: [vars includes: 'one']; 444 | should: [vars includes: 'two']; 445 | should: [vars includes: 'three'] 446 | ] 447 | 448 | testClassvars [ 449 | | vars | 450 | vars := compiledClass classVarNames asStringArray. 451 | self should: [vars includes: 'classOne']; 452 | should: [vars includes: 'classTwo']; 453 | should: [vars includes: 'classThree'] 454 | ] 455 | 456 | compileClassSample [ 457 | ^ 458 | ' 464 | one 465 | two 466 | three 467 | classOne 468 | classTwo 469 | classThree 470 | poolOne 471 | poolTwo 472 | poolThree 473 | ' 474 | ] 475 | ] 476 | 477 | ShampooTestCase subclass: CompileClassSideTest [ 478 | 479 | 480 | | classSide rside classSideResult | 481 | 482 | setUp [ 483 | classSide := self requestFrom: self classSideSample. 484 | rside := classSide execute. 485 | classSideResult := ShampooSamples.SampleClassSide class 486 | ] 487 | 488 | testClassInstVars [ 489 | | vars | 490 | vars := classSideResult instVarNames asStringArray. 491 | self should: [vars includes: 'classOne']; 492 | should: [vars includes: 'classTwo']; 493 | should: [vars includes: 'classThree'] 494 | ] 495 | 496 | classSideSample [ 497 | ^ 498 | ' 504 | classOne 505 | classTwo 506 | classThree 507 | ' 508 | ] 509 | ] 510 | 511 | ShampooTestCase subclass: CompileMethodTest [ 512 | 513 | 514 | setUp [ 515 | self execute: #compileMethodSample. 516 | self execute: #compileMethodCatSample. 517 | self execute: #compileMethodCatOvwrSample. 518 | ] 519 | 520 | testCompiledMethod [ 521 | | value | 522 | value := ShampooSamples.SampleClassD new 523 | sampleCompiledMethod: 11. 524 | self should: [value = 42] 525 | ] 526 | 527 | testMethodNoCategory [ 528 | | method | 529 | method := ShampooSamples.SampleClassD 530 | methodDictionary at: #sampleCompiledMethod:. 531 | self should: 532 | [method descriptor category = 'still unclassified'] 533 | ] 534 | 535 | testMethodCategory [ 536 | | method | 537 | method := ShampooSamples.SampleClassD 538 | methodDictionary at: #sampleMethodWithCategory. 539 | self should: 540 | [method descriptor category = 'some category'] 541 | ] 542 | 543 | testMethodCategoryOverwrite [ 544 | | method | 545 | method := ShampooSamples.SampleClassD 546 | methodDictionary at: #anotherMethodWithCategory. 547 | self should: 548 | [method descriptor category = 'used one'] 549 | ] 550 | 551 | compileMethodSample [ 552 | ^ 553 | ' 559 | sampleCompiledMethod: anInteger [ 560 | ^anInteger * 4 - 2 561 | ] 562 | ' 563 | ] 564 | 565 | compileMethodCatSample [ 566 | ^ 567 | ' 573 | sampleMethodWithCategory [ 574 | ] 575 | ' 576 | ] 577 | 578 | compileMethodCatOvwrSample [ 579 | ^ 580 | ' 586 | anotherMethodWithCategory [ 587 | <category: ''used one''> 588 | ] 589 | ' 590 | ] 591 | ] 592 | 593 | ShampooTestCase subclass: DoItTest [ 594 | 595 | 596 | | doit locals | 597 | 598 | setUp [ 599 | ShampooSamples at: #someUniqueKeyForDoIt put: nil. 600 | doit := self requestFrom: self doItSample. 601 | locals := self requestFrom: self localsDoItSample. 602 | ] 603 | 604 | testDoIt [ 605 | | r | 606 | r := doit execute. 607 | self should: [42 = (ShampooSamples at: #someUniqueKeyForDoIt)]; 608 | should: [r statusString = 'success'] 609 | ] 610 | 611 | testWithLocals [ 612 | | r | 613 | r := locals execute. 614 | self should: ['149' = (ShampooSamples at: #someUniqueKeyForLocals)] 615 | ] 616 | 617 | doItSample [ 618 | ^ 619 | ' 620 | ShampooSamples at: #someUniqueKeyForDoIt put: 42 621 | ' 622 | ] 623 | 624 | localsDoItSample [ 625 | ^ 626 | ' 627 | | c d | 628 | c := OrderedCollection new. 629 | c add: 1; add: 2; add: 3. 630 | d := (c collect: [:e | e squared]) 631 | inject: String new 632 | into: [:a :e | a, e asString]. 633 | ShampooSamples at: #someUniqueKeyForLocals put: d 634 | ' 635 | ] 636 | ] 637 | 638 | ShampooTestCase subclass: PrintItTest [ 639 | 640 | 641 | | printit | 642 | 643 | setUp [ 644 | printit := self requestFrom: self printItSample 645 | ] 646 | 647 | testPrintIt [ 648 | | r | 649 | r := printit execute. 650 | self should: [r value = 8] 651 | ] 652 | 653 | printItSample [ 654 | ^'2 + 2 * 2' 655 | ] 656 | ] 657 | 658 | ShampooTestCase subclass: OperationalResponseTest [ 659 | 660 | 661 | | succ fail | 662 | 663 | setUp [ 664 | succ := OperationalResponse success: 1. 665 | fail := OperationalResponse failure: 1. 666 | ] 667 | 668 | testSuccess [ 669 | self should: [succ statusString = 'success'] 670 | ] 671 | 672 | testFailure [ 673 | self should: [fail statusString = 'failure'] 674 | ] 675 | ] 676 | 677 | ShampooTestCase subclass: MessageParserTest [ 678 | 679 | 680 | | justParser overParser underParser brokenParser | 681 | 682 | setUp [ 683 | justParser := MessageParser new. 684 | overParser := MessageParser new. 685 | underParser := MessageParser new. 686 | brokenParser := MessageParser new. 687 | ] 688 | 689 | happy [ 690 | ^'Content-Length: 2', String crlf, 691 | String crlf, 692 | ':)' 693 | ] 694 | 695 | sad [ 696 | ^'Content-Length: 2', String crlf, 697 | String crlf, 698 | ':(' 699 | ] 700 | 701 | testSimple [ 702 | | msg r | 703 | msg := self happy. 704 | r := justParser process: msg. 705 | self should: [r first = ':)'] 706 | ] 707 | 708 | testOver [ 709 | | msg r | 710 | msg := self happy, self sad. 711 | r := overParser process: msg. 712 | self 713 | should: [r first = ':)']; 714 | should: [r second = ':('] 715 | ] 716 | 717 | testUnder [ 718 | | msg r | 719 | msg := self happy, (self sad copyFrom: 1 to: 7). 720 | r := underParser process: msg. 721 | self 722 | should: [r first = ':)']; 723 | should: [r size = 1] 724 | ] 725 | 726 | testBroken [ 727 | | msg part1 part2 r | 728 | msg := self sad. 729 | part1 := msg copyFrom: 1 to: 7. 730 | part2 := msg copyFrom: 8. 731 | r := brokenParser process: part1. 732 | self should: [r isEmpty]. 733 | r := brokenParser process: part2. 734 | self should: [r first = ':('] 735 | ] 736 | ] 737 | 738 | Object subclass: ShampooGenericMock [ 739 | | methods | 740 | 741 | methods [ 742 | 743 | ^methods ifNil: [methods := Dictionary new] 744 | ] 745 | 746 | doesNotUnderstand: aMessage [ 747 | 748 | | block | 749 | block := methods 750 | at: aMessage selector 751 | ifAbsent: [^super doesNotUnderstand: aMessage]. 752 | ^block ifNotNil: 753 | [block valueWithArguments: aMessage arguments]. 754 | ] 755 | 756 | on: aMessageSelector do: aBlock [ 757 | self methods at: aMessageSelector put: aBlock 758 | ] 759 | 760 | ignore: aMessageSelector [ 761 | self on: aMessageSelector do: nil. 762 | ] 763 | 764 | forgetAbout: aMessageSelector [ 765 | self methods removeKey: aMessageSelector ifAbsent: [] 766 | ] 767 | ] 768 | 769 | ShampooGenericMock subclass: ShampooConnectionMock [ 770 | | state | 771 | 772 | server [ 773 | ^self 774 | ] 775 | 776 | state [ 777 | ^state 778 | ] 779 | 780 | state: aState [ 781 | state := aState 782 | ] 783 | ] 784 | 785 | ShampooTestCase subclass: ShampooNotAuthStateTest [ 786 | | state connMock | 787 | 788 | setUp [ 789 | connMock := ShampooConnectionMock new. 790 | state := NotAuthorizedState of: connMock 791 | ] 792 | 793 | testCheckLoginSucc [ 794 | | rq resp | 795 | rq := self requestFrom: LoginTest loginSample. 796 | connMock 797 | on: #authenticates:with: 798 | do: [:creds :magic | true]. 799 | [resp := state process: rq] ifError: [self fail]. 800 | connMock forgetAbout: #authenticates:with:. 801 | 802 | self 803 | should: [connMock state class = AuthorizedState]; 804 | should: [resp class = ServerInfoResponse] 805 | ] 806 | 807 | testCheckLoginFail [ 808 | | rq failed | 809 | rq := self requestFrom: LoginTest loginSample. 810 | connMock 811 | on: #authenticates:with: 812 | do: [:creds :magic | false]. 813 | [state process: rq] on: FatalError do: [failed := true]. 814 | connMock forgetAbout: #authenticates:with:. 815 | self assert: failed. 816 | ] 817 | ] 818 | 819 | ShampooTestCase subclass: ShampooConnectionTest [ 820 | | conn sockMock srvMock | 821 | 822 | setUp [ 823 | sockMock := ShampooGenericMock new. 824 | sockMock 825 | ignore: #nextPutAll:; 826 | ignore: #crlf; 827 | ignore: #flush. 828 | 829 | srvMock := ShampooGenericMock new. 830 | conn := ClientConnection 831 | on: sockMock 832 | onDisconnect: [:cl | srvMock gotDisconnect] 833 | parent: srvMock. 834 | ] 835 | 836 | testFetchMessages [ 837 | | msg r | 838 | 839 | msg := 'Content-Length: 9', String crlf, 840 | String crlf, 841 | 'Smalltalk'. 842 | 843 | sockMock 844 | on: #ensureReadable do: [true]; 845 | on: #availableBytes do: [msg size]; 846 | on: #next: do: [:n | msg]. 847 | 848 | r := conn fetchMessages. 849 | self should: [r first = 'Smalltalk']. 850 | ] 851 | 852 | testFetchMessagesFail [ 853 | | caught | 854 | sockMock on: #ensureReadable do: [Error new signal]. 855 | [conn fetchMessages] 856 | on: ClientDisconnected do: [:e | caught := true]. 857 | self assert: caught. 858 | ] 859 | 860 | testSend [ 861 | | packetMock strings | 862 | strings := OrderedCollection new. 863 | packetMock := ShampooGenericMock new. 864 | packetMock on: #asXML do: ['Shampoo']. 865 | "I think that testing this thing by catching 866 | #nextPutAll is not a very good idea." 867 | sockMock on: #nextPutAll: do: [:s | strings add: s]. 868 | conn send: packetMock. 869 | self 870 | should: [strings first = 'Content-Length: 9']; 871 | should: [strings second = '''Shampoo''']. 872 | ] 873 | 874 | testDisconnect [ 875 | | got | 876 | srvMock on: #gotDisconnect do: [got := true]. 877 | sockMock 878 | on: #isPeerAlive do: [true]; 879 | on: #ensureReadable do: [Error new signal]. 880 | conn go. 881 | self assert: got. 882 | ] 883 | ] 884 | 885 | ShampooTestCase subclass: ShampooRemoveClassTest [ 886 | | foo bar baz | 887 | 888 | setUp [ 889 | foo := Object subclass: #ShampooFooClass. 890 | bar := Object subclass: #ShampooBarClass. 891 | baz := bar subclass: #ShampooBazClass. 892 | ] 893 | 894 | have: aClassName in: aNamespace [ 895 | ^aNamespace includesKey: aClassName 896 | ] 897 | 898 | have: aSymbol isSubclassOf: aClass [ 899 | ^aClass allSubclasses contains: [:cl | cl name = aSymbol] 900 | ] 901 | 902 | have: aSymbol isSubclassInstanceOf: aMetaclass [ 903 | ^aMetaclass allSubclasses contains: 904 | [:mcl | mcl instanceClass name = aSymbol]. 905 | ] 906 | 907 | testSimpleRemove [ 908 | | rq | 909 | rq := self requestFrom: self removeFooSample. 910 | self 911 | should: [rq execute success]. 912 | self 913 | shouldnt: [self have: #ShampooFooClass in: Smalltalk]; 914 | shouldnt: [self have: #ShampooFooClass isSubclassOf: Object]; 915 | shouldnt: [self have: #ShampooFooClass isSubclassInstanceOf: Object class] 916 | ] 917 | 918 | testHierarchyRemove [ 919 | | rq | 920 | rq := self requestFrom: self removeBarSample. 921 | self 922 | shouldnt: [rq execute success]. 923 | self 924 | should: [self have: #ShampooBarClass in: Smalltalk]; 925 | should: [self have: #ShampooBarClass isSubclassOf: Object]; 926 | should: [self have: #ShampooBarClass isSubclassInstanceOf: Object class]. 927 | self 928 | should: [self have: #ShampooBazClass in: Smalltalk]; 929 | should: [self have: #ShampooBazClass isSubclassOf: Object]; 930 | should: [self have: #ShampooBazClass isSubclassInstanceOf: Object class] 931 | ] 932 | 933 | removeFooSample [ 934 | ^ 935 | '' 937 | ] 938 | 939 | removeBarSample [ 940 | ^ 941 | '' 943 | ] 944 | ] 945 | 946 | ShampooTestCase subclass: ShampooRemoveMethodTest [ 947 | setUp [ 948 | ShampooSamples.SampleClassF compile: 'foo [^123]'. 949 | ShampooSamples.SampleClassF class compile: 'bar [^#bar]'. 950 | ] 951 | 952 | testInstanceSide [ 953 | | rq | 954 | rq := self requestFrom: self removeFooSample. 955 | self should: [rq execute success]. 956 | self shouldnt: [ShampooSamples.SampleClassF canUnderstand: #foo ] 957 | ] 958 | 959 | testClassSide [ 960 | | rq | 961 | rq := self requestFrom: self removeBarSample. 962 | self should: [rq execute success]. 963 | self shouldnt: [ShampooSamples.SampleClassF class canUnderstand: #bar ] 964 | ] 965 | 966 | removeFooSample [ 967 | ^ 968 | '' 971 | ] 972 | 973 | removeBarSample [ 974 | ^ 975 | '' 978 | ] 979 | ] 980 | 981 | ShampooTestCase subclass: ShampooChangeCategoryTest [ 982 | | rq foo | 983 | 984 | setUp [ 985 | | method | 986 | method := ShampooSamples.SampleClassD methodDictionary 987 | at: #methodWithExistingCategory. 988 | method descriptor category: 'change me'. 989 | 990 | rq := self requestFrom: self changeCatSample. 991 | ] 992 | 993 | testChange [ 994 | | method | 995 | rq execute. 996 | method := ShampooSamples.SampleClassD methodDictionary 997 | at: #methodWithExistingCategory. 998 | self should: [method descriptor category = 'changed'] 999 | ] 1000 | 1001 | changeCatSample [ 1002 | ^ 1003 | '' 1012 | ] 1013 | ] 1014 | 1015 | ShampooTestCase subclass: ShampooRemoveCategoryTest [ 1016 | selectors [ 1017 | ^#( #myCategoryWillBeRemoved1 1018 | #myCategoryWillBeRemoved2 1019 | #myCategoryWillBeRemoved3 ) 1020 | ] 1021 | 1022 | setUp [ 1023 | self selectors do: 1024 | [:each || method | 1025 | method := ShampooSamples.SampleClassD 1026 | methodDictionary at: each. 1027 | method descriptor category: 'to be removed']. 1028 | 1029 | self execute: #removeCatSample 1030 | ] 1031 | 1032 | testRemoval [ 1033 | self selectors do: 1034 | [:each || method | 1035 | method := ShampooSamples.SampleClassD 1036 | methodDictionary at: each. 1037 | self should: [method descriptor category = 1038 | 'still unclassified']] 1039 | ] 1040 | 1041 | removeCatSample [ 1042 | ^ 1043 | '' 1051 | ] 1052 | ] 1053 | 1054 | ShampooTestCase subclass: RenameCategoryTest [ 1055 | | rq | 1056 | 1057 | setUp [ 1058 | rq := self requestFrom: self renameCatSample. 1059 | 1060 | ShampooSamples.SampleClassG methodDictionary values do: 1061 | [:each | each descriptor category: 'to be renamed']. 1062 | ] 1063 | 1064 | testCategoryRename [ 1065 | | resp | 1066 | resp := rq execute. 1067 | self should: [resp success]. 1068 | 1069 | ShampooSamples.SampleClassG methodDictionary values do: 1070 | [:each | self should: [each descriptor category = 'finally renamed']] 1071 | ] 1072 | 1073 | renameCatSample [ 1074 | ^ 1075 | '' 1084 | ] 1085 | ] 1086 | 1087 | ShampooTestCase subclass: MethodSourcePrettifierTest [ 1088 | | ms | 1089 | 1090 | setUp [ 1091 | ms := MethodSource from: self methodSample 1092 | ] 1093 | 1094 | testSelector [ 1095 | self should: 1096 | [ms selectorWithArguments = 'aMessageWith: anArgument']. 1097 | ] 1098 | 1099 | testCompacting [ 1100 | ms compact. 1101 | self should: [ms body size = 4] 1102 | ] 1103 | 1104 | testIndentSize [ 1105 | ms compact. 1106 | self should: [ms methodIndent = 2] 1107 | ] 1108 | 1109 | testStrip [ 1110 | ms compact; stripIndent. 1111 | self should: [ms methodIndent = 0] 1112 | ] 1113 | 1114 | testIndenting [ 1115 | ms compact; stripIndent; indentWith: ' '. 1116 | self should: [ms methodIndent = 4]. 1117 | ] 1118 | 1119 | methodSample [ 1120 | ^ 1121 | 'aMessageWith: anArgument 1122 | [ 1123 | | one two | 1124 | one := 1. 1125 | two := 2. 1126 | ^one + two 1127 | 1128 | ]' 1129 | ] 1130 | ] 1131 | 1132 | ShampooTestCase subclass: ShampooFileOutTestCase [ 1133 | | rs | 1134 | 1135 | ShampooFileOutTestCase class >> isAbstract [ 1136 | ^true 1137 | ] 1138 | 1139 | responses: aCollectionOfResponses [ 1140 | rs := aCollectionOfResponses 1141 | ] 1142 | 1143 | responses [ 1144 | ^rs 1145 | ] 1146 | 1147 | testLastMark [ 1148 | self should: [rs last isLast] 1149 | ] 1150 | 1151 | testAllButLastMark [ 1152 | self shouldnt: 1153 | [(rs allButLast collect: [:each | each isLast]) or] 1154 | ] 1155 | 1156 | testSameId [ 1157 | rs allButFirst do: 1158 | [:each | self should: [each id = rs first id]] 1159 | ] 1160 | ] 1161 | 1162 | ShampooFileOutTestCase subclass: ShampooFileOutClassTest [ 1163 | 1164 | ShampooFileOutClassTest class >> isAbstract [ 1165 | ^false 1166 | ] 1167 | 1168 | setUp [ 1169 | self responses: (self execute: #fileOutClassSample) 1170 | ] 1171 | 1172 | testResponseCount [ 1173 | self should: [self responses size = 1] 1174 | ] 1175 | 1176 | fileOutClassSample [ 1177 | ^ 1178 | '' 1182 | ] 1183 | ] 1184 | 1185 | ShampooFileOutTestCase subclass: ShampooFileOutClassCategoryTest [ 1186 | 1187 | ShampooFileOutClassCategoryTest class >> isAbstract [ 1188 | ^false 1189 | ] 1190 | 1191 | setUp [ 1192 | self responses: (self execute: #fileOutClassCategorySample) 1193 | ] 1194 | 1195 | testResponseCount [ 1196 | self should: [self responses size = 7] 1197 | ] 1198 | 1199 | fileOutClassCategorySample [ 1200 | ^ 1201 | '' 1206 | ] 1207 | ] 1208 | 1209 | ShampooFileOutTestCase subclass: ShampooFileOutNamespaceTest [ 1210 | 1211 | ShampooFileOutNamespaceTest class >> isAbstract [ 1212 | ^false 1213 | ] 1214 | 1215 | setUp [ 1216 | self responses: (self execute: #fileOutNamespaceSample) 1217 | ] 1218 | 1219 | testResponseCount [ 1220 | self should: [self responses size >= 8] 1221 | ] 1222 | 1223 | fileOutNamespaceSample [ 1224 | ^ 1225 | '' 1229 | ] 1230 | ] 1231 | ] 1232 | --------------------------------------------------------------------------------