[squeak-dev] The Inbox: Network-tonyg.262.mczcommits at source.squeak.org commits at source.squeak.orgThu Jul 14 14:13:00 UTC 2022
A new version of Network was added to project The Inbox: http://source.squeak.org/inbox/Network-tonyg.262.mcz ==================== Summary ==================== Name: Network-tonyg.262 Author: tonyg Time: 7 June 2022, 9:32:58.541461 am UUID: 510fd136-5da5-43a8-93c3-d5adbe439d14 Ancestors: Network-mt.261 I missed a case in Network-tonyg.260. This change fixes connectTo:waitForConnectionFor: in the same way as the previous fix to connectTo:port:waitForConnectionFor:. =============== Diff against Network-mt.261 =============== Item was removed: - (PackageInfo named: 'Network') preamble: '"This clean all now non working servers" - ServerDirectory resetServers'! Item was removed: - SystemOrganization addCategory: #'Network-UUID'! - SystemOrganization addCategory: #'Network-Url'! - SystemOrganization addCategory: #'Network-URI'! - SystemOrganization addCategory: #'Network-RemoteDirectory'! - SystemOrganization addCategory: #'Network-Protocols'! - SystemOrganization addCategory: #'Network-Exceptions'! - SystemOrganization addCategory: #'Network-MailSending'! - SystemOrganization addCategory: #'Network-Kernel'! - SystemOrganization addCategory: #'Network-RFC822'! Item was removed: - ----- Method: AcornFileDirectory class>>privateFullPathForURI: (in category '*network-uri') ----- - privateFullPathForURI: aURI - "derive the full filepath from aURI" - | path | - path := String streamContents: [ :s | - aURI pathComponents - do: [ :p | s nextPutAll: p ] - separatedBy: [ s nextPut: self pathNameDelimiter ]. - ]. - ^path unescapePercents - ! Item was removed: - Object subclass: #Authorizer - instanceVariableNames: 'users realm' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-Url'! - - !Authorizer commentStamp: '<historical>' prior: 0! - The Authorizer does user authorization checking. Each instance of authorizer keeps track of the realm that it is authorizing for, and the table of authorized users. An authorizer can be asked to return the user name/symbol associated with a userID (which concatenates the username and password from the HTTP request) with the user: method. - ! Item was removed: - ----- Method: Authorizer class>>unauthorizedFor: (in category 'utilities') ----- - unauthorizedFor: realm - ^'HTTP/1.0 401 Unauthorized', self crlf, 'WWW-Authenticate: Basic realm="Squeak/',realm,'"', - String crlfcrlf, '<html><title>Unauthorized</title><body><h2>Unauthorized for ',realm, '</h2></body></html>' - - ! Item was removed: - ----- Method: Authorizer>>encode:password: (in category 'authentication') ----- - encode: nameString password: pwdString - "Encode per RFC1421 of the username:password combination." - - ^(nameString, ':', pwdString) base64Encoded! Item was removed: - ----- Method: Authorizer>>mapFrom:to: (in category 'authentication') ----- - mapFrom: aKey to: aPerson - "Establish a mapping from a RFC 1421 key to a user." - - users isNil ifTrue: [ users := Dictionary new ]. - aPerson - isNil ifTrue: [ users removeKey: aKey ] - ifFalse: [ - users removeKey: (users keyAtValue: aPerson ifAbsent: []) ifAbsent: []. - users at: aKey put: aPerson ] - ! Item was removed: - ----- Method: Authorizer>>mapName:password:to: (in category 'authentication') ----- - mapName: nameString password: pwdString to: aPerson - "Insert/remove the encoding per RFC1421 of the username:password combination into/from the UserMap. DO NOT call this directly, use mapName:password:to: in your ServerAction class. Only it knows how to record the change on the disk!!" - - self mapFrom: (self encode: nameString password: pwdString) to: aPerson - ! Item was removed: - ----- Method: Authorizer>>realm (in category 'realms') ----- - realm - ^realm! Item was removed: - ----- Method: Authorizer>>realm: (in category 'realms') ----- - realm: aString - realm := aString - ! Item was removed: - ----- Method: Authorizer>>user: (in category 'authentication') ----- - user: userId - "Return the requesting user." - ^users at: userId ifAbsent: [ self error: (self class unauthorizedFor: realm) ]! Item was removed: - GenericUrl subclass: #BrowserUrl - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-Url'! - - !BrowserUrl commentStamp: '<historical>' prior: 0! - URLs that instruct a browser to do something.! Item was removed: - ----- Method: BrowserUrl>>hasContents (in category 'downloading') ----- - hasContents - ^true! Item was removed: - ----- Method: BrowserUrl>>retrieveContentsForBrowser: (in category 'downloading') ----- - retrieveContentsForBrowser: aBrowser - ^aBrowser browserUrlContents: locator! Item was removed: - ----- Method: ByteArray>>asSocketAddress (in category '*Network-converting') ----- - asSocketAddress - ^SocketAddress fromOldByteAddress: self! Item was removed: - NetworkError subclass: #ConnectionClosed - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-Exceptions'! - - !ConnectionClosed commentStamp: 'mir 5/12/2003 18:12' prior: 0! - Signals a prematurely closed connection. - ! Item was removed: - Object subclass: #ConnectionQueue - instanceVariableNames: 'portNumber maxQueueLength connections accessSema socket process' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-Kernel'! - - !ConnectionQueue commentStamp: '<historical>' prior: 0! - A ConnectionQueue listens on a given port number and collects a queue of client connections. In order to handle state changes quickly, a ConnectionQueue has its own process that: (a) tries to keep a socket listening on the port whenever the queue isn't already full of connections and (b) prunes stale connections out of the queue to make room for fresh ones. - - The portNumber can be initialized to a collection, in which case all ports will be probed to create a listening socket. Once successfull, the portNumber is set to the chosen port.! Item was removed: - ----- Method: ConnectionQueue class>>portNumber:queueLength: (in category 'instance creation') ----- - portNumber: anInteger queueLength: queueLength - - ^ self new initPortNumber: anInteger queueLength: queueLength - ! Item was removed: - ----- 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." - - self pruneStaleConnections. - ^accessSema critical: [connections size]! Item was removed: - ----- Method: ConnectionQueue>>createListeningSocketWithBacklog: (in category 'private') ----- - createListeningSocketWithBacklog: aNumber - | addressInfo sock | - self portNumbers do: [:trialportNumber | - addressInfo := SocketAddressInformation - forHost: '' - service: trialportNumber asString - flags: SocketAddressInformation passiveFlag - addressFamily: SocketAddressInformation addressFamilyINET4 - socketType: SocketAddressInformation socketTypeStream - protocol: SocketAddressInformation protocolTCP. - sock := [addressInfo first listenWithBacklog: aNumber] ifError: [nil]. - sock ifNotNil: [ - portNumber := trialportNumber. - ^ sock]]. - ^ nil! Item was removed: - ----- Method: ConnectionQueue>>destroy (in category 'public') ----- - destroy - "Terminate the listener process and destroy all sockets in my possesion." - - process ifNotNil: [ - process terminate. - process := nil]. - socket ifNotNil: [ - socket destroy. - socket := nil]. - connections do: [:s | s destroy]. - connections := OrderedCollection new. - ! Item was removed: - ----- Method: ConnectionQueue>>getConnectionOrNil (in category 'public') ----- - getConnectionOrNil - "Return a connected socket, or nil if no connection has been established." - - ^accessSema critical: [ - | result | - connections isEmpty - ifTrue: [result := nil] - ifFalse: [ - result := connections removeFirst. - ((result isValid) and: [result isConnected]) ifFalse: [ "stale connection" - result destroy. - result := nil]]. - result]! Item was removed: - ----- Method: ConnectionQueue>>getConnectionOrNilLenient (in category 'public') ----- - getConnectionOrNilLenient - "Return a connected socket, or nil if no connection has been established." - - ^accessSema critical: [ - | result | - 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 - ]. - ! Item was removed: - ----- Method: ConnectionQueue>>initPortNumber:queueLength: (in category 'private') ----- - initPortNumber: anInteger queueLength: queueLength - "Private!! Initialize the receiver to listen on the given port number. Up to queueLength connections will be queued." - - portNumber := anInteger. - maxQueueLength := queueLength. - connections := OrderedCollection new. - accessSema := Semaphore forMutualExclusion. - socket := nil. - process := [self listenLoop] newProcess. - process priority: Processor highIOPriority. - process resume. - ! Item was removed: - ----- Method: ConnectionQueue>>isValid (in category 'public') ----- - isValid - ^process notNil! Item was removed: - ----- Method: ConnectionQueue>>listenLoop (in category 'private') ----- - listenLoop - "Private!! This loop is run in a separate process. It will establish up to maxQueueLength connections on the given port." - "Details: When out of sockets or queue is full, retry more frequently, since a socket may become available, space may open in the queue, or a previously queued connection may be aborted by the client, making it available for a fresh connection." - "Note: If the machine is disconnected from the network while the server is running, the currently waiting socket will go from 'isWaitingForConnection' to 'unconnected', and attempts to create new sockets will fail. When this happens, delete the broken socket and keep trying to create a socket in case the network connection is re-established. Connecting and disconnecting was tested under PPP on Mac system 8.1. It is not if this will work on other platforms." - - - | newConnection | - "We'll accept four simultanous connections at the same time" - NetNameResolver useOldNetwork - ifFalse: [ socket := self createListeningSocketWithBacklog: 4 ] - ifTrue: [ - socket := Socket newTCP. - socket listenOn: portNumber backlogSize: 4 ]. - "If the listener is not valid then the we cannot use the - BSD style accept() mechanism." - socket isValid ifFalse: [^self oldStyleListenLoop]. - [ - socket isValid ifFalse: [ - "socket has stopped listening for some reason" - socket destroy. - (Delay forMilliseconds: 10) wait. - ^self listenLoop ]. - newConnection := socket - waitForAcceptFor: 10 - ifTimedOut: [ nil ]. - (newConnection notNil and: [newConnection isConnected]) ifTrue: [ - accessSema critical: [connections addLast: newConnection.]. - newConnection := nil. - self changed]. - self pruneStaleConnections] repeat! Item was removed: - ----- Method: ConnectionQueue>>oldStyleListenLoop (in category 'private') ----- - oldStyleListenLoop - "Private!! This loop is run in a separate process. It will establish up to maxQueueLength connections on the given port." - "Details: When out of sockets or queue is full, retry more frequently, since a socket may become available, space may open in the queue, or a previously queued connection may be aborted by the client, making it available for a fresh connection." - "Note: If the machine is disconnected from the network while the server is running, the currently waiting socket will go from 'isWaitingForConnection' to 'unconnected', and attempts to create new sockets will fail. When this happens, delete the broken socket and keep trying to create a socket in case the network connection is re-established. Connecting and disconnecting was tested under PPP on Mac system 8.1. It is not if this will work on other platforms." - - [ - ((socket == nil) and: [connections size < maxQueueLength]) ifTrue: [ - "try to create a new socket for listening" - socket := Socket createIfFail: [nil]]. - - socket == nil - ifTrue: [(Delay forMilliseconds: 100) wait] - ifFalse: [ - socket isUnconnected ifTrue: [socket listenOn: portNumber]. - socket - waitForConnectionFor: 10 - ifTimedOut: [ - socket isConnected - ifTrue: [ "connection established" - accessSema critical: [connections addLast: socket]. - socket := nil] - ifFalse: [ - socket isWaitingForConnection - ifFalse: [socket destroy. socket := nil]]]]. "broken socket; start over" - self pruneStaleConnections] repeat - ! Item was removed: - ----- Method: ConnectionQueue>>portNumber (in category 'public') ----- - portNumber - ^ portNumber isCollection - ifTrue: [portNumber first] - ifFalse: [portNumber]! Item was removed: - ----- Method: ConnectionQueue>>portNumberOrNil (in category 'public') ----- - portNumberOrNil - "Answer nil while actual port has not been established" - ^ portNumber isCollection - ifFalse: [portNumber]! Item was removed: - ----- Method: ConnectionQueue>>portNumbers (in category 'public') ----- - portNumbers - ^ portNumber isCollection - ifTrue: [portNumber] - ifFalse: [{portNumber}]! Item was removed: - ----- 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." - - 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 removed: - NetworkError subclass: #ConnectionRefused - instanceVariableNames: 'host port' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-Exceptions'! - - !ConnectionRefused commentStamp: 'mir 5/12/2003 18:14' prior: 0! - Signals that a connection to the specified host and port was refused. - - host host which refused the connection - port prot to which the connection was refused - ! Item was removed: - ----- Method: ConnectionRefused class>>host:port: (in category 'instance creation') ----- - host: addressOrHostName port: portNumber - ^ self new host: addressOrHostName port: portNumber! Item was removed: - ----- Method: ConnectionRefused>>host (in category 'accessing') ----- - host - ^ host! Item was removed: - ----- Method: ConnectionRefused>>host:port: (in category 'accessing') ----- - host: addressOrHostName port: portNumber - host := addressOrHostName. - port := portNumber! Item was removed: - ----- Method: ConnectionRefused>>port (in category 'accessing') ----- - port - ^ port! Item was removed: - NetworkError subclass: #ConnectionTimedOut - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-Exceptions'! - - !ConnectionTimedOut commentStamp: 'mir 5/12/2003 18:14' prior: 0! - Signals that a connection attempt timed out. - ! Item was removed: - ----- Method: DateAndTime>>asMailMessageString (in category '*Network-Url') ----- - asMailMessageString - "According to RFC 822: https://tools.ietf.org/html/rfc822#section-5" - - | result | - result := WriteStream on: (String new: 30). - - result - nextPutAll: self dayOfWeekAbbreviation; - nextPut: $,; - space; - nextPutAll: (self dayOfMonth asString padded: #left to: 2 with: $0); - space; - nextPutAll: self monthAbbreviation; - space; - nextPutAll: self year asString; - space. - - self printHMSOn: result. - - result space. - - result - nextPutAll: (self offset negative ifTrue: ['-'] ifFalse: ['+']); - nextPutAll: (self offset abs hours asString padded: #left to: 2 with: $0); - nextPutAll: (self offset abs minutes asString padded: #left to: 2 with: $0). - - ^ result contents! Item was removed: - ----- Method: DosFileDirectory class>>privateFullPathForURI: (in category '*network-uri') ----- - privateFullPathForURI: aURI - | path | - path := aURI path unescapePercents. - - "Check for drive notation (a: etc)" - path size > 1 - ifTrue: [ - ((path at: 3) = $:) - ifTrue: [path := path copyFrom: 2 to: path size] - ifFalse: [ - "All other cases should be network path names (\\xxx\sdsd etc)" - path := '/' , path]]. - - ^(path copyReplaceAll: '/' with: self slash) unescapePercents! Item was removed: - ----- Method: DosFileDirectory>>uriPathToPlatformPath: (in category '*network-uri') ----- - uriPathToPlatformPath: aString - "Convert a URI path (w/ forward slashes) into a platform path if necessary. - Also make sure we deal properly with shares vs. drives" - | parts path | - path := aString unescapePercents. - parts := path findTokens: '/'. - (parts first endsWith: ':') ifTrue:[ - "it's a drive - compose c:\foo\bar" - ^path allButFirst copyReplaceAll: '/' with: '\' - ] ifFalse:[ - "it's a share - compose \\share\foo\bar" - ^'\', (path copyReplaceAll: '/' with: '\') - ].! Item was removed: - TelnetProtocolClient subclass: #FTPClient - instanceVariableNames: 'dataSocket' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-Protocols'! - - !FTPClient commentStamp: 'mir 5/12/2003 17:55' prior: 0! - A minimal FTP client program. Could store all state in inst vars, and use an instance to represent the full state of a connection in progress. But simpler to do all that in one method and have it be a complete transaction. - - Always operates in passive mode (PASV). All connections are initiated from client in order to get through firewalls. - - See ServerDirectory openFTP, ServerDirectory getFileNamed:, ServerDirectory putFile:named: for examples of use. - - See TCP/IP, second edition, by Dr. Sidnie Feit, McGraw-Hill, 1997, Chapter 14, p311.! Item was removed: - ----- Method: FTPClient class>>defaultPortNumber (in category 'accessing') ----- - defaultPortNumber - ^21! Item was removed: - ----- Method: FTPClient class>>logFlag (in category 'accessing') ----- - logFlag - ^#ftp! Item was removed: - ----- Method: FTPClient class>>rawResponseCodes (in category 'accessing') ----- - rawResponseCodes - #(200 'Command okay.' - 500 'Syntax error, command unrecognized. This may include errors such as command line too long.' - 501 'Syntax error in parameters or arguments.' - 202 'Command not implemented, superfluous at this site.' - 502 'Command not implemented.' - 503 'Bad sequence of commands.' - 504 'Command not implemented for that parameter.' - 110 'Restart marker reply. In this case, the text is exact and not left to the particular implementation; it must read: MARK yyyy = mmmm Where yyyy is User-process data stream marker, and mmmm server''s equivalent marker (note the spaces between markers and "=").' - 211 'System status, or system help reply.' - 212 'Directory status.' - 213 'File status.' - 214 'Help message. On how to use the server or the meaning of a particular non-standard command. This reply is useful only to the human user.' - 215 'NAME system type. Where NAME is an official system name from the list in the Assigned Numbers document.' - 120 'Service ready in nnn minutes.' - - 220 'Service ready for new user.' - 221 'Service closing control connection. Logged out if appropriate.' - 421 'Service not available, closing control connection. This may be a reply to any command if the service knows it must shut down.' - 125 'Data connection already open; transfer starting.' - 225 'Data connection open; no transfer in progress.' - 425 'Can''t open data connection.' - 226 'Closing data connection. Requested file action successful (for example, file transfer or file abort).' - 426 'Connection closed; transfer aborted.' - 227 'Entering Passive Mode (h1,h2,h3,h4,p1,p2).' - - 230 'User logged in, proceed.' - 530 'Not logged in.' - 331 'User name okay, need password.' - 332 'Need account for login.' - 532 'Need account for storing files.' - 150 'File status okay; about to open data connection.' - 250 'Requested file action okay, completed.' - 257 '"PATHNAME" created.' - 350 'Requested file action pending further information.' - 450 'Requested file action not taken. File unavailable (e.g., file busy).' - 550 'Requested action not taken. File unavailable (e.g., file not found, no access).' - 451 'Requested action aborted. Local error in processing.' - 551 'Requested action aborted. Page type unknown.' - 452 'Requested action not taken. Insufficient storage space in system.' - 552 'Requested file action aborted. Exceeded storage allocation (for current directory or dataset).' - 553 'Requested action not taken. File name not allowed.') - ! Item was removed: - ----- Method: FTPClient>>abortDataConnection (in category 'protocol') ----- - abortDataConnection - self sendCommand: 'ABOR'. - self closeDataSocket! Item was removed: - ----- Method: FTPClient>>ascii (in category 'protocol') ----- - ascii - self sendCommand: 'TYPE A'. - self lookForCode: 200! Item was removed: - ----- Method: FTPClient>>binary (in category 'protocol') ----- - binary - self sendCommand: 'TYPE I'. - self lookForCode: 200! Item was removed: - ----- Method: FTPClient>>changeDirectoryTo: (in category 'protocol') ----- - changeDirectoryTo: newDirName - self sendCommand: 'CWD ' , newDirName. - self checkResponse. - ! Item was removed: - ----- Method: FTPClient>>closeDataSocket (in category 'private') ----- - closeDataSocket - self dataSocket - ifNotNil: [ - self dataSocket closeAndDestroy. - self dataSocket: nil] - ! Item was removed: - ----- Method: FTPClient>>dataSocket (in category 'private') ----- - dataSocket - ^dataSocket! Item was removed: - ----- Method: FTPClient>>dataSocket: (in category 'private') ----- - dataSocket: aSocket - dataSocket := aSocket! Item was removed: - ----- Method: FTPClient>>deleteDirectory: (in category 'protocol') ----- - deleteDirectory: dirName - self sendCommand: 'RMD ' , dirName. - self checkResponse. - ! Item was removed: - ----- Method: FTPClient>>deleteFileNamed: (in category 'protocol') ----- - deleteFileNamed: fileName - self sendCommand: 'DELE ' , fileName. - self checkResponse. - ! Item was removed: - ----- Method: FTPClient>>get:dataInto: (in category 'private protocol') ----- - get: limit dataInto: dataStream - "Reel in data until the server closes the connection or the limit is reached. - At the same time, watch for errors on otherSocket." - - | buf bytesRead currentlyRead | - currentlyRead := 0. - buf := String new: 4000. - [currentlyRead < limit and: - [self dataSocket isConnected or: [self dataSocket dataAvailable]]] - whileTrue: [ - self checkForPendingError. - bytesRead := self dataSocket receiveDataWithTimeoutInto: buf. - 1 to: (bytesRead min: (limit - currentlyRead)) do: [:ii | dataStream nextPut: (buf at: ii)]. - currentlyRead := currentlyRead + bytesRead]. - dataStream reset. "position: 0." - ^ dataStream! Item was removed: - ----- Method: FTPClient>>getData (in category 'private protocol') ----- - getData - - | dataStream | - dataStream := RWBinaryOrTextStream on: (String new: 4000). - self getDataInto: dataStream. - self closeDataSocket. - ^dataStream contents - ! Item was removed: - ----- Method: FTPClient>>getDataInto: (in category 'private protocol') ----- - getDataInto: dataStream - "Reel in all data until the server closes the connection. At the same time, watch for errors on otherSocket. Don't know how much is coming. Put the data on the stream." - - | buf bytesRead | - buf := String new: 4000. - [self dataSocket isConnected or: [self dataSocket dataAvailable]] - whileTrue: [ - self checkForPendingError. - bytesRead := self dataSocket receiveDataWithTimeoutInto: buf. - 1 to: bytesRead do: [:ii | dataStream nextPut: (buf at: ii)]]. - dataStream reset. "position: 0." - ^ dataStream! Item was removed: - ----- Method: FTPClient>>getDirectory (in category 'protocol') ----- - getDirectory - | dirList | - self openPassiveDataConnection. - self sendCommand: 'LIST'. - dirList := self getData. - self checkResponse. - self checkResponse. - ^dirList - ! Item was removed: - ----- Method: FTPClient>>getFileList (in category 'protocol') ----- - getFileList - | dirList | - self openPassiveDataConnection. - self sendCommand: 'NLST'. - dirList := self getData. - self checkResponse. - self checkResponse. - ^dirList - ! Item was removed: - ----- Method: FTPClient>>getFileNamed: (in category 'protocol') ----- - getFileNamed: remoteFileName - | data | - self openPassiveDataConnection. - self sendCommand: 'RETR ', remoteFileName. - [self checkResponse] - on: TelnetProtocolError - do: [:ex | - self closeDataSocket. - ex pass]. - data := self getData. - self checkResponse. - ^data - ! Item was removed: - ----- Method: FTPClient>>getFileNamed:into: (in category 'protocol') ----- - getFileNamed: remoteFileName into: dataStream - self openPassiveDataConnection. - self sendCommand: 'RETR ', remoteFileName. - [self checkResponse] - on: TelnetProtocolError - do: [:ex | - self closeDataSocket. - ex pass]. - self getDataInto: dataStream. - self closeDataSocket. - self checkResponse! Item was removed: - ----- Method: FTPClient>>getPartial:fileNamed:into: (in category 'protocol') ----- - getPartial: limit fileNamed: remoteFileName into: dataStream - | data | - self openPassiveDataConnection. - self sendCommand: 'RETR ', remoteFileName. - [self checkResponse] - on: TelnetProtocolError - do: [:ex | - self closeDataSocket. - ex pass]. - data := self get: limit dataInto: dataStream. - self abortDataConnection. - ^data - ! Item was removed: - ----- Method: FTPClient>>getWorkingDirectory (in category 'protocol') ----- - getWorkingDirectory - | dirList | - self openPassiveDataConnection. - self sendCommand: 'PWD'. - dirList := self getData. - self checkResponse. - self checkResponse. - ^dirList - ! Item was removed: - ----- Method: FTPClient>>initiateSession (in category 'private') ----- - initiateSession - "EHLO <SP> <domain> <CRLF>" - - self sendCommand: 'FEAT'. - self checkResponse. - - self parseCapabilities: self lastResponse lines allButFirst allButLast. - ! Item was removed: - ----- Method: FTPClient>>login (in category 'private') ----- - login - - self initiateSession. - - self user ifNil: [^self]. - - ["repeat both USER and PASS since some servers require it" - self sendCommand: 'USER ', self user. - - "331 Password required" - self lookForCode: 331. - - self sendCommand: 'PASS ', self password."will ask user, if needed. An extra delight is that either accepting an empty string or cancelling the dialog will return an empty string. So how do we know whether to try to log in with an empty password or give up?" - - "230 User logged in" - ([self lookForCode: 230.] - on: TelnetProtocolError - do: [false]) == false - ] whileTrue: [ - (LoginFailedException protocolInstance: self) signal: self lastResponse] - - ! Item was removed: - ----- Method: FTPClient>>loginUser:password: (in category 'protocol') ----- - loginUser: userName password: passwdString - - self user: userName. - self password: passwdString. - - self login! Item was removed: - ----- 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." - - - "check for multi-line response" - (self lastResponse size > 3 - and: [(self lastResponse at: 4) = $-]) - ifTrue: "Discard continuation lines." - [ | headToDiscard | - 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 removed: - ----- Method: FTPClient>>makeDirectory: (in category 'protocol') ----- - makeDirectory: newDirName - self sendCommand: 'MKD ' , newDirName. - self checkResponse. - ! Item was removed: - ----- Method: FTPClient>>openDataSocket:port: (in category 'protocol') ----- - openDataSocket: remoteHostAddress port: dataPort - dataSocket := Socket new. - dataSocket connectTo: remoteHostAddress port: dataPort! Item was removed: - ----- Method: FTPClient>>openPassiveDataConnection (in category 'private protocol') ----- - openPassiveDataConnection - | portInfo list dataPort remoteHostAddress | - self sendCommand: 'PASV'. - self lookForCode: 227 ifDifferent: [:response | (TelnetProtocolError protocolInstance: self) signal: 'Could not enter passive mode: ' , response]. - portInfo := (self lastResponse findTokens: '()') at: 2. - list := portInfo findTokens: ','. - remoteHostAddress := NetNameResolver addressForName: (list at: 1) - , '.' - , (list at: 2) , '.' - , (list at: 3) , '.' - , (list at: 4) timeout: 30. - dataPort := (list at: 5) asNumber * 256 + (list at: 6) asNumber. - self openDataSocket: remoteHostAddress port: dataPort! Item was removed: - ----- Method: FTPClient>>passive (in category 'protocol') ----- - passive - self sendCommand: 'PASV'. - self lookForCode: 227! Item was removed: - ----- Method: FTPClient>>putFileNamed:as: (in category 'protocol') ----- - putFileNamed: filePath as: fileNameOnServer - "FTP a file to the server." - - - | fileStream | - fileStream := FileStream readOnlyFileNamed: filePath. - fileStream - ifNil: [(FileDoesNotExistException fileName: filePath) signal]. - self putFileStreamContents: fileStream as: fileNameOnServer - ! Item was removed: - ----- Method: FTPClient>>putFileStreamContents:as: (in category 'protocol') ----- - putFileStreamContents: fileStream as: fileNameOnServer - "FTP a file to the server." - - - self openPassiveDataConnection. - self sendCommand: 'STOR ', fileNameOnServer. - - fileStream reset. - - [self sendStreamContents: fileStream] - ensure: [self closeDataSocket]. - - self checkResponse. - self checkResponse. - ! Item was removed: - ----- Method: FTPClient>>pwd (in category 'protocol') ----- - pwd - | result | - self sendCommand: 'PWD'. - self lookForCode: 257. - result := self lastResponse. - ^result copyFrom: (result indexOf: $")+1 to: (result lastIndexOf: $")-1! Item was removed: - ----- Method: FTPClient>>quit (in category 'protocol') ----- - quit - self sendCommand: 'QUIT'. - self close! Item was removed: - ----- Method: FTPClient>>removeFileNamed: (in category 'protocol') ----- - removeFileNamed: remoteFileName - self sendCommand: 'DELE ', remoteFileName. - self checkResponse. - ! Item was removed: - ----- Method: FTPClient>>renameFileNamed:to: (in category 'protocol') ----- - renameFileNamed: oldFileName to: newFileName - self sendCommand: 'RNFR ' , oldFileName. - self lookForCode: 350. - self sendCommand: 'RNTO ' , newFileName. - self lookForCode: 250! Item was removed: - ----- Method: FTPClient>>sendStreamContents: (in category 'private') ----- - sendStreamContents: aStream - self dataSocket sendStreamContents: aStream checkBlock: [self checkForPendingError. true]! Item was removed: - ----- Method: FTPClient>>wantsStarttls (in category 'private testing') ----- - wantsStarttls - - ^ false! Item was removed: - Error subclass: #FTPConnectionException - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-Protocols'! Item was removed: - ----- Method: FTPConnectionException>>defaultAction (in category 'handling') ----- - defaultAction - - self resume! Item was removed: - ----- Method: FTPConnectionException>>isResumable (in category 'handling') ----- - isResumable - - ^true! Item was removed: - ----- Method: FileDirectory class>>contentStreamForURI: (in category '*network-uri') ----- - contentStreamForURI: aURI - | fullPath fileDir | - fullPath := self fullPathForURI: aURI. - fileDir := self forFileName: fullPath. - " ^fileDir readOnlyFileNamed: (self localNameFor: fullPath)" - ^StandardFileStream readOnlyFileNamed: fullPath - ! Item was removed: - ----- Method: FileDirectory class>>directoryEntryForURI: (in category '*network-uri') ----- - directoryEntryForURI: aURI - ^ self directoryEntryFor: (self fullPathForURI: aURI)! Item was removed: - ----- Method: FileDirectory class>>fullPathForURI: (in category '*network-uri') ----- - fullPathForURI: aURI - ^self activeDirectoryClass privateFullPathForURI: (FileDirectory default uri resolveRelativeURI: aURI)! Item was removed: - ----- Method: FileDirectory class>>privateFullPathForURI: (in category '*network-uri') ----- - privateFullPathForURI: aURI - ^(aURI path copyReplaceAll: '/' with: self slash) unescapePercents! Item was removed: - ----- Method: FileDirectory class>>retrieveMIMEDocument: (in category '*network-uri') ----- - retrieveMIMEDocument: uri - | file | - file := [self contentStreamForURI: uri] - on: FileDoesNotExistException do:[:ex| ex return: nil]. - file ifNotNil: [^MIMEDocument contentType: (MIMEDocument guessTypeFromName: uri) content: file contents url: uri]. - ^nil! Item was removed: - ----- Method: FileDirectory class>>uri: (in category '*network-uri') ----- - uri: aURI - ^self on: (FileDirectory fullPathForURI: aURI)! Item was removed: - ----- Method: FileDirectory>>asUrl (in category '*network-url') ----- - asUrl - "Convert my path into a file:// type url - a FileUrl." - - ^FileUrl pathParts: (self pathParts copyWith: '')! Item was removed: - ----- Method: FileDirectory>>pathFromURI: (in category '*network-uri') ----- - pathFromURI: aString - | path | - aString class == Array ifTrue:["bullet-proofing" - ^FileDirectory pathFrom: {self pathName}, aString]. - "To support paths like foo/bar/user#2.doc, use #allButScheme instead of #path" - path := (self uri resolveRelativeURI: aString) allButScheme. - ^self uriPathToPlatformPath: path - ! Item was removed: - ----- Method: FileDirectory>>uri (in category '*network-uri') ----- - uri - "Convert my path into a file:// type url. Use slash instead of the local delimiter (:), and convert odd characters to %20 notation." - - "If slash (/) is not the file system delimiter, encode slashes before converting." - | list | - list := self pathParts. - ^(String streamContents: [:strm | - strm nextPutAll: 'file:'. - list do: [:each | strm nextPut: $/; nextPutAll: each encodeForHTTP]. - strm nextPut: $/]) asURI! Item was removed: - ----- Method: FileDirectory>>uriPathToPlatformPath: (in category '*network-uri') ----- - uriPathToPlatformPath: aString - "Convert a URI path (w/ forward slashes) into a platform path if necessary" - ^aString! Item was removed: - ----- Method: FileStream>>asUrl (in category '*network-url') ----- - asUrl - "Convert my path into a file:// type url - a FileUrl." - - ^FileUrl pathParts: (self directory pathParts copyWith: self localName)! Item was removed: - ----- Method: FileStream>>uri (in category '*network-uri') ----- - uri - ^self directory uri resolveRelativeURI: self localName! Item was removed: - Url subclass: #FileUrl - instanceVariableNames: 'host path isAbsolute' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-Url'! - - !FileUrl commentStamp: 'gk 10/21/2005 10:58' prior: 0! - This class models a file URL according to (somewhat) RFC1738, see http://www.w3.org/Addressing/rfc1738.txt - - Here is the relevant part of the RFC: - - 3.10 FILES - - The file URL scheme is used to designate files accessible on a - particular host computer. This scheme, unlike most other URL schemes, - does not designate a resource that is universally accessible over the - Internet. - - A file URL takes the form: - - file://<host>/<path> - - where <host> is the fully qualified domain name of the system on - which the <path> is accessible, and <path> is a hierarchical - directory path of the form <directory>/<directory>/.../<name>. - - For example, a VMS file - - DISK$USER:[MY.NOTES]NOTE123456.TXT - - might become - - <URL:file://vms.host.edu/disk$user/my/notes/note12345.txt> - - As a special case, <host> can be the string "localhost" or the empty - string; this is interpreted as `the machine from which the URL is - being interpreted'. - - The file URL scheme is unusual in that it does not specify an - Internet protocol or access method for such files; as such, its - utility in network protocols between hosts is limited. - - From the above we can conclude that the RFC says that the <path> part never starts or ends with a slash and is always absolute. If the last name can be a directory instead of a file is not specified clearly. - - The path is stored as a SequenceableCollection of path parts. - - Notes regarding non RFC features in this class: - - - If the last path part is the empty string, then the FileUrl is referring to a directory. This is also shown with a trailing slash when converted to a String. - - - The FileUrl has an attribute isAbsolute which signals if the path should be considered absolute or relative to the current directory. This distinction is not visible in the String representation of FileUrl, since the RFC does not have that. - - - Fragment is supported (kept for historical reasons) - - ! Item was removed: - ----- Method: FileUrl class>>absoluteFromText: (in category 'instance creation') ----- - absoluteFromText: aString - "Method that can be called explicitly to create a FileUrl." - - ^self new privateInitializeFromText: aString! Item was removed: - ----- Method: FileUrl class>>host:pathParts:isAbsolute: (in category 'instance creation') ----- - host: aHost pathParts: aCollectionOfPathParts isAbsolute: aBoolean - "Create a FileUrl." - - ^self new host: aHost pathParts: aCollectionOfPathParts isAbsolute: aBoolean! Item was removed: - ----- Method: FileUrl class>>pathParts: (in category 'instance creation') ----- - pathParts: aCollectionOfPathParts - "Create a FileUrl." - - ^self host: nil pathParts: aCollectionOfPathParts isAbsolute: true! Item was removed: - ----- Method: FileUrl class>>pathParts:isAbsolute: (in category 'instance creation') ----- - pathParts: aCollectionOfPathParts isAbsolute: aBoolean - "Create a FileUrl." - - ^self host: nil pathParts: aCollectionOfPathParts isAbsolute: aBoolean! Item was removed: - ----- Method: FileUrl class>>schemeName (in category 'constants') ----- - schemeName - ^'file'! Item was removed: - ----- Method: FileUrl>>default (in category 'downloading') ----- - default - "Use the default local Squeak file directory." - - | local | - local := self class pathParts: (FileDirectory default pathParts), #('') isAbsolute: true. - self privateInitializeFromText: self pathString relativeTo: local. - "sets absolute also"! Item was removed: - ----- Method: FileUrl>>directoryUrl (in category 'access') ----- - directoryUrl - "The path always has at least one element so this works." - - ^self copy path: (path copyFrom: 1 to: path size - 1)! Item was removed: - ----- Method: FileUrl>>fileName (in category 'access') ----- - fileName - "Return the last part of the path, - most often a filename but can also be a directory." - - ^self path last! Item was removed: - ----- Method: FileUrl>>firstPartIsDriveLetter (in category 'testing') ----- - firstPartIsDriveLetter - "Return true if the first part of the path is a letter - followed by a $: like 'C:' " - - | firstPart | - path isEmpty ifTrue: [^false]. - firstPart := path first. - ^firstPart size = 2 and: [ - firstPart first isLetter - and: [firstPart last = $:]]! Item was removed: - ----- Method: FileUrl>>hasContents (in category 'downloading') ----- - hasContents - ^true! Item was removed: - ----- Method: FileUrl>>hasSameSchemeSpecificPartAs: (in category 'comparing') ----- - hasSameSchemeSpecificPartAs: anotherUrl - - self host = anotherUrl host ifFalse: [^ false]. - self path = anotherUrl path ifFalse: [^ false]. - ^ true! Item was removed: - ----- Method: FileUrl>>hash (in category 'comparing') ----- - hash - - ^ (fragment hash bitXor: host hash) bitXor: path hash! Item was removed: - ----- Method: FileUrl>>host (in category 'accessing') ----- - host - "Return the host name, either 'localhost', '', or a fully qualified domain name." - - ^host ifNil: ['']! Item was removed: - ----- Method: FileUrl>>host: (in category 'accessing') ----- - host: hostName - "Set the host name, either 'localhost', '', or a fully qualified domain name." - - host := hostName! Item was removed: - ----- Method: FileUrl>>host:pathParts:isAbsolute: (in category 'private-initialization') ----- - host: aHostString pathParts: aCollection isAbsolute: aBoolean - - host := aHostString. - path := aCollection. - isAbsolute := aBoolean! Item was removed: - ----- Method: FileUrl>>initializeFromPathString: (in category 'private-initialization') ----- - initializeFromPathString: aPathString - "<aPathString> is a file path as a String. - We construct a path collection using various heuristics." - - | pathString hasDriveLetter | - pathString := aPathString. - pathString isEmpty ifTrue: [pathString := '/']. - path := (pathString findTokens: '/') collect: [:token | token unescapePercents]. - - "A path like 'C:' refers in practice to 'c:/'" - ((pathString endsWith: '/') or: - [(hasDriveLetter := self firstPartIsDriveLetter) and: [path size = 1]]) - ifTrue: [path add: '']. - - "Decide if we are absolute by checking for leading $/ or - beginning with drive letter. Smarts for other OSes?" - self isAbsolute: ((pathString beginsWith: '/') - or: [hasDriveLetter ifNil: [self firstPartIsDriveLetter]])! Item was removed: - ----- Method: FileUrl>>isAbsolute (in category 'accessing') ----- - isAbsolute - "Should the path be considered absolute to - the filesystem instead of relative to the default directory?" - - ^isAbsolute! Item was removed: - ----- Method: FileUrl>>isAbsolute: (in category 'accessing') ----- - isAbsolute: aBoolean - "Set if the path should be considered absolute to - the filesystem instead of relative to the default directory." - - isAbsolute := aBoolean! Item was removed: - ----- Method: FileUrl>>path (in category 'accessing') ----- - path - "Return an ordered collection of the path elements." - - ^path! Item was removed: - ----- Method: FileUrl>>path: (in category 'accessing') ----- - path: aCollection - "Set the collection of path elements." - - path := aCollection! Item was removed: - ----- Method: FileUrl>>pathDirString (in category 'paths') ----- - pathDirString - "Path to directory as url, using slash as delimiter. - Filename is left out." - - ^String streamContents: [ :s | - isAbsolute ifTrue: [ s nextPut: $/ ]. - 1 to: self path size - 1 do: [ :ii | - s nextPutAll: (path at: ii); nextPut: $/]]! Item was removed: - ----- Method: FileUrl>>pathForDirectory (in category 'paths') ----- - pathForDirectory - "Path using local file system's pathname delimiter. - DOS paths with drive letters should not - be prepended with a delimiter even though - they are absolute. Filename is left out." - - | delimiter | - delimiter := FileDirectory default pathNameDelimiter. - ^String streamContents: [ :s | - (self isAbsolute and: [self firstPartIsDriveLetter not]) - ifTrue: [ s nextPut: delimiter ]. - 1 to: self path size - 1 do: [ :ii | - s nextPutAll: (path at: ii); nextPut: delimiter]]! Item was removed: - ----- Method: FileUrl>>pathForFile (in category 'access') ----- - pathForFile - "Path using local file system's delimiter. $\ or $:" - ^FileDirectory default pathFromUrl: self! Item was removed: - ----- Method: FileUrl>>pathParts:isAbsolute: (in category 'private-initialization') ----- - pathParts: aCollection isAbsolute: aBoolean - - ^self host: nil pathParts: aCollection isAbsolute: aBoolean! Item was removed: - ----- Method: FileUrl>>pathString (in category 'paths') ----- - pathString - "Path as it appears in a URL with $/ as delimiter." - - ^String streamContents: [ :s | - "isAbsolute ifTrue:[ s nextPut: $/ ]." - self path - do: [ :p | s nextPutAll: p encodeForHTTP ] - separatedBy: [ s nextPut: $/]]! Item was removed: - ----- Method: FileUrl>>postCopy (in category 'copying') ----- - postCopy - "Be sure not to share the path with the copy." - - super postCopy. - path := path copy! Item was removed: - ----- Method: FileUrl>>printOn: (in category 'printing') ----- - printOn: aStream - "Return the FileUrl according to RFC1738 plus supporting fragments: - 'file://<host>/<path>#<fragment>' - Note that <host> being '' is equivalent to 'localhost'. - Note: The pathString can not start with a leading $/ - to indicate an 'absolute' file path. - This is not according to RFC1738 where the path should have - no leading or trailing slashes, and always - be considered absolute relative to the filesystem." - - aStream nextPutAll: self schemeName, '://'. - - host ifNotNil: [aStream nextPutAll: host]. - - aStream - nextPut: $/; - nextPutAll: self pathString. - - fragment ifNotNil: - [aStream - nextPut: $#; - nextPutAll: fragment encodeForHTTP].! Item was removed: - ----- Method: FileUrl>>privateInitializeFromText: (in category 'private-initialization') ----- - privateInitializeFromText: aString - "Calculate host and path from a file URL in String format. - Some malformed formats are allowed and interpreted by guessing." - - | schemeName pathString bare hasDriveLetter stream char i | - bare := aString withBlanksTrimmed. - schemeName := Url schemeNameForString: bare. - (schemeName isNil or: [schemeName ~= self schemeName]) - ifTrue: [ - host := ''. - pathString := bare] - ifFalse: [ - "First remove schemeName and colon" - bare := bare copyFrom: (schemeName size + 2) to: bare size. - "A proper file URL then has two slashes before host, - A malformed URL is interpreted as using syntax file:<path>." - (bare beginsWith: '//') - ifTrue: [i := bare indexOf: $/ startingAt: 3. - i=0 ifTrue: [ - host := bare copyFrom: 3 to: bare size. - pathString := ''] - ifFalse: [ - host := bare copyFrom: 3 to: i-1. - pathString := bare copyFrom: host size + 3 to: bare size]] - ifFalse: [host := ''. - pathString := bare]]. - self initializeFromPathString: pathString - ! Item was removed: - ----- Method: FileUrl>>privateInitializeFromText:relativeTo: (in category 'private-initialization') ----- - privateInitializeFromText: pathString relativeTo: aUrl - "<pathString> should be a filesystem path. - This url is adjusted to be aUrl + the path." - - | bare newPath | - self host: aUrl host. - self initializeFromPathString: pathString. - self isAbsolute: aUrl isAbsolute. - - newPath := aUrl path copy. - newPath removeLast. "empty string that says its a directory" - path do: [ :token | - ((token ~= '..') and: [token ~= '.']) ifTrue: [ - newPath addLast: token unescapePercents ]. - token = '..' ifTrue: [ - newPath isEmpty ifFalse: [ - newPath last = '..' ifFalse: [ newPath removeLast ] ] ]. - "token = '.' do nothing" ]. - path := newPath - - ! Item was removed: - ----- Method: FileUrl>>retrieveContents (in category 'downloading') ----- - retrieveContents - | file pathString s type entries | - pathString := self pathForFile. - file := [FileStream readOnlyFileNamed: pathString] - on: FileDoesNotExistException do:[:ex| ex return: nil]. - file ifNotNil: [ - type := file mimeTypes. - type ifNotNil:[type := type first]. - type ifNil:[type := MIMEDocument guessTypeFromName: self path last]. - ^MIMELocalFileDocument - contentType: type - contentStream: file]. - - "see if it's a directory..." - entries := [(FileDirectory on: pathString) entries] - on: InvalidDirectoryError do:[:ex| ex return: nil]. - entries ifNil:[^nil]. - - s := WriteStream on: String new. - (pathString endsWith: '/') ifFalse: [ pathString := pathString, '/' ]. - s nextPutAll: '<title>Directory Listing for ', pathString, '</title>'. - s nextPutAll: '<h1>Directory Listing for ', pathString, '</h1>'. - s nextPutAll: '<ul>'. - s cr. - entries do: [ :entry | - s nextPutAll: '<li><a href="'. - s nextPutAll: entry name. - s nextPutAll: '">'. - s nextPutAll: entry name. - s nextPutAll: '</a>'. - s cr. ]. - s nextPutAll: '</ul>'. - ^MIMEDocument contentType: 'text/html' content: s contents url: ('file://', pathString)! Item was removed: - ----- Method: FileUrl>>scheme (in category 'classification') ----- - scheme - ^self class schemeName! Item was removed: - ----- Method: FileUrl>>schemeName (in category 'classification') ----- - schemeName - ^self class schemeName! Item was removed: - HierarchicalUrl subclass: #FtpUrl - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-Url'! - - !FtpUrl commentStamp: 'ls 6/15/2003 13:44' prior: 0! - a reference to a file which may be downloaded by anonymous ftp . - - - - TODO: use the username and password, if specified - ! Item was removed: - ----- Method: FtpUrl>>downloadUrl (in category 'downloading') ----- - downloadUrl - "Returns a http download url for the location defined by this url." - | ans | - ans := WriteStream on: String new. - ans nextPutAll: self schemeName. - ans nextPutAll: '://'. - ans nextPutAll: self authority. - port ifNotNil: [ans nextPut: $:; print: port]. - path do: [ :pathElem | - ans nextPut: $/. - ans nextPutAll: pathElem encodeForHTTP. ]. - self query isNil ifFalse: [ - ans nextPut: $?. - ans nextPutAll: self query. ]. - self fragment isNil ifFalse: [ - ans nextPut: $#. - ans nextPutAll: self fragment encodeForHTTP. ]. - - ^ans contents! Item was removed: - ----- Method: FtpUrl>>hasRemoteContents (in category 'testing') ----- - hasRemoteContents - "Return true if the receiver describes some remotely accessible content. - Typically, this should only return if we could retrieve the contents - on an arbitrary place in the outside world using a standard browser. - In other words: If you can get to it from the next Internet Cafe, - return true, else return false." - ^true! Item was removed: - ----- Method: FtpUrl>>pathString (in category 'access') ----- - pathString - self path isEmpty ifTrue: [ ^'/' copy ]. - - ^String streamContents: [ :s | - self path do: [ :p | - s nextPut: $/. - s nextPutAll: p ] ]! Item was removed: - ----- Method: FtpUrl>>retrieveContents (in category 'downloading') ----- - retrieveContents - "currently assumes directories end in /, and things that don't end in / are files. Also, doesn't handle errors real well...." - | server contents pathString listing auth idx fileName serverName userName password | - pathString := self pathString. - pathString := pathString copyFrom: 2 to: pathString size. "remove the leading /" - pathString last = $/ ifTrue:["directory?!!" - fileName := nil. - ] ifFalse:[ - fileName := pathString copyFrom: (pathString lastIndexOf: $/)+1 to: pathString size. - pathString := pathString copyFrom: 1 to: (pathString lastIndexOf: $/) - 1. - ]. - auth := self authority. - idx := auth indexOf: $@. - idx > 0 ifTrue:[ - serverName := (auth copyFrom: idx+1 to: auth size). - userName := (auth copyFrom: 1 to: idx-1). - password := nil. - ] ifFalse:[ - serverName := auth. - userName := 'anonymous'. - password := 'SqueakUser'. - ]. - server := ServerDirectory servers - detect:[:s| s isTypeFTP and:[s server asLowercase = serverName asLowercase]] - ifNone:[nil]. - server ifNil:[ - server := ServerDirectory new. - server server: serverName. - ] ifNotNil:[server := server copy reset]. - server user: userName. - password ifNotNil:[server password: password]. - server directory: pathString. - - fileName == nil ifFalse:[ - "a file" - contents := (server getFileNamed: fileName). - server sleep. - ^MIMEDocument contentType: (MIMEDocument guessTypeFromName: self path last) content: contents]. - - "a directory?" - listing := String streamContents: [ :stream | - stream nextPutAll: '<title>', self pathString, '</title>'; cr. - stream nextPutAll: '<h1>Listing for ', self pathString, '</h1>'; cr. - stream nextPutAll: '<ul>'; cr. - server entries do: [ :entry | - stream nextPutAll: '<li>'; - nextPutAll: '<a href="', entry name encodeForHTTP. - entry isDirectory ifTrue: [ stream nextPut: $/ ]. - stream nextPutAll: '">'; - nextPutAll: entry name; - nextPutAll: '</a>'; - cr ] ]. - server sleep. - ^MIMEDocument contentType: 'text/html' content: listing! Item was removed: - Url subclass: #GenericUrl - instanceVariableNames: 'schemeName locator' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-Url'! - - !GenericUrl commentStamp: '<historical>' prior: 0! - a URL type that can't be broken down in any systematic way. For example, mailto: and telnet: URLs. The part after the scheme name is stored available via the #locator message.! Item was removed: - ----- Method: GenericUrl class>>absoluteFromText: (in category 'parsing') ----- - absoluteFromText: aString - | schemeName locator | - schemeName := Url schemeNameForString: aString. - schemeName ifNil: [ ^self schemeName: 'xnoscheme' locator: aString ]. - locator := aString copyFrom: (schemeName size + 2) to: aString size. - ^self schemeName: schemeName locator: locator! Item was removed: - ----- Method: GenericUrl class>>schemeName:locator: (in category 'instance creation') ----- - schemeName: schemeName locator: locator - ^self new schemeName: schemeName locator: locator! Item was removed: - ----- Method: GenericUrl>>hasSameSchemeSpecificPartAs: (in category 'comparing') ----- - hasSameSchemeSpecificPartAs: anotherUrl - - self locator = anotherUrl locator ifFalse: [^ false]. - ^ true! Item was removed: - ----- Method: GenericUrl>>hash (in category 'comparing') ----- - hash - - ^ (fragment hash bitXor: schemeName hash) bitXor: locator hash! Item was removed: - ----- Method: GenericUrl>>locator (in category 'access') ----- - locator - ^locator! Item was removed: - ----- Method: GenericUrl>>printOn: (in category 'printing') ----- - printOn: aStream - - aStream nextPutAll: self schemeName. - aStream nextPut: $:. - aStream nextPutAll: self locator. - - self fragment ifNotNil: - [aStream nextPut: $#. - aStream nextPutAll: self fragment].! Item was removed: - ----- Method: GenericUrl>>privateInitializeFromText: (in category 'parsing') ----- - privateInitializeFromText: aString - schemeName := Url schemeNameForString: aString. - schemeName ifNil: [ self error: 'opaque URL with no scheme--shouldn''t happen!!'. ]. - locator := aString copyFrom: (schemeName size+2) to: aString size.! Item was removed: - ----- Method: GenericUrl>>privateInitializeFromText:relativeTo: (in category 'parsing') ----- - privateInitializeFromText: aString relativeTo: aUrl - schemeName := aUrl schemeName. - locator := aString.! Item was removed: - ----- Method: GenericUrl>>scheme (in category 'classification') ----- - scheme - ^ self schemeName.! Item was removed: - ----- Method: GenericUrl>>schemeName (in category 'access') ----- - schemeName - ^schemeName! Item was removed: - ----- Method: GenericUrl>>schemeName:locator: (in category 'private') ----- - schemeName: schemeName0 locator: locator0 - schemeName := schemeName0. - locator := locator0.! Item was removed: - Notification subclass: #HTTPProgress - instanceVariableNames: 'total amount' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-Protocols'! - - !HTTPProgress commentStamp: 'ar 12/30/2009 16:16' prior: 0! - HTTP progress notification. Includes: - - total: The total size of the download (if known) - - amount: The completed amount of the download (if known) - ! Item was removed: - ----- Method: HTTPProgress>>amount (in category 'accessing') ----- - amount - "Answer the completed amount of the download (if known)" - ^amount! Item was removed: - ----- Method: HTTPProgress>>amount: (in category 'accessing') ----- - amount: bytes - "Set the completed amount of the download (if known)" - amount := bytes! Item was removed: - ----- Method: HTTPProgress>>total (in category 'accessing') ----- - total - "Answer the total size of the download, if known" - ^total! Item was removed: - ----- Method: HTTPProgress>>total: (in category 'accessing') ----- - total: bytes - "Answer the total size of the download, if known" - total := bytes! Item was removed: - ProjectSwikiServer subclass: #HTTPServerDirectory - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-RemoteDirectory'! Item was removed: - ----- Method: HTTPServerDirectory>>dirListUrl (in category 'accessing') ----- - dirListUrl - | listURL | - listURL := self altUrl - ifNil: [^ nil]. - ^ listURL last ~= $/ - ifTrue: [listURL , '/'] - ifFalse: [listURL]! Item was removed: - ----- Method: HTTPServerDirectory>>directoryNamed: (in category 'accessing') ----- - directoryNamed: localFileName - | newDir | - newDir := super directoryNamed: localFileName. - newDir altUrl: (self altUrl , '/' , localFileName). - ^newDir! Item was removed: - ----- Method: HTTPServerDirectory>>directoryNames (in category 'file directory') ----- - directoryNames - | dirNames projectNames entries | - "Return a collection of names for the subdirectories of this directory but filter out project directories." - - entries := self entries. - dirNames := (entries select: [:entry | entry isDirectory]) - collect: [:entry | entry name]. - projectNames := Set new. - entries do: [:entry | - (entry isDirectory not - and: ['*.pr' match: entry name]) - ifTrue: [projectNames add: (entry name copyFrom: 1 to: entry name size - 3)]]. - ^dirNames reject: [:each | projectNames includes: each] - ! Item was removed: - ----- Method: HTTPServerDirectory>>entries (in category 'file directory') ----- - entries - | answer ftpEntries | - answer := HTTPSocket httpGetDocument: self dirListUrl. - answer isString - ifTrue: [^self error: 'Listing failed: ' , answer] - ifFalse: [answer := answer content]. - answer first = $< ifTrue: - [(answer first: 5) = '<?xml' ifTrue: - [(self environment classNamed: #XMLDOMParser) ifNotNil: - [:parserClass | ^ self parseFTPEntriesFromXML: (parserClass parseDocumentFrom: answer readStream useNamespaces: true)]]. - self error: 'Listing failed: ' , answer]. - ftpEntries := answer lines. - ^ ftpEntries - collect:[:ftpEntry | self class parseFTPEntry: ftpEntry] - thenSelect: [:entry | entry notNil]! Item was removed: - ----- Method: HTTPServerDirectory>>fileNames (in category 'file directory') ----- - fileNames - "Return a collection of names for the files (but not directories) in this directory." - "(ServerDirectory serverNamed: 'UIUCArchive') fileNames" - - self dirListUrl - ifNil: [^self error: 'No URL set for fetching the directory listing.' ]. - ^(self entries select: [:entry | entry isDirectory not]) - collect: [:entry | entry name] - ! Item was removed: - ----- Method: HTTPServerDirectory>>fileSizeFromString: (in category 'misc') ----- - fileSizeFromString: aString - | size | - size := aString asNumber. - ('KMGTP' indexOf: aString last asUppercase ifAbsent: nil) ifNotNil: - [:index| size := size * (2 raisedTo: index * 10)]. "1k = 2^10, etc..." - ^size asInteger! Item was removed: - ----- Method: HTTPServerDirectory>>oldFileNamed: (in category 'file directory') ----- - oldFileNamed: aName - - | contents | - contents := HTTPLoader default retrieveContentsFor: (self altUrl , '/' , aName). - ^(SwikiPseudoFileStream with: contents content) - reset; - directory: self; - localName: aName; - yourself - ! Item was removed: - ----- Method: HTTPServerDirectory>>parseFTPEntriesFromXML: (in category 'misc') ----- - parseFTPEntriesFromXML: anXMLDocument - | entries | - entries := OrderedCollection new. - anXMLDocument - tagsNamed: #tr - ifReceiverDoAndRecurse: - [:node| | ec | - ((ec := node elementsAndContents) size = 4 - and: [((ec := ec asArray) allSatisfy: [:n| n isTag]) - and: [((ec collect: [:n| n attributeAt: 'class']) sameElements: #('n' 'm' 's' 't'))]]) ifTrue: - [[:n :m :s :t| | modificationString nameString | - (n isTag - and: [(modificationString := m string) size > 12 "YYYYMMDDHHSS" - and: [modificationString first isDigit]]) ifTrue: - [nameString := n attributeAt: 'href'. - entries addLast: - (t string = 'Directory' "is-a-directory flag" - ifTrue: - [DirectoryEntryDirectory - directory: self - name: nameString "file name" - creationTime: nil - modificationTime: modificationString asDateAndTime "modification time" - fileSize: nil] - ifFalse: - [DirectoryEntryFile - directory: self - name: nameString "file name" - creationTime: nil - modificationTime: modificationString asDateAndTime "modification time" - fileSize: (self fileSizeFromString: s string)])]] valueWithArguments: (ec collect: [:element| element elementsAndContents first])]]. - ^entries! Item was removed: - ----- Method: HTTPServerDirectory>>pathName (in category 'file directory') ----- - pathName - "Path name as used in reading the file. with slashes for ftp, with local file delimiter (:) for a file: url" - - urlObject ifNotNil: [^ urlObject pathForFile]. - directory size = 0 ifTrue: [^ server]. - ^(directory at: 1) = self pathNameDelimiter - ifTrue: [server, directory] - ifFalse: [user - ifNil: [server, self pathNameDelimiter asString, directory] - ifNotNil: [user, '@', server, self pathNameDelimiter asString, directory]]! Item was removed: - ----- Method: HTTPServerDirectory>>readOnlyFileNamed: (in category 'file directory') ----- - readOnlyFileNamed: aName - - ^self oldFileNamed: aName! Item was removed: - ----- Method: HTTPServerDirectory>>typeForPrefs (in category 'accessing') ----- - typeForPrefs - - ^'http'! Item was removed: - Object subclass: #HTTPSocket - instanceVariableNames: '' - classVariableNames: 'HTTPBlabEmail HTTPPort HTTPProxyCredentials HTTPProxyExceptions HTTPProxyPort HTTPProxyServer HTTPRequestHandler' - poolDictionaries: '' - category: 'Network-Protocols'! - - !HTTPSocket commentStamp: 'ar 7/10/2010 14:05' prior: 0! - HTTPSockets is a facade for handling common HTTP requests. It provides a minimal implementation of the HTTP protocol, but can be extended by third party clients that register themselves as #httpRequestHandler (see class-side protocol). - - A third-party request handler needs to implement the single method - - #httpRequest:url:headers:content:response: - - in a way that is compatible with the baseline implementation in HTTPSocket. - ! Item was removed: - ----- Method: HTTPSocket class>>addProxyException: (in category 'proxy settings') ----- - addProxyException: domainName - "Add a (partial, wildcard) domain name to the list of proxy exceptions" - "HTTPSocket addProxyException: '*.online.disney.com'" - - self httpProxyExceptions add: domainName! Item was removed: - ----- Method: HTTPSocket class>>argString: (in category 'utilities') ----- - argString: args - "Return the args in a long string, as encoded in a url" - - | argsString first | - args isString ifTrue: ["sent in as a string, not a dictionary" - ^ (args first = $? ifTrue: [''] ifFalse: ['?']), args]. - argsString := WriteStream on: String new. - argsString nextPut: $?. - first := true. - args associationsDo: [ :assoc | - assoc value do: [ :value | - first ifTrue: [ first := false ] ifFalse: [ argsString nextPut: $& ]. - argsString nextPutAll: assoc key encodeForHTTP. - argsString nextPut: $=. - argsString nextPutAll: value encodeForHTTP. ] ]. - ^ argsString contents - ! Item was removed: - ----- Method: HTTPSocket class>>blabEmail: (in category 'class initialization') ----- - blabEmail: aRequest - "Of the form 'From: me at isp.com <crlf>'" - HTTPBlabEmail := aRequest! Item was removed: - ----- Method: HTTPSocket class>>defaultPort (in category 'class initialization') ----- - defaultPort - "default port to connect on" - ^80! Item was removed: - ----- Method: HTTPSocket class>>fetchExternalSettingsIn: (in category 'proxy settings') ----- - fetchExternalSettingsIn: aDirectory - "Scan for server configuration files" - "HTTPSocket fetchExternalSettingsIn: (FileDirectory default directoryNamed: 'prefs')" - - | stream entries | - (aDirectory fileExists: self proxySettingsFileName) - ifFalse: [^self]. - stream := aDirectory readOnlyFileNamed: self proxySettingsFileName. - stream - ifNotNil: [ - [entries := ExternalSettings parseServerEntryArgsFrom: stream] - ensure: [stream close]]. - - entries ifNil: [^self]. - - self httpProxyServer: (entries at: 'host' ifAbsent: [nil]). - self httpProxyPort: ((entries at: 'port' ifAbsent: ['80']) asInteger ifNil: [self defaultPort]). - HTTPSocket addProxyException: (entries at: 'exception' ifAbsent: [nil])! Item was removed: - ----- Method: HTTPSocket class>>httpFileIn: (in category 'get the page') ----- - httpFileIn: url - "Do a regular file-in of a file that is served from a web site. If the file contains an EToy, then open it. Might just be code instead. tk 7/23/97 17:10" - "Notes: To store a file on an HTTP server, use the program 'Fetch'. After indicating what file to store, choose 'Raw Data' from the popup menu that has MacBinary/Text/etc. Use any file extension as long as it is not one of the common ones. The server does not have to know about the .sqo extension in order to send your file. (We do not need a new MIME type and .sqo does not have to be registered with the server.)" - " HTTPSocket httpFileIn: 'www.webPage.com/~kaehler2/sample.etoy' " - " HTTPSocket httpFileIn: '206.18.68.12/squeak/car.sqo' " - " HTTPSocket httpFileIn: 'jumbo/tedk/sample.etoy' " - - | doc eToyHolder | - doc := self httpGet: url accept: 'application/octet-stream'. - doc isString ifTrue: - [self inform: 'Cannot seem to contact the web site']. - doc reset. - eToyHolder := doc fileInObjectAndCode. - - eToyHolder ifNotNil: [eToyHolder open]. - "Later may want to return it, instead of open it" - ! Item was removed: - ----- Method: HTTPSocket class>>httpFileInNewChangeSet: (in category 'get the page') ----- - httpFileInNewChangeSet: url - "Do a regular file-in of a file that is served from a web site. Put it into a new changeSet." - "Notes: To store a file on an HTTP server, use the program 'Fetch'. After indicating what file to store, choose 'Raw Data' from the popup menu that has MacBinary/Text/etc. Use any file extension as long as it is not one of the common ones." - " HTTPSocket httpFileInNewChangeSet: '206.18.68.12/squeak/updates/83tk:=test.cs' " - - | doc | - doc := self httpGet: url accept: 'application/octet-stream'. - doc isString ifTrue: - [self inform: 'Cannot seem to contact the web site']. - doc reset. - ChangeSet newChangesFromStream: doc - named: (url findTokens: '/') last.! Item was removed: - ----- Method: HTTPSocket class>>httpGet: (in category 'get the page') ----- - httpGet: url - "Return the exact contents of a web page or other web object. The parsed header is saved. Use a proxy server if one has been registered. tk 7/23/97 17:21" - " HTTPSocket httpShowPage: 'http://www.altavista.digital.com/index.html' " - " HTTPSocket httpShowPage: 'www.webPage.com/~kaehler2/ab.html' " - " HTTPSocket httpShowPage: 'www.exploratorium.edu/index.html' " - " HTTPSocket httpShowPage: 'www.apple.com/default.html' " - " HTTPSocket httpShowPage: 'www.altavista.digital.com/' " - " HTTPSocket httpShowPage: 'jumbo/tedk/ab.html' " - - ^ self httpGet: url accept: '*/*' - ! Item was removed: - ----- Method: HTTPSocket class>>httpGet:accept: (in category 'get the page') ----- - httpGet: url accept: mimeType - "Return the exact contents of a web object. Asks for the given MIME type. If mimeType is nil, use 'text/html'. The parsed header is saved. Use a proxy server if one has been registered. - Note: To fetch raw data, you can use the MIME type 'application/octet-stream'. To accept anything, use '*/*'." - - ^self httpGet: url args: nil accept: mimeType! Item was removed: - ----- Method: HTTPSocket class>>httpGet:args:accept: (in category 'get the page') ----- - httpGet: url args: args accept: mimeType - - ^self httpGet: url args: args accept: mimeType request: ''! Item was removed: - ----- Method: HTTPSocket class>>httpGet:args:accept:request: (in category 'get the page') ----- - httpGet: 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'. 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'." - - | document | - document := self httpGetDocument: url args: args accept: mimeType request: requestString. - (document isString) ifTrue: [ - "strings indicate errors" - ^ document ]. - - ^ (RWBinaryOrTextStream with: document content) reset - ! Item was removed: - ----- Method: HTTPSocket class>>httpGetDocument: (in category 'get the page') ----- - httpGetDocument: url - "Return the exact contents of a web page or other web object. The parsed header is saved. Use a proxy server if one has been registered. tk 7/23/97 17:21" - " HTTPSocket httpShowPage: 'http://www.altavista.digital.com/index.html' " - " HTTPSocket httpShowPage: 'www.webPage.com/~kaehler2/ab.html' " - " HTTPSocket httpShowPage: 'www.exploratorium.edu/index.html' " - " HTTPSocket httpShowPage: 'www.apple.com/default.html' " - " HTTPSocket httpShowPage: 'www.altavista.digital.com/' " - " HTTPSocket httpShowPage: 'jumbo/tedk/ab.html' " - - ^ self httpGetDocument: url args: nil accept: 'application/octet-stream' request: '' - ! Item was removed: - ----- Method: HTTPSocket class>>httpGetDocument:accept: (in category 'get the page') ----- - httpGetDocument: url accept: mimeType - "Return the exact contents of a web object. Asks for the given MIME type. If mimeType is nil, use 'text/html'. The parsed header is saved. Use a proxy server if one has been registered. tk 7/23/97 17:12" - ^self httpGetDocument: url args: nil accept: mimeType request: ''! Item was removed: - ----- Method: HTTPSocket class>>httpGetDocument:args: (in category 'get the page') ----- - httpGetDocument: url args: args - "Return the exact contents of a web object. Asks for the given MIME type. If mimeType is nil, use 'text/html'. 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 MIMI type 'application/octet-stream'." - ^self httpGetDocument: url args: args accept: 'application/octet-stream' request: ''! Item was removed: - ----- Method: HTTPSocket class>>httpGetDocument:args:accept: (in category 'get the page') ----- - httpGetDocument: url args: args accept: mimeType - "Return the exact contents of a web object. Asks for the given MIME type. If mimeType is nil, use 'text/html'. The parsed header is saved. Use a proxy server if one has been registered. Note: To fetch raw data, you can use the MIME type 'application/octet-stream'." - - ^ self httpGetDocument: url args: args accept: mimeType request: ''! Item was removed: - ----- Method: HTTPSocket class>>httpGetNoError:args:accept: (in category 'get the page') ----- - httpGetNoError: url args: args accept: mimeType - "Return the exact contents of a web file. Do better error checking. Asks for the given MIME type. To fetch raw data, you can use the MIMI type 'application/octet-stream'. If mimeType is nil, use 'text/html'. The parsed header is saved. Use a proxy server if one has been registered." - - "Edited to remove a lineFeed from the source 4/4/99 - di" - - | document data | - document := self httpGetDocument: url args: args accept: mimeType. - (document isString) ifTrue: [ - "strings indicate errors" - ^ document ]. - data := document content. - (data beginsWith: '<HTML><HEAD>' , (String with: Character linefeed) , '<TITLE>4') - ifTrue: ["an error message 404 File not found" - ^ data copyFrom: 21 to: data size-16]. - - ^ (RWBinaryOrTextStream with: data) reset - ! Item was removed: - ----- Method: HTTPSocket class>>httpGif: (in category 'get the page') ----- - httpGif: url - "Fetch the given URL, parse it using the GIF reader, and return the resulting Form." - " HTTPSocket httpShowGif: 'www.altavista.digital.com/av/pix/default/av-adv.gif' " - " HTTPSocket httpShowGif: 'www.webPage.com/~kaehler2/ainslie.gif' " - - | doc ggg | - doc := self httpGet: url accept: 'image/gif'. - doc isString ifTrue: [ - self inform: 'The server with that GIF is not responding'. - ^ ColorForm extent: 20 at 20 depth: 8]. - doc binary; reset. - (ggg := GIFReadWriter new) setStream: doc. - ^ ggg nextImage. - ! Item was removed: - ----- Method: HTTPSocket class>>httpJpeg: (in category 'get the page') ----- - httpJpeg: url - "Fetch the given URL, parse it using the JPEG reader, and return the resulting Form." - - | doc ggg | - doc := self httpGet: url. - doc binary; reset. - (ggg := JPEGReadWriter new) setStream: doc. - ^ ggg nextImage. - ! Item was removed: - ----- Method: HTTPSocket class>>httpPost:args:accept: (in category 'get the page') ----- - httpPost: url args: argsDict accept: mimeType - "like httpGET, except it does a POST instead of a GET. POST allows data to be uploaded" - | document | - document := self httpPostDocument: url args: argsDict accept: mimeType request: ''. - (document isString) ifTrue: [ - "strings indicate errors" - ^document ]. - - - ^RWBinaryOrTextStream with: document content! Item was removed: - ----- Method: HTTPSocket class>>httpPostDocument:args: (in category 'get the page') ----- - httpPostDocument: url args: argsDict - "like httpGET, except it does a POST instead of a GET. POST allows data to be uploaded" - - ^self httpPostDocument: url args: argsDict accept: 'application/octet-stream' request: ''! Item was removed: - ----- Method: HTTPSocket class>>httpPostDocument:args:accept: (in category 'get the page') ----- - httpPostDocument: url args: argsDict accept: mimeType - "like httpGET, except it does a POST instead of a GET. POST allows data to be uploaded" - - ^ self httpPostDocument: url args: argsDict accept: mimeType request: '' - ! Item was removed: - ----- Method: HTTPSocket class>>httpProxyExceptions (in category 'proxy settings') ----- - httpProxyExceptions - HTTPProxyExceptions ifNil: [HTTPProxyExceptions := OrderedCollection new]. - ^HTTPProxyExceptions! Item was removed: - ----- Method: HTTPSocket class>>httpProxyPort (in category 'proxy settings') ----- - httpProxyPort - "answer the httpProxyPort" - <preference: 'HTTP Proxy Port' - category: 'HTTP Proxy' - description: 'HTTP Proxy Port' - type: #Number> - ^HTTPProxyPort ifNil:[80]! Item was removed: - ----- Method: HTTPSocket class>>httpProxyPort: (in category 'proxy settings') ----- - httpProxyPort: aPortNumber - "Set the proxy port" - HTTPProxyPort := aPortNumber.! Item was removed: - ----- Method: HTTPSocket class>>httpProxyServer (in category 'proxy settings') ----- - httpProxyServer - "answer the httpProxyServer. Take into account that as a Preference the Server might appear as an empty string but HTTPSocket expect it to be nil" - <preference: 'HTTP Proxy Server' - category: 'HTTP Proxy' - description: 'HTTP Proxy Server. Leave blank if you don''t want to use a Proxy' - type: #String> - ^HTTPProxyServer ifNil:[''] - ! Item was removed: - ----- Method: HTTPSocket class>>httpProxyServer: (in category 'proxy settings') ----- - httpProxyServer: aString - "answer the httpProxyServer. Take into account that as a Preference the Server might appear as an empty string but HTTPSocket expect it to be nil" - HTTPProxyServer := aString. - ! Item was removed: - ----- Method: HTTPSocket class>>httpRequest:url:headers:content:response: (in category 'get the page') ----- - httpRequest: method url: urlString headers: hdrs content: contentOrNil response: responseBlock - - "Sends an HTTP request to the server. Returns a MIMEDocument if successful, - a string indicating the error otherwise. If a response block is provided, the - response is fed into into so that the sender can see all the headers. - The url string is assumed to be properly escaped by the sender." - - | index serverAndPort server port rawUrl stream resp code headers - contentLength contentType content | - - (urlString beginsWith: 'http://') ifFalse:[self error: 'Not a http url']. - - "Extract server, port, and url" - index := urlString indexOf: $/ startingAt: 8 ifAbsent:[urlString size+1]. "past http://" - serverAndPort := urlString copyFrom: 8 to: index-1. - server := serverAndPort copyUpTo: $:. - port := ((serverAndPort copyAfter: $:) ifEmpty:['80']) asNumber. - - "Prepare the request URI" - rawUrl := urlString copyFrom: index to: urlString size. - (rawUrl beginsWith: '/') ifFalse:[rawUrl := '/', rawUrl]. - - "Check for proxy" - (self shouldUseProxy: server) ifTrue:[ - self httpProxyServer ifNotEmpty:[ - rawUrl := 'http://', serverAndPort, rawUrl. "per RFC 2616" - server := self httpProxyServer. - port := self httpProxyPort. - ]. - ]. - - "Fire off the request" - stream := SocketStream openConnectionToHostNamed: server port: port. - stream nextPutAll: method; space; nextPutAll: rawUrl; space; nextPutAll: 'HTTP/1.0'; crlf. - stream nextPutAll: 'Host: ', serverAndPort; crlf. - stream nextPutAll: 'Connection: close'; crlf. - stream nextPutAll: 'User-Agent: ', self userAgentString; crlf. - stream nextPutAll: 'Accept-Encoding: gzip'; crlf. - stream nextPutAll: hdrs. - stream crlf. - - contentOrNil ifNotNil:[ - | contentStream | - "Upload request content" - contentStream := contentOrNil readStream. - [contentStream atEnd] whileFalse:[ - (HTTPProgress new) total: contentOrNil size; - amount: contentStream position; signal: 'Uploading...'. - stream nextPutAll: (contentStream next: 4096). - stream flush. - ]. - ]. - - stream flush. - - "Read the response" - resp := stream upToAll: String crlfcrlf. - "Extract the response code" - code := ((resp copyUpTo: String cr) findTokens: ' ') second asNumber. - "And the response headers" - headers := Dictionary new. - resp lines allButFirstDo: [ :nextLine | - headers at: (nextLine copyUpTo: $:) asLowercase - put: (nextLine copyAfter: $:) withBlanksTrimmed ]. - - (code between: 301 and: 303) - ifTrue:[ - headers at: 'location' ifPresent: [:location | - stream close. - ^ self httpRequest: method url: location headers: hdrs content: contentOrNil response: responseBlock]]. - - - "Read response content" - contentLength := headers at: 'content-length' ifAbsent:[nil]. - contentType := headers at: 'content-type' ifAbsent:['application/octet-stream']. - - "Fixme - Provide HTTProgress" - contentLength - ifNil: [ content := stream upToEnd ] - ifNotNil: [ - contentLength := contentLength asInteger. - content := String new: contentLength. - index := 1. - [ index <= contentLength ] whileTrue: [ - | bytesRead | - bytesRead := stream readInto: content startingAt: index count: ((contentLength - index + 1) min: 8192). - index := index + bytesRead. - HTTPProgress new - total: contentLength; - amount: index; - signal: 'Downloading...' ] ]. - - responseBlock ifNotNil:[responseBlock value: resp]. - - (headers at: 'content-encoding' ifAbsent: [ nil ]) = 'gzip' ifTrue: [ - content := (GZipReadStream on: content) upToEnd ]. - - ^(code between: 200 and: 299) - ifTrue:[MIMEDocument contentType: contentType - content: content url: urlString] - ifFalse:[resp asString, content]. - ! Item was removed: - ----- Method: HTTPSocket class>>httpRequestHandler (in category 'handler') ----- - httpRequestHandler - "Answer the registered handler for http requests. The handler needs to implement - #httpRequest:url:headers:content:response: compatible with the baseline version - in HTTPSocket. If no handler is registered, answer the receiver" - - ^HTTPRequestHandler ifNil:[self]! Item was removed: - ----- Method: HTTPSocket class>>httpRequestHandler: (in category 'handler') ----- - httpRequestHandler: anObject - "Set the registered handler for http requests. The handler needs to implement - #httpRequest:url:headers:content:response: compatible with the baseline version - in HTTPSocket." - - HTTPRequestHandler := anObject! Item was removed: - ----- Method: HTTPSocket class>>httpShowChunk: (in category 'get the page') ----- - httpShowChunk: url - "From a Swiki server, get a text chunk in the changes file. Show its text in a window with style. Vertical bar separates class and selector. BE SURE TO USE ; instead of : in selectors!!" - " HTTPSocket httpShowChunk: 'http://206.16.12.145:80/OurOwnArea.chunk.Socket|Comment' " - " HTTPSocket httpShowChunk: 'http://206.16.12.145:80/OurOwnArea.chunk.Point|class|x;y;' " - - | doc text | - doc := (self httpGet: url accept: 'application/octet-stream'). - " doc size = 0 ifTrue: [doc := 'The server does not seem to be responding']." - doc isString ifTrue: [text := doc] ifFalse: [text := doc nextChunkText]. - (StringHolder new contents: text) openLabel: url. - ! Item was removed: - ----- Method: HTTPSocket class>>httpShowGif: (in category 'get the page') ----- - httpShowGif: url - "Display the picture retrieved from the given URL, which is assumed to be a GIF file. - See examples in httpGif:." - - self showImage: (self httpGif: url) named: (url findTokens: '/') last! Item was removed: - ----- Method: HTTPSocket class>>httpShowJpeg: (in category 'get the page') ----- - httpShowJpeg: url - "Display the picture retrieved from the given URL, which is assumed to be a JPEG file. - See examples in httpGif:." - - self showImage: (self httpJpeg: url) named: (url findTokens: '/') last! Item was removed: - ----- Method: HTTPSocket class>>httpShowPage: (in category 'get the page') ----- - httpShowPage: url - "Display the exact contents of the given URL as text. See examples in httpGet:" - - | doc | - doc := (self httpGet: url accept: 'application/octet-stream') contents. - doc size = 0 ifTrue: [^ self error: 'Document could not be fetched' translated]. - (StringHolder new contents: doc) openLabel: url. - ! Item was removed: - ----- Method: HTTPSocket class>>initialize (in category 'class initialization') ----- - initialize - "HTTPSocket initialize" - - HTTPPort := 80. - self httpProxyServer: nil. - HTTPBlabEmail := ''. " 'From: somebody at no.where', CrLf " - HTTPProxyCredentials := ''. - - ExternalSettings registerClient: self. - self removeHTTPProxyPreferences.! Item was removed: - ----- Method: HTTPSocket class>>proxySettingsFileName (in category 'proxy settings') ----- - proxySettingsFileName - ^'proxySettings'! Item was removed: - ----- Method: HTTPSocket class>>proxyUser:password: (in category 'proxy settings') ----- - proxyUser: userName password: password - "Store HTTP 1.0 basic authentication credentials - Note: this is an ugly hack that stores your password - in your image. It's just enought to get you going - if you use a firewall that requires authentication" - | encoded | - encoded := (userName, ':', password) base64Encoded. - HTTPProxyCredentials := 'Proxy-Authorization: Basic ' , encoded, String crlf! Item was removed: - ----- Method: HTTPSocket class>>removeHTTPProxyPreferences (in category 'proxy settings') ----- - removeHTTPProxyPreferences - " This method will remove the old HTTP Proxy preferences. " - (Preferences valueOfPreference: #httpProxyServer) ifNotNil:[ - HTTPProxyServer := Preferences valueOfPreference: #httpProxyServer. - Preferences removePreference: #httpProxyServer. - ]. - (Preferences valueOfPreference: #httpProxyPort) ifNotNil:[ - HTTPProxyPort := Preferences valueOfPreference: #httpProxyPort. - Preferences removePreference: #httpProxyPort. - ]. - ! Item was removed: - ----- Method: HTTPSocket class>>removeProxyException: (in category 'proxy settings') ----- - removeProxyException: domainName - "Remove a (partial, wildcard) domain name from the list of proxy exceptions" - - self httpProxyExceptions remove: domainName ifAbsent: []! Item was removed: - ----- Method: HTTPSocket class>>shouldUseProxy: (in category 'utilities') ----- - shouldUseProxy: serverName - "Retrieve the server and port information from the URL, match it to the proxy settings and open a http socket for the request." - - self httpProxyServer ifNotEmpty: [ - self httpProxyExceptions - detect: [:domainName | domainName match: serverName] - ifNone: [^true]]. - ^false - ! Item was removed: - ----- Method: HTTPSocket class>>showImage:named: (in category 'utilities') ----- - showImage: image named: imageName - - Project current showImage: image named: imageName - ! Item was removed: - ----- Method: HTTPSocket class>>stopUsingProxyServer (in category 'proxy settings') ----- - stopUsingProxyServer - "Stop directing HTTP request through a proxy server." - - self httpProxyServer: nil. - self httpProxyPort: 80. - HTTPProxyCredentials := '' - ! Item was removed: - ----- Method: HTTPSocket class>>useProxyServerNamed:port: (in category 'proxy settings') ----- - useProxyServerNamed: proxyServerName port: portNum - "Direct all HTTP requests to the HTTP proxy server with the given name and port number." - - proxyServerName ifNil: [ "clear proxy settings" - self httpProxyServer: nil. - self httpProxyPort: 80. - ^ self]. - - proxyServerName isString - ifFalse: [self error: 'Server name must be a String or nil']. - self httpProxyServer: proxyServerName. - - self httpProxyPort: portNum. - (self httpProxyPort isKindOf: String) ifTrue: [HTTPPort := portNum asNumber]. - self httpProxyPort ifNil: [self httpProxyPort: self defaultPort].! Item was removed: - ----- Method: HTTPSocket class>>useProxyServerNamed:port:proxyUser:password: (in category 'proxy settings') ----- - useProxyServerNamed: proxyServerName port: portNum proxyUser: aString password: anotherString - self useProxyServerNamed: proxyServerName port: portNum. - self proxyUser: aString password: anotherString! Item was removed: - ----- Method: HTTPSocket class>>userAgentString (in category 'utilities') ----- - userAgentString - "self userAgentString" - - ^'User-Agent: ', - SystemVersion current version, '-', - SystemVersion current highestUpdate printString! Item was removed: - URI subclass: #HierarchicalURI - instanceVariableNames: 'authority query' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-URI'! Item was removed: - ----- Method: HierarchicalURI>>absoluteFromString:scheme: (in category 'private') ----- - absoluteFromString: aString scheme: schemeName - | remainder | - super absoluteFromString: aString scheme: schemeName. - - "We now have the interesting part in schemeSpecficPart and can parse it further" - - "This check is somewhat redundant, just in case somebody calls this directly." - remainder := schemeSpecificPart. - (remainder isEmpty - or: [remainder first ~~ $/]) - ifTrue: [(IllegalURIException new uriString: remainder) signal: 'Invalid absolute URI']. - - (aString beginsWith: '//') - ifTrue: [remainder := self extractAuthority: (remainder copyFrom: 3 to: remainder size)]. - - self extractSchemeSpecificPartAndFragment: remainder! Item was removed: - ----- Method: HierarchicalURI>>absolutePath (in category 'accessing') ----- - absolutePath - ^self schemeSpecificPart isEmpty - ifTrue: ['/'] - ifFalse: [self schemeSpecificPart]! Item was removed: - ----- Method: HierarchicalURI>>allButScheme (in category 'printing') ----- - allButScheme - "Answer the entire url except its scheme" - - ^String streamContents:[:s| - authority ifNotNil:[self authority printOn: s]. - s nextPutAll: super allButScheme. - query ifNotNil:[s nextPutAll: query]. - ].! Item was removed: - ----- Method: HierarchicalURI>>assureExistance (in category 'directory operations') ----- - assureExistance - ! Item was removed: - ----- Method: HierarchicalURI>>authority (in category 'accessing') ----- - authority - ^authority! Item was removed: - ----- Method: HierarchicalURI>>baseName (in category 'accessing') ----- - baseName - "returns the last component stripped of its extension" - - | baseName i | - baseName := self pathComponents last. - i := baseName findLast: [:c | c = $.]. - ^i = 0 - ifTrue: [baseName] - ifFalse: [baseName copyFrom: 1 to: i-1]. - ! Item was removed: - ----- Method: HierarchicalURI>>buildAbsolutePath: (in category 'private') ----- - buildAbsolutePath: pathComponents - ^String streamContents: [:stream | - stream nextPut: $/. - pathComponents - do: [:pathPart | stream nextPutAll: pathPart] - separatedBy: [stream nextPut: $/]]! Item was removed: - ----- Method: HierarchicalURI>>extension (in category 'accessing') ----- - extension - "This method assumes a $. as extension delimiter" - - | i leafName | - leafName := self pathComponents last. - i := leafName findLast: [:c | c = $.]. - ^i = 0 - ifTrue: [''] - ifFalse: [leafName copyFrom: i + 1 to: leafName size]. - ! Item was removed: - ----- Method: HierarchicalURI>>extractAuthority: (in category 'private') ----- - extractAuthority: aString - | endAuthorityIndex authorityString | - endAuthorityIndex := (aString indexOf: $/ ) - 1. - endAuthorityIndex < 0 - ifTrue: [endAuthorityIndex := aString size]. - authorityString := aString copyFrom: 1 to: endAuthorityIndex. - authority := URIAuthority fromString: authorityString. - ^aString copyFrom: endAuthorityIndex+1 to: aString size! Item was removed: - ----- Method: HierarchicalURI>>extractQuery: (in category 'private') ----- - extractQuery: remainder - | queryIndex | - queryIndex := remainder indexOf: $?. - queryIndex > 0 - ifFalse: [^remainder]. - query := remainder copyFrom: queryIndex to: remainder size. - ^remainder copyFrom: 1 to: queryIndex-1! Item was removed: - ----- Method: HierarchicalURI>>extractSchemeSpecificPartAndFragment: (in category 'private') ----- - extractSchemeSpecificPartAndFragment: remainder - super extractSchemeSpecificPartAndFragment: remainder. - schemeSpecificPart := self extractQuery: schemeSpecificPart! Item was removed: - ----- Method: HierarchicalURI>>host (in category 'accessing') ----- - host - ^self authority host! Item was removed: - ----- Method: HierarchicalURI>>path (in category 'accessing') ----- - path - " ^self schemeSpecificPart isEmpty - ifTrue: ['/'] - ifFalse: [self schemeSpecificPart]" - ^self schemeSpecificPart! Item was removed: - ----- Method: HierarchicalURI>>pathComponents (in category 'accessing') ----- - pathComponents - ^self path findTokens: $/! Item was removed: - ----- Method: HierarchicalURI>>port (in category 'accessing') ----- - port - ^self authority port! Item was removed: - ----- Method: HierarchicalURI>>printSchemeSpecificPartOn: (in category 'printing') ----- - printSchemeSpecificPartOn: stream - self isAbsolute - ifTrue: [stream nextPutAll: '//']. - authority - ifNotNil: [self authority printOn: stream]. - super printSchemeSpecificPartOn: stream. - query - ifNotNil: [stream nextPutAll: query]! Item was removed: - ----- Method: HierarchicalURI>>query (in category 'accessing') ----- - query - ^query! Item was removed: - ----- Method: HierarchicalURI>>relativeFromString: (in category 'private') ----- - relativeFromString: aString - | remainder authorityEnd | - remainder := (aString beginsWith: '//') - ifTrue: [ - authorityEnd := aString indexOf: $/ startingAt: 3. - authorityEnd = 0 - ifTrue: [authorityEnd := aString size+1]. - self extractAuthority: (aString copyFrom: 3 to: authorityEnd-1)] - ifFalse: [aString]. - self extractSchemeSpecificPartAndFragment: remainder! Item was removed: - ----- Method: HierarchicalURI>>removeComponentDotDotPairs: (in category 'private') ----- - removeComponentDotDotPairs: pathComponents - | dotDotIndex | - dotDotIndex := pathComponents indexOf: '..'. - [dotDotIndex > 1] - whileTrue: [ - pathComponents - removeAt: dotDotIndex; - removeAt: dotDotIndex-1. - dotDotIndex := pathComponents indexOf: '..']! Item was removed: - ----- Method: HierarchicalURI>>resolveRelativeURI: (in category 'accessing') ----- - resolveRelativeURI: aURI - | relativeURI newAuthority newPath pathComponents newURI relComps | - relativeURI := aURI asURI. - - relativeURI isAbsolute - ifTrue: [^relativeURI]. - - relativeURI authority - ifNil: [ - newAuthority := self authority. - (relativeURI path beginsWith: '/') - ifTrue: [newPath := relativeURI path] - ifFalse: [ - pathComponents := (self path copyUpToLast: $/) findTokens: $/. - relComps := relativeURI pathComponents. - relComps removeAllSuchThat: [:each | each = '.']. - pathComponents addAll: relComps. - pathComponents removeAllSuchThat: [:each | each = '.']. - self removeComponentDotDotPairs: pathComponents. - newPath := self buildAbsolutePath: pathComponents. - ((relComps isEmpty - or: [relativeURI path last == $/ - or: [(relativeURI path endsWith: '/..') - or: [relativeURI path = '..' - or: [relativeURI path endsWith: '/.' ]]]]) - and: [newPath size > 1]) - ifTrue: [newPath := newPath , '/']]] - ifNotNil: [ - newAuthority := relativeURI authority. - newPath := relativeURI path]. - - newURI := String streamContents: [:stream | - stream nextPutAll: self scheme. - stream nextPut: $: . - newAuthority notNil - ifTrue: [ - stream nextPutAll: '//'. - newAuthority printOn: stream]. - newPath notNil - ifTrue: [stream nextPutAll: newPath]. - relativeURI query notNil - ifTrue: [stream nextPutAll: relativeURI query]. - relativeURI fragment notNil - ifTrue: [ - stream nextPut: $# . - stream nextPutAll: relativeURI fragment]]. - ^newURI asURI! Item was removed: - ----- Method: HierarchicalURI>>userInfo (in category 'accessing') ----- - userInfo - ^self authority userInfo! Item was removed: - Url subclass: #HierarchicalUrl - instanceVariableNames: 'schemeName authority path query port username password' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-Url'! - - !HierarchicalUrl commentStamp: '<historical>' prior: 0! - A URL which has a hierarchical encoding. For instance, http and ftp URLs are hierarchical.! Item was removed: - ----- Method: HierarchicalUrl class>>schemeName:authority:path:query: (in category 'instance creation') ----- - schemeName: schemeName authority: authority path: path query: query - ^self new schemeName: schemeName authority: authority path: path query: query! Item was removed: - ----- Method: HierarchicalUrl>>authority (in category 'access') ----- - authority - ^authority! Item was removed: - ----- Method: HierarchicalUrl>>directoryUrl (in category 'access') ----- - directoryUrl - "The path always has at least one element so this works." - - ^self copy path: (path copyFrom: 1 to: path size - 1)! Item was removed: - ----- Method: HierarchicalUrl>>fileName (in category 'access') ----- - fileName - "Return the last part of the path, - most often a filename but does not need to be." - - ^self path last! Item was removed: - ----- Method: HierarchicalUrl>>fullPath (in category 'printing') ----- - fullPath - | ans | - ans := WriteStream on: String new. - path do: [ :pathElem | - ans nextPut: $/. - ans nextPutAll: pathElem encodeForHTTP. ]. - self query isNil ifFalse: [ - ans nextPut: $?. - ans nextPutAll: self query. ]. - self fragment isNil ifFalse: [ - ans nextPut: $#. - ans nextPutAll: self fragment encodeForHTTP. ]. - - ^ans contents! Item was removed: - ----- Method: HierarchicalUrl>>hasContents (in category 'downloading') ----- - hasContents - "most of these do...." - ^true! Item was removed: - ----- Method: HierarchicalUrl>>hasSameSchemeSpecificPartAs: (in category 'comparing') ----- - hasSameSchemeSpecificPartAs: anotherUrl - - self authority = anotherUrl authority ifFalse: [^ false]. - self path = anotherUrl path ifFalse: [^ false]. - self query = anotherUrl query ifFalse: [^ false]. - self port = anotherUrl port ifFalse: [^ false]. - self username = anotherUrl username ifFalse: [^ false]. - self password = anotherUrl password ifFalse: [^ false]. - ^ true! Item was removed: - ----- Method: HierarchicalUrl>>hash (in category 'comparing') ----- - hash - - ^ (((((((fragment hash - bitXor: schemeName hash) - bitXor: authority hash) - bitXor: path hash) - bitXor: query hash) - bitXor: port hash) - bitXor: username hash) - bitXor: password hash)! Item was removed: - ----- Method: HierarchicalUrl>>isAbsolute (in category 'access') ----- - isAbsolute - - path size > 0 ifFalse: [^ false]. - (path at: 1) size > 0 ifFalse: [^ false]. - ^ ((path at: 1) at: 1) ~~ $.! Item was removed: - ----- Method: HierarchicalUrl>>password (in category 'access') ----- - password - "http://user:pword@foo.com' asUrl password" - ^password! Item was removed: - ----- Method: HierarchicalUrl>>path (in category 'access') ----- - path - "return a collection of the decoded path elements, as strings" - ^path! Item was removed: - ----- Method: HierarchicalUrl>>path: (in category 'access') ----- - path: aCollection - "Set the collection of path elements." - - path := aCollection! Item was removed: - ----- Method: HierarchicalUrl>>port (in category 'access') ----- - port - ^port! Item was removed: - ----- Method: HierarchicalUrl>>postCopy (in category 'copying') ----- - postCopy - "Be sure not to share the path with the original" - - super postCopy. - path := path copy! Item was removed: - ----- Method: HierarchicalUrl>>printOn: (in category 'printing') ----- - printOn: aStream - - aStream nextPutAll: self schemeName. - aStream nextPutAll: '://'. - self username ifNotNil: [ - aStream nextPutAll: self username encodeForHTTP. - self password ifNotNil: [ - aStream nextPutAll: ':'. - aStream nextPutAll: self password encodeForHTTP]. - aStream nextPutAll: '@' ]. - aStream nextPutAll: self authority. - port ifNotNil: [aStream nextPut: $:; print: port]. - path do: [ :pathElem | - aStream nextPut: $/. - aStream nextPutAll: pathElem encodeForHTTP. ]. - self query isNil ifFalse: [ - aStream nextPut: $?. - aStream nextPutAll: self query. ]. - self fragment isNil ifFalse: [ - aStream nextPut: $#. - aStream nextPutAll: self fragment encodeForHTTP. ].! Item was removed: - ----- Method: HierarchicalUrl>>privateInitializeFromText: (in category 'parsing') ----- - privateInitializeFromText: aString - | remainder ind specifiedSchemeName | - remainder := aString. - schemeName ifNil: - [specifiedSchemeName := Url schemeNameForString: remainder. - specifiedSchemeName ifNotNil: - [schemeName := specifiedSchemeName. - remainder := remainder copyFrom: schemeName size + 2 to: remainder size]. - schemeName ifNil: - ["assume HTTP" - - schemeName := 'http']]. - - "remove leading // if it's there" - (remainder beginsWith: '//') - ifTrue: [remainder := remainder copyFrom: 3 to: remainder size]. - - - "get the query" - ind := remainder indexOf: $?. - ind > 0 - ifTrue: - [query := remainder copyFrom: ind + 1 to: remainder size. - remainder := remainder copyFrom: 1 to: ind - 1]. - - "get the authority" - ind := remainder indexOf: $/. - ind > 0 - ifTrue: - [ind = 1 - ifTrue: [authority := ''] - ifFalse: - [authority := remainder copyFrom: 1 to: ind - 1. - remainder := remainder copyFrom: ind + 1 to: remainder size]] - ifFalse: - [authority := remainder. - remainder := '']. - - "extract the username+password" - (authority includes: $@) - ifTrue: - [username := authority copyUpTo: $@. - authority := authority copyFrom: (authority indexOf: $@) + 1 - to: authority size. - (username includes: $:) - ifTrue: - [password := (username copyFrom: (username indexOf: $:) + 1 to: username size) unescapePercents. - username := username copyUpTo: $:]. - username := username unescapePercents]. - - "Extract the port" - (authority includes: $:) - ifTrue: - [| lastColonIndex portString | - lastColonIndex := authority findLast: [:c | c = $:]. - portString := authority copyFrom: lastColonIndex + 1 to: authority size. - portString isAllDigits - ifTrue: - [port := Integer readFromString: portString. - (port > 65535) ifTrue: [self error: 'Invalid port number']. - authority := authority copyFrom: 1 to: lastColonIndex - 1] - ifFalse:[self error: 'Invalid port number']]. - - "get the path" - path := self privateParsePath: remainder relativeTo: #() .! Item was removed: - ----- Method: HierarchicalUrl>>privateInitializeFromText:relativeTo: (in category 'parsing') ----- - privateInitializeFromText: aString relativeTo: aUrl - | remainder ind basePath | - remainder := aString. - "set the scheme" - schemeName := aUrl schemeName. - - "a leading // means the authority is specified, meaning it is absolute" - (remainder beginsWith: '//') - ifTrue: [^ self privateInitializeFromText: aString]. - - "otherwise, use the same authority" - authority := aUrl authority. - port := aUrl port. - username := aUrl username. - password := aUrl password. - - "get the query" - ind := remainder indexOf: $?. - ind > 0 - ifTrue: [query := remainder copyFrom: ind + 1 to: remainder size. - remainder := remainder copyFrom: 1 to: ind - 1]. - - "get the path" - (remainder beginsWith: '/') - ifTrue: [ basePath := #() ] - ifFalse: [ basePath := aUrl path ]. - path := self privateParsePath: remainder relativeTo: basePath. - - ! Item was removed: - ----- Method: HierarchicalUrl>>privateParsePath:relativeTo: (in category 'parsing') ----- - privateParsePath: remainder relativeTo: basePath - | nextTok s parsedPath | - s := ReadStream on: remainder. - - parsedPath := OrderedCollection new. - parsedPath addAll: basePath. - parsedPath isEmpty ifFalse: [ parsedPath removeLast ]. - - [s peek = $/ ifTrue: [s next]. - nextTok := WriteStream on: String new. - [s atEnd or: [s peek = $/]] whileFalse: [nextTok nextPut: s next]. - nextTok := nextTok contents unescapePercents. - nextTok = '..' - ifTrue: [parsedPath size > 0 ifTrue: [parsedPath removeLast]] - ifFalse: [nextTok ~= '.' ifTrue: [parsedPath add: nextTok]]. - s atEnd] - whileFalse. - parsedPath isEmpty ifTrue: [parsedPath add: '']. - - ^parsedPath! Item was removed: - ----- Method: HierarchicalUrl>>query (in category 'access') ----- - query - "return the query, the part after any ?. Any %XY's have already been decoded. If there wasno query part, nil is returned (it is possible to also have an empty query" - ^query ! Item was removed: - ----- Method: HierarchicalUrl>>scheme (in category 'classification') ----- - scheme - ^ self schemeName.! Item was removed: - ----- Method: HierarchicalUrl>>schemeName (in category 'access') ----- - schemeName - ^schemeName! Item was removed: - ----- Method: HierarchicalUrl>>schemeName:authority:path:query: (in category 'private') ----- - schemeName: schemeName0 authority: authority0 path: path0 query: query0 - "initialize a new instance" - schemeName := schemeName0. - authority := authority0. - path := path0. - query := query0. - ! Item was removed: - ----- Method: HierarchicalUrl>>username (in category 'access') ----- - username - "http://user:pword@foo.com' asUrl username" - ^username! Item was removed: - HierarchicalUrl subclass: #HttpUrl - instanceVariableNames: 'realm' - classVariableNames: 'Passwords' - poolDictionaries: '' - category: 'Network-Url'! - - !HttpUrl commentStamp: 'ls 6/15/2003 13:44' prior: 0! - A URL that can be accessed via the Hypertext Transfer Protocol (HTTP), ie, a standard Web URL - - realm = the name of the security realm that has been discovered for this URL. Look it up in Passwords. - - Passwords = a Dictionary of (realm -> encoded user&password) - - - TODO: use the username and password, if specified - ! Item was removed: - ----- Method: HttpUrl class>>shutDown (in category 'system startup') ----- - shutDown - "Forget all cached passwords, so they won't stay in the image" - - Passwords := nil.! Item was removed: - ----- Method: HttpUrl>>= (in category 'comparing') ----- - = anObject - - self == anObject ifTrue: [^ true]. - super = anObject ifFalse: [^ false]. - - self realm = anObject realm ifFalse: [^ false]. - - ^ true! Item was removed: - ----- Method: HttpUrl>>askNamePassword (in category 'downloading') ----- - askNamePassword - "Authorization is required by the host site. Ask the user for a userName and password. Encode them and store under this realm. Return false if the user wants to give up." - - | user pass | - (self confirm: 'Host ', self asString, ' - wants a different user and password. Type them now?' orCancel: [false]) - ifFalse: [^ false]. - user := UIManager default request: 'User account name?' initialAnswer: ''. - pass := UIManager default requestPassword: 'Password?'. - Passwords at: realm put: (Authorizer new encode: user password: pass). - ^ true! Item was removed: - ----- Method: HttpUrl>>checkAuthorization:retry: (in category 'downloading') ----- - checkAuthorization: webDocument retry: retryBlock - "authorization failed if webDocument is a String" - | oldRealm i end encoded | - ((webDocument isString) - and: [(webDocument beginsWith: 'HTTP/1.0 401') - or: [webDocument beginsWith: 'HTTP/1.1 401']]) - ifFalse: [^self]. - - oldRealm := realm. - i := webDocument findString: 'realm="'. - i = 0 ifTrue: [^self]. - end := webDocument indexOf: $" startingAt: i. - realm := webDocument copyFrom: i+7 to: end. - "realm := (webDocument findTokens: '""') at: 2." - Passwords ifNil: [Passwords := Dictionary new]. - encoded := Passwords at: realm ifAbsent: [nil]. - (oldRealm ~= realm) & (encoded ~~ nil) - ifTrue: [^ retryBlock value] - ifFalse: ["ask the user" - self askNamePassword ifTrue: [^ retryBlock value]]! Item was removed: - ----- Method: HttpUrl>>hasRemoteContents (in category 'testing') ----- - hasRemoteContents - "Return true if the receiver describes some remotely accessible content. - Typically, this should only return if we could retrieve the contents - on an arbitrary place in the outside world using a standard browser. - In other words: If you can get to it from the next Internet Cafe, - return true, else return false." - ^true! Item was removed: - ----- Method: HttpUrl>>hasSameSchemeSpecificPartAs: (in category 'comparing') ----- - hasSameSchemeSpecificPartAs: anotherUrl - - (super hasSameSchemeSpecificPartAs: anotherUrl) ifFalse: [^ false]. - self realm = anotherUrl realm ifFalse: [^ false]. - ^ true! Item was removed: - ----- Method: HttpUrl>>hash (in category 'comparing') ----- - hash - - ^ super hash bitXor: realm hash! Item was removed: - ----- Method: HttpUrl>>loadRemoteObjects (in category 'downloading') ----- - loadRemoteObjects - "Load a remote image segment and extract the root objects. - Check if the remote file is a zip archive." - "'http://bradley.online.disney.com/games/subgame/squeak-test/assetInfo.extSeg' - asUrl loadRemoteObjects" - "'http://bradley.online.disney.com/games/subgame/squeak-test/assetInfo.zip' - asUrl loadRemoteObjects" - - | stream info data extension | - data := self retrieveContents content. - extension := (FileDirectory extensionFor: self path last) asLowercase. - (#('zip' 'gzip') includes: extension) - ifTrue: [data := (GZipReadStream on: data) upToEnd]. - " stream := StreamWrapper streamOver: (ReadStream on: data)." - stream := RWBinaryOrTextStream on: data. - stream reset. - info := stream fileInObjectAndCode. - stream close. - ^info arrayOfRoots! Item was removed: - ----- Method: HttpUrl>>normalizeContents: (in category 'downloading') ----- - normalizeContents: webDocument - (webDocument isString) ifTrue: [ - ^MIMEDocument - contentType: 'text/plain' - content: 'error occured retrieving ', self asString, ': ', webDocument - url: (Url absoluteFromText: '')]. - webDocument contentType = MIMEDocument defaultContentType ifTrue: [ - ^MIMEDocument contentType: (MIMEDocument guessTypeFromName: self path last) - content: webDocument content url: webDocument url ]. - - ^webDocument! Item was removed: - ----- Method: HttpUrl>>postFormArgs: (in category 'downloading') ----- - postFormArgs: args - | contents request | - request := realm ifNotNil: [Passwords at: realm ifAbsent: ['']] - ifNil: ['']. - request = '' ifFalse: [request := 'Authorization: Basic ', request, String crlf]. - "Why doesn't Netscape send the name of the realm instead of Basic?" - contents := (HTTPSocket httpPostDocument: self asString args: args - accept: 'application/octet-stream' request: request). - - self checkAuthorization: contents retry: [^ self postFormArgs: args]. - - ^self normalizeContents: contents! Item was removed: - ----- Method: HttpUrl>>postMultipartFormArgs: (in category 'downloading') ----- - postMultipartFormArgs: args - | contents request | - request := realm ifNotNil: [Passwords at: realm ifAbsent: ['']] - ifNil: ['']. - request = '' ifFalse: [request := 'Authorization: Basic ', request, String crlf]. - "Why doesn't Netscape send the name of the realm instead of Basic?" - contents := (HTTPSocket httpPostMultipart: self asString args: args - accept: 'application/octet-stream' request: request). - - self checkAuthorization: contents retry: [^ self postMultipartFormArgs: args]. - - ^self normalizeContents: contents! Item was removed: - ----- Method: HttpUrl>>privateInitializeFromText:relativeTo: (in category 'downloading') ----- - privateInitializeFromText: aString relativeTo: aUrl - - super privateInitializeFromText: aString relativeTo: aUrl. - realm := aUrl realm.! Item was removed: - ----- Method: HttpUrl>>realm (in category 'downloading') ----- - realm - ^ realm! Item was removed: - ----- Method: HttpUrl>>retrieveContents (in category 'downloading') ----- - retrieveContents - ^ self retrieveContentsArgs: nil! Item was removed: - ----- Method: HttpUrl>>retrieveContentsAccept: (in category 'downloading') ----- - retrieveContentsAccept: mimeType - ^ self retrieveContentsArgs: nil accept: mimeType! Item was removed: - ----- Method: HttpUrl>>retrieveContentsArgs: (in category 'downloading') ----- - retrieveContentsArgs: args - ^self retrieveContentsArgs: args accept: '*/*; q=1'! Item was removed: - ----- Method: HttpUrl>>retrieveContentsArgs:accept: (in category 'downloading') ----- - retrieveContentsArgs: args accept: mimeType - | contents request | - request := realm ifNotNil: [Passwords at: realm ifAbsent: ['']] ifNil: ['']. - request = '' ifFalse: [request := 'Authorization: Basic ' , request , String crlf]. - "Why doesn't Netscape send the name of the realm instead of Basic?" - - contents := (HTTPSocket - httpGetDocument: self withoutFragment asString - args: args - accept: mimeType - request: request). - - self checkAuthorization: contents retry: [^ self retrieveContentsArgs: args]. - - ^ self normalizeContents: contents! Item was removed: - Error subclass: #IllegalURIException - instanceVariableNames: 'uriString' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-URI'! Item was removed: - ----- Method: IllegalURIException>>uriString (in category 'accessing') ----- - uriString - ^uriString! Item was removed: - ----- Method: IllegalURIException>>uriString: (in category 'accessing') ----- - uriString: aString - uriString := aString! Item was removed: - Object subclass: #InternetConfiguration - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-Kernel'! Item was removed: - ----- Method: InternetConfiguration class>>getArchiePreferred (in category 'lookups') ----- - getArchiePreferred - "Return the preferred Archie server" - "InternetConfiguration getArchiePreferred" - - ^self primitiveGetStringKeyedBy: 'ArchiePreferred' - ! Item was removed: - ----- Method: InternetConfiguration class>>getDownloadPath (in category 'lookups') ----- - getDownloadPath - "Return the download path" - "InternetConfiguration getDownloadPath" - - ^self primitiveGetStringKeyedBy: 'DownLoadPath' - ! Item was removed: - ----- Method: InternetConfiguration class>>getEmail (in category 'lookups') ----- - getEmail - "Return the email address of user" - "InternetConfiguration getEmail" - - ^self primitiveGetStringKeyedBy: 'Email' - ! Item was removed: - ----- Method: InternetConfiguration class>>getFTPHost (in category 'lookups') ----- - getFTPHost - "Return the FTPHost" - "InternetConfiguration getFTPHost" - - ^self primitiveGetStringKeyedBy: 'FTPHost' - ! Item was removed: - ----- Method: InternetConfiguration class>>getFTPProxyAccount (in category 'lookups') ----- - getFTPProxyAccount - "Return the second level FTP proxy authorisation" - "InternetConfiguration getFTPProxyAccount" - - ^self primitiveGetStringKeyedBy: 'FTPProxyAccount' - ! Item was removed: - ----- Method: InternetConfiguration class>>getFTPProxyHost (in category 'lookups') ----- - getFTPProxyHost - "Return the FTP proxy host" - "InternetConfiguration getFTPProxyHost" - - ^self primitiveGetStringKeyedBy: 'FTPProxyHost' - ! Item was removed: - ----- Method: InternetConfiguration class>>getFTPProxyPassword (in category 'lookups') ----- - getFTPProxyPassword - "Return the FTP proxy password" - "InternetConfiguration getFTPProxyPassword" - - ^self primitiveGetStringKeyedBy: 'FTPProxyPassword' - ! Item was removed: - ----- Method: InternetConfiguration class>>getFTPProxyUser (in category 'lookups') ----- - getFTPProxyUser - "Return the first level FTP proxy authorisation" - "InternetConfiguration getFTPProxyUser" - - ^self primitiveGetStringKeyedBy: 'FTPProxyUser' - ! Item was removed: - ----- Method: InternetConfiguration class>>getFingerHost (in category 'lookups') ----- - getFingerHost - "Return the default finger server" - "InternetConfiguration getFingerHost" - - ^self primitiveGetStringKeyedBy: 'FingerHost' - ! Item was removed: - ----- Method: InternetConfiguration class>>getGopherHost (in category 'lookups') ----- - getGopherHost - "Return the default Gopher server" - "InternetConfiguration getGopherHost" - - ^self primitiveGetStringKeyedBy: 'GopherHost' - ! Item was removed: - ----- Method: InternetConfiguration class>>getGopherProxy (in category 'lookups') ----- - getGopherProxy - "Return the Gopher proxy" - "InternetConfiguration getGopherProxy" - - ^self primitiveGetStringKeyedBy: 'GopherProxy' - ! Item was removed: - ----- Method: InternetConfiguration class>>getHTTPProxyHost (in category 'lookups') ----- - getHTTPProxyHost - "Return the http proxy for this client." - "InternetConfiguration getHTTPProxyHost" - - ^self primitiveGetStringKeyedBy: 'HTTPProxyHost' - ! Item was removed: - ----- Method: InternetConfiguration class>>getIRCHost (in category 'lookups') ----- - getIRCHost - "Return the Internet Relay Chat server" - "InternetConfiguration getIRCHost" - - ^self primitiveGetStringKeyedBy: 'IRCHost' - ! Item was removed: - ----- Method: InternetConfiguration class>>getLDAPSearchbase (in category 'lookups') ----- - getLDAPSearchbase - "Return the LDAP thing" - "InternetConfiguration getLDAPSearchbase" - - ^self primitiveGetStringKeyedBy: 'LDAPSearchbase' - ! Item was removed: - ----- Method: InternetConfiguration class>>getLDAPServer (in category 'lookups') ----- - getLDAPServer - "Return the LDAP server" - "InternetConfiguration getLDAPServer" - - ^self primitiveGetStringKeyedBy: 'LDAPServer' - ! Item was removed: - ----- Method: InternetConfiguration class>>getMacintoshFileTypeAndCreatorFrom: (in category 'lookups') ----- - getMacintoshFileTypeAndCreatorFrom: aFileName - "Return the application type and application signature for the file - for the macintosh file system based on the file ending, the file does not need to exist - failure to find a signature based on the file ending, or because of primitive failure turns nil" - "InternetConfiguration getMacintoshFileTypeAndCreatorFrom: 'test.jpg'" - | string | - - string := self primitiveGetMacintoshFileTypeAndCreatorFrom: aFileName. - string = '********' ifTrue: [^nil]. - ^Array with: (string first: 4) with: (string last: 4) - ! Item was removed: - ----- Method: InternetConfiguration class>>getMailAccount (in category 'lookups') ----- - getMailAccount - "Return the mail account user at host.domain" - "InternetConfiguration getMailAccount" - - ^self primitiveGetStringKeyedBy: 'MailAccount' - ! Item was removed: - ----- Method: InternetConfiguration class>>getMailPassword (in category 'lookups') ----- - getMailPassword - "Return the mail account Password " - "InternetConfiguration getMailPassword " - - ^self primitiveGetStringKeyedBy: 'MailPassword' - ! Item was removed: - ----- Method: InternetConfiguration class>>getNNTPHost (in category 'lookups') ----- - getNNTPHost - "Return the NNTP server" - "InternetConfiguration getNNTPHost" - - ^self primitiveGetStringKeyedBy: 'NNTPHost' - ! Item was removed: - ----- Method: InternetConfiguration class>>getNTPHost (in category 'lookups') ----- - getNTPHost - "Return the Network Time Protocol (NTP)" - "InternetConfiguration getNTPHost" - - ^self primitiveGetStringKeyedBy: 'NTPHost' - ! Item was removed: - ----- Method: InternetConfiguration class>>getNewsAuthPassword (in category 'lookups') ----- - getNewsAuthPassword - "Return the Password for the authorised news servers" - "InternetConfiguration getNewsAuthPassword" - - ^self primitiveGetStringKeyedBy: 'NewsAuthPassword' - ! Item was removed: - ----- Method: InternetConfiguration class>>getNewsAuthUsername (in category 'lookups') ----- - getNewsAuthUsername - "Return the user name for authorised news servers" - "InternetConfiguration getNewsAuthUsername" - - ^self primitiveGetStringKeyedBy: 'NewsAuthUsername' - ! Item was removed: - ----- Method: InternetConfiguration class>>getNoProxyDomains (in category 'lookups') ----- - getNoProxyDomains - "Return a comma seperated string of domains not to proxy" - "InternetConfiguration getNoProxyDomains" - - ^self primitiveGetStringKeyedBy: 'NoProxyDomains' - ! Item was removed: - ----- Method: InternetConfiguration class>>getOrganization (in category 'lookups') ----- - getOrganization - "Return the Organization" - "InternetConfiguration getOrganization" - - ^self primitiveGetStringKeyedBy: 'Organization' - ! Item was removed: - ----- Method: InternetConfiguration class>>getPhHost (in category 'lookups') ----- - getPhHost - "Return the PhHost server" - "InternetConfiguration getPhHost" - - ^self primitiveGetStringKeyedBy: 'PhHost' - ! Item was removed: - ----- Method: InternetConfiguration class>>getRealName (in category 'lookups') ----- - getRealName - "Return the RealName" - "InternetConfiguration getRealName" - - ^self primitiveGetStringKeyedBy: 'RealName' - ! Item was removed: - ----- Method: InternetConfiguration class>>getSMTPHost (in category 'lookups') ----- - getSMTPHost - "Return the SMTP server" - "InternetConfiguration getSMTPHost" - - ^self primitiveGetStringKeyedBy: 'SMTPHost' - ! Item was removed: - ----- Method: InternetConfiguration class>>getSocksHost (in category 'lookups') ----- - getSocksHost - "Return the Socks server" - "InternetConfiguration getSocksHost" - - ^self primitiveGetStringKeyedBy: 'SocksHost' - ! Item was removed: - ----- Method: InternetConfiguration class>>getTelnetHost (in category 'lookups') ----- - getTelnetHost - "Return the TelnetHost server" - "InternetConfiguration getTelnetHost" - - ^self primitiveGetStringKeyedBy: 'TelnetHost' - ! Item was removed: - ----- Method: InternetConfiguration class>>getWAISGateway (in category 'lookups') ----- - getWAISGateway - "Return the wais gateway" - "InternetConfiguration getWAISGateway" - - ^self primitiveGetStringKeyedBy: 'WAISGateway' - ! Item was removed: - ----- Method: InternetConfiguration class>>getWWWHomePage (in category 'lookups') ----- - getWWWHomePage - "Return the WWW home page url" - "InternetConfiguration getWWWHomePage" - - ^self primitiveGetStringKeyedBy: 'WWWHomePage' - ! Item was removed: - ----- Method: InternetConfiguration class>>getWhoisHost (in category 'lookups') ----- - getWhoisHost - "Return the WhoisHost server" - "InternetConfiguration getWhoisHost" - - ^self primitiveGetStringKeyedBy: 'WhoisHost' - ! Item was removed: - ----- Method: InternetConfiguration class>>initialize (in category 'initialize-release') ----- - initialize - "self initialize" - Smalltalk addToStartUpList: self. - Smalltalk addToShutDownList: self.! Item was removed: - ----- Method: InternetConfiguration class>>primitiveGetMacintoshFileTypeAndCreatorFrom: (in category 'system primitives') ----- - primitiveGetMacintoshFileTypeAndCreatorFrom: aFileName - <primitive: 'primitiveGetMacintoshFileTypeAndCreatorFrom' module: 'InternetConfigPlugin'> - ^'********' copy ! Item was removed: - ----- Method: InternetConfiguration class>>primitiveGetStringKeyedBy: (in category 'system primitives') ----- - primitiveGetStringKeyedBy: aKey - <primitive: 'primitiveGetStringKeyedBy' module: 'InternetConfigPlugin'> - ^String new. - ! Item was removed: - ----- Method: InternetConfiguration class>>shutDown (in category 'system startup') ----- - shutDown - (Smalltalk platformName = 'Mac OS') ifTrue: [ - HTTPSocket stopUsingProxyServer] - - ! Item was removed: - ----- Method: InternetConfiguration class>>startUp (in category 'system startup') ----- - startUp - (Smalltalk platformName = 'Mac OS') ifTrue: [ - self useHTTPProxy ifTrue: [ - (self getHTTPProxyHost findTokens: ':') ifNotEmpty: [:p | - HTTPSocket useProxyServerNamed: p first port: p second asInteger]]]! Item was removed: - ----- Method: InternetConfiguration class>>useFTPProxy (in category 'tests') ----- - useFTPProxy - "Return true if UseFTPProxy" - "InternetConfiguration useFTPProxy" - - ^(self primitiveGetStringKeyedBy: 'UseFTPProxy') = '1' - ! Item was removed: - ----- Method: InternetConfiguration class>>useGopherProxy (in category 'tests') ----- - useGopherProxy - "Return true if UseGopherProxy" - "InternetConfiguration useGopherProxy" - - ^(self primitiveGetStringKeyedBy: 'UseGopherProxy') = '1' - ! Item was removed: - ----- Method: InternetConfiguration class>>useHTTPProxy (in category 'tests') ----- - useHTTPProxy - "Return true if UseHTTPProxy" - "InternetConfiguration useHTTPProxy" - - ^(self primitiveGetStringKeyedBy: 'UseHTTPProxy') = '1' - ! Item was removed: - ----- Method: InternetConfiguration class>>usePassiveFTP (in category 'tests') ----- - usePassiveFTP - "Return true if UsePassiveFTP" - "InternetConfiguration usePassiveFTP" - - ^(self primitiveGetStringKeyedBy: 'UsePassiveFTP') = '1' - ! Item was removed: - ----- Method: InternetConfiguration class>>useSocks (in category 'tests') ----- - useSocks - "Return true if UseSocks" - "InternetConfiguration useSocks" - - ^(self primitiveGetStringKeyedBy: 'UseSocks') = '1' - ! Item was removed: - Error subclass: #InvalidSocketStatusException - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-Kernel'! - - !InvalidSocketStatusException commentStamp: 'mir 5/12/2003 18:15' prior: 0! - Signals if an operation on a Socket found it in a state invalid for that operation. - ! Item was removed: - ProtocolClientError subclass: #LoginFailedException - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-Protocols'! - - !LoginFailedException commentStamp: 'mir 5/12/2003 17:57' prior: 0! - Exception for signaling login failures of protocol clients. - ! Item was removed: - ----- Method: LoginFailedException>>isResumable (in category 'exceptionDescription') ----- - isResumable - "Resumable so we can give the user another chance to login" - - ^true! Item was removed: - Object subclass: #MIMEDocument - instanceVariableNames: 'mainType subType content fields url parts' - classVariableNames: 'MIMEdatabase' - poolDictionaries: '' - category: 'Network-Url'! - - !MIMEDocument commentStamp: 'pre 7/6/2017 13:58' prior: 0! - a MIME object, along with its type and the URL it was found at (if any) - - Design decisions: - - The API for using the content of the MIME object inside Squeak returns Strings - in Squeak encoding. The serializing methods return the content serialized according - to the content-type and content-transfer-encoding --pre! Item was removed: - ----- Method: MIMEDocument class>>cleanUp (in category 'initialize-release') ----- - cleanUp - - self resetMIMEdatabase.! Item was removed: - ----- Method: MIMEDocument class>>content: (in category 'instance creation') ----- - content: aString - ^self contentType: self defaultContentType content: aString! Item was removed: - ----- Method: MIMEDocument class>>contentType: (in category 'private') ----- - contentType: aString - - ^ self new - contentTypeHeaderValue: (MIMEHeaderValue fromMIMEHeader: aString); - yourself! Item was removed: - ----- Method: MIMEDocument class>>contentType:content: (in category 'instance creation') ----- - contentType: aString content: content - "create a MIMEObject with the given content-type and content" - "MIMEDocument contentType: 'text/plain' content: 'This is a test'" - - | ans | - ans := self contentType: aString. - - (ans isPlaintext or: [ans isHTML]) - ifTrue: [ans content: (self tryToDecodeBody: content as: ans charset)] - ifFalse: [ans isMultipart - ifTrue: [| separator | - separator := ans attachmentSeparator asLowercase. - separator ifNil: [self error: 'Bad attachment separater']. - - separator := '--', separator withoutTrailingBlanks. - ans addAllParts: (self parseParts: content withSeparator:separator).] - ifFalse: [ans content: content]]. - - ^ ans! Item was removed: - ----- Method: MIMEDocument class>>contentType:content:url: (in category 'instance creation') ----- - contentType: aString content: content url: aUrl - "create a MIMEObject with the given content-type and content" - "MIMEObject contentType: 'text/plain' content: 'This is a test'" - - | ans | - ans := self contentType: aString content: content. - ans privateUrl: aUrl asUrl. - ^ans - ! Item was removed: - ----- Method: MIMEDocument class>>contentTypeBinaryData (in category 'content-types') ----- - contentTypeBinaryData - ^'application/octet-stream'! Item was removed: - ----- Method: MIMEDocument class>>contentTypeFormData (in category 'content-types') ----- - contentTypeFormData - ^'application/x-www-form-urlencoded'! Item was removed: - ----- Method: MIMEDocument class>>contentTypeHtml (in category 'content-types') ----- - contentTypeHtml - ^'text/html'! Item was removed: - ----- Method: MIMEDocument class>>contentTypeMultipart (in category 'content-types') ----- - contentTypeMultipart - ^'multipart/form-data'! Item was removed: - ----- Method: MIMEDocument class>>contentTypeMultipartAlternative (in category 'content-types') ----- - contentTypeMultipartAlternative - ^'multipart/alternative'! Item was removed: - ----- Method: MIMEDocument class>>contentTypeMultipartMixed (in category 'content-types') ----- - contentTypeMultipartMixed - ^'multipart/mixed'! Item was removed: - ----- Method: MIMEDocument class>>contentTypePlainText (in category 'content-types') ----- - contentTypePlainText - ^'text/plain'! Item was removed: - ----- Method: MIMEDocument class>>contentTypeXml (in category 'content-types') ----- - contentTypeXml - ^'text/xml'! Item was removed: - ----- Method: MIMEDocument class>>defaultContentType (in category 'content-types') ----- - defaultContentType - ^ self contentTypeBinaryData! Item was removed: - ----- Method: MIMEDocument class>>defaultMIMEdatabase (in category 'initialize-release') ----- - defaultMIMEdatabase - | d | - (d := Dictionary new) - at: 'html' put: 'text/html'; - at: 'htm' put: 'text/html'; - at: 'xml' put: 'text/xml'; - at: 'txt' put: 'text/plain'; - at: 'c' put: 'text/plain'; - at: 'gif' put: 'image/gif'; - at: 'jpg' put: 'image/jpeg'; - at: 'jpeg' put: 'image/jpeg'; - at: 'gif' put: 'image/gif'; - at: 'png' put: 'image/png'; - at: 'pnm' put: 'image/pnm'; - at: 'xbm' put: 'image/x-xbitmap'; - at: 'mid' put: 'audio/midi'; - at: 'doc' put: 'application/ms-word-document'. - ^d! Item was removed: - ----- Method: MIMEDocument class>>extendedMIMEdatabase (in category 'initialize-release') ----- - extendedMIMEdatabase - | d | - (d := self defaultMIMEdatabase) - at: 'hqx' put: 'application/mac-binhex40'; - at: 'cpt' put: 'application/mac-compactpro'; - at: 'pdf' put: 'application/pdf'; - at: 'ps' put: 'application/postscript'; - at: 'ai' put: 'application/postscript'; - at: 'eps' put: 'application/postscript'; - at: 'rtf' put: 'text/rtf'; - at: 'ics' put: 'text/calendar'; - at: 'bin' put: 'application/octet-stream'; - at: 'dms' put: 'application/octet-stream'; - at: 'lha' put: 'application/octet-stream'; - at: 'lzh' put: 'application/octet-stream'; - at: 'exe' put: 'application/octet-stream'; - at: 'class' put: 'application/octet-stream'; - at: 'zip' put: 'application/zip'; - at: 'gtar' put: 'application/x-gtar'; - at: 'swf' put: 'application/x-shockwave-flash'; - at: 'sit' put: 'application/x-stuffit'; - at: 'tar' put: 'application/x-tar'; - at: 'au' put: 'audio/basic'; - at: 'snd' put: 'audio/basic'; - at: 'mid' put: 'audio/midi'; - at: 'midi' put: 'audio/midi'; - at: 'mpga' put: 'audio/mpeg'; - at: 'mp2' put: 'audio/mpeg'; - at: 'mp3' put: 'audio/mpeg'; - at: 'aiff' put: 'audio/x-aiff'; - at: 'aif' put: 'audio/x-aiff'; - at: 'aifc' put: 'audio/x-aiff'; - at: 'rm' put: 'audio/x-pn-realaudio'; - at: 'ram' put: 'audio/x-pn-realaudio'; - at: 'rpm' put: 'audio/x-pn-realaudio-plugin'; - at: 'ra' put: 'audio/x-realaudio'; - at: 'wav' put: 'audio/x-wav'; - at: 'css' put: 'text/css'; - at: 'mpeg' put: 'video/mpeg'; - at: 'mpg' put: 'video/mpeg'; - at: 'mpe' put: 'video/mpeg'; - at: 'qt' put: 'video/quicktime'; - at: 'mov' put: 'video/quicktime'; - at: 'avi' put: 'video/x-msvideo'; - at: 'movie' put: 'video/x-sgi-movie'. - ^ d! Item was removed: - ----- Method: MIMEDocument class>>fromPartString: (in category 'instance creation') ----- - fromPartString: aString - "This method allows for easy creation of MIME documents - representing parts in a multipart MIME document" - - ^ self new initializeFromString: aString! Item was removed: - ----- Method: MIMEDocument class>>guessTypeFromExtension: (in category 'content-types') ----- - guessTypeFromExtension: ext - "guesses a content type from the extension" - | extension | - extension := ext asString. - (extension includes: $.) ifTrue: [ ^self defaultContentType]. - - MIMEdatabase ifNil: [self resetMIMEdatabase]. - ^ MIMEdatabase at: extension ifAbsent: [self defaultContentType].! Item was removed: - ----- Method: MIMEDocument class>>guessTypeFromName: (in category 'content-types') ----- - guessTypeFromName: url - "guesses a content type from the url" - | extension | - extension := url asString. - (extension includes: $.) ifFalse: [ ^self defaultContentType]. - - extension := (extension findTokens: '.') last asLowercase. - - MIMEdatabase ifNil: [self resetMIMEdatabase]. - ^ MIMEdatabase at: extension ifAbsent: [self defaultContentType]. - ! Item was removed: - ----- Method: MIMEDocument class>>linkExtension:toType: (in category 'content-types') ----- - linkExtension: ext toType: mimeType - MIMEdatabase at: ext asString put: mimeType asString! Item was removed: - ----- Method: MIMEDocument class>>newMultipart (in category 'instance creation') ----- - newMultipart - - | ans | - - ans := self new. - - ans contentTypeHeaderValue: (MIMEHeaderValue fromMIMEHeader: self contentTypeMultipartMixed). - ans contentTypeHeaderValue parameterAt: 'boundary' put: MailMessage generateSeparator. - - ^ ans! Item was removed: - ----- Method: MIMEDocument class>>parseParts:withSeparator: (in category 'instance creation') ----- - parseParts: bodyText withSeparator: separator - "private -- parse the parts of the message and store them into a collection" - - | parseStream msgStream messages normalizedSeparator | - - parseStream := ReadStream on: bodyText. - - msgStream := LimitingLineStreamWrapper on: parseStream delimiter: separator. - normalizedSeparator := separator asLowercase. - msgStream limitingBlock: [:aLine | | normalizedLine | - normalizedLine := aLine withoutTrailingBlanks asLowercase. - normalizedLine = normalizedSeparator or: "Match the separator" - [normalizedLine = ('--',normalizedSeparator)] or: "or -- and the separator" - [normalizedLine = (normalizedSeparator, '--')]]. "or the final separator with --" - - "Throw away everything up to and including the first separator" - msgStream upToEnd. - msgStream skipThisLine. - - "Extract each of the multi-parts as strings" - messages := OrderedCollection new. - [parseStream atEnd] - whileFalse: - [messages add: msgStream upToEnd. - msgStream skipThisLine]. - - ^ messages collect: [:e | MIMEDocument fromPartString: e]! Item was removed: - ----- Method: MIMEDocument class>>readMIMEdatabaseFrom: (in category 'initialize-release') ----- - readMIMEdatabaseFrom: someStream - | d line tokens stream | - "type/subtype extension" - "white spaces are separators" - "apache conf file format: mime.types" - - "must normalize line endings" - stream := ReadStream on: someStream contentsOfEntireFile withSqueakLineEndings. - - d := Dictionary new. - [(line := stream nextLine) isNil not] - whileTrue: [tokens := line findTokens: ' '. - (tokens size = 2 and: [line first ~= $#]) - ifTrue: [d at: tokens second put: tokens first]]. - ^d! Item was removed: - ----- Method: MIMEDocument class>>resetMIMEdatabase (in category 'initialize-release') ----- - resetMIMEdatabase - MIMEdatabase := self extendedMIMEdatabase! Item was removed: - ----- Method: MIMEDocument class>>tryToDecodeBody:as: (in category 'instance creation') ----- - tryToDecodeBody: content as: encodingName - - ^ [(MultiByteBinaryOrTextStream - with: content - encoding: encodingName) contents] - on: InvalidUTF8 , NoConverterFound do: [(MultiByteBinaryOrTextStream - with: content - encoding: 'latin1') contents]! Item was removed: - ----- Method: MIMEDocument class>>tryToEncodeBody:as: (in category 'instance creation') ----- - tryToEncodeBody: content as: encodingName - - ^ content convertToEncoding: encodingName! Item was removed: - ----- Method: MIMEDocument>>addAllParts: (in category 'parts') ----- - addAllParts: MIMEDocuments - - parts addAll: MIMEDocuments! Item was removed: - ----- Method: MIMEDocument>>addPart: (in category 'parts') ----- - addPart: aMIMEDocument - - parts add: aMIMEDocument! Item was removed: - ----- Method: MIMEDocument>>asSendableBodyText (in category 'serializing') ----- - asSendableBodyText - - | sendableBodyText | - sendableBodyText := self isMultipart - ifTrue: [self sendableMultipartBodyText] - ifFalse: [(self isPlaintext or: [self isHTML]) - ifTrue: [self class tryToEncodeBody: self contents as: self charset] - ifFalse: [self contents]]. - - ^ (self hasFieldNamed: 'content-transfer-encoding') - ifFalse: [sendableBodyText] - ifTrue: [ | transferEncoding | - transferEncoding := self contentTransferEncoding. - (MimeConverter forEncoding: transferEncoding) mimeEncode: sendableBodyText readStream ] ! Item was removed: - ----- Method: MIMEDocument>>asSendablePartText (in category 'serializing') ----- - asSendablePartText - - ^ String streamContents: [ :str | | | - "first put the header" - fields keysAndValuesDo: [ :fieldName :fieldValues | - fieldValues do: [ :fieldValue | - str - nextPutAll: fieldName capitalized ; - nextPutAll: ': '; - nextPutAll: fieldValue asHeaderValue; - cr ]. ]. - - str cr. - - str nextPutAll: self asSendableBodyText].! Item was removed: - ----- Method: MIMEDocument>>attachmentFileName (in category 'accessing') ----- - attachmentFileName - - ^ (self fieldNamed: 'content-disposition' ifAbsent: [^ '']) - parameterAt: 'filename' ifAbsent: [''] ! Item was removed: - ----- Method: MIMEDocument>>attachmentSeparator (in category 'accessing') ----- - attachmentSeparator - ^(self fieldNamed: 'content-type' ifAbsent: [^nil]) parameters - at: 'boundary' ifAbsent: [^nil]! Item was removed: - ----- Method: MIMEDocument>>bodyTextFormatted (in category 'serializing') ----- - bodyTextFormatted - "Answer a version of the text in my body suitable for display. This will parse multipart forms, decode HTML, and other such things" - - self isMultipart ifTrue: [ - self isMultipartAlternative ifTrue: [ - "it's multipart/alternative. search for a part that we can display, biasing towards simpler formats" - #('text/plain' 'text/html') do: [ :format | - self parts do: [ :part | - part contentType = format ifTrue: [ ^ part bodyTextFormatted ] ] ]. - - "couldn't find a desirable part to display; just display the first part" - ^self parts first bodyTextFormatted ]. - - "not alternative parts. put something for each part" - ^Text streamContents: [ :str | - self parts do: [ :part | - ((#('text' 'multipart') includes: part mainType) or: - [ part contentType = 'message/rfc822']) - ifTrue: [ - "try to inline the message part" - str nextPutAll: part bodyTextFormatted. ] - ifFalse: [ - |descript | - str cr. - descript := part name ifNil: [ 'attachment' ]. - str nextPutAll: (Text string: '[', descript, ']' attribute: (TextMessageLink message: part)). ] ] ]. ]. - - - "check for HTML" - (self contentType = 'text/html') ifTrue: [ - Smalltalk at: #HtmlParser ifPresent: [ :htmlParser | - ^(htmlParser parse: (ReadStream on: self content)) formattedText]. - Smalltalk at: #HtmlReadWriter ifPresent: [:html | - ^ self content asTextFromHtml] - ]. - - "check for an embedded message" - self contentType = 'message/rfc822' ifTrue: [ - ^(MailMessage from: self content) formattedText ]. - - "nothing special--just return the text" - ^self content. - ! Item was removed: - ----- Method: MIMEDocument>>charset (in category 'accessing') ----- - charset - - ^ self contentTypeHeaderValue parameterAt: #charset ifAbsent: ['us-ascii']! Item was removed: - ----- Method: MIMEDocument>>charset: (in category 'accessing') ----- - charset: aString - - ^ self contentTypeHeaderValue parameterAt: #charset put: aString! Item was removed: - ----- Method: MIMEDocument>>containsViewableImage (in category 'testing') ----- - containsViewableImage - - ^ self isJpeg or: [self isGif or: [self isPng]]! Item was removed: - ----- Method: MIMEDocument>>content (in category 'accessing') ----- - content - "Answer the receiver's raw data." - - ^ content! Item was removed: - ----- Method: MIMEDocument>>content: (in category 'accessing') ----- - content: aString - content := aString! Item was removed: - ----- Method: MIMEDocument>>contentStream (in category 'accessing') ----- - contentStream - "Answer a RWBinaryOrTextStream on the contents." - - ^ (RWBinaryOrTextStream with: self content) reset! Item was removed: - ----- Method: MIMEDocument>>contentTransferEncoding (in category 'accessing') ----- - contentTransferEncoding - - ^ self contentTransferEncodingHeaderValue mainValue! Item was removed: - ----- Method: MIMEDocument>>contentTransferEncodingHeaderValue (in category 'accessing') ----- - contentTransferEncodingHeaderValue - - ^ self fieldNamed: 'content-transfer-encoding' ifAbsent: [nil]! Item was removed: - ----- Method: MIMEDocument>>contentType (in category 'accessing') ----- - contentType - - ^ self contentTypeHeaderValue mainValue! Item was removed: - ----- Method: MIMEDocument>>contentTypeHeaderValue (in category 'accessing') ----- - contentTypeHeaderValue - - ^ self fieldNamed: 'content-type' ifAbsent: [self error: 'MIMEDocument requires a content-type field']! Item was removed: - ----- Method: MIMEDocument>>contentTypeHeaderValue: (in category 'accessing') ----- - contentTypeHeaderValue: aMIMEHeaderValue - - ^ self setField: 'content-type' to: aMIMEHeaderValue! Item was removed: - ----- Method: MIMEDocument>>contents (in category 'accessing') ----- - contents - "Compatibility with stream protocol" - ^self content! Item was removed: - ----- Method: MIMEDocument>>fieldNamed:ifAbsent: (in category 'fields') ----- - fieldNamed: aString ifAbsent: aBlock - | matchingFields | - "return the value of the field with the specified name. If there is more than one field, then return the first one" - matchingFields := fields at: aString asLowercase ifAbsent: [ ^aBlock value ]. - ^matchingFields first! Item was removed: - ----- Method: MIMEDocument>>fieldsFrom:do: (in category 'fields') ----- - fieldsFrom: aStream do: aBlock - "Invoke the given block with each of the header fields from the given stream. The block arguments are the field name and value. The streams position is left right after the empty line separating header and body. - Duplicate of code in MailMessage" - - | savedLine line s | - savedLine := aStream nextLine. - [aStream atEnd] whileFalse: [ - line := savedLine. - (line isEmpty) ifTrue: [^self]. "quit when we hit a blank line" - [savedLine := aStream nextLine. - savedLine notNil and: [savedLine notEmpty] and: [savedLine first isSeparator]] whileTrue: [ - "lines starting with white space are continuation lines" - s := ReadStream on: savedLine. - s skipSeparators. - line := line, ' ', s upToEnd]. - self reportField: line withBlanksTrimmed to: aBlock]. - - "process final header line of a body-less message" - (savedLine isEmpty) ifFalse: [self reportField: savedLine withBlanksTrimmed to: aBlock]. - ! Item was removed: - ----- Method: MIMEDocument>>hasFieldNamed: (in category 'fields') ----- - hasFieldNamed: aString - ^fields includesKey: aString asLowercase! Item was removed: - ----- Method: MIMEDocument>>initialize (in category 'testing') ----- - initialize - - parts := OrderedCollection new. - fields := Dictionary new. - self setField: 'content-type' toString: self class defaultContentType.! Item was removed: - ----- Method: MIMEDocument>>initializeFromString: (in category 'initialize-release') ----- - initializeFromString: aString - "This can only be used for MIME documents which are not multipart." - - | parseStream contentType bodyText contentTransferEncoding text | - - text := aString withoutTrailingBlanks, String cr, String cr. - parseStream := ReadStream on: text. - contentType := 'text/plain'. - contentTransferEncoding := nil. - fields := Dictionary new. - - "Extract information out of the header fields" - self fieldsFrom: parseStream do: - [:fName :fValue | - "NB: fName is all lowercase" - - fName = 'content-type' ifTrue: [contentType := fValue asLowercase]. - fName = 'content-transfer-encoding' ifTrue: [contentTransferEncoding := fValue asLowercase]. - - (fields at: fName ifAbsentPut: [OrderedCollection new: 1]) - add: (MIMEHeaderValue forField: fName fromString: fValue)]. - - "Extract the body of the message" - bodyText := parseStream upToEnd. - bodyText := (MimeConverter forEncoding: contentTransferEncoding) - mimeDecode: (ReadStream on: bodyText) as: String. - bodyText := self class tryToDecodeBody: bodyText as: self charset. - - self isMultipart - ifTrue: [parts := self class parseParts: bodyText withSeparator: self attachmentSeparator] - ifFalse: [content := bodyText] - ! Item was removed: - ----- Method: MIMEDocument>>isGif (in category 'testing') ----- - isGif - ^ self mainType = 'image' - and: [self subType = 'gif']! Item was removed: - ----- Method: MIMEDocument>>isHTML (in category 'testing') ----- - isHTML - - ^ self mainType = 'text' and: [self subType = 'html']! Item was removed: - ----- Method: MIMEDocument>>isJpeg (in category 'testing') ----- - isJpeg - ^ self mainType = 'image' - and: [self subType = 'jpeg' | (self subType = 'jpg')]! Item was removed: - ----- Method: MIMEDocument>>isMultipart (in category 'testing') ----- - isMultipart - ^self mainType = 'multipart'! Item was removed: - ----- Method: MIMEDocument>>isMultipartAlternative (in category 'testing') ----- - isMultipartAlternative - "whether the document is in a multipart format where the parts are alternates" - ^ self contentType = 'multipart/alternative' - ! Item was removed: - ----- Method: MIMEDocument>>isPlaintext (in category 'testing') ----- - isPlaintext - - ^ self mainType = 'text' and: [self subType = 'plain']! Item was removed: - ----- Method: MIMEDocument>>isPng (in category 'testing') ----- - isPng - ^ self mainType = 'image' - and: [self subType = 'png']! Item was removed: - ----- Method: MIMEDocument>>isPnm (in category 'testing') ----- - isPnm - ^ self mainType = 'image' - and: [self subType = 'pnm']! Item was removed: - ----- Method: MIMEDocument>>mainType (in category 'accessing') ----- - mainType - ^ (self contentType splitBy: '/') first! Item was removed: - ----- Method: MIMEDocument>>name (in category 'accessing') ----- - name - "return a default name for this part, if any was specified. If not, return nil" - | type nameField disposition | - - "try in the content-type: header" - type := self fieldNamed: 'content-type' ifAbsent: [nil]. - (type notNil and: [(nameField := type parameters at: 'name' ifAbsent: [nil]) notNil]) - ifTrue: [^ nameField]. - - "try in content-disposition:" - disposition := self fieldNamed: 'content-disposition' ifAbsent: [nil]. - (disposition notNil and: [(nameField := disposition parameters at: 'filename' ifAbsent: [nil]) notNil]) - ifTrue: [^ nameField]. - - "give up" - ^ nil! Item was removed: - ----- Method: MIMEDocument>>parameterizedContentTransferEncoding (in category 'accessing') ----- - parameterizedContentTransferEncoding - - ^ self contentTransferEncoding asHeaderValue! Item was removed: - ----- Method: MIMEDocument>>parameterizedContentType (in category 'accessing') ----- - parameterizedContentType - - ^ self contentTypeHeaderValue asHeaderValue - - ! Item was removed: - ----- Method: MIMEDocument>>parts (in category 'accessing') ----- - parts - - ^ parts - ! Item was removed: - ----- Method: MIMEDocument>>printOn: (in category 'printing') ----- - printOn: aStream - aStream nextPutAll: self class name; - nextPutAll: ' ('; - nextPutAll: self contentType; - nextPutAll: ', '. - self content - ifNotNil: [aStream - nextPutAll: self content size printString; - nextPutAll: ' bytes)'] - ifNil: [aStream nextPutAll: 'unknown size)'].! Item was removed: - ----- Method: MIMEDocument>>privateContent: (in category 'private') ----- - privateContent: aString - content := aString! Item was removed: - ----- Method: MIMEDocument>>privateMainType: (in category 'private') ----- - privateMainType: aString - - self contentTypeHeaderValue mainValue: (aString , '/' , self subType)! Item was removed: - ----- Method: MIMEDocument>>privateSubType: (in category 'private') ----- - privateSubType: aString - - self contentTypeHeaderValue mainValue: (self mainType , '/' , aString)! Item was removed: - ----- Method: MIMEDocument>>privateUrl: (in category 'private') ----- - privateUrl: aUrl - url := aUrl! Item was removed: - ----- Method: MIMEDocument>>reportField:to: (in category 'fields') ----- - reportField: aString to: aBlock - "Evaluate the given block with the field name a value in the given field. Do nothing if the field is malformed. - Duplicate of code in MailMessage" - - | s fieldName fieldValue | - (aString includes: $:) ifFalse: [^self]. - s := ReadStream on: aString. - fieldName := (s upTo: $:) asLowercase. "fieldname must be lowercase" - fieldValue := s upToEnd withBlanksTrimmed. - fieldValue isEmpty ifFalse: [aBlock value: fieldName value: fieldValue]. - ! Item was removed: - ----- Method: MIMEDocument>>save (in category 'interactions') ----- - save - "save the part to a file" - | fileName file | - fileName := self name - ifNil: ['attachment' , Utilities dateTimeSuffix]. - (fileName includes: $.) ifFalse: [ - #(isJpeg 'jpg' isGif 'gif' isPng 'png' isPnm 'pnm') pairsDo: [ :s :e | - (self perform: s) ifTrue: [fileName := fileName, '.', e] - ] - ]. - fileName := UIManager default request: 'File name for save?' initialAnswer: fileName. - fileName isEmpty - ifTrue: [^ nil]. - - - file := FileStream newFileNamed: fileName. - self contentTransferEncoding = 'base64' ifTrue: [file binary]. - file nextPutAll: self contents. - file close! Item was removed: - ----- Method: MIMEDocument>>sendableMultipartBodyText (in category 'serializing') ----- - sendableMultipartBodyText - - ^ String streamContents: [ :str | - str cr. - parts do: [ :part | - str - cr; - nextPutAll: '--'; - nextPutAll: self attachmentSeparator; - cr; - nextPutAll: part asSendablePartText ]. - - str - cr; - nextPutAll: '--'; - nextPutAll: self attachmentSeparator; - nextPutAll: '--'; - cr ]! Item was removed: - ----- Method: MIMEDocument>>setField:to: (in category 'fields') ----- - setField: fieldName to: aFieldValue - "set a field. If any field of the specified name exists, it will be overwritten" - fields at: fieldName asLowercase put: (OrderedCollection with: aFieldValue).! Item was removed: - ----- Method: MIMEDocument>>setField:toString: (in category 'fields') ----- - setField: fieldName toString: fieldValue - ^self setField: fieldName to: (MIMEHeaderValue forField: fieldName fromString: fieldValue)! Item was removed: - ----- Method: MIMEDocument>>subType (in category 'accessing') ----- - subType - ^ (self contentType splitBy: '/') second! Item was removed: - ----- Method: MIMEDocument>>text (in category 'accessing') ----- - text - "Compatibility with MailMessage protocol" - ^self contents! Item was removed: - ----- Method: MIMEDocument>>type (in category 'accessing') ----- - type - "Deprecated. Use contentType instead." - - ^ self contentType! Item was removed: - ----- Method: MIMEDocument>>url (in category 'accessing') ----- - url - "Answer the URL the receiver was downloaded from. It may legitimately be nil." - - ^ url! Item was removed: - ----- Method: MIMEDocument>>view (in category 'interactions') ----- - view - - self containsViewableImage - ifTrue: [^ self viewImage]. - (StringHolder new contents: self bodyTextFormatted; - yourself) - openLabel: (self name ifNil: ['(a message part)'])! Item was removed: - ----- Method: MIMEDocument>>viewImage (in category 'interactions') ----- - viewImage - | stream image | - stream := self contentStream. - image := Form fromBinaryStream: stream. - (Project current world drawingClass withForm: image) openInWorld! Item was removed: - ----- Method: MIMEDocument>>withUrl: (in category 'converting') ----- - withUrl: newUrl - "return an identical document except that the URL has been modified" - ^MIMEDocument contentType: self contentType content: self content url: newUrl! Item was removed: - Object subclass: #MIMEHeaderValue - instanceVariableNames: 'mainValue parameters' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-Url'! - - !MIMEHeaderValue commentStamp: '<historical>' prior: 0! - I contain the value portion of a MIME-compatible header. - - I must be only initialized with the value and not the field name. E.g. in processing - Subject: This is the subject - the MIMEHeaderValue should be given only 'This is the subject' - - For traditional non-MIME headers, the complete value returned for mainValue and paramaters returns an empty collection. - - For MIME headers, both mainValue and parameters are used.! Item was removed: - ----- Method: MIMEHeaderValue class>>forField:fromString: (in category 'instance creation') ----- - forField: aFName fromString: aString - "Create a MIMEHeaderValue from aString. How it is parsed depends on whether it is a MIME specific field or a generic header field." - - | decodedString | - decodedString := [aString decodeMimeHeader] - on: InvalidUTF8 , NoConverterFound do: [:e | aString]. - (aFName beginsWith: 'content-') - ifTrue: [^self fromMIMEHeader: decodedString] - ifFalse: [^self fromTraditionalHeader: decodedString] - ! Item was removed: - ----- 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. - This assumes a string without any special encodings (e.g. q encoding)." - - | parts newValue parms | - - newValue := self new. - - parts := ReadStream on: (aString findTokens: ';'). - newValue mainValue: parts next. - parms := Dictionary new. - parts do: - [:e | | separatorPos parmName parmValue | - 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 removed: - ----- Method: MIMEHeaderValue class>>fromTraditionalHeader: (in category 'instance creation') ----- - fromTraditionalHeader: aString - "This is a traditional non-MIME header (like Subject:) and so should be stored whole. - This assumes a string without any special encodings (e.g. q encoding)." - - | newValue | - - newValue := self new. - newValue mainValue: aString. - newValue parameters: #(). - ^newValue. - ! Item was removed: - ----- Method: MIMEHeaderValue>>asHeaderValue (in category 'printing') ----- - asHeaderValue - | strm result | - strm := WriteStream on: (String new: 20). - strm nextPutAll: mainValue. - parameters associationsDo: [:e | - strm - nextPut: $; ; - nextPutAll: e key; - nextPutAll: '='; - nextPutAll: e value]. - ^ (result := strm contents) isAsciiString - ifFalse: [QEncodingMimeConverter mimeEncode: result] - ifTrue: [result] - ! Item was removed: - ----- Method: MIMEHeaderValue>>mainValue (in category 'accessing') ----- - mainValue - ^ mainValue! Item was removed: - ----- Method: MIMEHeaderValue>>mainValue: (in category 'accessing') ----- - mainValue: anObject - mainValue := anObject! Item was removed: - ----- Method: MIMEHeaderValue>>parameterAt:ifAbsent: (in category 'accessing') ----- - parameterAt: aParameter ifAbsent: absentBlock - - ^ parameters at: aParameter ifAbsent: absentBlock! Item was removed: - ----- Method: MIMEHeaderValue>>parameterAt:put: (in category 'accessing') ----- - parameterAt: aParameter put: value - parameters at: aParameter put: value! Item was removed: - ----- Method: MIMEHeaderValue>>parameters (in category 'accessing') ----- - parameters - ^parameters! Item was removed: - ----- Method: MIMEHeaderValue>>parameters: (in category 'accessing') ----- - parameters: anObject - parameters := anObject! Item was removed: - ----- Method: MIMEHeaderValue>>printOn: (in category 'printing') ----- - printOn: aStream - super printOn: aStream. - aStream nextPutAll: ': '. - aStream nextPutAll: self asHeaderValue! Item was removed: - MIMEDocument subclass: #MIMELocalFileDocument - instanceVariableNames: 'contentStream' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-Url'! - - !MIMELocalFileDocument commentStamp: '<historical>' prior: 0! - For local files, we do not read the entire contents unless we absolutely have to.! Item was removed: - ----- Method: MIMELocalFileDocument class>>contentType:contentStream: (in category 'instance creation') ----- - contentType: aString contentStream: aStream - - ^ (self contentType: aString) - contentStream: aStream; - yourself! Item was removed: - ----- Method: MIMELocalFileDocument>>content (in category 'accessing') ----- - content - ^content ifNil:[content := contentStream contentsOfEntireFile].! Item was removed: - ----- Method: MIMELocalFileDocument>>contentStream (in category 'accessing') ----- - contentStream - ^contentStream ifNil:[super contentStream]! Item was removed: - ----- Method: MIMELocalFileDocument>>contentStream: (in category 'accessing') ----- - contentStream: aFileStream - contentStream := aFileStream. - content := nil.! Item was removed: - ----- Method: MacFileDirectory class>>privateFullPathForURI: (in category '*network-uri') ----- - privateFullPathForURI: aURI - | path | - - path := String streamContents: [ :s | | first | - first := false. - aURI pathComponents do: [ :p | - first ifTrue: [ s nextPut: self pathNameDelimiter ]. - first := true. - s nextPutAll: p ] ]. - ^path unescapePercents - ! Item was removed: - Object subclass: #MailAddressParser - instanceVariableNames: 'tokens addresses storeNames curAddrTokens' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-RFC822'! - - !MailAddressParser commentStamp: '<historical>' prior: 0! - Parse mail addresses. The basic syntax is: - - addressList := MailAddressParser addressesIn: aString - - This currently only returns the bare addresses, but it could also return a list of the address "source codes". For example, if you give it "Joe <joe at foo>, <jane>", it will currently return a list ('joe at foo' 'jane'). It would be nice to also get a list ('Joe <joe at foo>' '<jane>').! Item was removed: - ----- Method: MailAddressParser class>>addressesAndNamePairsIn: (in category 'parsing') ----- - addressesAndNamePairsIn: aString - "return a collection of the addresses and the corresponding names listed in aString" - | tokens | - tokens := MailAddressTokenizer tokensIn: aString. - ^(self new initialize: tokens) grabAddressesAndNames! Item was removed: - ----- Method: MailAddressParser class>>addressesIn: (in category 'parsing') ----- - addressesIn: aString - "return a collection of the bare addresses listed in aString" - | tokens | - tokens := MailAddressTokenizer tokensIn: aString. - ^(self new initialize: tokens) grabAddresses! Item was removed: - ----- Method: MailAddressParser>>addToAddress (in category 'building address list') ----- - addToAddress - "add the last token to the address. removes the token from the collection" - curAddrTokens addFirst: (tokens removeLast)! Item was removed: - ----- Method: MailAddressParser>>finishAddress (in category 'building address list') ----- - finishAddress - "we've finished one address. Bundle it up and add it to the list of addresses" - | address | - - address := String streamContents: [ :str | - curAddrTokens do: [ :tok | str nextPutAll: tok text ] ]. - - addresses addFirst: address. - - curAddrTokens := nil.! Item was removed: - ----- Method: MailAddressParser>>grabAddressWithRoute (in category 'parsing') ----- - grabAddressWithRoute - "grad an address of the form 'Descriptive Text <real.address at c.d.e>" - - | name | - self startNewAddress. - - tokens removeLast. "remove the >" - - "grab until we see a $<" - [ tokens isEmpty ifTrue: [self error: '<> are not matched' ]. - tokens last type = $<] - whileFalse: [ self addToAddress ]. - - tokens removeLast. "remove the <" - self finishAddress. - - name := self grabName. - - storeNames ifTrue: [addresses addFirst: {name . addresses removeFirst}].! Item was removed: - ----- Method: MailAddressParser>>grabAddresses (in category 'parsing') ----- - grabAddresses - - | token | - "remove comments" - tokens removeAllSuchThat: [:t | t type == #Comment]. - - "grab one address or address group each time through this loop" - [ [tokens isEmpty not and: [ tokens last type = $, ]] - whileTrue: [ tokens removeLast ]. - tokens isEmpty ] whileFalse: [ - - token := tokens last. - - "delegate, depending on what form the address is in" - "the from can be determined from the last token" - token type = $> - ifTrue: [self grabAddressWithRoute ] - ifFalse: [ (#(Atom DomainLiteral QuotedString) includes: token type) - ifTrue: [self grabBasicAddress ] - ifFalse: [token type = $; - ifTrue: [self grabGroupAddress ] - ifFalse: [self error: 'un-recognized address format' ]]]]. - - ^ addresses! Item was removed: - ----- Method: MailAddressParser>>grabAddressesAndNames (in category 'parsing') ----- - grabAddressesAndNames - - storeNames := true. - - self grabAddresses. - - addresses := addresses collect: [:a | - a isString - ifTrue: [{'' . a}] - ifFalse: [a] ]. - - ^ addresses! Item was removed: - ----- Method: MailAddressParser>>grabBasicAddress (in category 'parsing') ----- - grabBasicAddress - "grad an address of the form a.b at c.d.e" - | name | - self startNewAddress. - "grab either the domain if specified, or the domain if not" - self addToAddress. - [tokens isEmpty not and: [ tokens last type = $.] ] - whileTrue: - ["add name-dot pairs of tokens" - self addToAddress. - (#(Atom QuotedString ) includes: tokens last type) - ifFalse: [self error: 'bad token in address: ' , tokens last text]. - self addToAddress]. - (tokens isEmpty or: [tokens last type ~= $@]) - ifTrue: ["no domain specified" - self finishAddress] - ifFalse: - ["that was the domain. check that no QuotedString's slipped in" - curAddrTokens do: [:tok | tok type = #QuotedString ifTrue: [self error: 'quote marks are not allowed within a domain name (' , tok text , ')']]. - "add the @ sign" - self addToAddress. - "add the local part" - (#(Atom QuotedString ) includes: tokens last type) - ifFalse: [self error: 'invalid local part for address: ' , tokens last text]. - self addToAddress. - "add word-dot pairs if there are any" - [tokens isEmpty not and: [tokens last type = $.]] - whileTrue: - [self addToAddress. - (tokens isEmpty not and: [#(Atom QuotedString ) includes: tokens last type]) - ifTrue: [self addToAddress]]. - self finishAddress]. - - name := self grabName. - storeNames ifTrue: [addresses addFirst: {name . addresses removeFirst}].! Item was removed: - ----- Method: MailAddressParser>>grabGroupAddress (in category 'parsing') ----- - grabGroupAddress - "grab an address of the form 'phrase : address, address, ..., address;'" - "I'm not 100% sure what this format means, so I'm just returningthe list of addresses between the : and ; -ls (if this sounds right to someone, feel free to remove this comment :)" - - "remove the $; " - tokens removeLast. - - "grab one address each time through this loop" - [ "remove commas" - [tokens isEmpty not and: [ tokens last type = $, ]] - whileTrue: [ tokens removeLast ]. - - tokens isEmpty ifTrue: ["no matching :" ^ self error: 'stray ; in address list']. - tokens last type = $:] - whileFalse: [ - - "delegate to either grabAddressWithRoute, or grabBasicAddress. nested groups are not allowed" - tokens last type = $> - ifTrue: [self grabAddressWithRoute ] - ifFalse: [ (#(Atom DomainLiteral QuotedString) includes: tokens last type) - ifTrue: [self grabBasicAddress ] - ifFalse: [^ self error: 'un-recognized address format' ]]]. - - tokens removeLast. "remove the :" - - self removePhrase.! Item was removed: - ----- Method: MailAddressParser>>grabName (in category 'parsing') ----- - grabName - - | name | - name := ''. - [tokens isEmpty not and: [#(Atom QuotedString $. $@) includes: (tokens last type) ]] - whileTrue: [ name := {tokens removeLast text copyWithoutAll: '"'. name} joinSeparatedBy: Character space ]. - ^ name withBlanksTrimmed! Item was removed: - ----- Method: MailAddressParser>>initialize (in category 'private-initialization') ----- - initialize - - storeNames := false.! Item was removed: - ----- Method: MailAddressParser>>initialize: (in category 'private-initialization') ----- - initialize: tokenList - tokens := tokenList asOrderedCollection copy. - addresses := OrderedCollection new.! Item was removed: - ----- Method: MailAddressParser>>removePhrase (in category 'parsing') ----- - removePhrase - "skip most characters to the left of this" - - [tokens isEmpty not and: [#(Atom QuotedString $. $@) includes: (tokens last type)]] - whileTrue: [ tokens removeLast ]. - ! Item was removed: - ----- Method: MailAddressParser>>startNewAddress (in category 'building address list') ----- - startNewAddress - "set up data structures to begin a new address" - (curAddrTokens ~~ nil) ifTrue: [ - self error: 'starting new address before finishing the last one!!' ]. - - curAddrTokens := OrderedCollection new. - ! Item was removed: - Object subclass: #MailAddressToken - instanceVariableNames: 'type text' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-RFC822'! - - !MailAddressToken commentStamp: '<historical>' prior: 0! - a single token from an RFC822 mail address. Used internally in MailAddressParser! Item was removed: - ----- Method: MailAddressToken class>>type:text: (in category 'instance creation') ----- - type: type text: text - ^self new type: type text: text! Item was removed: - ----- Method: MailAddressToken>>printOn: (in category 'printing') ----- - printOn: aStream - aStream nextPut: $[. - aStream nextPutAll: self type asString. - aStream nextPut: $|. - aStream nextPutAll: self text. - aStream nextPut: $].! Item was removed: - ----- Method: MailAddressToken>>text (in category 'access') ----- - text - ^text! Item was removed: - ----- Method: MailAddressToken>>type (in category 'access') ----- - type - ^type! Item was removed: - ----- Method: MailAddressToken>>type:text: (in category 'private') ----- - type: type0 text: text0 - type := type0. - text := text0.! Item was removed: - Stream subclass: #MailAddressTokenizer - instanceVariableNames: 'cachedToken text pos' - classVariableNames: 'CSNonAtom CSParens CSSpecials' - poolDictionaries: '' - category: 'Network-RFC822'! - - !MailAddressTokenizer commentStamp: '<historical>' prior: 0! - Divides an address into tokens, as specified in RFC 822. Used by MailAddressParser.! Item was removed: - ----- Method: MailAddressTokenizer class>>cleanUp: (in category 'class initialization') ----- - cleanUp: aggressive - - CSParens := CSSpecials := CSNonAtom := nil! Item was removed: - ----- Method: MailAddressTokenizer class>>forString: (in category 'instance creation') ----- - forString: aString - ^super basicNew initialize: aString! Item was removed: - ----- Method: MailAddressTokenizer class>>nonAtomSet (in category 'class initialization') ----- - nonAtomSet - "Create a ByteCharacterSet to ensure quick parsing of the email address string, which must be a ByteString (UTF-8 encoded)" - - ^CSNonAtom ifNil: [ - CSNonAtom := CharacterSet new - "Atom characters as defined in RFC 2822 3.2.4" - addAll: ($A to: $Z); - addAll: ($a to: $z); - addAll: ($0 to: $9); - addAll: '!!#$%&''*+-/=?^_`{|}~'; - "RFC 6531 allows characters with value > 127 encoded as UTF-8, which means values between 128 and 255 may appear as part of atoms." - addAll: ((Character value: 128) to: (Character value: 255)); - byteComplement ]! Item was removed: - ----- Method: MailAddressTokenizer class>>parenthesesSet (in category 'class initialization') ----- - parenthesesSet - - ^CSParens ifNil: [ CSParens:= CharacterSet newFrom: '()' ]! Item was removed: - ----- Method: MailAddressTokenizer class>>specialsSet (in category 'class initialization') ----- - specialsSet - - ^CSSpecials ifNil: [ CSSpecials := CharacterSet newFrom: '()<>@,;:\".[]' ]! Item was removed: - ----- Method: MailAddressTokenizer class>>tokensIn: (in category 'instance creation') ----- - tokensIn: aString - "return a collection of the tokens in aString" - ^(self forString: aString) upToEnd! Item was removed: - ----- Method: MailAddressTokenizer>>atEnd (in category 'stream protocol') ----- - atEnd - ^self peek == nil! Item was removed: - ----- Method: MailAddressTokenizer>>atEndOfChars (in category 'tokenizing') ----- - atEndOfChars - ^pos > text size! Item was removed: - ----- Method: MailAddressTokenizer>>initialize: (in category 'initialization') ----- - initialize: aString - text := aString. - pos := 1.! Item was removed: - ----- Method: MailAddressTokenizer>>next (in category 'stream protocol') ----- - next - | ans | - cachedToken ifNil: [ ^self nextToken ]. - ans := cachedToken. - cachedToken := nil. - ^ans! Item was removed: - ----- Method: MailAddressTokenizer>>nextAtom (in category 'tokenizing') ----- - nextAtom - | start end | - start := pos. - pos := text indexOfAnyOf: self class nonAtomSet startingAt: start ifAbsent: [ text size + 1]. - end := pos - 1. - ^MailAddressToken - type: #Atom - text: (text copyFrom: start to: end)! Item was removed: - ----- Method: MailAddressTokenizer>>nextChar (in category 'tokenizing') ----- - nextChar - self atEndOfChars ifTrue: [ ^nil ]. - pos := pos + 1. - ^text at: (pos-1)! Item was removed: - ----- Method: MailAddressTokenizer>>nextComment (in category 'tokenizing') ----- - nextComment - | start nestLevel paren | - start := pos. - pos := pos + 1. - nestLevel := 1. - - [ nestLevel > 0 ] whileTrue: [ - pos := text indexOfAnyOf: self class parenthesesSet startingAt: pos. - pos = 0 ifTrue: [ - self error: 'unterminated comment. ie, more (''s than )''s' ]. - - paren := self nextChar. - paren = $( ifTrue: [ nestLevel := nestLevel + 1 ] ifFalse: [ nestLevel := nestLevel - 1 ]]. - ^ MailAddressToken type: #Comment - text: (text copyFrom: start to: pos - 1)! Item was removed: - ----- Method: MailAddressTokenizer>>nextDomainLiteral (in category 'tokenizing') ----- - nextDomainLiteral - | start end | - start := pos. - end := text indexOf: $] startingAt: start. - end = 0 ifTrue: [ - "not specified" - self error: 'saw [ without a matching ]' ]. - - pos := end+1. - - ^MailAddressToken - type: #DomainLiteral - text: (text copyFrom: start to: end)! Item was removed: - ----- Method: MailAddressTokenizer>>nextQuotedString (in category 'tokenizing') ----- - nextQuotedString - | res c | - res := WriteStream on: String new. - res nextPut: self nextChar. "record the starting quote" - [ self atEndOfChars ] whileFalse: [ - c := self nextChar. - c = $\ ifTrue: [ - res nextPut: c. - res nextPut: self nextChar ] - ifFalse: [ - c = $" ifTrue: [ - res nextPut: c. - ^MailAddressToken type: #QuotedString text: res contents ] - ifFalse: [ - res nextPut: c ] ] ]. - - "hmm, never saw the final quote mark" - ^MailAddressToken type: #QuotedString text: (res contents, '"')! Item was removed: - ----- Method: MailAddressTokenizer>>nextSpecial (in category 'tokenizing') ----- - nextSpecial - | c | - c := self nextChar. - ^MailAddressToken type: c text: c asString.! Item was removed: - ----- Method: MailAddressTokenizer>>nextToken (in category 'tokenizing') ----- - nextToken - | c | - self skipSeparators. - c := self peekChar. - c ifNil: [ ^nil ]. - c = $( ifTrue: [ ^self nextComment ]. - c = $" ifTrue: [ ^self nextQuotedString ]. - c = $[ ifTrue: [ ^self nextDomainLiteral ]. - (self class specialsSet includes: c) ifTrue: [ ^self nextSpecial ]. - ^self nextAtom! Item was removed: - ----- Method: MailAddressTokenizer>>peek (in category 'stream protocol') ----- - peek - cachedToken ifNil: [ cachedToken := self nextToken. ]. - - ^cachedToken ! Item was removed: - ----- Method: MailAddressTokenizer>>peekChar (in category 'tokenizing') ----- - peekChar - ^text at: pos ifAbsent: [ nil ]! Item was removed: - ----- Method: MailAddressTokenizer>>skipSeparators (in category 'tokenizing') ----- - skipSeparators - pos := text indexOfAnyOf: CharacterSet nonSeparators startingAt: pos ifAbsent: [ text size + 1 ].! Item was removed: - Model subclass: #MailComposition - instanceVariableNames: 'mailMessage isSending' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-MailSending'! - - !MailComposition commentStamp: 'pre 5/16/2017 20:00' prior: 0! - a message being composed in a fancy way. The mail is send via the registered MailSender by default. Fields do not have to be saved, they are saved automatically on send. ! Item was removed: - ----- Method: MailComposition class>>initialize (in category 'class initialization') ----- - initialize - - MailSender register: self ! Item was removed: - ----- Method: MailComposition class>>open (in category 'opening') ----- - open - - ^ ToolBuilder default open: self! Item was removed: - ----- Method: MailComposition class>>openOn: (in category 'opening') ----- - openOn: aMessage - - ^ ToolBuilder default open: (self new on: aMessage; yourself)! Item was removed: - ----- Method: MailComposition class>>sendMailMessage: (in category 'MailSender interface') ----- - sendMailMessage: aMessage - - self openOn: aMessage! Item was removed: - ----- Method: MailComposition class>>unload (in category 'initialize-release') ----- - unload - - MailSender unregister: self ! Item was removed: - ----- Method: MailComposition>>addAttachment (in category 'actions') ----- - addAttachment - - self saveFields. - (UIManager default chooseFileMatching: '*' label: 'Choose attachment') ifNotNil: - [:fileName | - FileStream readOnlyFileNamed: fileName do: - [:file | - file binary. - mailMessage - addAttachmentFrom: file - withName: (FileDirectory localNameFor: fileName)]. - self changed: #messageText]. ! Item was removed: - ----- Method: MailComposition>>addAttachment:named: (in category 'private') ----- - addAttachment: stream named: attachmentName - - stream binary. - mailMessage - addAttachmentFrom: stream - withName: attachmentName! Item was removed: - ----- Method: MailComposition>>addAttachmentButtonLabel (in category 'ui constants') ----- - addAttachmentButtonLabel - - ^ 'add attachment' translated! Item was removed: - ----- Method: MailComposition>>bccLabel (in category 'ui constants') ----- - bccLabel - - ^ 'BCC' translated! Item was removed: - ----- Method: MailComposition>>breakLines:atWidth: (in category 'private') ----- - breakLines: aString atWidth: width - "break lines in the given string into shorter lines" - | result atAttachment | - - result := WriteStream on: (String new: (aString size * 50 // 49)). - - atAttachment := false. - aString asString linesDo: [ :line | | start end | - (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 removed: - ----- Method: MailComposition>>breakLinesInMessage: (in category 'private') ----- - breakLinesInMessage: message - "reformat long lines in the specified message into shorter ones" - message body mainType = 'text' ifTrue: [ - "it's a single-part text message. reformat the text" - | newBodyText | - newBodyText := self breakLines: message bodyText atWidth: 72. - message body: (MIMEDocument contentType: message body contentType content: newBodyText). - - ^self ]. - - message body isMultipart ifTrue: [ - "multipart message; process the top-level parts. HACK: the parts are modified in place" - message parts do: [ :part | - part body mainType = 'text' ifTrue: [ - | newBodyText | - newBodyText := self breakLines: part bodyText atWidth: 72. - part body: (MIMEDocument contentType: part body contentType content: newBodyText) ] ]. - message regenerateBodyFromParts. ].! Item was removed: - ----- Method: MailComposition>>buildButtonBarSpecWith: (in category 'toolbuilder') ----- - buildButtonBarSpecWith: aBuilder - - | buttonBarSpec | - buttonBarSpec := aBuilder pluggablePanelSpec new - children: OrderedCollection new; - layout: #horizontal; - frame: (LayoutFrame new - leftFraction: 0 offset: 0; - topFraction: 0 offset: 0; - rightFraction: 1 offset: 0; - bottomFraction: 0 offset: self buttonBarHeight); - yourself. - - buttonBarSpec children add: (aBuilder pluggableButtonSpec new - model: self; - action: #sendMail; - label: #sendMailButtonLabel; - color: #sendMailButtonColor; - yourself). - - buttonBarSpec children add: (aBuilder pluggableButtonSpec new - model: self; - action: #addAttachment; - label: #addAttachmentButtonLabel; - yourself). - - buttonBarSpec children add: (aBuilder pluggableButtonSpec new - model: self; - action: #removeAttachment; - label: #removeAttachmentButtonLabel; - yourself). - - ^ buttonBarSpec! Item was removed: - ----- Method: MailComposition>>buildWith: (in category 'toolbuilder') ----- - buildWith: aBuilder - - | spec | - - spec := self createSpecsWith: aBuilder. - - ^ aBuilder build: spec! Item was removed: - ----- Method: MailComposition>>buttonBarHeight (in category 'ui constants') ----- - buttonBarHeight - - ^ (Preferences standardButtonFont height * 2.5) truncated! Item was removed: - ----- Method: MailComposition>>ccLabel (in category 'ui constants') ----- - ccLabel - - ^ 'CC' translated! Item was removed: - ----- Method: MailComposition>>createDetailsFieldsIn:by: (in category 'toolbuilder') ----- - createDetailsFieldsIn: detailsPanelSpec by: aBuilder - - #((senderLabel messageSender messageSender:) - (recipientLabel messageRecipient messageRecipient:) - (ccLabel messageCC messageCC:) - (bccLabel messageBCC messageBCC:) - (subjectLabel messageSubject messageSubject:)) - do: [:config | detailsPanelSpec children add: - (self createFieldInputNamed: config first - getter: config second - setter: config third - with: aBuilder)] - ! Item was removed: - ----- Method: MailComposition>>createFieldInputNamed:getter:setter:with: (in category 'toolbuilder') ----- - createFieldInputNamed: fieldLabelGetter getter: fieldGetter setter: fieldSetter with: aBuilder - - ^ aBuilder pluggableInputFieldSpec new - model: self; - indicateUnacceptedChanges: false; - getText: fieldGetter; - setText: fieldSetter; - name: fieldGetter; - frame: (LayoutFrame new - leftFraction: 0 offset: 0; - topFraction: 0 offset: 0; - rightFraction: 1 offset: 0; - bottomFraction: 0 offset: self lineHeight); - help: fieldLabelGetter; - yourself! Item was removed: - ----- Method: MailComposition>>createSpecsWith: (in category 'toolbuilder') ----- - createSpecsWith: aBuilder - - | detailsPanelSpec textSpec windowSpec | - windowSpec := self createWindowSpecWith: aBuilder. - windowSpec children add: (self buildButtonBarSpecWith: aBuilder). - - detailsPanelSpec := aBuilder pluggablePanelSpec new - children: OrderedCollection new; - layout: #vertical; - yourself. - windowSpec children add: detailsPanelSpec. - - self createDetailsFieldsIn: detailsPanelSpec by: aBuilder. - - detailsPanelSpec children: detailsPanelSpec children reversed. - detailsPanelSpec frame: (LayoutFrame new - leftFraction: 0 offset: 0; - topFraction: 0 offset: self buttonBarHeight; - rightFraction: 1 offset: 0; - bottomFraction: 0 offset: self buttonBarHeight + (detailsPanelSpec children size * self lineHeight)). - - textSpec := aBuilder pluggableTextSpec new - model: self; - indicateUnacceptedChanges: true; - getText: #messageText; - setText: #messageText:; - name: #messageText; - frame: (LayoutFrame new - leftFraction: 0 offset: 0; - topFraction: 0 offset: self buttonBarHeight + (detailsPanelSpec children size * self lineHeight); - rightFraction: 1 offset: 0; - bottomFraction: 1 offset: 0); - yourself. - windowSpec children add: textSpec. - - ^ windowSpec! Item was removed: - ----- Method: MailComposition>>createWindowSpecWith: (in category 'toolbuilder') ----- - createWindowSpecWith: aBuilder - - ^ aBuilder pluggableWindowSpec new - model: self; - label: #dialogTitle; - children: OrderedCollection new.! Item was removed: - ----- Method: MailComposition>>dialogTitle (in category 'toolbuilder') ----- - dialogTitle - - ^ 'mail editor' translated! Item was removed: - ----- Method: MailComposition>>doSendMail (in category 'private') ----- - doSendMail - - (SMTPClient openOnHostNamed: self smtpServer port: self smtpServerPort) - user: self smtpUser; - password: self smtpPassword; - login; - mailFrom: mailMessage from to: (mailMessage to findTokens: ',') text: mailMessage asSendableText.! Item was removed: - ----- Method: MailComposition>>initialize (in category 'initialize-release') ----- - initialize - - mailMessage := MailMessage empty. - isSending := false.! Item was removed: - ----- Method: MailComposition>>isSending (in category 'private') ----- - isSending - - ^ isSending! Item was removed: - ----- Method: MailComposition>>lineHeight (in category 'ui constants') ----- - lineHeight - - ^ (Preferences standardDefaultTextFont height * 3/2) truncated! Item was removed: - ----- Method: MailComposition>>messageBCC (in category 'access to mail object') ----- - messageBCC - - ^ mailMessage bcc! Item was removed: - ----- Method: MailComposition>>messageBCC: (in category 'access to mail object') ----- - messageBCC: emailAddresses - - self flag: #TODO. "add validation" - mailMessage bcc: emailAddresses asString. - ^ true! Item was removed: - ----- Method: MailComposition>>messageCC (in category 'access to mail object') ----- - messageCC - - ^ mailMessage cc! Item was removed: - ----- Method: MailComposition>>messageCC: (in category 'access to mail object') ----- - messageCC: emailAddresses - - self flag: #TODO. "add validation" - mailMessage cc: emailAddresses asString. - ^ true! Item was removed: - ----- Method: MailComposition>>messageRecipient (in category 'access to mail object') ----- - messageRecipient - - ^ mailMessage to! Item was removed: - ----- Method: MailComposition>>messageRecipient: (in category 'access to mail object') ----- - messageRecipient: emailAddresses - - self flag: #TODO. "add validation" - mailMessage to: emailAddresses asString. - ^ true! Item was removed: - ----- Method: MailComposition>>messageSender (in category 'access to mail object') ----- - messageSender - - ^ mailMessage from! Item was removed: - ----- Method: MailComposition>>messageSender: (in category 'access to mail object') ----- - messageSender: emailAddress - - self flag: #TODO. "add validation" - mailMessage from: emailAddress asString. - ^ true! Item was removed: - ----- Method: MailComposition>>messageSubject (in category 'access to mail object') ----- - messageSubject - - ^ mailMessage subject! Item was removed: - ----- Method: MailComposition>>messageSubject: (in category 'access to mail object') ----- - messageSubject: aSubject - - self flag: #TODO. "add validation" - mailMessage subject: aSubject asString. - ^ true! Item was removed: - ----- Method: MailComposition>>messageText (in category 'access to mail object') ----- - messageText - - ^ mailMessage bodyTextFormatted! Item was removed: - ----- Method: MailComposition>>messageText: (in category 'access to mail object') ----- - messageText: aText - - mailMessage body: ((MIMEDocument - contentType: MIMEDocument contentTypePlainText - content: aText asString) - charset: 'UTF-8'; - yourself). - ^ true! Item was removed: - ----- Method: MailComposition>>on: (in category 'initialize-release') ----- - on: aMessage - - mailMessage := aMessage! Item was removed: - ----- Method: MailComposition>>open (in category 'initialize-release') ----- - open - "open an interface" - - ^ToolBuilder open: self label: self dialogTitle! Item was removed: - ----- Method: MailComposition>>recipientLabel (in category 'ui constants') ----- - recipientLabel - - ^ 'Recipients' translated! Item was removed: - ----- Method: MailComposition>>removeAttachment (in category 'actions') ----- - removeAttachment - - | attachmentToBeRemoved | - - self saveFields. - attachmentToBeRemoved := UIManager default - chooseFrom: (mailMessage attachments collect: [:m | m attachmentFileName ]) - values: mailMessage attachments - title: 'Choose attachment to be removed' translated. - mailMessage removeAttachment: attachmentToBeRemoved. - self changed: #messageText.! Item was removed: - ----- Method: MailComposition>>removeAttachmentButtonLabel (in category 'ui constants') ----- - removeAttachmentButtonLabel - - ^ 'remove attachment' translated! Item was removed: - ----- Method: MailComposition>>resetSending (in category 'private') ----- - resetSending - - isSending := false. - self changed.! Item was removed: - ----- Method: MailComposition>>saveFields (in category 'private') ----- - saveFields - - (self dependents select: [:d | d hasUnacceptedEdits]) do: [:d | d accept].! Item was removed: - ----- Method: MailComposition>>sendMail (in category 'actions') ----- - sendMail - - self isSending ifFalse: [ - self saveFields. - - self setSending. - - [[self doSendMail] on: Error do: [:e | self resetSending. e signal]. - Project current addDeferredUIMessage: [self changed: #close].] - forkAt: 30. - - self - changed: #sendMailButtonLabel; - changed: #sendMailButtonColor]! Item was removed: - ----- Method: MailComposition>>sendMailButtonColor (in category 'ui constants') ----- - sendMailButtonColor - - ^ self isSending - ifTrue: [Color green lighter duller] - ifFalse: [PluggableButtonMorph new userInterfaceTheme color]! Item was removed: - ----- Method: MailComposition>>sendMailButtonLabel (in category 'ui constants') ----- - sendMailButtonLabel - - ^ (self isSending - ifTrue: ['sending...'] - ifFalse: ['send mail']) translated! Item was removed: - ----- Method: MailComposition>>sendMailMessage: (in category 'interface') ----- - sendMailMessage: aMailMessage - self messageText: aMailMessage text! Item was removed: - ----- Method: MailComposition>>senderLabel (in category 'ui constants') ----- - senderLabel - - ^ 'Sender' translated! Item was removed: - ----- Method: MailComposition>>setSending (in category 'private') ----- - setSending - - isSending := true.! Item was removed: - ----- Method: MailComposition>>smtpPassword (in category 'MailSender interface') ----- - smtpPassword - - ^ MailSender userPassword! Item was removed: - ----- Method: MailComposition>>smtpServer (in category 'MailSender interface') ----- - smtpServer - - ^ MailSender smtpServer! Item was removed: - ----- Method: MailComposition>>smtpServerPort (in category 'MailSender interface') ----- - smtpServerPort - - ^ MailSender smtpServerPort! Item was removed: - ----- Method: MailComposition>>smtpUser (in category 'MailSender interface') ----- - smtpUser - - ^ MailSender userName! Item was removed: - ----- Method: MailComposition>>subjectLabel (in category 'ui constants') ----- - subjectLabel - - ^ 'Subject' translated! Item was removed: - Object subclass: #MailMessage - instanceVariableNames: 'text body fields parts' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-Url'! - - !MailMessage commentStamp: '<historical>' prior: 0! - I represent an Internet mail or news message. - - text - the raw text of my message - body - the body of my message, as a MIMEDocument - fields - a dictionary mapping lowercased field names into collections of MIMEHeaderValue's - parts - if I am a multipart message, then this is a cache of my parts! Item was removed: - ----- Method: MailMessage class>>dateStamp: (in category 'utilities') ----- - dateStamp: aDateAndTime - "Return the given date and time formatted as a email Date: line" - "The result conforms to RFC822 with a long year, e.g. 'Thu, 18 Feb 1999 20:38:51'" - | d t | - d := aDateAndTime asDate. - t := aDateAndTime asTime. - ^ (d weekday copyFrom: 1 to: 3), ', ', - (d printFormat: #(1 2 3 $ 2 1 1)), ' ', - "We are careful to avoid fractional seconds appearing in the result:" - (Time fromSeconds: t asSeconds) print24! Item was removed: - ----- Method: MailMessage class>>dateStampNow (in category 'utilities') ----- - dateStampNow - "Return the current date and time formatted as a email Date: line" - ^ self dateStamp: DateAndTime now! Item was removed: - ----- Method: MailMessage class>>empty (in category 'instance creation') ----- - empty - "return a message with no text and no header" - - ^self new! Item was removed: - ----- Method: MailMessage class>>from: (in category 'instance creation') ----- - from: aString - "Initialize a new instance from the given string." - - ^(self new) initializeFromString: aString! Item was removed: - ----- Method: MailMessage class>>generateSeparator (in category 'utilities') ----- - generateSeparator - "generate a separator usable for making MIME multipart documents. A leading -- will *not* be included" - ^'==CelesteAttachment' , (10000 to: 99999) atRandom asString , '=='.! Item was removed: - ----- Method: MailMessage class>>omittedHeaderFields (in category 'preferences') ----- - omittedHeaderFields - "Reply a list of fields to omit when displaying a nice simple message" - - "Note that heads of the form - X-something: value - are filtered programatically. This is done since we don't want any of them - and it is impossible to predict them in advance." - - ^ #( - 'comments' - 'priority' - 'disposition-notification-to' - 'content-id' - 'received' - 'return-path' - 'newsgroups' - 'message-id' - 'path' - 'in-reply-to' - 'sender' - 'fonts' - 'mime-version' - 'status' - 'content-type' - 'content-transfer-encoding' - 'errors-to' - 'keywords' - 'references' - 'nntp-posting-host' - 'lines' - 'return-receipt-to' - 'precedence' - 'originator' - 'distribution' - 'content-disposition' - 'importance' - 'resent-to' - 'resent-cc' - 'resent-message-id' - 'resent-date' - 'resent-sender' - 'resent-from' - 'delivered-to' - 'user-agent' - 'content-class' - 'thread-topic' - 'thread-index' - 'list-help', - 'list-post', - 'list-subscribe', - 'list-id', - 'list-unsubscribe', - 'list-archive' - ) - ! Item was removed: - ----- Method: MailMessage class>>replyAllFor: (in category 'instance creation') ----- - replyAllFor: aMailMessage - - ^ self replyFor: aMailMessage excluding: {}! Item was removed: - ----- Method: MailMessage class>>replyAllFor:excluding: (in category 'instance creation') ----- - replyAllFor: aMailMessage excluding: ignoredEmailAddresses - - | replySubject references replyReceivers ccReceivers | - - replyReceivers := MailAddressParser addressesIn: (aMailMessage fieldsNamed: 'to' separatedBy: ', '). - replyReceivers := replyReceivers reject: [:m | - ignoredEmailAddresses includes: m ]. - replyReceivers addFirst: aMailMessage replyReceiver. - - replySubject := aMailMessage replySubject. - references := aMailMessage references. - - ccReceivers := MailAddressParser addressesIn: aMailMessage cc. - ccReceivers := ccReceivers reject: [:m | - ignoredEmailAddresses includes: m ]. - - ^ self empty - to: (replyReceivers joinSeparatedBy: ','); - cc: (ccReceivers joinSeparatedBy: ','); - subject: replySubject; - setField: 'in-reply-to' toString: aMailMessage messageId; - setField: 'references' toString: references; - yourself - ! Item was removed: - ----- Method: MailMessage class>>replyFor: (in category 'instance creation') ----- - replyFor: aMailMessage - - | replyReceiver replySubject references | - replyReceiver := aMailMessage replyReceiver. - replySubject := aMailMessage replySubject. - references := aMailMessage references. - - ^ self empty - to: replyReceiver; - subject: replySubject; - setField: 'in-reply-to' toString: aMailMessage messageId; - setField: 'references' toString: references; - yourself - ! Item was removed: - ----- Method: MailMessage>>addAttachmentFrom:withName: (in category 'multipart') ----- - addAttachmentFrom: aStream withName: aName - "add an attachment, encoding with base64. aName is the optional filename" - | newPart | - self makeMultipart. - - newPart := MIMEDocument contentType: (MIMEDocument guessTypeFromName: aName) content: ''. - newPart setField: 'content-transfer-encoding' toString: 'base64'. - newPart setField: 'content-disposition' toString: 'attachment'. - - aName ifNotNil: [ - | dispositionField contentTypeField | - dispositionField := newPart fieldNamed: 'content-disposition' - ifAbsent: [self error: 'Should be initialized by now']. - dispositionField parameterAt: 'filename' put: '"' , aName , '"'. - - contentTypeField := newPart fieldNamed: 'content-type' - ifAbsent: [self error: 'Should be initialized by now']. - contentTypeField parameterAt: 'name' put: '"' , aName , '"'.]. - - newPart content: aStream upToEnd. - self body addPart: newPart.! Item was removed: - ----- Method: MailMessage>>asSendableText (in category 'printing/formatting') ----- - asSendableText - - ^ self text! Item was removed: - ----- Method: MailMessage>>atomicParts (in category 'multipart') ----- - atomicParts - "Answer all of the leaf parts of this message, including those of multipart included messages" - - self body isMultipart ifFalse: [^ OrderedCollection with: self]. - ^ self parts inject: OrderedCollection new into: [:col :part | col , part atomicParts]! Item was removed: - ----- Method: MailMessage>>attachmentSeparator (in category 'multipart') ----- - attachmentSeparator - ^(self fieldNamed: 'content-type' ifAbsent: [^nil]) parameters - at: 'boundary' ifAbsent: [^nil]! Item was removed: - ----- Method: MailMessage>>attachments (in category 'multipart') ----- - attachments - - ^ self body parts select: [:p | - (p fieldNamed: 'content-disposition' ifAbsent: [nil]) - ifNil: [false] - ifNotNil: [:headerValue | headerValue mainValue = 'attachment' ]]! Item was removed: - ----- Method: MailMessage>>bcc (in category 'accessing') ----- - bcc - - ^ self fieldsNamed: 'bcc' separatedBy: ', '! Item was removed: - ----- Method: MailMessage>>bcc: (in category 'accessing') ----- - bcc: commaSeperatedListOfEmailAddresses - - ^ self setField: 'bcc' toString: commaSeperatedListOfEmailAddresses! Item was removed: - ----- Method: MailMessage>>body (in category 'accessing') ----- - body - "return just the body of the message" - ^body! Item was removed: - ----- Method: MailMessage>>body: (in category 'initialize-release') ----- - body: newBody - - self isMultipart - ifTrue: [self body parts at: 1 put: newBody] - ifFalse: [body := newBody]! Item was removed: - ----- Method: MailMessage>>bodyText (in category 'accessing') ----- - bodyText - "return the text of the body of the message" - ^ body asSendableBodyText! Item was removed: - ----- Method: MailMessage>>bodyTextFormatted (in category 'printing/formatting') ----- - bodyTextFormatted - - ^ self body bodyTextFormatted - ! Item was removed: - ----- Method: MailMessage>>canonicalFields (in category 'fields') ----- - canonicalFields - "Break long header fields and escape those containing high-ascii characters according to RFC2047" - - self rewriteFields: - [ :fName :fValue | - (fName size + fValue size < 72 and: [fValue allSatisfy: [:c | c asciiValue <= 128]]) - ifFalse: [QEncodingMimeConverter mimeEncode: fName, ': ', fValue]] - append: []. - - ! Item was removed: - ----- Method: MailMessage>>cc (in category 'accessing') ----- - cc - - ^ self fieldsNamed: 'cc' separatedBy: ', '! Item was removed: - ----- Method: MailMessage>>cc: (in category 'accessing') ----- - cc: commaSeperatedListOfEmailAddresses - - ^ self setField: 'cc' toString: commaSeperatedListOfEmailAddresses! Item was removed: - ----- Method: MailMessage>>cleanedHeader (in category 'printing/formatting') ----- - cleanedHeader - "Reply with a cleaned up version email header. First show fields people would normally want to see (in a regular order for easy browsing), and then any other fields not explictly excluded" - - | new priorityFields omittedFields | - - new := WriteStream on: (String new: text size). - - priorityFields := #('Date' 'From' 'Subject' 'To' 'Cc'). - omittedFields := MailMessage omittedHeaderFields. - - "Show the priority fields first, in the order given in priorityFields" - priorityFields do: [ :pField | - "We don't check whether the priority field is in the omitted list!!" - self headerFieldsNamed: pField do: - [: fValue | new nextPutAll: pField, ': ', fValue decodeMimeHeader; cr]]. - - "Show the rest of the fields, omitting the uninteresting ones and ones we have already shown" - omittedFields := omittedFields, priorityFields. - self fieldsFrom: (ReadStream on: text) do: - [: fName : fValue | - ((fName beginsWith: 'x-') or: - [omittedFields anySatisfy: [: omitted | fName sameAs: omitted]]) - ifFalse: [new nextPutAll: fName, ': ', fValue; cr]]. - - ^new contents! Item was removed: - ----- Method: MailMessage>>containsViewableImage (in category 'testing') ----- - containsViewableImage - ^self body isJpeg | self body isGif | self body isPng! Item was removed: - ----- Method: MailMessage>>contentType (in category 'accessing') ----- - contentType - - ^ self body contentTypeHeaderValue! Item was removed: - ----- Method: MailMessage>>date (in category 'accessing') ----- - date - - ^ DateAndTime fromSeconds: self time + (Date newDay: 1 year: 1980) asSeconds! Item was removed: - ----- Method: MailMessage>>dateString (in category 'accessing') ----- - dateString - "Answer a date string for this message." - - ^(Date fromSeconds: self time + (Date newDay: 1 year: 1980) asSeconds) - printFormat: #(2 1 3 47 1 2)! Item was removed: - ----- Method: MailMessage>>dateTime: (in category 'accessing') ----- - dateTime: aDateTime - - self setField: 'date' toString: aDateTime asMailMessageString! Item was removed: - ----- Method: MailMessage>>decoderClass (in category 'multipart') ----- - decoderClass - | encoding | - encoding := self fieldNamed: 'content-transfer-encoding' ifAbsent: [^ nil]. - encoding := encoding mainValue. - encoding asLowercase = 'base64' ifTrue: [^ Base64MimeConverter]. - encoding asLowercase = 'quoted-printable' ifTrue: [^ QuotedPrintableMimeConverter]. - ^ nil! Item was removed: - ----- Method: MailMessage>>excerpt (in category 'printing/formatting') ----- - excerpt - "Return a short excerpt of the text of the message" - - ^ self bodyText withSeparatorsCompacted truncateWithElipsisTo: 60! Item was removed: - ----- Method: MailMessage>>fieldNamed:ifAbsent: (in category 'fields') ----- - fieldNamed: aString ifAbsent: aBlock - | matchingFields | - "return the value of the field with the specified name. If there is more than one field, then return the first one" - matchingFields := fields at: aString asLowercase ifAbsent: [ ^aBlock value ]. - ^matchingFields first! Item was removed: - ----- Method: MailMessage>>fields (in category 'accessing') ----- - fields - "return the internal fields structure. This is private and subject to change!!" - ^ fields! Item was removed: - ----- Method: MailMessage>>fieldsFrom:do: (in category 'parsing') ----- - fieldsFrom: aStream do: aBlock - "Invoke the given block with each of the header fields from the given stream. The block arguments are the field name and value. The streams position is left right after the empty line separating header and body." - - | savedLine line s | - savedLine := aStream nextLine. - [aStream atEnd] whileFalse: [ - line := savedLine. - (line isEmpty) ifTrue: [^self]. "quit when we hit a blank line" - [savedLine := aStream nextLine. - savedLine notNil and: [savedLine notEmpty] and: [savedLine first isSeparator]] whileTrue: [ - "lines starting with white space are continuation lines" - s := ReadStream on: savedLine. - s skipSeparators. - line := line, ' ', s upToEnd]. - self reportField: line withBlanksTrimmed to: aBlock]. - - "process final header line of a body-less message" - (savedLine isEmpty) ifFalse: [self reportField: savedLine withBlanksTrimmed to: aBlock]. - ! Item was removed: - ----- Method: MailMessage>>fieldsNamed:ifAbsent: (in category 'fields') ----- - fieldsNamed: aString ifAbsent: aBlock - "return a list of all fields with the given name" - ^fields at: aString asLowercase ifAbsent: aBlock! Item was removed: - ----- Method: MailMessage>>fieldsNamed:separatedBy: (in category 'fields') ----- - fieldsNamed: aString separatedBy: separationString - "return all fields with the specified name, concatenated together with separationString between each element. Return an empty string if no fields with the specified name are present" - | matchingFields | - matchingFields := self fieldsNamed: aString ifAbsent: [ ^'' ]. - ^String streamContents: [ :str | - matchingFields - do: [ :field | str nextPutAll: field mainValue ] - separatedBy: [ str nextPutAll: separationString ]]. - ! Item was removed: - ----- Method: MailMessage>>format (in category 'printing/formatting') ----- - format - "Replace the text of this message with a formatted version." - "NOTE: This operation discards extra header fields." - - text := self formattedText.! Item was removed: - ----- Method: MailMessage>>formattedText (in category 'printing/formatting') ----- - formattedText - "Answer a version of my text suitable for display. This cleans up the header, decodes HTML, and things like that" - - - ^ self cleanedHeader asText, String cr , self bodyTextFormatted! Item was removed: - ----- Method: MailMessage>>from (in category 'accessing') ----- - from - - ^(self fieldNamed: 'from' ifAbsent: [ ^'' ]) mainValue! Item was removed: - ----- Method: MailMessage>>from: (in category 'accessing') ----- - from: aString - - | sanitizedMailAddress | - sanitizedMailAddress := (MailAddressParser addressesIn: aString) first. - ^self setField: 'from' toString: sanitizedMailAddress! Item was removed: - ----- Method: MailMessage>>hasFieldNamed: (in category 'fields') ----- - hasFieldNamed: aString - ^fields includesKey: aString asLowercase! Item was removed: - ----- Method: MailMessage>>headerFieldsNamed:do: (in category 'parsing') ----- - headerFieldsNamed: fieldName do: aBlock - "Evalue aBlock once for each header field which matches fieldName. The block is valued with one parameter, the value of the field" - - self fieldsFrom: (ReadStream on: text) do: - [: fName : fValue | - (fieldName sameAs: fName) ifTrue: [aBlock value: fValue]]. - ! Item was removed: - ----- Method: MailMessage>>initialize (in category 'initialize-release') ----- - initialize - "initialize as an empty message" - - text := String cr. - fields := Dictionary new. - body := MIMEDocument contentType: 'text/plain' content: String cr. - self dateTime: TimeStamp now.! Item was removed: - ----- Method: MailMessage>>initializeFromString: (in category 'initialize-release') ----- - initializeFromString: aString - "Parse aString to initialize myself." - - | parseStream contentType bodyText contentTransferEncoding | - - text := aString withoutTrailingBlanks, String cr, String cr. - parseStream := ReadStream on: text. - contentType := 'text/plain'. - contentTransferEncoding := nil. - fields := Dictionary new. - - "Extract information out of the header fields" - self fieldsFrom: parseStream do: - [:fName :fValue | - "NB: fName is all lowercase" - - fName = 'content-type' ifTrue: [contentType := fValue asLowercase]. - fName = 'content-transfer-encoding' ifTrue: [contentTransferEncoding := fValue asLowercase]. - - (fields at: fName ifAbsentPut: [OrderedCollection new: 1]) - add: (MIMEHeaderValue forField: fName fromString: fValue)]. - - "Extract the body of the message" - bodyText := parseStream upToEnd. - bodyText := (MimeConverter forEncoding: contentTransferEncoding) - mimeDecode: (ReadStream on: bodyText) as: String. - - body := MIMEDocument contentType: contentType content: bodyText! Item was removed: - ----- Method: MailMessage>>isMultipart (in category 'multipart') ----- - isMultipart - - ^ self body isMultipart! Item was removed: - ----- Method: MailMessage>>makeMultipart (in category 'multipart') ----- - makeMultipart - "if I am not multipart already, then become a multipart message with one part" - - | newBody | - - body isMultipart ifTrue: [ ^self ]. - - "set up the new message part" - newBody := MIMEDocument newMultipart. - newBody addPart: body. - - self setField: 'mime-version' to: (MIMEHeaderValue fromMIMEHeader: '1.0'). - - body := newBody.! Item was removed: - ----- Method: MailMessage>>messageId (in category 'accessing') ----- - messageId - - ^ (self fieldNamed: 'message-id' ifAbsent: [ ^'' ]) mainValue! Item was removed: - ----- Method: MailMessage>>messageId: (in category 'accessing') ----- - messageId: aString - - ^ self setField: 'message-id' toString: aString! Item was removed: - ----- Method: MailMessage>>name (in category 'access') ----- - name - "return a default name for this part, if any was specified. If not, return nil" - | type nameField disposition | - - "try in the content-type: header" - type := self fieldNamed: 'content-type' ifAbsent: [nil]. - (type notNil and: [(nameField := type parameters at: 'name' ifAbsent: [nil]) notNil]) - ifTrue: [^ nameField]. - - "try in content-disposition:" - disposition := self fieldNamed: 'content-disposition' ifAbsent: [nil]. - (disposition notNil and: [(nameField := disposition parameters at: 'filename' ifAbsent: [nil]) notNil]) - ifTrue: [^ nameField]. - - "give up" - ^ nil! Item was removed: - ----- Method: MailMessage>>parseParts (in category 'multipart') ----- - parseParts - "private -- parse the parts of the message and store them into a collection" - - | parseStream msgStream messages separator | - - "If this is not multipart, store an empty collection" - self body isMultipart ifFalse: [parts := #(). ^self]. - - "If we can't find a valid separator, handle it as if the message is not multipart" - separator := self attachmentSeparator. - separator ifNil: [Transcript show: 'Ignoring bad attachment separater'; cr. parts := #(). ^self]. - - separator := '--', separator withoutTrailingBlanks. - parseStream := ReadStream on: self bodyText. - - msgStream := LimitingLineStreamWrapper on: parseStream delimiter: separator. - msgStream limitingBlock: [:aLine | - aLine withoutTrailingBlanks = separator or: "Match the separator" - [aLine withoutTrailingBlanks = (separator, '--')]]. "or the final separator with --" - - "Throw away everything up to and including the first separator" - msgStream upToEnd. - msgStream skipThisLine. - - "Extract each of the multi-parts as strings" - messages := OrderedCollection new. - [parseStream atEnd] - whileFalse: - [messages add: msgStream upToEnd. - msgStream skipThisLine]. - - parts := messages collect: [:e | MailMessage from: e]! Item was removed: - ----- Method: MailMessage>>parseParts: (in category 'multipart') ----- - parseParts: bodyText - "private -- parse the parts of the message and store them into a collection" - - | parseStream msgStream messages separator | - - "If we can't find a valid separator, handle it as if the message is not multipart" - separator := self attachmentSeparator. - separator ifNil: [self error: 'Bad attachment separater']. - - separator := '--', separator withoutTrailingBlanks. - parseStream := ReadStream on: bodyText. - - msgStream := LimitingLineStreamWrapper on: parseStream delimiter: separator. - msgStream limitingBlock: [:aLine | - aLine withoutTrailingBlanks = separator or: "Match the separator" - [aLine withoutTrailingBlanks = (separator, '--')]]. "or the final separator with --" - - "Throw away everything up to and including the first separator" - msgStream upToEnd. - msgStream skipThisLine. - - "Extract each of the multi-parts as strings" - messages := OrderedCollection new. - [parseStream atEnd] - whileFalse: - [messages add: msgStream upToEnd. - msgStream skipThisLine]. - - ^ messages collect: [:e | MIMEDocument from: e]! Item was removed: - ----- Method: MailMessage>>parts (in category 'multipart') ----- - parts - - ^ self body parts! Item was removed: - ----- Method: MailMessage>>printOn: (in category 'printing/formatting') ----- - printOn: aStream - - aStream nextPutAll: 'Text: ' , self excerpt! Item was removed: - ----- Method: MailMessage>>readDateFrom: (in category 'parsing') ----- - readDateFrom: aStream - "Parse a date from the given stream and answer nil if the date can't be parsed. The date may be in any of the following forms: - <day> <monthName> <year> (5 April 1982; 5-APR-82) - <monthName> <day> <year> (April 5, 1982) - <monthNumber> <day> <year> (4/5/82) - In addition, the date may be preceded by the day of the week and an optional comma, such as: - Tue, November 14, 1989" - - | day month year | - self skipWeekdayName: aStream. - aStream peek isDigit ifTrue: [day := Integer readFrom: aStream]. - [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. - aStream peek isLetter - ifTrue: "month name or weekday name" - [month := WriteStream on: (String new: 10). - [aStream peek isLetter] whileTrue: [month nextPut: aStream next]. - month := month contents. - day isNil ifTrue: "name/number..." - [[aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. - (aStream peek isDigit) ifFalse: [^nil]. - day := Integer readFrom: aStream]] - ifFalse: "number/number..." - [month := Date nameOfMonth: day. - day := Integer readFrom: aStream]. - [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. - (aStream peek isDigit) ifFalse: [^nil]. - year := Integer readFrom: aStream. - ^ Date newDay: day month: month year: year! Item was removed: - ----- Method: MailMessage>>readFrom: (in category 'parsing') ----- - readFrom: parseStream - - | bodyText contentTransferEncoding contentType | - contentType := 'text/plain'. - contentTransferEncoding := nil. - fields := Dictionary new. - - "Extract information out of the header fields" - self fieldsFrom: parseStream do: - [:fName :fValue | - "NB: fName is all lowercase" - - fName = 'content-type' ifTrue: [contentType := fValue asLowercase]. - fName = 'content-transfer-encoding' ifTrue: [contentTransferEncoding := fValue asLowercase]. - - (fields at: fName ifAbsentPut: [OrderedCollection new: 1]) - add: (MIMEHeaderValue forField: fName fromString: fValue)]. - - "Extract the body of the message" - bodyText := parseStream upToEnd. - contentTransferEncoding = 'base64' ifTrue: [ - bodyText := Base64MimeConverter mimeDecodeToChars: (ReadStream on: bodyText). - bodyText := bodyText contents]. - contentTransferEncoding = 'quoted-printable' ifTrue: [ - bodyText := bodyText decodeQuotedPrintable]. - - body := MIMEDocument contentType: contentType content: bodyText! Item was removed: - ----- Method: MailMessage>>readStringLineFrom: (in category 'parsing') ----- - readStringLineFrom: aStream - "Read and answer the next line from the given stream. Consume the carriage return but do not append it to the string." - - ^aStream nextLine! Item was removed: - ----- Method: MailMessage>>references (in category 'accessing') ----- - references - - ^ (self hasFieldNamed: 'references') - ifTrue: [(self fieldNamed: 'references' ifAbsent: [self error: 'Something changed the mail between the check and now']) - mainValue , ', ' , self messageId] - ifFalse: [self messageId].! Item was removed: - ----- Method: MailMessage>>regenerateBodyFromParts (in category 'printing/formatting') ----- - regenerateBodyFromParts - "regenerate the message body from the multiple parts" - | bodyText | - - bodyText := String streamContents: [ :str | - str cr. - parts do: [ :part | - str - cr; - nextPutAll: '--'; - nextPutAll: self attachmentSeparator; - cr; - nextPutAll: part text ]. - - str - cr; - nextPutAll: '--'; - nextPutAll: self attachmentSeparator; - nextPutAll: '--'; - cr ]. - - body := MIMEDocument contentType: 'multipart/mixed' content: bodyText. - text := nil. "text needs to be reformatted"! Item was removed: - ----- Method: MailMessage>>regenerateText (in category 'printing/formatting') ----- - regenerateText - "regenerate the full text from the body and headers" - - text := String streamContents: [ :str | | encodedBodyText | - "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 removed: - ----- Method: MailMessage>>removeAttachment: (in category 'multipart') ----- - removeAttachment: aMIMEDocument - - ^ self body parts remove: aMIMEDocument ifAbsent: []! Item was removed: - ----- Method: MailMessage>>removeFieldNamed: (in category 'fields') ----- - removeFieldNamed: name - "remove all fields with the specified name" - fields removeKey: name ifAbsent: []! Item was removed: - ----- Method: MailMessage>>replyReceiver (in category 'accessing') ----- - replyReceiver - - ^ (self - fieldNamed: 'reply-to' - ifAbsent: [self - fieldNamed: 'from' - ifAbsent: [self error: 'there is a field missing in the original message']]) mainValue. - ! Item was removed: - ----- Method: MailMessage>>replySubject (in category 'accessing') ----- - replySubject - - ^ (self subject asLowercase beginsWith: 're:') - ifTrue: [self subject] - ifFalse: ['Re: ' , self subject].! Item was removed: - ----- Method: MailMessage>>reportField:to: (in category 'parsing') ----- - reportField: aString to: aBlock - "Evaluate the given block with the field name a value in the given field. Do nothing if the field is malformed." - - | s fieldName fieldValue | - (aString includes: $:) ifFalse: [^self]. - s := ReadStream on: aString. - fieldName := (s upTo: $:) asLowercase. "fieldname must be lowercase" - fieldValue := s upToEnd withBlanksTrimmed. - fieldValue isEmpty ifFalse: [aBlock value: fieldName value: fieldValue]. - ! Item was removed: - ----- 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 | - 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 | - 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 removed: - ----- Method: MailMessage>>save (in category 'multipart') ----- - save - "save the part to a file" - | fileName | - fileName := self name ifNil: ['attachment' , Utilities dateTimeSuffix]. - (fileName includes: $.) - ifFalse: [#(#isJpeg 'jpg' #isGif 'gif' #isPng 'png' #isPnm 'pnm') - pairsDo: [:s :e | (self body perform: s) - ifTrue: [fileName := fileName , FileDirectory dot , e]]]. - - fileName := UIManager default saveFilenameRequest: 'File name for save?' initialAnswer: fileName. - fileName ifNil: [^ nil]. - - FileStream newFileNamed: fileName - do: [:file | file nextPutAll: self bodyText]! Item was removed: - ----- Method: MailMessage>>selfTest (in category 'testing') ----- - selfTest - "For testing only: Check that this instance is well formed and makes sense" - - self formattedText. - - [MailAddressParser addressesIn: self from] ifError: - [ :err :rcvr | Transcript show: 'Error parsing From: (', self from, ') ', err]. - [MailAddressParser addressesIn: self to] ifError: - [ :err :rcvr | Transcript show: 'Error parsing To: (', self to, ') ', err]. - [MailAddressParser addressesIn: self cc] ifError: - [ :err :rcvr | Transcript show: 'Error parsing CC: (', self cc, ') ', err]. - ! Item was removed: - ----- Method: MailMessage>>setField:to: (in category 'fields') ----- - setField: fieldName to: aFieldValue - "set a field. If any field of the specified name exists, it will be overwritten" - fields at: fieldName asLowercase put: (OrderedCollection with: aFieldValue). - text := nil.! Item was removed: - ----- Method: MailMessage>>setField:toString: (in category 'fields') ----- - setField: fieldName toString: fieldValue - ^self setField: fieldName to: (MIMEHeaderValue forField: fieldName fromString: fieldValue)! Item was removed: - ----- Method: MailMessage>>setText: (in category 'access') ----- - setText: aString - - text := aString withoutTrailingBlanks, String cr, String cr. - self readFrom: text readStream. - ! Item was removed: - ----- Method: MailMessage>>skipWeekdayName: (in category 'parsing') ----- - skipWeekdayName: aStream - "If the given stream starts with a weekday name or its abbreviation, advance the stream to the first alphaNumeric character following the weekday name." - - | position name abbrev | - aStream skipSeparators. - (aStream peek isDigit) ifTrue: [^self]. - (aStream peek isLetter) ifTrue: - [position := aStream position. - name := WriteStream on: (String new: 10). - [aStream peek isLetter] whileTrue: [name nextPut: aStream next]. - abbrev := (name contents copyFrom: 1 to: (3 min: name position)). - abbrev := abbrev asLowercase. - (#('sun' 'mon' 'tue' 'wed' 'thu' 'fri' 'sat') includes: abbrev asLowercase) - ifTrue: - ["found a weekday; skip to the next alphanumeric character" - [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]] - ifFalse: - ["didn't find a weekday so restore stream position" - aStream position: position]].! Item was removed: - ----- Method: MailMessage>>subject (in category 'accessing') ----- - subject - - ^ (self fieldNamed: 'subject' ifAbsent: [ ^'' ]) mainValue! Item was removed: - ----- Method: MailMessage>>subject: (in category 'accessing') ----- - subject: aString - - ^self setField: 'subject' toString: aString! Item was removed: - ----- Method: MailMessage>>text (in category 'accessing') ----- - text - - ^ String streamContents: [ :str | | encodedBodyText | - "first put the header" - (fields associations , {'content-type' -> {self body contentTypeHeaderValue} }) - do: [ :assoc | | fieldName fieldValues | - fieldName := assoc key. - fieldValues := assoc value. - fieldValues do: [ :fieldValue | - str - nextPutAll: fieldName capitalized ; - nextPutAll: ': '; - nextPutAll: fieldValue asHeaderValue; - cr ]]. - - self body contentTransferEncodingHeaderValue - ifNotNil: [:headerValue | - str - nextPutAll: 'content-transfer-encoding' capitalized; - nextPutAll: ': '; - nextPutAll: headerValue 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 asSendableBodyText. - str nextPutAll: encodedBodyText ].! Item was removed: - ----- Method: MailMessage>>time (in category 'accessing') ----- - time - | dateField | - dateField := (self fieldNamed: 'date' ifAbsent: [ ^0 ]) mainValue. - ^ [self timeFrom: dateField] ifError: [:err :rcvr | Date today asSeconds]. - ! Item was removed: - ----- Method: MailMessage>>timeFrom: (in category 'parsing') ----- - timeFrom: aString - "Parse the date and time (rfc822) and answer the result as the number of seconds - since the start of 1980." - - | s t rawDelta delta plusOrMinus | - s := ReadStream on: aString. - - "date part" - t := ((self readDateFrom: s) ifNil: [Date today]) asSeconds. - - [s atEnd or: [s peek isAlphaNumeric]] - whileFalse: [s next]. - - "time part" - s atEnd ifFalse: ["read time part (interpreted as local, regardless of sender's timezone)" - (s peek isDigit) ifTrue: [t := t + (Time readFrom: s) asSeconds]. - ]. - s skipSeparators. - - "Check for a numeric time zone offset" - ('+-' includes: s peek) ifTrue: - [plusOrMinus := s next. - rawDelta := (s peek isDigit) ifTrue: [Integer readFrom: s] ifFalse: [0]. - delta := (rawDelta // 100 * 60 + (rawDelta \\ 100)) * 60. - t := plusOrMinus = $+ ifTrue: [t - delta] ifFalse: [t + delta]]. - - "We ignore text time zone offsets like EST, GMT, etc..." - - ^ t - (Date newDay: 1 year: 1980) asSeconds - - "MailMessage new timeFrom: 'Thu, 22 Jun 2000 14:17:47 -500'" - "MailMessage new timeFrom: 'Thu, 22 Jun 2000 14:17:47 --500'" - "MailMessage new timeFrom: 'on, 04 apr 2001 14:57:32'"! Item was removed: - ----- Method: MailMessage>>to (in category 'accessing') ----- - to - ^self fieldsNamed: 'to' separatedBy: ', '! Item was removed: - ----- Method: MailMessage>>to: (in category 'accessing') ----- - to: aString - - | sanitizedMailAddresses | - sanitizedMailAddresses := (MailAddressParser addressesIn: aString) withoutDuplicates. - ^self setField: 'to' toString: (sanitizedMailAddresses joinSeparatedBy: ', ')! Item was removed: - ----- Method: MailMessage>>viewBody (in category 'printing/formatting') ----- - viewBody - "open a viewer on the body of this message" - self containsViewableImage - ifTrue: [^ self viewImageInBody]. - (StringHolder new contents: self bodyTextFormatted; - yourself) - openLabel: (self name - ifNil: ['(a message part)'])! Item was removed: - ----- Method: MailMessage>>viewImageInBody (in category 'printing/formatting') ----- - viewImageInBody - | stream image | - stream := self body contentStream. - image := Form fromBinaryStream: stream. - (Project current world drawingClass withForm: image) openInWorld! Item was removed: - GenericUrl subclass: #MailtoUrl - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-Url'! - - !MailtoUrl commentStamp: '<historical>' prior: 0! - a URL specifying a mailing address; activating it triggers a mail-sender to start up, if one is present.! Item was removed: - ----- Method: MailtoUrl>>activate (in category 'downloading') ----- - activate - "Activate a Celeste window for the receiver" - - MailSender sendMessage: (MailMessage from: self composeText)! Item was removed: - ----- Method: MailtoUrl>>composeText (in category 'downloading') ----- - composeText - "Answer the template for a new message." - - ^ String streamContents: [:str | - str nextPutAll: 'From: '. - str nextPutAll: MailSender userName; cr. - str nextPutAll: 'To: '. - str nextPutAll: locator asString; cr. - - str nextPutAll: 'Subject: '; cr. - - str cr].! Item was removed: - NetworkError subclass: #NameLookupFailure - instanceVariableNames: 'hostName' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-Exceptions'! - - !NameLookupFailure commentStamp: 'mir 5/12/2003 18:16' prior: 0! - Signals that a name lookup operation failed. - - hostName hostName for which the name loopup failed - ! Item was removed: - ----- Method: NameLookupFailure class>>hostName: (in category 'instance creation') ----- - hostName: aString - ^ self new hostName: aString! Item was removed: - ----- Method: NameLookupFailure>>defaultAction (in category 'handling') ----- - defaultAction - "Backward compatibility" - | response | - response := (Project uiManager - chooseOptionFrom: #( 'Retry' 'Give Up') - title: self messageText). - ^ response = 2 ifFalse: [self retry]! Item was removed: - ----- Method: NameLookupFailure>>hostName (in category 'accessing') ----- - hostName - ^ hostName! Item was removed: - ----- Method: NameLookupFailure>>hostName: (in category 'accessing') ----- - hostName: aString - hostName := aString! Item was removed: - Object subclass: #NetNameResolver - instanceVariableNames: '' - classVariableNames: 'DefaultHostName EnableIPv6 HaveNetwork ResolverBusy ResolverError ResolverMutex ResolverReady ResolverSemaphore ResolverUninitialized UseOldNetwork' - poolDictionaries: '' - category: 'Network-Kernel'! - - !NetNameResolver commentStamp: '<historical>' prior: 0! - This class implements TCP/IP style network name lookup and translation facilities. - - Attempt to keep track of whether there is a network available. - HaveNetwork true if last attempt to contact the network was successful. - LastContact Time of that contact (totalSeconds). - haveNetwork returns true, false, or #expired. True means there was contact in the last 30 minutes. False means contact failed or was false last time we asked. Get out of false state by making contact with a server in some way (FileList or updates).! Item was removed: - ----- Method: NetNameResolver class>>addressForName: (in category 'lookups') ----- - addressForName: hostName - "NetNameResolver addressForName: 'impara.de' " - "NetNameResolver addressForName: 'localhost' " - "NetNameResolver addressForName: '127.0.0.1' " - | addresses | - self useOldNetwork - ifTrue: [^self oldAddressForName: hostName]. - addresses := self addressesForName: hostName. - ^addresses - ifEmpty: [nil] - ifNotEmpty: [addresses first socketAddress]! Item was removed: - ----- Method: NetNameResolver class>>addressForName:family: (in category 'lookups') ----- - addressForName: hostName family: addressFamily - "NetNameResolver addressForName: 'squeak.org' family: SocketAddressInformation addressFamilyINET4" - "NetNameResolver addressForName: 'localhost' family: SocketAddressInformation addressFamilyINET6" - "NetNameResolver addressForName: '127.0.0.1' family: SocketAddressInformation addressFamilyINET6" - | addresses | - self useOldNetwork ifTrue: - [^self oldAddressForName: hostName]. - addresses := self addressesForName: hostName family: addressFamily. - ^addresses - ifEmpty: [nil] - ifNotEmpty: [addresses first socketAddress]! Item was removed: - ----- Method: NetNameResolver class>>addressForName:timeout: (in category 'lookups') ----- - addressForName: hostName timeout: secs - "Look up the given host name and return its address. Return nil if the address is not found in the given number of seconds." - "NetNameResolver addressForName: 'create.ucsb.edu' timeout: 30" - "NetNameResolver addressForName: '100000jobs.de' timeout: 30" - "NetNameResolver addressForName: '1.7.6.4' timeout: 30" - "NetNameResolver addressForName: '' timeout: 30 (This seems to return nil?)" - - | deadline | - self initializeNetwork. - self useOldNetwork - ifFalse: [^self addressForName: hostName]. - "check if this is a valid numeric host address (e.g. 1.2.3.4)" - (self addressFromString: hostName) ifNotNil: [ :numericHostAddress | - ^numericHostAddress ]. - - "Look up a host name, including ones that start with a digit (e.g. 100000jobs.de or squeak.org)" - deadline := Time utcMicrosecondClock + (secs * 1000000). - "Protect the execution of this block, as the ResolverSemaphore is used for both parts of the transaction." - ^(self resolverMutex critical: [ - (self waitForResolverReadyUntil: deadline) ifTrue: [ - self primStartLookupOfName: hostName. - (self waitForCompletionUntil: deadline) ifTrue: [ - self primNameLookupResult. ] ] ]) - ifNil: [ (NameLookupFailure hostName: hostName) signal: 'Could not resolve the server named: ', hostName ] ! Item was removed: - ----- Method: NetNameResolver class>>addressFromString: (in category 'address string utils') ----- - 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 = nil ifTrue: [^ nil]. - newAddr at: i put: byte. - i < 4 ifTrue: [ - delimiter := s next. - ((delimiter = $.) or: [(delimiter = $,) or: [delimiter = $ ]]) - ifFalse: [^ nil]]]. - ^ newAddr - ! Item was removed: - ----- Method: NetNameResolver class>>addressesForName: (in category 'lookup') ----- - addressesForName: hostName - "NetNameResolver addressesForName: 'impara.de' " - - ^SocketAddressInformation - forHost: hostName - service: '' - flags: 0 - addressFamily: 0 - socketType: SocketAddressInformation socketTypeStream - protocol: SocketAddressInformation protocolTCP! Item was removed: - ----- Method: NetNameResolver class>>addressesForName:family: (in category 'lookup') ----- - addressesForName: hostName family: addressFamily - "NetNameResolver - addressesForName: 'squeak.org' - family: SocketAddressInformation addressFamilyINET4" - "NetNameResolver - addressesForName: 'impara.de' - family: SocketAddressInformation addressFamilyINET6" - - ^SocketAddressInformation - forHost: hostName - service: '' - flags: 0 - addressFamily: addressFamily - socketType: SocketAddressInformation socketTypeStream - protocol: SocketAddressInformation protocolTCP! Item was removed: - ----- Method: NetNameResolver class>>enableIPv6 (in category 'system startup') ----- - enableIPv6 - <preference: 'Enable IPv6 and new network support' - category: 'general' - description: 'If true allow IPv6 support. If false, NetNameResolver useOldNetwork is set.' - type: #Boolean> - ^EnableIPv6 ifNil: [true]! Item was removed: - ----- Method: NetNameResolver class>>enableIPv6: (in category 'system startup') ----- - enableIPv6: aBool - "Set a preference to control whether IPv6 primitives and new network support - should be used if available, and reinitialize the UseOldNetwork flag to recognize - the setting. If true, the new networking support will be used if the VM provides - the required primitives. If false, IPv6 and new network support will not be used. - The new network support may be unreliable on some platforms, so this preference - allows it to be explicitly disabled." - - EnableIPv6 := aBool. - self initializeOldNetworkFlag - ! Item was removed: - ----- Method: NetNameResolver class>>hasIpv6PrimSupport (in category 'system startup') ----- - hasIpv6PrimSupport - "True if the VM includes the ipv6 primitives" - ^[NetNameResolver primHostNameSize. true] - on: Error - do: [false] - ! Item was removed: - ----- Method: NetNameResolver class>>initialize (in category 'class initialization') ----- - initialize - "NetNameResolver initialize" - "Note: On the Mac, the name resolver is asynchronous (i.e., Squeak can do other things while it is working), but can only handle one request at a time. On other platforms, such as Unix, the resolver is synchronous; a call to, say, the name lookup primitive will block all Squeak processes until it returns." - - "Resolver Status Values" - ResolverUninitialized := 0. "network is not initialized" - ResolverReady := 1. "resolver idle, last request succeeded" - ResolverBusy := 2. "lookup in progress" - ResolverError := 3. "resolver idle, last request failed" - - DefaultHostName := ''. - - self enableIPv6: true. "Initialize preference to permit use of new networking" - Smalltalk addToStartUpList: self. - - ! Item was removed: - ----- Method: NetNameResolver class>>initializeNetwork (in category 'network initialization') ----- - initializeNetwork - "Initialize the network drivers and record the semaphore to be used by the resolver. Do nothing if the network is already initialized. Signal NoNetworkError if network initialization fails." - "NetNameResolver initializeNetwork" - - self resolverStatus = ResolverUninitialized - ifFalse: [^HaveNetwork := true]. "network is already initialized" - - HaveNetwork := false. "in case abort" - Smalltalk newExternalSemaphoreDo: [ :semaphore :index | - ResolverSemaphore := semaphore. - "result is nil if network initialization failed, self if it succeeds" - (self primInitializeNetwork: index) - ifNil: [ - Smalltalk unregisterExternalObject: ResolverSemaphore. - ResolverSemaphore := nil. - NoNetworkError signal: 'failed network initialization'] - ifNotNil: [ HaveNetwork := true ] ]. - - self initializeOldNetworkFlag! Item was removed: - ----- Method: NetNameResolver class>>initializeOldNetworkFlag (in category 'system startup') ----- - initializeOldNetworkFlag - "If the VM does not provide support for IPv6 primitives, or if the enable IPv6 - preference is not selected, then set a flag to force use of traditional IPv4 - network support. This limits network support to IPv4 and uses a four-element - ByteArray rather than SocketAddress to represent network addresses." - - UseOldNetwork := self hasIpv6PrimSupport not or: [self enableIPv6 ~= true]! Item was removed: - ----- Method: NetNameResolver class>>localAddressString (in category 'lookups') ----- - localAddressString - "Return a string representing the local host address as four decimal bytes delimited with decimal points." - "NetNameResolver localAddressString" - - self useOldNetwork - ifTrue: [^self stringFromAddress: self primLocalAddress]. - ^self localHostAddress hostNumber! Item was removed: - ----- Method: NetNameResolver class>>localHostAddress (in category 'lookups') ----- - localHostAddress - "Return the local address of this host." - "NetNameResolver localHostAddress" - - self useOldNetwork ifTrue: [ - self initializeNetwork. - ^self primLocalAddress ]. - ^NetNameResolver addressForName: self localHostName! Item was removed: - ----- Method: NetNameResolver class>>localHostName (in category 'lookups') ----- - localHostName - "Return the local name of this host." - "NetNameResolver localHostName" - - | host | - self useOldNetwork ifTrue: [ - | hostName | - hostName := self - nameForAddress: self localHostAddress - timeout: 5. - ^hostName ifNil: [ self localAddressString ] ]. - host := String new: NetNameResolver primHostNameSize. - NetNameResolver primHostNameResult: host. - ^host! Item was removed: - ----- Method: NetNameResolver class>>nameForAddress: (in category 'lookups') ----- - nameForAddress: hostAddress - - ^self nameForAddress: hostAddress timeout: 60! Item was removed: - ----- 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 | - self initializeNetwork. - deadline := Time utcMicrosecondClock + (secs * 1000000). - "Protect the execution of this block, as the ResolverSemaphore is used for both parts of the transaction." - ^self resolverMutex critical: [ - (self waitForResolverReadyUntil: deadline) ifTrue: [ - self primStartLookupOfAddress: hostAddress. - (self waitForCompletionUntil: deadline) ifTrue: [ - self primAddressLookupResult ] ] ]! Item was removed: - ----- Method: NetNameResolver class>>nextSocketAddressInformation (in category 'private') ----- - nextSocketAddressInformation - - | addrSize addr info | - addrSize := self primGetAddressInfoSize. - addrSize < 0 ifTrue: [^nil]. - addr := SocketAddress new: addrSize. - self primGetAddressInfoResult: addr. - info := SocketAddressInformation - withSocketAddress: addr - family: self primGetAddressInfoFamily - type: self primGetAddressInfoType - protocol: self primGetAddressInfoProtocol. - self primGetAddressInfoNext. - ^info! Item was removed: - ----- Method: NetNameResolver class>>oldAddressForName: (in category 'lookups-old') ----- - oldAddressForName: aString - "NetNameResolver oldAddressForName: 'vpri.org' " - ^self addressForName: aString timeout: 60! Item was removed: - ----- Method: NetNameResolver class>>primAbortLookup (in category 'primitives') ----- - primAbortLookup - "Abort the current lookup operation, freeing the name resolver for the next query." - - <primitive: 'primitiveResolverAbortLookup' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: NetNameResolver class>>primAddressLookupResult (in category 'primitives') ----- - primAddressLookupResult - "Return the host name found by the last host address lookup. Returns nil if the last lookup was unsuccessful." - - <primitive: 'primitiveResolverAddressLookupResult' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: NetNameResolver class>>primGetAddressInfoFamily (in category 'primitives-ipv6') ----- - primGetAddressInfoFamily - - <primitive: 'primitiveResolverGetAddressInfoFamily' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: NetNameResolver class>>primGetAddressInfoHost:service:flags:family:type:protocol: (in category 'primitives-ipv6') ----- - primGetAddressInfoHost: hostName service: servName flags: flags family: family type: type protocol: protocol - - <primitive: 'primitiveResolverGetAddressInfo' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: NetNameResolver class>>primGetAddressInfoNext (in category 'primitives-ipv6') ----- - primGetAddressInfoNext - - <primitive: 'primitiveResolverGetAddressInfoNext' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: NetNameResolver class>>primGetAddressInfoProtocol (in category 'primitives-ipv6') ----- - primGetAddressInfoProtocol - - <primitive: 'primitiveResolverGetAddressInfoProtocol' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: NetNameResolver class>>primGetAddressInfoResult: (in category 'primitives-ipv6') ----- - primGetAddressInfoResult: socketAddress - - <primitive: 'primitiveResolverGetAddressInfoResult' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: NetNameResolver class>>primGetAddressInfoSize (in category 'primitives-ipv6') ----- - primGetAddressInfoSize - - <primitive: 'primitiveResolverGetAddressInfoSize' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: NetNameResolver class>>primGetAddressInfoType (in category 'primitives-ipv6') ----- - primGetAddressInfoType - - <primitive: 'primitiveResolverGetAddressInfoType' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: NetNameResolver class>>primGetNameInfo:flags: (in category 'primitives-ipv6') ----- - primGetNameInfo: socketAddress flags: flags - - <primitive: 'primitiveResolverGetNameInfo' module: 'SocketPlugin'> - flags == 0 ifTrue: [^self primGetNameInfo: socketAddress - flags: SocketAddressInformation numericFlag]. - self primitiveFailed! Item was removed: - ----- Method: NetNameResolver class>>primGetNameInfoHostResult: (in category 'primitives-ipv6') ----- - primGetNameInfoHostResult: aString - - <primitive: 'primitiveResolverGetNameInfoHostResult' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: NetNameResolver class>>primGetNameInfoHostSize (in category 'primitives-ipv6') ----- - primGetNameInfoHostSize - - <primitive: 'primitiveResolverGetNameInfoHostSize' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: NetNameResolver class>>primGetNameInfoServiceResult: (in category 'primitives-ipv6') ----- - primGetNameInfoServiceResult: aString - - <primitive: 'primitiveResolverGetNameInfoServiceResult' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: NetNameResolver class>>primGetNameInfoServiceSize (in category 'primitives-ipv6') ----- - primGetNameInfoServiceSize - - <primitive: 'primitiveResolverGetNameInfoServiceSize' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: NetNameResolver class>>primHostNameResult: (in category 'primitives-ipv6') ----- - primHostNameResult: aString - - <primitive: 'primitiveResolverHostNameResult' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: NetNameResolver class>>primHostNameSize (in category 'primitives-ipv6') ----- - primHostNameSize - - <primitive: 'primitiveResolverHostNameSize' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: NetNameResolver class>>primInitializeNetwork: (in category 'network initialization') ----- - primInitializeNetwork: resolverSemaIndex - "Initialize the network drivers on platforms that need it, such as the Macintosh, and return nil if network initialization failed or the reciever if it succeeds. Since mobile computers may not always be connected to a network, this method should NOT be called automatically at startup time; rather, it should be called when first starting a networking application. It is a noop if the network driver has already been initialized. If non-zero, resolverSemaIndex is the index of a VM semaphore to be associated with the network name resolver. This semaphore will be signalled when the resolver status changes, such as when a name lookup query is completed." - "Note: some platforms (e.g., Mac) only allow only one name lookup query at a time, so a manager process should be used to serialize resolver lookup requests." - - <primitive: 'primitiveInitializeNetwork' module: 'SocketPlugin'> - ^ nil "return nil if primitive fails" - ! Item was removed: - ----- Method: NetNameResolver class>>primLocalAddress (in category 'primitives') ----- - primLocalAddress - "Return the local address of this host." - - <primitive: 'primitiveResolverLocalAddress' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: NetNameResolver class>>primNameLookupResult (in category 'primitives') ----- - primNameLookupResult - "Return the host address found by the last host name lookup. Returns nil if the last lookup was unsuccessful." - - <primitive: 'primitiveResolverNameLookupResult' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: NetNameResolver class>>primNameResolverError (in category 'primitives') ----- - primNameResolverError - "Return an integer reflecting the error status of the last network name resolver request. Zero means no error." - - <primitive: 'primitiveResolverError' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: NetNameResolver class>>primNameResolverStatus (in category 'primitives') ----- - primNameResolverStatus - "Return an integer reflecting the status of the network name resolver. For a list of possible values, see the comment in the 'initialize' method of this class." - - <primitive: 'primitiveResolverStatus' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: NetNameResolver class>>primStartLookupOfAddress: (in category 'primitives') ----- - primStartLookupOfAddress: hostAddr - "Look up the given host address in the Domain Name Server to find its name. This call is asynchronous. To get the results, wait for it to complete or time out and then use primAddressLookupResult." - - <primitive: 'primitiveResolverStartAddressLookup' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: NetNameResolver class>>primStartLookupOfName: (in category 'primitives') ----- - primStartLookupOfName: hostName - "Look up the given host name in the Domain Name Server to find its address. This call is asynchronous. To get the results, wait for it to complete or time out and then use primNameLookupResult." - - <primitive: 'primitiveResolverStartNameLookup' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: NetNameResolver class>>promptUserForHostAddress (in category 'lookups') ----- - promptUserForHostAddress - "Ask the user for a host name and return its address." - "NetNameResolver promptUserForHostAddress" - - ^ NetNameResolver promptUserForHostAddressDefault: '' - ! Item was removed: - ----- Method: NetNameResolver class>>promptUserForHostAddressDefault: (in category 'lookups') ----- - promptUserForHostAddressDefault: defaultName - "Ask the user for a host name and return its address. If the default name is the empty string, use the last host name as the default." - "NetNameResolver promptUserForHostAddressDefault: ''" - - | default hostName serverAddr | - defaultName isEmpty - ifTrue: [default := DefaultHostName] - ifFalse: [default := defaultName]. - hostName := UIManager default - request: 'Host name or address?' - initialAnswer: default. - hostName isEmpty ifTrue: [^ 0]. - serverAddr := NetNameResolver addressForName: hostName timeout: 15. - hostName size > 0 ifTrue: [DefaultHostName := hostName]. - ^ serverAddr! Item was removed: - ----- Method: NetNameResolver class>>readDecimalByteFrom: (in category 'private') ----- - readDecimalByteFrom: aStream - "Read a positive, decimal integer from the given stream. Stop when a non-digit or end-of-stream is encountered. Return nil if stream is not positioned at a decimal digit or if the integer value read exceeds 255. - JMM - 000503 fixed didn't work correctly" - - | digitSeen value digit | - digitSeen := false. - value := 0. - [aStream atEnd] whileFalse: - [digit := aStream next digitValue. - (digit < 0 or: [digit > 9]) ifTrue: [ - aStream skip: -1. - (digitSeen not or: [value > 255]) ifTrue: [^ nil]. - ^ value]. - digitSeen := true. - value := (value * 10) + digit]. - (digitSeen not or: [value > 255]) ifTrue: [^ nil]. - ^ value - ! Item was removed: - ----- Method: NetNameResolver class>>resolverError (in category 'lookups') ----- - resolverError - ^self primNameResolverError - ! Item was removed: - ----- Method: NetNameResolver class>>resolverMutex (in category 'private') ----- - resolverMutex - ResolverMutex ifNil: [ResolverMutex := Semaphore forMutualExclusion]. - ^ResolverMutex! Item was removed: - ----- Method: NetNameResolver class>>resolverStatus (in category 'lookups') ----- - resolverStatus - ^self primNameResolverStatus - ! Item was removed: - ----- Method: NetNameResolver class>>startUp: (in category 'system startup') ----- - startUp: resuming - "Set the UseOldNetwork flag if ipv6 primitives are not present or if the EnableIPv6 preference is not set." - - resuming ifTrue: [self initializeOldNetworkFlag]! Item was removed: - ----- Method: NetNameResolver class>>stringFromAddress: (in category 'address string utils') ----- - stringFromAddress: addr - "Return a string representing the given host address as four decimal bytes delimited with decimal points." - "NetNameResolver stringFromAddress: NetNameResolver localHostAddress" - - | s | - (addr isKindOf: SocketAddress) ifTrue: [^addr printString copyUpTo: $( ]. - s := WriteStream on: ''. - 1 to: 3 do: [ :i | (addr at: i) printOn: s. s nextPut: $.]. - (addr at: 4) printOn: s. - ^ s contents - ! Item was removed: - ----- Method: NetNameResolver class>>testIPv6 (in category 'tests') ----- - testIPv6 - "NetNameResolver testIPv6" - | world infos addr sock size host serverSocket listeningSocket clientSocket | - world := Project current world. - world findATranscript: world currentEvent. - Transcript clear. - "Transcript show: Smalltalk listLoadedModules; cr." - self initializeNetwork. - Transcript show: '---- host name ----'; cr. - size := NetNameResolver primHostNameSize. - host := String new: size. - NetNameResolver primHostNameResult: host. - Transcript show: host; cr. - Transcript show: '---- address information ----'; cr. - Transcript show: (infos := SocketAddressInformation - forHost: 'localhost' service: 'echo' flags: 0 - addressFamily: 0 socketType: 0 protocol: 0) printString; cr. - Transcript show: '---- port manipulation ----'; cr. - addr := infos first socketAddress. - Transcript show: addr port printString; cr. - addr port: 1234. - Transcript show: addr port printString; cr. - Transcript show: addr printString; cr. - Transcript show: '---- client socket ----'; cr. - Transcript show: (infos := SocketAddressInformation - forHost: 'localhost' service: 'echo' flags: 0 - addressFamily: 0 - socketType: SocketAddressInformation socketTypeStream - protocol: SocketAddressInformation protocolTCP) printString; cr. - infos do: [:info | - Transcript show: 'Trying ', info printString, '... '. - (sock := info connect) notNil - ifTrue: - [sock sendData: 'hello' count: 5. - Transcript show: sock receiveData printString. - sock close; destroy]. - Transcript cr]. - Transcript show: '---- localhost defaults: loopback and wildcard addresses ----'; cr. - Transcript show: (SocketAddress loopbacks) printString; cr. - Transcript show: (SocketAddress wildcards) printString; cr. - Transcript show: (SocketAddress loopback4) printString; cr. - Transcript show: (SocketAddress wildcard4) printString; cr. - Transcript show: '---- impossible constraints ----'; cr. - Transcript show: (SocketAddressInformation - forHost: 'localhost' service: 'echo' flags: 0 - addressFamily: 0 - socketType: SocketAddressInformation socketTypeDGram - protocol: SocketAddressInformation protocolTCP) printString; cr. - Transcript show: '---- INET4 client-server ----'; cr. - Transcript show: (infos := SocketAddressInformation - forHost: '' service: '4242' - flags: SocketAddressInformation passiveFlag - addressFamily: SocketAddressInformation addressFamilyINET4 - socketType: SocketAddressInformation socketTypeStream - protocol: SocketAddressInformation protocolTCP) printString; cr. - listeningSocket := infos first listenWithBacklog: 5. - Transcript show: (infos := SocketAddressInformation - forHost: 'localhost' service: '4242' - flags: 0 - addressFamily: SocketAddressInformation addressFamilyINET4 - socketType: SocketAddressInformation socketTypeStream - protocol: SocketAddressInformation protocolTCP) printString; cr. - clientSocket := infos first connect. - serverSocket := listeningSocket accept. - serverSocket sendData: 'Hi there!!' count: 9. - Transcript show: clientSocket receiveData; cr. - Transcript nextPutAll: 'client side local/remote: '; - print: clientSocket localSocketAddress; space; - print: clientSocket remoteSocketAddress; cr. - Transcript nextPutAll: 'server side local/remote: '; - print: serverSocket localSocketAddress; space; - print: serverSocket remoteSocketAddress; cr; - endEntry. - clientSocket close; destroy. - serverSocket close; destroy. - listeningSocket close; destroy. - Transcript show: '---- INET6 client-server ----'; cr. - Transcript show: (infos := SocketAddressInformation - forHost: '' service: '4242' - flags: SocketAddressInformation passiveFlag - addressFamily: SocketAddressInformation addressFamilyINET6 - socketType: SocketAddressInformation socketTypeStream - protocol: SocketAddressInformation protocolTCP) printString; cr. - infos isEmpty - ifTrue: [Transcript show: 'FAIL -- CANNOT CREATE INET6 SERVER'; cr] - ifFalse: - [listeningSocket := infos first listenWithBacklog: 5. - Transcript show: (infos := SocketAddressInformation - forHost: 'localhost' service: '4242' - flags: 0 - addressFamily: SocketAddressInformation addressFamilyINET6 - socketType: SocketAddressInformation socketTypeStream - protocol: SocketAddressInformation protocolTCP) printString; cr. - clientSocket := infos first connect. - serverSocket := listeningSocket accept. - serverSocket sendData: 'Hi there!!' count: 9. - Transcript show: clientSocket receiveData; cr. - Transcript nextPutAll: 'client side local/remote: '; - print: clientSocket localSocketAddress; space; - print: clientSocket remoteSocketAddress; cr. - Transcript nextPutAll: 'server side local/remote: '; - print: serverSocket localSocketAddress; space; - print: serverSocket remoteSocketAddress; cr; - endEntry. - clientSocket close; destroy. - serverSocket close; destroy. - listeningSocket close; destroy]. - Transcript show: '---- trivial tests done ---'; cr.! Item was removed: - ----- Method: NetNameResolver class>>testPort80 (in category 'tests') ----- - testPort80 - "NetNameResolver testPort80" - | infos | - Transcript show: (infos := SocketAddressInformation - forHost: 'localhost' service: '80' flags: 0 - addressFamily: 0 socketType: 0 protocol: 0) printString; cr. - Transcript show: (infos := SocketAddressInformation - forHost: '::1' service: '80' flags: 0 - addressFamily: 0 socketType: 0 protocol: 0) printString; cr. - ! Item was removed: - ----- Method: NetNameResolver class>>useOldNetwork (in category 'private') ----- - useOldNetwork - ^UseOldNetwork ~~ false! Item was removed: - ----- Method: NetNameResolver class>>useOldNetwork: (in category 'private') ----- - useOldNetwork: flag - "Unit test support, not intended for public access" - ^UseOldNetwork := flag! Item was removed: - ----- Method: NetNameResolver class>>waitForCompletionUntil: (in category 'private') ----- - waitForCompletionUntil: deadline - "Wait until deadline for the resolver to be ready to accept a new request. - Return true if the resolver is ready, false if the network is not initialized or - the resolver has not become free within the given time period." - - | status millisecondsLeft | - status := self resolverStatus. - [ status = ResolverBusy - and: [millisecondsLeft := (deadline - Time utcMicrosecondClock) // 1000. - millisecondsLeft > 0 ] ] - whileTrue: "wait for resolver to be available" - [ ResolverSemaphore waitTimeoutMSecs: millisecondsLeft. - status := self resolverStatus ]. - status = ResolverReady ifTrue: [ ^true ]. - status = ResolverBusy ifTrue: [ self primAbortLookup ]. - ^false! Item was removed: - ----- Method: NetNameResolver class>>waitForResolverReadyUntil: (in category 'private') ----- - waitForResolverReadyUntil: deadline - "Wait until deadline for the resolver to be ready to accept a new request. Return true if the resolver is not busy, false if the network is not initialized or the resolver has not become free within the given time period." - - | status millisecondsLeft | - (status := self resolverStatus) = ResolverUninitialized ifTrue: [ ^false ]. - [ status = ResolverBusy - and: [millisecondsLeft := (deadline - Time utcMicrosecondClock) // 1000. - millisecondsLeft > 0 ] ] - whileTrue: "wait for resolver to be available" - [ ResolverSemaphore waitTimeoutMSecs: millisecondsLeft. - status := self resolverStatus ]. - ^status ~= ResolverBusy! Item was removed: - Error subclass: #NetworkError - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-Exceptions'! - - !NetworkError commentStamp: 'mir 5/12/2003 18:12' prior: 0! - Abstract super class for all network related exceptions.! Item was removed: - NetworkError subclass: #NoNetworkError - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-Exceptions'! - - !NoNetworkError commentStamp: 'mir 5/12/2003 18:17' prior: 0! - Signals that no network was found. This could happen, e.g., on dial-up connection when no connection was established when Squeak tried to access it. - - ! Item was removed: - URI subclass: #OpaqueURI - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-URI'! Item was removed: - ----- Method: OpaqueURI>>isOpaque (in category 'testing') ----- - isOpaque - ^true! Item was removed: - ProtocolClient subclass: #POP3Client - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-Protocols'! - - !POP3Client commentStamp: 'mir 5/12/2003 17:57' prior: 0! - This class implements POP3 (Post Office Protocol 3) as specified in RFC 1939. (see http://www.ietf.org/rfc.html) - - You can use it to download email from the mail server to your personal mail program. - - To see an example of it's use, see POPSocket class>>example.! Item was removed: - ----- Method: POP3Client class>>defaultPortNumber (in category 'accessing') ----- - defaultPortNumber - ^110! Item was removed: - ----- Method: POP3Client class>>example (in category 'example') ----- - example - "POP3Client example" - "download a user's messages into an OrderedCollection and inspect the OrderedCollection" - - | ps messages userName password | - userName := (UIManager default request: 'POP username'). - password := (UIManager default request: 'POP password'). - ps := POP3Client openOnHostNamed: (UIManager default request: 'POP server'). - [ - ps loginUser: userName password: password. - ps logProgressToTranscript. - - messages := OrderedCollection new. - 1 to: ps messageCount do: [ :messageNr | - messages add: (ps retrieveMessage: messageNr) ]] - ensure: [ps close]. - - messages inspect.! Item was removed: - ----- Method: POP3Client class>>logFlag (in category 'accessing') ----- - logFlag - ^#pop! Item was removed: - ----- 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 | - "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 removed: - ----- Method: POP3Client>>apopLoginUser:password: (in category 'public protocol') ----- - apopLoginUser: userName password: password - - self loginUser: userName password: password loginMethod: #APOP! Item was removed: - ----- Method: POP3Client>>clearTextLogin (in category 'private protocol') ----- - clearTextLogin - - [self sendCommand: 'USER ', self user. - self checkResponse. - self logProgress: self lastResponse. - - self sendCommand: 'PASS ', self password. - self checkResponse. - self logProgress: self lastResponse] - on: TelnetProtocolError - do: [:ex | - "Neither authentication worked. Indicate an error and close up" - self close. - ex resignalAs: ((LoginFailedException protocolInstance: self) signal: 'Login failed.')]! Item was removed: - ----- Method: POP3Client>>deleteMessage: (in category 'public protocol') ----- - deleteMessage: num - "delete the numbered message" - - self ensureConnection. - self sendCommand: 'DELE ', num printString. - self checkResponse. - self logProgress: self lastResponse! Item was removed: - ----- Method: POP3Client>>getMultilineResponse (in category 'private protocol') ----- - getMultilineResponse - "Get a multiple line response to the last command, filtering out LF characters. A multiple line response ends with a line containing only a single period (.) character." - - | response done chunk | - response := WriteStream on: ''. - done := false. - [done] whileFalse: [ - chunk := self stream nextLine. - (chunk beginsWith: '.') - ifTrue: [response nextPutAll: (chunk copyFrom: 2 to: chunk size); cr ] - ifFalse: [response nextPutAll: chunk; cr ]. - done := (chunk = '.') ]. - - ^ response contents - ! Item was removed: - ----- Method: POP3Client>>initiateSession (in category 'private protocol') ----- - initiateSession - - self sendCommand: 'CAPA'. - self checkResponse. - - self parseCapabilities: self getMultilineResponse lines. - - (self tlsIsActive not and: [self serverSupportsStarttls] and: [self wantsStarttls]) - ifTrue: [self starttls]! Item was removed: - ----- Method: POP3Client>>login (in category 'private protocol') ----- - login - - self initiateSession. - self loginMethod - ifNil: [^self]. - self loginMethod == #clearText - ifTrue: [^self clearTextLogin]. - self loginMethod == #APOP - ifTrue: [^self apopLogin]. - (POP3LoginError protocolInstance: self) signal: 'Unsupported login procedure.'! Item was removed: - ----- Method: POP3Client>>loginMethod (in category 'private') ----- - loginMethod - ^self connectionInfo at: #loginMethod ifAbsent: [nil]! Item was removed: - ----- Method: POP3Client>>loginMethod: (in category 'private') ----- - loginMethod: aSymbol - ^self connectionInfo at: #loginMethod put: aSymbol! Item was removed: - ----- Method: POP3Client>>loginUser:password: (in category 'public protocol') ----- - loginUser: userName password: password - - self loginUser: userName password: password loginMethod: #clearText! Item was removed: - ----- Method: POP3Client>>loginUser:password:loginMethod: (in category 'public protocol') ----- - loginUser: userName password: password loginMethod: aLoginMethod - - self user: userName. - self password: password. - self loginMethod: aLoginMethod. - self login! Item was removed: - ----- 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 | - self ensureConnection. - self sendCommand: 'STAT'. - self checkResponse. - self logProgress: self lastResponse. - - [ | answerString | - answerString := (self lastResponse substrings) second. - numMessages := answerString asNumber asInteger] - on: Error - do: [:ex | (ProtocolClientError protocolInstance: self) signal: 'Invalid STAT response.']. - ^numMessages! Item was removed: - ----- Method: POP3Client>>quit (in category 'public protocol') ----- - quit - "QUIT <CRLF>" - - self sendCommand: 'QUIT'. - self checkResponse.! Item was removed: - ----- Method: POP3Client>>responseIsError (in category 'private testing') ----- - responseIsError - ^self lastResponse beginsWith: '-'! Item was removed: - ----- Method: POP3Client>>responseIsSuccess (in category 'private testing') ----- - responseIsSuccess - ^self lastResponse beginsWith: '+'! Item was removed: - ----- Method: POP3Client>>responseIsWarning (in category 'private testing') ----- - responseIsWarning - ^self lastResponse beginsWith: '-'! Item was removed: - ----- Method: POP3Client>>retrieveMessage: (in category 'public protocol') ----- - retrieveMessage: number - "retrieve the numbered message" - - self ensureConnection. - self sendCommand: 'RETR ', number printString. - self checkResponse. - self logProgress: self lastResponse. - - ^self getMultilineResponse! Item was removed: - ----- Method: POP3Client>>starttlsVerb (in category 'private') ----- - starttlsVerb - - ^ #STLS! Item was removed: - ----- Method: POP3Client>>wantsStarttls (in category 'private') ----- - wantsStarttls - - ^ true! Item was removed: - ProtocolClientError subclass: #POP3LoginError - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-Protocols'! - - !POP3LoginError commentStamp: 'mir 5/12/2003 17:58' prior: 0! - Exception for signaling POP3 login failures.! Item was removed: - Object subclass: #PRServerDirectory - instanceVariableNames: 'server directories' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-RemoteDirectory'! - - !PRServerDirectory commentStamp: 'md 1/26/2004 12:40' prior: 0! - Add support to publish or download projects from Small-Land Project - Repository (SLPR). - - The SLPR has virtual folders where the projects appears. The SLPR can - be acceded from the FileList or from the web interface at - http://repository.small-land.org:8080 - - Basically it's a type of superswiki (but better ;)). - - The features in SMPR not present in SuperSwiki are: - - - Both the web interface and the squeak-side interface are full - translatable. The server has translations for English and Spanish just - now, but it's almost trivial to include other translations... Stef? - Marcus? ;) - - - The projects are categorized in "virtual" folder. These folders (By - Category, By Author, By Language, Alphabetical, etc) give us good - searching behaviour just using the FileList and mouse clicks. - - - The web interface (also full translatable) has a search a la google. - - - All the urls to query the web interface are "clean enough" so google - can make a good job indexing our content in .pr files. - - - It's planned to add "editing" features to the web interface to - re-categorize, remove, etc projects. - - - Enjoy it, - - -- - Diego Gomez Deck - http://www.small-land.org! Item was removed: - ----- Method: PRServerDirectory class>>fullPath: (in category 'instance creation') ----- - fullPath: fullNameString - "answer an instance of the receiver on fullName" - | pathParts | - pathParts := self pathParts: fullNameString. - ^ self server: pathParts first directories: pathParts allButFirst! Item was removed: - ----- Method: PRServerDirectory class>>pathParts: (in category 'instance creation') ----- - pathParts: fullName - "private - parse fullName in server and directory" - | url slashPos server directory | - url := fullName. - (url beginsWith: 'http://') - ifTrue: [url := url allButFirst: 7]. - url last = $/ - ifTrue: [url := url allButLast]. - "" - slashPos := url indexOf: $/. - slashPos isZero - ifTrue: [^ {'http://' , url}]. - "" - server := url first: slashPos - 1. - directory := url allButFirst: slashPos. - "" - ^ {'http://' , server. directory}! Item was removed: - ----- Method: PRServerDirectory class>>server: (in category 'instance creation') ----- - server: serverString - "answer a new instance of the receiver on server aString" - ^ self server: serverString directories: #()! Item was removed: - ----- Method: PRServerDirectory class>>server:directories: (in category 'instance creation') ----- - server: serverString directories: aCollection - "answer a new instance of the receiver on server aString" - ^ self new initializeServer: serverString directories: aCollection! Item was removed: - ----- Method: PRServerDirectory class>>server:directory: (in category 'instance creation') ----- - server: serverString directory: directoryString - "answer a new instance of the receiver on server aString" - ^ self new - initializeServer: serverString - directories: (directoryString findTokens: '/')! Item was removed: - ----- Method: PRServerDirectory>>acceptsUploads (in category 'testing') ----- - acceptsUploads - "answer whatever the receiver accepts uploads" - ^ true! Item was removed: - ----- Method: PRServerDirectory>>createDirectory: (in category 'file directory') ----- - createDirectory: localName - "Create a new sub directory within the current one" - ^ self inform: 'operation not supported' translated! Item was removed: - ----- Method: PRServerDirectory>>deleteFileNamed: (in category 'file directory') ----- - deleteFileNamed: localFileName - "Delete the file with the given name in this directory." - ^ self inform: 'operation not supported' translated! Item was removed: - ----- Method: PRServerDirectory>>directories (in category 'accessing') ----- - directories - "answer the receiver's directories" - ^ directories! Item was removed: - ----- Method: PRServerDirectory>>directory (in category 'accessing') ----- - directory - "answer the receiver's directory" - | result | - result := String new writeStream. - self directories - do: [:each | result nextPutAll: each] - separatedBy: [result nextPutAll: self slash]. - ^ result contents! Item was removed: - ----- Method: PRServerDirectory>>directoryNamed: (in category 'file directory') ----- - directoryNamed: aString - "Return the subdirectory of this directory with the given name." - ^ self class server: self server directory: self directory , self slash, aString! Item was removed: - ----- Method: PRServerDirectory>>directoryNames (in category 'file directory') ----- - directoryNames - "Return a collection of names for the subdirectories of this - directory. " - ^ self entries - select: [:entry | entry isDirectory] - thenCollect: [:entry | entry name]! Item was removed: - ----- Method: PRServerDirectory>>directoryWrapperClass (in category 'accessing') ----- - directoryWrapperClass - "answer the class to be used as a wrapper in FileList2" - ^ FileDirectoryWrapper! Item was removed: - ----- Method: PRServerDirectory>>downloadUrl (in category 'accessing') ----- - downloadUrl - "The url under which files will be accessible." - ^ (self urlFromServer: self server directories: {'programmatic'}) - , self slash! Item was removed: - ----- Method: PRServerDirectory>>entries (in category 'file directory') ----- - entries - "Return a collection of directory entries for the files and - directories in this directory." - | lines | - lines := self getLines. - ^ lines isNil - ifTrue: [#()] ifFalse:[ - - self parseLines: lines]! Item was removed: - ----- Method: PRServerDirectory>>fileNames (in category 'file directory') ----- - fileNames - "Return a collection of names for the files (but not directories) in this directory." - ^ self entries - select: [:entry | entry isDirectory not] - thenCollect: [:entry | entry name]! Item was removed: - ----- Method: PRServerDirectory>>fullNameFor: (in category 'file directory') ----- - fullNameFor: aString - "Return a corrected, fully-qualified name for the given file name." - ^ self urlFromServer: self server directories: self directories , {aString}! Item was removed: - ----- Method: PRServerDirectory>>getFullProjectContents: (in category 'private') ----- - getFullProjectContents: aString - "private - get the project content from the server" - ^ self getOnly: nil ofProjectContents: aString! Item was removed: - ----- Method: PRServerDirectory>>getLines (in category 'private') ----- - getLines - "private - answer a collection of lines with the server response" - | url lines string | - url := self urlFromServer: self server directories: {'programmatic'} , self directories. - url := url , self slash. - string := Cursor read - showWhile: [(HTTPSocket httpGetDocument: url) contents]. - (string beginsWith: '--OK--') - ifFalse: [^ nil]. - lines := OrderedCollection new. - (string allButFirst: 6) - linesDo: [:line | lines add: line]. - - ^ lines! Item was removed: - ----- Method: PRServerDirectory>>getOnly:from: (in category 'file directory') ----- - getOnly: numberOfBytes from: fileNameOnServer - "Just capture the first numberOfBytes of the file. - - Goes faster for long files. Return the contents, not a stream." - | fileName | - self flag: #todo. - "use LRUCache" - fileName := fileNameOnServer - allButFirst: (fileNameOnServer lastIndexOf: self pathNameDelimiter). - "" - ^ self getOnly: numberOfBytes ofProjectContents: fileName! Item was removed: - ----- Method: PRServerDirectory>>getOnly:ofProjectContents: (in category 'private') ----- - getOnly: numberOfBytes ofProjectContents: aString - "private - get numberOfBytes of the project contents" - | url args contents | - self flag: #todo. - "use an LRUCache" - url := self urlFromServer: self server directories: {'programmatic'. aString}. - "" - args := numberOfBytes isNil - ifFalse: ['numberOfBytes=' , numberOfBytes asString]. - "" - contents := Cursor read showWhile: [ - (HTTPSocket httpGetDocument: url args: args) contents]. - "" - (contents beginsWith: '--OK--') - ifFalse: [^ nil]. - "" - ^ contents allButFirst: 6! Item was removed: - ----- Method: PRServerDirectory>>getPostArgsFromProject:fileNamed:fromDirectory: (in category 'private') ----- - getPostArgsFromProject: aProject fileNamed: fileNameString fromDirectory: localDirectory - | args thumbnail uploader | - args := Dictionary new. - - "args at: 'contents' put: {(localDirectory oldFileNamed: fileNameString) contentsOfEntireFile}." - args at: 'contents' put: {(StandardFileStream - readOnlyFileNamed: (localDirectory fullNameFor: fileNameString)) contentsOfEntireFile}. - - args at: 'name' put: {aProject name}. - args at: 'version' put: {(Project parseProjectFileName: fileNameString) second asString}. - args at: 'language' put: {aProject naturalLanguage asString}. - - uploader := Utilities authorNamePerSe. - uploader isEmptyOrNil - ifTrue: [uploader := Utilities authorInitialsPerSe]. - uploader isEmptyOrNil - ifFalse: [args at: 'uploader' put: {uploader}]. - - self putSmalltalkInfoInto: args. - - thumbnail := self getProjectThumbnail: aProject. - thumbnail isNil - ifFalse: [args at: 'thumbnailcontents' put: {thumbnail}]. - - self putProjectDetailsFrom: aProject to: args. - - ^ args! Item was removed: - ----- Method: PRServerDirectory>>getPostArgsFromThingsToSearchFor: (in category 'private') ----- - getPostArgsFromThingsToSearchFor: thingsToSearchForCollection - | args | - args := Dictionary new. - "" - thingsToSearchForCollection - do: [:each | - | pos | - pos := each indexOf: $:. - pos isZero - ifFalse: [| key value | - key := (each first: pos - 1) withBlanksTrimmed. - value := (each allButFirst: pos) withBlanksTrimmed. - (value beginsWith: '*') - ifTrue: [value := value allButFirst]. - (value endsWith: '*') - ifTrue: [value := value allButLast]. - "" - args at: key put: {value}]]. - "" - ^ args! Item was removed: - ----- Method: PRServerDirectory>>getProjectThumbnail: (in category 'private') ----- - getProjectThumbnail: aProject - "private - answer a stream with the aProject's thumbnail or nil if none" - | form stream | - form := aProject thumbnail. - form isNil - ifTrue: [^ nil]. - "" - form unhibernate. - form := form colorReduced. - "" - self flag: #todo. - "use a better image format than GIF" - stream := ByteArray new writeStream. - GIFReadWriter putForm: form onStream: stream. - "" - ^ stream contents asString! Item was removed: - ----- Method: PRServerDirectory>>initializeServer:directories: (in category 'initialization') ----- - initializeServer: serverString directories: directoriesCollection - "initialize the receiver's server and directories" - server := serverString withBlanksTrimmed. - server last = self pathNameDelimiter - ifTrue: [server := server allButLast withBlanksTrimmed]. - "" - directories := directoriesCollection! Item was removed: - ----- Method: PRServerDirectory>>isProjectSwiki (in category 'testing') ----- - isProjectSwiki - "answer whatever the receiver is a project swiki" - ^ true! Item was removed: - ----- Method: PRServerDirectory>>isRemoteDirectory (in category 'testing') ----- - isRemoteDirectory - "answer whatever the receiver is a remote directory" - ^ true! Item was removed: - ----- Method: PRServerDirectory>>isSearchable (in category 'testing') ----- - isSearchable - "answer whatever the receiver is searchable" - ^ true! Item was removed: - ----- Method: PRServerDirectory>>moniker (in category 'accessing') ----- - moniker - "a plain language name for this directory" - ^ self server! Item was removed: - ----- Method: PRServerDirectory>>oldFileNamed: (in category 'file directory') ----- - oldFileNamed: aName "Open the existing file with the given name in this directory." - ^ self oldFileOrNoneNamed: aName! Item was removed: - ----- Method: PRServerDirectory>>oldFileOrNoneNamed: (in category 'file directory') ----- - oldFileOrNoneNamed: fullName - "If the file exists, answer a read-only FileStream on it. If it - doesn't, answer nil." - | fileName contents | - fileName := fullName - allButFirst: (fullName lastIndexOf: self pathNameDelimiter). - "" - contents := self getFullProjectContents: fileName. - contents isNil - ifTrue: [^ nil]. - "" - ^ (SwikiPseudoFileStream with: contents) directory: self; - localName: fileName; - reset; - yourself! Item was removed: - ----- Method: PRServerDirectory>>on: (in category 'file directory') ----- - on: fullName - "Answer another ServerDirectory on the partial path name. - fullName is directory path, and does include the name of the - server." - ^ self class fullPath: fullName! Item was removed: - ----- Method: PRServerDirectory>>parseLine: (in category 'private') ----- - parseLine: aString - "private - parse a line from a server response" - | tokens | - tokens := aString findTokens: '|'. - "" - ^ tokens first = 'D' - ifTrue: - [ DirectoryEntryDirectory - directory: self - name: tokens second - creationTime: 0 - modificationTime: 0 - fileSize: 0 ] - ifFalse: - [ DirectoryEntryFile - directory: self - name: tokens second - creationTime: tokens third asInteger - modificationTime: tokens fourth asInteger - fileSize: tokens fifth asInteger ]! Item was removed: - ----- Method: PRServerDirectory>>parseLines: (in category 'private') ----- - parseLines: aCollection - "private - parse aCollection of lines from a server response" - ^ aCollection - collect: [:each | self parseLine: each]! Item was removed: - ----- Method: PRServerDirectory>>pathName (in category 'file directory') ----- - pathName"Path name as used in reading the file. " - ^ self urlFromServer: self server directories: self directories! Item was removed: - ----- Method: PRServerDirectory>>pathNameDelimiter (in category 'path access') ----- - pathNameDelimiter"Return the delimiter character for this kind of directory." - ^ $/! Item was removed: - ----- Method: PRServerDirectory>>pathParts (in category 'file directory') ----- - pathParts - "Return the path from the root of the file system to this - directory as an array of directory names. On a remote server." - ^ (OrderedCollection with: self server) addAll: self directories; - yourself! Item was removed: - ----- Method: PRServerDirectory>>putProjectDetailsFrom:to: (in category 'private') ----- - putProjectDetailsFrom: aProject to: args - | projectDetails | - projectDetails := aProject world - valueOfProperty: #ProjectDetails - ifAbsent: [^ self]. - "" - self flag: #todo. - "projectname ?" - projectDetails - at: 'projectdescription' - ifPresent: [:value | args at: 'description' put: {value}]. - projectDetails - at: 'projectauthor' - ifPresent: [:value | args at: 'author' put: {value}]. - projectDetails - at: 'projectcategory' - ifPresent: [:value | args at: 'category' put: {value}]. - projectDetails - at: 'projectsubcategory' - ifPresent: [:value | args at: 'subcategory' put: {value}]. - projectDetails - at: 'projectkeywords' - ifPresent: [:value | args at: 'keywords' put: {value}]! Item was removed: - ----- Method: PRServerDirectory>>putSmalltalkInfoInto: (in category 'private') ----- - putSmalltalkInfoInto: args - "private - fills args with information from Smalltalk" - self flag: #todo. - " - lastest small-land changeset / small-land version - " - #(#datedVersion #osVersion #platformName #platformSubtype #vmPath #vmVersion #imageName #changesName #sourcesName #listBuiltinModules #listLoadedModules #getVMParameters ) - do: [:each | - | value | - value := Smalltalk perform: each. - args at: 'extra-' , each asString put: {value asString}]! Item was removed: - ----- Method: PRServerDirectory>>queryProjectsAndShow: (in category 'testing') ----- - queryProjectsAndShow: thingsToSearchForCollection - "query the server for all the projects that match - thingsToSearchForCollection" - | url arguments string | - url := self urlFromServer: self server directories: {'programmatic'. 'queryprojects'}. - arguments := self getPostArgsFromThingsToSearchFor: thingsToSearchForCollection. - "" - string := Cursor read showWhile: [ - "(HTTPClient httpPostDocument: url args: args) contents." - (HTTPSocket httpGetDocument: url args: arguments) contents]. - (string beginsWith: '--OK--') - ifTrue: [^ true]. - "" - self - inform: ('Server responded: {1}' translated format: {string}). - ^ false! Item was removed: - ----- Method: PRServerDirectory>>readOnlyFileNamed: (in category 'file directory') ----- - readOnlyFileNamed: aName - "Open the existing file with the given name in this directory for read-only access." - ^ self oldFileNamed: aName! Item was removed: - ----- Method: PRServerDirectory>>realUrl (in category 'accessing') ----- - realUrl - "a fully expanded version of the url we represent." - ^self urlFromServer: self server directories: self directories! Item was removed: - ----- Method: PRServerDirectory>>rename:toBe: (in category 'file directory') ----- - rename: fullName toBe: newName - "Rename a remote file. fullName is just be a fileName, or can - be directory path that includes name of the server. newName - is just a fileName" - ^ self inform: 'operation not supported' translated! Item was removed: - ----- Method: PRServerDirectory>>server (in category 'accessing') ----- - server - "answer the receiver's server" - ^ server! Item was removed: - ----- Method: PRServerDirectory>>slash (in category 'path access') ----- - slash - "answer the recevier 'slash'" - ^ self pathNameDelimiter asString! Item was removed: - ----- Method: PRServerDirectory>>sleep (in category 'file directory') ----- - sleep"Leave the FileList window. Do nothing. " - ^ self! Item was removed: - ----- Method: PRServerDirectory>>urlFromServer:directories: (in category 'private') ----- - urlFromServer: serverString directories: aCollection - "private - builds an url for server/directories" - | result | - result := String new writeStream. - "" - {serverString} , aCollection - do: [:each | "" - result - nextPutAll: (each copyReplaceAll: ' ' with: '+')] - separatedBy: [result nextPutAll: self slash]. - "" - ^ result contents! Item was removed: - ----- Method: PRServerDirectory>>wakeUp (in category 'file directory') ----- - wakeUp"Entering a FileList window. Do nothing." - ^ self! Item was removed: - ----- 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 := self urlFromServer: self server directories: {'programmatic'. 'uploadproject'}. - arguments := self - getPostArgsFromProject: aProject - fileNamed: fileNameString - fromDirectory: localDirectory. - - string := Cursor read showWhile: [ - (HTTPSocket httpPostDocument: url args: arguments) contents]. - (string beginsWith: '--OK--') - ifTrue: [^ true]. - - self inform: ('Server responded: {1}' translated format: {string}). - ^ false! Item was removed: - Object subclass: #Password - instanceVariableNames: 'cache' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-Kernel'! - - !Password commentStamp: 'cbc 6/7/2019 11:19' prior: 0! - "Hold a password in memory during a run of the app. - - After each save (after each startup), when an applicaiton asks for a password, one of two things will happen: - 1> the user will be prompted for the password - 2> If the user was previously prompted, return that password - - Passwords are stored encoded. - At shutDown, passwords are cleared (will not be written to disc). - - The intent for this class is to avoid storing passwords in code or on files on the system. Instead, prompt the user during the running of the application."! Item was removed: - ----- Method: Password class>>shutDown (in category 'system startup') ----- - shutDown - "Forget all cached passwords, so they won't stay in the image" - - self allSubInstancesDo: [:each | each cache: nil].! Item was removed: - ----- Method: Password>>cache: (in category 'accessing') ----- - cache: anObject - "if anObject is nil, then clear out cache - don't store values to disc" - anObject ifNil: [^cache := nil]. - "Otherwise, 'encode' (trivially) the password while it resides in memory - no plain text" - cache := self decode: anObject! Item was removed: - ----- Method: Password>>decode: (in category 'private') ----- - decode: string - "Xor with secret number -- just so file won't have raw password in it" - | kk rand | - rand := Random new seed: 234237. - kk := (ByteArray new: string size) collect: [:bb | (rand next * 255) asInteger]. - 1 to: kk size do: [:ii | - kk at: ii put: ((kk at: ii) bitXor: (string at: ii) asciiValue)]. - ^ kk asString! Item was removed: - ----- Method: Password>>passwordForMessage: (in category 'accessing') ----- - passwordForMessage: msg - cache ifNotNil: [^self decode: cache]. "Our stored value is encoded" - ^self decode: (cache := self decode: (UIManager default requestPassword: 'Password for ', msg, ':')).! Item was removed: - ServerDirectory subclass: #ProjectSwikiServer - instanceVariableNames: 'acceptsUploads' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-RemoteDirectory'! Item was removed: - ----- Method: ProjectSwikiServer>>acceptsUploads (in category 'testing') ----- - acceptsUploads - ^acceptsUploads == true! Item was removed: - ----- Method: ProjectSwikiServer>>acceptsUploads: (in category 'accessing') ----- - acceptsUploads: aBoolean - acceptsUploads := aBoolean! Item was removed: - ----- Method: ProjectSwikiServer>>isProjectSwiki (in category 'testing') ----- - isProjectSwiki - ^true! Item was removed: - ----- Method: ProjectSwikiServer>>wakeUp (in category 'initialize') ----- - wakeUp! Item was removed: - Object subclass: #ProtocolClient - instanceVariableNames: 'stream connectInfo serverCapabilities lastResponse pendingResponses progressObservers' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-Protocols'! - - !ProtocolClient commentStamp: 'gk 12/13/2005 00:34' prior: 0! - ProtocolClient is the abstract super class for a variety of network protocol clients. - It uses a stream rather than the direct network access so it could also work for streams on serial connections etc. - - Structure: - stream stream representing the connection to and from the server - connectInfo information required for opening a connection - lastResponse remembers the last response from the server. - progressObservers any object understanding #show: can be registered as a progress observer (login, transfer, etc)! Item was removed: - ----- Method: ProtocolClient class>>defaultPortNumber (in category 'accessing') ----- - defaultPortNumber - self subclassResponsibility! Item was removed: - ----- Method: ProtocolClient class>>logFlag (in category 'accessing') ----- - logFlag - self subclassResponsibility! Item was removed: - ----- Method: ProtocolClient class>>openOnHost:port: (in category 'instance creation') ----- - openOnHost: hostIP port: portNumber - ^self new openOnHost: hostIP port: portNumber! Item was removed: - ----- Method: ProtocolClient class>>openOnHostNamed: (in category 'instance creation') ----- - openOnHostNamed: hostNameAndPort - "If the hostname uses the colon syntax to express a certain port number we use that instead of the default port number." - - ^self new openOnHostNamed: hostNameAndPort - ! Item was removed: - ----- Method: ProtocolClient class>>openOnHostNamed:port: (in category 'instance creation') ----- - openOnHostNamed: hostName port: portNumber - - ^ self new openOnHostNamed: hostName port: portNumber! Item was removed: - ----- Method: ProtocolClient class>>retrieveMIMEDocument: (in category 'retrieval') ----- - retrieveMIMEDocument: aURI - self subclassResponsibility! Item was removed: - ----- Method: ProtocolClient>>checkForPendingError (in category 'private protocol') ----- - checkForPendingError - "If data is waiting, check it to catch any error reports. - In case the response is not an error, push it back." - - self stream isDataAvailable - ifFalse: [^self]. - self fetchNextResponse. - self - checkResponse: self lastResponse - onError: [:response | (TelnetProtocolError protocolInstance: self) signal] - onWarning: [:response | (TelnetProtocolError protocolInstance: self) signal]. - "if we get here, it wasn't an error" - self pushResponse: self lastResponse! Item was removed: - ----- Method: ProtocolClient>>checkResponse (in category 'private protocol') ----- - checkResponse - "Get the response from the server and check for errors." - - self - checkResponseOnError: [:response | (TelnetProtocolError protocolInstance: self) signal] - onWarning: [:response | (TelnetProtocolError protocolInstance: self) signal]. - ! Item was removed: - ----- Method: ProtocolClient>>checkResponse:onError:onWarning: (in category 'private protocol') ----- - checkResponse: aResponse onError: errorBlock onWarning: warningBlock - "Get the response from the server and check for errors. Invoke one of the blocks if an error or warning is encountered. See class comment for classification of error codes." - - self responseIsError - ifTrue: [errorBlock value: aResponse]. - self responseIsWarning - ifTrue: [warningBlock value: aResponse]. - ! Item was removed: - ----- Method: ProtocolClient>>checkResponseOnError:onWarning: (in category 'private protocol') ----- - checkResponseOnError: errorBlock onWarning: warningBlock - "Get the response from the server and check for errors. Invoke one of the blocks if an error or warning is encountered. See class comment for classification of error codes." - - self fetchPendingResponse. - self checkResponse: self lastResponse onError: errorBlock onWarning: warningBlock! Item was removed: - ----- Method: ProtocolClient>>close (in category 'actions') ----- - close - self stream - ifNotNil: [ - self stream close. - stream := nil]! Item was removed: - ----- Method: ProtocolClient>>connectionInfo (in category 'private') ----- - connectionInfo - connectInfo ifNil: [connectInfo := Dictionary new]. - ^connectInfo! Item was removed: - ----- Method: ProtocolClient>>defaultPortNumber (in category 'private') ----- - defaultPortNumber - ^self class defaultPortNumber! Item was removed: - ----- Method: ProtocolClient>>ensureConnection (in category 'private') ----- - ensureConnection - self isConnected - ifTrue: [^self]. - self stream - ifNotNil: [self stream close]. - - self stream: (SocketStream openConnectionToHost: self host port: self port). - self checkResponse. - self login! Item was removed: - ----- Method: ProtocolClient>>fetchNextResponse (in category 'private protocol') ----- - fetchNextResponse - self lastResponse: self stream nextLine! Item was removed: - ----- Method: ProtocolClient>>fetchPendingResponse (in category 'private protocol') ----- - fetchPendingResponse - ^pendingResponses - ifNil: [self fetchNextResponse; lastResponse] - ifNotNil: [self popResponse]! Item was removed: - ----- Method: ProtocolClient>>host (in category 'private') ----- - host - ^self connectionInfo at: #host! Item was removed: - ----- Method: ProtocolClient>>host: (in category 'private') ----- - host: hostId - ^self connectionInfo at: #host put: hostId! Item was removed: - ----- Method: ProtocolClient>>hostName (in category 'private') ----- - hostName - - ^ self connectionInfo at: #hostName ifAbsent: [NetNameResolver nameForAddress: self host]! Item was removed: - ----- Method: ProtocolClient>>hostName: (in category 'private') ----- - hostName: aString - - ^ self connectionInfo at: #hostName put: aString! Item was removed: - ----- Method: ProtocolClient>>isConnected (in category 'testing') ----- - isConnected - ^stream notNil - and: [stream isConnected]! Item was removed: - ----- Method: ProtocolClient>>lastResponse (in category 'private') ----- - lastResponse - ^lastResponse! Item was removed: - ----- Method: ProtocolClient>>lastResponse: (in category 'private') ----- - lastResponse: aString - lastResponse := aString. - ! Item was removed: - ----- Method: ProtocolClient>>logFlag (in category 'private') ----- - logFlag - ^self class logFlag! Item was removed: - ----- Method: ProtocolClient>>logProgress: (in category 'private') ----- - logProgress: aString - self progressObservers do: [:each | each show: aString]. - ! Item was removed: - ----- Method: ProtocolClient>>logProgressToTranscript (in category 'accessing') ----- - logProgressToTranscript - self progressObservers add: Transcript! Item was removed: - ----- Method: ProtocolClient>>messageText (in category 'accessing') ----- - messageText - ^super messageText - ifNil: [self response]! Item was removed: - ----- Method: ProtocolClient>>openOnHost:port: (in category 'private') ----- - openOnHost: hostIP port: portNumber - "open a connection to a specific port on a host for which we have the IP number. - We handle any login if the user and password are set" - self host: hostIP. - self port: portNumber. - self ensureConnection! Item was removed: - ----- Method: ProtocolClient>>openOnHostNamed: (in category 'private') ----- - openOnHostNamed: hostNameAndPort - "If the hostname uses the colon syntax to express a certain port number - we use that instead of the default port number." - - | thing hostName port | - "derive a host name and port number" - thing := hostNameAndPort splitBy: ':'. - hostName := thing first. - port := (thing at: 2 ifAbsent: [self defaultPortNumber]) asInteger. - - ^self openOnHostNamed: hostName port: port - ! Item was removed: - ----- Method: ProtocolClient>>openOnHostNamed:port: (in category 'private') ----- - openOnHostNamed: hostName port: portNumber - "open a connection to a specific port on a server" - | serverIP | - serverIP := NetNameResolver addressForName: hostName timeout: 20. - self - hostName: hostName; - openOnHost: serverIP port: portNumber! Item was removed: - ----- Method: ProtocolClient>>parseCapabilities: (in category 'private') ----- - parseCapabilities: lines - - self serverCapabilities addAll: (lines select: [:l | l notEmpty] - thenCollect: [:l | | tokens capability values | - tokens := l findTokens: String space. - capability := tokens first asSymbol. - values := tokens allButFirst - ifEmpty: [true] - ifNotEmpty: [:rawValues | rawValues collect: [:v | - v isAllDigits - ifTrue: [v asNumber] - ifFalse: [v asSymbol]]]. - capability -> values])! Item was removed: - ----- Method: ProtocolClient>>password (in category 'private') ----- - password - ^self connectionInfo at: #password! Item was removed: - ----- Method: ProtocolClient>>password: (in category 'private') ----- - password: aString - ^self connectionInfo at: #password put: aString! Item was removed: - ----- Method: ProtocolClient>>pendingResponses (in category 'private') ----- - pendingResponses - pendingResponses ifNil: [pendingResponses := OrderedCollection new]. - ^pendingResponses! Item was removed: - ----- Method: ProtocolClient>>popResponse (in category 'private') ----- - popResponse - | pendingResponse | - pendingResponse := self pendingResponses removeFirst. - pendingResponses isEmpty - ifTrue: [pendingResponses := nil]. - ^pendingResponse! Item was removed: - ----- Method: ProtocolClient>>port (in category 'private') ----- - port - ^self connectionInfo at: #port! Item was removed: - ----- Method: ProtocolClient>>port: (in category 'private') ----- - port: aPortNumber - ^self connectionInfo at: #port put: aPortNumber! Item was removed: - ----- Method: ProtocolClient>>progressObservers (in category 'private') ----- - progressObservers - progressObservers ifNil: [progressObservers := OrderedCollection new]. - ^progressObservers! Item was removed: - ----- Method: ProtocolClient>>pushResponse: (in category 'private') ----- - pushResponse: aResponse - self pendingResponses add: aResponse! Item was removed: - ----- Method: ProtocolClient>>reopen (in category 'actions') ----- - reopen - self ensureConnection! Item was removed: - ----- Method: ProtocolClient>>resetConnectionInfo (in category 'private') ----- - resetConnectionInfo - connectInfo := nil! Item was removed: - ----- Method: ProtocolClient>>response (in category 'accessing') ----- - response - ^self protocolInstance lastResponse! Item was removed: - ----- Method: ProtocolClient>>responseIsError (in category 'private testing') ----- - responseIsError - self subclassResponsibility! Item was removed: - ----- Method: ProtocolClient>>responseIsSuccess (in category 'private protocol') ----- - responseIsSuccess - - ^ self responseCode = 220! Item was removed: - ----- Method: ProtocolClient>>responseIsWarning (in category 'private testing') ----- - responseIsWarning - self subclassResponsibility! Item was removed: - ----- Method: ProtocolClient>>sendCommand: (in category 'private protocol') ----- - sendCommand: aString - self stream sendCommand: aString. - ! Item was removed: - ----- Method: ProtocolClient>>sendStreamContents: (in category 'private protocol') ----- - sendStreamContents: aStream - self stream sendStreamContents: aStream! Item was removed: - ----- Method: ProtocolClient>>serverCapabilities (in category 'private') ----- - serverCapabilities - serverCapabilities ifNil: [serverCapabilities := Dictionary new]. - ^serverCapabilities! Item was removed: - ----- Method: ProtocolClient>>serverSupportsStarttls (in category 'testing') ----- - serverSupportsStarttls - - ^ self serverCapabilities at: self starttlsVerb ifAbsent: [false]! Item was removed: - ----- Method: ProtocolClient>>standardTimeout (in category 'private') ----- - standardTimeout - - ^ Socket standardTimeout! Item was removed: - ----- Method: ProtocolClient>>starttls (in category 'private protocol') ----- - starttls - Smalltalk at: #SqueakSSL ifAbsent:[self error: 'SqueakSSL is missing']. - - self sendCommand: self starttlsVerb. - self checkResponse. - self responseIsSuccess ifTrue: [ - stream := SqueakSSL secureSocketStream on: stream socket. - stream sslConnectTo: self hostName. - self connectionInfo at: #tlsActive put: true].! Item was removed: - ----- Method: ProtocolClient>>starttlsVerb (in category 'private') ----- - starttlsVerb - - ^ #STARTTLS! Item was removed: - ----- Method: ProtocolClient>>stream (in category 'accessing') ----- - stream - ^stream! Item was removed: - ----- Method: ProtocolClient>>stream: (in category 'accessing') ----- - stream: aStream - stream := aStream! Item was removed: - ----- Method: ProtocolClient>>tlsIsActive (in category 'testing') ----- - tlsIsActive - - ^ self connectionInfo at: #tlsActive ifAbsent: [false]! Item was removed: - ----- Method: ProtocolClient>>user (in category 'private') ----- - user - ^self connectionInfo at: #user ifAbsent: [nil]! Item was removed: - ----- Method: ProtocolClient>>user: (in category 'private') ----- - user: aString - ^self connectionInfo at: #user put: aString! Item was removed: - ----- Method: ProtocolClient>>wantsStarttls (in category 'private testing') ----- - wantsStarttls - - ^ self serverSupportsStarttls! Item was removed: - Error subclass: #ProtocolClientError - instanceVariableNames: 'protocolInstance' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-Protocols'! - - !ProtocolClientError commentStamp: 'mir 5/12/2003 18:05' prior: 0! - Abstract super class for protocol clients - - protocolInstance reference to the protocol client throughing the exception. Exception handlers can access the client in order close, respond or whatever may be appropriate - ! Item was removed: - ----- Method: ProtocolClientError class>>protocolInstance: (in category 'instance creation') ----- - protocolInstance: aProtocolInstance - ^self new protocolInstance: aProtocolInstance! Item was removed: - ----- Method: ProtocolClientError>>messageText (in category 'accessing') ----- - messageText - ^super messageText - ifNil: [self response]! Item was removed: - ----- Method: ProtocolClientError>>protocolInstance (in category 'accessing') ----- - protocolInstance - ^protocolInstance! Item was removed: - ----- Method: ProtocolClientError>>protocolInstance: (in category 'accessing') ----- - protocolInstance: aProtocolInstance - protocolInstance := aProtocolInstance! Item was removed: - ----- Method: ProtocolClientError>>response (in category 'accessing') ----- - response - ^self protocolInstance lastResponse! Item was removed: - RWBinaryOrTextStream subclass: #RemoteFileStream - instanceVariableNames: 'remoteFile localDataValid' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-RemoteDirectory'! - - !RemoteFileStream commentStamp: '<historical>' prior: 0! - An in-memory stream that can be used to fileIn code from the network. Knows its ServerFile, and thus its name, path, etc. - - localDataValid -- false when have never read the file from the server. Set to true after reading, when my contents has the true data. When creating a remote file, set localDataValid to true so it will write to server.! Item was removed: - ----- Method: RemoteFileStream>>close (in category 'file status') ----- - close - "Write if we have data to write. FTP files are always binary to preserve the data exactly. The binary/text (ascii) flag is just for tell how the bits are delivered from a read." - - remoteFile writable ifTrue: [ - remoteFile putFile: (self as: RWBinaryOrTextStream) reset named: remoteFile fileName]! Item was removed: - ----- Method: RemoteFileStream>>contentsOfEntireFile (in category 'accessing') ----- - contentsOfEntireFile - "Fetch the data off the server and store it in me. But not if I already have it." - - readLimit := readLimit max: position. - localDataValid ifTrue: [^ super contentsOfEntireFile]. - collection size = 0 ifTrue: [self on: (String new: 2000)]. - remoteFile getFileNamed: remoteFile fileName into: self. "sets localDataValid := true" - ^ super contentsOfEntireFile! Item was removed: - ----- Method: RemoteFileStream>>dataIsValid (in category 'accessing') ----- - dataIsValid - - localDataValid := true.! Item was removed: - ----- Method: RemoteFileStream>>directory (in category 'accessing') ----- - directory - ^ remoteFile! Item was removed: - ----- Method: RemoteFileStream>>directoryUrl (in category 'accessing') ----- - directoryUrl - ^ remoteFile directoryUrl! Item was removed: - ----- Method: RemoteFileStream>>localName (in category 'accessing') ----- - localName - ^ remoteFile fileName! Item was removed: - ----- Method: RemoteFileStream>>openReadOnly (in category 'accessing') ----- - openReadOnly - "If we have data, don't reread." - - self readOnly. - readLimit := readLimit max: position. - localDataValid ifFalse: [remoteFile getFileNamed: remoteFile fileName into: self]. - "sets localDataValid := true"! Item was removed: - ----- Method: RemoteFileStream>>padToEndWith: (in category 'read, write, position') ----- - padToEndWith: aChar - "On the Mac, files do not truncate, so pad it with a harmless character. But Remote FTP files always replace, so no need to pad." - - self atEnd ifFalse: [self inform: 'Why is this stream not at its end?'].! Item was removed: - ----- Method: RemoteFileStream>>readOnly (in category 'accessing') ----- - readOnly - ^ remoteFile readOnly! Item was removed: - ----- Method: RemoteFileStream>>remoteFile (in category 'accessing') ----- - remoteFile - ^ remoteFile! Item was removed: - ----- Method: RemoteFileStream>>remoteFile: (in category 'accessing') ----- - remoteFile: aServerFile - remoteFile := aServerFile. - localDataValid := false. "need to read from the server"! Item was removed: - ----- Method: RemoteFileStream>>sleep (in category 'file directory') ----- - sleep - "If we are done, then let the server know" - - self close. - remoteFile sleep.! Item was removed: - TelnetProtocolClient subclass: #SMTPClient - instanceVariableNames: '' - classVariableNames: 'UseTLSIfAvailable' - poolDictionaries: '' - category: 'Network-Protocols'! - - !SMTPClient commentStamp: 'mir 2/21/2002 16:57' prior: 0! - This class implements the SMTP (mail sending) protocol specified in RFC 821. - - HELO <SP> <domain> <CRLF> - - MAIL <SP> FROM:<reverse-path> <CRLF> - - RCPT <SP> TO:<forward-path> <CRLF> - - DATA <CRLF> - - RSET <CRLF> - - SEND <SP> FROM:<reverse-path> <CRLF> - - SOML <SP> FROM:<reverse-path> <CRLF> - - SAML <SP> FROM:<reverse-path> <CRLF> - - VRFY <SP> <string> <CRLF> - - EXPN <SP> <string> <CRLF> - - HELP [<SP> <string>] <CRLF> - - NOOP <CRLF> - - QUIT <CRLF> - - TURN <CRLF> - - ! Item was removed: - ----- Method: SMTPClient class>>defaultPortNumber (in category 'accessing') ----- - defaultPortNumber - ^25! Item was removed: - ----- Method: SMTPClient class>>deliverMailFrom:to:text:usingServer: (in category 'sending mail') ----- - deliverMailFrom: fromAddress to: recipientList text: messageText usingServer: serverName - "Deliver a single email to a list of users and then close the connection - for delivering multiple messages, it is best to create a single connection and send all mail over it. - The serverName can include the port number - simply append ':587' for example to over ride the default port number. - No user name or password is used in this method; see deliverMailFrom:to:text:usingServer:userName:password: for more. - NOTE: the recipient list should be a collection of simple internet style addresses -- no '<>' or '()' stuff" - - self deliverMailFrom: fromAddress to: recipientList text: messageText usingServer: serverName userName: nil password: nil - ! Item was removed: - ----- Method: SMTPClient class>>deliverMailFrom:to:text:usingServer:userName:password: (in category 'sending mail') ----- - deliverMailFrom: fromAddress to: recipientList text: messageText usingServer: serverName userName: uNameString password: pwdString - "Deliver a single email to a list of users and then close the connection - for delivering multiple messages, it is best to create a single connection and send all mail over it. - The serverName can include the port number - simply append ':587' for example to over ride the default port number. - If uNameString or pwdString are non-nil, set the uid/pwd for the client. It is inadvisable to try setting a uid and not a pwd, or indeed vice versa. - NOTE: the recipient list should be a collection of simple internet style addresses -- no '<>' or '()' stuff" - - | smtpClient | - smtpClient := self new. - - uNameString ifNotNil:[smtpClient user: uNameString]. - pwdString ifNotNil:[smtpClient password: pwdString]. - smtpClient openOnHostNamed: serverName. - [smtpClient mailFrom: fromAddress to: recipientList text: messageText. - smtpClient quit] - ensure: [smtpClient close] - ! Item was removed: - ----- Method: SMTPClient class>>example (in category 'example') ----- - example - "SMTPClient example" - - self deliverMailFrom: 'm.rueger at acm.org' to: #('m.rueger at acm.org') text: - 'From: test - To: "not listed" - Subject: this is a test - - Hello from Squeak!! - ' usingServer: 'smtp.concentric.net'! Item was removed: - ----- Method: SMTPClient class>>example2 (in category 'example') ----- - example2 - "SMTPClient example2" - - self deliverMailFrom: 'm.rueger at acm.org' to: #('m.rueger at acm.org') text: - 'Subject: this is a test - - Hello from Squeak!! - ' usingServer: 'smtp.concentric.net'! Item was removed: - ----- Method: SMTPClient class>>logFlag (in category 'accessing') ----- - logFlag - ^#smtp! Item was removed: - ----- Method: SMTPClient>>data: (in category 'private protocol') ----- - data: messageData - "send the data of a message" - "DATA <CRLF>" - - "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 | - 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 removed: - ----- Method: SMTPClient>>encodeString: (in category 'utility') ----- - encodeString: aString - | str dec out | - str := String new: (aString size * 4 / 3 + 3) ceiling. - dec := Base64MimeConverter new. - dec - mimeStream: (out := WriteStream on: str); - dataStream: (ReadStream on: aString); - multiLine: false; - mimeEncode. - ^out contents! Item was removed: - ----- Method: SMTPClient>>initiateSession (in category 'private protocol') ----- - initiateSession - "EHLO <SP> <domain> <CRLF>" - - self sendCommand: (self useHelo ifTrue:['HELO '] ifFalse: ['EHLO ']) , self localHostName. - self checkResponse. - - self parseCapabilities: (self lastResponse lines allButFirst - collect: [:l | self valueOfResponseLine: l]). - - (self tlsIsActive not and: [self serverSupportsStarttls] and: [self wantsStarttls]) - ifTrue: [ - self starttls. - self responseIsSuccess ifTrue: [ - self initiateSession ] ]! Item was removed: - ----- Method: SMTPClient>>localHostName (in category 'public protocol') ----- - localHostName - "The local host name for purposes of identifying the the server. - If nil, NetNameResolver localHostName will be used." - - ^self connectionInfo at: #localHostName ifAbsent: [NetNameResolver localHostName]! Item was removed: - ----- Method: SMTPClient>>localHostName: (in category 'public protocol') ----- - localHostName: aString - "The local host name for purposes of identifying the the server. - If nil, NetNameResolver localHostName will be used." - - ^self connectionInfo at: #localHostName put: aString! Item was removed: - ----- Method: SMTPClient>>login (in category 'private protocol') ----- - login - "Send HELO first" - self initiateSession. - self user ifNil: [^self]. - self user ifEmpty: [^self]. - self sendCommand: 'AUTH LOGIN ' , (self encodeString: self user). - [self checkResponse] - on: TelnetProtocolError - do: [ :ex | ex isCommandUnrecognized ifTrue: [^ self] ifFalse: [ex pass]]. - self sendCommand: (self encodeString: self password). - self checkResponse! Item was removed: - ----- Method: SMTPClient>>mailFrom: (in category 'private protocol') ----- - mailFrom: fromAddress - " MAIL <SP> FROM:<reverse-path> <CRLF>" - - | address | - address := (MailAddressParser addressesIn: fromAddress) first. - - self sendCommand: 'MAIL FROM: <', address, '>'. - self checkResponse.! Item was removed: - ----- Method: SMTPClient>>mailFrom:to:text: (in category 'public protocol') ----- - mailFrom: sender to: recipientList text: messageText - "deliver this mail to a list of users. NOTE: the recipient list should be a collection of simple internet style addresses -- no '<>' or '()' stuff" - - self mailFrom: sender. - recipientList do: [ :recipient | - self recipient: recipient ]. - self data: messageText. - ! Item was removed: - ----- Method: SMTPClient>>quit (in category 'private protocol') ----- - quit - "send a QUIT command. This is polite to do, and indeed some servers might drop messages that don't have an associated QUIT" - "QUIT <CRLF>" - - self sendCommand: 'QUIT'. - self checkResponse.! Item was removed: - ----- Method: SMTPClient>>recipient: (in category 'private protocol') ----- - recipient: aRecipient - "specify a recipient for the message. aRecipient should be a bare email address" - "RCPT <SP> TO:<forward-path> <CRLF>" - - self sendCommand: 'RCPT TO: <', aRecipient, '>'. - self checkResponse.! Item was removed: - ----- Method: SMTPClient>>sendMailMessage:fromAddress: (in category '*Network-MailSending') ----- - sendMailMessage: mailMessage fromAddress: sender - "Convenience mechanism to handle handling of receivers - between MailMessage objects and SMTP." - - | mailMessageToSend recipients | - mailMessageToSend := mailMessage deepCopy. - recipients := (mailMessage to findTokens: ',') , - (mailMessage cc findTokens: ',') , - (mailMessage bcc findTokens: ','). - recipients := recipients asSet collect: [:r | r withBlanksTrimmed]. - mailMessageToSend bcc: ''. - - self - mailFrom: mailMessageToSend from - to: recipients - text: mailMessageToSend asSendableText! Item was removed: - ----- Method: SMTPClient>>useHelo (in category 'public protocol') ----- - useHelo - "If client use HELO instead of EHLO. HELO is the old protocol and - an old server may require it instead of EHLO." - - ^self connectionInfo at: #useHelo ifAbsent: [false]! Item was removed: - ----- Method: SMTPClient>>useHelo: (in category 'public protocol') ----- - useHelo: aBoolean - "Tell client to use HELO instead of EHLO. HELO is the old protocol and - an old server may require it instead of EHLO." - - ^self connectionInfo at: #useHelo put: aBoolean! Item was removed: - Object subclass: #ServerDirectory - instanceVariableNames: 'server directory type user passwordHolder group moniker altURL urlObject client loaderUrl eToyUserListUrl eToyUserList keepAlive encodingName' - classVariableNames: 'LocalEToyBaseFolderSpecs LocalEToyUserListUrls LocalProjectDirectories Servers' - poolDictionaries: '' - category: 'Network-RemoteDirectory'! - - !ServerDirectory commentStamp: '<historical>' prior: 0! - Holds all the information needed to read or write on a directory of an internet server. I am used for FTP and HTTP (and STMP? NNTP?). The password policy is: unless it is a public password (like annomyous), clear all passwords before any snapshot. There is a way to store passwords on the disk. - - server 'www.disney.com' or '123.34.56.08' or the ServerDirectory above me - (if I am a subdirectory sharing the info in a master directory) - directory 'ftp/pubs/' name of my directory within the server or superdirectory. - (for file://, directory is converted to local delimiters.) - type #ftp what you can do in this directory - user 'Jones45' - password an instance of Password. - group an Association ('group name' -> an array of ServerDirectorys) - If this first one is down, try the next one. Store on all of them. I am in the list. - moniker 'Main Squeak Directory' Description of this directory. - altURL When a FTP server holds some web pages, the altURL of those pages is often - different from the FTP directory. Put the altURL here. If the directory is - 'public_html/Squeak/', the altURL might be 'www.webPage.com/~kaehler2/ - Squeak/'. - urlObject An instance of a subclass of Url. It is very good at parsing complex urls. - Relative references. file:// uses this. Use this in the future instead of - server and directory inst vars. - socket nil or an FTPSocket. Only non-nil if the connection is being kept open - for multiple stores or retrievals. - loaderUrl a partial url that is ised to invoke squeak in a browser and load a project. - - A normal call on some command like (aServer getFileNamed: 'foo') does not set 'socket'. Socket being nil tells it to close the connection and destroy the socket after this one transcation. If the caller stores into 'socket', then the same command does NOT close the - connection. - Call 'openKeepFTP' or 'openGroup' to store into socket and keep the connection open. It is up to the user to call 'quit' or 'closeGroup' later. - - DD openKeepFTP. - Transcript cr; show: ((DD getFileNamed: '1198misc-tkKG.cs') next: 100). - Transcript cr; show: ((DD getFileNamed: '1192multFinder-tkKF.cs') next: 100). - DD quit.! Item was removed: - ----- Method: ServerDirectory class>>addLocalProjectDirectory: (in category 'available servers') ----- - addLocalProjectDirectory: aFileDirectory - self localProjectDirectories add: aFileDirectory - ! Item was removed: - ----- Method: ServerDirectory class>>addServer:named: (in category 'available servers') ----- - addServer: server named: nameString - self servers at: nameString put: server! Item was removed: - ----- Method: ServerDirectory class>>cleanUp: (in category 'class initialization') ----- - cleanUp: aggressive - "Clean out servers when doing aggressive cleanup" - - aggressive ifTrue:[self resetServers].! Item was removed: - ----- Method: ServerDirectory class>>defaultStemUrl (in category 'misc') ----- - defaultStemUrl - "For writing on an FTP directory. Users should insert their own server url here." - "ftp://jumbo.rd.wdi.disney.com/raid1/people/dani/Books/Grp/Grp" - " ServerDirectory defaultStemUrl " - - | rand dir | - rand := String new: 4. - 1 to: rand size do: [:ii | - rand at: ii put: ('bdfghklmnpqrstvwz' at: 17 atRandom)]. - dir := self serverNamed: 'DaniOnJumbo'. - ^ 'ftp://', dir server, dir slashDirectory, '/BK', rand! Item was removed: - ----- Method: ServerDirectory class>>determineLocalServerDirectory: (in category 'server prefs') ----- - determineLocalServerDirectory: directoryName - "This is part of a workaround for Mac file name oddities regarding relative file names. - The real fix should be in fullNameFor: but that seems to break other parts of the system." - - | dirName | - dirName := directoryName. - (Smalltalk platformName = 'Mac OS' - and: [directoryName beginsWith: ':']) - ifTrue: [ - dirName := (FileDirectory default pathName endsWith: directoryName) - ifTrue: [FileDirectory default pathName] - ifFalse: [(FileDirectory default pathName , directoryName) replaceAll: '::' with: ':']]. - ^FileDirectory default directoryNamed: dirName! Item was removed: - ----- Method: ServerDirectory class>>fetchExternalSettingsIn: (in category 'server prefs') ----- - fetchExternalSettingsIn: aDirectory - "Scan for server configuration files" - "ServerDirectory fetchExternalSettingsIn: (FileDirectory default directoryNamed: 'prefs')" - - | serverConfDir | - (aDirectory directoryExists: self serverConfDirectoryName) - ifFalse: [^self]. - self resetLocalProjectDirectories. - serverConfDir := aDirectory directoryNamed: self serverConfDirectoryName. - serverConfDir fileNames do: [:fileName | | stream | - stream := serverConfDir readOnlyFileNamed: fileName. - stream - ifNotNil: [ - [self parseServerEntryFrom: stream] ifError: [:err :rcvr | ]. - stream close]]! Item was removed: - ----- Method: ServerDirectory class>>initialize (in category 'class initialization') ----- - initialize - "ServerDirectory initialize" - "ServerDirectory resetLocalProjectDirectories. - Servers := Dictionary new." - - ExternalSettings registerClient: self! Item was removed: - ----- Method: ServerDirectory class>>localProjectDirectories (in category 'available servers') ----- - localProjectDirectories - LocalProjectDirectories ifNil: [LocalProjectDirectories := OrderedCollection new]. - ^LocalProjectDirectories! Item was removed: - ----- Method: ServerDirectory class>>nameForServer: (in category 'available servers') ----- - nameForServer: aServer - ^self servers keyAtValue: aServer! Item was removed: - ----- Method: ServerDirectory class>>newFrom: (in category 'misc') ----- - newFrom: aSimilarObject - "Must copy the urlObject, so they won't be shared" - - | inst | - inst := super newFrom: aSimilarObject. - inst urlObject: aSimilarObject urlObject copy. - ^ inst! Item was removed: - ----- Method: ServerDirectory class>>on: (in category 'misc') ----- - on: pathString - - ^self new on: pathString! Item was removed: - ----- Method: ServerDirectory class>>parseFTPEntry: (in category 'misc') ----- - parseFTPEntry: ftpEntry - | tokens longy dateInSeconds thisYear thisMonth | - thisYear := Date today year. - thisMonth := Date today monthIndex. - tokens := ftpEntry findTokens: ' '. - tokens size = 8 ifTrue: - [((tokens at: 6) size ~= 3 and: [(tokens at: 5) size = 3]) ifTrue: - ["Fix for case that group is blank (relies on month being 3 chars)" - tokens := tokens copyReplaceFrom: 4 to: 3 with: {'blank'}]]. - tokens size >= 9 ifFalse:[^nil]. - - ((tokens at: 6) size ~= 3 and: [(tokens at: 5) size = 3]) ifTrue: - ["Fix for case that group is blank (relies on month being 3 chars)" - tokens := tokens copyReplaceFrom: 4 to: 3 with: {'blank'}]. - - tokens size > 9 ifTrue: - [ "cmm: this approach fails for filenames containing two spaces in a row." - longy := tokens at: 9. - 10 to: tokens size do: [:i | longy := longy , ' ' , (tokens at: i)]. - tokens at: 9 put: longy]. - dateInSeconds := self - secondsForDay: (tokens at: 7) - month: (tokens at: 6) - yearOrTime: (tokens at: 8) - thisMonth: thisMonth - thisYear: thisYear. - ^DirectoryEntry name: (tokens at: 9) "file name" - creationTime: dateInSeconds "creation date" - modificationTime: dateInSeconds "modification time" - isDirectory: ((tokens first first) = $d or: [tokens first first =$l]) "is-a-directory flag" - fileSize: tokens fifth asNumber "file size" - ! Item was removed: - ----- Method: ServerDirectory class>>parseServerEntryFrom: (in category 'server prefs') ----- - parseServerEntryFrom: stream - - | server type directory entries serverName | - - entries := ExternalSettings parseServerEntryArgsFrom: stream. - - serverName := entries at: 'name' ifAbsent: [^nil]. - directory := entries at: 'directory' ifAbsent: [^nil]. - type := entries at: 'type' ifAbsent: [^nil]. - type = 'file' - ifTrue: [ - server := self determineLocalServerDirectory: directory. - entries at: 'userListUrl' ifPresent:[:value | server eToyUserListUrl: value]. - entries at: 'baseFolderSpec' ifPresent:[:value | server eToyBaseFolderSpec: value]. - ^self addLocalProjectDirectory: server]. - type = 'bss' - ifTrue: [server := SuperSwikiServer new type: #http]. - type = 'http' - ifTrue: [server := HTTPServerDirectory new type: #ftp]. - type = 'ftp' - ifTrue: [server := ServerDirectory new type: #ftp]. - - server directory: directory. - entries at: 'server' ifPresent: [:value | server server: value]. - entries at: 'user' ifPresent: [:value | server user: value]. - entries at: 'group' ifPresent: [:value | server groupName: value]. - entries at: 'passwdseq' ifPresent: [:value | server passwordSequence: value asNumber]. - entries at: 'url' ifPresent: [:value | server altUrl: value]. - entries at: 'loaderUrl' ifPresent: [:value | server loaderUrl: value]. - entries at: 'acceptsUploads' ifPresent: [:value | server acceptsUploads: value asLowercase = 'true']. - entries at: 'userListUrl' ifPresent:[:value | server eToyUserListUrl: value]. - entries at: 'encodingName' ifPresent:[:value | server encodingName: value]. - ServerDirectory addServer: server named: serverName. - ! Item was removed: - ----- Method: ServerDirectory class>>projectDefaultDirectory (in category 'school support') ----- - projectDefaultDirectory - ^Preferences eToyLoginEnabled - ifTrue: [ - (ServerDirectory localProjectDirectories, ServerDirectory servers values) - detect:[:any| any hasEToyUserList] - ifNone:[FileDirectory default]] - ifFalse: [FileDirectory default]! Item was removed: - ----- Method: ServerDirectory class>>projectServers (in category 'available servers') ----- - projectServers - "ServerDirectory projectServers" - - | projectServers | - projectServers := OrderedCollection new. - self serverNames do: [ :n | | projectServer | - projectServer := ServerDirectory serverNamed: n. - (projectServer isProjectSwiki and: [projectServer isSearchable]) - ifTrue: [projectServers add: projectServer]]. - ^projectServers! Item was removed: - ----- Method: ServerDirectory class>>releaseExternalSettings (in category 'server prefs') ----- - releaseExternalSettings - "Release for server configurations" - "ServerDirectory releaseExternalSettings" - - (Preferences valueOfFlag: #externalServerDefsOnly) - ifTrue: [ - self resetLocalProjectDirectories. - Servers := Dictionary new]! Item was removed: - ----- Method: ServerDirectory class>>removeServerNamed: (in category 'available servers') ----- - removeServerNamed: nameString - self - removeServerNamed: nameString - ifAbsent: [self error: 'Server "' , nameString asString , '" not found']! Item was removed: - ----- Method: ServerDirectory class>>removeServerNamed:ifAbsent: (in category 'available servers') ----- - removeServerNamed: nameString ifAbsent: aBlock - - self servers removeKey: nameString ifAbsent: aBlock! Item was removed: - ----- Method: ServerDirectory class>>resetLocalProjectDirectories (in category 'available servers') ----- - resetLocalProjectDirectories - LocalProjectDirectories := nil. - LocalEToyUserListUrls := nil. - LocalEToyBaseFolderSpecs := nil. - ! Item was removed: - ----- Method: ServerDirectory class>>resetServers (in category 'available servers') ----- - resetServers - Servers := nil! Item was removed: - ----- Method: ServerDirectory class>>secondsForDay:month:yearOrTime:thisMonth:thisYear: (in category 'misc') ----- - secondsForDay: dayToken month: monthToken yearOrTime: ytToken - thisMonth: thisMonth thisYear: thisYear - - | ftpDay ftpMonth pickAYear jDateToday trialJulianDate | - - ftpDay := dayToken asNumber. - ftpMonth := Date indexOfMonth: monthToken. - (ytToken includes: $:) ifFalse: [ - ^(Date newDay: ftpDay month: ftpMonth year: ytToken asNumber) asSeconds - ]. - jDateToday := Date today dayOfYear. - trialJulianDate := (Date newDay: ftpDay month: ftpMonth year: thisYear) dayOfYear. - - "Date has no year if within six months (do we need to check the day, too?)" - - "Well it appear to be pickier than that... it isn't just 6 months or 6 months and the day of the month, put perhaps the julian date AND the time as well. I don't know what the precise standard is, but this seems to produce better results" - - pickAYear := (jDateToday - trialJulianDate) > 182 ifTrue: [ - thisYear + 1 "his clock could be ahead of ours??" - ] ifFalse: [ - pickAYear := (trialJulianDate - jDateToday) > 182 ifTrue: [ - thisYear - 1 - ] ifFalse: [ - thisYear - ]. - ]. - ^(Date newDay: ftpDay month: ftpMonth year: pickAYear) asSeconds + - (Time readFrom: (ReadStream on: ytToken)) asSeconds - - ! Item was removed: - ----- Method: ServerDirectory class>>serverConfDirectoryName (in category 'server prefs') ----- - serverConfDirectoryName - ^'knownServers'! Item was removed: - ----- Method: ServerDirectory class>>serverForURL: (in category 'available servers') ----- - serverForURL: aURLString - | serversForURL server urlPath serverPath relPath | - serversForURL := self servers values select: [:each | - (aURLString beginsWith: each downloadUrl) - or: [(aURLString beginsWith: each realUrl) - or: [aURLString , '/' beginsWith: each downloadUrl]]]. - serversForURL isEmpty - ifTrue: [^nil]. - server := serversForURL first. - urlPath := aURLString asUrl path. - (urlPath isEmpty not - and: [urlPath last isEmpty]) - ifTrue: [urlPath removeLast]. - serverPath := server downloadUrl asUrl path. - (serverPath isEmpty not - and: [serverPath last isEmpty]) - ifTrue: [serverPath removeLast]. - urlPath size < serverPath size - ifTrue: [^nil]. - relPath := String new. - serverPath size +1 to: urlPath size do: [:i | relPath := relPath , '/' , (urlPath at: i)]. - ^relPath isEmpty - ifTrue: [server] - ifFalse: [server directoryNamed: (relPath copyFrom: 2 to: relPath size)]! Item was removed: - ----- Method: ServerDirectory class>>serverNamed: (in category 'available servers') ----- - serverNamed: nameString - ^self serverNamed: nameString ifAbsent: [self error: 'Server name not found']! Item was removed: - ----- Method: ServerDirectory class>>serverNamed:ifAbsent: (in category 'available servers') ----- - serverNamed: nameString ifAbsent: aBlock - - ^self servers at: nameString asString ifAbsent: aBlock! Item was removed: - ----- Method: ServerDirectory class>>serverNames (in category 'available servers') ----- - serverNames - ^self servers keys asArray sort! Item was removed: - ----- Method: ServerDirectory class>>servers (in category 'available servers') ----- - servers - Servers ifNil: [Servers := Dictionary new]. - ^Servers! Item was removed: - ----- Method: ServerDirectory class>>storeCurrentServersIn: (in category 'server prefs') ----- - storeCurrentServersIn: aDirectory - - self servers do: [:each | - | file | - file := aDirectory fileNamed: (ServerDirectory nameForServer: each). - each storeServerEntryOn: file. - file close]. - self localProjectDirectories do: [:each | - | file | - file := aDirectory fileNamed: each localName. - each storeServerEntryOn: file. - file close]. - ! Item was removed: - ----- Method: ServerDirectory class>>transferServerDefinitionsToExternal (in category 'server prefs') ----- - transferServerDefinitionsToExternal - "ServerDirectory transferServerDefinitionsToExternal" - - | serverDir | - serverDir := ExternalSettings preferenceDirectory directoryNamed: self serverConfDirectoryName. - serverDir assureExistence. - ServerDirectory storeCurrentServersIn: serverDir! Item was removed: - ----- Method: ServerDirectory>>acceptsUploads (in category 'testing') ----- - acceptsUploads - ^true! Item was removed: - ----- Method: ServerDirectory>>acceptsUploads: (in category 'accessing') ----- - acceptsUploads: aBoolean - "Do nothing yet"! Item was removed: - ----- Method: ServerDirectory>>altUrl (in category 'accessing') ----- - altUrl - "When a ftp server also has http access, use this to store the http url" - ^ altURL! Item was removed: - ----- Method: ServerDirectory>>altUrl: (in category 'accessing') ----- - altUrl: aString - altURL := aString! Item was removed: - ----- Method: ServerDirectory>>asServerFileNamed: (in category 'file directory') ----- - asServerFileNamed: aName - - | rFile | - rFile := self as: ServerFile. - (aName includes: self pathNameDelimiter) - ifTrue: [rFile fullPath: aName] - "sets server, directory(path), fileName. If relative, merge with self." - ifFalse: [rFile fileName: aName]. "JUST a single NAME, already have the rest" - "Mac files that include / in name, must encode it as %2F " - ^rFile - ! Item was removed: - ----- Method: ServerDirectory>>assureExistence (in category 'file directory') ----- - assureExistence - "Make sure the current directory exists. If necessary, create all parts inbetween" - - self exists ifFalse: [ - self isRoot ifFalse: [ - self containingDirectory assureExistenceOfPath: self localName]]! Item was removed: - ----- Method: ServerDirectory>>assureExistenceOfPath: (in category 'file directory') ----- - assureExistenceOfPath: localPath - "Make sure the local directory exists. If necessary, create all parts inbetween" - - localPath = (String with: self pathNameDelimiter) ifTrue: [^self]. - self assureExistence. - (self localPathExists: localPath) ifFalse: [ - self createDirectory: localPath].! Item was removed: - ----- Method: ServerDirectory>>bareDirectory (in category 'accessing') ----- - bareDirectory - - ^ directory first == $/ - ifTrue: [directory copyFrom: 2 to: directory size] - ifFalse: [directory]! Item was removed: - ----- Method: ServerDirectory>>containingDirectory (in category 'file directory') ----- - containingDirectory - - self splitName: directory to: [:parentPath :localName | - ^self copy directory: parentPath]! Item was removed: - ----- Method: ServerDirectory>>createDirectory: (in category 'file directory') ----- - createDirectory: localName - "Create a new sub directory within the current one" - - self isTypeFile ifTrue: [ - ^FileDirectory createDirectory: localName - ]. - - client := self openFTPClient. - self switchDirectory. - [client makeDirectory: localName] - ensure: [self quit]. - ! Item was removed: - ----- Method: ServerDirectory>>deleteDirectory: (in category 'file directory') ----- - deleteDirectory: localName - "Delete the sub directory within the current one. Call needs to ask user to confirm." - - self isTypeFile ifTrue: [ - ^FileDirectory deleteFileNamed: localName - ]. - "Is this the right command???" - - client := self openFTPClient. - [ self switchDirectory. - client deleteDirectory: localName] - ensure: [self quit]. - ! Item was removed: - ----- Method: ServerDirectory>>deleteFileNamed: (in category 'file directory') ----- - deleteFileNamed: fullName - "Detete a remote file. fullName is directory path, and does include name of the server. Or it can just be a fileName." - | file | - file := self asServerFileNamed: fullName. - file isTypeFile ifTrue: [ - ^ (FileDirectory forFileName: (file fileNameRelativeTo: self)) - deleteFileNamed: file fileName - ]. - - client := self openFTPClient. - [ self switchDirectory. - client deleteFileNamed: fullName] - ensure: [self quit]. - ! Item was removed: - ----- Method: ServerDirectory>>deleteLocalFiles (in category 'file directory') ----- - deleteLocalFiles - "Delete the local files in this directory." - self switchDirectory. - self fileNames do:[:fn| self deleteFileNamed: fn ifAbsent: [(CannotDeleteFileException new - messageText: 'Could not delete the old version of file ' , (self fullNameFor: fn)) signal]]! Item was removed: - ----- Method: ServerDirectory>>directory (in category 'accessing') ----- - directory - "String of part of url that is the directory. Has slashes as separators" - - urlObject ifNotNil: [^ urlObject pathDirString]. - ^ directory! Item was removed: - ----- Method: ServerDirectory>>directory: (in category 'accessing') ----- - directory: anObject - directory := anObject! Item was removed: - ----- Method: ServerDirectory>>directoryNamed: (in category 'file directory') ----- - directoryNamed: localFileName - "Return a copy of me pointing at this directory below me" - | new newPath newAltUrl | - new := self copy. - urlObject - ifNotNil: [new urlObject path: new urlObject path copy. - new urlObject path removeLast; addLast: localFileName; addLast: ''. - ^ new]. - "sbw. When working from an FTP server, the first time we access - a subdirectory the <directory> variable is empty. In that case we - cannot begin with a leading path delimiter since that leads us to - the wrong place." - newPath := directory isEmpty - ifTrue: [localFileName] - ifFalse: [directory , self pathNameDelimiter asString , localFileName]. - self altUrl ifNotNil: [ - newAltUrl := self altUrl, self pathNameDelimiter asString , localFileName]. - new directory: newPath; altUrl: newAltUrl. - ^ new! Item was removed: - ----- Method: ServerDirectory>>directoryNames (in category 'file directory') ----- - directoryNames - "Return a collection of names for the subdirectories of this directory." - "(ServerDirectory serverNamed: 'UIUCArchive') directoryNames" - - ^ (self entries select: [:entry | entry isDirectory and: [entry name ~= '.' and:[entry name ~= '..']]]) - collect: [:entry | entry name] - ! Item was removed: - ----- Method: ServerDirectory>>directoryObject (in category 'accessing') ----- - directoryObject - - ^self! Item was removed: - ----- Method: ServerDirectory>>directoryWrapperClass (in category 'squeaklets') ----- - directoryWrapperClass - - ^FileDirectoryWrapper! Item was removed: - ----- Method: ServerDirectory>>downloadUrl (in category 'accessing') ----- - downloadUrl - "The url under which files will be accessible." - ^(self altUrl - ifNil: [self realUrl] - ifNotNil: [self altUrl]) , '/'! Item was removed: - ----- Method: ServerDirectory>>encodingName (in category 'accessing') ----- - encodingName - ^encodingName.! Item was removed: - ----- Method: ServerDirectory>>encodingName: (in category 'accessing') ----- - encodingName: aName - encodingName := aName! Item was removed: - ----- Method: ServerDirectory>>entries (in category 'file directory') ----- - entries - "Return a collection of directory entries for the files and directories in this directory. Each entry is a five-element array: (<name> <creationTime> <modificationTime> <dirFlag> <fileSize>)." - | dir ftpEntries | - "We start with ftp directory entries of the form... - d--------- 1 owner group 0 Apr 27 22:01 blasttest - ---------- 1 owner group 93812 Jul 21 1997 COMMAND.COM - 1 2 3 4 5 6 7 8 9 -- token index" - self isTypeFile ifTrue: [ - urlObject isAbsolute ifFalse: [urlObject default]. - ^ (FileDirectory on: urlObject pathForDirectory) entries - ]. - - dir := self getDirectory. - (dir respondsTo: #contentsOfEntireFile) ifFalse: [^ #()]. - ftpEntries := dir contentsOfEntireFile lines. - ^ ftpEntries - collect:[:ftpEntry | self class parseFTPEntry: ftpEntry] - thenSelect: [:entry | entry notNil]! Item was removed: - ----- Method: ServerDirectory>>entryAt: (in category 'file directory') ----- - entryAt: fileName - "find the entry with local name fileName" - ^ self - entryAt: fileName - ifAbsent: [ self error: 'file not in directory: ' , fileName ]! Item was removed: - ----- Method: ServerDirectory>>entryAt:ifAbsent: (in category 'file directory') ----- - entryAt: fileName ifAbsent: aBlock - "Find the entry with local name fileName and answer it. - If not found, answer the result of evaluating aBlock." - ^ self entries - detect: [ : entry | entry name = fileName ] - ifNone: aBlock! Item was removed: - ----- Method: ServerDirectory>>exists (in category 'file directory') ----- - exists - "It is difficult to tell if a directory exists. This is ugly, but it works for writable directories. http: will fall back on ftp for this" - - | probe | - self isTypeFile ifTrue: [ - self entries size > 0 ifTrue: [^ true]. - probe := self newFileNamed: 'withNoName23'. - probe ifNotNil: [ - probe close. - probe directory deleteFileNamed: probe localName]. - ^probe notNil]. - ^ - [client := self openFTPClient. - [self switchDirectory] - ensure: [self quit]. - true] - on: Error - do: [:ex | false]! Item was removed: - ----- Method: ServerDirectory>>fileAndDirectoryNames (in category 'file directory') ----- - fileAndDirectoryNames - "FileDirectory default fileAndDirectoryNames" - - ^ self entries collect: [:entry | entry name] - ! Item was removed: - ----- Method: ServerDirectory>>fileEntries (in category 'file directory') ----- - fileEntries - "Return a collection of names for the files (but not directories) in this directory." - "(ServerDirectory serverNamed: 'UIUCArchive') fileEntries" - - ^ self entries select: [:entry | entry isDirectory not]! Item was removed: - ----- Method: ServerDirectory>>fileExists: (in category 'up/download') ----- - fileExists: fileName - "Does the file exist on this server directory? fileName must be simple with no / or references to other directories." - - | stream | - self isTypeFile ifTrue: [^ self fileNames includes: fileName]. - self isTypeHTTP ifTrue: [ - stream := self readOnlyFileNamed: fileName. - ^stream contents notEmpty]. - "ftp" - ^ self entries anySatisfy: [:entry | entry name = fileName]! Item was removed: - ----- Method: ServerDirectory>>fileNamed: (in category 'file directory') ----- - fileNamed: fullName - "Create a RemoteFileStream for writing. If the file exists, do not complain. fullName is directory path, and does include name of the server. Or it can just be a fileName. Only write the data upon close." - - | file remoteStrm | - file := self asServerFileNamed: fullName. - file readWrite. - file isTypeFile ifTrue: [ - ^ FileStream fileNamed: (file fileNameRelativeTo: self) - ]. - - remoteStrm := RemoteFileStream on: (String new: 2000). - remoteStrm remoteFile: file. - ^ remoteStrm "no actual writing till close" - ! Item was removed: - ----- Method: ServerDirectory>>fileNames (in category 'file directory') ----- - fileNames - "Return a collection of names for the files (but not directories) in this directory." - "(ServerDirectory serverNamed: 'UIUCArchive') fileNames" - - ^ self entries select: [:entry | entry isDirectory not] - thenCollect: [:entry | entry name] - ! Item was removed: - ----- Method: ServerDirectory>>fromUser (in category 'initialize') ----- - fromUser - "Ask the user for all data on a new server. Save it in a named server." ! Item was removed: - ----- Method: ServerDirectory>>fullName (in category 'accessing') ----- - fullName - ^server! Item was removed: - ----- Method: ServerDirectory>>fullNameFor: (in category 'file directory') ----- - fullNameFor: aFileName - "Convention: - If it is an absolute path, directory stored with a leading slash, and url has no user at . - If relative path, directory stored with no leading slash, and url begins user at . - Should we include ftp:// on the front?" - - urlObject ifNotNil: [^ urlObject pathString, aFileName]. - (aFileName includes: self pathNameDelimiter) - ifTrue: [^ aFileName]. - self isTypeHTTP ifTrue: [ - ^ self downloadUrl, aFileName]. - directory isEmpty ifTrue: [^ server, - self pathNameDelimiter asString, aFileName]. - ^ (directory first == $/ ifTrue: [''] ifFalse: [user,'@']), - server, self slashDirectory, - self pathNameDelimiter asString, aFileName! Item was removed: - ----- 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 | - 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 | - 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 removed: - ----- Method: ServerDirectory>>getDirectory (in category 'up/download') ----- - getDirectory - "Return a stream with a listing of the current server directory. (Later -- Use a proxy server if one has been registered.)" - - | listing | - client := self openFTPClient. - listing := - [ self switchDirectory. - client getDirectory] - ensure: [self quit]. - ^ReadStream on: listing! Item was removed: - ----- Method: ServerDirectory>>getFileList (in category 'up/download') ----- - getFileList - "Return a stream with a list of files in the current server directory. (Later -- Use a proxy server if one has been registered.)" - - | listing | - client := self openFTPClient. - listing := [client getFileList] - ensure: [self quit]. - ^ReadStream on: listing! Item was removed: - ----- Method: ServerDirectory>>getFileNamed: (in category 'up/download') ----- - getFileNamed: fileNameOnServer - "Just FTP a file from a server. Return contents. - (Later -- Use a proxy server if one has been registered.)" - - | result | - client := self openFTPClient. - result := [client getFileNamed: fileNameOnServer] - ensure: [self quit]. - ^result! Item was removed: - ----- Method: ServerDirectory>>getFileNamed:into: (in category 'up/download') ----- - getFileNamed: fileNameOnServer into: dataStream - - ^self getFileNamed: fileNameOnServer into: dataStream - httpRequest: 'Pragma: no-cache', String crlf! Item was removed: - ----- Method: ServerDirectory>>getFileNamed:into:httpRequest: (in category 'up/download') ----- - getFileNamed: fileNameOnServer into: dataStream httpRequest: requestString - "Just FTP a file from a server. Return a stream. (Later -- Use a proxy server if one has been registered.)" - - | resp | - self isTypeFile ifTrue: [ - dataStream nextPutAll: - (resp := FileStream oldFileNamed: server,(self serverDelimiter asString), - self bareDirectory, (self serverDelimiter asString), - fileNameOnServer) contentsOfEntireFile. - dataStream dataIsValid. - ^ resp]. - self isTypeHTTP ifTrue: [ - resp := HTTPSocket httpGet: (self fullNameFor: fileNameOnServer) - args: nil accept: 'application/octet-stream' request: requestString. - resp isString ifTrue: [^ dataStream]. "error, no data" - dataStream copyFrom: resp. - dataStream dataIsValid. - ^ dataStream]. - - client := self openFTPClient. "Open passive. Do everything up to RETR or STOR" - [self switchDirectory. - client getFileNamed: fileNameOnServer into: dataStream] - ensure: [self quit]. - - dataStream dataIsValid. - ! Item was removed: - ----- Method: ServerDirectory>>getOnly:from: (in category 'file directory') ----- - getOnly: nnn from: fileNameOnServer - | file ff resp | - "Use FTP to just capture the first nnn characters of the file. Break the connection after that. Goes faster for long files. Return the contents, not a stream." - - self isTypeFile ifTrue: [ - file := self as: ServerFile. - file fileName: fileNameOnServer. - ff := FileStream oldFileOrNoneNamed: (file fileNameRelativeTo: self). - ^ ff next: nnn]. - self isTypeHTTP ifTrue: [ - resp := HTTPSocket httpGet: (self fullNameFor: fileNameOnServer) - accept: 'application/octet-stream'. - "For now, get the whole file. This branch not used often." - ^ resp truncateTo: nnn]. - - ^ self getOnlyBuffer: (String new: nnn) from: fileNameOnServer! Item was removed: - ----- Method: ServerDirectory>>getOnlyBuffer:from: (in category 'up/download') ----- - getOnlyBuffer: buffer from: fileNameOnServer - "Open ftp, fill the buffer, and close the connection. Only first part of a very long file." - - | dataStream | - client := self openFTPClient. - dataStream := WriteStream on: buffer. - [client getPartial: buffer size fileNamed: fileNameOnServer into: dataStream] - ensure: [self quit]. - ^buffer! Item was removed: - ----- Method: ServerDirectory>>groupName (in category 'server groups') ----- - groupName - - ^group - ifNil: [self moniker] - ifNotNil: [ - (group isString) - ifTrue: [group] - ifFalse: [group key]]! Item was removed: - ----- Method: ServerDirectory>>groupName: (in category 'server groups') ----- - groupName: groupName - group := groupName! Item was removed: - ----- Method: ServerDirectory>>hasFiles (in category 'testing') ----- - hasFiles - "Return true if we find an entry that is a file, false otherwise" - "(ServerDirectory serverNamed: 'UIUCArchive') hasFiles" - - ^ self entries anySatisfy: [:entry | entry isDirectory not]! Item was removed: - ----- Method: ServerDirectory>>hasSubDirectories (in category 'testing') ----- - hasSubDirectories - "Return true if we find an entry that is a directory, false otherwise" - "(ServerDirectory serverNamed: 'UIUCArchive') hasSubDirectories" - - ^ self entries anySatisfy: [:entry | entry isDirectory]! Item was removed: - ----- Method: ServerDirectory>>includesKey: (in category 'file directory') ----- - includesKey: localName - "Answer true if this directory includes a file or directory of the given name. Note that the name should be a local file name, in contrast with fileExists:, which takes either local or full-qualified file names." - - ^ self fileAndDirectoryNames includes: localName - ! Item was removed: - ----- Method: ServerDirectory>>isProjectSwiki (in category 'testing') ----- - isProjectSwiki - ^false! Item was removed: - ----- Method: ServerDirectory>>isRemoteDirectory (in category 'testing') ----- - isRemoteDirectory - "answer whatever the receiver is a remote directory" - ^ true! Item was removed: - ----- Method: ServerDirectory>>isRoot (in category 'testing') ----- - isRoot - ^ directory = '/'! Item was removed: - ----- Method: ServerDirectory>>isSearchable (in category 'testing') ----- - isSearchable - ^false! Item was removed: - ----- Method: ServerDirectory>>isTypeFTP (in category 'accessing') ----- - isTypeFTP - - ^self typeWithDefault == #ftp! Item was removed: - ----- Method: ServerDirectory>>isTypeFile (in category 'accessing') ----- - isTypeFile - - ^self typeWithDefault == #file! Item was removed: - ----- Method: ServerDirectory>>isTypeHTTP (in category 'accessing') ----- - isTypeHTTP - - ^self typeWithDefault == #http! Item was removed: - ----- Method: ServerDirectory>>keepAlive (in category 'testing') ----- - keepAlive - keepAlive ifNil: [keepAlive := false]. - ^keepAlive! Item was removed: - ----- Method: ServerDirectory>>keepAlive: (in category 'accessing') ----- - keepAlive: aBoolean - keepAlive := aBoolean! Item was removed: - ----- Method: ServerDirectory>>loaderUrl (in category 'accessing') ----- - loaderUrl - - ^loaderUrl! Item was removed: - ----- Method: ServerDirectory>>loaderUrl: (in category 'accessing') ----- - loaderUrl: aString - - loaderUrl := aString! Item was removed: - ----- Method: ServerDirectory>>localName (in category 'file directory') ----- - localName - - ^ServerDirectory servers keyAtIdentityValue: self ifAbsent:[ - directory isEmpty ifTrue: [self error: 'no directory']. - self localNameFor: directory]! Item was removed: - ----- Method: ServerDirectory>>localNameFor: (in category 'file directory') ----- - localNameFor: fullName - "Return the local part the given name." - - self - splitName: fullName - to: [:dirPath :localName | ^ localName] - ! Item was removed: - ----- Method: ServerDirectory>>localPathExists: (in category 'file directory') ----- - localPathExists: localPath - - ^self directoryNames includes: localPath! Item was removed: - ----- Method: ServerDirectory>>matchingEntries: (in category 'file directory') ----- - matchingEntries: criteria - "Ignore the filter criteria for now" - ^self entries! Item was removed: - ----- Method: ServerDirectory>>moniker (in category 'accessing') ----- - moniker - "a plain language name for this directory" - - moniker ifNotNil: [^ moniker]. - directory ifNotNil: [^ self server]. - urlObject ifNotNil: [^ urlObject asString]. - ^ ''! Item was removed: - ----- Method: ServerDirectory>>moniker: (in category 'accessing') ----- - moniker: nickName - "a plain language name for this directory" - - moniker := nickName! Item was removed: - ----- Method: ServerDirectory>>moveAllButYoungest:in:to: (in category 'squeaklets') ----- - moveAllButYoungest: young in: versions to: repository - | all | - "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 := (versions as: Array) - replace: [ :each | { each. Base64MimeConverter decodeInteger: each second unescapePercents } ]; - sort: [ :a :b | a second < b second ]; - replace: [ :each | each first ]. - - all from: 1 to: all size - young do: [:vv | | fName | - fName := vv first, '_', vv second, '.', vv third. - repository rename: self fullName,fName toBe: fName]. - ! Item was removed: - ----- Method: ServerDirectory>>newFileNamed: (in category 'file directory') ----- - newFileNamed: fullName - "Create a RemoteFileStream. If the file exists, and complain. fullName is directory path, and does include name of the server. Or it can just be a fileName. Only write the data upon close." - - | file remoteStrm selection | - - file := self asServerFileNamed: fullName. - file readWrite. - file isTypeFile ifTrue: - [^ FileStream newFileNamed: (file fileNameRelativeTo: self)]. - file exists - ifTrue: - [selection := Project uiManager - chooseOptionFrom: #('overwrite that file' 'choose another name' 'cancel') - title: (file fullNameFor: file fileName) , ' - already exists.'] - ifFalse: [selection := 1]. - - selection = 1 ifTrue: - [remoteStrm := RemoteFileStream on: (String new: 2000). - remoteStrm remoteFile: file. - remoteStrm dataIsValid. "empty stream is the real contents!!" - ^ remoteStrm]. "no actual writing till close" - selection = 2 ifTrue: - [^ self newFileNamed: - (Project uiManager - request: 'Enter a new file name' - initialAnswer: file fileName)]. - ^ nil "cancel"! Item was removed: - ----- Method: ServerDirectory>>oldFileNamed: (in category 'file directory') ----- - oldFileNamed: aName - "If the file exists, answer a read-only RemoteFileStream on it. aName is directory path, and does include name of the server. Or it can just be a fileName. For now, pre-read the file." - - | rFile | - - rFile := self asServerFileNamed: aName. - rFile readOnly. - rFile isTypeFile ifTrue: [ - ^ FileStream oldFileNamed: (rFile fileNameRelativeTo: self)]. - - ^self streamOnBeginningOf: rFile - ! Item was removed: - ----- 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." - - - ^ Cursor wait showWhile: - [ | file | - 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 removed: - ----- Method: ServerDirectory>>on: (in category 'file directory') ----- - on: fullName - "Answer another ServerDirectory on the partial path name. fullName is directory path, and does include the name of the server." - - | new | - new := self copy. - new fullPath: fullName. "sets server, directory(path)" - ^ new! Item was removed: - ----- Method: ServerDirectory>>openFTPClient (in category 'dis/connect') ----- - openFTPClient - - | loginSuccessful | - client ifNotNil: - [client isConnected - ifTrue: [^client] - ifFalse: [client := nil]]. - client := FTPClient openOnHostNamed: server. - client ifNil: [^nil]. - loginSuccessful := false. - [loginSuccessful] - whileFalse: - [[loginSuccessful := true. - client loginUser: self user password: self password] - on: LoginFailedException - do: [:ex | - | what | - passwordHolder := nil. - what := Project uiManager - chooseOptionFrom: #('enter password' 'give up') - title: 'Would you like to try another password?'. - what = 1 ifFalse: [ ^nil]. - loginSuccessful := false]]. - client changeDirectoryTo: directory. - ^client! Item was removed: - ----- Method: ServerDirectory>>password (in category 'accessing') ----- - password - - passwordHolder ifNil: [passwordHolder := ServerPassword new]. - ^ passwordHolder passwordFor: self "may ask the user"! Item was removed: - ----- Method: ServerDirectory>>password: (in category 'accessing') ----- - password: pp - - passwordHolder := ServerPassword new. - pp isString - ifTrue: [passwordHolder cache: pp. ^ self]. - pp isInteger - ifTrue: [passwordHolder sequence: pp] - ifFalse: [passwordHolder := pp].! Item was removed: - ----- Method: ServerDirectory>>passwordSequence (in category 'accessing') ----- - passwordSequence - - ^passwordHolder - ifNotNil: [passwordHolder sequence]! Item was removed: - ----- Method: ServerDirectory>>passwordSequence: (in category 'accessing') ----- - passwordSequence: aNumber - - passwordHolder ifNil: [passwordHolder := ServerPassword new]. - passwordHolder sequence: aNumber! Item was removed: - ----- Method: ServerDirectory>>pathName (in category 'file directory') ----- - pathName - "Path name as used in reading the file. with slashes for ftp, with local file delimiter (:) for a file: url" - - urlObject ifNotNil: [^ urlObject pathForFile]. - directory size = 0 ifTrue: [^ server]. - ^ (directory at: 1) = self pathNameDelimiter - ifTrue: [server, directory] - ifFalse: [user, '@', server, self pathNameDelimiter asString, directory]! Item was removed: - ----- Method: ServerDirectory>>pathNameDelimiter (in category 'file directory') ----- - pathNameDelimiter - "the separator that is used in URLs" - - ^ $/! Item was removed: - ----- Method: ServerDirectory>>pathParts (in category 'file directory') ----- - pathParts - "Return the path from the root of the file system to this directory as an array of directory names. On a remote server." - - urlObject ifNotNil: [^ (urlObject path copy) removeLast; yourself]. - ^ (OrderedCollection with: server) addAll: - (directory findTokens: self pathNameDelimiter asString); - yourself. - ! Item was removed: - ----- Method: ServerDirectory>>postCopy (in category 'copying') ----- - postCopy - super postCopy. - self urlObject: urlObject copy! Item was removed: - ----- Method: ServerDirectory>>printOn: (in category 'accessing') ----- - printOn: aStrm - aStrm nextPutAll: self class name; nextPut: $<. - aStrm nextPutAll: self moniker. - aStrm nextPut: $>. - ! Item was removed: - ----- Method: ServerDirectory>>putFile:named: (in category 'up/download') ----- - putFile: fileStream named: fileNameOnServer - "Just FTP a local fileStream to the server. (Later -- Use a proxy server if one has been registered.)" - - client := self openFTPClient. - client binary. - [self switchDirectory. - client putFileStreamContents: fileStream as: fileNameOnServer] - ensure: [self quit]! Item was removed: - ----- Method: ServerDirectory>>putFile:named:retry: (in category 'up/download') ----- - putFile: fileStream named: fileNameOnServer retry: aBool - "ar 11/24/1998 Do the usual putFile:named: operation but retry if some error occurs and aBool is set. Added due to having severe transmission problems on shell.webpage.com." - | resp | - self isTypeFile ifTrue: [ - ^ (FileDirectory on: urlObject pathForDirectory) - putFile: fileStream named: fileNameOnServer]. - - [resp := [self putFile: fileStream named: fileNameOnServer] - ifError:[:err :rcvr| '5xx ',err]. "Report as error" - aBool and:[((resp isString) and: [resp size > 0]) and:[resp first ~= $2]]] whileTrue:[ - (self confirm:('Error storing ',fileNameOnServer,' on the server.\(',resp,',)\Retry operation?') withCRs) ifFalse:[^resp]. - ]. - ^resp! Item was removed: - ----- Method: ServerDirectory>>putFileSavingOldVersion:named: (in category 'up/download') ----- - putFileSavingOldVersion: fileStream named: fileNameOnServer - - | tempName oldName | - "Put a copy of this file out after saving the prior version. - Nothing happens to the old version until the new vers is successfully stored." - tempName := fileNameOnServer , '.beingWritten'. - oldName := fileNameOnServer , '.prior'. - self putFile: fileStream named: tempName retry: true. - (self includesKey: oldName) ifTrue: [self deleteFileNamed: oldName]. - self rename: fileNameOnServer toBe: oldName. - self rename: tempName toBe: fileNameOnServer. - ! Item was removed: - ----- Method: ServerDirectory>>quit (in category 'dis/connect') ----- - quit - "break the connection" - - self keepAlive - ifFalse: [self quitClient]! Item was removed: - ----- Method: ServerDirectory>>quitClient (in category 'dis/connect') ----- - quitClient - "break the connection" - - client ifNotNil: [client quit]. - client := nil! Item was removed: - ----- Method: ServerDirectory>>readOnlyFileNamed: (in category 'file directory') ----- - readOnlyFileNamed: aName - "If the file exists, answer a read-only RemoteFileStream on it. aName is directory path, and does include name of the server. Or it can just be a fileName. For now, pre-read the file." - - | rFile | - - rFile := self asServerFileNamed: aName. - rFile readOnly. - rFile isTypeFile ifTrue: [ - ^ FileStream oldFileNamed: (rFile fileNameRelativeTo: self)]. - - ^self streamOnBeginningOf: rFile! Item was removed: - ----- Method: ServerDirectory>>realUrl (in category 'accessing') ----- - realUrl - "a fully expanded version of the url we represent. Prefix the path with http: or ftp: or file:" - - self isTypeFile ifTrue: [ - self fileNameRelativeTo: self. - ^ urlObject asString - ]. - ^ self typeWithDefault asString, '://', self pathName - ! Item was removed: - ----- Method: ServerDirectory>>recursiveDelete (in category 'file-operations') ----- - recursiveDelete - "Delete the this directory, recursing down its tree." - self directoryNames - do: [:dn | (self directoryNamed: dn) recursiveDelete]. - self deleteLocalFiles. - "should really be some exception handling for directory deletion, but no - support for it yet" - self containingDirectory deleteDirectory: self localName! Item was removed: - ----- Method: ServerDirectory>>rename:toBe: (in category 'file directory') ----- - rename: fullName toBe: newName - "Rename a remote file. fullName is just be a fileName, or can be directory path that includes name of the server. newName is just a fileName" - | file | - - file := self asServerFileNamed: fullName. - file isTypeFile ifTrue: [ - (FileDirectory forFileName: (file fileNameRelativeTo: self)) - rename: file fileName toBe: newName - ]. - - client := self openFTPClient. - [client renameFileNamed: fullName to: newName] - ensure: [self quit]. - ! Item was removed: - ----- Method: ServerDirectory>>reset (in category 'multi-action sessions') ----- - reset - ! Item was removed: - ----- Method: ServerDirectory>>server (in category 'accessing') ----- - server - ^ server! Item was removed: - ----- Method: ServerDirectory>>server: (in category 'accessing') ----- - server: anObject - server := anObject! Item was removed: - ----- Method: ServerDirectory>>serverDelimiter (in category 'file directory') ----- - serverDelimiter - "the separator that is used in the place where the file actually is. ftp server or local disk." - - ^ self isTypeFile - ifTrue: [FileDirectory default pathNameDelimiter] - ifFalse: [$/] "for ftp, http"! Item was removed: - ----- Method: ServerDirectory>>slash (in category 'accessing') ----- - slash - ^'/'! Item was removed: - ----- Method: ServerDirectory>>slashDirectory (in category 'accessing') ----- - slashDirectory - - ^ directory first == $/ - ifTrue: [directory] - ifFalse: ['/', directory]! Item was removed: - ----- Method: ServerDirectory>>sleep (in category 'multi-action sessions') ----- - sleep - "If still connected, break the connection" - - self quitClient. - self keepAlive: false! Item was removed: - ----- Method: ServerDirectory>>splitName:to: (in category 'file directory') ----- - splitName: fullName to: pathAndNameBlock - "Take the file name and convert it to the path name of a directory and a local file name within that directory. FileName must be of the form: <dirPath><delimiter><localName>, where <dirPath><delimiter> is optional. The <dirPath> part may contain delimiters." - - | delimiter i dirName localName | - delimiter := self pathNameDelimiter. - (i := fullName findLast: [:c | c = delimiter]) = 0 - ifTrue: - [dirName := String new. - localName := fullName] - ifFalse: - [dirName := fullName copyFrom: 1 to: (i - 1 max: 1). - localName := fullName copyFrom: i + 1 to: fullName size]. - - ^ pathAndNameBlock value: dirName value: localName! Item was removed: - ----- Method: ServerDirectory>>storeServerEntryOn: (in category 'file-in/out') ----- - storeServerEntryOn: stream - - stream - nextPutAll: 'name:'; tab; nextPutAll: (ServerDirectory nameForServer: self); cr; - nextPutAll: 'directory:'; tab; nextPutAll: self directory; cr; - nextPutAll: 'type:'; tab; nextPutAll: self typeForPrefs; cr; - nextPutAll: 'server:'; tab; nextPutAll: self server; cr. - group - ifNotNil: [stream nextPutAll: 'group:'; tab; nextPutAll: self groupName; cr]. - self user - ifNotNil: [stream nextPutAll: 'user:'; tab; nextPutAll: self user; cr]. - self passwordSequence - ifNotNil: [stream nextPutAll: 'passwdseq:'; tab; nextPutAll: self passwordSequence asString; cr]. - self altUrl - ifNotNil: [stream nextPutAll: 'url:'; tab; nextPutAll: self altUrl; cr]. - self loaderUrl - ifNotNil: [stream nextPutAll: 'loaderUrl:'; tab; nextPutAll: self loaderUrl; cr]. - self acceptsUploads - ifTrue: [stream nextPutAll: 'acceptsUploads:'; tab; nextPutAll: 'true'; cr]. - self encodingName - ifNotNil: [stream nextPutAll: 'encodingName:'; tab; nextPutAll: self encodingName; cr].! Item was removed: - ----- Method: ServerDirectory>>streamOnBeginningOf: (in category 'file directory') ----- - streamOnBeginningOf: serverFile - - | remoteStrm | - remoteStrm := RemoteFileStream on: (String new: 2000). - remoteStrm remoteFile: serverFile. - serverFile getFileNamed: serverFile fileName into: remoteStrm. "prefetch data" - ^ remoteStrm! Item was removed: - ----- Method: ServerDirectory>>switchDirectory (in category 'initialize') ----- - switchDirectory - client changeDirectoryTo: directory! Item was removed: - ----- Method: ServerDirectory>>type: (in category 'accessing') ----- - type: aSymbol - type := aSymbol! Item was removed: - ----- Method: ServerDirectory>>typeForPrefs (in category 'accessing') ----- - typeForPrefs - - ^self typeWithDefault! Item was removed: - ----- Method: ServerDirectory>>typeWithDefault (in category 'accessing') ----- - typeWithDefault - - ^ type ifNil: [type := #ftp]! Item was removed: - ----- Method: ServerDirectory>>upLoadProject:members:retry: (in category 'squeaklets') ----- - upLoadProject: projectName members: archiveMembers retry: aBool - | dir m dirName | - 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 | - 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 removed: - ----- 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 | - 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 | - "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 removed: - ----- Method: ServerDirectory>>updateProjectInfoFor: (in category 'squeaklets') ----- - updateProjectInfoFor: aProject - - "only swiki servers for now"! Item was removed: - ----- Method: ServerDirectory>>url: (in category 'accessing') ----- - url: aString - altURL := aString! Item was removed: - ----- Method: ServerDirectory>>urlObject (in category 'accessing') ----- - urlObject - ^ urlObject! Item was removed: - ----- Method: ServerDirectory>>urlObject: (in category 'accessing') ----- - urlObject: aUrl - - urlObject := aUrl! Item was removed: - ----- Method: ServerDirectory>>user (in category 'accessing') ----- - user - ^ user! Item was removed: - ----- Method: ServerDirectory>>user: (in category 'accessing') ----- - user: anObject - user := anObject! Item was removed: - ----- Method: ServerDirectory>>wakeUp (in category 'multi-action sessions') ----- - wakeUp - "Start a multi-action session: Open for FTP and keep the connection open" - - self isTypeFTP - ifTrue: [client := self openFTPClient]. - self keepAlive: true - ! Item was removed: - ----- Method: ServerDirectory>>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)" - aProject - writeFileNamed: fileNameString - fromDirectory: localDirectory - toServer: self! Item was removed: - ServerDirectory subclass: #ServerFile - instanceVariableNames: 'fileName rwmode' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-RemoteDirectory'! - - !ServerFile commentStamp: '<historical>' prior: 0! - Represents the non-data part of a file on a server on the internet. I am owned by a RemoteFileStream, who has the data. - - Since FileStream is a Stream and I am not, use this to always get a stream: - xxx isStream ifFalse: [^ xxx asStream]. - - ! Item was removed: - ----- Method: ServerFile>>asStream (in category 'converting') ----- - asStream - "Return a RemoteFileStream (subclass of RWBinaryOrTextStream) on the contents of the remote file I represent. For reading only. This method is probably misnamed. Maybe call it makeStream" - - ^ self readOnlyFileNamed: self fileName! Item was removed: - ----- Method: ServerFile>>directoryUrl (in category 'accessing') ----- - directoryUrl - | ru | - "A url to the directory this file is in" - - ru := self realUrl. - ^ ru copyFrom: 1 to: (ru size - fileName size)! Item was removed: - ----- Method: ServerFile>>exists (in category 'file directory') ----- - exists - "Return true if the file exists on the server already" - - ^ self fileExists: fileName! Item was removed: - ----- Method: ServerFile>>fileName (in category 'accessing') ----- - fileName - "should this be local or as in a url?" - - urlObject ifNotNil: [^ urlObject path last]. "path last encodeForHTTP ?" - ^ fileName! Item was removed: - ----- Method: ServerFile>>fileName: (in category 'accessing') ----- - fileName: aString - - urlObject ~~ nil "type == #file" - ifTrue: [urlObject path at: urlObject path size put: aString] - ifFalse: [fileName := aString]! Item was removed: - ----- Method: ServerFile>>fileNameRelativeTo: (in category 'accessing') ----- - fileNameRelativeTo: aServerDir - "Produce an absolute fileName from me and an absolute directory" - urlObject isAbsolute ifFalse: [ - (aServerDir urlObject ~~ nil and: [aServerDir urlObject isAbsolute]) - ifTrue: [urlObject - privateInitializeFromText: urlObject pathString - relativeTo: aServerDir urlObject] - ifFalse: [urlObject default]]. "relative to Squeak directory" - ^ urlObject pathForDirectory, self fileName! Item was removed: - ----- Method: ServerFile>>fullPath: (in category 'accessing') ----- - fullPath: serverAndDirectory - "Parse and save a full path. Separate out fileName at the end." - - | delim ii | - super fullPath: serverAndDirectory. "set server and directory" - self isTypeFile ifTrue: [ - fileName := ''. - ^ self - ]. - delim := self pathNameDelimiter. - ii := directory findLast: [:c | c = delim]. - ii = 0 - ifTrue: [self error: 'expecting directory and fileName'] - ifFalse: [fileName := directory copyFrom: ii+1 to: directory size. - directory := (directory copyFrom: 1 to: directory size - fileName size - 1)].! Item was removed: - ----- Method: ServerFile>>localName (in category 'file directory') ----- - localName - - ^ self fileName! Item was removed: - ----- Method: ServerFile>>readOnly (in category 'file modes') ----- - readOnly - "Set the receiver to be read-only" - - rwmode := false! Item was removed: - ----- Method: ServerFile>>readWrite (in category 'file modes') ----- - readWrite - "Set the receiver to be writable" - - rwmode := true! Item was removed: - ----- Method: ServerFile>>realUrl (in category 'accessing') ----- - realUrl - "a fully expanded version of the url we represent. Prefix the path with http: or ftp: or file:" - - self isTypeFile ifTrue: [ - self fileNameRelativeTo: self. - ^ urlObject asString - ]. - ^ self typeWithDefault asString, '://', self pathName, '/', fileName "note difference!!" - ! Item was removed: - ----- Method: ServerFile>>writable (in category 'file modes') ----- - writable - ^ rwmode! Item was removed: - Password subclass: #ServerPassword - instanceVariableNames: 'sequence' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-Kernel'! - - !ServerPassword commentStamp: 'cbc 6/7/2019 11:15' prior: 0! - "Hold a password. There are three ways to get the password. - - If there is no password (sequence == nil), ask the user for it. - - If the user supplied one during this session, return that. It is cleared at shutDown. - - If sequence is a number, get the server passwords off the disk. File 'sqk.info' must be in the same folder 'Squeak.sources' file. Decode the file. Return the password indexed by sequence."! Item was removed: - ----- Method: ServerPassword>>cache: (in category 'accessing') ----- - cache: anObject - cache := anObject! Item was removed: - ----- Method: ServerPassword>>passwordFor: (in category 'accessing') ----- - passwordFor: serverDir - "Returned the password from one of many sources. OK if send in a nil arg." - - | sp msg | - cache ifNotNil: [^ cache]. - sequence ifNotNil: [ - (sp := self serverPasswords) ifNotNil: [ - sequence <= sp size ifTrue: [^ sp at: sequence]]]. - msg := serverDir isRemoteDirectory - ifTrue: [serverDir moniker] - ifFalse: ['this directory']. - (serverDir user = 'anonymous') & (serverDir typeWithDefault == #ftp) ifTrue: [ - ^ cache := UIManager default request: 'Please let this anonymous ftp\server know your email address.\This is the polite thing to do.' withCRs - initialAnswer: 'yourName at company.com']. - - ^ cache := UIManager default requestPassword: 'Password for ', serverDir user, ' at ', msg, ':'. - "Diff between empty string and abort?"! Item was removed: - ----- Method: ServerPassword>>sequence (in category 'accessing') ----- - sequence - ^sequence! Item was removed: - ----- Method: ServerPassword>>sequence: (in category 'accessing') ----- - sequence: anNumber - sequence := anNumber! Item was removed: - ----- Method: ServerPassword>>serverPasswords (in category 'accessing') ----- - serverPasswords - "Get the server passwords off the disk and decode them. The file 'sqk.info' must be in some folder that Squeak thinks is special (vm folder, or default directory). (Note: This code works even if you are running with no system sources file.)" - - | sfile | - (sfile := FileDirectory lookInUsualPlaces: 'sqk.info') ifNil: [^ nil]. - "If not there, Caller will ask user for password" - "If you don't have this file, and you really do want to release an update, - contact Ted Kaehler." - ^ (self decode: (sfile contentsOfEntireFile)) lines - ! Item was removed: - Object subclass: #Socket - instanceVariableNames: 'semaphore socketHandle readSemaphore writeSemaphore family' - classVariableNames: 'Connected DeadServer DefaultReceiveBufferSize DefaultSendBufferSize InvalidSocket MaximumReadSemaphoreWaitTimeout OtherEndClosed Registry TCPSocketType ThisEndClosed UDPSocketType Unconnected WaitingForConnection' - poolDictionaries: '' - category: 'Network-Kernel'! - - !Socket commentStamp: 'gk 12/13/2005 00:43' prior: 0! - A Socket represents a network connection point. Current sockets are designed to support the TCP/IP and UDP protocols. Sockets are the lowest level of networking object in Squeak and are not normally used directly. SocketStream is a higher level object wrapping a Socket in a stream like protocol. - - ProtocolClient and subclasses are in turn wrappers around a SocketStream to provide support for specific network protocols such as POP, NNTP, HTTP, and FTP.! Item was removed: - ----- Method: Socket class>>acceptFrom: (in category 'instance creation') ----- - acceptFrom: aSocket - ^[ super new acceptFrom: aSocket ] - repeatWithGCIf: [ :sock | sock isValid not ]! Item was removed: - ----- Method: Socket class>>createIfFail: (in category 'instance creation') ----- - createIfFail: failBlock - "Attempt to create a new socket. If successful, return the new socket. Otherwise, return the result of evaluating the given block. Socket creation can fail if the network isn't available or if there are not sufficient resources available to create another socket." - "Note: The default creates a TCP socket" - ^self tcpCreateIfFail: failBlock! Item was removed: - ----- Method: Socket class>>deadServer (in category 'utilities') ----- - deadServer - - ^ DeadServer! Item was removed: - ----- Method: Socket class>>deadServer: (in category 'utilities') ----- - deadServer: aStringOrNil - "Keep the machine name of the most recently encoutered non-responding machine. Next time the user can move it to the last in a list of servers to try." - - DeadServer := aStringOrNil! Item was removed: - ----- Method: Socket class>>deadlineSecs: (in category 'utilities') ----- - deadlineSecs: secs - "Answer a deadline time in milliseconds a given number of seconds from now. - Note that because the millisecondClockValue is derived from the non-wrapping - 61-bit microsecond clock there is no roll over issue." - - ^Time millisecondClockValue + (secs * 1000) truncated - ! Item was removed: - ----- Method: Socket class>>initialize (in category 'class initialization') ----- - initialize - "Socket initialize" - - "Socket Types" - TCPSocketType := 0. - UDPSocketType := 1. - - "Socket Status Values" - InvalidSocket := -1. - Unconnected := 0. - WaitingForConnection := 1. - Connected := 2. - OtherEndClosed := 3. - ThisEndClosed := 4. - - "Default buffer sizes" - DefaultReceiveBufferSize := 8192. - DefaultSendBufferSize := 8192! Item was removed: - ----- Method: Socket class>>initializeNetwork (in category 'network initialization') ----- - initializeNetwork - "Initialize the network drivers and the NetNameResolver. Do nothing if the network is already initialized." - "Note: The network must be re-initialized every time Squeak starts up, so applications that persist across snapshots should be prepared to re-initialize the network as needed. Such applications should call 'Socket initializeNetwork' before every network transaction. " - - NetNameResolver initializeNetwork! Item was removed: - ----- Method: Socket class>>loopbackTest (in category 'tests') ----- - loopbackTest - "Send data from one socket to another on the local machine. - Tests most of the socket primitives." - - "100 timesRepeat: [Socket loopbackTest]" - - | sock1 sock2 bytesToSend sendBuf receiveBuf done bytesSent bytesReceived t extraBytes packetsSent packetsRead | - Transcript - cr; - show: 'starting loopback test'; - cr. - Transcript - show: '---------- Connecting ----------'; - cr. - self initializeNetwork. - sock1 := self new. - sock2 := self new. - sock1 listenOn: 54321. - sock2 connectTo: NetNameResolver localHostAddress port: 54321. - sock1 waitForConnectionFor: self standardTimeout. - sock2 waitForConnectionFor: self standardTimeout. - sock1 isConnected ifFalse: [self error: 'sock1 not connected']. - sock2 isConnected ifFalse: [self error: 'sock2 not connected']. - Transcript - show: 'connection established'; - cr. - bytesToSend := 5000000. - sendBuf := String new: 5000 withAll: $x. - receiveBuf := String new: 50000. - done := false. - packetsSent := packetsRead := bytesSent := bytesReceived := 0. - t := Time millisecondsToRun: - [[done] whileFalse: - [(sock1 sendDone and: [bytesSent < bytesToSend]) - ifTrue: - [packetsSent := packetsSent + 1. - bytesSent := bytesSent + (sock1 sendSomeData: sendBuf)]. - sock2 dataAvailable - ifTrue: - [packetsRead := packetsRead + 1. - bytesReceived := bytesReceived + (sock2 receiveDataInto: receiveBuf)]. - done := bytesSent >= bytesToSend and: [bytesReceived = bytesSent]]]. - Transcript - show: 'closing connection'; - cr. - sock1 waitForSendDoneFor: self standardTimeout. - sock1 close. - sock2 waitForDisconnectionFor: self standardTimeout. - extraBytes := sock2 discardReceivedData. - extraBytes > 0 - ifTrue: - [Transcript - show: ' *** received ' , extraBytes size printString , ' extra bytes ***'; - cr]. - sock2 close. - sock1 waitForDisconnectionFor: self standardTimeout. - sock1 isUnconnectedOrInvalid ifFalse: [self error: 'sock1 not closed']. - sock2 isUnconnectedOrInvalid ifFalse: [self error: 'sock2 not closed']. - Transcript - show: '---------- Connection Closed ----------'; - cr. - sock1 destroy. - sock2 destroy. - Transcript - show: 'loopback test done; time = ' , t printString; - cr. - Transcript - show: (bytesToSend asFloat / t printShowingMaxDecimalPlaces: 2), '* 1000 bytes/sec'; - cr. - Transcript endEntry! Item was removed: - ----- Method: Socket class>>maximumReadSemaphoreWaitTimeout (in category 'preferences') ----- - maximumReadSemaphoreWaitTimeout - - <preference: 'Maximum readSemaphore wait timeout.' - category: 'general' - description: 'The number of milliseconds for which we''ll wait for the readSemaphore of a Socket to signal. This is used by a workaround for a VM bug. Lower values use more CPU, but result in less delay in extremal cases.' - type: #Number> - ^MaximumReadSemaphoreWaitTimeout ifNil: [ 500 ]! Item was removed: - ----- Method: Socket class>>maximumReadSemaphoreWaitTimeout: (in category 'preferences') ----- - maximumReadSemaphoreWaitTimeout: anInteger - "The number of milliseconds for which we'll wait for the readSemaphore to signal. This is used by a workaround for a VM bug." - - MaximumReadSemaphoreWaitTimeout := anInteger! Item was removed: - ----- Method: Socket class>>nameForWellKnownTCPPort: (in category 'utilities') ----- - nameForWellKnownTCPPort: portNum - "Answer the name for the given well-known TCP port number. Answer a string containing the port number if it isn't well-known." - - | portList entry | - portList := #( - (7 'echo') (9 'discard') (13 'time') (19 'characterGenerator') - (21 'ftp') (23 'telnet') (25 'smtp') - (80 'http') (110 'pop3') (119 'nntp')). - entry := portList detect: [:pair | pair first = portNum] ifNone: [^ 'port-', portNum printString]. - ^ entry last - ! Item was removed: - ----- Method: Socket class>>new (in category 'instance creation') ----- - new - "Return a new, unconnected Socket. Note that since socket creation may fail, it is safer to use the method createIfFail: to handle such failures gracefully; this method is primarily for backward compatibility and may be disallowed in a future release." - "Note: The default creates a TCP socket - this is also backward compatibility." - ^self newTCP! Item was removed: - ----- Method: Socket class>>newAcceptCheck (in category 'tests') ----- - newAcceptCheck - "Check if the platform has support for the BSD style accept()." - - "Socket newAcceptCheck" - - | socket | - self initializeNetwork. - socket := self newTCP. - socket listenOn: 44444 backlogSize: 4. - socket isValid ifTrue: [ - self inform: 'Everything looks OK for the BSD style accept()' - ] ifFalse: [ - self inform: 'It appears that you DO NOT have support for the BSD style accept()']. - socket destroy! Item was removed: - ----- Method: Socket class>>newTCP (in category 'instance creation') ----- - newTCP - "Create a socket and initialise it for TCP" - ^self newTCP: SocketAddressInformation addressFamilyINET4! Item was removed: - ----- Method: Socket class>>newTCP: (in category 'instance creation') ----- - newTCP: family - "Create a socket and initialise it for TCP" - self initializeNetwork. - ^[ super new initialize: TCPSocketType family: family ] - repeatWithGCIf: [ :socket | socket isValid not ]! Item was removed: - ----- Method: Socket class>>newUDP (in category 'instance creation') ----- - newUDP - "Create a socket and initialise it for UDP" - ^self newUDP: SocketAddressInformation addressFamilyINET4! Item was removed: - ----- Method: Socket class>>newUDP: (in category 'instance creation') ----- - newUDP: family - "Create a socket and initialise it for UDP" - self initializeNetwork. - ^[ super new initialize: UDPSocketType family: family ] - repeatWithGCIf: [ :socket | socket isValid not ]! Item was removed: - ----- Method: Socket class>>ping: (in category 'utilities') ----- - 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'. - ! Item was removed: - ----- 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.org' timeOutSecs: 15" - - | serverAddr sockets startTime timeoutMsecs done result unconnectedCount connectedCount waitingCount | - serverAddr := NetNameResolver addressForName: hostName timeout: 10. - serverAddr ifNil: [ - self inform: 'Could not find an address for ' , hostName. - ^ #() ]. - sockets := portList - collect: [ :portNum | - | sock | - sock := Socket new. - [ sock connectTo: serverAddr port: portNum ] - on: ConnectionTimedOut - do: [ ]. - sock ]. - startTime := Time millisecondClockValue. - timeoutMsecs := (1000 * timeOutSecs) truncated. - 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 millisecondsSince: startTime) >= timeoutMsecs - ifTrue: [ done := true ] ]. - result := (sockets select: [ :s | s isConnected ]) collect: [ :s | self nameForWellKnownTCPPort: s remotePort ]. - sockets do: [ :s | s destroy ]. - ^ result! Item was removed: - ----- Method: Socket class>>pingPortsOn: (in category 'utilities') ----- - pingPortsOn: hostName - "Attempt to connect to a set of well-known sockets on the given host, and answer the names of the available ports." - "Socket pingPortsOn: 'www.disney.com'" - - ^ Socket - pingPorts: #(7 13 19 21 23 25 80 110 119) - on: hostName - timeOutSecs: 20 - ! Item was removed: - ----- Method: Socket class>>primInitializeNetwork: (in category 'network initialization') ----- - primInitializeNetwork: resolverSemaIndex - "Initialize the network drivers on platforms that need it, such as the Macintosh, and return nil if network initialization failed or the reciever if it succeeds. Since mobile computers may not always be connected to a network, this method should NOT be called automatically at startup time; rather, it should be called when first starting a networking application. It is a noop if the network driver has already been initialized. If non-zero, resolverSemaIndex is the index of a VM semaphore to be associated with the network name resolver. This semaphore will be signalled when the resolver status changes, such as when a name lookup query is completed." - "Note: some platforms (e.g., Mac) only allow only one name lookup query at a time, so a manager process should be used to serialize resolver lookup requests." - - <primitive: 'primitiveInitializeNetwork' module: 'SocketPlugin'> - ^ nil "return nil if primitive fails" - ! Item was removed: - ----- Method: Socket class>>register: (in category 'registry') ----- - register: anObject - - ^self registry add: anObject! Item was removed: - ----- Method: Socket class>>registry (in category 'registry') ----- - registry - - ^Registry ifNil: [ Registry := WeakRegistry new ]! Item was removed: - ----- Method: Socket class>>sendTest (in category 'tests') ----- - 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 := UIManager default request: 'What is the destination server?' initialAnswer: 'create.ucsb.edu'. - serverAddr := NetNameResolver addressForName: serverName timeout: 10. - serverAddr = nil - ifTrue: [^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 printShowingMaxDecimalPlaces: 2), ' * 1000 bytes/sec';cr;endEntry! Item was removed: - ----- Method: Socket class>>standardDeadline (in category 'utilities') ----- - standardDeadline - "Return a default deadline time some seconds into the future." - - ^ self deadlineSecs: self standardTimeout - ! Item was removed: - ----- Method: Socket class>>standardTimeout (in category 'utilities') ----- - standardTimeout - - ^45 - ! Item was removed: - ----- Method: Socket class>>tcpCreateIfFail: (in category 'instance creation') ----- - tcpCreateIfFail: failBlock - "Attempt to create a new socket. If successful, return the new socket. Otherwise, return the result of evaluating the given block. Socket creation can fail if the network isn't available or if there are not sufficient resources available to create another socket." - - | sock | - self initializeNetwork. - sock := self newTCP. - sock isValid ifFalse: [^ failBlock value]. - ^ sock - ! Item was removed: - ----- Method: Socket class>>timeTest (in category 'examples') ----- - timeTest - "Socket timeTest" - - | serverName serverAddr s | - Transcript show: 'initializing network ... '. - self initializeNetwork. - Transcript - show: 'ok'; - cr. - serverName := UIManager default request: 'What is your time server?' - initialAnswer: 'localhost'. - serverName isEmpty - ifTrue: - [^Transcript - show: 'never mind'; - cr]. - serverAddr := NetNameResolver addressForName: serverName timeout: 10. - serverAddr = nil - ifTrue: [self error: 'Could not find the address for ' , serverName]. - s := self new. - Transcript - show: '---------- Connecting ----------'; - cr. - s connectTo: serverAddr port: 13. "13 is the 'daytime' port number" - s waitForConnectionUntil: (self deadlineSecs: 1). - Transcript show: 'the time server reports: ' , s receiveData. - s closeAndDestroy. - Transcript - show: '---------- Connection Closed ----------'; - cr! Item was removed: - ----- Method: Socket class>>timeTestUDP (in category 'examples') ----- - timeTestUDP - "Socket timeTestUDP" - - | serverName serverAddr s | - Transcript show: 'initializing network ... '. - self initializeNetwork. - Transcript - show: 'ok'; - cr. - serverName := UIManager default request: 'What is your time server?' - initialAnswer: 'localhost'. - serverName isEmpty - ifTrue: - [^Transcript - show: 'never mind'; - cr]. - serverAddr := NetNameResolver addressForName: serverName timeout: 10. - serverAddr = nil - ifTrue: [self error: 'Could not find the address for ' , serverName]. - s := self newUDP. "a 'random' port number will be allocated by the system" - "Send a packet to the daytime port and it will reply with the current date." - Transcript - show: '---------- Sending datagram from port ' , s port printString - , ' ----------'; - cr. - s - sendData: '!!' - toHost: serverAddr - port: 13. "13 is the daytime service" - Transcript show: 'the time server reports: ' , s receiveData. - s closeAndDestroy. - Transcript - show: '---------- Socket closed ----------'; - cr! Item was removed: - ----- Method: Socket class>>udpCreateIfFail: (in category 'instance creation') ----- - udpCreateIfFail: failBlock - "Attempt to create a new socket. If successful, return the new socket. Otherwise, return the result of evaluating the given block. Socket creation can fail if the network isn't available or if there are not sufficient resources available to create another socket." - - | sock | - self initializeNetwork. - sock := self newUDP. - sock isValid ifFalse: [^ failBlock value]. - ^ sock - ! Item was removed: - ----- Method: Socket class>>unregister: (in category 'registry') ----- - unregister: anObject - - ^self registry remove: anObject ifAbsent: nil! Item was removed: - ----- Method: Socket class>>wildcardAddress (in category 'utilities') ----- - wildcardAddress - "Answer a don't-care address for use with UDP sockets." - - ^ByteArray new: 4 "0.0.0.0"! Item was removed: - ----- Method: Socket class>>wildcardPort (in category 'utilities') ----- - wildcardPort - "Answer a don't-care port for use with UDP sockets. (The system will allocate an - unused port number to the socket.)" - - ^0! Item was removed: - ----- Method: Socket>>accept (in category 'connection open/close') ----- - accept - "Accept a connection from the receiver socket. - Return a new socket that is connected to the client" - ^Socket acceptFrom: self.! Item was removed: - ----- Method: Socket>>acceptFrom: (in category 'initialize-destroy') ----- - acceptFrom: aSocket - "Initialize a new socket handle from an accept call" - - self initializeSocketHandleUsing: [ :semaIndex :readSemaIndex :writeSemaIndex | - self - primAcceptFrom: aSocket socketHandle - receiveBufferSize: DefaultReceiveBufferSize - sendBufSize: DefaultSendBufferSize - semaIndex: semaIndex - readSemaIndex: readSemaIndex - writeSemaIndex: writeSemaIndex ]! Item was removed: - ----- Method: Socket>>address (in category 'accessing') ----- - address - "Shortcut" - ^self localAddress! Item was removed: - ----- Method: Socket>>addressFamily (in category 'accessing') ----- - addressFamily - ^family! Item was removed: - ----- Method: Socket>>bindTo: (in category 'ipv6') ----- - bindTo: aSocketAddress - - | status | - self initializeNetwork. - status := self primSocketConnectionStatus: socketHandle. - (status == Unconnected) - ifFalse: [InvalidSocketStatusException signal: 'Socket status must Unconnected when binding it to an address']. - - self primSocket: socketHandle bindTo: aSocketAddress. - ! Item was removed: - ----- Method: Socket>>close (in category 'connection open/close') ----- - close - "Close this connection gracefully. For TCP, this sends a close request, but the stream remains open until the other side also closes it." - - self primSocketCloseConnection: socketHandle. "close this end" - ! Item was removed: - ----- Method: Socket>>closeAndDestroy (in category 'connection open/close') ----- - closeAndDestroy - "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)." - - self closeAndDestroy: 20. - - ! Item was removed: - ----- 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 ifNil: [ ^self ]. - self isConnected ifTrue: [ - self close. "Close this end.". - (self waitForDisconnectionFor: timeoutSeconds) ifFalse: [ - "The other end has not closed the connect yet, so we will just abort it." - self primSocketAbortConnection: socketHandle ] ]. - self destroy! Item was removed: - ----- Method: Socket>>connectNonBlockingTo: (in category 'ipv6') ----- - connectNonBlockingTo: aSocketAddress - - | status | - self initializeNetwork. - status := self primSocketConnectionStatus: socketHandle. - (status == Unconnected) - ifFalse: [InvalidSocketStatusException signal: 'Socket status must Unconnected before opening a new connection']. - - self primSocket: socketHandle connectTo: aSocketAddress. - ! Item was removed: - ----- Method: Socket>>connectNonBlockingTo:port: (in category 'connection open/close') ----- - connectNonBlockingTo: hostAddress port: port - "Initiate a connection to the given port at the given host address. This operation will return immediately; follow it with waitForConnectionUntil: to wait until the connection is established." - - | status | - self initializeNetwork. - status := self primSocketConnectionStatus: socketHandle. - (status == Unconnected) - ifFalse: [InvalidSocketStatusException signal: 'Socket status must Unconnected before opening a new connection']. - - NetNameResolver useOldNetwork - ifTrue: [self primSocket: socketHandle connectTo: hostAddress port: port] - ifFalse: [ | socketAddress | - socketAddress := hostAddress asSocketAddress. - socketAddress port: port. - self connectNonBlockingTo: socketAddress]! Item was removed: - ----- Method: Socket>>connectTo: (in category 'ipv6') ----- - connectTo: aSocketAddress - - self connectTo: aSocketAddress waitForConnectionFor: Socket standardTimeout! Item was removed: - ----- Method: Socket>>connectTo:port: (in category 'connection open/close') ----- - connectTo: hostAddress port: port - "Initiate a connection to the given port at the given host address. - Waits until the connection is established or time outs." - - NetNameResolver useOldNetwork - ifTrue: [self connectTo: hostAddress port: port waitForConnectionFor: Socket standardTimeout] - ifFalse: [ | socketAddress | - socketAddress := hostAddress asSocketAddress. - socketAddress port: port. - self connectTo: socketAddress]! Item was removed: - ----- Method: Socket>>connectTo:port:waitForConnectionFor: (in category 'connection open/close') ----- - connectTo: hostAddress port: port waitForConnectionFor: timeout - "Initiate a connection to the given port at the given host - address. Waits until the connection is established or time outs." - self connectNonBlockingTo: hostAddress port: port. - self - waitForConnectionFor: timeout - ifTimedOut: [ConnectionTimedOut signal: ('Cannot connect to {1}' translated format: {hostAddress printString})] - ifRefused: [ConnectionRefused signal: ('Cannot connect to {1}' translated format: {hostAddress printString})]! Item was removed: - ----- Method: Socket>>connectTo:waitForConnectionFor: (in category 'ipv6') ----- - connectTo: aSocketAddress waitForConnectionFor: timeout - - self connectNonBlockingTo: aSocketAddress. - self - waitForConnectionFor: timeout - ifTimedOut: [ConnectionTimedOut signal: ('Cannot connect to {1}' translated format: {aSocketAddress})] - ifRefused: [ConnectionRefused signal: ('Cannot connect to {1}' translated format: {aSocketAddress})]! Item was removed: - ----- Method: Socket>>connectToHostNamed:port: (in category 'connection open/close') ----- - connectToHostNamed: hostName port: portNumber - | serverIP | - serverIP := NetNameResolver addressForName: hostName timeout: 20. - ^self connectTo: serverIP port: portNumber - ! Item was removed: - ----- Method: Socket>>dataAvailable (in category 'queries') ----- - dataAvailable - "Return true if this socket has unread received data." - - socketHandle == nil ifTrue: [^ false]. - ^ self primSocketReceiveDataAvailable: socketHandle - ! Item was removed: - ----- Method: Socket>>destroy (in category 'initialize-destroy') ----- - 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 unregisterExternalObjects: { - semaphore. - readSemaphore. - writeSemaphore }. - socketHandle := nil. - readSemaphore := writeSemaphore := semaphore := nil. - self unregister ]! Item was removed: - ----- Method: Socket>>discardReceivedData (in category 'receiving') ----- - discardReceivedData - "Discard any data received up until now, and return the number of bytes discarded." - - | buf totalBytesDiscarded | - buf := String new: 10000. - totalBytesDiscarded := 0. - [self isConnected and: [self dataAvailable]] whileTrue: [ - totalBytesDiscarded := - totalBytesDiscarded + (self receiveDataInto: buf)]. - ^ totalBytesDiscarded - ! Item was removed: - ----- Method: Socket>>disconnect (in category 'connection open/close') ----- - disconnect - "Break this connection, no matter what state it is in. Data that has been sent but not received will be lost." - - self primSocketAbortConnection: socketHandle. - ! Item was removed: - ----- Method: Socket>>finalize (in category 'finalization') ----- - finalize - - self primSocketDestroyGently: socketHandle. - Smalltalk unregisterExternalObjects: { - semaphore. - readSemaphore. - writeSemaphore } - ! Item was removed: - ----- Method: Socket>>getOption: (in category 'other') ----- - getOption: aName - "Get options on this socket, see Unix man pages for values for - sockets, IP, TCP, UDP. IE SO_KEEPALIVE - returns an array, element one is an status number (0 ok, -1 read only option) - element two is the resulting of the requested option" - - (socketHandle == nil or: [self isValid not]) - ifTrue: [InvalidSocketStatusException signal: 'Socket status must valid before getting an option']. - ^self primSocket: socketHandle getOption: aName - - "| foo options | - Socket initializeNetwork. - foo := Socket newTCP. - foo connectTo: (NetNameResolver addressFromString: '192.168.1.1') port: 80. - foo waitForConnectionUntil: (Socket standardDeadline). - - options := { - 'SO_DEBUG'. 'SO_REUSEADDR'. 'SO_REUSEPORT'. 'SO_DONTROUTE'. - 'SO_BROADCAST'. 'SO_SNDBUF'. 'SO_RCVBUF'. 'SO_KEEPALIVE'. - 'SO_OOBINLINE'. 'SO_PRIORITY'. 'SO_LINGER'. 'SO_RCVLOWAT'. - 'SO_SNDLOWAT'. 'IP_TTL'. 'IP_HDRINCL'. 'IP_RCVOPTS'. - 'IP_RCVDSTADDR'. 'IP_MULTICAST_IF'. 'IP_MULTICAST_TTL'. - 'IP_MULTICAST_LOOP'. 'UDP_CHECKSUM'. 'TCP_MAXSEG'. - 'TCP_NODELAY'. 'TCP_ABORT_THRESHOLD'. 'TCP_CONN_NOTIFY_THRESHOLD'. - 'TCP_CONN_ABORT_THRESHOLD'. 'TCP_NOTIFY_THRESHOLD'. - 'TCP_URGENT_PTR_TYPE'}. - - 1 to: options size do: [:i | | fum | - fum :=foo getOption: (options at: i). - Transcript show: (options at: i),fum printString;cr]. - - foo := Socket newUDP. - foo setPeer: (NetNameResolver addressFromString: '192.168.1.9') port: 7. - foo waitForConnectionUntil: (Socket standardDeadline). - - 1 to: options size do: [:i | | fum | - fum :=foo getOption: (options at: i). - Transcript show: (options at: i),fum printString;cr]. - "! Item was removed: - ----- Method: Socket>>initialize: (in category 'initialize-destroy') ----- - initialize: socketType - "Initialize a new socket handle. If socket creation fails, socketHandle will be set to nil." - - self initializeSocketHandleUsing: [ :semaIndex :readSemaIndex :writeSemaIndex | - self primSocketCreateNetwork: 0 - type: socketType - receiveBufferSize: DefaultReceiveBufferSize - sendBufSize: DefaultSendBufferSize - semaIndex: semaIndex - readSemaIndex: readSemaIndex - writeSemaIndex: writeSemaIndex ]! Item was removed: - ----- Method: Socket>>initialize:family: (in category 'initialize-destroy') ----- - initialize: socketType family: addressFamily - "Initialize a new socket handle. If socket creation fails, socketHandle will be set to nil." - - family := addressFamily. - NetNameResolver useOldNetwork ifTrue: [ ^self initialize: socketType ]. - self initializeSocketHandleUsing: [ :semaIndex :readSemaIndex :writeSemaIndex | - self primSocketCreateNetwork: family - type: socketType - receiveBufferSize: DefaultReceiveBufferSize - sendBufSize: DefaultSendBufferSize - semaIndex: semaIndex - readSemaIndex: readSemaIndex - writeSemaIndex: writeSemaIndex ]! Item was removed: - ----- Method: Socket>>initializeNetwork (in category 'initialize-destroy') ----- - initializeNetwork - self class initializeNetwork! Item was removed: - ----- Method: Socket>>initializeSocketHandleUsing: (in category 'initialize-destroy') ----- - initializeSocketHandleUsing: aBlock - "Initialize a new socket handle. If socket creation fails, socketHandle will be set to nil." - - | semaphoresAndIndexes semaphores indexes | - semaphoresAndIndexes := Smalltalk newExternalSemaphores: 3. - semaphores := semaphoresAndIndexes at: 1. - indexes := semaphoresAndIndexes at: 2. - semaphore := semaphores at: 1. - readSemaphore := semaphores at: 2. - writeSemaphore := semaphores at: 3. - (socketHandle := aBlock valueWithArguments: indexes) - ifNotNil: [ self register ] - ifNil: [ - "socket creation failed" - semaphore := readSemaphore := writeSemaphore := nil. - Smalltalk unregisterExternalObjects: semaphores ]! Item was removed: - ----- Method: Socket>>isConnected (in category 'queries') ----- - isConnected - "Return true if this socket is connected." - - socketHandle == nil ifTrue: [^ false]. - ^ (self primSocketConnectionStatus: socketHandle) == Connected - ! Item was removed: - ----- Method: Socket>>isOtherEndClosed (in category 'queries') ----- - isOtherEndClosed - "Return true if this socket had the other end closed." - - socketHandle == nil ifTrue: [^ false]. - ^ (self primSocketConnectionStatus: socketHandle) == OtherEndClosed - ! Item was removed: - ----- Method: Socket>>isOtherEndConnected (in category 'queries') ----- - isOtherEndConnected - "Return true if this socket is connected, or this end has closed the connection but not the other end, so we can still receive data." - - | state | - socketHandle ifNil: [ ^false ]. - (state := self primSocketConnectionStatus: socketHandle) == Connected ifTrue: [ ^true ]. - ^state == ThisEndClosed - ! Item was removed: - ----- Method: Socket>>isThisEndClosed (in category 'queries') ----- - isThisEndClosed - "Return true if this socket had the this end closed." - - socketHandle == nil ifTrue: [^ false]. - ^ (self primSocketConnectionStatus: socketHandle) == ThisEndClosed - ! Item was removed: - ----- Method: Socket>>isThisEndConnected (in category 'queries') ----- - isThisEndConnected - "Return true if this socket is connected, other the other end has closed the connection but not this end, so we can still send data." - - | state | - socketHandle ifNil: [ ^false ]. - (state := self primSocketConnectionStatus: socketHandle) == Connected ifTrue: [ ^true ]. - ^state == OtherEndClosed - ! Item was removed: - ----- Method: Socket>>isUnconnected (in category 'queries') ----- - isUnconnected - "Return true if this socket's state is Unconnected." - - socketHandle == nil ifTrue: [^ false]. - ^ (self primSocketConnectionStatus: socketHandle) == Unconnected - ! Item was removed: - ----- Method: Socket>>isUnconnectedOrInvalid (in category 'queries') ----- - isUnconnectedOrInvalid - "Return true if this socket is completely disconnected or is invalid." - - | status | - socketHandle == nil ifTrue: [^ true]. - status := self primSocketConnectionStatus: socketHandle. - ^ (status = Unconnected) | (status = InvalidSocket) - ! Item was removed: - ----- Method: Socket>>isValid (in category 'queries') ----- - isValid - "Return true if this socket contains a valid, non-nil socket handle." - - | status | - socketHandle == nil ifTrue: [^ false]. - status := self primSocketConnectionStatus: socketHandle. - ^ status ~= InvalidSocket - ! Item was removed: - ----- Method: Socket>>isWaitingForConnection (in category 'queries') ----- - isWaitingForConnection - "Return true if this socket is waiting for a connection." - - socketHandle == nil ifTrue: [^ false]. - ^ (self primSocketConnectionStatus: socketHandle) == WaitingForConnection - ! Item was removed: - ----- Method: Socket>>listenOn: (in category 'connection open/close') ----- - listenOn: port - "Listen for a connection on the given port. This operation will return immediately; follow it with waitForConnectionUntil: to wait until a connection is established." - - | status | - status := self primSocketConnectionStatus: socketHandle. - (status == Unconnected) - ifFalse: [InvalidSocketStatusException signal: 'Socket status must Unconnected before listening for a new connection']. - - self primSocket: socketHandle listenOn: port. - ! Item was removed: - ----- Method: Socket>>listenOn:backlogSize: (in category 'connection open/close') ----- - listenOn: portNumber backlogSize: backlog - "Listen for a connection on the given port. - If this method succeeds, #accept may be used to establish a new connection" - | status | - status := self primSocketConnectionStatus: socketHandle. - (status == Unconnected) - ifFalse: [InvalidSocketStatusException signal: 'Socket status must Unconnected before listening for a new connection']. - self primSocket: socketHandle listenOn: portNumber backlogSize: backlog. - ! Item was removed: - ----- Method: Socket>>listenOn:backlogSize:interface: (in category 'connection open/close') ----- - listenOn: portNumber backlogSize: backlog interface: ifAddr - "Listen for a connection on the given port. - If this method succeeds, #accept may be used to establish a new connection" - | status | - status := self primSocketConnectionStatus: socketHandle. - (status == Unconnected) - ifFalse: [InvalidSocketStatusException signal: 'Socket status must Unconnected before listening for a new connection']. - self primSocket: socketHandle listenOn: portNumber backlogSize: backlog interface: ifAddr asByteArray. - ! Item was removed: - ----- Method: Socket>>listenWithBacklog: (in category 'ipv6') ----- - listenWithBacklog: backlogSize - - | status | - self initializeNetwork. - status := self primSocketConnectionStatus: socketHandle. - (status == Unconnected) - ifFalse: [InvalidSocketStatusException signal: 'Socket status must Unconnected before it can listen for connections']. - - self primSocket: socketHandle listenWithBacklog: backlogSize. - ! Item was removed: - ----- Method: Socket>>localAddress (in category 'accessing') ----- - localAddress - - self isWaitingForConnection ifFalse: [ - self - waitForConnectionFor: Socket standardTimeout - ifTimedOut: [ - NetNameResolver useOldNetwork - ifTrue: [^ByteArray new: 4] - ifFalse: [^(ByteArray new: 4) asSocketAddress]]]. - NetNameResolver useOldNetwork - ifTrue: [^self primSocketLocalAddress: socketHandle] - ifFalse: [^(self primSocketLocalAddress: socketHandle) asSocketAddress] - ! Item was removed: - ----- Method: Socket>>localAddressPortString (in category 'accessing') ----- - localAddressPortString - ^ self localAddressString, ':', self localPort printString! Item was removed: - ----- Method: Socket>>localAddressString (in category 'accessing') ----- - localAddressString - ^ NetNameResolver stringFromAddress: self localAddress! Item was removed: - ----- Method: Socket>>localPort (in category 'accessing') ----- - localPort - - self isWaitingForConnection ifFalse: [ - self - waitForConnectionFor: Socket standardTimeout - ifTimedOut: [ ^0] ]. - ^ self primSocketLocalPort: socketHandle! Item was removed: - ----- Method: Socket>>localSocketAddress (in category 'ipv6') ----- - localSocketAddress - - | size addr | - size := self primSocketLocalAddressSize: socketHandle. - addr := SocketAddress new: size. - self primSocket: socketHandle localAddressResult: addr. - ^addr! Item was removed: - ----- Method: Socket>>peerName (in category 'accessing') ----- - peerName - "Return the name of the host I'm connected to, or nil if its name isn't known to the domain name server or the request times out." - "Note: Slow. Calls the domain name server, taking up to 20 seconds to time out. Even when sucessful, delays of up to 13 seconds have been observed during periods of high network load." - - | remoteAddress | - NetNameResolver useOldNetwork ifFalse: [ ^self remoteAddress hostName ]. - (remoteAddress := self remoteAddress) = #[0 0 0 0] ifTrue: [ - "Don't wait for the lookup" - ^nil ]. - ^NetNameResolver - nameForAddress: remoteAddress - timeout: 20! Item was removed: - ----- Method: Socket>>port (in category 'accessing') ----- - port - "Shortcut" - ^self localPort! Item was removed: - ----- Method: Socket>>primAcceptFrom:receiveBufferSize:sendBufSize:semaIndex: (in category 'primitives') ----- - primAcceptFrom: aHandle receiveBufferSize: rcvBufSize sendBufSize: sndBufSize semaIndex: semaIndex - "Create and return a new socket handle based on accepting the connection from the given listening socket" - <primitive: 'primitiveSocketAccept' module: 'SocketPlugin'> - ^self primitiveFailed! Item was removed: - ----- Method: Socket>>primAcceptFrom:receiveBufferSize:sendBufSize:semaIndex:readSemaIndex:writeSemaIndex: (in category 'primitives') ----- - primAcceptFrom: aHandle receiveBufferSize: rcvBufSize sendBufSize: sndBufSize semaIndex: semaIndex readSemaIndex: aReadSema writeSemaIndex: aWriteSema - "Create and return a new socket handle based on accepting the connection from the given listening socket" - - <primitive: 'primitiveSocketAccept3Semaphores' module: 'SocketPlugin'> - self primitiveFailed! Item was removed: - ----- Method: Socket>>primSocket:bindTo: (in category 'primitives-ipv6') ----- - primSocket: socketID bindTo: socketAddress - - <primitive: 'primitiveSocketBindTo' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: Socket>>primSocket:connectTo: (in category 'primitives-ipv6') ----- - primSocket: socketID connectTo: socketAddress - - <primitive: 'primitiveSocketConnectTo' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: Socket>>primSocket:connectTo:port: (in category 'primitives') ----- - primSocket: socketID connectTo: hostAddress port: port - "Attempt to establish a connection to the given port of the given host. This is an asynchronous call; query the socket status to discover if and when the connection is actually completed." - - <primitive: 'primitiveSocketConnectToPort' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: Socket>>primSocket:getOption: (in category 'primitives') ----- - primSocket: socketID getOption: aString - "Get some option information on this socket. Refer to the UNIX - man pages for valid SO, TCP, IP, UDP options. In case of doubt - refer to the source code. - TCP_NODELAY, SO_KEEPALIVE are valid options for example - returns an array containing the error code and the option value" - - <primitive: 'primitiveSocketGetOptions' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: Socket>>primSocket:listenOn: (in category 'primitives') ----- - primSocket: socketID listenOn: port - "Listen for a connection on the given port. This is an asynchronous call; query the socket status to discover if and when the connection is actually completed." - - <primitive: 'primitiveSocketListenWithOrWithoutBacklog' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: Socket>>primSocket:listenOn:backlogSize: (in category 'primitives') ----- - primSocket: aHandle listenOn: portNumber backlogSize: backlog - "Primitive. Set up the socket to listen on the given port. - Will be used in conjunction with #accept only." - <primitive: 'primitiveSocketListenWithOrWithoutBacklog' module: 'SocketPlugin'> - self destroy. "Accept not supported so clean up"! Item was removed: - ----- Method: Socket>>primSocket:listenOn:backlogSize:interface: (in category 'primitives') ----- - primSocket: aHandle listenOn: portNumber backlogSize: backlog interface: ifAddr - "Primitive. Set up the socket to listen on the given port. - Will be used in conjunction with #accept only." - <primitive: 'primitiveSocketListenOnPortBacklogInterface' module: 'SocketPlugin'> - self destroy. "Accept not supported so clean up"! Item was removed: - ----- Method: Socket>>primSocket:listenWithBacklog: (in category 'primitives-ipv6') ----- - primSocket: socketID listenWithBacklog: backlogSize - - <primitive: 'primitiveSocketListenWithBacklog' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: Socket>>primSocket:localAddressResult: (in category 'primitives-ipv6') ----- - primSocket: socketID localAddressResult: socketAddress - - <primitive: 'primitiveSocketLocalAddressResult' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: Socket>>primSocket:receiveDataInto:startingAt:count: (in category 'primitives') ----- - primSocket: socketID receiveDataInto: aStringOrByteArray startingAt: startIndex count: count - "Receive data from the given socket into the given array starting at the given index. Return the number of bytes read or zero if no data is available." - - <primitive: 'primitiveSocketReceiveDataBufCount' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: Socket>>primSocket:receiveUDPDataInto:startingAt:count: (in category 'primitives') ----- - primSocket: socketID receiveUDPDataInto: aStringOrByteArray startingAt: startIndex count: count - "Receive data from the given socket into the given array starting at the given index. - Return an Array containing the amount read, the host address byte array, the host port, and the more flag" - - <primitive: 'primitiveSocketReceiveUDPDataBufCount' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: Socket>>primSocket:remoteAddressResult: (in category 'primitives-ipv6') ----- - primSocket: socketID remoteAddressResult: socketAddress - - <primitive: 'primitiveSocketRemoteAddressResult' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: Socket>>primSocket:sendData:startIndex:count: (in category 'primitives') ----- - primSocket: socketID sendData: aStringOrByteArray startIndex: startIndex count: count - "Send data to the remote host through the given socket starting with the given byte index of the given byte array. The data sent is 'pushed' immediately. Return the number of bytes of data actually sent; any remaining data should be re-submitted for sending after the current send operation has completed." - "Note: In general, it many take several sendData calls to transmit a large data array since the data is sent in send-buffer-sized chunks. The size of the send buffer is determined when the socket is created." - - <primitive: 'primitiveSocketSendDataBufCount' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: Socket>>primSocket:sendUDPData:toHost:port:startIndex:count: (in category 'primitives') ----- - primSocket: socketID sendUDPData: aStringOrByteArray toHost: hostAddress port: portNumber startIndex: startIndex count: count - "Send data to the remote host through the given socket starting with the given byte index of the given byte array. The data sent is 'pushed' immediately. Return the number of bytes of data actually sent; any remaining data should be re-submitted for sending after the current send operation has completed." - "Note: In general, it many take several sendData calls to transmit a large data array since the data is sent in send-buffer-sized chunks. The size of the send buffer is determined when the socket is created." - - <primitive: 'primitiveSocketSendUDPDataBufCount' module: 'SocketPlugin'> - self primitiveFailed - - ! Item was removed: - ----- Method: Socket>>primSocket:setOption:value: (in category 'primitives') ----- - primSocket: socketID setOption: aString value: aStringValue - "Set some option information on this socket. Refer to the UNIX - man pages for valid SO, TCP, IP, UDP options. In case of doubt - refer to the source code. - TCP_NODELAY, SO_KEEPALIVE are valid options for example - returns an array containing the error code and the negotiated value" - - <primitive: 'primitiveSocketSetOptions' module: 'SocketPlugin'> - ^nil! Item was removed: - ----- Method: Socket>>primSocket:setPort: (in category 'primitives') ----- - primSocket: socketID setPort: port - "Set the local port associated with a UDP socket. - Note: this primitive is overloaded. The primitive will not fail on a TCP socket, but - the effects will not be what was desired. Best solution would be to split Socket into - two subclasses, TCPSocket and UDPSocket." - - <primitive: 'primitiveSocketListenWithOrWithoutBacklog' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: Socket>>primSocketAbortConnection: (in category 'primitives') ----- - primSocketAbortConnection: socketID - "Terminate the connection on the given port immediately without going through the normal close sequence. This is an asynchronous call; query the socket status to discover if and when the connection is actually terminated." - - <primitive: 'primitiveSocketAbortConnection' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: Socket>>primSocketCloseConnection: (in category 'primitives') ----- - primSocketCloseConnection: socketID - "Close the connection on the given port. The remote end is informed that this end has closed and will do no further sends. This is an asynchronous call; query the socket status to discover if and when the connection is actually closed." - - <primitive: 'primitiveSocketCloseConnection' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: Socket>>primSocketConnectionStatus: (in category 'primitives') ----- - primSocketConnectionStatus: socketID - "Return an integer reflecting the connection status of this socket. For a list of possible values, see the comment in the 'initialize' method of this class. If the primitive fails, return a status indicating that the socket handle is no longer valid, perhaps because the Squeak image was saved and restored since the socket was created. (Sockets do not survive snapshots.)" - - <primitive: 'primitiveSocketConnectionStatus' module: 'SocketPlugin'> - ^ InvalidSocket - ! Item was removed: - ----- Method: Socket>>primSocketCreateNetwork:type:receiveBufferSize:sendBufSize:semaIndex: (in category 'primitives') ----- - primSocketCreateNetwork: netType type: socketType receiveBufferSize: rcvBufSize sendBufSize: sendBufSize semaIndex: semaIndex - "Return a new socket handle for a socket of the given type and buffer sizes. Return nil if socket creation fails. - The netType parameter is platform dependent and can be used to encode both the protocol type (IP, Xerox XNS, etc.) and/or the physical network interface to use if this host is connected to multiple networks. A zero netType means to use IP protocols and the primary (or only) network interface. - The socketType parameter specifies: - 0 reliable stream socket (TCP if the protocol is IP) - 1 unreliable datagram socket (UDP if the protocol is IP) - The buffer size parameters allow performance to be tuned to the application. For example, a larger receive buffer should be used when the application expects to be receiving large amounts of data, especially from a host that is far away. These values are considered requests only; the underlying implementation will ensure that the buffer sizes actually used are within allowable bounds. Note that memory may be limited, so an application that keeps many sockets open should use smaller buffer sizes. Note the macintosh implementation ignores this buffer size. Also see setOption to get/set socket buffer sizes which allows you to set/get the current buffer sizes for reading and writing. - If semaIndex is > 0, it is taken to be the index of a Semaphore in the external objects array to be associated with this socket. This semaphore will be signalled when the socket status changes, such as when data arrives or a send completes. All processes waiting on the semaphore will be awoken for each such event; each process must then query the socket state to figure out if the conditions they are waiting for have been met. For example, a process waiting to send some data can see if the last send has completed." - - <primitive: 'primitiveSocketCreate' module: 'SocketPlugin'> - ^ nil "socket creation failed" - ! Item was removed: - ----- Method: Socket>>primSocketCreateNetwork:type:receiveBufferSize:sendBufSize:semaIndex:readSemaIndex:writeSemaIndex: (in category 'primitives') ----- - primSocketCreateNetwork: netType type: socketType receiveBufferSize: rcvBufSize sendBufSize: sendBufSize semaIndex: semaIndex readSemaIndex: aReadSema writeSemaIndex: aWriteSema - "See comment in primSocketCreateNetwork: with one semaIndex. However you should know that some implementations ignore the buffer size and this interface supports three semaphores, one for open/close/listen and the other two for reading and writing" - - <primitive: 'primitiveSocketCreate3Semaphores' module: 'SocketPlugin'> - self primitiveFailed! Item was removed: - ----- Method: Socket>>primSocketDestroy: (in category 'primitives') ----- - primSocketDestroy: socketID - "Release the resources associated with this socket. If a connection is open, it is aborted." - - <primitive: 'primitiveSocketDestroy' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: Socket>>primSocketDestroyGently: (in category 'primitives') ----- - primSocketDestroyGently: socketID - "Release the resources associated with this socket. If a connection is open, it is aborted. - Do not fail if the receiver is already closed." - - <primitive: 'primitiveSocketDestroy' module: 'SocketPlugin'> - ! Item was removed: - ----- Method: Socket>>primSocketError: (in category 'primitives') ----- - primSocketError: socketID - "Return an integer encoding the most recent error on this socket. Zero means no error." - - <primitive: 'primitiveSocketError' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: Socket>>primSocketLocalAddress: (in category 'primitives') ----- - primSocketLocalAddress: socketID - "Return the local host address for this socket." - - <primitive: 'primitiveSocketLocalAddress' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: Socket>>primSocketLocalAddressSize: (in category 'primitives-ipv6') ----- - primSocketLocalAddressSize: handle - - <primitive: 'primitiveSocketLocalAddressSize' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: Socket>>primSocketLocalPort: (in category 'primitives') ----- - primSocketLocalPort: socketID - "Return the local port for this socket, or zero if no port has yet been assigned." - - <primitive: 'primitiveSocketLocalPort' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: Socket>>primSocketReceiveDataAvailable: (in category 'primitives') ----- - primSocketReceiveDataAvailable: socketID - "Answer if data may be available for reading from the current socket." - - <primitive: 'primitiveSocketReceiveDataAvailable' module: 'SocketPlugin' error: ec> - self primitiveFailed - ! Item was removed: - ----- Method: Socket>>primSocketRemoteAddress: (in category 'primitives') ----- - primSocketRemoteAddress: socketID - "Return the remote host address for this socket, or zero if no connection has been made." - - <primitive: 'primitiveSocketRemoteAddress' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: Socket>>primSocketRemoteAddressSize: (in category 'primitives-ipv6') ----- - primSocketRemoteAddressSize: handle - - <primitive: 'primitiveSocketRemoteAddressSize' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: Socket>>primSocketRemotePort: (in category 'primitives') ----- - primSocketRemotePort: socketID - "Return the remote port for this socket, or zero if no connection has been made." - - <primitive: 'primitiveSocketRemotePort' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: Socket>>primSocketSendDone: (in category 'primitives') ----- - primSocketSendDone: socketID - "Return true if there is no send in progress on the current socket." - - <primitive: 'primitiveSocketSendDone' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: Socket>>primitiveFailed: (in category 'primitives') ----- - primitiveFailed: selector - SocketPrimitiveFailed signal: selector asString, ' failed'! Item was removed: - ----- Method: Socket>>primitiveOnlySupportsOneSemaphore (in category 'accessing') ----- - primitiveOnlySupportsOneSemaphore - - self deprecated: 'All sockets have 3 semaphores.'. - ^false! Item was removed: - ----- Method: Socket>>printOn: (in category 'printing') ----- - printOn: aStream - - super printOn: aStream. - aStream nextPutAll: '[', self statusString, ']'. - ! Item was removed: - ----- Method: Socket>>readSemaphore (in category 'accessing') ----- - readSemaphore - - ^readSemaphore! Item was removed: - ----- Method: Socket>>receiveAvailableData (in category 'receiving') ----- - receiveAvailableData - "Receive all available data (if any). Do not wait." - - | buffer bytesRead | - buffer := String new: 2000. - bytesRead := self receiveAvailableDataInto: buffer. - ^buffer copyFrom: 1 to: bytesRead! Item was removed: - ----- Method: Socket>>receiveAvailableDataInto: (in category 'receiving') ----- - receiveAvailableDataInto: buffer - "Receive all available data into the given buffer and return the number of bytes received. - Note the given buffer may be only partially filled by the received data. - Do not wait for data." - - ^self receiveAvailableDataInto: buffer startingAt: 1! Item was removed: - ----- Method: Socket>>receiveAvailableDataInto:startingAt: (in category 'receiving') ----- - receiveAvailableDataInto: buffer startingAt: startIndex - "Receive all available data into the given buffer and return the number of bytes received. - Note the given buffer may be only partially filled by the received data. - Do not wait for data." - - | bufferPos bytesRead | - bufferPos := startIndex. - [self dataAvailable - and: [bufferPos-1 < buffer size]] - whileTrue: [ - bytesRead := self receiveSomeDataInto: buffer startingAt: bufferPos. - bufferPos := bufferPos + bytesRead]. - ^bufferPos - startIndex! Item was removed: - ----- Method: Socket>>receiveAvailableDataIntoBuffer: (in category 'receiving') ----- - receiveAvailableDataIntoBuffer: buffer - "Receive all available data (if any). Do not wait." - - | bytesRead | - bytesRead := self receiveAvailableDataInto: buffer. - ^buffer copyFrom: 1 to: bytesRead! Item was removed: - ----- Method: Socket>>receiveData (in category 'receiving') ----- - receiveData - "Receive data into the given buffer and return the number of bytes received. - Note the given buffer may be only partially filled by the received data. - Waits for data once. - Either returns data or signals a time out or connection close." - - | buffer bytesRead | - buffer := String new: 2000. - bytesRead := self receiveDataInto: buffer. - ^buffer copyFrom: 1 to: bytesRead! Item was removed: - ----- Method: Socket>>receiveDataInto: (in category 'receiving') ----- - receiveDataInto: aStringOrByteArray - "Receive data into the given buffer and return the number of bytes received. - Note the given buffer may be only partially filled by the received data. - Waits for data once. - Either returns data or signals a time out or connection close." - - ^self receiveDataInto: aStringOrByteArray startingAt: 1! Item was removed: - ----- Method: Socket>>receiveDataInto:fromHost:port: (in category 'datagrams') ----- - receiveDataInto: aStringOrByteArray fromHost: hostAddress port: portNumber - | datagram | - "Receive a UDP packet from the given hostAddress/portNumber, storing the data in the given buffer, and return the number of bytes received. Note the given buffer may be only partially filled by the received data." - - [ - datagram := self receiveUDPDataInto: aStringOrByteArray. - ((datagram at: 2) = hostAddress and: [(datagram at: 3) = portNumber]) - ifTrue: [^datagram at: 1] - ifFalse: [^0]] repeat! Item was removed: - ----- Method: Socket>>receiveDataInto:startingAt: (in category 'receiving') ----- - receiveDataInto: aStringOrByteArray startingAt: aNumber - "Receive data into the given buffer and return the number of bytes received. - Note the given buffer may be only partially filled by the received data. - Waits for data once. The answer may be zero (indicating that no data was - available before the socket closed)." - - | bytesRead open | - bytesRead := 0. - open := true. - [open and: [bytesRead = 0]] whileTrue: - [self waitForDataIfClosed: [open := false]. - open ifTrue: - [bytesRead := self primSocket: socketHandle - receiveDataInto: aStringOrByteArray - startingAt: aNumber - count: aStringOrByteArray size - aNumber + 1]]. - ^bytesRead - ! Item was removed: - ----- Method: Socket>>receiveDataSignallingClosedInto:startingAt: (in category 'receiving') ----- - receiveDataSignallingClosedInto: aStringOrByteArray startingAt: aNumber - "Receive data into the given buffer and return the number of bytes received. - Note the given buffer may be only partially filled by the received data. - Waits for data until something is read or the socket is closed, upon which - we signal." - - | bytesRead | - bytesRead := 0. - [bytesRead = 0] - whileTrue: [ - self waitForData. - bytesRead := self primSocket: socketHandle - receiveDataInto: aStringOrByteArray - startingAt: aNumber - count: aStringOrByteArray size-aNumber+1]. - ^bytesRead - ! Item was removed: - ----- Method: Socket>>receiveDataSignallingTimeout:into:startingAt: (in category 'receiving') ----- - receiveDataSignallingTimeout: timeout into: aStringOrByteArray startingAt: aNumber - "Receive data into the given buffer and return the number of bytes received. - Note the given buffer may be only partially filled by the received data. - Wait for data once for the specified nr of seconds. This method will - throw exceptions on timeout or the socket closing." - - self waitForDataFor: timeout. - ^self primSocket: socketHandle - receiveDataInto: aStringOrByteArray - startingAt: aNumber - count: aStringOrByteArray size-aNumber+1 - ! Item was removed: - ----- Method: Socket>>receiveDataTimeout: (in category 'receiving') ----- - receiveDataTimeout: timeout - "Receive data into the given buffer and return the number of bytes received. - Note the given buffer may be only partially filled by the received data. - Waits for data once." - - | buffer bytesRead | - buffer := String new: 2000. - bytesRead := self receiveDataTimeout: timeout into: buffer. - ^buffer copyFrom: 1 to: bytesRead! Item was removed: - ----- Method: Socket>>receiveDataTimeout:into: (in category 'receiving') ----- - receiveDataTimeout: timeout into: aStringOrByteArray - "Receive data into the given buffer and return the number of bytes received. - Note the given buffer may be only partially filled by the received data. - Waits for data once." - - ^self receiveDataTimeout: timeout into: aStringOrByteArray startingAt: 1! Item was removed: - ----- Method: Socket>>receiveDataTimeout:into:startingAt: (in category 'receiving') ----- - receiveDataTimeout: timeout into: aStringOrByteArray startingAt: aNumber - "Receive data into the given buffer and return the number of bytes received. - Note the given buffer may be only partially filled by the received data. - Wait for data once for the specified nr of seconds. The answer may be - zero (indicating that there was no data available within the given timeout)." - - self waitForDataFor: timeout ifClosed: [] ifTimedOut: []. - ^self primSocket: socketHandle - receiveDataInto: aStringOrByteArray - startingAt: aNumber - count: aStringOrByteArray size-aNumber+1 - ! Item was removed: - ----- Method: Socket>>receiveDataWithTimeout (in category 'receiving') ----- - receiveDataWithTimeout - "Receive data into the given buffer and return the number of bytes received. - Note the given buffer may be only partially filled by the received data. - Waits for data once. - Either returns data or signals a time out or connection close." - - | buffer bytesRead | - buffer := String new: 2000. - bytesRead := self receiveDataWithTimeoutInto: buffer. - ^buffer copyFrom: 1 to: bytesRead! Item was removed: - ----- Method: Socket>>receiveDataWithTimeoutInto: (in category 'receiving') ----- - receiveDataWithTimeoutInto: aStringOrByteArray - "Receive data into the given buffer and return the number of bytes received. - Note the given buffer may be only partially filled by the received data. - Waits for data once. - Either returns data or signals a time out or connection close." - - ^self receiveDataWithTimeoutInto: aStringOrByteArray startingAt: 1! Item was removed: - ----- Method: Socket>>receiveDataWithTimeoutInto:startingAt: (in category 'receiving') ----- - receiveDataWithTimeoutInto: aStringOrByteArray startingAt: aNumber - "Receive data into the given buffer and return the number of bytes received. - Note the given buffer may be only partially filled by the received data. - Waits for data once." - - ^self receiveDataTimeout: Socket standardTimeout into: aStringOrByteArray startingAt: aNumber - ! Item was removed: - ----- Method: Socket>>receiveSomeData (in category 'receiving') ----- - receiveSomeData - "Receive currently available data (if any). Do not wait." - - | buffer bytesRead | - buffer := String new: 2000. - bytesRead := self receiveSomeDataInto: buffer. - ^buffer copyFrom: 1 to: bytesRead! Item was removed: - ----- Method: Socket>>receiveSomeDataInto: (in category 'receiving') ----- - receiveSomeDataInto: aStringOrByteArray - "Receive data into the given buffer and return the number of bytes received. Note the given buffer may be only partially filled by the received data." - - ^self receiveSomeDataInto: aStringOrByteArray startingAt: 1! Item was removed: - ----- Method: Socket>>receiveSomeDataInto:startingAt: (in category 'receiving') ----- - receiveSomeDataInto: aStringOrByteArray startingAt: aNumber - "Receive data into the given buffer and return the number of bytes received. Note the given buffer may be only partially filled by the received data." - - ^ self primSocket: socketHandle - receiveDataInto: aStringOrByteArray - startingAt: aNumber - count: aStringOrByteArray size-aNumber+1 - ! Item was removed: - ----- Method: Socket>>receiveUDPDataInto: (in category 'datagrams') ----- - receiveUDPDataInto: aStringOrByteArray - "Receive UDP data into the given buffer and return the number of bytes received. Note the given buffer may be only partially filled by the received data. What is returned is an array, the first element is the bytes read, the second the sending bytearray address, the third the senders port, the fourth, true if more of the datagram awaits reading" - - ^ self primSocket: socketHandle - receiveUDPDataInto: aStringOrByteArray - startingAt: 1 - count: aStringOrByteArray size - ! Item was removed: - ----- Method: Socket>>register (in category 'registry') ----- - register - ^self class register: self! Item was removed: - ----- Method: Socket>>remoteAddress (in category 'accessing') ----- - remoteAddress - - NetNameResolver useOldNetwork - ifTrue: [^self primSocketRemoteAddress: socketHandle] - ifFalse: [^(self primSocketRemoteAddress: socketHandle) asSocketAddress] - ! Item was removed: - ----- Method: Socket>>remoteAddressPortString (in category 'accessing') ----- - remoteAddressPortString - ^ self remoteAddressString, ':', self remotePort printString! Item was removed: - ----- Method: Socket>>remoteAddressString (in category 'accessing') ----- - remoteAddressString - ^ NetNameResolver stringFromAddress: self remoteAddress! Item was removed: - ----- Method: Socket>>remotePort (in category 'accessing') ----- - remotePort - - ^ self primSocketRemotePort: socketHandle - ! Item was removed: - ----- Method: Socket>>remoteSocketAddress (in category 'ipv6') ----- - remoteSocketAddress - - NetNameResolver useOldNetwork - ifTrue: [ ^self primSocketRemoteAddress: socketHandle ] - ifFalse: [ - | size addr | - size := self primSocketRemoteAddressSize: socketHandle. - addr := SocketAddress new: size. - self primSocket: socketHandle remoteAddressResult: addr. - ^addr]! Item was removed: - ----- Method: Socket>>semaphore (in category 'accessing') ----- - semaphore - ^semaphore! Item was removed: - ----- Method: Socket>>sendData: (in category 'sending') ----- - sendData: aStringOrByteArray - "Send all of the data in the given array, even if it requires multiple calls to send it all. Return the number of bytes sent." - - "An experimental version use on slow lines: Longer timeout and smaller writes to try to avoid spurious timeouts." - - | bytesSent bytesToSend count | - bytesToSend := aStringOrByteArray size. - bytesSent := 0. - [bytesSent < bytesToSend] whileTrue: [ - (self waitForSendDoneFor: 60) - ifFalse: [ConnectionTimedOut signal: 'send data timeout; data not sent']. - count := self primSocket: socketHandle - sendData: aStringOrByteArray - startIndex: bytesSent + 1 - count: bytesToSend - bytesSent. - bytesSent := bytesSent + count]. - - ^ bytesSent - ! Item was removed: - ----- Method: Socket>>sendData:count: (in category 'sending') ----- - sendData: buffer count: n - "Send the amount of data from the given buffer." - | sent totalSent | - totalSent := 0. - [totalSent < n] whileTrue: - [sent := self sendSomeData: buffer startIndex: totalSent+1 count: n-totalSent. - totalSent := totalSent + sent. - sent = 0 ifTrue: "If no data was sent don't just sit here spinning hard..." - [Processor yield]].! Item was removed: - ----- Method: Socket>>sendData:toHost:port: (in category 'datagrams') ----- - sendData: aStringOrByteArray toHost: hostAddress port: portNumber - "Send a UDP packet containing the given data to the specified host/port." - - ^self sendUDPData: aStringOrByteArray toHost: hostAddress port: portNumber! Item was removed: - ----- Method: Socket>>sendDone (in category 'queries') ----- - sendDone - "Return true if the most recent send operation on this socket has completed." - - socketHandle == nil ifTrue: [^ false]. - ^ self primSocketSendDone: socketHandle - ! Item was removed: - ----- Method: Socket>>sendSomeData: (in category 'sending') ----- - sendSomeData: aStringOrByteArray - "Send as much of the given data as possible and answer the number of bytes actually sent." - "Note: This operation may have to be repeated multiple times to send a large amount of data." - - ^ self - sendSomeData: aStringOrByteArray - startIndex: 1 - count: aStringOrByteArray size! Item was removed: - ----- Method: Socket>>sendSomeData:startIndex: (in category 'sending') ----- - sendSomeData: aStringOrByteArray startIndex: startIndex - "Send as much of the given data as possible starting at the given index. Answer the number of bytes actually sent." - "Note: This operation may have to be repeated multiple times to send a large amount of data." - - ^ self - sendSomeData: aStringOrByteArray - startIndex: startIndex - count: (aStringOrByteArray size - startIndex + 1)! Item was removed: - ----- Method: Socket>>sendSomeData:startIndex:count: (in category 'sending') ----- - sendSomeData: aStringOrByteArray startIndex: startIndex count: count - ^ self sendSomeData: aStringOrByteArray startIndex: startIndex count: count for: Socket standardTimeout! Item was removed: - ----- Method: Socket>>sendSomeData:startIndex:count:for: (in category 'sending') ----- - sendSomeData: aStringOrByteArray startIndex: startIndex count: count for: aTimeoutInSeconds - "Send up to count bytes of the given data starting at the given index. Answer the number of bytes actually sent." - "Note: This operation may have to be repeated multiple times to send a large amount of data." - - (self waitForSendDoneFor: aTimeoutInSeconds) ifFalse: [ - ConnectionTimedOut signal: 'send data timeout; data not sent'. - ^0 ]. - ^self primSocket: socketHandle - sendData: aStringOrByteArray - startIndex: startIndex - count: count! Item was removed: - ----- Method: Socket>>sendStreamContents: (in category 'sending') ----- - sendStreamContents: stream - "Send the data in the stream. Close the stream. - Usefull for directly sending contents of a file without reading into memory first." - - self sendStreamContents: stream checkBlock: [true]! Item was removed: - ----- 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]] - whileFalse: [ - buffer := stream next: chunkSize into: buffer. - self sendData: buffer]] - ensure: [stream close]! Item was removed: - ----- Method: Socket>>sendUDPData:toHost:port: (in category 'datagrams') ----- - sendUDPData: aStringOrByteArray toHost: hostAddress port: portNumber - "Send a UDP packet containing the given data to the specified host/port." - | bytesToSend bytesSent count | - - bytesToSend := aStringOrByteArray size. - bytesSent := 0. - [bytesSent < bytesToSend] whileTrue: [ - (self waitForSendDoneFor: 20) - ifFalse: [ConnectionTimedOut signal: 'send data timeout; data not sent']. - count := self primSocket: socketHandle - sendUDPData: aStringOrByteArray - toHost: hostAddress asByteArray - port: portNumber - startIndex: bytesSent + 1 - count: bytesToSend - bytesSent. - count isZero ifTrue: [NetworkError signal: 'failed to send data'].. - bytesSent := bytesSent + count]. - - ^ bytesSent - ! Item was removed: - ----- Method: Socket>>setOption:value: (in category 'other') ----- - setOption: aName value: aValue - | value | - "setup options on this socket, see Unix man pages for values for - sockets, IP, TCP, UDP. IE SO_KEEPALIVE - returns an array, element one is the error number - element two is the resulting of the negotiated value. - See #getOption: for list of keys" - - self isValid ifFalse: [ - InvalidSocketStatusException signal: 'Socket status must valid before setting an option' ]. - value := aValue - caseOf: { - [ true ] -> [ '1' ]. - [ false ] -> [ '0' ] } - otherwise: [ aValue asString ]. - ^ self primSocket: socketHandle setOption: aName value: value! Item was removed: - ----- Method: Socket>>setPeer:port: (in category 'datagrams') ----- - setPeer: hostAddress port: port - "Set the default send/recv address." - - self primSocket: socketHandle connectTo: hostAddress asByteArray port: port. - ! Item was removed: - ----- Method: Socket>>setPort: (in category 'datagrams') ----- - setPort: port - "Associate a local port number with a UDP socket. Not applicable to TCP sockets." - - self primSocket: socketHandle setPort: port. - ! Item was removed: - ----- Method: Socket>>setPort:interface: (in category 'datagrams') ----- - setPort: portNumber interface: ifAddr - "Allow an UDP socket to bind to a specific interface." - - self primSocket: socketHandle listenOn: portNumber backlogSize: 0 interface: ifAddr asByteArray. - ! Item was removed: - ----- Method: Socket>>socketError (in category 'queries') ----- - socketError - ^self primSocketError: socketHandle! Item was removed: - ----- Method: Socket>>socketHandle (in category 'accessing') ----- - socketHandle - ^socketHandle! Item was removed: - ----- Method: Socket>>statusString (in category 'queries') ----- - statusString - "Return a string describing the status of this socket." - - | status | - socketHandle == nil ifTrue: [^ 'destroyed']. - status := self primSocketConnectionStatus: socketHandle. - status = InvalidSocket ifTrue: [^ 'invalidSocketHandle']. - status = Unconnected ifTrue: [^ 'unconnected']. - status = WaitingForConnection ifTrue: [^ 'waitingForConnection']. - status = Connected ifTrue: [^ 'connected']. - status = OtherEndClosed ifTrue: [^ 'otherEndClosedButNotThisEnd']. - status = ThisEndClosed ifTrue: [^ 'thisEndClosedButNotOtherEnd']. - ^ 'unknown socket status' - ! Item was removed: - ----- Method: Socket>>unregister (in category 'registry') ----- - unregister - ^self class unregister: self! Item was removed: - ----- Method: Socket>>waitForAcceptFor: (in category 'waiting') ----- - waitForAcceptFor: timeout - "Wait and accept an incoming connection. Return nil if it falis" - self waitForConnectionFor: timeout ifTimedOut: [^ nil]. - ^ self isConnected - ifTrue:[self accept] - ! Item was removed: - ----- Method: Socket>>waitForAcceptFor:ifTimedOut: (in category 'waiting') ----- - waitForAcceptFor: timeout ifTimedOut: timeoutBlock - "Wait and accept an incoming connection" - self waitForConnectionFor: timeout ifTimedOut: [^timeoutBlock value]. - ^self isConnected - ifTrue:[self accept] - ! Item was removed: - ----- Method: Socket>>waitForConnectionFor: (in category 'waiting') ----- - waitForConnectionFor: timeout - "Wait up until the given deadline for a connection to be established. Return true if it is established by the deadline, false if not." - - ^self - waitForConnectionFor: timeout - ifTimedOut: [ConnectionTimedOut signal: 'Failed to connect in ', timeout asString, ' seconds'] - ifRefused: [ConnectionRefused signal: 'Failed to connect in ', timeout asString, ' seconds'] - ! Item was removed: - ----- Method: Socket>>waitForConnectionFor:ifTimedOut: (in category 'waiting') ----- - waitForConnectionFor: timeout ifTimedOut: timeoutBlock - "Wait up until the given deadline for a connection to be established. Return true if it is established by the deadline, false if not." - - ^ self waitForConnectionFor: timeout ifTimedOut: timeoutBlock ifRefused: timeoutBlock - ! Item was removed: - ----- Method: Socket>>waitForConnectionFor:ifTimedOut:ifRefused: (in category 'waiting') ----- - waitForConnectionFor: timeout ifTimedOut: timeoutBlock ifRefused: refusedBlock - "Wait up until the given deadline for a connection to be established. Return true if it is established by the deadline, false if not." - - | deadline timeLeft status | - deadline := Time millisecondClockValue + (timeout * 1000) truncated. - (status := self primSocketConnectionStatus: socketHandle) == Connected ifTrue: [^true]. - [ (status == WaitingForConnection) and: [ (timeLeft := deadline - Time millisecondClockValue) > 0 ] ] - whileTrue: [ - semaphore waitTimeoutMSecs: timeLeft. - status := self primSocketConnectionStatus: socketHandle ]. - status == Connected ifTrue: [ ^true ]. - status == WaitingForConnection - ifTrue: [ timeoutBlock value ] - ifFalse: [ refusedBlock value ]. - ^false! Item was removed: - ----- Method: Socket>>waitForConnectionUntil: (in category 'waiting') ----- - waitForConnectionUntil: deadline - "Wait up until the given deadline for a connection to be established. Return true if it is established by the deadline, false if not." - - | status timeLeft | - [ - (status := self primSocketConnectionStatus: socketHandle) == Connected ifTrue: [ ^true ]. - status == WaitingForConnection ifFalse: [ ^false ]. - (timeLeft := deadline - Time millisecondClockValue) <= 0 ifTrue: [ ^false ]. - semaphore waitTimeoutMSecs: timeLeft ] repeat! Item was removed: - ----- Method: Socket>>waitForData (in category 'waiting') ----- - waitForData - "Wait for data to arrive. This method will block until - data is available or the socket is closed. If the socket is closed - a ConnectionClosed exception will be signaled." - - ^self waitForDataIfClosed: - [ConnectionClosed signal: 'Connection close while waiting for data.']! Item was removed: - ----- Method: Socket>>waitForDataFor: (in category 'waiting') ----- - waitForDataFor: timeout - "Wait for the given nr of seconds for data to arrive. - Signal a time out or connection close exception if either happens before data becomes available." - - ^self - waitForDataFor: timeout - ifClosed: [ConnectionClosed signal: 'Connection closed while waiting for data.' translated] - ifTimedOut: [ConnectionTimedOut signal: 'Data receive timed out.' translated] - ! Item was removed: - ----- Method: Socket>>waitForDataFor:ifClosed:ifTimedOut: (in category 'waiting') ----- - waitForDataFor: timeout ifClosed: closedBlock ifTimedOut: timedOutBlock - "Wait for the given nr of seconds for data to arrive." - - | deadline timeLeft | - socketHandle ifNil: [ ^closedBlock value ]. - deadline := Time millisecondClockValue + (timeout * 1000) truncated. - [ - (self primSocketReceiveDataAvailable: socketHandle) ifTrue: [ ^self ]. - self isConnected ifFalse: [ ^closedBlock value ]. - (timeLeft := deadline - Time millisecondClockValue) <= 0 ifTrue: [ ^timedOutBlock value ]. - "Providing a maximum for the time for waiting is a workaround for a VM bug which causes sockets waiting for data forever in some rare cases, because the semaphore doesn't get signaled. Remove the ""min: self class maximumReadSemaphoreWaitTimeout"" part when the bug is fixed." - readSemaphore waitTimeoutMSecs: - (timeLeft min: self class maximumReadSemaphoreWaitTimeout) ] repeat! Item was removed: - ----- Method: Socket>>waitForDataIfClosed: (in category 'waiting') ----- - waitForDataIfClosed: closedBlock - "Wait indefinitely for data to arrive. This method will block until - data is available or the socket is closed." - - [socketHandle ifNil: [^closedBlock value ]. - (self primSocketReceiveDataAvailable: socketHandle) ifTrue: [ ^self ]. - self isConnected ifFalse: [ ^closedBlock value ]. - "ul 8/13/2014 21:16 - Providing a maximum for the time for waiting is a workaround for a VM bug which - causes sockets waiting for data forever in some rare cases, because the semaphore - doesn't get signaled. Replace the ""waitTimeoutMSecs: self class maximumReadSemaphoreWaitTimeout"" - part with ""wait"" when the bug is fixed." - readSemaphore waitTimeoutMSecs: self class maximumReadSemaphoreWaitTimeout ] repeat! Item was removed: - ----- Method: Socket>>waitForDisconnectionFor: (in category 'waiting') ----- - waitForDisconnectionFor: timeout - "Wait for the given nr of seconds for the connection to be broken. - Return true if it is broken by the deadline, false if not. - The client should know the connection is really going to be closed - (e.g., because he has called 'close' to send a close request to the other end) - before calling this method." - - | deadline | - deadline := Time millisecondClockValue + (timeout * 1000) truncated. - [ self isConnected and: [ deadline - Time millisecondClockValue > 0 ] ] - whileTrue: [ - self discardReceivedData. - "Providing a maximum for the time for waiting is a workaround for a VM bug which causes sockets waiting for data forever in some rare cases, because the semaphore doesn't get signaled. Remove the ""min: self class maximumReadSemaphoreWaitTimeout"" part when the bug is fixed." - readSemaphore waitTimeoutMSecs: - (deadline - Time millisecondClockValue min: self class maximumReadSemaphoreWaitTimeout) ]. - ^self isConnected! Item was removed: - ----- Method: Socket>>waitForSendDoneFor: (in category 'waiting') ----- - waitForSendDoneFor: timeout - "Wait up until the given deadline for the current send operation to complete. Return true if it completes by the deadline, false if not." - - | deadline timeleft | - deadline := Time millisecondClockValue + (timeout * 1000) truncated. - [ - (self primSocketSendDone: socketHandle) ifTrue: [ ^true ]. - self isConnected ifFalse: [ ^false ]. - (timeleft := deadline - Time millisecondClockValue) <= 0 ifTrue: [ ^false ]. - writeSemaphore waitTimeoutMSecs: timeleft ] repeat! Item was removed: - ----- Method: Socket>>writeSemaphore (in category 'accessing') ----- - writeSemaphore - - ^writeSemaphore! Item was removed: - ByteArray variableByteSubclass: #SocketAddress - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-Kernel'! - - !SocketAddress commentStamp: '<historical>' prior: 0! - I represent a socket (network) address consisting of a host internet address and a port number. My contents are opaque and cannot be interpreted directly. See the accessing protocol for methods that retrieve the information I contain.! Item was removed: - ----- Method: SocketAddress class>>fromOldByteAddress: (in category 'instance creation') ----- - fromOldByteAddress: byteArray - "Use the resolver to find a socket address corresponding to byteArray" - - | rs addrString addressInfos addressInfo | - rs := ReadStream on: byteArray. - addrString := String streamContents: [:strm | - [rs atEnd] whileFalse: [ - strm nextPutAll: rs next asString. - rs atEnd ifFalse: [strm nextPut: $. ]]]. - addressInfos := NetNameResolver addressesForName: addrString. - addressInfos isEmpty ifTrue: [self error: 'invalid address ', addrString]. - addressInfo := addressInfos - detect: [:e | e addressFamilyName = #inet4] - ifNone: [self error: 'no inet4 address for ', addrString]. - ^addressInfo socketAddress "first available inet4 interface" - ! Item was removed: - ----- Method: SocketAddress class>>loopback4 (in category 'accessing') ----- - loopback4 - - ^self loopbacks4 first! Item was removed: - ----- Method: SocketAddress class>>loopback6 (in category 'accessing') ----- - loopback6 - - ^self loopbacks6 first! Item was removed: - ----- Method: SocketAddress class>>loopbacks (in category 'accessing') ----- - loopbacks - - ^SocketAddressInformation forHost: '' service: '0' - flags: 0 - addressFamily: 0 - socketType: 0 - protocol: 0! Item was removed: - ----- Method: SocketAddress class>>loopbacks4 (in category 'accessing') ----- - loopbacks4 - - ^SocketAddressInformation forHost: 'localhost' service: '' - flags: 0 - addressFamily: SocketAddressInformation addressFamilyINET4 - socketType: 0 - protocol: 0! Item was removed: - ----- Method: SocketAddress class>>loopbacks6 (in category 'accessing') ----- - loopbacks6 - - ^SocketAddressInformation forHost: '' service: '0' - flags: 0 - addressFamily: SocketAddressInformation addressFamilyINET6 - socketType: 0 - protocol: 0! Item was removed: - ----- Method: SocketAddress class>>wildcard4 (in category 'accessing') ----- - wildcard4 - - ^self wildcards4 first! Item was removed: - ----- Method: SocketAddress class>>wildcard6 (in category 'accessing') ----- - wildcard6 - - ^self wildcards6 first! Item was removed: - ----- Method: SocketAddress class>>wildcards (in category 'accessing') ----- - wildcards - - ^SocketAddressInformation forHost: '' service: '0' - flags: SocketAddressInformation passiveFlag - addressFamily: 0 - socketType: 0 - protocol: 0! Item was removed: - ----- Method: SocketAddress class>>wildcards4 (in category 'accessing') ----- - wildcards4 - - ^SocketAddressInformation forHost: '' service: '0' - flags: SocketAddressInformation passiveFlag - addressFamily: SocketAddressInformation addressFamilyINET4 - socketType: SocketAddressInformation socketTypeStream - protocol: 0! Item was removed: - ----- Method: SocketAddress class>>wildcards6 (in category 'accessing') ----- - wildcards6 - - ^SocketAddressInformation forHost: '' service: '0' - flags: SocketAddressInformation passiveFlag - addressFamily: SocketAddressInformation addressFamilyINET6 - socketType: 0 - protocol: 0! Item was removed: - ----- Method: SocketAddress>>asByteArray (in category 'converting') ----- - asByteArray - "Assuming IPV4, answer a byte array representation of the host number" - ^ ((self hostNumber findTokens: '.') - collect: [:e | e asInteger]) asByteArray! Item was removed: - ----- Method: SocketAddress>>asSocketAddress (in category 'converting') ----- - asSocketAddress - ! Item was removed: - ----- Method: SocketAddress>>hostName (in category 'accessing') ----- - hostName - - | size name | - NetNameResolver primGetNameInfo: self flags: 0. - size := NetNameResolver primGetNameInfoHostSize. - name := String new: size. - NetNameResolver primGetNameInfoHostResult: name. - ^name! Item was removed: - ----- Method: SocketAddress>>hostNumber (in category 'accessing') ----- - hostNumber - - | size name | - NetNameResolver primGetNameInfo: self flags: 1. - size := NetNameResolver primGetNameInfoHostSize. - name := String new: size. - NetNameResolver primGetNameInfoHostResult: name. - ^name! Item was removed: - ----- Method: SocketAddress>>port (in category 'primitives') ----- - port - - <primitive: 'primitiveSocketAddressGetPort' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: SocketAddress>>port: (in category 'primitives') ----- - port: anInteger - - <primitive: 'primitiveSocketAddressSetPort' module: 'SocketPlugin'> - self primitiveFailed - ! Item was removed: - ----- Method: SocketAddress>>printOn: (in category 'printing') ----- - printOn: aStream - - [aStream - nextPutAll: self hostNumber; - nextPut: $(; nextPutAll: self hostName; nextPut: $); - nextPut: $,; - nextPutAll: self serviceNumber; - nextPut: $(; nextPutAll: self serviceName; nextPut: $)] - on: Error "e.g. inspector on address from a previous session" - do: [aStream nextPutAll: 'an invalid '; - nextPutAll: self class name; - nextPut: Character space. - ^super printOn: aStream]! Item was removed: - ----- Method: SocketAddress>>serviceName (in category 'accessing') ----- - serviceName - - | size name | - NetNameResolver primGetNameInfo: self flags: 0. - size := NetNameResolver primGetNameInfoServiceSize. - name := String new: size. - NetNameResolver primGetNameInfoServiceResult: name. - ^name! Item was removed: - ----- Method: SocketAddress>>serviceNumber (in category 'accessing') ----- - serviceNumber - - | size name | - NetNameResolver primGetNameInfo: self flags: 1. - size := NetNameResolver primGetNameInfoServiceSize. - name := String new: size. - NetNameResolver primGetNameInfoServiceResult: name. - ^name! Item was removed: - Object subclass: #SocketAddressInformation - instanceVariableNames: 'socketAddress addressFamily socketType protocol' - classVariableNames: 'AddressFamilyINET4 AddressFamilyINET6 AddressFamilyLocal AddressFamilyUnspecified NumericFlag PassiveFlag PrimitiveAccessProtect ProtocolTCP ProtocolUDP ProtocolUnspecified SocketTypeDGram SocketTypeStream SocketTypeUnspecified' - poolDictionaries: '' - category: 'Network-Kernel'! - - !SocketAddressInformation commentStamp: '<historical>' prior: 0! - I represent a local or remote network service. - - Instance Variables - addressFamily: <SmallInteger> the address family (unix, inet4, inet6, ...) in which the service address is available. - protocol: <SmallInteger> the protocol (tcp, udp, ...) that the service uses. - socketAddress: <SocketAddress> the socket address at which the service can be contacted or created. - socketType: <SmallInteger> the type (stream, dgram) of the socket that should be created for communication with the service. - ! Item was removed: - ----- Method: SocketAddressInformation class>>addressFamilyINET4 (in category 'accessing') ----- - addressFamilyINET4 - - ^AddressFamilyINET4! Item was removed: - ----- Method: SocketAddressInformation class>>addressFamilyINET6 (in category 'accessing') ----- - addressFamilyINET6 - - ^AddressFamilyINET6! Item was removed: - ----- Method: SocketAddressInformation class>>addressFamilyLocal (in category 'accessing') ----- - addressFamilyLocal - - ^AddressFamilyLocal! Item was removed: - ----- Method: SocketAddressInformation class>>addressFamilyUnspecified (in category 'accessing') ----- - addressFamilyUnspecified - - ^AddressFamilyUnspecified! Item was removed: - ----- Method: SocketAddressInformation class>>forHost:service:flags:addressFamily:socketType:protocol: (in category 'instance creation') ----- - forHost: hostName service: servName flags: flags addressFamily: family socketType: type protocol: protocol - - | result addr | - PrimitiveAccessProtect critical: [ - NetNameResolver initializeNetwork. - NetNameResolver - primGetAddressInfoHost: hostName - service: servName - flags: flags - family: family - type: type - protocol: protocol. - result := OrderedCollection new. - [(addr := NetNameResolver nextSocketAddressInformation) notNil] - whileTrue: [result add: addr]]. - ^ result! Item was removed: - ----- Method: SocketAddressInformation class>>initialize (in category 'class initialization') ----- - initialize - "SocketAddressInformation initialize" - - NumericFlag := 1. - PassiveFlag := 2. - AddressFamilyUnspecified := 0. - AddressFamilyLocal := 1. - AddressFamilyINET4 := 2. - AddressFamilyINET6 := 3. - SocketTypeUnspecified := 0. - SocketTypeStream := 1. - SocketTypeDGram := 2. - ProtocolUnspecified := 0. - ProtocolTCP := 1. - ProtocolUDP := 2. - - "SocketPlugin maintains internal state across primitive calls, so methods that rely - on the result of sequential primitive calls require concurrency control." - PrimitiveAccessProtect := Semaphore forMutualExclusion. - ! Item was removed: - ----- Method: SocketAddressInformation class>>numericFlag (in category 'accessing') ----- - numericFlag - - ^NumericFlag! Item was removed: - ----- Method: SocketAddressInformation class>>passiveFlag (in category 'accessing') ----- - passiveFlag - - ^PassiveFlag! Item was removed: - ----- Method: SocketAddressInformation class>>protocolTCP (in category 'accessing') ----- - protocolTCP - - ^ProtocolTCP! Item was removed: - ----- Method: SocketAddressInformation class>>protocolUDP (in category 'accessing') ----- - protocolUDP - - ^ProtocolUDP! Item was removed: - ----- Method: SocketAddressInformation class>>protocolUnspecified (in category 'accessing') ----- - protocolUnspecified - - ^ProtocolUnspecified! Item was removed: - ----- Method: SocketAddressInformation class>>socketTypeDGram (in category 'accessing') ----- - socketTypeDGram - - ^SocketTypeDGram! Item was removed: - ----- Method: SocketAddressInformation class>>socketTypeStream (in category 'accessing') ----- - socketTypeStream - - ^SocketTypeStream! Item was removed: - ----- Method: SocketAddressInformation class>>socketTypeUnspecified (in category 'accessing') ----- - socketTypeUnspecified - - ^SocketTypeUnspecified! Item was removed: - ----- Method: SocketAddressInformation class>>withSocketAddress:family:type:protocol: (in category 'instance creation') ----- - withSocketAddress: socketAddress family: family type: type protocol: protocol - - ^self new initSocketAddress: socketAddress family: family type: type protocol: protocol! Item was removed: - ----- Method: SocketAddressInformation>>addressFamilyName (in category 'accessing') ----- - addressFamilyName - - ^#(unspecified local inet4 inet6) at: addressFamily + 1! Item was removed: - ----- Method: SocketAddressInformation>>connect (in category 'circuit setup') ----- - connect - - | sock | - socketType == SocketTypeStream ifFalse: [^nil]. - sock := Socket newTCP: addressFamily. - sock connectTo: socketAddress. - sock waitForConnectionFor: Socket standardTimeout - ifTimedOut: [ConnectionTimedOut signal: ('Cannot connect to {1}' translated format: {self})] - ifRefused: [ConnectionRefused signal: ('Cannot connect to {1}' translated format: {self})]. - ^sock! Item was removed: - ----- Method: SocketAddressInformation>>initSocketAddress:family:type:protocol: (in category 'initialize-release') ----- - initSocketAddress: aSocketAddress family: familyInteger type: typeInteger protocol: protocolInteger - - socketAddress := aSocketAddress. - addressFamily := familyInteger. - socketType := typeInteger. - protocol := protocolInteger.! Item was removed: - ----- Method: SocketAddressInformation>>listenWithBacklog: (in category 'circuit setup') ----- - listenWithBacklog: backlog - - | sock | - (socketType == SocketTypeStream and: [protocol == ProtocolTCP]) ifFalse: [self error: 'cannot listen']. - sock := Socket newTCP: addressFamily. - sock bindTo: socketAddress. - sock listenWithBacklog: 5. - ^sock! Item was removed: - ----- Method: SocketAddressInformation>>printOn: (in category 'printing') ----- - printOn: aStream - - aStream - print: socketAddress; - nextPut: $-; nextPutAll: self addressFamilyName; - nextPut: $-; nextPutAll: self socketTypeName; - nextPut: $-; nextPutAll: self protocolName! Item was removed: - ----- Method: SocketAddressInformation>>protocolName (in category 'accessing') ----- - protocolName - - ^#(unspecified tcp udp) at: socketType + 1! Item was removed: - ----- Method: SocketAddressInformation>>socketAddress (in category 'accessing') ----- - socketAddress - - ^socketAddress! Item was removed: - ----- Method: SocketAddressInformation>>socketTypeName (in category 'accessing') ----- - socketTypeName - - ^#(unspecified stream dgram) at: socketType + 1! Item was removed: - NetworkError subclass: #SocketPrimitiveFailed - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-Exceptions'! Item was removed: - Object subclass: #SocketStream - instanceVariableNames: 'recentlyRead socket inBuffer outBuffer inNextToWrite outNextToWrite lastRead timeout autoFlush bufferSize binary shouldSignal' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-Kernel'! - - !SocketStream commentStamp: 'md 7/14/2006 16:32' prior: 0! - SocketStream is a wrapper for class Socket making it easy to write networking code by giving the programmer a stream-like protocol. A Socket is a two way communication link with two logically separate channels - input and output. The Socket class is the lowest level in Squeak for network communication and using it directly can be difficult and bug prone. - - A SocketStream can be in binary or ascii mode, ascii is the default which means you are transmitting and receiving Strings. Most Internet protocols are in clear text ascii, like for example HTTP. Another setting is what timeout you want to use - default is the standardTimeout from Socket. More settings can be found in the method category 'configuration'. - - Simplest example of connecting, sending/receiving and closing: - - | stream result | - stream := SocketStream openConnectionToHostNamed: 'www.squeak.org' port: 80. - [[stream nextPutAll: 'GET / HTTP/1.0'; crlf; crlf; flush. - result := stream upToEnd. "Give us all data until the socket is closed." - Transcript show: result; cr.] - ensure: [stream close]] - on: ConnectionTimedOut - do: [:ex | Transcript show: ex asString;cr. ex resume] - - There are two important things to note above: - - The methods in category "stream in" can signal two exceptions (unless turned off with #shouldSignal:): - ConnectionClosed and ConnectionTimedOut - - We close the stream using #ensure:, that is to make sure it isn't left opened. - - We use #on:do: to catch any signal. In this case we do not need to catch ConnectionClosed since #upToEnd does that for us intrinsically. - - ---------------- - SocketStream (below called SS) is a reimplementation of 'Old'-SocketStream (below called OSS) - the class that originates from the original Comanche implementation but now is included in standard Squeak. SS has the same protocol as OSS and is meant to replace it. SS is faster, more flexible, is better documented and adds a few features: - - 1. #shouldSignal:, which decides if SS should signal low level Socket exceptions (true) or if it should swallow them like original OSS did. Default is true. The only reason I added this is for backwards compatibility - not signalling causes problems - see bug 4 below. - - 2. #nextAllInBuffer, #nextInBuffer:, #skip:, #receiveData:, #nextPutAllFlush: and #recentlyRead are new additions to the public protocol. - - - It also fixes various bugs: - - 1. #isDataAvailable could theoretically answer false, when there actually is some in the buffer in OSS. If #receiveDataIfAvailable reads the last byte then the following "socket dataAvailable" would answer false. So the last byte would be sitting in the inStream missed. - - 2. #upToAll: in OSS has several problems, for example - #positionOfSubCollection:ifAbsent: which was introduced answers one position too low. This was compensated in upToAll:, but only in the pushBack: call, not the actual result being returned which was cut short 1 byte. Amusingly this makes KomHttpServer not use "Keep-Alive" since the last $e in 'Alive' was cut short. :) - - 3. SS doesn't inherit from PositionableStream since that just breaks various inherited messages, like for example #skip:. OSS should IMHO be changed to inherit from Object - or of course, replaced in full with SS. :) - - 4. Since SocketStream by default signals closes and timeouts the SocketStreamTest now passes. The reason for SocketStream to fail is that while it does timeout on a low level (#SocketStream>>receiveData doesn't hang forever) - the callers of #receiveData sometimes loop - like in #next:, and thus eliminates the timeout. SS warns about some methods (in their method comments) not honouring timeouts if shouldSignal is false, I really don't know what they should do in that case: - #next:, #upTo:, #upToAll: and #upToEnd (and #receiveData:) - - - The primary reason for the SS implementation is optimal performance. The main differences in implementation with the old OSS are: - - 1. SS uses two buffers directly (inBuffer and outBuffer) with pointers marking start and stop within the buffer. OSS instead uses two regular streams, a ReadStream and a WriteStream. Using internal buffers makes it possible to avoid copying and reallocation in various ways, it also makes SS be able to have specialized growing/buffer moving behaviour. - - 2. #upTo:, #upToAll: and #peekForAll: uses selectged String messages that in turn uses fast primitives for searching. OSS used other messages that fell back on byte per byte reading. - - 3. #receiveData in OSS creates a temporary buffer stream for each call!! During a long read operation, like say #upToAll: (which for example is used when uploading files using HTTP POST forms), this is devastating - especially since the default size is only 2000 bytes - and leads to a very high number of low level read operations on the Socket, typically 100 times more calls than with OSS. The buffer in OSS is held in an instvar (not recreated for each call), is larger from the start and above all - grows dynamically by doubling. OSS can also avoid a grow/reallocation by doing a "move down" if data has been read from the SS as it comes in and through that making room in the lower part of the inBuffer. The net result is that upToAll: for large files is about 10 times faster. - - 4. The implementation of upTo: and upToAll: tries to avoid doing unnecessary find operations in the buffer and is greedy by default, which means it favors reading more data - if available - before searching for the stop sequence. If we had #findString:startingAt:stoppingAt: this wouldn't have to be greedy and we wouldn't be needlessly scanning dead buffer area. VM hackers? Also, while you are at it - make it work for ByteArrays too. :) - - - SS can not be run unbuffered, since that seems unneeded. The option to autoFlush is still available, with it set to true SocketStream (just like OSS) will flush on its own on each nextPut:/nextPutAll:, otherwise flushing it will have to be done manually but is done on close. - - The first performance tests shows that, as noted above, receiving large amounts of data using #upToAll: is greatly improved - factor of 10. Serving HTTP with small payloads seemed at first not be faster at all - but this is due to the high overhead of Socket connect/close and other things. Increasing payloads show a difference and especially with keep alive on - where the new SS roughly doubles the throughput!!! Item was removed: - ----- Method: SocketStream class>>finger:at: (in category 'example') ----- - finger: userName at: aHostnameOrAddressString - "SocketStream finger: 'stp' at: 'example.com'" - - | s | - s := SocketStream openConnectionToHost: aHostnameOrAddressString port: 79. "finger port number" - Transcript show: '---------- Connecting ----------'; cr. - s sendCommand: userName. - Transcript show: s getLine. - s close. - Transcript show: '---------- Connection Closed ----------'; cr; endEntry. - ! Item was removed: - ----- Method: SocketStream class>>on: (in category 'instance creation') ----- - on: socket - "Create a socket stream on a connected server socket." - - ^self basicNew initialize socket: socket! Item was removed: - ----- Method: SocketStream class>>openConnectionToHost:port: (in category 'instance creation') ----- - openConnectionToHost: hostIP port: portNumber - | socket | - socket := Socket new. - socket connectTo: hostIP port: portNumber. - ^self on: socket! Item was removed: - ----- Method: SocketStream class>>openConnectionToHost:port:timeout: (in category 'instance creation') ----- - openConnectionToHost: hostIP port: portNumber timeout: timeout - | socket | - socket := Socket new. - socket connectTo: hostIP port: portNumber waitForConnectionFor: timeout. - ^self on: socket! Item was removed: - ----- Method: SocketStream class>>openConnectionToHostNamed:port: (in category 'instance creation') ----- - openConnectionToHostNamed: hostName port: portNumber - - | addressInformations stream | - NetNameResolver useOldNetwork - ifTrue: [ | hostIP | - hostIP := NetNameResolver addressForName: hostName timeout: 20. - hostIP ifNil: [NetworkError signal: ('Cannot resolve {1}.' translated format: {hostName})]. - ^self openConnectionToHost: hostIP port: portNumber]. - addressInformations := SocketAddressInformation - forHost: hostName - service: portNumber asString - flags: 0 - addressFamily: 0 - socketType: SocketAddressInformation socketTypeStream - protocol: SocketAddressInformation protocolTCP. - addressInformations ifEmpty: [ - NoNetworkError signal: ('Could not find a network for {1} on port {2}' translated format: {hostName. portNumber})]. - stream := addressInformations readStream. - ^ [self on: stream next connect] on: NetworkError - do: [:exc | stream atEnd - ifTrue: - ["No more address to retry, pass the exception to upper level" - exc pass] - ifFalse: - ["retry with next address" - exc retry]].! Item was removed: - ----- Method: SocketStream>><< (in category 'private') ----- - << items - - items putOn: self. - - ^ self! Item was removed: - ----- Method: SocketStream>>adjustInBuffer: (in category 'private') ----- - adjustInBuffer: bytesRead - "Adjust markers and possibly grow inBuffer or move data down. - Currently grows through doubling when less than 1024 bytes are left. - Never shrinks. Returns the position in the buffer where any new - data can be found." - - | old | - bytesRead = 0 ifTrue: [^inNextToWrite]. - old := inNextToWrite. - inNextToWrite := inNextToWrite + bytesRead. - (inBuffer size - inNextToWrite) < 1024 - ifTrue: [ - "Hit the roof, move data down (if enough has been read) or do we grow?" - (lastRead > 512) - ifTrue: [^old - self moveInBufferDown] - ifFalse: [self growInBuffer]]. - ^old! Item was removed: - ----- Method: SocketStream>>adjustOutBuffer: (in category 'private') ----- - adjustOutBuffer: bytesToWrite - "Possibly grow outBuffer to accommodate the new data. - Currently grows through doubling when less - than 1024 bytes are left. If bytesToWrite is even - larger we double that instead. Never shrinks." - - (outBuffer size - outNextToWrite - bytesToWrite) < 1024 ifTrue: [ - outBuffer := (self streamBuffer: ((outBuffer size max: bytesToWrite) * 2)) - replaceFrom: 1 to: outBuffer size with: outBuffer startingAt: 1]! Item was removed: - ----- Method: SocketStream>>ascii (in category 'configuration') ----- - ascii - "Tell the SocketStream to send data - as Strings instead of ByteArrays. - This is default." - - binary := false. - inBuffer - ifNil: [self resetBuffers] - ifNotNil: [ - ByteString - adoptInstance: inBuffer; - adoptInstance: outBuffer ]! Item was removed: - ----- Method: SocketStream>>atEnd (in category 'testing') ----- - atEnd - "There is nothing more to read when - there is no more data in our inBuffer, the socket - is disconnected and there is none available on the socket. - Note that we need to check isConnected before isDataAvailable, - otherwise data may sneak in in the meantime. But we check the - buffer first, because it is faster." - - self isInBufferEmpty ifFalse: [^false]. - ^self isConnected not - and: [self isDataAvailable not]! Item was removed: - ----- Method: SocketStream>>autoFlush (in category 'configuration') ----- - autoFlush - "If autoFlush is enabled data will be sent through - the socket (flushed) when the bufferSize is reached - or the SocketStream is closed. Otherwise the user - will have to send #flush manually. - Close will always flush. Default is false." - - ^autoFlush! Item was removed: - ----- Method: SocketStream>>autoFlush: (in category 'configuration') ----- - autoFlush: aBoolean - "If autoFlush is enabled data will be sent through - the socket (flushed) when the bufferSize is reached - or the SocketStream is closed. Otherwise the user - will have to send #flush manually. - Close will always flush. Default is false." - - autoFlush := aBoolean! Item was removed: - ----- Method: SocketStream>>beSignalingWhile: (in category 'private') ----- - beSignalingWhile: aBlock - "Temporarily turn a non-signaling SocketStream into a signaling one. - Required for some of operations that will catch ConnectionClosed in - order to find out that an operation completed" - - | signaling | - signaling := shouldSignal. - shouldSignal := true. - ^aBlock ensure:[shouldSignal := signaling] - ! Item was removed: - ----- Method: SocketStream>>binary (in category 'configuration') ----- - binary - "Tell the SocketStream to send data - as ByteArrays instead of Strings. - Default is ascii." - - binary := true. - inBuffer - ifNil: [self resetBuffers] - ifNotNil: [ - ByteArray - adoptInstance: inBuffer; - adoptInstance: outBuffer ]! Item was removed: - ----- Method: SocketStream>>bufferSize (in category 'configuration') ----- - bufferSize - "Default buffer size is 4kb. - increased from earlier 2000 bytes." - - ^bufferSize! Item was removed: - ----- Method: SocketStream>>bufferSize: (in category 'configuration') ----- - bufferSize: anInt - "Default buffer size is 4kb. - increased from earlier 2000 bytes." - - bufferSize := anInt! Item was removed: - ----- Method: SocketStream>>checkFlush (in category 'private') ----- - checkFlush - "If autoFlush is true we flush if - we have reached the bufferSize - of data in the outBuffer." - - (autoFlush and: [outNextToWrite > bufferSize]) - ifTrue: [self flush]! Item was removed: - ----- Method: SocketStream>>close (in category 'control') ----- - close - "Flush any data still not sent - and take care of the socket." - - self flush. - socket closeAndDestroy: 30. - "Reclaim memory consumed by possibly very large buffers." - self resetBuffers! Item was removed: - ----- Method: SocketStream>>cr (in category 'stream out') ----- - cr - self nextPutAll: String cr! Item was removed: - ----- Method: SocketStream>>crlf (in category 'stream out') ----- - crlf - self nextPutAll: String crlf! Item was removed: - ----- Method: SocketStream>>debug (in category 'printing') ----- - debug - "Display debug info." - - | data | - data := self inBufferSize. - ^String streamContents: [:s | - s - nextPutAll: 'Buffer size: ', inBuffer size asString;cr; - nextPutAll: 'InBuffer data size: ', data asString; cr; - nextPutAll: 'In data (20):', (inBuffer copyFrom: lastRead + 1 to: lastRead + (data min: 20)); cr; - nextPutAll: 'OutBuffer data size: ', (outNextToWrite - 1) asString; cr; - nextPutAll: 'Out data (20):', (outBuffer copyFrom: 1 to: ((outNextToWrite - 1) min: 20)); cr]! Item was removed: - ----- Method: SocketStream>>destroy (in category 'initialize-release') ----- - destroy - "Destroy the receiver and its underlying socket. Does not attempt to flush the output buffers. For a graceful close use SocketStream>>close instead." - - socket ifNotNil:[socket destroy]! Item was removed: - ----- Method: SocketStream>>flush (in category 'control') ----- - flush - "If the other end is connected and we have something - to send, then we send it and reset the outBuffer." - (outNextToWrite > 1 and: [ socket isOtherEndClosed not ]) ifTrue: - [ [ self - sendData: outBuffer - count: outNextToWrite - 1 ] - on: ConnectionTimedOut - do: [ : ex | shouldSignal ifTrue: [ ex pass ] ]. - outNextToWrite := 1 ]! Item was removed: - ----- Method: SocketStream>>growInBuffer (in category 'private') ----- - growInBuffer - "Grows through doubling." - - self resizeInBuffer: inBuffer size * 2! Item was removed: - ----- Method: SocketStream>>inBufferSize (in category 'configuration') ----- - inBufferSize - "Answers the current size of data in the inBuffer." - - ^inNextToWrite - lastRead - 1! Item was removed: - ----- Method: SocketStream>>initialize (in category 'initialize-release') ----- - initialize - autoFlush := true. - shouldSignal := true. - recentlyRead := 0. - bufferSize := 4096. - self ascii! Item was removed: - ----- Method: SocketStream>>isBinary (in category 'testing') ----- - isBinary - ^binary! Item was removed: - ----- Method: SocketStream>>isConnected (in category 'testing') ----- - isConnected - "The stream is connected if the socket is." - - ^socket isConnected! Item was removed: - ----- Method: SocketStream>>isDataAvailable (in category 'testing') ----- - isDataAvailable - "Answer if more data can be read. It the inbuffer is empty, we read more data. - - Note: It is important not to rely on 'socket dataAvailable' here since this will - not work for subclasses such as SecureSocketStream (which can contain - undecrypted contents that has been read from the socket)." - - self isInBufferEmpty ifFalse: [^true]. - ^self receiveAvailableData < inNextToWrite - ! Item was removed: - ----- Method: SocketStream>>isEmpty (in category 'testing') ----- - isEmpty - "Test if there are more data to read." - - ^self isInBufferEmpty and: [self isDataAvailable not]! Item was removed: - ----- Method: SocketStream>>isInBufferEmpty (in category 'testing') ----- - isInBufferEmpty - "Any data in the buffer?" - - ^lastRead + 1 = inNextToWrite! Item was removed: - ----- Method: SocketStream>>isOtherEndConnected (in category 'testing') ----- - isOtherEndConnected - ^socket isOtherEndClosed not! Item was removed: - ----- Method: SocketStream>>moveInBufferDown (in category 'private') ----- - moveInBufferDown - "Move down contents of inBuffer to the start. - Return distance moved." - - | sz distanceMoved | - sz := inNextToWrite - lastRead - 1. - inBuffer replaceFrom: 1 to: sz with: inBuffer startingAt: lastRead + 1. - distanceMoved := lastRead. - lastRead := 0. - inNextToWrite := sz + 1. - ^distanceMoved - ! Item was removed: - ----- Method: SocketStream>>next (in category 'stream in') ----- - next - "Return next byte, if inBuffer is empty - we recieve some more data and try again." - - self atEnd ifTrue: [^nil]. - self isInBufferEmpty ifTrue: - [self receiveData. - self atEnd ifTrue: [^nil]]. - lastRead := lastRead + 1. - ^inBuffer at: lastRead! Item was removed: - ----- Method: SocketStream>>next: (in category 'stream in') ----- - next: anInteger - "Answer anInteger bytes of data. - - NOTE: This method doesn't honor timeouts if shouldSignal is false!!" - - | start | - self receiveData: anInteger. - start := lastRead + 1. - lastRead := (lastRead + anInteger) min: inNextToWrite - 1. - ^inBuffer copyFrom: start to: lastRead! Item was removed: - ----- Method: SocketStream>>next:into: (in category 'stream in') ----- - next: n into: aCollection - "Read n objects into the given collection. - Return aCollection or a partial copy if less than - n elements have been read." - ^self next: n into: aCollection startingAt: 1! Item was removed: - ----- Method: SocketStream>>next:into:startingAt: (in category 'stream in') ----- - next: anInteger into: aCollection startingAt: startIndex - "Read n objects into the given collection. - Return aCollection or a partial copy if less than - n elements have been read." - - "Implementation note: This method DOES signal timeout if not - enough elements are received. It does NOT signal - ConnectionClosed as closing the connection is the only way by - which partial data can be read." - - | start amount | - - [self beSignalingWhile:[self receiveData: anInteger]] - on: ConnectionClosed do:[:ex| ex return]. - - "Inlined version of nextInBuffer: to avoid copying the contents" - amount := anInteger min: (inNextToWrite - lastRead - 1). - start := lastRead + 1. - lastRead := lastRead + amount. - aCollection - replaceFrom: startIndex - to: startIndex + amount-1 - with: inBuffer - startingAt: start. - ^amount < anInteger - ifTrue:[aCollection copyFrom: 1 to: startIndex + amount-1] - ifFalse:[aCollection]! Item was removed: - ----- Method: SocketStream>>next:putAll:startingAt: (in category 'stream out') ----- - next: n putAll: aCollection startingAt: startIndex - "Put a String or a ByteArray onto the stream. - Currently a large collection will allocate a large buffer. - Warning: this does not work with WideString: they have to be converted first." - - n > 0 ifFalse: [ ^aCollection ]. - self adjustOutBuffer: n. - outBuffer replaceFrom: outNextToWrite to: outNextToWrite + n - 1 with: aCollection startingAt: startIndex. - outNextToWrite := outNextToWrite + n. - self checkFlush. - ^aCollection! Item was removed: - ----- Method: SocketStream>>nextAllInBuffer (in category 'stream in') ----- - nextAllInBuffer - "Return all data currently in the inBuffer," - - ^self nextInBuffer: inNextToWrite - lastRead - 1! Item was removed: - ----- Method: SocketStream>>nextAvailable (in category 'stream in') ----- - nextAvailable - "Answer all the data currently available, - in buffer or in socket." - - self isInBufferEmpty ifFalse: [^self nextAllInBuffer]. - self isDataAvailable ifTrue: [self receiveData]. - ^self nextAllInBuffer! Item was removed: - ----- Method: SocketStream>>nextAvailable: (in category 'stream in') ----- - nextAvailable: howMany - "Answer all the data currently available, - in buffer or in socket - but limited to <howMany>." - - self isInBufferEmpty ifFalse: [^self nextInBuffer: howMany]. - self isDataAvailable ifTrue: [self receiveData]. - ^self nextInBuffer: howMany! Item was removed: - ----- Method: SocketStream>>nextInBuffer: (in category 'stream in') ----- - nextInBuffer: anInteger - "Answer anInteger bytes of data at most, - but only from the inBuffer." - - | start amount | - amount := anInteger min: (inNextToWrite - lastRead - 1). - start := lastRead + 1. - lastRead := lastRead + amount. - ^inBuffer copyFrom: start to: lastRead! Item was removed: - ----- Method: SocketStream>>nextInto: (in category 'stream in') ----- - nextInto: aCollection - "Read the next elements of the receiver into aCollection. - Return aCollection or a partial copy if less than aCollection - size elements have been read." - ^self next: aCollection size into: aCollection startingAt: 1.! Item was removed: - ----- Method: SocketStream>>nextInto:startingAt: (in category 'stream in') ----- - nextInto: aCollection startingAt: startIndex - "Read the next elements of the receiver into aCollection. - Return aCollection or a partial copy if less than aCollection - size elements have been read." - ^self next: (aCollection size - startIndex+1) into: aCollection startingAt: startIndex.! Item was removed: - ----- Method: SocketStream>>nextLine (in category 'stream in') ----- - nextLine - ^self nextLineCrLf! Item was removed: - ----- Method: SocketStream>>nextLineCrLf (in category 'stream in') ----- - nextLineCrLf - ^self upToAll: String crlf! Item was removed: - ----- Method: SocketStream>>nextLineLf (in category 'stream in') ----- - nextLineLf - | nextLine | - nextLine := self upToAll: String lf. - ^nextLine! Item was removed: - ----- Method: SocketStream>>nextPut: (in category 'stream out') ----- - nextPut: char - "Put a single Character or byte onto the stream." - - | toPut | - toPut := binary ifTrue: [char asInteger] ifFalse: [char asCharacter]. - self adjustOutBuffer: 1. - outBuffer at: outNextToWrite put: toPut. - outNextToWrite := outNextToWrite + 1. - self checkFlush. - "return the argument - added by kwl" - ^ char! Item was removed: - ----- Method: SocketStream>>nextPutAll: (in category 'stream out') ----- - nextPutAll: aCollection - "Put a String or a ByteArray onto the stream. - Currently a large collection will allocate a large buffer." - - | toPut | - toPut := binary ifTrue: [aCollection asByteArray] ifFalse: [aCollection asString]. - self adjustOutBuffer: toPut size. - outBuffer replaceFrom: outNextToWrite to: outNextToWrite + toPut size - 1 with: toPut startingAt: 1. - outNextToWrite := outNextToWrite + toPut size. - self checkFlush. - ^aCollection! Item was removed: - ----- Method: SocketStream>>nextPutAllFlush: (in category 'stream out') ----- - nextPutAllFlush: aCollection - "Put a String or a ByteArray onto the stream. - You can use this if you have very large data - it avoids - copying into the buffer (and avoids buffer growing) - and also flushes any other pending data first." - | toPut | - toPut := binary - ifTrue: [ aCollection asByteArray ] - ifFalse: [ aCollection asString ]. - self flush. - "first flush pending stuff, then directly send" - socket isOtherEndClosed ifFalse: - [ [ self - sendData: toPut - count: toPut size ] - on: ConnectionTimedOut - do: [ : ex | shouldSignal ifTrue: [ ex pass ] ] ]! Item was removed: - ----- Method: SocketStream>>noTimeout (in category 'configuration') ----- - noTimeout - "Do not use timeout." - - timeout := 0! Item was removed: - ----- Method: SocketStream>>outBufferSize (in category 'configuration') ----- - outBufferSize - "Answers the current size of data in the outBuffer." - - ^outNextToWrite - 1! Item was removed: - ----- Method: SocketStream>>peek (in category 'stream in') ----- - peek - "Return next byte, if inBuffer is empty - we recieve some more data and try again. - Do not consume the byte." - - self atEnd ifTrue: [^nil]. - self isInBufferEmpty ifTrue: - [self receiveData. - self atEnd ifTrue: [^nil]]. - ^inBuffer at: lastRead+1! Item was removed: - ----- Method: SocketStream>>peek: (in category 'stream in') ----- - peek: anInteger - "Answer anInteger bytes of data. - Do not consume data. - - NOTE: This method doesn't honor timeouts if shouldSignal is false!!" - - | start | - self receiveData: anInteger. - start := lastRead + 1. - ^inBuffer copyFrom: start to: ((lastRead + anInteger) min: inNextToWrite - 1).! Item was removed: - ----- Method: SocketStream>>peekFor: (in category 'stream in') ----- - peekFor: aCharacterOrByte - "Read and return next character or byte - if it is equal to the argument. - Otherwise return false." - - | nextObject | - self atEnd ifTrue: [^false]. - self isInBufferEmpty ifTrue: - [self receiveData. - self atEnd ifTrue: [^false]]. - nextObject := inBuffer at: lastRead + 1. - nextObject = aCharacterOrByte ifTrue: [ - lastRead := lastRead + 1. - ^true]. - ^false - ! Item was removed: - ----- Method: SocketStream>>peekForAll: (in category 'stream in') ----- - peekForAll: aString - "Answer whether or not the next string of characters in the receiver - matches aString. If a match is made, advance over that string in the receiver and - answer true. If no match, then leave the receiver alone and answer false. - We use findString:startingAt: to avoid copying. - - NOTE: This method doesn't honor timeouts if shouldSignal is false!!" - - | sz start | - sz := aString size. - self receiveData: sz. - (inNextToWrite - lastRead - 1) < sz ifTrue: [^false]. - start := lastRead + 1. - (inBuffer findString: aString startingAt: start) = start - ifFalse: [^false]. - lastRead := lastRead + sz. - ^true! Item was removed: - ----- Method: SocketStream>>print: (in category 'printing') ----- - print: anObject - anObject printOn: self! Item was removed: - ----- Method: SocketStream>>printOn: (in category 'printing') ----- - printOn: aStream - "Display buffer sizes." - - aStream nextPutAll: self class name. - inBuffer ifNotNil: [ - aStream nextPutAll: '[inbuf:', - (inBuffer size / 1024) rounded asString, 'kb/outbuf:', - (outBuffer size / 1024) rounded asString, 'kb]']! Item was removed: - ----- Method: SocketStream>>readInto:startingAt:count: (in category 'stream in') ----- - readInto: aCollection startingAt: startIndex count: anInteger - "Read n objects into the given collection starting at startIndex. - Return number of elements that have been read." - - "Implementation note: This method DOES signal timeout if not - enough elements are received. It does NOT signal - ConnectionClosed as closing the connection is the only way by - which partial data can be read." - - | start amount | - - [self beSignalingWhile:[self receiveData: anInteger]] - on: ConnectionClosed do:[:ex| ex return]. - - "Inlined version of nextInBuffer: to avoid copying the contents" - amount := anInteger min: (inNextToWrite - lastRead - 1). - start := lastRead + 1. - lastRead := lastRead + amount. - aCollection - replaceFrom: startIndex - to: startIndex + amount-1 - with: inBuffer - startingAt: start. - ^amount! Item was removed: - ----- Method: SocketStream>>receiveAvailableData (in category 'private-socket') ----- - receiveAvailableData - "Receive available data (as much as fits in the inBuffer) but not waiting for more to arrive. Return the position in the buffer where the new data starts, regardless if anything was read, see #adjustInBuffer." - - recentlyRead := self receiveDataInto: inBuffer startingAt: inNextToWrite. - ^self adjustInBuffer: recentlyRead! Item was removed: - ----- Method: SocketStream>>receiveData (in category 'private-socket') ----- - receiveData - self waitForData. - ^self receiveAvailableData! Item was removed: - ----- Method: SocketStream>>receiveData: (in category 'control') ----- - receiveData: nBytes - "Keep reading the socket until we have nBytes - in the inBuffer or we reach the end. This method - does not return data, but can be used to make sure - data has been read into the buffer from the Socket - before actually reading it from the FastSocketStream. - Mainly used internally. We could also adjust the buffer - to the expected amount of data and avoiding several - incremental grow operations. - - NOTE: This method doesn't honor timeouts if shouldSignal - is false!! And frankly, I am not sure how to handle that - case or if I care - I think we should always signal." - - [self atEnd not and: [nBytes > self inBufferSize]] - whileTrue: [self receiveData]! Item was removed: - ----- Method: SocketStream>>receiveDataInto:startingAt: (in category 'private-socket') ----- - receiveDataInto: buffer startingAt: index. - "Read data from the underlying socket. This method may be overridden by subclasses wanting to control incoming traffic for other purposes like encryption or statistics." - - ^socket receiveAvailableDataInto: buffer startingAt: index.! Item was removed: - ----- Method: SocketStream>>recentlyRead (in category 'control') ----- - recentlyRead - "Return the number of bytes read - during the last socket operation." - - ^recentlyRead! Item was removed: - ----- Method: SocketStream>>resetBuffers (in category 'private') ----- - resetBuffers - "Recreate the buffers with default start sizes." - - (inBuffer isNil or: [ inBuffer size ~= bufferSize ]) ifTrue: [ - inBuffer := self streamBuffer: bufferSize ]. - lastRead := 0. - inNextToWrite := 1. - (outBuffer isNil or: [ outBuffer size ~= bufferSize ]) ifTrue: [ - outBuffer := self streamBuffer: bufferSize ]. - outNextToWrite := 1! Item was removed: - ----- Method: SocketStream>>resizeInBuffer: (in category 'private') ----- - resizeInBuffer: newSize - "Resize the inBuffer by recreating it. - This also has the effect of getting rid of - dead data above inNextToWrite. - <newSize> must >= inBuffer size!!" - - inBuffer := (self streamBuffer: newSize) - replaceFrom: 1 to: inNextToWrite - 1 with: inBuffer startingAt: 1! Item was removed: - ----- Method: SocketStream>>sendCommand: (in category 'stream out') ----- - sendCommand: aString - "Sends a String ending it with CR LF and then flush - causing it to block until sent." - - self nextPutAll: aString, String crlf; flush! Item was removed: - ----- Method: SocketStream>>sendData:count: (in category 'private-socket') ----- - sendData: buffer count: n - "Sends outgoing data directly on the underlying socket." - - ^socket sendData: buffer count: n! Item was removed: - ----- Method: SocketStream>>shouldSignal (in category 'configuration') ----- - shouldSignal - "If shouldSignal is enabled the Socket Exceptions - ConnectionClosed and ConnectionTimedOut - will not be swallowed. Default is true. - For more info, see #shouldSignal:" - - ^shouldSignal! Item was removed: - ----- Method: SocketStream>>shouldSignal: (in category 'configuration') ----- - shouldSignal: aBoolean - "If shouldSignal is enabled the Socket Exceptions - ConnectionClosed and ConnectionTimedOut will not be swallowed. - Default is true. And please - don't set it to false - it is better to - use an exception handler (see below) and several methods - in this class will not honour timeouts (says so in their method comments). - Also, it is quite hard to understand what for example #upToEnd - should return to indicate a timeout. - - Wrap your use of SocketStream with a handler like: - - [stuff := mySocketStream next: 10] - on: ConnectionClosed, ConnectionTimedOut - do: [:ex | - Transcript show: 'Oops!! Did not get my ten bytes!!;cr] - " - - shouldSignal := aBoolean! Item was removed: - ----- Method: SocketStream>>shouldTimeout (in category 'testing') ----- - shouldTimeout - ^self timeout > 0! Item was removed: - ----- Method: SocketStream>>signalClosed (in category 'private-socket') ----- - signalClosed - self shouldSignal ifFalse: [^ self]. - ConnectionClosed signal: 'Connection closed while waiting for data.' translated.! Item was removed: - ----- Method: SocketStream>>signalTimeout (in category 'private-socket') ----- - signalTimeout - self shouldSignal ifFalse: [^ self]. - ConnectionTimedOut signal: 'Data receive timed out.' translated.! Item was removed: - ----- Method: SocketStream>>skip: (in category 'stream in') ----- - skip: anInteger - "Skip a number of bytes. - This is faster than #next: since it does not - have to copy and return a new String or ByteArray. - - NOTE: This method doesn't honor timeouts if shouldSignal is false!!" - - self receiveData: anInteger. - lastRead := (lastRead + anInteger) min: inNextToWrite - 1! Item was removed: - ----- Method: SocketStream>>socket (in category 'configuration') ----- - socket - ^socket! Item was removed: - ----- Method: SocketStream>>socket: (in category 'configuration') ----- - socket: aSocket - socket := aSocket! Item was removed: - ----- Method: SocketStream>>space (in category 'stream out') ----- - space - self nextPut: Character space! Item was removed: - ----- Method: SocketStream>>streamBuffer: (in category 'private') ----- - streamBuffer: size - "Create a buffer of the correct class and given size." - - ^(self isBinary - ifTrue: [ByteArray] - ifFalse: [String]) new: size! Item was removed: - ----- Method: SocketStream>>timeout (in category 'configuration') ----- - timeout - "Lazily initialized unless it has been set explicitly." - - timeout ifNil: [timeout := Socket standardTimeout]. - ^timeout! Item was removed: - ----- Method: SocketStream>>timeout: (in category 'configuration') ----- - timeout: seconds - timeout := seconds! Item was removed: - ----- Method: SocketStream>>upTo: (in category 'stream in') ----- - upTo: aCharacterOrByte - "Answer a subcollection from the current access position to the occurrence (if any, but not inclusive) of anObject in the receiver. If anObject is not in the collection, answer the entire rest of the receiver." - - ^self upTo: aCharacterOrByte limit: nil! Item was removed: - ----- Method: SocketStream>>upTo:limit: (in category 'stream in') ----- - upTo: aCharacterOrByte limit: nBytes - "Return data up to, but not including given character or byte. If the character is not in the stream, or not found within nBytes answer the available contents of the stream" - - | target index result searchedSoFar | - "Deal with ascii vs. binary" - self isBinary - ifTrue:[target := aCharacterOrByte asInteger] - ifFalse:[target := aCharacterOrByte asCharacter]. - - "Look in the current inBuffer first" - index := inBuffer indexOf: target startingAt: lastRead + 1. - - (index > 0 and: [(index + 1) <= inNextToWrite]) ifTrue: ["found it" - result := self nextInBuffer: index - lastRead - 1. - self skip: 1. - ^ result - ]. - - [searchedSoFar := self inBufferSize. - "Receive more data" - self receiveData. - "We only get recentlyRead = 0 in the case of a non-signaling socket close." - recentlyRead > 0] whileTrue:[ - "Data begins at lastRead + 1, we add searchedSoFar as offset." - - index := inBuffer indexOf: target startingAt: (lastRead + searchedSoFar + 1). - (index > 0 and: [(index + 1) <= inNextToWrite]) ifTrue: ["found it" - result := self nextInBuffer: index - lastRead - 1. - self skip: 1. - ^ result - ]. - - "Check if we've exceeded the max. amount" - (nBytes notNil and:[inNextToWrite - lastRead > nBytes]) - ifTrue:[^self nextAllInBuffer]. - ]. - - "not found and (non-signaling) connection was closed" - ^self nextAllInBuffer! Item was removed: - ----- Method: SocketStream>>upToAll: (in category 'stream in') ----- - upToAll: aStringOrByteArray - "Answer a subcollection from the current access position to the occurrence (if any, but not inclusive) of aCollection. If aCollection is not in the stream, answer the entire rest of the stream." - - "Note: The 100k limit below is compatible with the previous version though arguably incorrect. If you need unbounded behavior either up the argument or provide nil in which case we'll read until we get it or run out of memory" - - ^self upToAll: aStringOrByteArray limit: 100000! Item was removed: - ----- Method: SocketStream>>upToAll:limit: (in category 'stream in') ----- - upToAll: aStringOrByteArray limit: nBytes - "Answer a subcollection from the current access position to the occurrence (if any, but not inclusive) of aStringOrByteArray. If aCollection is not in the stream, or not found within nBytes answer the available contents of the stream" - - | index sz result searchedSoFar target | - "Deal with ascii vs. binary" - target := self isBinary - ifTrue:[aStringOrByteArray asByteArray] - ifFalse:[aStringOrByteArray asString]. - - sz := target size. - "Look in the current inBuffer first" - index := inBuffer indexOfSubCollection: target - startingAt: (lastRead - sz + 2 max: 1). - (index > 0 and: [(index + sz) <= inNextToWrite]) ifTrue: ["found it" - result := self nextInBuffer: index - lastRead - 1. - self skip: sz. - ^ result - ]. - - [searchedSoFar := self inBufferSize. - "Receive more data" - self receiveData. - recentlyRead > 0] whileTrue:[ - - "Data begins at lastRead + 1, we add searchedSoFar as offset and - backs up sz - 1 so that we can catch any borderline hits." - - index := inBuffer indexOfSubCollection: target - startingAt: (lastRead + searchedSoFar - sz + 2 max: 1). - (index > 0 and: [(index + sz) <= inNextToWrite]) ifTrue: ["found it" - result := self nextInBuffer: index - lastRead - 1. - self skip: sz. - ^ result - ]. - "Check if we've exceeded the max. amount" - (nBytes notNil and:[inNextToWrite - lastRead > nBytes]) - ifTrue:[^self nextAllInBuffer]. - ]. - - "not found and (non-signaling) connection was closed" - ^self nextAllInBuffer! Item was removed: - ----- Method: SocketStream>>upToEnd (in category 'stream in') ----- - upToEnd - "Answer all data coming in on the socket until the socket - is closed by the other end, or we get a timeout. - This means this method catches ConnectionClosed by itself." - - [[self atEnd] whileFalse: [self beSignalingWhile:[self receiveData]]] - on: ConnectionClosed - do: [:ex | "swallow it"]. - ^self nextAllInBuffer! Item was removed: - ----- Method: SocketStream>>waitForData (in category 'private-socket') ----- - waitForData - "Wait for data. If shouldTimeout, we will time out if nothing arrives, otherwise we wait indefinitely" - - self shouldTimeout - ifTrue: [socket waitForDataFor: self timeout - ifClosed: [self signalClosed] - ifTimedOut: [self signalTimeout]] - ifFalse: [socket waitForDataIfClosed: [self signalClosed]]! Item was removed: - Socket subclass: #SocksSocket - instanceVariableNames: 'vers method socksIP socksPort dstPort dstIP dstName' - classVariableNames: 'DefaultSocksVersion' - poolDictionaries: '' - category: 'Network-Kernel'! - - !SocksSocket commentStamp: '<historical>' prior: 0! - This class implements the socks 4 and partially socks 5 connection protocol. - For backward compatibility the socks protocol is disabled by default, so subclasses still work. - For further documentation check out: - - Socks4: http://spiderman.socks.nec.com/protocol/socks4.protocol - - Socks5: http://spiderman.socks.nec.com/rfc/rfc1928.txt! Item was removed: - ----- Method: SocksSocket class>>defaultSocksHostAddress (in category 'accessing') ----- - defaultSocksHostAddress - - ^NetNameResolver addressForName: HTTPSocket httpProxyServer! Item was removed: - ----- Method: SocksSocket class>>defaultSocksPort (in category 'accessing') ----- - defaultSocksPort - ^HTTPSocket httpProxyPort! Item was removed: - ----- Method: SocksSocket class>>defaultSocksVersion (in category 'accessing') ----- - defaultSocksVersion - "nil means no socks" - ^DefaultSocksVersion! Item was removed: - ----- Method: SocksSocket class>>defaultSocksVersion: (in category 'accessing') ----- - defaultSocksVersion: anInteger - "nil means no socks" - DefaultSocksVersion := anInteger! Item was removed: - ----- Method: SocksSocket class>>noAutorizationMethod (in category 'accessing') ----- - noAutorizationMethod - ^0! Item was removed: - ----- Method: SocksSocket>>connectCommandCode (in category 'private') ----- - connectCommandCode - ^1! Item was removed: - ----- Method: SocksSocket>>connectSocks4 (in category 'socks4') ----- - connectSocks4 - self - sendSocks4ConnectionRequestUserId: ''; - waitForSocks4ConnectionReply. - ! Item was removed: - ----- Method: SocksSocket>>connectSocks5 (in category 'socks5') ----- - connectSocks5 - self - socks5MethodSelection; - sendSocks5ConnectionRequest; - socks5RequestReply - ! Item was removed: - ----- Method: SocksSocket>>connectTo:port: (in category 'connection open/close') ----- - connectTo: hostAddress port: port - self initializeNetwork. - self shouldUseSocks - ifFalse: [^super connectTo: hostAddress port: port]. - super connectTo: socksIP port: socksPort. - self waitForConnectionFor: Socket standardTimeout. - dstIP := hostAddress. - dstPort := port. - vers = 4 - ifTrue: [self connectSocks4] - ifFalse: [self connectSocks5] - ! Item was removed: - ----- Method: SocksSocket>>connectToHostNamed:port: (in category 'connection open/close') ----- - connectToHostNamed: hostName port: port - super connectTo: socksIP port: socksPort. - self waitForConnectionFor: Socket standardTimeout. - dstName := hostName. - dstPort := port. - vers = 4 - ifTrue: [self connectSocks4] - ifFalse: [self connectSocks5] - ! Item was removed: - ----- Method: SocksSocket>>defaultTimeOutDuration (in category 'private') ----- - defaultTimeOutDuration - ^20000! Item was removed: - ----- Method: SocksSocket>>dstIP (in category 'private') ----- - dstIP - ^dstIP! Item was removed: - ----- Method: SocksSocket>>dstPort (in category 'private') ----- - dstPort - ^dstPort! Item was removed: - ----- Method: SocksSocket>>hostIP6Code (in category 'socks5') ----- - hostIP6Code - ^4! Item was removed: - ----- Method: SocksSocket>>hostIPCode (in category 'socks5') ----- - hostIPCode - ^1! Item was removed: - ----- Method: SocksSocket>>qualifiedHostNameCode (in category 'socks5') ----- - qualifiedHostNameCode - ^3! Item was removed: - ----- Method: SocksSocket>>requestGrantedCode (in category 'private') ----- - requestGrantedCode - ^90! Item was removed: - ----- Method: SocksSocket>>sendSocks4ConnectionRequestUserId: (in category 'socks4') ----- - sendSocks4ConnectionRequestUserId: userId - "The client connects to the SOCKS server and sends a CONNECT request when - it wants to establish a connection to an application server. The client - includes in the request packet the IP address and the port number of the - destination host, and userid, in the following format. - - +----+----+----+----+----+----+----+----+----+----+....+----+ - | VN | CD | DSTPORT | DSTIP | USERID |NULL| - +----+----+----+----+----+----+----+----+----+----+....+----+ - 1 1 2 4 variable 1 - " - - | requestString | - requestString := WriteStream on: ByteArray new. - dstIP - ifNil: [dstIP := NetNameResolver addressForName: dstName]. - requestString - nextPut: 4; - nextPut: self connectCommandCode; - nextWordPut: dstPort; - nextPutAll: self dstIP; - nextPutAll: userId asByteArray; - nextPut: 0. - self sendData: requestString contents! Item was removed: - ----- Method: SocksSocket>>sendSocks5ConnectionRequest (in category 'socks5') ----- - sendSocks5ConnectionRequest - "Once the method-dependent subnegotiation has completed, the client - sends the request details." - - | requestString | - requestString := WriteStream on: ByteArray new. - requestString - nextPut: 5; - nextPut: self connectCommandCode; - nextPut: 0. "Reserved slot" - dstName isNil - ifTrue: [ - requestString - nextPutAll: self hostIPCode; - nextPutAll: dstIP] - ifFalse: [ - requestString - nextPut: self qualifiedHostNameCode; - nextPut: dstName size; - nextPutAll: dstName asByteArray]. - requestString nextWordPut: dstPort. - self sendData: requestString contents! Item was removed: - ----- Method: SocksSocket>>shouldUseSocks (in category 'private') ----- - shouldUseSocks - ^vers notNil! Item was removed: - ----- Method: SocksSocket>>skipQualifiedHostName (in category 'socks5') ----- - skipQualifiedHostName - - | startTime response bytesRead | - startTime := Time millisecondClockValue. - response := ByteArray new: 1. - - [(bytesRead := self receiveDataInto: response) < 1 - and: [(Time millisecondClockValue - startTime) < self defaultTimeOutDuration]] whileTrue. - - bytesRead < 1 - ifTrue: [self socksError: 'Time out reading data']. - - self waitForReply: (response at: 1) + 2 for: self defaultTimeOutDuration! Item was removed: - ----- Method: SocksSocket>>socks4 (in category 'initialize') ----- - socks4 - vers := 4. - method := nil. - socksIP := self class defaultSocksHostAddress. - socksPort := self class defaultSocksPort! Item was removed: - ----- Method: SocksSocket>>socks5 (in category 'initialize') ----- - socks5 - vers := 5. - method := self class noAutorizationMethod. - socksIP := self class defaultSocksHostAddress. - socksPort := self class defaultSocksPort! Item was removed: - ----- Method: SocksSocket>>socks5MethodSelection (in category 'socks5') ----- - socks5MethodSelection - "The client connects to the server, and sends a version - identifier/method selection message. - The server selects from one of the methods given in METHODS, and - sends a METHOD selection message." - - | requestString response | - requestString := WriteStream on: ByteArray new. - requestString - nextPut: 5; - nextPut: 1; - nextPut: 0. - self sendData: requestString contents. - - response := self waitForReply: 2 for: self defaultTimeOutDuration. - (response at: 2) = 16rFF - ifTrue: [self socksError: 'No acceptable methods.'] - ifFalse: [method := response at: 2]! Item was removed: - ----- Method: SocksSocket>>socks5RequestReply (in category 'socks5') ----- - socks5RequestReply - - | response | - response := self waitForReply: 4 for: self defaultTimeOutDuration. - "Skip rest for now." - (response at: 4) = self hostIPCode - ifTrue: [self waitForReply: 6 for: self defaultTimeOutDuration]. - (response at: 4) = self qualifiedHostNameCode - ifTrue: [self skipQualifiedHostName]. - (response at: 4) = self hostIP6Code - ifTrue: [self waitForReply: 18 for: self defaultTimeOutDuration]. - (response at: 2) ~= 0 - ifTrue: [^self socksError: 'Connection failed: ', (response at: 2) printString]. - ! Item was removed: - ----- Method: SocksSocket>>socksError: (in category 'private') ----- - socksError: errorString - self close; destroy. - self error: errorString! Item was removed: - ----- Method: SocksSocket>>waitForReply:for: (in category 'private') ----- - waitForReply: replySize for: timeOutDuration - | startTime response delay bytesRead | - startTime := Time millisecondClockValue. - response := ByteArray new: replySize. - bytesRead := 0. - delay := Delay forMilliseconds: 500. - [bytesRead < replySize - and: [(Time millisecondClockValue - startTime) < timeOutDuration]] whileTrue: [ - bytesRead := bytesRead + (self receiveDataInto: response). - delay wait. - Transcript show: '.']. - bytesRead < replySize - ifTrue: [self close; destroy. - ^ (ConnectionRefused host: self dstIP port: self dstPort) signal]. - ^response! Item was removed: - ----- Method: SocksSocket>>waitForSocks4ConnectionReply (in category 'socks4') ----- - waitForSocks4ConnectionReply - - | response | - response := self waitForReply: 8 for: self defaultTimeOutDuration. - - (response at: 2) = self requestGrantedCode - ifFalse: [^self socksError: 'Connection failed: ' , (response at: 2) printString].! Item was removed: - ----- Method: String>>asAlphaNumeric:extraChars:mergeUID: (in category '*network-uuid') ----- - asAlphaNumeric: totalSize extraChars: additionallyAllowed mergeUID: minimalSizeOfRandomPart - "Generates a String with unique identifier ( UID ) qualities, the difference to a - UUID is that its beginning is derived from the receiver, so that it has a meaning - for a human reader. - - Answers a String of totalSize, which consists of 3 parts - 1.part: the beginning of the receiver only consisting of - a-z, A-Z, 0-9 and extraChars in Collection additionallyAllowed ( which can be nil ) - 2.part: a single _ - 3.part: a ( random ) UID of size >= minimalSizeOfRandomPart consisting of - a-z, A-Z, 0-9 - - Starting letters are capitalized. - TotalSize must be at least 1. - Exactly 1 occurrence of $_ is guaranteed ( unless additionallyAllowed includes $_ ). - The random part has even for small sizes good UID qualitites for many practical purposes. - If only lower- or uppercase letters are demanded, simply convert the answer with - say #asLowercase. The probability of a duplicate will rise only moderately ( see below ). - - Example: - size of random part = 10 - in n generated UIDs the chance p of having non-unique UIDs is - n = 10000 -> p < 1e-10 if answer is reduced to lowerCase: p < 1.4 e-8 - n = 100000 -> p < 1e-8 - at the bottom is a snippet for your own calculations - Note: the calculated propabilites are theoretical, - for the actually used random generator they may be much worse" - - | stream out sizeOfFirstPart index ascii ch skip array random | - totalSize > minimalSizeOfRandomPart - ifFalse: [ self errorOutOfBounds ]. - stream := ReadStream on: self. - out := WriteStream on: ( String new: totalSize ). - index := 0. - skip := true. - sizeOfFirstPart := totalSize - minimalSizeOfRandomPart - 1. - [ stream atEnd or: [ index >= sizeOfFirstPart ]] - whileFalse: [ - ((( ascii := ( ch := stream next ) asciiValue ) >= 65 and: [ ascii <= 90 ]) or: [ - ( ascii >= 97 and: [ ascii <= 122 ]) or: [ - ch isDigit or: [ - additionallyAllowed notNil and: [ additionallyAllowed includes: ch ]]]]) - ifTrue: [ - skip - ifTrue: [ out nextPut: ch asUppercase ] - ifFalse: [ out nextPut: ch ]. - index := index + 1. - skip := false ] - ifFalse: [ skip := true ]]. - out nextPut: $_. - array := Array new: 62. - 1 to: 26 do: [ :i | - array at: i put: ( i + 64 ) asCharacter. - array at: i + 26 put: ( i + 96 ) asCharacter ]. - 53 to: 62 do: [ :i | - array at: i put: ( i - 5 ) asCharacter ]. - random := ThreadSafeRandom value. - totalSize - index - 1 timesRepeat: [ - out nextPut: ( array atRandom: random )]. - ^out contents - - " calculation of probability p for failure of uniqueness in n UIDs - Note: if answer will be converted to upper or lower case replace 62 with 36 - | n i p all | - all := 62 raisedTo: sizeOfRandomPart. - i := 1. - p := 0.0 . - n := 10000. - [ i <= n ] - whileTrue: [ - p := p + (( i - 1 ) / all ). - i := i + 1 ]. - p - - approximation formula: n squared / ( 62.0 raisedTo: sizeOfRandomPart ) / 2 - " - - "'Crop SketchMorphs and Grab Screen Rect to JPG' - asAlphaNumeric: 31 extraChars: nil mergeUID: 10 - 'CropSketchMorphsAndG_iOw94jquN6' - 'Monticello' - asAlphaNumeric: 31 extraChars: nil mergeUID: 10 - 'Monticello_kp6aV2l0IZK9uBULGOeG' - 'version-', ( '1.1.2' replaceAll: $. with: $- ) - asAlphaNumeric: 31 extraChars: #( $- ) mergeUID: 10 - 'Version-1-1-2_kuz2tMg2xX9iRLDVR'" - ! Item was removed: - ----- Method: String>>asURI (in category '*network-uri') ----- - asURI - "convert to a Url" - "'http://www.cc.gatech.edu/' asURI" - "'msw://chaos.resnet.gatech.edu:9000/' asURI" - ^URI fromString: self! Item was removed: - ----- Method: String>>asUrl (in category '*network-url') ----- - asUrl - "convert to a Url" - "'http://www.cc.gatech.edu/' asUrl" - "msw://chaos.resnet.gatech.edu:9000/' asUrl" - ^Url absoluteFromText: self! Item was removed: - ----- Method: String>>asUrlRelativeTo: (in category '*network-url') ----- - asUrlRelativeTo: aUrl - ^aUrl newFromRelativeText: self! Item was removed: - ----- Method: String>>urlEncoded (in category '*network-url') ----- - urlEncoded - "Encode the receiver, which is assumed to be URL, properly. - This method is specific to URLs in such that it will parse - the url and perform a semantically correct substitution, for example: - - 'http://squeak.org/name with space?and=value' encodeForHTTP. - => 'http%3A%2F%2Fsqueak.org%2Fname%20with%20space%3Fand%3Dvalue' - - 'http://squeak.org/name with space?and=value' urlEncoded. - => 'http://squeak.org/name%20with%20space?and=value" - - ^self asUrl asString! Item was removed: - ProjectSwikiServer subclass: #SuperSwikiServer - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-RemoteDirectory'! Item was removed: - ----- Method: SuperSwikiServer class>>currentSuperSwiki (in category 'instances') ----- - currentSuperSwiki - - "make this return nil to disable SuperSwiki hack" - - ^self defaultSuperSwiki - - ! Item was removed: - ----- Method: SuperSwikiServer class>>defaultEncodingName (in category 'defaults') ----- - defaultEncodingName - Locale current isoLanguage = 'ja' ifTrue: [^'shift_jis' copy] ifFalse: [^'latin1' copy]. - ! Item was removed: - ----- Method: SuperSwikiServer class>>defaultSuperSwiki (in category 'instances') ----- - defaultSuperSwiki - - ^SuperSwikiServer new - type: #http; - server: self defaultSuperSwikiIPAddress; - directory: '/super/SuperSwikiProj' - - ! Item was removed: - ----- Method: SuperSwikiServer class>>defaultSuperSwikiIPAddress (in category 'instances') ----- - defaultSuperSwikiIPAddress - - ^'209.143.91.36' - ! Item was removed: - ----- Method: SuperSwikiServer class>>testOnlySuperSwiki (in category 'tests') ----- - testOnlySuperSwiki - - ^SuperSwikiServer new - type: #http; - server: self defaultSuperSwikiIPAddress; - directory: '/super/SuperSwikiProj' - - ! Item was removed: - ----- Method: SuperSwikiServer>>allEntries (in category 'for real') ----- - allEntries - - | answer | - - answer := self sendToSwikiProjectServer: { - 'action: listallprojects'. - }. - (answer beginsWith: 'OK') ifFalse: [^#()]. - ^self parseListEntries: answer! Item was removed: - ----- Method: SuperSwikiServer>>directoryNames (in category 'for real') ----- - directoryNames - - ^self entries select:[:each| each isDirectory] thenCollect: [ :each | each name]! Item was removed: - ----- Method: SuperSwikiServer>>directoryWrapperClass (in category 'for real') ----- - directoryWrapperClass - - ^SuperSwikiDirectoryWrapper! Item was removed: - ----- Method: SuperSwikiServer>>encodingName (in category 'accessing') ----- - encodingName - (super encodingName) ifNil: [ ^SuperSwikiServer defaultEncodingName ] ifNotNil: [^super encodingName].! Item was removed: - ----- Method: SuperSwikiServer>>entries (in category 'for real') ----- - entries - - ^self allEntries! Item was removed: - ----- Method: SuperSwikiServer>>fastParseEntriesFrom: (in category 'for real') ----- - fastParseEntriesFrom: aString - - | c first | - - c := OrderedCollection new. - first := true. - aString linesDo: [ :x | | xEntryName ch xIsDirectory strm xCreationTime xModificationTime xFileSize | - 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 removed: - ----- Method: SuperSwikiServer>>fileNames (in category 'for real') ----- - fileNames - - ^self entries select:[:each| each isDirectory not] thenCollect: [ :each | each name]! Item was removed: - ----- Method: SuperSwikiServer>>getOnly:from: (in category 'for real') ----- - getOnly: numberOfBytes from: aName - - | answer | - - answer := self sendToSwikiProjectServer: { - 'action: readnamedfile'. - 'projectname: ',aName. - 'bytestoread: ',numberOfBytes printString. - }. - (answer beginsWith: 'OK') ifFalse: [ ^nil]. - ^answer allButFirst: 3 - ! Item was removed: - ----- Method: SuperSwikiServer>>isSearchable (in category 'testing') ----- - isSearchable - ^true! Item was removed: - ----- Method: SuperSwikiServer>>matchingEntries: (in category 'for real') ----- - matchingEntries: criteria - | result | - eToyUserListUrl ifNil:[^self entries]. - result := self sendToSwikiProjectServer: { - 'action: listmatchingprojects'. - } , criteria. - (result beginsWith: 'OK') - ifFalse: [^self entries]. "If command not supported" - ^self parseListEntries: result! Item was removed: - ----- Method: SuperSwikiServer>>oldFileNamed: (in category 'for real') ----- - oldFileNamed: aName - - | answer | - - answer := self sendToSwikiProjectServer: { - 'action: readnamedfile'. - 'projectname: ',aName convertToEncoding: self encodingName. - }. - (answer beginsWith: 'OK') ifFalse: [ ^nil]. - ^(SwikiPseudoFileStream with: (answer allButFirst: 3)) - reset; - directory: self; - localName: (aName convertToEncoding: self encodingName); - yourself - ! Item was removed: - ----- Method: SuperSwikiServer>>oldFileOrNoneNamed: (in category 'for real') ----- - oldFileOrNoneNamed: fullName - - | answer aName | - - self flag: #bob. "fix this up for full names" - - aName := fullName. - answer := self sendToSwikiProjectServer: { - 'action: readnamedfile'. - 'projectname: ',(self localNameFor: aName). - }. - (answer beginsWith: 'OK') ifFalse: [^nil]. - ^(SwikiPseudoFileStream with: (answer allButFirst: 3)) - reset; - directory: self; - localName: aName; - yourself - ! Item was removed: - ----- Method: SuperSwikiServer>>parseListEntries: (in category 'private') ----- - parseListEntries: listResult - - | c first | - c := self fastParseEntriesFrom: listResult. - c ifNotNil: [^c]. - c := OrderedCollection new. - first := true. - listResult linesDo: [ :x | - first ifFalse: [c add: (Compiler evaluate: x)]. - first := false. - ]. - ^c - ! Item was removed: - ----- Method: SuperSwikiServer>>parseQueryResult: (in category 'testing') ----- - parseQueryResult: resultStream - - | projectInfos projectName downloadUrl | - projectInfos := OrderedCollection new. - downloadUrl := self downloadUrl. - resultStream reset; nextLine. - [resultStream atEnd] whileFalse: [ - projectName := resultStream nextLine. - projectInfos add: projectName. - "Transcript show: projectName; cr." - ]. - "Transcript show: 'done'; cr." - ^projectInfos - ! Item was removed: - ----- Method: SuperSwikiServer>>putFile:named: (in category 'for real') ----- - putFile: fileStream named: fileNameOnServer - - - ^( - self sendToSwikiProjectServer: { - 'uploadproject: ',fileNameOnServer convertToEncoding: self encodingName. - 'password: ',ProjectPasswordNotification signal. - fileStream contentsOfEntireFile. - } - ) beginsWith: 'OK' - ! Item was removed: - ----- Method: SuperSwikiServer>>queryAllProjects (in category 'testing') ----- - queryAllProjects - - "answer a collection of DirectoryEntry objects for each file on server" - - "SuperSwikiServer testOnlySuperSwiki queryAllProjects" - - ^self sendToSwikiProjectServer: { - 'action: listallprojects'. - }! Item was removed: - ----- Method: SuperSwikiServer>>queryProjects: (in category 'testing') ----- - queryProjects: criteria - | result | - "SuperSwikiServer defaultSuperSwiki queryProjects: #('submittedBy: mir' )" - result := self sendToSwikiProjectServer: { - 'action: findproject'. - } , criteria. - (result beginsWith: 'OK') ifFalse: [^self inform: result printString]. - ^self parseQueryResult: (ReadStream on: result). - ! Item was removed: - ----- Method: SuperSwikiServer>>queryProjectsAndShow (in category 'testing') ----- - queryProjectsAndShow - | result | - "SuperSwikiServer testOnlySuperSwiki queryProjectsAndShow" - - result := self sendToSwikiProjectServer: { - 'action: findproject'. - "'projectname: *proj*'." - }. - (result beginsWith: 'OK') ifFalse: [^self inform: result printString]. - self showQueryAsPVM: (ReadStream on: result). - ! Item was removed: - ----- Method: SuperSwikiServer>>queryProjectsAndShow: (in category 'testing') ----- - queryProjectsAndShow: thingsToSearchFor - | result | - "SuperSwikiServer testOnlySuperSwiki queryProjectsAndShow" - - result := self sendToSwikiProjectServer: { - 'action: findproject'. - }, thingsToSearchFor. - (result beginsWith: 'OK') ifFalse: [^self inform: result printString]. - self showQueryAsPVM: (ReadStream on: result). - ! Item was removed: - ----- Method: SuperSwikiServer>>queryPythagoras (in category 'testing') ----- - queryPythagoras - "SuperSwikiServer testOnlySuperSwiki queryPythagoras" - - ^self sendToSwikiProjectServer: { - 'action: findproject'. - 'projectsubcategory: *geometry*'. - "'projectname: *pythagoras*'." - }! Item was removed: - ----- Method: SuperSwikiServer>>readOnlyFileNamed: (in category 'for real') ----- - readOnlyFileNamed: aName - - ^self oldFileNamed: aName - ! Item was removed: - ----- Method: SuperSwikiServer>>sendToSwikiProjectServer: (in category 'for real') ----- - sendToSwikiProjectServer: anArray - - | argsDict answer buildStream | - - buildStream := WriteStream on: String new. - anArray do: [ :each | - buildStream - nextPutAll: each size printString; - space; - nextPutAll: each - ]. - (argsDict := Dictionary new) - at: 'swikicommands' - put: {buildStream contents}. - answer := HTTPSocket - httpPostToSuperSwiki: self url - args: argsDict - accept: 'application/octet-stream' - request: ''. - ^(answer isKindOf: MIMEDocument) ifTrue: [answer content] ifFalse: [answer] - ! Item was removed: - ----- Method: SuperSwikiServer>>showQueryAsPVM: (in category 'testing') ----- - showQueryAsPVM: resultStream - | answer gif whatToShow projectName fileName firstURL wrapper currX currY maxX maxY rawProjectName | - "SuperSwikiServer testOnlySuperSwiki queryProjectsAndShow" - - resultStream reset; nextLine. - answer := RectangleMorph new - useRoundedCorners; - borderWidth: 0; - borderColor: Color blue; - color: Color paleBlue. - currX := currY := maxX := maxY := 10. - [resultStream atEnd] whileFalse: [ - rawProjectName := resultStream nextLine. - projectName := rawProjectName convertFromEncoding: self encodingName. - fileName := resultStream nextLine convertFromEncoding: self encodingName. - gif := self oldFileOrNoneNamed: rawProjectName,'.gif'. - gif ifNotNil: [gif := GIFReadWriter formFromStream: gif]. - currX > 600 ifTrue: [ - currX := 10. - currY := maxY + 10. - ]. - gif ifNil: [ - gif := AlignmentMorph newColumn - hResizing: #shrinkWrap; - vResizing: #shrinkWrap; - borderWidth: 8; - borderColor: Color red; - color: Color lightRed; - addMorph: (StringMorph contents: 'No GIF for ',projectName); - fullBounds; - imageForm - ]. - firstURL := self url. - firstURL last == $/ ifFalse: [firstURL := firstURL, '/']. - - whatToShow := ProjectViewMorph new - image: (gif asFormOfDepth: Display depth); - lastProjectThumbnail: gif; - setProperty: #SafeProjectName toValue: projectName; - project: (DiskProxy - global: #Project - selector: #namedUrl: - args: {firstURL,fileName} - ). - - answer addMorphBack: (whatToShow position: currX @ currY). - currX := currX + whatToShow width + 10. - maxX := maxX max: currX. - maxY := maxY max: currY + whatToShow height. - ]. - maxX = 10 ifTrue: [ - ^self inform: 'No projects found for your criteria' - ]. - answer extent: (maxX @ maxY) + (0 at 10). - wrapper := ScrollPane new extent: (answer width + 10) @ (answer height min: 400). - wrapper color: Color white. - wrapper scroller addMorph: answer. - wrapper - openCenteredInWorld; - useRoundedCorners; - setScrollDeltas.! Item was removed: - ----- Method: SuperSwikiServer>>speedTest1 (in category 'testing') ----- - speedTest1 - - "SuperSwikiServer testOnlySuperSwiki speedTest1" - - | totalTime answer | - - totalTime := [ - answer := (1 to: 10) collect: [ :x | | t | - t := [answer := self sendToSwikiProjectServer: { - 'action: readnamedfile'. - 'projectname: xyz.002.pr'. - }] timeToRun. - {t. answer size} - ]. - ] timeToRun. - ^{totalTime. answer} - ! Item was removed: - ----- 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 | - - 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 removed: - ----- Method: SuperSwikiServer>>test1 (in category 'testing') ----- - test1 - - | localDirectory localFileName local resp | - - localDirectory := FileDirectory default. - localFileName := 'superTest1.07Oct1611.cs'. - local := localDirectory oldFileNamed: localFileName. - resp := self putFile: local named: localFileName retry: false. - local close. - ^resp - ! Item was removed: - ----- Method: SuperSwikiServer>>typeForPrefs (in category 'accessing') ----- - typeForPrefs - - ^'bss'! Item was removed: - ----- Method: SuperSwikiServer>>upLoadProject:members:retry: (in category 'squeaklets') ----- - upLoadProject: projectName members: archiveMembers retry: aBool - - archiveMembers do:[:entry| | answer | - 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 removed: - ----- Method: SuperSwikiServer>>updateProjectInfoFor: (in category 'for real') ----- - updateProjectInfoFor: aProject - - | data details projectLinks linkString uploader | - - data := OrderedCollection new. - data add: 'action: updatepage'. - data add: 'password: ',ProjectPasswordNotification signal. - data add: 'projectimage: ', (aProject name convertToEncoding: self encodingName) , '.gif'. - uploader := Utilities authorNamePerSe. - uploader isEmptyOrNil ifTrue: [uploader := Utilities authorInitialsPerSe]. - uploader isEmptyOrNil ifFalse: [ - data add: ('submittedBy: ',uploader convertToEncoding: self encodingName). - ]. - projectLinks := Set new. - aProject world allMorphsDo: [ :each | - (each isKindOf: ProjectViewMorph) ifTrue: [ - projectLinks add: each safeProjectName. - ]. - ]. - details := aProject world valueOfProperty: #ProjectDetails ifAbsent: [Dictionary new]. - details at: 'projectname' ifAbsentPut: [aProject name]. - projectLinks isEmpty ifTrue: [ - details removeKey: 'projectlinks' ifAbsent: [] - ] ifFalse: [ - linkString := String streamContents: [ :strm | - projectLinks sorted do: [ :each | - strm nextPutAll: each - ] separatedBy: [ - strm nextPut: $. - ]. - ]. - details at: 'projectlinks' put: linkString - ]. - details keysAndValuesDo: [ :k :v | - data add: k , ': ' , (v convertToEncoding: self encodingName). self flag: #yoFlag. - ]. - ^self sendToSwikiProjectServer: data! Item was removed: - RWBinaryOrTextStream subclass: #SwikiPseudoFileStream - instanceVariableNames: 'directoryUrl localName directory' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-RemoteDirectory'! Item was removed: - ----- Method: SwikiPseudoFileStream>>directory (in category 'accessing') ----- - directory - - ^directory url! Item was removed: - ----- Method: SwikiPseudoFileStream>>directory: (in category 'accessing') ----- - directory: x - - directory := x! Item was removed: - ----- Method: SwikiPseudoFileStream>>directoryObject (in category 'accessing') ----- - directoryObject - - ^directory! Item was removed: - ----- Method: SwikiPseudoFileStream>>directoryUrl (in category 'accessing') ----- - directoryUrl - - ^directory url! Item was removed: - ----- Method: SwikiPseudoFileStream>>directoryUrl: (in category 'accessing') ----- - directoryUrl: x - - directoryUrl := x! Item was removed: - ----- Method: SwikiPseudoFileStream>>fileName (in category 'accessing') ----- - fileName - - ^localName! Item was removed: - ----- Method: SwikiPseudoFileStream>>isTypeHTTP (in category 'testing') ----- - isTypeHTTP - - ^true! Item was removed: - ----- Method: SwikiPseudoFileStream>>localName (in category 'accessing') ----- - localName - - ^localName! Item was removed: - ----- Method: SwikiPseudoFileStream>>localName: (in category 'accessing') ----- - localName: x - - localName := x! Item was removed: - ProtocolClient subclass: #TelnetProtocolClient - instanceVariableNames: 'responseCode' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-Protocols'! - - !TelnetProtocolClient commentStamp: 'mir 5/12/2003 18:06' prior: 0! - Abstract super class for protocol clients based on the generic telnet protocol "<response code> <response>" - - Structure: - responseCode the numerical (integer) value of the last response code - ! Item was removed: - ----- Method: TelnetProtocolClient class>>rawResponseCodes (in category 'accessing') ----- - rawResponseCodes - self subclassResponsibility! Item was removed: - ----- Method: TelnetProtocolClient>>determineResponseCode (in category 'private') ----- - determineResponseCode - self lastResponse size >= 3 - ifFalse: [^0]. - ^[SmallInteger readFromString: (self lastResponse copyFrom: 1 to: 3)] - on: Error - do: [:ex | ex return: 0]! Item was removed: - ----- Method: TelnetProtocolClient>>fetchNextResponse (in category 'private protocol') ----- - fetchNextResponse - "The FTP and similar protocols allow multi-line responses. - 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." - - | response result firstLine | - result := '' writeStream. - firstLine := self stream nextLine. - result nextPutAll: firstLine. - (self responseIsContinuation: firstLine) ifTrue: - ["continued over multiple lines. Discard continuation lines." - [response := self stream nextLine. - response ifNil: [^nil]. - self response: response indicatesEndOf: firstLine.] - whileFalse: [result cr; nextPutAll: response]. - result cr; nextPutAll: response]. - self lastResponse: result contents! Item was removed: - ----- Method: TelnetProtocolClient>>lastResponse: (in category 'private') ----- - lastResponse: aString - super lastResponse: aString. - responseCode := self determineResponseCode! Item was removed: - ----- Method: TelnetProtocolClient>>lookForCode: (in category 'private protocol') ----- - lookForCode: code - "We are expecting a certain code next." - - self - lookForCode: code - ifDifferent: [:response | (TelnetProtocolError protocolInstance: self) signal: response] - ! Item was removed: - ----- Method: TelnetProtocolClient>>lookForCode:ifDifferent: (in category 'private protocol') ----- - lookForCode: code ifDifferent: handleBlock - "We are expecting a certain code next." - - self fetchNextResponse. - - self responseCode == code - ifFalse: [handleBlock value: self lastResponse] - ! Item was removed: - ----- Method: TelnetProtocolClient>>response:indicatesEndOf: (in category 'private testing') ----- - response: response indicatesEndOf: aLine - - ^ response size > 3 - and: [(response copyFrom: 1 to: 3) = (aLine copyFrom: 1 to: 3) - and: [(response at: 4) = Character space]]! Item was removed: - ----- Method: TelnetProtocolClient>>responseCode (in category 'accessing') ----- - responseCode - ^responseCode! Item was removed: - ----- Method: TelnetProtocolClient>>responseIsContinuation: (in category 'private testing') ----- - responseIsContinuation: response - ^ response size > 3 and: [(response at: 4) == $-]! Item was removed: - ----- Method: TelnetProtocolClient>>responseIsError (in category 'private testing') ----- - responseIsError - ^self responseCode between: 500 and: 599! Item was removed: - ----- Method: TelnetProtocolClient>>responseIsSuccess (in category 'private testing') ----- - responseIsSuccess - ^self responseCode between: 200 and: 299! Item was removed: - ----- Method: TelnetProtocolClient>>responseIsWarning (in category 'private testing') ----- - responseIsWarning - ^self responseCode between: 400 and: 499! Item was removed: - ----- Method: TelnetProtocolClient>>valueOfResponseLine: (in category 'private') ----- - valueOfResponseLine: aString - - ^ aString allButFirst: 4 ! Item was removed: - ProtocolClientError subclass: #TelnetProtocolError - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-Protocols'! - - !TelnetProtocolError commentStamp: 'mir 5/12/2003 18:07' prior: 0! - Abstract super class for exceptions signalled by clients based on the telnet protocol. - ! Item was removed: - ----- Method: TelnetProtocolError>>code (in category 'accessing') ----- - code - ^self protocolInstance responseCode! Item was removed: - ----- Method: TelnetProtocolError>>isCommandUnrecognized (in category 'private') ----- - isCommandUnrecognized - ^ self code = 500! Item was removed: - ----- Method: Text>>asUrl (in category '*network-url') ----- - asUrl - ^self asString asUrl! Item was removed: - ----- Method: Text>>asUrlRelativeTo: (in category '*network-url') ----- - asUrlRelativeTo: aUrl - ^self asString asUrlRelativeTo: aUrl! Item was removed: - TextAttribute subclass: #TextMessageLink - instanceVariableNames: 'message' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-Url'! - - !TextMessageLink commentStamp: '<historical>' prior: 0! - A link to a hidden mail message. Clicking on it allows the message to be viewed or saved to disk.! Item was removed: - ----- Method: TextMessageLink class>>message: (in category 'instance creation') ----- - message: aMessage - ^super new initialize: aMessage! Item was removed: - ----- Method: TextMessageLink>>actOnClickFor: (in category 'acting') ----- - actOnClickFor: evt - | choice viewMsg | - viewMsg := message containsViewableImage - ifTrue: ['view this image attachment'] - ifFalse: ['view this attachment']. - choice := UIManager default chooseFrom: (Array with: viewMsg - with: 'save this attachment' ). - choice = 1 - ifTrue: ["open a new viewer" - message viewBody]. - choice = 2 - ifTrue: ["save the mesasge" - message save]. - ^ true! Item was removed: - ----- Method: TextMessageLink>>emphasizeScanner: (in category 'appearance') ----- - emphasizeScanner: scanner - scanner textColor: Color brown! Item was removed: - ----- Method: TextMessageLink>>initialize: (in category 'initialization') ----- - initialize: message0 - message := message0! Item was removed: - ----- Method: TextMessageLink>>mayActOnClick (in category 'acting') ----- - mayActOnClick - ^true! Item was removed: - Object subclass: #URI - instanceVariableNames: 'fragment scheme schemeSpecificPart' - classVariableNames: 'ClientClasses' - poolDictionaries: '' - category: 'Network-URI'! - - !URI commentStamp: 'tpr 2/18/2019 18:06' prior: 0! - This class is deprecated. Consider using one of the Url classes instead. - - A Uniform Resource Identifier (URI) is a compact string of characters for identifying an abstract or physical resource. - This implementation is based on http://www.ietf.org/rfc/rfc2396.txt. - - ! Item was removed: - ----- Method: URI class>>absoluteFromString:scheme: (in category 'instance creation') ----- - absoluteFromString: aString scheme: scheme - | remainder | - remainder := aString copyFrom: scheme size+2 to: aString size. - remainder isEmpty - ifTrue: [(IllegalURIException new uriString: aString) signal: 'Invalid absolute URI']. - ^(remainder first = $/ - ifTrue: [HierarchicalURI] - ifFalse: [OpaqueURI]) new absoluteFromString: remainder scheme: scheme! Item was removed: - ----- Method: URI class>>extractSchemeFrom: (in category 'instance creation') ----- - extractSchemeFrom: aString - | colonIndex slashIndex | - colonIndex := aString indexOf: $: . - ^colonIndex > 0 - ifTrue: [ - slashIndex := aString indexOf: $/ . - (slashIndex = 0 - or: [colonIndex < slashIndex]) - ifTrue: [aString copyFrom: 1 to: colonIndex-1] - ifFalse: [nil]] - ifFalse: [nil]! Item was removed: - ----- Method: URI class>>fromString: (in category 'instance creation') ----- - fromString: aString - | parseString scheme | - parseString := aString withBlanksTrimmed. - scheme := self extractSchemeFrom: parseString. - ^scheme - ifNil: [HierarchicalURI new relativeFromString: aString] - ifNotNil: [self absoluteFromString: aString scheme: scheme] - ! Item was removed: - ----- Method: URI class>>initialize (in category 'class initialization') ----- - initialize - "URI initialize" - - ClientClasses := Dictionary new. - ClientClasses - at: 'http' put: #HTTPClient; - at: 'ftp' put: #FTPClient; - at: 'file' put: #FileDirectory - ! Item was removed: - ----- Method: URI>>= (in category 'testing') ----- - = otherURI - ^ self class = otherURI class - and: [self asString = otherURI asString]! Item was removed: - ----- Method: URI>>absoluteFromString:scheme: (in category 'private') ----- - absoluteFromString: remainder scheme: schemeName - scheme := schemeName. - self extractSchemeSpecificPartAndFragment: remainder! Item was removed: - ----- Method: URI>>allButScheme (in category 'printing') ----- - allButScheme - "Answer the entire url except its scheme" - - ^String streamContents:[:s| - s nextPutAll: schemeSpecificPart. - fragment ifNotNil: [ - s nextPut: $# . - s nextPutAll: self fragment] - ].! Item was removed: - ----- Method: URI>>asText (in category 'converting') ----- - asText - ^self asString asText! Item was removed: - ----- Method: URI>>asURI (in category 'converting') ----- - asURI - ^self! Item was removed: - ----- Method: URI>>asUrl (in category 'converting') ----- - asUrl - - ^self asString asUrl! Item was removed: - ----- Method: URI>>clientClass (in category 'private') ----- - clientClass - ^Smalltalk at: (ClientClasses at: self scheme ifAbsent: [ClientClasses at: 'file'])! Item was removed: - ----- Method: URI>>contentStream (in category 'retrieval') ----- - contentStream - ^self clientClass contentStreamForURI: self! Item was removed: - ----- Method: URI>>downloadUrl (in category 'converting') ----- - downloadUrl - self halt! Item was removed: - ----- Method: URI>>extractSchemeSpecificPartAndFragment: (in category 'private') ----- - extractSchemeSpecificPartAndFragment: remainder - | fragmentIndex | - fragmentIndex := remainder indexOf: $# . - fragmentIndex > 0 - ifTrue: [ - schemeSpecificPart := remainder copyFrom: 1 to: fragmentIndex-1. - fragment := remainder copyFrom: fragmentIndex+1 to: remainder size] - ifFalse: [schemeSpecificPart := remainder]! Item was removed: - ----- Method: URI>>fragment (in category 'accessing') ----- - fragment - ^fragment! Item was removed: - ----- Method: URI>>hasRemoteContents (in category 'testing') ----- - hasRemoteContents - self halt! Item was removed: - ----- Method: URI>>hash (in category 'testing') ----- - hash - ^ self asString hash! Item was removed: - ----- Method: URI>>isAbsolute (in category 'testing') ----- - isAbsolute - ^self scheme notNil! Item was removed: - ----- Method: URI>>isOpaque (in category 'testing') ----- - isOpaque - ^false! Item was removed: - ----- Method: URI>>isRelative (in category 'testing') ----- - isRelative - ^self isAbsolute not! Item was removed: - ----- Method: URI>>printOn: (in category 'printing') ----- - printOn: stream - self isAbsolute - ifTrue: [ - stream nextPutAll: self scheme. - stream nextPut: $: ]. - self printSchemeSpecificPartOn: stream. - fragment - ifNotNil: [ - stream nextPut: $# . - stream nextPutAll: self fragment] - ! Item was removed: - ----- Method: URI>>printSchemeSpecificPartOn: (in category 'printing') ----- - printSchemeSpecificPartOn: stream - stream nextPutAll: self schemeSpecificPart! Item was removed: - ----- Method: URI>>resolveRelativeURI: (in category 'accessing') ----- - resolveRelativeURI: relativeURI - self shouldNotImplement! Item was removed: - ----- Method: URI>>retrieveContentStream (in category 'retrieval') ----- - retrieveContentStream - ^self retrieveMIMEDocument contentStream! Item was removed: - ----- Method: URI>>retrieveContents (in category 'retrieval') ----- - retrieveContents - ^self retrieveMIMEDocument contents! Item was removed: - ----- Method: URI>>retrieveMIMEDocument (in category 'retrieval') ----- - retrieveMIMEDocument - ^self clientClass retrieveMIMEDocument: self! Item was removed: - ----- Method: URI>>scheme (in category 'accessing') ----- - scheme - ^scheme! Item was removed: - ----- Method: URI>>schemeSpecificPart (in category 'private') ----- - schemeSpecificPart - ^schemeSpecificPart! Item was removed: - Object subclass: #URIAuthority - instanceVariableNames: 'host port userInfo' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-URI'! Item was removed: - ----- Method: URIAuthority class>>fromString: (in category 'instance creation') ----- - fromString: authorityString - ^self new fromString: authorityString! Item was removed: - ----- Method: URIAuthority>>fromString: (in category 'private') ----- - fromString: authorityString - | userInfoEnd remainder hostEnd | - userInfoEnd := authorityString indexOf: $@. - remainder := userInfoEnd > 0 - ifTrue: [ - userInfo := authorityString copyFrom: 1 to: userInfoEnd-1. - authorityString copyFrom: userInfoEnd+1 to: authorityString size] - ifFalse: [authorityString]. - hostEnd := remainder indexOf: $: . - hostEnd > 0 - ifTrue: [ - host := remainder copyFrom: 1 to: hostEnd-1. - port := (remainder copyFrom: hostEnd+1 to: remainder size) asNumber] - ifFalse: [host := remainder]! Item was removed: - ----- Method: URIAuthority>>host (in category 'accessing') ----- - host - ^host! Item was removed: - ----- Method: URIAuthority>>port (in category 'accessing') ----- - port - ^port! Item was removed: - ----- Method: URIAuthority>>printOn: (in category 'printing') ----- - printOn: stream - userInfo - ifNotNil: [ - stream nextPut: $@ . - stream nextPutAll: userInfo]. - stream nextPutAll: host. - port - ifNotNil: [ - stream nextPut: $: . - port printOn: stream] ! Item was removed: - ----- Method: URIAuthority>>userInfo (in category 'accessing') ----- - userInfo - ^userInfo! Item was removed: - ByteArray variableByteSubclass: #UUID - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-UUID'! - - !UUID commentStamp: '<historical>' prior: 0! - A class to generate UUID - by John M McIntosh johnmci at smalltalkconsulting.com - - See http://www.webdav.org/specs/draft-leach-uuids-guids-01.txt - - If a plugin does not exist then we generate a UUID version 4 type GUUID! Item was removed: - ----- Method: UUID class>>fromString: (in category 'instance creation') ----- - fromString: aString - | object | - aString size ~= 36 ifTrue: [Error signal]. - object := self nilUUID. - object asUUID: aString. - ^object! Item was removed: - ----- Method: UUID class>>new (in category 'instance creation') ----- - new - ^(self new: 16)! Item was removed: - ----- Method: UUID class>>nilUUID (in category 'instance creation') ----- - nilUUID - "Must call basicNew: here because I have a non-trivial initialize method." - - ^self basicNew: 16! Item was removed: - ----- Method: UUID>>< (in category 'comparing') ----- - < aMagnitude - "Answer whether the receiver is less than the argument." - - 1 to: self size do: [ :i | - | x y | - (x := self at: i) = (y := aMagnitude at: i) ifFalse: [ ^x < y ] ]. - ^false.! Item was removed: - ----- Method: UUID>><= (in category 'comparing') ----- - <= aMagnitude - "Answer whether the receiver is less than or equal to the argument." - - ^(self > aMagnitude) not! Item was removed: - ----- Method: UUID>>> (in category 'comparing') ----- - > aMagnitude - "Answer whether the receiver is greater than the argument." - - ^aMagnitude < self! Item was removed: - ----- Method: UUID>>>= (in category 'comparing') ----- - >= aMagnitude - "Answer whether the receiver is greater than or equal to the argument." - - ^(self < aMagnitude) not! Item was removed: - ----- Method: UUID>>asString (in category 'converting') ----- - asString - | result data | - data := String new: 36. - result := WriteStream on: data. - 1 to: 4 do:[:i| self printHexAt: i to: result]. - result nextPut: $-. - 5 to: 6 do:[:i| self printHexAt: i to: result]. - result nextPut: $-. - 7 to: 8 do:[:i| self printHexAt: i to: result]. - result nextPut: $-. - 9 to: 10 do:[:i| self printHexAt: i to: result]. - result nextPut: $-. - 11 to: 16 do:[:i| self printHexAt: i to: result]. - ^data. - ! Item was removed: - ----- Method: UUID>>asUUID: (in category 'converting') ----- - asUUID: aString - | stream token byte | - stream := ReadStream on: (aString copyReplaceAll: '-' with: '') asUppercase. - 1 to: stream size/2 do: [:i | - token := stream next: 2. - byte := Integer readFrom: (ReadStream on: token ) base: 16. - self at: i put: byte]. - ^self - ! Item was removed: - ----- Method: UUID>>createStringStartingAt:for: (in category 'converting') ----- - createStringStartingAt: index for: bytes - - | results candidate data | - data := String new: bytes*2. - results := WriteStream on: data. - index to: index+bytes -1 do: - [:i | - candidate := ((self at: i) printStringBase: 16) last: 2. - candidate first = $r ifTrue: [candidate := String with: $0 with: candidate last]. - results nextPutAll: candidate]. - ^data asLowercase! Item was removed: - ----- Method: UUID>>initialize (in category 'initalize-release') ----- - initialize - self makeUUID.! Item was removed: - ----- Method: UUID>>isNilUUID (in category 'testing') ----- - isNilUUID - 1 to: self size do: [:i | (self at: i) ~= 0 ifTrue: [^false]]. - ^true.! Item was removed: - ----- Method: UUID>>makeUUID (in category 'private - initialize') ----- - makeUUID - - self primMakeUUID ifNil: [ - UUIDGenerator default generateBytes: self forVersion: 4 ]! Item was removed: - ----- Method: UUID>>primMakeUUID (in category 'system primitives') ----- - primMakeUUID - - <primitive: 'primitiveMakeUUID' module: 'UUIDPlugin'> - ^nil! Item was removed: - ----- Method: UUID>>printHexAt:to: (in category 'converting') ----- - printHexAt: index to: aStream - | map v | - map := '0123456789abcdef'. - v := self at: index. - aStream nextPut: (map at: (v bitShift: -4) + 1). - aStream nextPut: (map at: (v bitAnd: 15) + 1). - ! Item was removed: - ----- Method: UUID>>printOn: (in category 'printing') ----- - printOn: aStream - aStream nextPutAll: 'an UUID('. - self asString printOn: aStream. - aStream nextPutAll: ')'! Item was removed: - ----- Method: UUID>>printString (in category 'printing') ----- - printString - ^self asString! Item was removed: - ----- Method: UUID>>variant (in category 'accessing') ----- - variant - - ^(self at: 9) bitShift: -6! Item was removed: - ----- Method: UUID>>version (in category 'accessing') ----- - version - - ^(self at: 7) bitShift: -4! Item was removed: - Object subclass: #UUIDGenerator - instanceVariableNames: '' - classVariableNames: 'Default TheRandom TheSemaphore' - poolDictionaries: '' - category: 'Network-UUID'! - - !UUIDGenerator commentStamp: 'topa 10/19/2015 23:23:19' prior: 0! - I generate a pseudo-random UUID by asking Random for a 128 bit value. - - See https://tools.ietf.org/html/rfc4122.html#section-4.4 for reference.! Item was removed: - ----- Method: UUIDGenerator class>>default (in category 'instance creation') ----- - default - ^ Default ifNil: [Default := self new] - ! Item was removed: - ----- Method: UUIDGenerator class>>initialize (in category 'class initialization') ----- - initialize - TheRandom := Random new. - TheSemaphore := Semaphore forMutualExclusion. - Smalltalk addToStartUpList: self! Item was removed: - ----- Method: UUIDGenerator class>>resetDefault (in category 'class initialization') ----- - resetDefault - Default := nil.! Item was removed: - ----- Method: UUIDGenerator class>>startUp (in category 'class initialization') ----- - startUp - "Reseed the random" - TheSemaphore critical: [TheRandom seed: nil].! Item was removed: - ----- Method: UUIDGenerator>>fillRandomly: (in category 'instance creation') ----- - fillRandomly: aUUID - - TheSemaphore critical: [ - TheRandom nextBytes: 16 "128 bit" into: aUUID startingAt: 1].! Item was removed: - ----- Method: UUIDGenerator>>generateBytes:forVersion: (in category 'instance creation') ----- - generateBytes: aUUID forVersion: aVersion - | versionID fixedValue | - - aVersion = 4 ifFalse: [^ self error: 'Unsupported version']. - - self fillRandomly: aUUID. - versionID := ((aUUID at: 7) bitAnd: 16r0F) bitOr: 16r40. "Version 4" - fixedValue := ((aUUID at: 9) bitAnd: 16r3F) bitOr: 16r80. "Fixed 8..b value" - aUUID - at: 7 put: versionID; - at: 9 put: fixedValue.! Item was removed: - Object subclass: #Url - instanceVariableNames: 'fragment' - classVariableNames: 'SchemeRegistry' - poolDictionaries: '' - category: 'Network-Url'! - - !Url commentStamp: '<historical>' prior: 0! - A Uniform Resource Locator. It specifies the location of a document on the Internet. The base class is abstract; child classes break different types of URLs down in ways appropriate for that type.! Item was removed: - ----- Method: Url class>>absoluteFromFileNameOrUrlString: (in category 'parsing') ----- - absoluteFromFileNameOrUrlString: aString - "Return a URL from and handle Strings without schemes - as local relative FileUrls instead of defaulting to a HttpUrl - as absoluteFromText: does." - - ^(Url schemeNameForString: aString) - ifNil: [aString asUrlRelativeTo: FileDirectory default asUrl] - ifNotNil: [Url absoluteFromText: aString]! Item was removed: - ----- Method: Url class>>absoluteFromText: (in category 'parsing') ----- - absoluteFromText: aString - "Return a URL from a string and handle - a String without a scheme as a HttpUrl." - - "Url absoluteFromText: 'http://chaos.resnet.gatech.edu:8000/docs/java/index.html?A%20query%20#part'" - "Url absoluteFromText: 'msw://chaos.resnet.gatech.edu:9000/testbook?top'" - "Url absoluteFromText: 'telnet:chaos.resnet.gatech.edu'" - "Url absoluteFromText: 'file:/etc/passwd'" - - | remainder index scheme fragment newUrl | - "trim surrounding whitespace" - remainder := aString withBlanksTrimmed. - - "extract the fragment, if any" - index := remainder indexOf: $#. - index > 0 ifTrue: [ - fragment := remainder copyFrom: index + 1 to: remainder size. - remainder := remainder copyFrom: 1 to: index - 1]. - - "choose class based on the scheme name, and let that class do the bulk of the parsing" - scheme := self schemeNameForString: remainder. - newUrl := (self urlClassForScheme: scheme) new privateInitializeFromText: remainder. - newUrl privateFragment: fragment. - ^newUrl! Item was removed: - ----- Method: Url class>>combine:withRelative: (in category 'parsing') ----- - combine: baseURL withRelative: relURL - "Take two URL as string form, combine them and return the corresponding URL in string form" - - ^((self absoluteFromText: baseURL) newFromRelativeText: relURL) asString! Item was removed: - ----- Method: Url class>>initialize (in category 'class initialization') ----- - initialize - - SchemeRegistry := Dictionary new - at: 'browser' put: BrowserUrl; - at: 'file' put: FileUrl; - at: 'ftp' put: FtpUrl; - at: 'http' put: HttpUrl; - at: 'https' put: HttpUrl; - at: 'mailto' put: MailtoUrl; - at: nil put: HttpUrl; - yourself! Item was removed: - ----- Method: Url class>>registerUrlClass:forScheme: (in category 'class initialization') ----- - registerUrlClass: aClass forScheme: aString - SchemeRegistry at: aString put: aClass.! Item was removed: - ----- Method: Url class>>schemeNameForString: (in category 'parsing') ----- - schemeNameForString: aString - "Get the scheme name from a string, or return nil if it's not specified. - Used in internal parsing routines - an outsider may as well use asUrl. - Return scheme in lowercases." - - "Url schemeNameForString: 'http://www.yahoo.com'" - "Url schemeNameForString: '/etc/passwed'" - "Url schemeNameForString: '/etc/testing:1.2.3'" - - | index schemeName | - index := aString indexOf: $: ifAbsent: [^ nil]. - schemeName := aString first: index - 1. - (schemeName allSatisfy: [:each | each isLetter]) ifFalse: [^ nil]. - ^ schemeName asLowercase! Item was removed: - ----- Method: Url class>>urlClassForScheme: (in category 'parsing') ----- - urlClassForScheme: scheme - ^ SchemeRegistry at: scheme ifAbsent: [GenericUrl].! Item was removed: - ----- Method: Url>>= (in category 'comparing') ----- - = anotherUrl - - self == anotherUrl ifTrue: [^ true]. - self class == anotherUrl class ifFalse: [^ false]. - - self schemeName = anotherUrl schemeName ifFalse: [^ false]. - (self hasSameSchemeSpecificPartAs: anotherUrl) ifFalse: [^ false]. - self fragment = anotherUrl fragment ifFalse: [ ^ false ]. - - ^ true! Item was removed: - ----- Method: Url>>activate (in category 'downloading') ----- - activate - "spawn an external handler for this URL" - ! Item was removed: - ----- Method: Url>>asText (in category 'converting') ----- - asText - ^self asString asText! Item was removed: - ----- Method: Url>>asURI (in category 'converting') ----- - asURI - ^self asString asURI! Item was removed: - ----- Method: Url>>asUrl (in category 'converting') ----- - asUrl - ^self! Item was removed: - ----- Method: Url>>asUrlRelativeTo: (in category 'converting') ----- - asUrlRelativeTo: aUrl - ^self! Item was removed: - ----- Method: Url>>authority (in category 'accessing') ----- - authority - ^''! Item was removed: - ----- Method: Url>>downloadUrl (in category 'converting') ----- - downloadUrl - ^self asString! Item was removed: - ----- Method: Url>>fragment (in category 'fragment') ----- - fragment - ^fragment! Item was removed: - ----- Method: Url>>hasContents (in category 'downloading') ----- - hasContents - "whether this URL can download contents to be displayed; if not, it fundamentally requires an outside application to deal with it. For example, mailto: and telnet: urls" - ^false! Item was removed: - ----- Method: Url>>hasRemoteContents (in category 'classification') ----- - hasRemoteContents - "Return true if the receiver describes some remotely accessible content. - Typically, this should only return if we could retrieve the contents - on an arbitrary place in the outside world using a standard browser. - In other words: If you can get to it from the next Internet Cafe, - return true, else return false." - ^false! Item was removed: - ----- Method: Url>>hasSameSchemeSpecificPartAs: (in category 'comparing') ----- - hasSameSchemeSpecificPartAs: anotherUrl - "Should check whether this Url and the other Url are equal in their scheme specific parts. - This is hook is called by Url>>#=, which already checks schemeName and fragments, so no need to check them in your implementation of this method." - - self subclassResponsibility! Item was removed: - ----- Method: Url>>newFromRelativeText: (in category 'parsing') ----- - newFromRelativeText: aString - "return a URL relative to the current one, given by aString. For instance, if self is 'http://host/dir/file', and aString is '/dir2/file2', then the return will be a Url for 'http://host/dir2/file2'" - - "if the scheme is the same, or not specified, then use the same class" - - | newSchemeName remainder fragmentStart newFragment newUrl bare | - - bare := aString withBlanksTrimmed. - newSchemeName := Url schemeNameForString: bare. - (newSchemeName isNil not and: [ newSchemeName ~= self schemeName ]) ifTrue: [ - "different scheme -- start from scratch" - ^Url absoluteFromText: aString ]. - - remainder := bare. - - "remove the fragment, if any" - fragmentStart := remainder indexOf: $#. - fragmentStart > 0 ifTrue: [ - newFragment := remainder copyFrom: fragmentStart+1 to: remainder size. - remainder := remainder copyFrom: 1 to: fragmentStart-1]. - - "remove the scheme name" - newSchemeName ifNotNil: [ - remainder := remainder copyFrom: (newSchemeName size + 2) to: remainder size ]. - - "create and initialize the new url" - newUrl := self class new privateInitializeFromText: remainder relativeTo: self. - - - "set the fragment" - newUrl privateFragment: newFragment. - - - ^newUrl! Item was removed: - ----- Method: Url>>printOn: (in category 'printing') ----- - printOn: aStream - ^self subclassResponsibility! Item was removed: - ----- Method: Url>>privateFragment: (in category 'fragment') ----- - privateFragment: aString - fragment := aString! Item was removed: - ----- Method: Url>>privateInitializeFromText: (in category 'parsing') ----- - privateInitializeFromText: aString - ^self subclassResponsibility! Item was removed: - ----- Method: Url>>privateInitializeFromText:relativeTo: (in category 'parsing') ----- - privateInitializeFromText: aString relativeTo: aUrl - "initialize from the given string, as a relative URL. aString will have had the scheme name removed, if it was present to begin with. If it was, then the scheme name was the same as the receiver's scheme name" - - "by default, just do regular initialization" - ^self privateInitializeFromText: aString! Item was removed: - ----- Method: Url>>retrieveContents (in category 'downloading') ----- - retrieveContents - "return a MIMEObject with the object's contents, or nil if the object could not be retrieved" - ^nil! Item was removed: - ----- Method: Url>>retrieveContentsForBrowser: (in category 'downloading') ----- - retrieveContentsForBrowser: aBrowser - "return a MIMEObject with the object's contents, or nil if the object could not be retrieved. Since aBrowser is specified, this could do browser specific things" - ^self retrieveContents! Item was removed: - ----- Method: Url>>scheme (in category 'classification') ----- - scheme - "return a string with the scheme of this URL. For instance, HTTP" - ^self subclassResponsibility! Item was removed: - ----- Method: Url>>schemeName (in category 'classification') ----- - schemeName - "return a lowercase string with the scheme of this URL. For instance, 'http'" - ^self subclassResponsibility! Item was removed: - ----- Method: Url>>toText (in category 'printing') ----- - toText - self deprecated: 'Use Url>>asText instead'. - ^ self asString.! Item was removed: - ----- Method: Url>>withFragment: (in category 'fragment') ----- - withFragment: newFragment - "return a URL which is the same except that it has a different fragment" - ^self copy privateFragment: newFragment; yourself! Item was removed: - ----- Method: Url>>withoutFragment (in category 'fragment') ----- - withoutFragment - "return a URL which is identical to the receiver except that it has no fragment associated with it" - ^self withFragment: nil! Item was removed: - OrderedCollection subclass: #UrlArgumentList - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Network-Url'! Item was removed: - ----- Method: UrlArgumentList class>>with: (in category 'instance creation') ----- - with: argAssoc - | argList | - argList := self new. - argList add: argAssoc key value: argAssoc value. - ^argList! Item was removed: - ----- Method: UrlArgumentList class>>with:with: (in category 'instance creation') ----- - with: firstArgAssoc with: secondArgAssoc - | argList | - argList := self with: firstArgAssoc. - argList add: secondArgAssoc key value: secondArgAssoc value. - ^argList! Item was removed: - ----- Method: UrlArgumentList class>>with:with:with: (in category 'instance creation') ----- - with: firstArgAssoc with: secondArgAssoc with: thirdArgAssoc - | argList | - argList := self with: firstArgAssoc with: secondArgAssoc. - argList add: thirdArgAssoc key value: thirdArgAssoc value. - ^argList! Item was removed: - ----- Method: UrlArgumentList>>add:value: (in category 'adding') ----- - add: argName value: argValue - | argAssociation | - argAssociation := self argumentNamed: argName. - argAssociation isNil - ifTrue: [self add: (argName -> (OrderedCollection with: argValue))] - ifFalse: [argAssociation value add: argValue]! Item was removed: - ----- Method: UrlArgumentList>>argumentNamed: (in category 'private') ----- - argumentNamed: argName - ^self - detect: [:each | each key = argName] - ifNone: [nil]! Item was removed: - (PackageInfo named: 'Network') postscript: 'MIMEDocument cleanUp. "Reset recognized MIME types."'!
More information about the Squeak-dev mailing list |