'From Cuis 2.0 of 24 February 2010 [latest update: #440] on 2 March 2010 at 11:31:36 am'!

!Browser methodsFor: 'message category list' stamp: 'jmv 3/2/2010 11:15'!
categorizeAllUncategorizedMethods
	"Categorize methods by looking in parent classes for a method category."

	| organizer organizers |
	organizer _ self classOrMetaClassOrganizer.
	organizers _ self selectedClassOrMetaClass withAllSuperclasses collect: [:ea | ea organization].
	(organizer listAtCategoryNamed: ClassOrganizer default) do: [:sel | | found |
		found _ (organizers collect: [ :org | org categoryOfElement: sel])
			detect: [:ea | ea ~= ClassOrganizer default and: [ ea notNil]]
			ifNone: nil.
		found ifNotNil: [organizer classify: sel under: found]].

	self changed: #messageCategoryList! !


!CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'jmv 3/2/2010 11:15'!
cr 
	"Answer a CharacterBlock that specifies the current location of the mouse 
	relative to a carriage return stop condition that has just been 
	encountered. The ParagraphEditor convention is to denote selections by 
	CharacterBlocks, sometimes including the carriage return (cursor is at 
	the end) and sometimes not (cursor is in the middle of the text)."

	((characterIndex notNil
		and: [characterIndex > text size])
			or: [(line last = text size)
				and: [(destY + line lineHeight) < characterPoint y]])
		ifTrue:	["When off end of string, give data for next character"
				destY _ destY +  line lineHeight.
				lastCharacter _ nil.
				characterPoint _ leftMargin @ destY.
				lastIndex _ lastIndex + 1.
				self lastCharacterExtentSetX: 0.
				^ true].
		lastCharacter _ Character cr.
		characterPoint _ destX @ destY.
		self lastCharacterExtentSetX: rightMargin - destX.
		^true! !


!Form methodsFor: 'converting' stamp: 'jmv 3/2/2010 11:20'!
colorReduced
	"Return a color-reduced ColorForm version of the receiver, if possible, or the receiver itself if not."

	| tally tallyDepth colorCount newForm cm oldPixelValues newFormColors nextColorIndex c |
	tally _ self tallyPixelValues asArray.
	tallyDepth _ (tally size log: 2) asInteger.
	colorCount _ 0.
	tally do: [:n | n > 0 ifTrue: [colorCount _ colorCount + 1]].
	(tally at: 1) = 0 ifTrue: [colorCount _ colorCount + 1].  "include transparent"
	colorCount > 256 ifTrue: [^ self].  "cannot reduce"
	newForm _ self formForColorCount: colorCount.

	"build an array of just the colors used, and a color map to translate
	 old pixel values to their indices into this color array"
	cm _ Bitmap new: tally size.
	oldPixelValues _ self colormapIfNeededForDepth: 32.
	newFormColors _ Array new: colorCount.
	newFormColors at: 1 put: Color transparent.
	nextColorIndex _ 2.
	2 to: cm size do: [:i |
		(tally at: i) > 0 ifTrue: [
			c _ oldPixelValues
				ifNil: [ Color colorFromPixelValue: i - 1 depth: tallyDepth]
				ifNotNil: [ Color colorFromPixelValue: (oldPixelValues at: i) depth: 32].
			newFormColors at: nextColorIndex put: c.
			cm at: i put: nextColorIndex - 1.  "pixel values are zero-based indices"
			nextColorIndex _ nextColorIndex + 1]].

	"copy pixels into new ColorForm, mapping to new pixel values"
	newForm copyBits: self boundingBox
		from: self
		at: 0@0
		clippingBox: self boundingBox
		rule: Form over
		fillColor: nil
		map: cm.
	newForm colors: newFormColors.
	newForm offset: offset.
	^ newForm
! !


!InputSensor methodsFor: 'private' stamp: 'jmv 3/2/2010 11:21'!
characterForKeycode: keycode
	"Map the given keycode to a Smalltalk character object. Encoding:
		A keycode is 12 bits:   <4 modifer bits><8 bit ISO character>
		Modifier bits are:       <command><option><control><shift>"

	"NOTE: the command and option keys are specific to the Macintosh and may not have equivalents on other platforms."

	keycode ifNil: [ ^nil ].
	keycode class = Character ifTrue: [ ^keycode ].  "to smooth the transition!!"
	^ Character value: (keycode bitAnd: 16rFF)! !


!EventSensor methodsFor: 'private-I/O' stamp: 'jmv 3/2/2010 11:18'!
primGetNextEvent: array
	"Store the next OS event available into the provided array.
	Essential. If the VM is not event driven the ST code will fall
	back to the old-style mechanism and use the state based
	primitives instead."
	| kbd buttons modifiers pos mapped |
	<primitive: 94>
	"Simulate the events"
	array at: 1 put: EventTypeNone. "assume no more events"

	"First check for keyboard"
	kbd _ super primKbdNext.
	kbd ifNotNil: [
		"simulate keyboard event"
		array at: 1 put: EventTypeKeyboard. "evt type"
		array at: 2 put: Time millisecondClockValue. "time stamp"
		array at: 3 put: (kbd bitAnd: 255). "char code"
		array at: 4 put: EventKeyChar. "key press/release"
		array at: 5 put: (kbd bitShift: -8). "modifier keys"
		^self].

	"Then check for mouse"
	buttons _ super primMouseButtons.
	pos _ super primMousePt.
	modifiers _ buttons bitShift: -3.
	buttons _ buttons bitAnd: 7.
	mapped _ self mapButtons: buttons modifiers: modifiers.
	(pos = mousePosition and:[(mapped bitOr: (modifiers bitShift: 3)) = mouseButtons])
		ifTrue:[^self].
	array 
		at: 1 put: EventTypeMouse;
		at: 2 put: Time millisecondClockValue;
		at: 3 put: pos x;
		at: 4 put: pos y;
		at: 5 put: mapped;
		at: 6 put: modifiers.
! !

!EventSensor methodsFor: 'private-I/O' stamp: 'jmv 3/2/2010 11:19'!
processKeyboardEvent: evt
	"process a keyboard event, updating InputSensor state"
	| charCode pressCode |
	"Never update keyboardBuffer if we have an eventQueue active"
	mouseButtons _ (mouseButtons bitAnd: 7) bitOr: ((evt at: 5) bitShift: 3).
	eventQueue ifNotNil:[^self]. 
	charCode _ evt at: 3.
	charCode ifNil: [^self]. "extra characters not handled in MVC"
	pressCode _ evt at: 4.
	pressCode = EventKeyChar ifFalse:[^self]. "key down/up not handled in MVC"
	"mix in modifiers"
	charCode _ charCode bitOr: ((evt at: 5) bitShift: 8).
	keyboardBuffer nextPut: charCode.! !


!NetNameResolver class methodsFor: 'address string utils' stamp: 'jmv 3/2/2010 11:22'!
addressFromString: addressString
	"Return the internet address represented by the given string. The string should contain four positive decimal integers delimited by periods, commas, or spaces, where each integer represents one address byte. Return nil if the string is not a host address in an acceptable format."
	"NetNameResolver addressFromString: '1.2.3.4'"
	"NetNameResolver addressFromString: '1,2,3,4'"
	"NetNameResolver addressFromString: '1 2 3 4'"

	| newAddr s byte delimiter |
	newAddr _ ByteArray new: 4.
	s _ ReadStream on: addressString.
	s skipSeparators.
	1 to: 4 do: [:i |
		byte _ self readDecimalByteFrom: s.
		byte ifNil: [^ nil].
		newAddr at: i put: byte.
		i < 4 ifTrue: [
			delimiter _ s next.
			((delimiter = $.) or: [(delimiter = $,) or: [delimiter = $ ]])
				ifFalse: [^ nil]]].
	^ newAddr
! !


!PseudoContext class methodsFor: 'class initialization' stamp: 'jmv 3/2/2010 11:22'!
initialize
	"It's tricky to do the necessary stuff with the regular file-in machinery."

	PseudoContext superclass
		ifNotNil: [
			(Smalltalk confirm: 'Shall I convert PseudoContext into a compact subclass of nil?
("yes" is almost always the correct response)')
				ifTrue: [
					PseudoContext becomeCompact.
					PseudoContext superclass removeSubclass: PseudoContext.
					PseudoContext superclass: nil]].
	Smalltalk recreateSpecialObjectsArray.
	Smalltalk specialObjectsArray size = 50
		ifFalse: [self error: 'Please check size of special objects array!!']! !


!SelectionMenu methodsFor: 'basic control sequence' stamp: 'jmv 3/2/2010 11:23'!
invokeOn: targetObject
	"Pop up this menu and return the result of sending to the target object
	 the selector corresponding to the menu item selected by the user. Return
	 nil if no item is selected."

	| sel |
	sel _ self startUp.
	^sel ifNotNil: [ targetObject perform: sel]

"(SelectionMenu labels:
'sin
cos
neg' lines: #() selections: #(sin cos negated)) invokeOn: 0.7"! !

!SelectionMenu methodsFor: 'basic control sequence' stamp: 'jmv 3/2/2010 11:23'!
startUpWithCaption: captionOrNil at: location allowKeyboard: aBoolean
	"Overridden to return value returned by manageMarker.  The boolean parameter indicates whether the menu should be given keyboard focus (if in morphic)"

	| index |
	index _ super startUpWithCaption: captionOrNil at: location allowKeyboard: aBoolean.
	(selections isNil or: [(index between: 1 and: selections size) not])
		ifTrue: [^ nil].
	^ selections at: index! !


!Socket methodsFor: 'initialize-destroy' stamp: 'jmv 3/2/2010 11:27'!
acceptFrom: aSocket
	"Initialize a new socket handle from an accept call"
	| semaIndex readSemaIndex writeSemaIndex |

	primitiveOnlySupportsOneSemaphore _ false.
	semaphore _ Semaphore new.
	readSemaphore _ Semaphore new.
	writeSemaphore _ Semaphore new.
	semaIndex _ Smalltalk registerExternalObject: semaphore.
	readSemaIndex _ Smalltalk registerExternalObject: readSemaphore.
	writeSemaIndex _ Smalltalk registerExternalObject: writeSemaphore.
	socketHandle _ self primAcceptFrom: aSocket socketHandle
						receiveBufferSize: 8000
						sendBufSize: 8000
						semaIndex: semaIndex
						readSemaIndex: readSemaIndex
						writeSemaIndex: writeSemaIndex.
	socketHandle
		ifNil: [  "socket creation failed"
			Smalltalk unregisterExternalObject: semaphore.
			Smalltalk unregisterExternalObject: readSemaphore.
			Smalltalk unregisterExternalObject: writeSemaphore.
			readSemaphore _ writeSemaphore _ semaphore _ nil ]
		ifNotNil: [ self register]! !

!Socket methodsFor: 'initialize-destroy' stamp: 'jmv 3/2/2010 11:28'!
destroy
	"Destroy this socket. Its connection, if any, is aborted and its resources are freed. Do nothing if the socket has already been destroyed (i.e., if its socketHandle is nil)."

	socketHandle ifNotNil: [
		self isValid ifTrue: [self primSocketDestroy: socketHandle].
		Smalltalk unregisterExternalObject: semaphore.
		Smalltalk unregisterExternalObject: readSemaphore.
		Smalltalk unregisterExternalObject: writeSemaphore.
		socketHandle _ nil.
		readSemaphore _ writeSemaphore _ semaphore _ nil.
		self unregister]! !

!Socket methodsFor: 'initialize-destroy' stamp: 'jmv 3/2/2010 11:29'!
initialize: socketType
	"Initialize a new socket handle. If socket creation fails, socketHandle will be set to nil."
	| semaIndex readSemaIndex writeSemaIndex |

	primitiveOnlySupportsOneSemaphore _ false.
	semaphore _ Semaphore new.
	readSemaphore _ Semaphore new.
	writeSemaphore _ Semaphore new.
	semaIndex _ Smalltalk registerExternalObject: semaphore.
	readSemaIndex _ Smalltalk registerExternalObject: readSemaphore.
	writeSemaIndex _ Smalltalk registerExternalObject: writeSemaphore.
	socketHandle _
		self primSocketCreateNetwork: 0
			type: socketType
			receiveBufferSize: 8000
			sendBufSize: 8000
			semaIndex: semaIndex
			readSemaIndex: readSemaIndex
			writeSemaIndex: writeSemaIndex.

	socketHandle 
		ifNil: [  "socket creation failed"
			Smalltalk unregisterExternalObject: semaphore.
			Smalltalk unregisterExternalObject: readSemaphore.
			Smalltalk unregisterExternalObject: writeSemaphore.
			readSemaphore _ writeSemaphore _ semaphore _ nil ]
		ifNotNil: [ self register]! !

!Socket methodsFor: 'connection open/close' stamp: 'jmv 3/2/2010 11:28'!
closeAndDestroy: timeoutSeconds
	"First, try to close this connection gracefully. If the close attempt fails or times out, abort the connection. In either case, destroy the socket. Do nothing if the socket has already been destroyed (i.e., if its socketHandle is nil)."

	socketHandle
		ifNotNil: [
			self isConnected ifTrue: [
				self close.  "close this end"
				(self waitForDisconnectionFor: timeoutSeconds)
					ifFalse: [
						"if the other end doesn't close soon, just abort the connection"
						self primSocketAbortConnection: socketHandle]].
			self destroy]! !


!Socket class methodsFor: 'utilities' stamp: 'jmv 3/2/2010 11:29'!
ping: hostName
	"Ping the given host. Useful for checking network connectivity. The host must be running a TCP echo server."
	"Socket ping: 'squeak.cs.uiuc.edu'"

	| tcpPort sock serverAddr startTime echoTime |
	tcpPort _ 7.  "7 = echo port, 13 = time port, 19 = character generator port"

	serverAddr _ NetNameResolver addressForName: hostName timeout: 10.
	serverAddr ifNil: [
		^ self inform: 'Could not find an address for ', hostName].

	sock _ Socket new.
	sock connectNonBlockingTo: serverAddr port: tcpPort.
	[sock waitForConnectionFor: 10]
		on: ConnectionTimedOut
		do: [:ex |
			(self confirm: 'Continue to wait for connection to ', hostName, '?')
				ifTrue: [ex retry]
				ifFalse: [
					sock destroy.
					^ self]].

	sock sendData: 'echo!!'.
	startTime _ Time millisecondClockValue.
	[sock waitForDataFor: 15]
		on: ConnectionTimedOut
		do: [:ex | (self confirm: 'Packet sent but no echo yet; keep waiting?')
			ifTrue: [ex retry]].
	echoTime _ Time millisecondClockValue - startTime.

	sock destroy.
	self inform: hostName, ' responded in ', echoTime printString, ' milliseconds'.
! !

!Socket class methodsFor: 'utilities' stamp: 'jmv 3/2/2010 11:29'!
pingPorts: portList on: hostName timeOutSecs: timeOutSecs
	"Attempt to connect to each of the given sockets on the given host. Wait at most timeOutSecs for the connections to be established. Answer an array of strings indicating the available ports."
	"Socket pingPorts: #(7 13 19 21 23 25 80 110 119) on: 'squeak.cs.uiuc.edu' timeOutSecs: 15"

	| serverAddr sockets sock deadline done unconnectedCount connectedCount waitingCount result |
	serverAddr _ NetNameResolver addressForName: hostName timeout: 10.
	serverAddr ifNil: [
		self inform: 'Could not find an address for ', hostName.
		^ #()].

	sockets _ portList collect: [:portNum |
		sock _ Socket new.
		sock connectTo: serverAddr port: portNum].

	deadline _ self deadlineSecs: timeOutSecs.
	done _ false.
	[done] whileFalse: [
		unconnectedCount _ 0.
		connectedCount _ 0.
		waitingCount _ 0.
		sockets do: [:s |
			s isUnconnectedOrInvalid
				ifTrue: [unconnectedCount _ unconnectedCount + 1]
				ifFalse: [
					s isConnected ifTrue: [connectedCount _ connectedCount + 1].
					s isWaitingForConnection ifTrue: [waitingCount _ waitingCount + 1]]].
		waitingCount = 0 ifTrue: [done _ true].
		connectedCount = sockets size ifTrue: [done _ true].
		Time millisecondClockValue > deadline ifTrue: [done _ true]].

	result _ (sockets select: [:s | s isConnected])
		collect: [:s | self nameForWellKnownTCPPort: s remotePort].
	sockets do: [:s | s destroy].
	^ result
! !

!Socket class methodsFor: 'tests' stamp: 'jmv 3/2/2010 11:29'!
sendTest
	"Send data to the 'discard' socket of the given host.
	Tests the speed of one-way data transfers across the
	network to the given host. Note that most hosts
	do not run a discard server."

	"Socket sendTest"

	| sock bytesToSend sendBuf bytesSent t serverName serverAddr |
	Transcript cr; show: 'starting send test'; cr.
	self initializeNetwork.
	serverName := FillInTheBlank request: 'What is the destination server?' initialAnswer: 'create.ucsb.edu'.
	serverAddr := NetNameResolver addressForName: serverName timeout: 10.
	serverAddr ifNil: [
		^self inform: 'Could not find an address for ' , serverName].
	sock := self new.
	Transcript show: '---------- Connecting ----------';cr.
	sock connectTo: serverAddr port: 9.
	sock isConnected ifFalse: [
		sock destroy.
		^self inform: 'could not connect'].
	Transcript show: 'connection established; sending data'; cr.
	bytesToSend := 1000000.
	sendBuf := String new: 64 * 1024 withAll: $x.
	bytesSent := 0.
	t := Time millisecondsToRun: 
					[[bytesSent < bytesToSend] whileTrue: 
							[sock sendDone 
								ifTrue: [bytesSent := bytesSent + (sock sendSomeData: sendBuf)]]].
	sock waitForSendDoneFor: self standardTimeout.
	sock destroy.
	Transcript show: '---------- Connection Closed ----------'; cr;
		show: 'send test done; time = ' , t printString; cr;
		show: (bytesToSend asFloat / t roundTo: 0.01) printString, ' * 1000 bytes/sec';cr;endEntry! !


!ZipEncoderNode methodsFor: 'encoding' stamp: 'jmv 3/2/2010 11:31'!
encodeBitLength: blCounts from: aTree
	| index |
	"Note: If bitLength is not nil then the tree must be broken"
	bitLength ifNotNil: [ self error:'Huffman tree is broken'].
	bitLength _ parent
		ifNil: [0]
		ifNotNil: [ parent bitLength + 1].
	self isLeaf ifTrue:[
		index _ bitLength + 1.
		blCounts at: index put: (blCounts at: index) + 1.
	] ifFalse:[
		left encodeBitLength: blCounts from: aTree.
		right encodeBitLength: blCounts from: aTree.
	]! !


!ZipWriteStream class methodsFor: 'regression test' stamp: 'jmv 3/2/2010 11:31'!
regressionDecompress: aFile from: tempFile notifying: progressBar stats: stats
	"Validate aFile as decompressed from tempFile"
	| unzip rawSize compressedSize buffer1 buffer2 |
	rawSize _ aFile size.
	compressedSize _ tempFile size.
	aFile ascii.
	aFile position: 0.
	tempFile ascii.
	tempFile position: 0.
	buffer1 _ String new: 4096.
	buffer2 _ buffer1 copy.
	unzip _ FastInflateStream on: tempFile.
	[aFile atEnd] whileFalse:[
		progressBar value: aFile position.
		buffer1 _ aFile nextInto: buffer1.
		buffer2 _ unzip nextInto: buffer2.
		buffer1 = buffer2
			ifFalse:[^self logProblem: 'contents ' for: aFile].
	].
	unzip next ifNotNil: [ ^self logProblem: 'EOF' for: aFile].
	stats at: #rawSize put:
		(stats at: #rawSize ifAbsent:[0]) + rawSize.
	stats at: #compressedSize put:
		(stats at: #compressedSize ifAbsent:[0]) + compressedSize.
	^compressedSize asFloat / rawSize asFloat.! !

PseudoContext initialize!
