[squeak-dev] The Trunk: Network-nice.44.mczcommits at source.squeak.org commits at source.squeak.orgSun Dec 27 03:35:56 UTC 2009
Nicolas Cellier uploaded a new version of Network to project The Trunk: http://source.squeak.org/trunk/Network-nice.44.mcz ==================== Summary ==================== Name: Network-nice.44 Author: nice Time: 27 December 2009, 4:35:34 am UUID: 02348f14-a1a6-408c-86fe-30b1dd5b2567 Ancestors: Network-ul.43 Cosmetic: move or remove a few temps inside closures =============== Diff against Network-ul.43 =============== Item was changed: ----- Method: NetNameResolver class>>nameForAddress:timeout: (in category 'lookups') ----- nameForAddress: hostAddress timeout: secs "Look up the given host address and return its name. Return nil if the lookup fails or is not completed in the given number of seconds. Depends on the given host address being known to the gateway, which may not be the case for dynamically allocated addresses." "NetNameResolver nameForAddress: (NetNameResolver addressFromString: '128.111.92.2') timeout: 30" + | deadline | - | deadline result | self initializeNetwork. deadline := Time millisecondClockValue + (secs * 1000). "Protect the execution of this block, as the ResolverSemaphore is used for both parts of the transaction." + ^self resolverMutex - self resolverMutex critical: [ + (self waitForResolverReadyUntil: deadline) - result := (self waitForResolverReadyUntil: deadline) ifTrue: [ self primStartLookupOfAddress: hostAddress. (self waitForCompletionUntil: deadline) ifTrue: [self primAddressLookupResult] ifFalse: [nil]] + ifFalse: [nil]].! - ifFalse: [nil]]. - ^result - ! Item was changed: ----- Method: AcornFileDirectory class>>privateFullPathForURI: (in category '*network-uri') ----- privateFullPathForURI: aURI "derive the full filepath from aURI" + | path | - | first path | - path := String streamContents: [ :s | + aURI pathComponents + do: [ :p | s nextPutAll: p ] + separatedBy: [ s nextPut: self pathNameDelimiter ]. + ]. - first := false. - aURI pathComponents do: [ :p | - first ifTrue: [ s nextPut: self pathNameDelimiter ]. - first := true. - s nextPutAll: p ] ]. ^path unescapePercents ! Item was changed: ----- Method: SuperSwikiServer>>fastParseEntriesFrom: (in category 'for real') ----- fastParseEntriesFrom: aString + | c first | - | c first strm xEntryName xCreationTime xModificationTime xIsDirectory xFileSize ch | c := OrderedCollection new. first := true. + aString linesDo: [ :x | | xEntryName ch xIsDirectory strm xCreationTime xModificationTime xFileSize | - aString linesDo: [ :x | first ifFalse: [ strm := ReadStream on: x. (strm upTo: $ ) = '(DirectoryEntry' ifFalse: [^nil]. (strm upTo: $ ) = 'name:' ifFalse: [^nil]. xEntryName := WriteStream on: String new. strm next = $' ifFalse: [^nil]. [ ch := strm next. ch = $' and: [(strm peekFor: $') not] ] whileFalse: [ xEntryName nextPut: ch. ]. xEntryName := xEntryName contents. strm skipSeparators. (strm upTo: $ ) = 'creationTime:' ifFalse: [^nil]. xCreationTime := (strm upTo: $ ) asNumber. (strm upTo: $ ) = 'modificationTime:' ifFalse: [^nil]. xModificationTime := (strm upTo: $ ) asNumber. (strm upTo: $ ) = 'isDirectory:' ifFalse: [^nil]. xIsDirectory := (strm upTo: $ ) = 'true'. (strm upTo: $ ) = 'fileSize:' ifFalse: [^nil]. xFileSize := (strm upTo: $ ) asNumber. c add: (DirectoryEntry name: (xEntryName convertFromEncoding: self encodingName) creationTime: xCreationTime modificationTime: xModificationTime isDirectory: xIsDirectory fileSize: xFileSize ) ]. first := false. ]. ^c ! Item was changed: ----- Method: HTTPSocket class>>httpPostMultipart:args:accept:request: (in category 'get the page') ----- httpPostMultipart: url args: argsDict accept: mimeType request: requestString " do multipart/form-data encoding rather than x-www-urlencoded " " by Bolot Kerimbaev, 1998 " " this version is a memory hog: puts the whole file in memory " "bolot 12/14/2000 18:28 -- minor fixes to make it comply with RFC 1867" + | serverName serverAddr s header length bare page list firstData aStream port argsStream specifiedServer type newUrl mimeBorder | - | serverName serverAddr s header length bare page list firstData aStream port argsStream specifiedServer type newUrl mimeBorder fieldValue | Socket initializeNetwork. "parse url" bare := (url asLowercase beginsWith: 'http://') ifTrue: [url copyFrom: 8 to: url size] ifFalse: [url]. serverName := bare copyUpTo: $/. specifiedServer := serverName. (serverName includes: $:) ifFalse: [ port := self defaultPort ] ifTrue: [ port := (serverName copyFrom: (serverName indexOf: $:) + 1 to: serverName size) asNumber. serverName := serverName copyUpTo: $:. ]. page := bare copyFrom: (bare indexOf: $/) to: bare size. page size = 0 ifTrue: [page := '/']. (self shouldUseProxy: serverName) ifTrue: [ page := 'http://', serverName, ':', port printString, page. "put back together" serverName := self httpProxyServer. port := self httpProxyPort]. mimeBorder := '----squeak-georgia-tech-', Time millisecondClockValue printString, '-csl-cool-stuff-----'. "encode the arguments dictionary" argsStream := WriteStream on: String new. argsDict associationsDo: [:assoc | + assoc value do: [ :value | | fieldValue | - assoc value do: [ :value | "print the boundary" argsStream nextPutAll: '--', mimeBorder, CrLf. " check if it's a non-text field " argsStream nextPutAll: 'Content-disposition: multipart/form-data; name="', assoc key, '"'. (value isKindOf: MIMEDocument) ifFalse: [fieldValue := value] ifTrue: [argsStream nextPutAll: ' filename="', value url pathForFile, '"', CrLf, 'Content-Type: ', value contentType. fieldValue := (value content ifNil: [(FileStream fileNamed: value url pathForFile) contentsOfEntireFile] ifNotNil: [value content]) asString]. " Transcript show: 'field=', key, '; value=', fieldValue; cr. " argsStream nextPutAll: CrLf, CrLf, fieldValue, CrLf. ]]. argsStream nextPutAll: '--', mimeBorder, '--'. "make the request" serverAddr := NetNameResolver addressForName: serverName timeout: 20. serverAddr ifNil: [ ^ 'Could not resolve the server named: ', serverName]. s := HTTPSocket new. s connectTo: serverAddr port: port. s waitForConnectionUntil: self standardDeadline. Transcript cr; show: serverName, ':', port asString; cr. s sendCommand: 'POST ', page, ' HTTP/1.1', CrLf, (mimeType ifNotNil: ['ACCEPT: ', mimeType, CrLf] ifNil: ['']), 'ACCEPT: text/html', CrLf, "Always accept plain text" HTTPProxyCredentials, HTTPBlabEmail, "may be empty" requestString, "extra user request. Authorization" self userAgentString, CrLf, 'Content-type: multipart/form-data; boundary=', mimeBorder, CrLf, 'Content-length: ', argsStream contents size printString, CrLf, 'Host: ', specifiedServer, CrLf. "blank line automatically added" s sendCommand: argsStream contents. "get the header of the reply" list := s getResponseUpTo: CrLf, CrLf. "list = header, CrLf, CrLf, beginningOfData" header := list at: 1. "Transcript show: page; cr; show: argsStream contents; cr; show: header; cr." firstData := list at: 3. "dig out some headers" s header: header. length := s getHeader: 'content-length'. length ifNotNil: [ length := length asNumber ]. type := s getHeader: 'content-type'. s responseCode first = $3 ifTrue: [ "redirected - don't re-post automatically" "for now, just do a GET, without discriminating between 301/302 codes" newUrl := s getHeader: 'location'. newUrl ifNotNil: [ (newUrl beginsWith: 'http://') ifFalse: [ (newUrl beginsWith: '/') ifTrue: [newUrl := (bare copyUpTo: $/), newUrl] ifFalse: [newUrl := url, newUrl. self flag: #todo "should do a relative URL"] ]. Transcript show: 'redirecting to: ', newUrl; cr. s destroy. ^self httpGetDocument: newUrl "for some codes, may do: ^self httpPostMultipart: newUrl args: argsDict accept: mimeType request: requestString"] ]. aStream := s getRestOfBuffer: firstData totalLength: length. s responseCode = '401' ifTrue: [^ header, aStream contents]. s destroy. "Always OK to destroy!!" ^ MIMEDocument contentType: type content: aStream contents url: url! Item was changed: ----- Method: POP3Client>>messageCount (in category 'public protocol') ----- messageCount "Query the server and answer the number of messages that are in the user's mailbox." + | numMessages | - | answerString numMessages | self ensureConnection. self sendCommand: 'STAT'. self checkResponse. self logProgress: self lastResponse. + [ | answerString | + answerString := (self lastResponse findTokens: Character separators) second. - [answerString := (self lastResponse findTokens: Character separators) second. numMessages := answerString asNumber asInteger] on: Error do: [:ex | (ProtocolClientError protocolInstance: self) signal: 'Invalid STAT response.']. ^numMessages! Item was changed: ----- Method: MailMessage>>regenerateText (in category 'printing/formatting') ----- regenerateText "regenerate the full text from the body and headers" + + text := String streamContents: [ :str | | encodedBodyText | - | encodedBodyText | - text := String streamContents: [ :str | "first put the header" fields keysAndValuesDo: [ :fieldName :fieldValues | fieldValues do: [ :fieldValue | str nextPutAll: fieldName capitalized ; nextPutAll: ': '; nextPutAll: fieldValue asHeaderValue; cr ]. ]. "skip a line between header and body" str cr. "put the body, being sure to encode it according to the header" encodedBodyText := body content. self decoderClass ifNotNil: [ encodedBodyText := (self decoderClass mimeEncode: (ReadStream on: encodedBodyText)) upToEnd ]. str nextPutAll: encodedBodyText ].! Item was changed: ----- Method: MIMEHeaderValue class>>fromMIMEHeader: (in category 'instance creation') ----- fromMIMEHeader: aString "This is the value of a MIME header field and so is parsed to extract the various parts" + | parts newValue parms | - | parts newValue parms separatorPos parmName parmValue | newValue := self new. parts := ReadStream on: (aString findTokens: ';'). newValue mainValue: parts next. parms := Dictionary new. parts do: + [:e | | separatorPos parmName parmValue | - [:e | separatorPos := e findAnySubStr: '=' startingAt: 1. separatorPos <= e size ifTrue: [parmName := (e copyFrom: 1 to: separatorPos - 1) withBlanksTrimmed asLowercase. parmValue := (e copyFrom: separatorPos + 1 to: e size) withBlanksTrimmed withoutQuoting. parms at: parmName put: parmValue]]. newValue parameters: parms. ^ newValue ! Item was changed: ----- Method: OldSocket class>>remoteTestClientTCPOpenClose1000 (in category 'examples') ----- remoteTestClientTCPOpenClose1000 "Socket remoteTestClientTCPOpenClose1000" + | number t1 serverName | - | number t1 socket serverName | Transcript show: 'starting client/server TCP test'; cr. Transcript show: 'initializing network ... '. self initializeNetworkIfFail: [^Transcript show: 'failed']. Transcript show: 'ok'; cr. number := 1000. serverName := UIManager default request: 'What is your remote Test Server?' initialAnswer: ''. t1 := Time millisecondsToRun: [number timesRepeat: + [ | socket | + socket := self newTCP. - [socket := self newTCP. socket connectTo: (NetNameResolver addressFromString: serverName) port: 54321. socket waitForConnectionUntil: self standardDeadline. socket closeAndDestroy]]. Transcript cr; show: 'connects/close per second ' , (number / t1 * 1000.0) printString; cr! Item was changed: ----- Method: ConnectionQueue>>getConnectionOrNilLenient (in category 'public') ----- getConnectionOrNilLenient "Return a connected socket, or nil if no connection has been established." + ^accessSema critical: [ + | result | - | result | - accessSema critical: [ connections isEmpty ifTrue: [ result := nil ] ifFalse: [ result := connections removeFirst. (result isValid and: [result isConnected or: [result isOtherEndClosed]]) ifFalse: [ "stale connection" result destroy. result := nil ] + ]. + result - ] ]. - ^ result ! Item was changed: ----- Method: Socket class>>pingPorts:on:timeOutSecs: (in category 'utilities') ----- 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 deadline done result unconnectedCount connectedCount waitingCount | - | serverAddr sockets sock deadline done unconnectedCount connectedCount waitingCount result | serverAddr := NetNameResolver addressForName: hostName timeout: 10. serverAddr = nil ifTrue: [ self inform: 'Could not find an address for ', hostName. ^ #()]. + sockets := portList collect: [:portNum | | sock | - 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 ! Item was changed: ----- Method: ServerDirectory>>moveAllButYoungest:in:to: (in category 'squeaklets') ----- moveAllButYoungest: young in: versions to: repository + | all | - | all fName aVers bVers | "Specialized to files with names of the form 'aName_vvv.ext'. Where vvv is a mime-encoded base 64 version number. Versions is an array of file names tokenized into three parts (aName vvv ext). Move the files by renaming them on the server." versions size <= young ifTrue: [^ self]. + all := SortedCollection sortBlock: [:aa :bb | | aVers bVers | + aVers := Base64MimeConverter decodeInteger: aa second unescapePercents. + bVers := Base64MimeConverter decodeInteger: bb second unescapePercents. - all _ SortedCollection sortBlock: [:aa :bb | - aVers _ Base64MimeConverter decodeInteger: aa second unescapePercents. - bVers _ Base64MimeConverter decodeInteger: bb second unescapePercents. aVers < bVers]. all addAll: versions. young timesRepeat: [all removeLast]. "ones we keep" + all do: [:vv | | fName | + fName := vv first, '_', vv second, '.', vv third. - all do: [:vv | - fName _ vv first, '_', vv second, '.', vv third. repository rename: self fullName,fName toBe: fName]. ! Item was changed: ----- Method: Socket>>closeAndDestroy: (in category 'connection open/close') ----- 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: [ - socketHandle = nil - ifFalse: [ self isConnected ifTrue: [ self close. "close this end" + (self waitForDisconnectionFor: timeoutSeconds) ifFalse: [ - (self waitForDisconnectionFor: timeoutSeconds) - ifFalse: [ "The other end didn't close so we just abort the connection" self primSocketAbortConnection: socketHandle]]. self destroy]. ! Item was changed: ----- Method: ConnectionQueue>>pruneStaleConnections (in category 'private') ----- pruneStaleConnections "Private!! The client may establish a connection and then disconnect while it is still in the connection queue. This method is called periodically to prune such sockets out of the connection queue and make room for fresh connections." - | foundStaleConnection | accessSema critical: [ + | foundStaleConnection | foundStaleConnection := false. connections do: [:s | s isUnconnected ifTrue: [ s destroy. foundStaleConnection := true]]. foundStaleConnection ifTrue: [ connections := connections select: [:s | s isValid]]]. ! Item was changed: ----- Method: HTTPSocket>>header: (in category 'as yet unclassified') ----- header: headerText "set the headers. Then getHeader: can be used" "divide into basic lines" + | lines foldedLines statusLine | + lines := headerText findTokens: String crlf. - | lines foldedLines i statusLine | - lines := headerText findTokens: (String with: Character cr with: Character linefeed). statusLine := lines first. lines := lines copyFrom: 2 to: lines size. "parse the status (pretty trivial right now)" responseCode := (statusLine findTokens: ' ') second. "fold lines that start with spaces into the previous line" foldedLines := OrderedCollection new. lines do: [ :line | line first isSeparator ifTrue: [ foldedLines at: foldedLines size put: (foldedLines last, line) ] ifFalse: [ foldedLines add: line ] ]. "make a dictionary mapping headers to header contents" headers := Dictionary new. + foldedLines do: [ :line | | i | - foldedLines do: [ :line | i := line indexOf: $:. i > 0 ifTrue: [ headers at: (line copyFrom: 1 to: i-1) asLowercase put: (line copyFrom: i+1 to: line size) withBlanksTrimmed ] ]. ! Item was changed: ----- Method: OldSocket class>>pingPorts:on:timeOutSecs: (in category 'utilities') ----- 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 deadline done result unconnectedCount connectedCount waitingCount | - | serverAddr sockets sock deadline done unconnectedCount connectedCount waitingCount result | self initializeNetwork. serverAddr := NetNameResolver addressForName: hostName timeout: 10. serverAddr = nil ifTrue: [self inform: 'Could not find an address for ' , hostName. ^#()]. sockets := portList collect: + [:portNum | | sock | - [:portNum | sock := self 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! Item was changed: ----- Method: HTTPSocket>>contentType: (in category 'as yet unclassified') ----- contentType: header "extract the content type from the header. Content-type: text/plain<cr><lf>, User may look in headerTokens afterwards." | this | + headerTokens ifNil: [ headerTokens := header findTokens: ParamDelimiters keep: String cr]. - headerTokens ifNil: [ headerTokens := header findTokens: ParamDelimiters keep: (String with: CR) ]. 1 to: headerTokens size do: [:ii | this := headerTokens at: ii. (this first asLowercase = $c and: [#('content-type:' 'content type') includes: this asLowercase]) ifTrue: [ ^ (headerTokens at: ii+1)]]. ^ nil "not found"! Item was changed: ----- Method: UUIDGenerator>>makeUnixSeed (in category 'random seed') ----- makeUnixSeed + | answer | + [ | strm |strm := (FileStream readOnlyFileNamed: '/dev/urandom') binary. - | strm answer | - [strm := (FileStream readOnlyFileNamed: '/dev/urandom') binary. strm converter: Latin1TextConverter new. answer := Integer byte1: strm next byte2: strm next byte3: strm next byte4: strm next. strm close. ] on: FileStreamException do: [answer := nil]. ^answer! Item was changed: ----- Method: FTPClient>>lookForCode:ifDifferent: (in category 'private protocol') ----- lookForCode: code ifDifferent: handleBlock "We are expecting a certain numeric code next. However, in the FTP protocol, multiple lines are allowed. If the response is multi-line, the fourth character of the first line is a $- and the last line repeats the numeric code but the code is followed by a space. So it's possible that there are more lines left of the last response that we need to throw away. We use peekForAll: so that we don't discard the next response that is not a continuation line." + - | headToDiscard | "check for multi-line response" (self lastResponse size > 3 and: [(self lastResponse at: 4) = $-]) ifTrue: ["Discard continuation lines." + [ | headToDiscard | + headToDiscard := self lastResponse first: 4. - [headToDiscard := self lastResponse first: 4. [[self stream peekForAll: headToDiscard] whileTrue: [self stream nextLine]] on: Exception do: [:ex | ^handleBlock value: nil]]]. ^ super lookForCode: code ifDifferent: handleBlock! Item was changed: ----- Method: ServerDirectory>>fullPath: (in category 'accessing') ----- fullPath: serverAndDirectory "Parse and save a full path. Convention: if ftp://user@server/dir, then dir is relative to user's directory. dir has no slash at beginning. If ftp://server/dir, then dir is absolute to top of machine, give dir a slash at the beginning." + | start bare sz userAndServer both slash score best | - | start bare sz userAndServer both slash score match best sd | bare := serverAndDirectory. sz := serverAndDirectory size. bare size > 0 ifTrue: [ start := (bare copyFrom: 1 to: (8 min: sz)) asLowercase. ((start beginsWith: 'ftp:') or: [start beginsWith: 'nil:']) "fix bad urls" ifTrue: [type := #ftp. bare := bare copyFrom: (7 min: sz) to: bare size]. (start beginsWith: 'http:') ifTrue: [type := #http. bare := bare copyFrom: (8 min: sz) to: serverAndDirectory size]. ((start beginsWith: 'file:') or: [type == #file]) ifTrue: [type := #file. urlObject := FileUrl absoluteFromText: serverAndDirectory. ^ self]]. userAndServer := bare copyUpTo: self pathNameDelimiter. both := userAndServer findTokens: '@'. slash := both size. "absolute = 1, relative = 2" server := both last. both size > 1 ifTrue: [user := both at: 1]. bare size > (userAndServer size + 1) ifTrue: [directory := bare copyFrom: userAndServer size + slash to: bare size] ifFalse: [directory := '']. "If this server is already known, copy in its userName and password" type == #ftp ifFalse: [^ self]. score := -1. + ServerDirectory serverNames do: [:name | | match sd | - ServerDirectory serverNames do: [:name | sd := ServerDirectory serverNamed: name. server = sd server ifTrue: [ match := directory asLowercase charactersExactlyMatching: sd directory asLowercase. match > score ifTrue: [score := match. best := sd]]]. best ifNil: [ self fromUser ] ifNotNil: [ user := best user. altURL := best altUrl. loaderUrl := best loaderUrl. self password: best password ]. ! Item was changed: ----- Method: ServerDirectory>>copyUpdatesNumbered:toVersion: (in category 'updates') ----- copyUpdatesNumbered: selectList toVersion: otherVersion "Into the section of updates.list corresponding to otherVersion, copy all the fileNames from this version matching the selectList." " (ServerDirectory serverInGroupNamed: 'Disney Internal Updates*') copyUpdatesNumbered: #(4411 4412) to version: 'Squeak3.1beta'. " + | myServers updateStrm indexPrefix version versIndex lastNum otherVersIndex additions outOfOrder listContents | - | myServers updateStrm seq indexPrefix listContents version versIndex lastNum otherVersIndex additions outOfOrder | self openGroup. indexPrefix := (self groupName includes: $*) ifTrue: [(self groupName findTokens: ' ') first] "special for internal updates" ifFalse: ['']. "normal" myServers := self checkServersWithPrefix: indexPrefix andParseListInto: [:x | listContents := x]. myServers size = 0 ifTrue: [self closeGroup. ^ self]. version := SystemVersion current version. versIndex := (listContents collect: [:pair | pair first]) indexOf: version. versIndex = 0 ifTrue: [self inform: 'There is no section in updates.list for your version'. self closeGroup. ^ nil]. "abort" otherVersIndex := (listContents collect: [:pair | pair first]) indexOf: otherVersion. otherVersIndex = 0 ifTrue: [self inform: 'There is no section in updates.list for the target version'. self closeGroup. ^ nil]. "abort" versIndex < listContents size ifTrue: [(self confirm: 'This system, ', version , ' is not the latest version.\OK to copy updates from that old version?' withCRs) ifFalse: [self closeGroup. ^ nil]]. "abort" "Append all fileNames in my list that are not in the export list" additions := OrderedCollection new. outOfOrder := OrderedCollection new. lastNum := (listContents at: otherVersIndex) last isEmpty ifTrue: [0] "no checking if the current list is empty" ifFalse: [(listContents at: otherVersIndex) last last initialIntegerOrNil]. (listContents at: versIndex) last do: + [:fileName | | seq | seq := fileName initialIntegerOrNil. - [:fileName | seq := fileName initialIntegerOrNil. (selectList includes: seq) ifTrue: [seq > lastNum ifTrue: [additions addLast: fileName] ifFalse: [outOfOrder addLast: seq]]]. outOfOrder isEmpty ifFalse: [UIManager default inform: 'Updates numbered ' , outOfOrder asArray printString, ' are out of order.\ The last update in ' withCRs, otherVersion, ' is ', lastNum printString, '.\No update will take place.' withCRs. self closeGroup. ^ nil]. "abort" "Save old copy of updates.list on local disk" FileDirectory default deleteFileNamed: indexPrefix , 'updates.list.bk'. Utilities writeList: listContents toStream: (FileStream fileNamed: indexPrefix , 'updates.list.bk'). "Write a new copy of updates.list on all servers..." listContents at: otherVersIndex put: {otherVersion. (listContents at: otherVersIndex) last , additions}. updateStrm := ReadStream on: (String streamContents: [:s | Utilities writeList: listContents toStream: s]). myServers do: [:aServer | updateStrm reset. aServer putFile: updateStrm named: indexPrefix , 'updates.list' retry: true. Transcript show: 'Update succeeded on server ', aServer moniker; cr]. self closeGroup. Transcript cr; show: 'Be sure to test your new update!!'; cr. ! Item was changed: ----- Method: MacFileDirectory class>>privateFullPathForURI: (in category '*network-uri') ----- privateFullPathForURI: aURI + | path | - | first path | + path := String streamContents: [ :s | | first | - path := String streamContents: [ :s | first := false. aURI pathComponents do: [ :p | first ifTrue: [ s nextPut: self pathNameDelimiter ]. first := true. s nextPutAll: p ] ]. ^path unescapePercents ! Item was changed: ----- Method: ServerDirectory>>putUpdateMulti:fromDirectory: (in category 'updates') ----- putUpdateMulti: list fromDirectory: updateDirectory "Put these files out as an Update on the servers of my group. List is an array of local file names with or without number prefixes. Each version of the system has its own set of update files. 'updates.list' holds the master list. Each update is a fileIn whose name begins with a number. See Utilities class absorbUpdatesFromServer." + | myServers updateStrm lastNum response newNames numStr indexPrefix version versIndex listContents | - | myServers updateStrm lastNum response newNames file numStr indexPrefix listContents version versIndex seq stripped | (self checkNames: (list collect: "Check the names without their numbers" [:each | each copyFrom: (each findFirst: [:c | c isDigit not]) to: each size])) ifFalse: [^ nil]. response := UIManager default chooseFrom: #('Install update' 'Cancel update') title: 'Do you really want to broadcast ', list size printString, ' updates', '\to every Squeak user who updates from ' withCRs, self groupName, '?'. response = 1 ifFalse: [^ nil]. "abort" self openGroup. indexPrefix := (self groupName includes: $*) ifTrue: [(self groupName findTokens: ' ') first] "special for internal updates" ifFalse: ['']. "normal" myServers := self checkServersWithPrefix: indexPrefix andParseListInto: [:x | listContents := x]. myServers size = 0 ifTrue: [self closeGroup. ^ self]. version := SystemVersion current version. versIndex := (listContents collect: [:pair | pair first]) indexOf: version. versIndex = 0 ifTrue: [self inform: 'There is no section in updates.list for your version'. self closeGroup. ^ nil]. "abort" lastNum := (listContents at: versIndex) last last initialIntegerOrNil. versIndex < listContents size ifTrue: [response := UIManager default chooseFrom: #('Make update for an older version' 'Cancel update') title: 'This system, ', SystemVersion current version, ' is not the latest version'. response = 1 ifFalse: [self closeGroup. ^ nil]. numStr := UIManager default request: 'Please confirm or change the starting update number' initialAnswer: (lastNum+1) printString. lastNum := numStr asNumber - 1]. "abort" "Save old copy of updates.list on local disk" FileDirectory default deleteFileNamed: indexPrefix , 'updates.list.bk'. Utilities writeList: listContents toStream: (FileStream fileNamed: indexPrefix , 'updates.list.bk'). "Append names to updates with new sequence numbers" newNames := list with: (lastNum+1 to: lastNum+list size) collect: + [:each :num | | stripped seq | seq := num printString padded: #left to: 4 with: $0. - [:each :num | seq := num printString padded: #left to: 4 with: $0. "strip off any old seq number" stripped := each copyFrom: (each findFirst: [:c | c isDigit not]) to: each size. seq , stripped]. listContents at: versIndex put: {version. (listContents at: versIndex) second , newNames}. "Write a new copy on all servers..." updateStrm := ReadStream on: (String streamContents: [:s | Utilities writeList: listContents toStream: s]). myServers do: [:aServer | + list doWithIndex: [:local :ind | | file | - list doWithIndex: [:local :ind | file := updateDirectory oldFileNamed: local. aServer putFile: file named: (newNames at: ind) retry: true. file close]. updateStrm reset. aServer putFile: updateStrm named: indexPrefix , 'updates.list' retry: true. Transcript show: 'Update succeeded on server ', aServer moniker; cr]. self closeGroup. Transcript cr; show: 'Be sure to test your new update!!'; cr. "rename the file locally" list with: newNames do: [:local :newName | updateDirectory rename: local toBe: newName]. ! Item was changed: ----- Method: MailMessage>>asSendableText (in category 'printing/formatting') ----- asSendableText "break lines in the given string into shorter lines" + | result atAttachment width aString pastHeader | - | result start end pastHeader atAttachment width aString | width := 72. aString := self text. result := WriteStream on: (String new: aString size * 50 // 49). pastHeader := false. atAttachment := false. aString asString linesDo: + [:line | | end start | - [:line | line isEmpty ifTrue: [pastHeader := true]. pastHeader ifTrue: ["(line beginsWith: '--==') ifTrue: [atAttachment := true]." atAttachment ifTrue: ["at or after an attachment line; no more wrapping for the rest of the message" result nextPutAll: line. result cr] ifFalse: [(line beginsWith: '>') ifTrue: ["it's quoted text; don't wrap it" result nextPutAll: line. result cr] ifFalse: ["regular old line. Wrap it to multiple lines " start := 1. "output one shorter line each time through this loop" [start + width <= line size] whileTrue: ["find the end of the line" end := start + width - 1. [end >= start and: [(line at: end + 1) isSeparator not]] whileTrue: [end := end - 1]. end < start ifTrue: ["a word spans the entire width!! " end := start + width - 1]. "copy the line to the output" result nextPutAll: (line copyFrom: start to: end). result cr. "get ready for next iteration" start := end + 1. (line at: start) isSeparator ifTrue: [start := start + 1]]. "write out the final part of the line" result nextPutAll: (line copyFrom: start to: line size). result cr]]] ifFalse: [result nextPutAll: line. result cr]]. ^ result contents! Item was changed: ----- Method: OldSimpleClientSocket class>>httpTestHost:port:url: (in category 'other examples') ----- httpTestHost: hostName port: port url: url "This test fetches a URL from the given host and port." "SimpleClientSocket httpTestHost: 'www.disney.com' port: 80 url: '/'" "Tests URL fetch through a local HTTP proxie server: (SimpleClientSocket httpTestHost: '127.0.0.1' port: 8080 url: 'HTTP://www.exploratorium.edu/index.html')" + | hostAddr s result buf t totalBytes | - | hostAddr s result buf bytes totalBytes t | Transcript cr; show: 'starting http test'; cr. Socket initializeNetwork. hostAddr := NetNameResolver addressForName: hostName timeout: 10. hostAddr = nil ifTrue: [^ self inform: 'Could not find an address for ', hostName]. s := OldSimpleClientSocket new. Transcript show: '---------- Connecting ----------'; cr. s connectTo: hostAddr port: port. s waitForConnectionUntil: "self standardDeadline" (Socket deadlineSecs: 10). (s isConnected) ifFalse: [ s destroy. ^ self inform: 'could not connect']. Transcript show: 'connection open; waiting for data'; cr. s sendCommand: 'GET ', url, ' HTTP/1.0'. s sendCommand: 'User-Agent: Squeak 1.19'. s sendCommand: 'ACCEPT: text/html'. "always accept plain text" s sendCommand: 'ACCEPT: application/octet-stream'. "also accept binary data" s sendCommand: ''. "blank line" result := WriteStream on: (String new: 10000). buf := String new: 10000. totalBytes := 0. + t := Time millisecondsToRun: [ | bytes | - t := Time millisecondsToRun: [ [s isConnected] whileTrue: [ s waitForDataUntil: (Socket deadlineSecs: 5). bytes := s receiveDataInto: buf. 1 to: bytes do: [:i | result nextPut: (buf at: i)]. totalBytes := totalBytes + bytes. Transcript show: totalBytes printString, ' bytes received'; cr]]. s destroy. Transcript show: '---------- Connection Closed ----------'; cr; endEntry. Transcript show: 'http test done; ', totalBytes printString, ' bytes read in '. Transcript show: ((t / 1000.0) roundTo: 0.01) printString, ' seconds'; cr. Transcript show: ((totalBytes asFloat / t) roundTo: 0.01) printString, ' kBytes/sec'; cr. Transcript endEntry. (StringHolder new contents: (result contents)) openLabel: 'HTTP Test Result: URL Contents'. ! Item was changed: ----- Method: SuperSwikiServer>>upLoadProject:members:retry: (in category 'squeaklets') ----- upLoadProject: projectName members: archiveMembers retry: aBool + + archiveMembers do:[:entry| | answer | - | answer | - archiveMembers do:[:entry| ProgressNotification signal: '4:uploadingFile' extra:'(uploading ' translated, entry fileName convertFromSystemString , '...)' translated. answer := self sendToSwikiProjectServer: { 'uploadproject2: ', entry fileName convertFromSystemString convertToEncoding: self encodingName. 'password: ',ProjectPasswordNotification signal. entry contents. }. answer = 'OK' ifFalse:[ self inform:'Server responded ' translated, answer. ^false]. ]. ProgressNotification signal: '4:uploadingFile' extra:''. ^true! Item was changed: ----- Method: OldSocket class>>remoteTestServerTCPOpenClosePutGet (in category 'examples') ----- remoteTestServerTCPOpenClosePutGet "The version of #remoteTestServerTCPOpenClosePutGet using the BSD style accept() mechanism." "Socket remoteTestServerTCPOpenClosePutGet" + | server bytesIWantToSend bytesExpected receiveBuf sendBuf | - | socket server bytesIWantToSend bytesExpected receiveBuf sendBuf checkLength | Transcript show: 'initializing network ... '. self initializeNetworkIfFail: [^Transcript show: 'failed']. Transcript show: 'ok'; cr. server := self newTCP. server listenOn: 54321 backlogSize: 20. server isValid ifFalse: [self error: 'Accept() is not supported']. Transcript show: 'server endpoint created -- run client test in other image'; cr. bytesIWantToSend := 20000. bytesExpected := 80. receiveBuf := String new: 40000. sendBuf := String new: bytesIWantToSend withAll: $x. 1000 timesRepeat: + [ | checkLength socket | + socket := server waitForAcceptUntil: (self deadlineSecs: 300). - [socket := server waitForAcceptUntil: (self deadlineSecs: 300). socket waitForDataUntil: (self deadlineSecs: 5). checkLength := socket receiveDataInto: receiveBuf. checkLength ~= bytesExpected ifTrue: [self halt]. socket sendData: sendBuf. socket waitForSendDoneUntil: (self deadlineSecs: 5). socket closeAndDestroy]. server closeAndDestroy. Transcript cr; show: 'server endpoint destroyed'; cr! Item was changed: ----- Method: HTTPSocket class>>httpGetDocument:args:accept:request: (in category 'proxy settings') ----- httpGetDocument: url args: args accept: mimeType request: requestString "Return the exact contents of a web object. Asks for the given MIME type. If mimeType is nil, use 'text/html'. An extra requestString may be submitted and must end with crlf. The parsed header is saved. Use a proxy server if one has been registered. tk 7/23/97 17:12" "Note: To fetch raw data, you can use the MIME type 'application/octet-stream'." + | serverName serverAddr port bare page index connectToHost connectToPort aStream | - | serverName serverAddr port sock header length bare page list firstData - aStream index connectToHost connectToPort type newUrl | Socket initializeNetwork. bare := (url asLowercase beginsWith: 'http://') ifTrue: [url copyFrom: 8 to: url size] ifFalse: [url]. bare := bare copyUpTo: $#. "remove fragment, if specified" serverName := bare copyUpTo: $/. page := bare copyFrom: serverName size + 1 to: bare size. (serverName includes: $:) ifTrue: [ index := serverName indexOf: $:. port := (serverName copyFrom: index+1 to: serverName size) asNumber. serverName := serverName copyFrom: 1 to: index-1. ] ifFalse: [ port := self defaultPort ]. page size = 0 ifTrue: [page := '/']. "add arguments" args ifNotNil: [page := page, (self argString: args) ]. (self shouldUseProxy: serverName) ifFalse: [ connectToHost := serverName. connectToPort := port ] ifTrue: [ page := 'http://', serverName, ':', port printString, page. "put back together" connectToHost := self httpProxyServer. connectToPort := self httpProxyPort]. serverAddr := NetNameResolver addressForName: connectToHost timeout: 20. serverAddr ifNil: [ ^ 'Could not resolve the server named: ', connectToHost]. + 3 timesRepeat: [ | sock length firstData list type header newUrl | - 3 timesRepeat: [ sock := HTTPSocket new. sock connectTo: serverAddr port: connectToPort. (sock waitForConnectionUntil: (self deadlineSecs: 30)) ifFalse: [ Socket deadServer: connectToHost. sock destroy. ^ 'Server ',connectToHost,' is not responding']. "Transcript cr;show: url; cr. Transcript show: page; cr." sock sendCommand: 'GET ', page, ' HTTP/1.0', CrLf, (mimeType ifNotNil: ['ACCEPT: ', mimeType, CrLf] ifNil: ['']), 'ACCEPT: text/html', CrLf, "Always accept plain text" HTTPBlabEmail, "may be empty" requestString, "extra user request. Authorization" self userAgentString, CrLf, 'Host: ', serverName, ':', port printString, CrLf. "blank line automatically added" list := sock getResponseUpTo: CrLf, CrLf ignoring: String cr. "list = header, CrLf, CrLf, beginningOfData" header := list at: 1. "Transcript show: page; cr; show: header; cr." firstData := list at: 3. header isEmpty ifTrue: [aStream := 'server aborted early'] ifFalse: [ "dig out some headers" sock header: header. length := sock getHeader: 'content-length'. length ifNotNil: [ length := length asNumber ]. type := sock getHeader: 'content-type'. sock responseCode first = $3 ifTrue: [ newUrl := sock getHeader: 'location'. newUrl ifNotNil: [ Transcript show: 'redirecting to ', newUrl; cr. sock destroy. newUrl := self expandUrl: newUrl ip: serverAddr port: connectToPort. ^self httpGetDocument: newUrl args: args accept: mimeType request: requestString] ]. aStream := sock getRestOfBuffer: firstData totalLength: length. "a 400-series error" sock responseCode first = $4 ifTrue: [^ header, aStream contents]. ]. sock destroy. "Always OK to destroy!!" aStream class ~~ String ifTrue: [ ^ MIMEDocument contentType: type content: aStream contents url: url]. aStream = 'server aborted early' ifTrue: [ ^aStream ]. ]. {'HTTPSocket class>>httpGetDocument:args:accept:request:'. aStream. url} inspect. ^'some other bad thing happened!!'! Item was changed: ----- Method: OldSocket class>>clientServerTestUDP2 (in category 'examples') ----- clientServerTestUDP2 "Socket clientServerTestUDP2" + | sock1 sock2 bytesToSend sendBuf receiveBuf t done bytesSent bytesReceived packetsSent packetsReceived | - | sock1 sock2 bytesToSend sendBuf receiveBuf done bytesSent bytesReceived packetsSent packetsReceived t datagramInfo | Transcript show: 'starting client/server UDP test'; cr. Transcript show: 'initializing network ... '. self initializeNetworkIfFail: [^Transcript show: 'failed']. Transcript show: 'ok'; cr. Transcript show: 'creating endpoints'; cr. sock1 := self newUDP. "the sender" sock2 := self newUDP. "the recipient" sock2 setPort: 54321. Transcript show: 'endpoints created'; cr. bytesToSend := 100000000. sendBuf := String new: 4000 withAll: $x. receiveBuf := String new: 2000. done := false. bytesSent := bytesReceived := packetsSent := packetsReceived := 0. t := Time millisecondsToRun: + [ | datagramInfo | + [done] whileFalse: - [[done] whileFalse: [(sock1 sendDone and: [bytesSent < bytesToSend]) ifTrue: [packetsSent := packetsSent + 1. bytesSent := bytesSent + (sock1 sendData: sendBuf toHost: NetNameResolver localHostAddress port: sock2 port)]. sock2 dataAvailable ifTrue: [packetsReceived := packetsReceived + 1. datagramInfo := sock2 receiveUDPDataInto: receiveBuf. bytesReceived := bytesReceived + (datagramInfo at: 1)]. done := bytesSent >= bytesToSend]. sock1 waitForSendDoneUntil: self standardDeadline. bytesReceived := bytesReceived + sock2 discardReceivedData]. Transcript show: 'closing endpoints'; cr. sock1 close. sock2 close. sock1 destroy. sock2 destroy. Transcript show: 'client/server UDP test done; time = ' , t printString; cr. Transcript show: packetsSent printString , ' packets, ' , bytesSent printString , ' bytes sent (' , (bytesSent * 1000 // t) printString , ' Bytes/sec)'; cr. Transcript show: packetsReceived printString , ' packets, ' , bytesReceived printString , ' bytes received (' , (bytesReceived * 1000 // t) printString , ' Bytes/sec)'; cr. Transcript show: (bytesSent // packetsSent) printString , ' bytes/packet, ' , (packetsReceived * 1000 // t) printString , ' packets/sec, ' , (packetsSent - packetsReceived) printString , ' packets dropped'; cr! Item was changed: ----- Method: SuperSwikiServer>>speedTest2 (in category 'testing') ----- speedTest2 "SuperSwikiServer testOnlySuperSwiki speedTest2" "==observed results 10 forks of 10 reads of 88K in 12.7 seconds 100 * 88110 / 12.7 ===> 693779 bytes per second --- 10 forks of 10 reads of 88K in 10.7 seconds 100 * 88110 / 10.7 ===> 823457 bytes per second ---at priority 5 10 forks of 10 reads of 88K in 9.8 seconds 100 * 88110 / 9.8 ===> 899081 bytes per second ===" + | bigAnswer tRealBegin tRealEnd | - | answer bigAnswer tRealBegin tRealEnd | bigAnswer := SharedQueue new. tRealBegin := tRealEnd := Time millisecondClockValue. 10 timesRepeat: [ + [ | answer | - [ answer := SuperSwikiServer testOnlySuperSwiki speedTest1. tRealEnd := Time millisecondClockValue. bigAnswer nextPut: { {tRealBegin. tRealEnd. tRealEnd - tRealBegin}. answer }. ] forkAt: Processor userInterruptPriority. ]. bigAnswer inspect. ! Item was changed: ----- Method: PRServerDirectory>>getLines (in category 'private') ----- getLines "private - answer a collection of lines with the server response" + | url lines string | - | url answer string lines | url := self urlFromServer: self server directories: {'programmatic'} , self directories. url := url , self slash. "" Cursor read + showWhile: [ | answer |"" - showWhile: ["" answer := HTTPClient httpGetDocument: url. string := answer contents. (string beginsWith: '--OK--') ifFalse: [^ nil]]. "" lines := OrderedCollection new. (string allButFirst: 6) linesDo: [:line | lines add: line squeakToIso]. "" ^ lines! Item was changed: ----- Method: ConnectionQueue>>getConnectionOrNil (in category 'public') ----- getConnectionOrNil "Return a connected socket, or nil if no connection has been established." + ^accessSema critical: [ + | result | - | result | - accessSema critical: [ connections isEmpty ifTrue: [result := nil] ifFalse: [ result := connections removeFirst. ((result isValid) and: [result isConnected]) ifFalse: [ "stale connection" result destroy. + result := nil]]. + result]! - result := nil]]]. - ^ result - ! Item was changed: ----- Method: HTTPSocket>>contentsLength: (in category 'as yet unclassified') ----- contentsLength: header "extract the data length from the header. Content-length: 1234<cr><lf>, User may look in headerTokens afterwards." | this | + headerTokens := header findTokens: ParamDelimiters keep: String cr. - headerTokens := header findTokens: ParamDelimiters keep: (String with: CR). 1 to: headerTokens size do: [:ii | this := headerTokens at: ii. (this first asLowercase = $c and: [this asLowercase = 'content-length:']) ifTrue: [ ^ (headerTokens at: ii+1) asNumber]]. ^ nil "not found"! Item was changed: ----- Method: OldSocket class>>remoteTestServerTCPUsingAccept (in category 'examples') ----- remoteTestServerTCPUsingAccept "The version of #remoteTestServer using the BSD style accept() mechanism." "Socket remoteTestServerTCPUsingAccept" + | buffer server socket | - | socket buffer n server | Transcript show: 'initializing network ... '. self initializeNetworkIfFail: [^Transcript show: 'failed']. Transcript show: 'ok'; cr. server := self newTCP. server listenOn: 54321 backlogSize: 4. server isValid ifFalse: [self error: 'Accept() is not supported']. Transcript show: 'server endpoint created -- run client test in other image'; cr. buffer := String new: 40000. 10 timesRepeat: + [ | n | + socket := server waitForAcceptUntil: (self deadlineSecs: 300). - [socket := server waitForAcceptUntil: (self deadlineSecs: 300). [socket isConnected] whileTrue: [socket dataAvailable ifTrue: [n := socket receiveDataInto: buffer. socket sendData: buffer count: n]]]. socket closeAndDestroy. server closeAndDestroy. Transcript cr; show: 'server endpoint destroyed'; cr! Item was changed: ----- Method: UUIDGenerator>>generateOneOrZero (in category 'generator') ----- generateOneOrZero + ^self semaphoreForGenerator - | result | - self semaphoreForGenerator critical: [| value | value := self randomGenerator next. self randomCounter: self randomCounter + 1. self randomCounter > 100000 ifTrue: [self setupRandom]. + value < 0.5 + ifTrue: [0] + ifFalse: [1]].! - result := value < 0.5 - ifTrue: [0] - ifFalse: [1]]. - ^ result! Item was changed: ----- Method: ConnectionQueue>>connectionCount (in category 'public') ----- connectionCount "Return an estimate of the number of currently queued connections. This is only an estimate since a new connection could be made, or an existing one aborted, at any moment." - | count | self pruneStaleConnections. + ^accessSema critical: [connections size]! - accessSema critical: [count := connections size]. - ^ count - ! Item was changed: ----- Method: SuperSwikiServer>>speedTest1 (in category 'testing') ----- speedTest1 "SuperSwikiServer testOnlySuperSwiki speedTest1" + | totalTime answer | - | answer t totalTime | totalTime := [ + answer := (1 to: 10) collect: [ :x | | t | - answer := (1 to: 10) collect: [ :x | t := [answer := self sendToSwikiProjectServer: { 'action: readnamedfile'. 'projectname: xyz.002.pr'. }] timeToRun. {t. answer size} ]. ] timeToRun. ^{totalTime. answer} ! Item was changed: ----- Method: POP3Client>>apopLogin (in category 'private protocol') ----- apopLogin "Attempt to authenticate ourselves to the server without sending the password as cleartext." "For secure authentication, we look for a timestamp in the initial response string we get from the server, and then try the APOP command as specified in RFC 1939. If the initial response from the server is +OK POP3 server ready <1896.697170952 at dbc.mtview.ca.us> we extract the timestamp <1896.697170952 at dbc.mtview.ca.us> then form a string of the form <1896.697170952 at dbc.mtview.ca.us>USERPASSWORD and then send only the MD5 hash of that to the server. Thus the password never hits the wire" + - | timestamp hash | + [ | timestamp hash | - [ "Look for a timestamp in the response we received from the server" timestamp := self lastResponse findTokens: '<>' includes: '@'. timestamp ifNil: [(POP3LoginError protocolInstance: self) signal: 'APOP not supported.']. (Smalltalk includesKey: #MD5) ifTrue: [ hash := ((Smalltalk at: #MD5) hashMessage: ('<', timestamp, '>', self password)) storeStringHex asLowercase. "trim starting 16r and zero pad it to 32 characters if needed" hash := hash padded: #left to: 32 with: $0] ifFalse: [(POP3LoginError protocolInstance: self) signal: 'APOP (MD5) not supported.']. self sendCommand: 'APOP ', self user, ' ', hash. self checkResponse. self logProgress: self lastResponse] on: ProtocolClientError do: [:ex | self close. (LoginFailedException protocolInstance: self) signal: 'Login failed.']! Item was changed: ----- Method: Socket>>sendStreamContents:checkBlock: (in category 'sending') ----- sendStreamContents: stream checkBlock: checkBlock "Send the data in the stream. Close the stream after you are done. After each block of data evaluate checkBlock and abort if it returns false. Usefull for directly sending contents of a file without reading into memory first." + [ - | chunkSize buffer | chunkSize := 5000. buffer := ByteArray new: chunkSize. stream binary. + [stream atEnd and: [checkBlock value]] - [[stream atEnd and: [checkBlock value]] whileFalse: [ buffer := stream next: chunkSize into: buffer. self sendData: buffer]] ensure: [stream close]! Item was changed: ----- Method: ServerDirectory>>upLoadProject:named:resourceUrl:retry: (in category 'squeaklets') ----- upLoadProject: projectFile named: fileNameOnServer resourceUrl: resUrl retry: aBool "Upload the given project file. If it's an archive, upload only the files that are local to the project." + | archive members prefix | - | archive members upload prefix | self isTypeFile ifTrue:[ ^(FileDirectory on: urlObject pathForDirectory) upLoadProject: projectFile named: fileNameOnServer resourceUrl: resUrl retry: aBool]. projectFile isZipArchive ifFalse:[^self putFile: projectFile named: fileNameOnServer retry: aBool]. projectFile binary. archive := ZipArchive new readFrom: projectFile. resUrl last = $/ ifTrue:[prefix := resUrl copyFrom: 1 to: resUrl size-1] "remove last slash" ifFalse:[prefix := resUrl]. prefix := prefix copyFrom: 1 to: (prefix lastIndexOf: $/). + members := archive members select:[:entry| | upload | - members := archive members select:[:entry| "figure out where it's coming from" upload := false. (entry fileName indexOf: $:) = 0 ifTrue:[ upload := true. "one of the core files, e.g., project itself, resource map, meta info" ] ifFalse:[ (entry fileName asLowercase beginsWith: resUrl asLowercase) ifTrue:[ upload := true. entry fileName: (entry fileName copyFrom: prefix size+1 to: entry fileName size). ]. ]. upload]. members := members asArray sort:[:m1 :m2| m1 compressedSize < m2 compressedSize]. ^self upLoadProject: fileNameOnServer members: members retry: aBool.! Item was changed: ----- Method: FileUrl>>pathString (in category 'paths') ----- pathString "Path as it appears in a URL with $/ as delimiter." + + ^String streamContents: [ :s | | first | - | first | - ^String streamContents: [ :s | "isAbsolute ifTrue:[ s nextPut: $/ ]." first := true. self path do: [ :p | first ifFalse: [ s nextPut: $/ ]. first := false. s nextPutAll: p encodeForHTTP ] ]! Item was changed: ----- Method: MailMessage>>rewriteFields:append: (in category 'fields') ----- rewriteFields: aBlock append: appendBlock "Rewrite header fields. The body is not modified. Each field's key and value is reported to aBlock. The block's return value is the replacement for the entire header line. Nil means don't change the line, empty means delete it. After all fields are processed, evaluate appendBlock and append the result to the header." + | old new appendString | - | old new result appendString | self halt: 'this method is out of date. it needs to update body, at the very least. do we really need this now that we have setField:to: and setField:toString: ?!!'. old := ReadStream on: text. new := WriteStream on: (String new: text size). + self fieldsFrom: old do: [ :fName :fValue | | result | - self fieldsFrom: old do: [ :fName :fValue | result := aBlock value: fName value: fValue. result ifNil: [new nextPutAll: fName, ': ', fValue; cr] ifNotNil: [result isEmpty ifFalse: [new nextPutAll: result. result last = Character cr ifFalse: [new cr]]]]. appendString := appendBlock value. appendString isEmptyOrNil ifFalse: [new nextPutAll: appendString. appendString last = Character cr ifFalse: [new cr]]. new cr. "End of header" text := new contents, old upToEnd. ! Item was changed: ----- Method: SMTPClient>>data: (in category 'private protocol') ----- data: messageData "send the data of a message" "DATA <CRLF>" + - | cookedLine | "inform the server we are sending the message data" self sendCommand: 'DATA'. self checkResponse. "process the data one line at a time" + messageData linesDo: [ :messageLine | | cookedLine | - messageData linesDo: [ :messageLine | cookedLine := messageLine. (cookedLine beginsWith: '.') ifTrue: [ "lines beginning with a dot must have the dot doubled" cookedLine := '.', cookedLine ]. self sendCommand: cookedLine ]. "inform the server the entire message text has arrived" self sendCommand: '.'. self checkResponse.! Item was changed: ----- Method: ServerDirectory>>exportUpdatesExcept: (in category 'updates') ----- exportUpdatesExcept: skipList "Into the section of updates.list corresponding to this version, copy all the fileNames in the named updates.list for this group that are more recently numbered." " (ServerDirectory serverInGroupNamed: 'Disney Internal Updates*') exportUpdatesExcept: #(3959). " + | myServers updateStrm response indexPrefix version versIndex lastNum expContents expVersIndex additions listContents | - | myServers updateStrm response seq indexPrefix listContents version versIndex lastNum expContents expVersIndex additions | self openGroup. indexPrefix := (self groupName includes: $*) ifTrue: [(self groupName findTokens: ' ') first] "special for internal updates" ifFalse: ['']. "normal" myServers := self checkServersWithPrefix: indexPrefix andParseListInto: [:x | listContents := x]. myServers size = 0 ifTrue: [self closeGroup. ^ self]. version := SystemVersion current version. versIndex := (listContents collect: [:pair | pair first]) indexOf: version. versIndex = 0 ifTrue: [self inform: 'There is no section in updates.list for your version'. self closeGroup. ^ nil]. "abort" versIndex < listContents size ifTrue: [response := UIManager default chooseFrom: #('Make update from an older version' 'Cancel update') title: 'This system, ', SystemVersion current version, ' is not the latest version'. response = 1 ifFalse: [self closeGroup. ^ nil]]. "abort" "Get the old export updates.list." expContents := Utilities parseListContents: (myServers first getFileNamed: 'updates.list'). expVersIndex := (expContents collect: [:pair | pair first]) indexOf: version. expVersIndex = 0 ifTrue: [self inform: 'There is no section in updates.list for your version'. self closeGroup. ^ nil]. "abort" lastNum := (expContents at: expVersIndex) last isEmpty ifTrue: [0] "no checking if the current list is empty" ifFalse: [(expContents at: expVersIndex) last last initialIntegerOrNil]. "Save old copy of updates.list on local disk" FileDirectory default deleteFileNamed: 'updates.list.bk'. Utilities writeList: expContents toStream: (FileStream fileNamed: 'updates.list.bk'). "Append all fileNames in my list that are not in the export list" additions := OrderedCollection new. (listContents at: versIndex) last do: + [:fileName | | seq | seq := fileName initialIntegerOrNil. - [:fileName | seq := fileName initialIntegerOrNil. (seq > lastNum and: [(skipList includes: seq) not]) ifTrue: [additions addLast: fileName]]. expContents at: expVersIndex put: {version. (expContents at: expVersIndex) last , additions}. (self confirm: 'Do you really want to export ' , additions size printString , ' recent updates?') ifFalse: [self closeGroup. ^ nil]. "abort" "Write a new copy of updates.list on all servers..." updateStrm := ReadStream on: (String streamContents: [:s | Utilities writeList: expContents toStream: s]). myServers do: [:aServer | updateStrm reset. aServer putFile: updateStrm named: 'updates.list' retry: true. Transcript show: 'Update succeeded on server ', aServer moniker; cr]. self closeGroup. Transcript cr; show: 'Be sure to test your new update!!'; cr. ! Item was changed: ----- Method: OldSimpleClientSocket class>>remoteCursorTest (in category 'remote cursor example') ----- remoteCursorTest "This version of the remote cursor test runs both the client and the server code in the same loop." "SimpleClientSocket remoteCursorTest" + | sock1 sock2 samplesToSend t samplesSent | - | sock1 sock2 samplesToSend samplesSent done t | Transcript show: 'starting remote cursor test'; cr. Transcript show: 'initializing network'; cr. Socket initializeNetwork. Transcript show: 'opening connection'; cr. sock1 := OldSimpleClientSocket new. sock2 := OldSimpleClientSocket new. sock1 listenOn: 54321. sock2 connectTo: (NetNameResolver localHostAddress) port: 54321. sock1 waitForConnectionUntil: self standardDeadline. sock2 waitForConnectionUntil: self standardDeadline. (sock1 isConnected) ifFalse: [self error: 'sock1 not connected']. (sock2 isConnected) ifFalse: [self error: 'sock2 not connected']. Transcript show: 'connection established'; cr. samplesToSend := 100. + t := Time millisecondsToRun: [ | done | - t := Time millisecondsToRun: [ samplesSent := 0. done := false. [done] whileFalse: [ (sock1 sendDone and: [samplesSent < samplesToSend]) ifTrue: [ sock1 sendCommand: self sensorStateString. samplesSent := samplesSent + 1]. sock2 dataAvailable ifTrue: [ sock2 getResponse displayOn: Display at: 10 at 10]. done := samplesSent = samplesToSend]]. sock1 destroy. sock2 destroy. Transcript show: 'remote cursor test done'; cr. Transcript show: samplesSent printString, ' samples sent in ', t printString, ' milliseconds'; cr. Transcript show: ((samplesSent * 1000) // t) printString, ' samples/sec'; cr. ! Item was changed: ----- Method: PRServerDirectory>>queryProjectsAndShow: (in category 'testing') ----- queryProjectsAndShow: thingsToSearchForCollection "query the server for all the projects that match thingsToSearchForCollection" + | url arguments string | - | url arguments answer string | url := self urlFromServer: self server directories: {'programmatic'. 'queryprojects'}. arguments := self getPostArgsFromThingsToSearchFor: thingsToSearchForCollection. "" Cursor read + showWhile: [ | answer |"" - showWhile: ["" "answer := HTTPClient httpPostDocument: url args: args." answer := HTTPSocket httpGetDocument: url args: arguments. string := answer contents. (string beginsWith: '--OK--') ifTrue: [^ true]]. "" self inform: ('Server responded: {1}' translated format: {string}). ^ false! Item was changed: ----- Method: ServerDirectory class>>projectServers (in category 'available servers') ----- projectServers "ServerDirectory projectServers" + | projectServers | - | projectServers projectServer | projectServers := OrderedCollection new. + self serverNames do: [ :n | | projectServer | - self serverNames do: [ :n | projectServer := ServerDirectory serverNamed: n. (projectServer isProjectSwiki and: [projectServer isSearchable]) ifTrue: [projectServers add: projectServer]]. ^projectServers! Item was changed: ----- Method: OldSocket class>>remoteTestServerTCPOpenClose1000 (in category 'examples') ----- remoteTestServerTCPOpenClose1000 "The version of #remoteTestServerTCPOpenClose1000 using the BSD style accept() mechanism." "Socket remoteTestServerTCPOpenClose1000" + | server | - | socket server | Transcript show: 'initializing network ... '. self initializeNetworkIfFail: [^Transcript show: 'failed']. Transcript show: 'ok'; cr. server := self newTCP. server listenOn: 54321 backlogSize: 20. server isValid ifFalse: [self error: 'Accept() is not supported']. Transcript show: 'server endpoint created -- run client test in other image'; cr. 1000 timesRepeat: + [ | socket | + socket := server waitForAcceptUntil: (self deadlineSecs: 300). - [socket := server waitForAcceptUntil: (self deadlineSecs: 300). socket closeAndDestroy]. server closeAndDestroy. Transcript cr; show: 'server endpoint destroyed'; cr! Item was changed: ----- Method: PRServerDirectory>>writeProject:inFileNamed:fromDirectory: (in category 'squeaklets') ----- writeProject: aProject inFileNamed: fileNameString fromDirectory: localDirectory "write aProject (a file version can be found in the file named fileNameString in localDirectory)" + | url arguments string | - | url arguments answer string | url := self urlFromServer: self server directories: {'programmatic'. 'uploadproject'}. arguments := self getPostArgsFromProject: aProject fileNamed: fileNameString fromDirectory: localDirectory. "" Cursor read + showWhile: [ | answer |"" - showWhile: ["" answer := HTTPClient httpPostDocument: url args: arguments. "answer := HTTPSocket httpGetDocument: url args: arguments." string := answer contents. (string beginsWith: '--OK--') ifTrue: [^ true]]. "" self inform: ('Server responded: {1}' translated format: {string}). ^ false! Item was changed: ----- Method: PRServerDirectory>>getOnly:ofProjectContents: (in category 'private') ----- getOnly: numberOfBytes ofProjectContents: aString "private - get numberOfBytes of the project contents" + | url args contents | - | url answer contents args | self flag: #todo. "use an LRUCache" url := self urlFromServer: self server directories: {'programmatic'. aString}. "" args := numberOfBytes isNil ifFalse: ['numberOfBytes=' , numberOfBytes asString]. "" Cursor read + showWhile: [ | answer |"" - showWhile: ["" answer := HTTPSocket httpGetDocument: url args: args. contents := answer contents]."" (contents beginsWith: '--OK--') ifFalse: [^ nil]. "" ^ contents allButFirst: 6! Item was changed: ----- Method: ServerDirectory class>>fetchExternalSettingsIn: (in category 'server prefs') ----- fetchExternalSettingsIn: aDirectory "Scan for server configuration files" "ServerDirectory fetchExternalSettingsIn: (FileDirectory default directoryNamed: 'prefs')" + | serverConfDir | - | serverConfDir stream | (aDirectory directoryExists: self serverConfDirectoryName) ifFalse: [^self]. self resetLocalProjectDirectories. serverConfDir := aDirectory directoryNamed: self serverConfDirectoryName. + serverConfDir fileNames do: [:fileName | | stream | - serverConfDir fileNames do: [:fileName | stream := serverConfDir readOnlyFileNamed: fileName. stream ifNotNil: [ [self parseServerEntryFrom: stream] ifError: [:err :rcvr | ]. stream close]]! Item was changed: ----- Method: ServerDirectory>>oldFileOrNoneNamed: (in category 'file directory') ----- oldFileOrNoneNamed: fullName "If the file exists, answer a read-only RemoteFileStream on it. If it doesn't, answer nil. fullName is directory path, and does include name of the server. Or just a simple fileName. Do prefetch the data." + - | file | ^ Cursor wait showWhile: + [ | file |file := self asServerFileNamed: fullName. - [file := self asServerFileNamed: fullName. file readOnly. "file exists ifFalse: [^ nil]." "on the server" file isTypeFile ifTrue: [FileStream oldFileOrNoneNamed: (file fileNameRelativeTo: self)] ifFalse: [self streamOnBeginningOf: file]]! Item was changed: ----- Method: MailComposition>>breakLines:atWidth: (in category 'private') ----- breakLines: aString atWidth: width "break lines in the given string into shorter lines" + | result atAttachment | - | result start end atAttachment | result := WriteStream on: (String new: (aString size * 50 // 49)). atAttachment := false. + aString asString linesDo: [ :line | | start end | - aString asString linesDo: [ :line | (line beginsWith: '====') ifTrue: [ atAttachment := true ]. atAttachment ifTrue: [ "at or after an attachment line; no more wrapping for the rest of the message" result nextPutAll: line. result cr ] ifFalse: [ (line beginsWith: '>') ifTrue: [ "it's quoted text; don't wrap it" result nextPutAll: line. result cr. ] ifFalse: [ "regular old line. Wrap it to multiple lines" start := 1. "output one shorter line each time through this loop" [ start + width <= line size ] whileTrue: [ "find the end of the line" end := start + width - 1. [end >= start and: [ (line at: (end+1)) isSeparator not ]] whileTrue: [ end := end - 1 ]. end < start ifTrue: [ "a word spans the entire width!!" end := start + width - 1 ]. "copy the line to the output" result nextPutAll: (line copyFrom: start to: end). result cr. "get ready for next iteration" start := end+1. (line at: start) isSeparator ifTrue: [ start := start + 1 ]. ]. "write out the final part of the line" result nextPutAll: (line copyFrom: start to: line size). result cr. ]. ]. ]. ^result contents! Item was changed: ----- Method: UUIDGenerator>>makeSeedFromSound (in category 'random seed') ----- makeSeedFromSound + ^[SoundService default randomBitsFromSoundInput: 32] + ifError: [nil].! - | answer | - [answer := SoundService default randomBitsFromSoundInput: 32 - ] ifError: [answer := nil]. - ^answer! Item was changed: ----- Method: ServerDirectory>>upLoadProject:members:retry: (in category 'squeaklets') ----- upLoadProject: projectName members: archiveMembers retry: aBool + | dir m dirName | - | dir okay m dirName idx | m := archiveMembers detect:[:any| any fileName includes: $/] ifNone:[nil]. m == nil ifFalse:[ dirName := m fileName copyUpTo: $/. self createDirectory: dirName. dir := self directoryNamed: dirName]. + archiveMembers do:[:entry| | okay idx | - archiveMembers do:[:entry| ProgressNotification signal: '4:uploadingFile' extra: ('(uploading {1}...)' translated format: {entry fileName}). idx := entry fileName indexOf: $/. okay := (idx > 0 ifTrue:[ dir putFile: entry contentStream named: (entry fileName copyFrom: idx+1 to: entry fileName size) retry: aBool] ifFalse:[ self putFile: entry contentStream named: entry fileName retry: aBool]). (okay == false or: [okay isString]) ifTrue: [ self inform: ('Upload for {1} did not succeed ({2}).' translated format: {entry fileName printString. okay}). ^false]. ]. ProgressNotification signal: '4:uploadingFile' extra:''. ^true! Item was changed: ----- Method: OldSocket class>>remoteTestClientTCPOpenClosePutGet (in category 'examples') ----- remoteTestClientTCPOpenClosePutGet "Socket remoteTestClientTCPOpenClosePutGet" + | number bytesExpected sendBuf receiveBuf t1 serverName | - | checkLength number bytesExpected sendBuf receiveBuf t1 socket bytesReceived serverName | Transcript show: 'starting client/server TCP test'; cr. Transcript show: 'initializing network ... '. self initializeNetworkIfFail: [^Transcript show: 'failed']. Transcript show: 'ok'; cr. serverName := UIManager default request: 'What is your remote Test Server?' initialAnswer: ''. number := 1000. bytesExpected := 20000. sendBuf := String new: 80 withAll: $x. receiveBuf := String new: 50000. t1 := Time millisecondsToRun: [number timesRepeat: + [ | socket checkLength bytesReceived | + socket := self newTCP. - [socket := self newTCP. socket connectTo: (NetNameResolver addressFromString: serverName) port: 54321. socket waitForConnectionUntil: self standardDeadline. socket sendData: sendBuf. socket waitForSendDoneUntil: (self deadlineSecs: 5). socket waitForDataUntil: (self deadlineSecs: 5). bytesReceived := 0. [bytesReceived < bytesExpected] whileTrue: [checkLength := socket receiveDataInto: receiveBuf. bytesReceived := bytesReceived + checkLength]. socket closeAndDestroy]]. Transcript cr; show: 'connects/get/put/close per second ' , (number / t1 * 1000.0) printString; cr!
More information about the Squeak-dev mailing list |