SystemOrganization addCategory: #'FTP-Server'! SystemOrganization addCategory: #'FTP-Command'! SystemOrganization addCategory: #'FTP-Context'! SystemOrganization addCategory: #'FTP-Context-Experimental'! SystemOrganization addCategory: #'FTP-Tests'! ProtoObject subclass: #FTPVirtualContext instanceVariableNames: 'context' classVariableNames: '' poolDictionaries: '' category: 'FTP-Context'! !FTPVirtualContext methodsFor: 'initialization' stamp: 'lr 9/1/2005 12:35'! setContext: aContext context := aContext! ! !FTPVirtualContext methodsFor: 'private' stamp: 'lr 9/1/2005 12:37'! doesNotUnderstand: aMessage | result | result := self context perform: aMessage selector withArguments: aMessage arguments. ^ self context == result ifFalse: [ result ] ifTrue: [ self ].! ! FTPVirtualContext subclass: #FTPRenamedContext instanceVariableNames: 'name' classVariableNames: '' poolDictionaries: '' category: 'FTP-Context'! !FTPRenamedContext methodsFor: 'accessing' stamp: 'lr 9/1/2005 12:34'! name ^ name! ! !FTPRenamedContext methodsFor: 'accessing' stamp: 'lr 9/1/2005 12:34'! name: aString name := aString! ! !FTPVirtualContext class methodsFor: 'instance-creation' stamp: 'lr 9/1/2005 12:40'! on: aContext ^ self new setContext: aContext; yourself.! ! !FTPVirtualContext methodsFor: 'accessing' stamp: 'lr 9/1/2005 12:34'! context ^ context! ! Notification subclass: #FTPCurrentSession instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Server'! !FTPCurrentSession class methodsFor: 'as yet unclassified' stamp: 'lr 8/20/2005 15:46'! value ^ self signal.! ! !FTPCurrentSession class methodsFor: 'as yet unclassified' stamp: 'lr 8/20/2005 15:46'! use: aSession during: aBlock ^ aBlock on: self do: [ :err | err resume: aSession ].! ! TestResource subclass: #FTPServerClientResource instanceVariableNames: 'server client' classVariableNames: '' poolDictionaries: '' category: 'FTP-Tests'! !FTPServerClientResource methodsFor: 'running' stamp: 'lr 8/17/2005 16:54'! tearDown self client isConnected ifTrue: [ self client close ]. self server isConnected ifTrue: [ self server stop ].! ! !FTPServerClientResource methodsFor: 'running' stamp: 'lr 8/17/2005 16:57'! setUp server := FTPServer startOn: self port. client := FTPClient openOnHost: self ip port: self port.! ! !FTPServerClientResource methodsFor: 'running' stamp: 'lr 8/17/2005 17:26'! connect ! ! !FTPServerClientResource methodsFor: 'accessing' stamp: 'lr 8/17/2005 16:42'! client ^ client! ! !FTPServerClientResource methodsFor: 'accessing-config' stamp: 'lr 8/17/2005 16:47'! port ^ 31415! ! !FTPServerClientResource methodsFor: 'accessing' stamp: 'lr 8/17/2005 16:42'! server ^ server! ! !FTPServerClientResource methodsFor: 'accessing-config' stamp: 'lr 8/17/2005 16:47'! ip ^ ByteArray with: 127 with: 0 with: 0 with: 1.! ! TestCase subclass: #FTPTestCase instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Tests'! FTPTestCase subclass: #FTPRequestTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Tests'! !FTPRequestTest methodsFor: 'testing' stamp: 'lr 8/18/2005 10:27'! testCommand self assert: (FTPRequest readFrom: 'foo') command = 'foo'. self assert: (FTPRequest readFrom: 'Foo') command = 'foo'. self assert: (FTPRequest readFrom: 'FOO') command = 'foo'.! ! !FTPRequestTest methodsFor: 'testing' stamp: 'lr 8/18/2005 10:22'! testParseLinefeed self assert: (FTPRequest readFrom: 'a b') command = 'a'. self assert: (FTPRequest readFrom: 'a b') argument = 'b'. self assert: (FTPRequest readFrom: 'a b' , String lf) command = 'a'. self assert: (FTPRequest readFrom: 'a b' , String lf) argument = 'b'. self assert: (FTPRequest readFrom: 'a b' , String crlf) command = 'a'. self assert: (FTPRequest readFrom: 'a b' , String crlf) argument = 'b'.! ! !FTPRequestTest methodsFor: 'testing' stamp: 'lr 8/18/2005 10:27'! testNoArgument self assert: (FTPRequest readFrom: 'a') command = 'a'. self assert: (FTPRequest readFrom: 'a') argument = ''.! ! FTPTestCase subclass: #FTPResponseTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Tests'! !FTPResponseTest methodsFor: 'testing' stamp: 'lr 8/19/2005 10:58'! testCode self assert: (FTPResponse code: 201) code = 201. self assert: (FTPResponse code: 202 description: 'FTP') code = 202.! ! !FTPResponseTest methodsFor: 'testing' stamp: 'lr 8/19/2005 11:04'! testStream self assertStreamOutput: [ :s | (FTPResponse code: 201) writeOn: s ] equals: '201 OK' , String crlf. self assertStreamOutput: [ :s | (FTPResponse code: 202 description: 'FTP') writeOn: s ] equals: '202 FTP' , String crlf. self assertStreamOutput: [ :s | (FTPResponse code: 203 lines: #( 'foo' 'bar' 'zrk' )) writeOn: s ] equals: '203-foo' , String crlf , '203-bar' , String crlf , '203 zrk' , String crlf.! ! !FTPResponseTest methodsFor: 'testing' stamp: 'lr 8/19/2005 11:02'! testLines self assert: (FTPResponse code: 201) lines = #( 'OK' ). self assert: (FTPResponse code: 202 description: 'FTP') lines = #( 'FTP' ). self assert: (FTPResponse code: 203 lines: #( 'foo' 'bar' )) lines = #( 'foo' 'bar' ).! ! !FTPTestCase methodsFor: 'comparing' stamp: 'lr 8/18/2005 10:16'! assertStreamOutput: aBlock equals: aString | stream | aBlock value: (stream := String new writeStream). self assert: stream contents = aString.! ! Object subclass: #FTPMessage instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Server'! FTPMessage subclass: #FTPRequest instanceVariableNames: 'command argument' classVariableNames: '' poolDictionaries: '' category: 'FTP-Server'! !FTPRequest methodsFor: 'accessing' stamp: 'lr 8/18/2005 09:49'! command ^ command! ! !FTPRequest methodsFor: 'initialization' stamp: 'lr 8/19/2005 13:34'! setCommand: aString command := aString asUppercase.! ! !FTPRequest methodsFor: 'printing' stamp: 'lr 8/19/2005 13:36'! writeOn: aStream ident: aString aStream nextPutAll: aString; nextPutAll: command. aStream space; nextPutAll: self argument. aStream nextPutAll: String crlf; flush.! ! !FTPRequest class methodsFor: 'instance creation' stamp: 'lr 8/19/2005 13:34'! readFrom: aStream | line | line := aStream upTo: Character lf. (line notEmpty and: [ line last = Character cr ]) ifTrue: [ line := line allButLast ]. ^ self new setCommand: (line copyUpTo: $ ); setArgument: (line copyAfter: $ ); yourself.! ! !FTPRequest methodsFor: 'accessing' stamp: 'lr 8/18/2005 09:49'! argument ^ argument! ! !FTPRequest methodsFor: 'conveniance' stamp: 'lr 8/19/2005 14:33'! normalized ^ self argument withBlanksTrimmed asUppercase.! ! !FTPRequest methodsFor: 'printing' stamp: 'lr 8/19/2005 13:31'! logOn: aStream self writeOn: aStream ident: '>> '.! ! !FTPRequest methodsFor: 'printing' stamp: 'lr 8/18/2005 09:51'! printOn: aStream super printOn: aStream. aStream nextPutAll: ' command: '; print: self command. aStream nextPutAll: ' argument: '; print: self argument.! ! !FTPRequest methodsFor: 'initialization' stamp: 'lr 8/19/2005 14:31'! setArgument: aString argument := aString! ! !FTPMessage methodsFor: 'printing' stamp: 'lr 8/19/2005 13:30'! writeOn: aStream self writeOn: aStream ident: String new.! ! FTPMessage subclass: #FTPResponse instanceVariableNames: 'code lines' classVariableNames: '' poolDictionaries: '' category: 'FTP-Server'! !FTPResponse class methodsFor: 'rejecting' stamp: 'lr 8/19/2005 18:28'! invalidParamter "The server does not like the format of the parameter." ^ self code: 501 line: 'Invalid parameter format'.! ! !FTPResponse class methodsFor: 'instance creation' stamp: 'lr 8/19/2005 14:19'! code: anInteger line: aString ^ self code: anInteger lines: (Array with: aString).! ! !FTPResponse class methodsFor: 'instance creation' stamp: 'lr 8/19/2005 10:56'! code: anInteger lines: aCollection ^ self new setCode: anInteger; setLines: aCollection; yourself.! ! !FTPResponse methodsFor: 'printing' stamp: 'lr 9/1/2005 15:03'! writeOn: aStream ident: aString 1 to: self lines size do: [ :index | aStream nextPutAll: aString; print: self code. aStream nextPut: (self lines size = index ifTrue: [ $ ] ifFalse: [ $- ]). aStream nextPutAll: (self lines at: index). aStream nextPutAll: String crlf ].! ! !FTPResponse class methodsFor: 'rejecting' stamp: 'lr 8/19/2005 18:27'! unsupportedCommand "The server recognized the verb but does not support it." ^ self code: 502 line: 'Unsupported command'.! ! !FTPResponse class methodsFor: 'errors' stamp: 'lr 9/1/2005 11:52'! error: aString "The request violated some internal parsing rule in the server." ^ self code: 500 string: aString.! ! !FTPResponse methodsFor: 'actions' stamp: 'lr 8/19/2005 10:54'! add: aString self lines add: aString.! ! !FTPResponse class methodsFor: 'instance creation' stamp: 'lr 8/19/2005 14:19'! code: anInteger ^ self code: anInteger line: 'OK'. ! ! !FTPResponse class methodsFor: 'errors' stamp: 'lr 8/19/2005 18:29'! notFound ^ self code: 550 line: 'No such file or directory'.! ! !FTPResponse class methodsFor: 'rejecting' stamp: 'lr 8/19/2005 18:28'! invalidCommand "The server does not like the command." ^ self code: 500 line: 'Invalid command'.! ! !FTPResponse class methodsFor: 'instance creation' stamp: 'lr 8/19/2005 19:21'! code: anInteger string: aString ^ self code: anInteger lines: (aString findTokens: Character cr).! ! !FTPResponse methodsFor: 'printing' stamp: 'lr 8/19/2005 13:31'! logOn: aStream self writeOn: aStream ident: '<< '.! ! !FTPResponse class methodsFor: 'accepting' stamp: 'lr 8/19/2005 14:22'! ready ^ self code: 220 line: 'SqueakFTP ready'.! ! !FTPResponse methodsFor: 'printing' stamp: 'lr 8/19/2005 10:54'! printOn: aStream super printOn: aStream. aStream nextPutAll: ' code: '; print: self code. aStream nextPutAll: ' lines: '; print: self lines.! ! !FTPResponse methodsFor: 'initialization' stamp: 'lr 8/19/2005 10:54'! setCode: aNumber code := aNumber! ! !FTPResponse methodsFor: 'accessing' stamp: 'lr 8/19/2005 10:49'! code ^ code! ! !FTPResponse methodsFor: 'initialization' stamp: 'lr 8/19/2005 10:53'! setLines: aCollection lines := aCollection! ! !FTPResponse class methodsFor: 'accepting' stamp: 'lr 8/18/2005 09:21'! okay ^ self code: 200.! ! !FTPResponse class methodsFor: 'rejecting' stamp: 'lr 8/19/2005 14:22'! unsupportedParameter "The server supports the verb but does not support the parameter." ^ self code: 504 line: 'Unsupported parameter'.! ! !FTPResponse methodsFor: 'accessing' stamp: 'lr 8/19/2005 10:49'! lines ^ lines! ! !FTPMessage methodsFor: 'printing' stamp: 'lr 8/19/2005 13:30'! writeOn: aStream ident: aString self subclassResponsibility.! ! !FTPMessage methodsFor: 'printing' stamp: 'lr 8/19/2005 13:29'! logOn: aStream self subclassResponsibility.! ! Object subclass: #FTPCommand instanceVariableNames: 'session request' classVariableNames: 'Commands' poolDictionaries: '' category: 'FTP-Command'! FTPCommand subclass: #FTPRestCommand instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Command'! !FTPRestCommand commentStamp: 'lr 9/1/2005 14:22' prior: 0! The server keeps track of a start position for the client. The start position is a nonnegative integer. At the beginning of the FTP connection, the start position is 0. A REST request sets the start position. REST has a parameter giving a number as ASCII digits. If the server accepts the REST request (required code 350), it has set the start position to that number. If the server rejects the REST request, it has left the start position alone. The server will set the start position to 0 after a successful RETR, but might not set the start position to 0 after an unsuccessful RETR, so the client must be careful to send a new REST request before the next RETR. The server might set the start position to 0 after responding to any request other than REST, so the client must send REST immediately before RETR.! !FTPRestCommand methodsFor: 'processing' stamp: 'lr 9/1/2005 14:25'! execute self request argument isAllDigits ifFalse: [ self return: (FTPResponse invalidParamter) ]. self state position: (self request argument asInteger ifNil: [ 0 ]). self return: (FTPResponse code: 350 string: 'Start position set to ' , self state position asString).! ! !FTPRestCommand class methodsFor: 'accessing' stamp: 'lr 9/1/2005 14:21'! command ^ 'REST'! ! FTPCommand subclass: #FTPStruCommand instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Command'! !FTPStruCommand commentStamp: 'lr 8/19/2005 13:58' prior: 0! STRU is obsolete. The server should accept STRU F (in any combination of lowercase and uppercase) with code 200, and reject all other STRU attempts with code 504.! !FTPStruCommand class methodsFor: 'accessing' stamp: 'lr 8/19/2005 19:51'! command ^ 'STRU'! ! !FTPStruCommand methodsFor: 'processing' stamp: 'lr 9/1/2005 15:07'! execute self return: (self request normalized = 'F' ifFalse: [ FTPResponse unsupportedParameter ] ifTrue: [ FTPResponse okay ]).! ! FTPCommand subclass: #FTPSiteCommand instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Command'! !FTPSiteCommand commentStamp: 'lr 9/1/2005 12:06' prior: 0! The SITE verb allows servers to provide server-defined extensions without any risk of conflict with future IETF extensions. A SITE request has a parameter with server-defined syntax and semantics. Typically the parameter consists of a subverb, a space, and a subparameter. Of course, there is a risk of conflict between server-defined extensions.! !FTPSiteCommand methodsFor: 'processing' stamp: 'lr 9/1/2005 12:04'! execute | command | command := FTPCommand in: self session for: (FTPRequest readFrom: self request argument) ifAbsent: [self return: FTPResponse invalidCommand ]. command execute.! ! !FTPSiteCommand class methodsFor: 'accessing' stamp: 'lr 9/1/2005 12:04'! command ^ 'SITE'! ! !FTPCommand methodsFor: 'conveniance' stamp: 'lr 9/1/2005 14:10'! findContext: aString ^ self findContext: aString type: nil.! ! !FTPCommand methodsFor: 'accessing-readonly' stamp: 'lr 8/19/2005 10:39'! request ^ request! ! !FTPCommand methodsFor: 'accessing-readonly' stamp: 'lr 8/19/2005 14:08'! state ^ self session state.! ! FTPCommand subclass: #FTPListingCommand instanceVariableNames: 'lines sizes' classVariableNames: '' poolDictionaries: '' category: 'FTP-Command'! !FTPListingCommand commentStamp: 'lr 8/19/2005 19:04' prior: 0! A directory is a list of files. It typically includes a name, type, size, and modification time of each file. The difference between LIST and NLST is that NLST returns a compressed form of the directory, showing only the name of each file, while LIST returns the entire directory.! !FTPListingCommand methodsFor: 'private' stamp: 'lr 8/31/2005 21:55'! sizes sizes isNil ifTrue: [ self build ]. ^ sizes.! ! !FTPListingCommand methodsFor: 'accessing' stamp: 'lr 8/31/2005 21:37'! padding self subclassResponsibility.! ! !FTPListingCommand methodsFor: 'private' stamp: 'lr 8/31/2005 21:54'! lines lines isNil ifTrue: [ self build ]. ^ lines.! ! !FTPListingCommand methodsFor: 'querying' stamp: 'lr 8/31/2005 21:41'! referencesOf: aContext ^ aContext references asString.! ! !FTPListingCommand methodsFor: 'querying' stamp: 'lr 8/31/2005 21:42'! userOf: aContext ^ aContext userName.! ! !FTPListingCommand methodsFor: 'querying' stamp: 'lr 8/31/2005 21:45'! timestampOf: aContext | stamp | stamp := aContext timestamp ifNil: [ TimeStamp now ]. ^ String streamContents: [ :stream | stream nextPutAll: (stamp monthName copyFrom: 1 to: 3); space. stream nextPutAll: (stamp daysInMonth asString padded: #left to: 2 with: $ ); space. 86400 * stamp asYear daysInYear + stamp asSeconds < TimeStamp now asSeconds ifTrue: [ stream nextPutAll: (stamp year asString padded: #left to: 4 with: $ ) ] ifFalse: [ stream nextPutAll: (stamp hours asString padded: #left to: 2 with: $0); nextPut: $:. stream nextPutAll: (stamp minutes asString padded: #left to: 2 with: $0) ] ].! ! !FTPListingCommand methodsFor: 'querying' stamp: 'lr 8/31/2005 21:40'! permissionsOf: aContext ^ String streamContents: [ :stream | stream nextPut: (aContext isDirectory ifTrue: [ $d ] ifFalse: [ $- ]). stream nextPut: (aContext isUserReadable ifTrue: [ $r ] ifFalse: [ $- ]). stream nextPut: (aContext isUserWriteable ifTrue: [ $w ] ifFalse: [ $- ]). stream nextPut: (aContext isUserExecutable ifTrue: [ $x ] ifFalse: [ $- ]). stream nextPut: (aContext isGroupReadable ifTrue: [ $r ] ifFalse: [ $- ]). stream nextPut: (aContext isGroupWriteable ifTrue: [ $w ] ifFalse: [ $- ]). stream nextPut: (aContext isGroupExecutable ifTrue: [ $x ] ifFalse: [ $- ]). stream nextPut: (aContext isOtherReadable ifTrue: [ $r ] ifFalse: [ $- ]). stream nextPut: (aContext isOtherWriteable ifTrue: [ $w ] ifFalse: [ $- ]). stream nextPut: (aContext isOtherExecutable ifTrue: [ $x ] ifFalse: [ $- ]) ].! ! !FTPListingCommand methodsFor: 'processing' stamp: 'lr 8/31/2005 22:03'! execute (FTPResponse code: 150) writeOn: self session telnet stream. self session withStreamDo: [ :stream | self lines do: [ :line | (1 to: self selectors size) do: [ :index | stream nextPutAll: ((line at: index) padded: (self padding at: index) to: (self sizes at: index) with: $ ) ] separatedBy: [ stream nextPut: Character space ]. stream crlf ] ]. self return: (FTPResponse code: 226).! ! !FTPListingCommand methodsFor: 'accessing' stamp: 'lr 8/29/2005 18:25'! selectors self subclassResponsibility.! ! FTPListingCommand subclass: #FTPNlstCommand instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Command'! !FTPNlstCommand methodsFor: 'accessing' stamp: 'lr 8/31/2005 21:44'! padding ^ #( none ).! ! !FTPNlstCommand methodsFor: 'accessing' stamp: 'lr 8/31/2005 21:44'! selectors ^ #( nameOf: ).! ! !FTPNlstCommand class methodsFor: 'accessing' stamp: 'lr 8/29/2005 18:29'! command ^ 'NLST'! ! !FTPListingCommand methodsFor: 'private' stamp: 'lr 8/31/2005 22:04'! build lines := self context children collect: [ :child | self selectors collect: [ :selector | self perform: selector with: child ] ]. sizes := (1 to: self padding size) collect: [ :index | self lines inject: 0 into: [ :result :each | result max: (each at: index) size ] ].! ! !FTPListingCommand methodsFor: 'querying' stamp: 'lr 8/31/2005 22:07'! nameOf: aContext ^ aContext name.! ! !FTPListingCommand methodsFor: 'querying' stamp: 'lr 8/31/2005 21:42'! groupOf: aContext ^ aContext groupName.! ! !FTPListingCommand methodsFor: 'querying' stamp: 'lr 8/31/2005 21:41'! sizeOf: aContext ^ aContext size asString.! ! FTPListingCommand subclass: #FTPListCommand instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Command'! !FTPListCommand methodsFor: 'accessing' stamp: 'lr 8/31/2005 22:05'! padding ^ #( none left right right left left none ).! ! !FTPListCommand methodsFor: 'accessing' stamp: 'lr 8/31/2005 21:44'! selectors ^ #( permissionsOf: referencesOf: userOf: groupOf: sizeOf: timestampOf: nameOf: ).! ! !FTPListCommand class methodsFor: 'accessing' stamp: 'lr 8/19/2005 19:51'! command ^ 'LIST' ! ! !FTPCommand methodsFor: 'actions' stamp: 'lr 9/1/2005 15:03'! response: aResponse self session response: aResponse.! ! FTPCommand subclass: #FTPQuitCommand instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Command'! !FTPQuitCommand commentStamp: 'lr 8/19/2005 13:45' prior: 0! This command terminates a USER and if file transfer is not in progress, the server closes the control connection. If file transfer is in progress, the connection will remain open for result response and the server will then close it. If the user-process is transferring files for several USERs but does not wish to close and then reopen connections for each, then the REIN command should be used instead of QUIT. An unexpected close on the control connection will cause the server to take the effective action of an abort (ABOR) and a logout (QUIT).! !FTPQuitCommand class methodsFor: 'accessing' stamp: 'lr 8/19/2005 19:50'! command ^ 'QUIT'! ! !FTPQuitCommand methodsFor: 'processing' stamp: 'lr 8/31/2005 21:22'! execute self session close.! ! !FTPCommand methodsFor: 'accessing-readonly' stamp: 'lr 8/19/2005 10:45'! session ^ session! ! !FTPCommand methodsFor: 'conveniance' stamp: 'lr 9/1/2005 14:10'! findContext: aString type: aSelector | target invalid | target := self context lookup: aString. invalid := target isNil or: [ aSelector == #file and: [ target isFile not ] ] or: [ aSelector == #directory and: [ target isDirectory not ] ]. invalid ifTrue: [ self return: FTPResponse notFound ]. ^ target.! ! !FTPCommand methodsFor: 'initialization' stamp: 'lr 8/19/2005 13:54'! setSession: aSession session := aSession! ! FTPCommand subclass: #FTPAlloCommand instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Command'! !FTPAlloCommand commentStamp: 'lr 9/1/2005 13:48' prior: 0! ALLO is obsolete. The server should accept any ALLO request with code 202.! !FTPAlloCommand methodsFor: 'processing' stamp: 'lr 9/1/2005 13:49'! execute self return: (FTPResponse code: 202).! ! !FTPAlloCommand class methodsFor: 'accessing' stamp: 'lr 9/1/2005 13:48'! command ^ 'ALLO'! ! FTPCommand subclass: #FTPTransferCommand instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Command'! !FTPTransferCommand methodsFor: 'private' stamp: 'lr 9/1/2005 15:42'! cleanup: aContext! ! !FTPTransferCommand methodsFor: 'processing' stamp: 'lr 9/1/2005 16:00'! execute | context | context := self lookup. self response: (FTPResponse code: 150). self session withStreamDo: [ :stream | [ self process: context on: stream ] ensure: [ self cleanup: context ] ]. self return: (FTPResponse code: 226).! ! FTPTransferCommand subclass: #FTPRetrCommand instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Command'! !FTPRetrCommand commentStamp: 'lr 8/23/2005 22:00' prior: 0! A RETR request asks the server to send the contents of a file over the data connection already established by the client. The RETR parameter is an encoded pathname of the file. The file is either a binary file or a text file, depending on the most recent TYPE request. Normally the server responds with a mark using code 150. It then stops accepting new connections, attempts to send the contents of the file over the data connection, and closes the data connection. Finally it - accepts the RETR request with code 226 if the entire file was successfully written to the server's TCP buffers; - rejects the RETR request with code 425 if no TCP connection was established; - rejects the RETR request with code 426 if the TCP connection was established but then broken by the client or by network failure; or rejects the RETR request with code 451 or 551 if the server had trouble reading the file from disk. The server is obliged to close the data connection in each of these cases. The client is not expected to look for a response from the server until the client sees that the data connection is closed.! !FTPRetrCommand methodsFor: 'private' stamp: 'lr 9/1/2005 15:42'! cleanup: aContext self state position: 0.! ! !FTPRetrCommand methodsFor: 'private' stamp: 'lr 9/1/2005 15:36'! lookup ^ self findContext: self request argument type: #file.! ! !FTPRetrCommand class methodsFor: 'accessing' stamp: 'lr 8/23/2005 22:50'! command ^ 'RETR'! ! !FTPRetrCommand methodsFor: 'private' stamp: 'lr 9/1/2005 15:36'! process: aContext on: aStream aContext get: aStream startingAt: self state position.! ! !FTPTransferCommand methodsFor: 'private' stamp: 'lr 9/1/2005 15:36'! lookup self subclassResponsibility.! ! FTPTransferCommand subclass: #FTPStorCommand instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Command'! !FTPStorCommand commentStamp: 'lr 8/23/2005 23:28' prior: 0! A STOR request asks the server to read the contents of a file from the data connection already established by the client. The STOR parameter is an encoded pathname of the file. The file is either a binary file or a text file, depending on the most recent TYPE request. If the server is willing to create a new file under that name, or replace an existing file under that name, it responds with a mark using code 150. It then stops accepting new connections, attempts to read the contents of the file from the data connection, and closes the data connection. Finally it - accepts the STOR request with code 226 if the entire file was successfully received and stored; - rejects the STOR request with code 425 if no TCP connection was established; - rejects the STOR request with code 426 if the TCP connection was established but then broken by the client or by network failure; or - rejects the STOR request with code 451, 452, or 552 if the server had trouble saving the file to disk. The server may reject the STOR request (code 450, 452, or 553) without first responding with a mark. In this case the server does not touch the data connection.! !FTPStorCommand methodsFor: 'private' stamp: 'lr 9/1/2005 15:38'! lookup ^ self findContext: self request argument type: #file.! ! !FTPStorCommand methodsFor: 'private' stamp: 'lr 9/1/2005 15:43'! cleanup: aContext aContext hasParent ifTrue: [ aContext parent flush ].! ! !FTPStorCommand class methodsFor: 'accessing' stamp: 'lr 8/23/2005 22:50'! command ^ 'STOR'! ! FTPStorCommand subclass: #FTPAppeCommand instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Command'! !FTPAppeCommand class methodsFor: 'accessing' stamp: 'lr 9/1/2005 15:40'! command ^ 'APPE'! ! !FTPAppeCommand methodsFor: 'private' stamp: 'lr 9/1/2005 15:40'! process: aContext on: aStream aContext put: aStream startingAt: aContext size.! ! !FTPStorCommand methodsFor: 'private' stamp: 'lr 9/1/2005 15:39'! process: aContext on: aStream aContext put: aStream.! ! !FTPTransferCommand methodsFor: 'private' stamp: 'lr 9/1/2005 15:34'! process: aContext on: aStream self subclassResponsibility.! ! !FTPCommand methodsFor: 'initialization' stamp: 'lr 8/19/2005 13:54'! setRequest: aRequest request := aRequest! ! FTPCommand subclass: #FTPPortCommand instanceVariableNames: 'numbers' classVariableNames: '' poolDictionaries: '' category: 'FTP-Command'! !FTPPortCommand class methodsFor: 'accessing' stamp: 'lr 8/19/2005 19:51'! command ^ 'PORT'! ! !FTPPortCommand methodsFor: 'private' stamp: 'lr 8/19/2005 19:12'! parseArgument numbers := self request argument findTokens: $,. (numbers size = 6 and: [ numbers allSatisfy: [ :each | each isAllDigits ] ]) ifFalse: [ self return: FTPResponse unsupportedParameter ]. numbers := numbers collect: [ :each | each asInteger ]. (numbers allSatisfy: [ :each | each between: 0 and: 256 ]) ifFalse: [ self return: FTPResponse invalidParamter ].! ! !FTPPortCommand methodsFor: 'processing' stamp: 'lr 8/19/2005 19:13'! execute self parseArgument. self state passive: false; ip: (ByteArray with: numbers first with: numbers second with: numbers third with: numbers fourth); port: numbers fifth * 256 + numbers sixth. self return: FTPResponse okay.! ! FTPCommand subclass: #FTPTypeCommand instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Command'! !FTPTypeCommand commentStamp: 'lr 8/19/2005 14:13' prior: 0! The server keeps track of a binary flag for the client. At any moment, the binary flag is either on or off. At the beginning of the FTP connection, the binary flag is off. A - Turn the binary flag off. A N - Turn the binary flag off. I - Turn the binary flag on. L 8 - Turn the binary flag on.! !FTPTypeCommand methodsFor: 'accessing' stamp: 'lr 8/19/2005 14:17'! binaryArguments ^ #( 'I' 'L 8' )! ! !FTPTypeCommand methodsFor: 'processing' stamp: 'lr 8/19/2005 14:34'! execute (self binaryArguments includes: self request normalized) ifTrue: [ self binary ]. (self asciiArguments includes: self request normalized) ifTrue: [ self ascii ]. self return: FTPResponse invalidParamter.! ! !FTPTypeCommand methodsFor: 'processing' stamp: 'lr 8/19/2005 14:19'! binary self state binary: true. self return: (FTPResponse code: 200 line: 'set to binary').! ! !FTPTypeCommand methodsFor: 'accessing' stamp: 'lr 8/19/2005 14:17'! asciiArguments ^ #( 'A' 'A N' )! ! !FTPTypeCommand class methodsFor: 'accessing' stamp: 'lr 8/19/2005 19:51'! command ^ 'TYPE'! ! !FTPTypeCommand methodsFor: 'processing' stamp: 'lr 8/19/2005 14:20'! ascii self state binary: false. self return: (FTPResponse code: 200 line: 'set to ascii').! ! FTPCommand subclass: #FTPSizeCommand instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Command'! !FTPSizeCommand methodsFor: 'processing' stamp: 'lr 9/1/2005 15:21'! execute | context | context := self findContext: self request argument. self return: (FTPResponse code: 213 line: context size asString).! ! !FTPSizeCommand class methodsFor: 'accessing' stamp: 'lr 9/1/2005 15:14'! command ^ 'SIZE'! ! FTPCommand subclass: #FTPModeCommand instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Command'! !FTPModeCommand commentStamp: 'lr 8/19/2005 13:57' prior: 0! MODE is obsolete. The server should accept MODE S (in any combination of lowercase and uppercase) with code 200, and reject all other MODE attempts with code 504.! !FTPModeCommand methodsFor: 'processing' stamp: 'lr 9/1/2005 15:08'! execute self response: (self request normalized = 'S' ifFalse: [ FTPResponse unsupportedParameter ] ifTrue: [ FTPResponse okay ]).! ! FTPCommand subclass: #FTPSessionCommand instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Command'! FTPSessionCommand subclass: #FTPPassCommand instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Command'! !FTPPassCommand commentStamp: '' prior: 0! A PASS request has a parameter called a password. The client must not send a PASS request except immediately after a USER request. The server may accept PASS with code 230, meaning that permission to access files under this username has been granted; or with code 202, meaning that permission was already granted in response to USER; or with code 332, meaning that permission might be granted after an ACCT request. The server may reject PASS with code 503 if the previous request was not USER or with code 530 if this username and password are jointly unacceptable.! !FTPPassCommand class methodsFor: 'accessing' stamp: 'lr 8/19/2005 19:50'! command ^ 'PASS'! ! !FTPPassCommand methodsFor: 'processing' stamp: 'lr 8/31/2005 22:22'! execute self state password: self request argument. self return: (FTPResponse code: 230).! ! !FTPSessionCommand methodsFor: 'actions' stamp: 'lr 8/31/2005 22:23'! return: aResponse self context updateAuthentication: self request. super return: aResponse.! ! FTPSessionCommand subclass: #FTPAcctCommand instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Command'! !FTPAcctCommand commentStamp: 'lr 8/31/2005 21:20' prior: 0! An ACCT request has a parameter called an account name. The client must not send an ACCT request except immediately after a PASS request. The server may accept ACCT with code 230, meaning that permission to access files under this username has been granted; or with code 202, meaning that permission was already granted in response to USER or PASS. The server may reject ACCT with code 503 if the previous request was not PASS or with code 530 if the username, password, and account name are jointly unacceptable.! !FTPAcctCommand class methodsFor: 'accessing' stamp: 'lr 8/31/2005 21:21'! command ^ 'ACCT'! ! !FTPAcctCommand methodsFor: 'processing' stamp: 'lr 8/31/2005 22:22'! execute self state account: self request argument. self return: (FTPResponse code: 230).! ! FTPSessionCommand subclass: #FTPUserCommand instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Command'! !FTPUserCommand commentStamp: '' prior: 0! A USER request has a parameter showing a username. Subsequent pathnames are interpreted relative to this username. The server may accept USER with code 230, meaning that the client has permission to access files under that username; or with code 331 or 332, meaning that permission might be granted after a PASS request. In theory, the server may reject USER with code 530, meaning that the username is unacceptable. In practice, the server does not check the username until after a PASS request.! !FTPUserCommand methodsFor: 'processing' stamp: 'lr 8/31/2005 22:20'! execute self state username: self request argument. self return: (FTPResponse code: 230).! ! !FTPUserCommand class methodsFor: 'accessing' stamp: 'lr 8/19/2005 19:50'! command ^ 'USER'! ! !FTPCommand methodsFor: 'actions' stamp: 'lr 9/1/2005 15:03'! return: aResponse self session return: aResponse.! ! FTPCommand subclass: #FTPInformationCommand instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Command'! !FTPInformationCommand methodsFor: 'processing' stamp: 'lr 8/31/2005 19:57'! execute self return: (FTPResponse code: self status string: self contents).! ! !FTPInformationCommand methodsFor: 'accessing' stamp: 'lr 8/31/2005 19:58'! contents self subclassResponsibility.! ! FTPInformationCommand subclass: #FTPHelpCommand instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Command'! !FTPHelpCommand commentStamp: 'lr 8/19/2005 19:35' prior: 0! A HELP request asks for human-readable information from the server. The server may accept this request with code 211 or 214, or reject it with code 502.! !FTPHelpCommand methodsFor: 'accessing' stamp: 'lr 8/31/2005 20:11'! contents ^ self context helpString.! ! !FTPHelpCommand class methodsFor: 'accessing' stamp: 'lr 8/19/2005 19:49'! command ^ 'HELP'! ! !FTPHelpCommand methodsFor: 'accessing' stamp: 'lr 8/31/2005 19:56'! status ^ 214! ! !FTPInformationCommand methodsFor: 'accessing' stamp: 'lr 8/31/2005 19:56'! status self subclassResponsibility.! ! FTPInformationCommand subclass: #FTPSystCommand instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Command'! !FTPSystCommand commentStamp: 'lr 8/19/2005 19:26' prior: 0! A SYST request asks for information about the server's operating system. The server accepts this request with code 215.! !FTPSystCommand class methodsFor: 'accessing' stamp: 'lr 8/19/2005 19:48'! command ^ 'SYST'! ! !FTPSystCommand methodsFor: 'accessing' stamp: 'lr 8/31/2005 19:58'! status ^ 215! ! !FTPSystCommand methodsFor: 'accessing' stamp: 'lr 8/31/2005 20:15'! contents ^ self context systemString.! ! FTPInformationCommand subclass: #FTPStatCommand instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Command'! !FTPStatCommand commentStamp: 'lr 8/19/2005 19:27' prior: 0! A STAT request asks for human-readable information about the server's status. The server normally accepts this request with code 211.! !FTPStatCommand methodsFor: 'accessing' stamp: 'lr 8/31/2005 19:57'! status ^ 211! ! !FTPStatCommand methodsFor: 'accessing' stamp: 'lr 8/31/2005 20:12'! contents ^ self context statusString.! ! !FTPStatCommand class methodsFor: 'accessing' stamp: 'lr 8/19/2005 19:48'! command ^ 'STAT'! ! !FTPCommand methodsFor: 'accessing' stamp: 'lr 8/19/2005 14:08'! context ^ self session context.! ! FTPCommand subclass: #FTPPasvCommand instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Command'! !FTPPasvCommand commentStamp: '' prior: 0! A PASV request asks the server to accept a data connection on a new TCP port selected by the server. PASV parameters are prohibited. The server normally accepts PASV with code 227. Its response is a single line showing the IP address of the server and the TCP port number where the server is accepting connections. Normally the client will connect to this TCP port, from the same IP address that the client is using for the FTP connection, and then send a RETR request. However, the client may send some other requests first, such as REST. The server must continue to read and respond to requests while it accepts connections. Most operating systems handle this automatically. If the client sends another PASV request, the server normally accepts the new request with a new TCP port. It stops listening for connections on the old port, and drops any connections already made. ! !FTPPasvCommand methodsFor: 'processing' stamp: 'lr 8/20/2005 16:29'! execute self request argument notEmpty ifTrue: [ self return: FTPResponse unsupportedParameter ]. self state passive: true; ip: NetNameResolver localHostAddress; port: 34558. self return: (FTPResponse code: 227 line: (String streamContents: [ :stream | self state ip do: [ :each | stream print: each; nextPut: $, ]. stream print: self state port // 256; nextPut: $,; print: self state port \\ 256 ])).! ! !FTPPasvCommand class methodsFor: 'accessing' stamp: 'lr 8/20/2005 16:24'! command ^ 'PASV'! ! FTPCommand subclass: #FTPFileCommand instanceVariableNames: 'target' classVariableNames: '' poolDictionaries: '' category: 'FTP-Command'! !FTPFileCommand methodsFor: 'accessing' stamp: 'lr 8/23/2005 23:12'! target ^ target! ! !FTPFileCommand methodsFor: 'initialization' stamp: 'lr 8/23/2005 23:11'! setRequest: aRequest super setRequest: aRequest. self setTarget: (self context lookup: aRequest argument).! ! !FTPFileCommand methodsFor: 'initialization' stamp: 'lr 8/23/2005 22:44'! setTarget: aContext target := aContext! ! !FTPFileCommand methodsFor: 'checking' stamp: 'lr 8/23/2005 23:15'! checkTarget: aSelector (self target notNil and: [ self target perform: aSelector ]) ifFalse: [ self return: FTPResponse notFound ].! ! !FTPCommand methodsFor: 'accessing-readonly' stamp: 'lr 8/19/2005 14:44'! server ^ self session server.! ! FTPCommand subclass: #FTPNoopCommand instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Command'! !FTPNoopCommand commentStamp: 'lr 8/19/2005 13:53' prior: 0! This command does not affect any parameters or previously entered commands. It specifies no action other than that the server send an OK reply.! !FTPNoopCommand class methodsFor: 'accessing' stamp: 'lr 8/19/2005 19:48'! command ^ 'NOOP'! ! !FTPNoopCommand methodsFor: 'processing' stamp: 'lr 8/21/2005 14:32'! execute self return: FTPResponse okay.! ! !FTPCommand class methodsFor: 'accessing' stamp: 'lr 8/19/2005 19:50'! command ^ nil! ! !FTPCommand class methodsFor: 'instance-creation' stamp: 'lr 8/19/2005 19:52'! in: aSession for: aRequest ifAbsent: aBlock | class | class := self allSubclasses detect: [ :each | aRequest command = each command ] ifNone: [ ^ aBlock value ]. ^ class new setSession: aSession; setRequest: aRequest; yourself.! ! FTPCommand subclass: #FTPCdupCommand instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Command'! !FTPCdupCommand commentStamp: 'lr 8/19/2005 18:05' prior: 0! A CDUP request asks the server to remove the last slash, and everything following it, from the name prefix. If this produces an empty name prefix, the new name prefix is a single slash. CDUP parameters are prohibited. The server may accept a CDUP request using code 200 or 250. (RFC 959 says that code 200 is required; but it also says that CDUP uses the same codes as CWD.) The server may reject a CDUP request using code 550.! !FTPCdupCommand methodsFor: 'processing' stamp: 'lr 8/19/2005 18:29'! execute self context hasParent ifFalse: [ self return: FTPResponse notFound ]. self context: self context parent. self return: FTPResponse okay.! ! !FTPCdupCommand class methodsFor: 'accessing' stamp: 'lr 8/19/2005 19:52'! command ^ 'CDUP'! ! !FTPCommand methodsFor: 'accessing' stamp: 'lr 8/19/2005 18:52'! context: aContext ^ self session context: aContext.! ! !FTPCommand methodsFor: 'processing' stamp: 'lr 8/19/2005 17:56'! execute self subclassResponsibility.! ! FTPCommand subclass: #FTPPwdCommand instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Command'! !FTPPwdCommand methodsFor: 'processing' stamp: 'lr 8/29/2005 14:48'! execute self return: (FTPResponse code: 257 line: (String streamContents: [ :stream | stream nextPut: $"; nextPutAll: self context pathString; nextPut: $". stream nextPutAll: ' is current directory' ])).! ! !FTPPwdCommand class methodsFor: 'accessing' stamp: 'lr 8/19/2005 19:54'! command ^ 'PWD'! ! FTPCommand subclass: #FTPCwdCommand instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Command'! !FTPCwdCommand commentStamp: 'lr 8/19/2005 18:33' prior: 0! A CWD request has a nonempty parameter giving an encoded pathname. It asks the server to set the name prefix to this pathname, or to another pathname that will have the same effect as this pathname if the filesystem does not change. The server may accept a CWD request using code 200 or 250. The server may reject a CWD request using code 550.! !FTPCwdCommand methodsFor: 'processing' stamp: 'lr 9/1/2005 14:40'! execute self context: (self findContext: self request argument type: #directory). self return: FTPResponse okay.! ! !FTPCwdCommand class methodsFor: 'accessing' stamp: 'lr 8/19/2005 19:51'! command ^ 'CWD'! ! Object subclass: #FTPSession instanceVariableNames: 'server context state telnet data escaper' classVariableNames: '' poolDictionaries: '' category: 'FTP-Server'! !FTPSession methodsFor: 'testing' stamp: 'lr 9/1/2005 11:53'! isTelnetConnected ^ self telnet isConnected.! ! !FTPSession methodsFor: 'initialization' stamp: 'lr 8/18/2005 12:14'! initialize super initialize. state := FTPState new.! ! !FTPSession methodsFor: 'accessing-reading' stamp: 'lr 8/31/2005 21:30'! telnet ^ telnet! ! !FTPSession methodsFor: 'actions' stamp: 'lr 9/1/2005 12:22'! close self server destroySession: self. self isDataConnected ifTrue: [ self data close ]. self telnet close. ! ! !FTPSession methodsFor: 'accessing-reading' stamp: 'lr 8/19/2005 10:19'! server ^ server! ! !FTPSession methodsFor: 'testing' stamp: 'lr 9/1/2005 11:53'! isDataConnected ^ self data notNil and: [ self data isConnected ].! ! !FTPSession methodsFor: 'connection-telnet' stamp: 'lr 9/1/2005 15:04'! return: aResponse escaper value: aResponse. ! ! !FTPSession methodsFor: 'accessing-reading' stamp: 'lr 8/17/2005 15:59'! state ^ state! ! !FTPSession class methodsFor: 'instance creation' stamp: 'lr 8/18/2005 12:12'! on: aSocket context: aContext ^ self new setSocket: aSocket; setContext: aContext; yourself.! ! !FTPSession methodsFor: 'processing' stamp: 'lr 8/20/2005 15:44'! responseForRequest: aRequest ^ self withEscaperDo: [ self withSessionDo: [ self withHandlerDo: [ self performRequest: aRequest ] ] ].! ! !FTPSession methodsFor: 'actions' stamp: 'lr 9/1/2005 12:17'! run self telnet run: [ self handlerLoop ].! ! !FTPSession methodsFor: 'initialization' stamp: 'lr 8/16/2005 14:56'! setContext: aContext context := aContext! ! !FTPSession methodsFor: 'processing' stamp: 'lr 9/1/2005 15:59'! handlerLoop | request response | self response: FTPResponse ready. [ self telnet isConnected ] whileTrue: [ request := FTPRequest readFrom: self telnet stream. request command notEmpty ifTrue: [ response := self responseForRequest: request. response notNil ifTrue: [ self response: response ] ] ].! ! !FTPSession methodsFor: 'processing' stamp: 'lr 8/20/2005 15:47'! withSessionDo: aBlock ^ FTPCurrentSession use: self during: aBlock.! ! !FTPSession methodsFor: 'processing' stamp: 'lr 9/1/2005 15:06'! performRequest: aRequest | command | aRequest command isEmpty ifTrue: [ self return: nil ]. command := FTPCommand in: self for: aRequest ifAbsent: [ self context unknownRequest: aRequest ]. command execute.! ! !FTPSession methodsFor: 'connection-data' stamp: 'lr 9/1/2005 11:40'! withStreamDo: aBlock self isDataConnected ifTrue: [ self data close ]. self setData: (self state passive ifTrue: [ FTPPassiveConnection ] ifFalse: [ FTPActiveConnection ]) tcp. self state passive ifFalse: [ self data socket connectTo: self state ip port: self state port ] ifTrue: [ self data socket listenOn: self state port backlogSize: self server backlog ]. self data run: [ aBlock value: self data stream ].! ! !FTPSession methodsFor: 'accessing' stamp: 'lr 8/15/2005 18:25'! context ^ context! ! !FTPSession methodsFor: 'accessing' stamp: 'lr 8/16/2005 10:19'! context: aContext context := aContext! ! !FTPSession methodsFor: 'initialization' stamp: 'lr 8/19/2005 10:20'! setServer: aServer server := aServer! ! !FTPSession methodsFor: 'initialization' stamp: 'lr 9/1/2005 12:16'! setSocket: aSocket telnet := FTPPassiveConnection on: aSocket.! ! !FTPSession methodsFor: 'accessing-reading' stamp: 'lr 8/19/2005 10:23'! data ^ data! ! !FTPSession methodsFor: 'processing' stamp: 'lr 8/18/2005 09:44'! withEscaperDo: aBlock escaper := [ :value | ^ value ]. ^ aBlock value.! ! !FTPSession methodsFor: 'processing' stamp: 'lr 9/1/2005 15:06'! withHandlerDo: aBlock ^ aBlock on: Error do: [ :error | self return: (FTPResponse error: (self context isNil ifFalse: [ self context walkbackException: error ] ifTrue: [ error description ])) ].! ! !FTPSession methodsFor: 'initialization' stamp: 'lr 8/20/2005 13:50'! setData: aConnection data := aConnection! ! !FTPSession methodsFor: 'connection-telnet' stamp: 'lr 9/1/2005 15:04'! response: aResponse aResponse writeOn: self telnet stream. self telnet stream flush.! ! Object subclass: #FTPConnection instanceVariableNames: 'stream' classVariableNames: '' poolDictionaries: '' category: 'FTP-Server'! !FTPConnection methodsFor: 'accessing' stamp: 'lr 8/16/2005 13:54'! stream ^ stream! ! FTPConnection subclass: #FTPActiveConnection instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Server'! !FTPConnection class methodsFor: 'instance-creation' stamp: 'lr 8/20/2005 14:09'! tcp ^ self on: Socket newTCP.! ! !FTPConnection methodsFor: 'actions' stamp: 'lr 8/20/2005 14:16'! open self subclassResponsibility.! ! !FTPConnection methodsFor: 'actions' stamp: 'lr 8/31/2005 21:27'! close self isConnected ifTrue: [ self stream close ].! ! !FTPConnection methodsFor: 'accessing' stamp: 'lr 8/18/2005 10:33'! socket ^ self stream socket.! ! !FTPConnection class methodsFor: 'instance-creation' stamp: 'lr 8/20/2005 14:08'! on: aSocket ^ self new setSocket: aSocket; yourself.! ! !FTPConnection methodsFor: 'actions' stamp: 'lr 9/1/2005 14:59'! run: aBlock aBlock ensure: [ self close ].! ! FTPConnection subclass: #FTPPassiveConnection instanceVariableNames: 'process' classVariableNames: '' poolDictionaries: '' category: 'FTP-Server'! !FTPPassiveConnection class methodsFor: 'instance creation' stamp: 'lr 8/19/2005 11:18'! on: aSocket do: aBlock ^ (self on: aSocket) do: aBlock; yourself.! ! !FTPPassiveConnection methodsFor: 'actions' stamp: 'lr 8/31/2005 21:29'! close super close. self process isTerminated ifFalse: [ self process terminate ].! ! !FTPPassiveConnection methodsFor: 'actions' stamp: 'lr 9/1/2005 14:59'! run: aBlock process := [ super run: aBlock ] fork.! ! !FTPPassiveConnection methodsFor: 'accessing' stamp: 'lr 8/31/2005 21:25'! process ^ process! ! !FTPConnection methodsFor: 'initialization' stamp: 'lr 8/18/2005 10:30'! setSocket: aSocket stream := SocketStream on: aSocket.! ! !FTPConnection methodsFor: 'testing' stamp: 'lr 8/31/2005 21:24'! isConnected ^ self stream isConnected.! ! Object subclass: #FTPServer instanceVariableNames: 'settings listener process sessions' classVariableNames: 'Servers' poolDictionaries: '' category: 'FTP-Server'! !FTPServer commentStamp: 'ijp 1/14/2005 19:09' prior: 0! An FTP Server.! !FTPServer class methodsFor: 'instance creation' stamp: 'lr 8/17/2005 17:01'! start ^ self new start; yourself.! ! !FTPServer methodsFor: 'testing' stamp: 'lr 8/16/2005 14:44'! isConnected ^ self listener notNil and: [ self listener isValid ] and: [ self listener isWaitingForConnection ].! ! !FTPServer methodsFor: 'actions' stamp: 'lr 8/29/2005 15:34'! start self isRunning ifTrue: [ ^ self ]. self createServer. self process resume. self class addServer: self.! ! !FTPServer methodsFor: 'private-starting' stamp: 'lr 8/24/2005 07:45'! createServer self createSessions. self createProcess. self createListener. ! ! !FTPServer class methodsFor: 'private' stamp: 'lr 11/21/2004 19:56'! removeServer: aServer self servers remove: aServer.! ! !FTPServer class methodsFor: 'private' stamp: 'lr 8/24/2005 07:50'! shutDown self servers do: [ :each | each stop ].! ! !FTPServer methodsFor: 'accessing' stamp: 'lr 8/24/2005 07:44'! sessions ^ sessions! ! !FTPServer class methodsFor: 'private' stamp: 'lr 11/21/2004 21:35'! addServer: aServer self servers add: aServer.! ! !FTPServer methodsFor: 'actions' stamp: 'lr 11/21/2004 19:45'! restart self stop; start.! ! !FTPServer methodsFor: 'private-stopping' stamp: 'lr 11/21/2004 23:16'! destroyListener listener destroy. listener := nil.! ! !FTPServer class methodsFor: 'instance creation' stamp: 'lr 8/17/2005 17:01'! startOn: aNumber ^ self new port: aNumber; start; yourself.! ! !FTPServer methodsFor: 'private-starting' stamp: 'lr 9/1/2005 12:43'! createProcess process := Process forContext: [ [ self serverLoop ] ensure: [ self destroyServer ] ] priority: self settings priority.! ! !FTPServer methodsFor: 'printing' stamp: 'lr 9/1/2005 12:31'! printOn: aStream super printOn: aStream. aStream space; nextPutAll: 'port: '; print: self settings port.! ! !FTPServer methodsFor: 'private-stopping' stamp: 'lr 9/1/2005 11:56'! destroySessions self sessions do: [ :each | each close ]. sessions := nil.! ! !FTPServer methodsFor: 'actions' stamp: 'lr 11/21/2004 20:56'! stop self isRunning ifFalse: [ ^self ]. self process terminate. self class removeServer: self.! ! !FTPServer class methodsFor: 'instance creation' stamp: 'lr 9/1/2005 13:42'! startOn: aNumber context: aContext | server | server := self new. server settings port: aNumber; context: aContext. ^ server start.! ! !FTPServer methodsFor: 'private' stamp: 'lr 8/20/2005 15:52'! serverLoop [ self serverLoopBody ] repeat.! ! !FTPServer methodsFor: 'private-stopping' stamp: 'lr 11/21/2004 20:53'! destroyProcess process := nil.! ! !FTPServer methodsFor: 'private' stamp: 'lr 9/1/2005 12:43'! serverLoopBody | socket | self isConnected ifFalse: [ self destroyListener; createListener ]. socket := listener waitForAcceptFor: self settings timeout ifTimedOut: [ nil ]. socket notNil ifTrue: [ socket isConnected ifTrue: [ self createSession: socket ] ifFalse: [ socket destroy ] ]. ! ! !FTPServer methodsFor: 'accessing' stamp: 'lr 8/24/2005 07:45'! process ^ process! ! !FTPServer methodsFor: 'private-starting' stamp: 'lr 8/24/2005 07:46'! createSessions sessions := Set new.! ! !FTPServer methodsFor: 'testing' stamp: 'lr 8/16/2005 14:44'! isRunning ^ self process notNil.! ! !FTPServer methodsFor: 'private-starting' stamp: 'lr 9/1/2005 13:42'! createListener listener := Socket newTCP. listener listenOn: self settings port backlogSize: self settings backlog.! ! !FTPServer class methodsFor: 'private' stamp: 'lr 8/17/2005 17:04'! servers ^ Servers ifNil: [ Servers := Set new ].! ! !FTPServer methodsFor: 'initialization' stamp: 'lr 9/1/2005 12:28'! initialize super initialize. settings := FTPSettings new.! ! !FTPServer methodsFor: 'private-stopping' stamp: 'lr 8/24/2005 07:47'! destroyServer self destroyProcess. self destroyListener. self destroySessions.! ! !FTPServer methodsFor: 'accessing' stamp: 'lr 9/1/2005 12:28'! settings ^ settings! ! !FTPServer class methodsFor: 'class initialization' stamp: 'lr 8/24/2005 07:48'! initialize Smalltalk addToStartUpList: self. Smalltalk addToShutDownList: self.! ! !FTPServer methodsFor: 'accessing' stamp: 'lr 8/24/2005 07:45'! listener ^ listener! ! !FTPServer methodsFor: 'private-starting' stamp: 'lr 9/1/2005 12:43'! createSession: aSocket self sessions add: (FTPSession new setContext: self settings context copy; setSocket: aSocket; setServer: self; run).! ! !FTPServer class methodsFor: 'private' stamp: 'lr 9/1/2005 18:46'! startUp self servers do: [ :each | each start ].! ! !FTPServer methodsFor: 'private-stopping' stamp: 'lr 8/24/2005 07:48'! destroySession: aSession self sessions remove: aSession.! ! Object subclass: #FTPContext instanceVariableNames: 'parent' classVariableNames: '' poolDictionaries: '' category: 'FTP-Context'! FTPContext subclass: #FTPDispatcher instanceVariableNames: 'children' classVariableNames: '' poolDictionaries: '' category: 'FTP-Context'! !FTPDispatcher methodsFor: 'accessing' stamp: 'lr 8/31/2005 20:46'! children ^ children! ! !FTPDispatcher methodsFor: 'copying' stamp: 'lr 9/1/2005 18:53'! postCopy super postCopy. children := self children collect: [ :each | each copy setParent: self ].! ! !FTPDispatcher methodsFor: 'initialization' stamp: 'lr 8/31/2005 20:46'! initialize super initialize. children := Set new.! ! !FTPDispatcher methodsFor: 'changing' stamp: 'lr 8/31/2005 20:45'! remove: aContext ^ children remove: aContext.! ! !FTPDispatcher methodsFor: 'changing' stamp: 'lr 8/31/2005 22:46'! add: aContext aContext setParent: self. ^ children add: aContext.! ! FTPContext subclass: #FTPOmniBrowser instanceVariableNames: 'filter node children' classVariableNames: '' poolDictionaries: '' category: 'FTP-Context-Experimental'! !FTPOmniBrowser methodsFor: 'accessing' stamp: 'lr 9/1/2005 10:45'! children ^ children ifNil: [ children := (self filter nodesForParent: self node) collect: [ :each | self species parent: self node: each ] ].! ! !FTPOmniBrowser class methodsFor: 'instance-creation' stamp: 'lr 8/31/2005 23:55'! parent: aContext node: aNode metaNode: aMetaNode ^ (self parent: aContext) setNode: aNode; setMetaNode: aMetaNode; yourself.! ! !FTPOmniBrowser methodsFor: 'private' stamp: 'lr 9/1/2005 10:12'! metaNode ^ filter metaNode! ! !FTPOmniBrowser methodsFor: 'accessing' stamp: 'lr 8/31/2005 23:45'! name ^ self node name. ! ! !FTPOmniBrowser class methodsFor: 'instance-creation' stamp: 'lr 8/31/2005 23:54'! parent: aContext node: aNode ^ self parent: aContext node: aNode metaNode: aNode metaNode.! ! !FTPOmniBrowser methodsFor: 'initialization' stamp: 'lr 8/31/2005 23:55'! setMetaNode: aMetaNode filter := aMetaNode filter monitor: self.! ! !FTPOmniBrowser methodsFor: 'private' stamp: 'lr 9/1/2005 10:12'! filter ^ filter! ! !FTPOmniBrowser methodsFor: 'private' stamp: 'lr 8/31/2005 23:44'! node ^ node! ! !FTPOmniBrowser methodsFor: 'initialization' stamp: 'lr 8/31/2005 23:55'! setNode: aNode node := aNode! ! !FTPContext methodsFor: 'accessing' stamp: 'lr 9/1/2005 11:17'! children " Return a collection of children of the receiver, or nil if this is supposed to be a file. " ^ nil! ! FTPContext subclass: #FTPSmalltalkContext instanceVariableNames: 'actualClass' classVariableNames: '' poolDictionaries: '' category: 'FTP-Context'! FTPSmalltalkContext subclass: #FTPMethodContext instanceVariableNames: 'selector stamp' classVariableNames: '' poolDictionaries: '' category: 'FTP-Context'! !FTPMethodContext methodsFor: 'private' stamp: 'lr 8/29/2005 20:58'! stamp stamp isNil ifTrue: [ stamp := VersionsBrowser timeStampFor: self selector class: self actualClass reverseOrdinal: 1 ]. ^ stamp.! ! !FTPMethodContext methodsFor: 'accessing' stamp: 'lr 8/23/2005 22:24'! selector ^ selector! ! !FTPMethodContext methodsFor: 'accessing-contents' stamp: 'lr 8/23/2005 22:29'! contents: aString self actualClass compile: aString.! ! !FTPMethodContext methodsFor: 'accessing' stamp: 'lr 9/1/2005 17:25'! name ^ self selector asString.! ! !FTPMethodContext methodsFor: 'accessing' stamp: 'lr 8/29/2005 20:59'! timestamp ^ [ TimeStamp fromString: (self stamp copyAfter: Character space) ] ifError: [ super timestamp ].! ! !FTPMethodContext methodsFor: 'events' stamp: 'lr 9/1/2005 17:27'! flush super flush. stamp := nil.! ! !FTPMethodContext methodsFor: 'accessing' stamp: 'lr 8/29/2005 21:07'! userName ^ self stamp isEmpty ifFalse: [ self stamp copyUpTo: Character space ] ifTrue: [ super userName ].! ! !FTPMethodContext methodsFor: 'initialization' stamp: 'lr 9/1/2005 17:25'! setSelector: aSelector selector := aSelector! ! !FTPMethodContext methodsFor: 'accessing-contents' stamp: 'lr 8/23/2005 22:28'! contents ^ self actualClass sourceCodeAt: self selector.! ! !FTPMethodContext methodsFor: 'testing-permissions' stamp: 'lr 8/29/2005 21:11'! isUserExecutable ^ self actualClass isMeta.! ! !FTPSmalltalkContext methodsFor: 'accessing' stamp: 'lr 9/1/2005 17:21'! actualClass ^ actualClass ifNil: [ actualClass := ProtoObject ].! ! !FTPSmalltalkContext methodsFor: 'initialization' stamp: 'lr 9/1/2005 17:23'! setActualClass: aClass actualClass := aClass! ! FTPSmalltalkContext subclass: #FTPClassContext instanceVariableNames: 'children' classVariableNames: '' poolDictionaries: '' category: 'FTP-Context'! !FTPClassContext methodsFor: 'events' stamp: 'lr 9/1/2005 17:24'! flush super flush. children := nil.! ! !FTPClassContext methodsFor: 'events' stamp: 'lr 9/1/2005 17:27'! unknownRequest: aRequest aRequest command = 'EVAL' ifTrue: [ self session return: (FTPResponse code: 200 string: (Compiler evaluate: aRequest argument for: self actualClass logged: false) asString) ]. super unknownRequest: aRequest. ! ! !FTPClassContext methodsFor: 'accessing' stamp: 'lr 9/1/2005 17:25'! name ^ self actualClass name asString.! ! !FTPClassContext methodsFor: 'accessing' stamp: 'lr 9/1/2005 17:29'! children ^ children ifNil: [ children := Array streamContents: [ :stream | self actualClass subclasses do: [ :each | stream nextPut: ((FTPClassContext parent: self) setActualClass: each; yourself) ]. self actualClass selectors do: [ :each | stream nextPut: ((FTPMethodContext parent: self) setActualClass: self actualClass; setSelector: each; yourself) ]. self actualClass class selectors do: [ :each | stream nextPut: ((FTPMethodContext parent: self) setActualClass: self actualClass class; setSelector: each; yourself) ] ] ].! ! !FTPContext methodsFor: 'testing' stamp: 'lr 8/31/2005 23:10'! isDirectory ^ self children notNil.! ! !FTPContext methodsFor: 'accessing-strings' stamp: 'lr 9/1/2005 14:47'! statusString " Return the status of the server, defaults to a human readable list of status values. " | state | state := self session state. ^ String streamContents: [ :stream | state account isEmpty ifFalse: [ stream nextPutAll: 'Account: '; nextPutAll: state account; cr ]. state username isEmpty ifFalse: [ stream nextPutAll: 'Username: '; nextPutAll: state username; cr ]. stream nextPutAll: 'Type: '; nextPutAll: (state isBinary ifTrue: [ 'binary' ] ifFalse: [ 'ascii' ]); cr. stream nextPutAll: 'Transfer: '; nextPutAll: (state isPassive ifTrue: [ 'passive' ] ifFalse: [ 'active' ]); cr ].! ! !FTPContext methodsFor: 'accessing' stamp: 'lr 9/1/2005 17:39'! size " Return the size in bytes of the receiver. " ^ self contents size.! ! !FTPContext methodsFor: 'testing-permissions' stamp: 'lr 8/29/2005 21:03'! isUserWriteable ^ self isFile.! ! !FTPContext methodsFor: 'events' stamp: 'lr 9/1/2005 15:04'! unknownRequest: aRequest " This message will be sent for any unknown command, sublcasses might override the default implementation to handle additional user defined commands. " self session return: FTPResponse invalidCommand.! ! !FTPContext methodsFor: 'converting' stamp: 'lr 9/1/2005 12:42'! asRenamed: aString ^ (FTPRenamedContext on: self) name: aString; yourself.! ! !FTPContext methodsFor: 'accessing' stamp: 'lr 8/31/2005 20:40'! parent " Return the parent of the reciever. " ^ parent! ! !FTPContext class methodsFor: 'instance-creation' stamp: 'lr 8/22/2005 08:29'! parent: aContext ^ self new setParent: aContext; yourself.! ! !FTPContext methodsFor: 'convenience' stamp: 'lr 9/1/2005 08:46'! find: aCollection aCollection isEmpty ifTrue: [ ^ self ]. self isFile ifTrue: [ ^ nil ]. ^ (self at: aCollection first ifAbsent: [ ^ nil ]) find: aCollection allButFirst.! ! !FTPContext methodsFor: 'testing-permissions' stamp: 'lr 8/29/2005 18:15'! isOtherExecutable ^ self isGroupExecutable.! ! !FTPContext methodsFor: 'testing-permissions' stamp: 'lr 8/29/2005 18:15'! isOtherWriteable ^ self isGroupWriteable.! ! !FTPContext methodsFor: 'testing-permissions' stamp: 'lr 8/29/2005 18:15'! isOtherReadable ^ self isGroupReadable.! ! !FTPContext methodsFor: 'events' stamp: 'lr 9/1/2005 15:49'! flush " Tells the receiver to flush any cached state, such as children. "! ! !FTPContext methodsFor: 'initialization' stamp: 'lr 8/19/2005 18:09'! setParent: aContext parent := aContext! ! !FTPContext methodsFor: 'accessing' stamp: 'lr 8/31/2005 20:44'! path " Return the context stack from the root up and including the receiver. " ^ self hasParent ifFalse: [ OrderedCollection with: self ] ifTrue: [ self parent path add: self; yourself ].! ! !FTPContext methodsFor: 'accessing-strings' stamp: 'lr 8/31/2005 20:39'! groupName " Return the name of the group owning the receiver. " ^ 'ftp'! ! FTPContext subclass: #FTPFileSystem instanceVariableNames: 'owner entry' classVariableNames: '' poolDictionaries: '' category: 'FTP-Context'! !FTPFileSystem methodsFor: 'accessing' stamp: 'lr 9/1/2005 10:56'! timestamp ^ TimeStamp fromSeconds: self entry third.! ! !FTPFileSystem methodsFor: 'accessing-configuration' stamp: 'lr 9/1/2005 10:51'! fileClass ^ FTPFileSystemFile! ! !FTPFileSystem methodsFor: 'initialization' stamp: 'lr 9/1/2005 11:03'! setOwner: aDirectory owner := aDirectory! ! !FTPFileSystem methodsFor: 'accessing-internal' stamp: 'lr 9/1/2005 11:03'! directory self subclassResponsibility.! ! !FTPFileSystem methodsFor: 'initialization' stamp: 'lr 9/1/2005 10:52'! setDirectory: aDirectory directory := aDirectory! ! !FTPFileSystem methodsFor: 'accessing' stamp: 'lr 9/1/2005 10:56'! size ^ self entry fifth.! ! !FTPFileSystem methodsFor: 'accessing' stamp: 'lr 9/1/2005 10:56'! name ^ self entry first.! ! !FTPFileSystem methodsFor: 'initialization' stamp: 'lr 9/1/2005 10:55'! setEntry: anArray entry := anArray! ! !FTPFileSystem methodsFor: 'accessing-internal' stamp: 'lr 9/1/2005 11:03'! owner ^ owner! ! !FTPFileSystem methodsFor: 'accessing-internal' stamp: 'lr 9/1/2005 10:56'! entry ^ entry! ! !FTPFileSystem methodsFor: 'accessing-configuration' stamp: 'lr 9/1/2005 10:51'! directoryClass ^ FTPFileSystemDirectory! ! FTPFileSystem subclass: #FTPFileSystemFile instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Context'! !FTPFileSystemFile methodsFor: 'accessing' stamp: 'lr 9/1/2005 11:04'! directory ^ self owner.! ! !FTPFileSystemFile methodsFor: 'streaming' stamp: 'lr 9/1/2005 17:09'! put: aReadStream startingAt: anInteger | stream | stream := self directory fileNamed: self name. [ stream position: anInteger; nextPutAll: aReadStream upToEnd ] ensure: [ stream close ].! ! !FTPFileSystemFile methodsFor: 'streaming' stamp: 'lr 9/1/2005 14:53'! get: aWriteStream startingAt: anInteger | stream | stream := self directory readOnlyFileNamed: self name. [ aWriteStream nextPutAll: (stream position: anInteger; upToEnd) ] ensure: [ stream close ].! ! FTPFileSystem subclass: #FTPFileSystemDirectory instanceVariableNames: 'children' classVariableNames: '' poolDictionaries: '' category: 'FTP-Context'! !FTPFileSystemDirectory methodsFor: 'accessing' stamp: 'lr 9/1/2005 11:05'! directory ^ self owner directoryNamed: self name.! ! !FTPFileSystemDirectory methodsFor: 'initialization' stamp: 'lr 9/1/2005 11:10'! setDirectory: aDirectory self setOwner: aDirectory containingDirectory. self setEntry: (self owner entryAt: aDirectory localName).! ! !FTPFileSystemDirectory class methodsFor: 'instance-creation' stamp: 'lr 9/1/2005 11:10'! on: aDirectory ^ self new setDirectory: aDirectory; yourself.! ! !FTPFileSystemDirectory methodsFor: 'accessing' stamp: 'lr 9/1/2005 11:05'! children ^ children ifNil: [ children := self directory entries collect: [ :each | (each fourth ifTrue: [ self directoryClass parent: self ] ifFalse: [ self fileClass parent: self ]) setOwner: self directory; setEntry: each; yourself ] ].! ! !FTPContext methodsFor: 'accessing' stamp: 'lr 8/31/2005 20:44'! root " Return the root context in the receiver's stack. " ^ self hasParent ifFalse: [ self ] ifTrue: [ self parent root ].! ! !FTPContext methodsFor: 'testing' stamp: 'lr 8/19/2005 18:08'! hasParent ^ self parent notNil.! ! !FTPContext methodsFor: 'accessing-contents' stamp: 'lr 9/1/2005 17:39'! contents: aString " Set the content of the receiver, for non-optimized cases override this method, else have a look at #put:startingAt:. "! ! !FTPContext methodsFor: 'convenience' stamp: 'lr 8/31/2005 20:57'! at: aString ifAbsent: aBlock self isDirectory ifFalse: [ self shouldNotImplement ]. ^ self children detect: [ :each | each name = aString ] ifNone: aBlock.! ! !FTPContext methodsFor: 'accessing-strings' stamp: 'lr 8/31/2005 20:33'! systemString " Return the system name of name of the server, defaults to a human readable string. " ^ SmalltalkImage current vmVersion.! ! !FTPContext methodsFor: 'testing-permissions' stamp: 'lr 8/29/2005 21:05'! isUserReadable ^ true.! ! !FTPContext methodsFor: 'streaming' stamp: 'lr 9/1/2005 00:28'! put: aReadStream startingAt: anInteger anInteger == 1 ifTrue: [ self contents: aReadStream upToEnd ] ifFalse: [ self contents: (String streamContents: [ :stream | stream nextPutAll: (self contents readStream next: anInteger). stream nextPutAll: aReadStream upToEnd ]) ].! ! !FTPContext methodsFor: 'events' stamp: 'lr 8/31/2005 21:11'! updateAuthentication: aRequest " This message will be sent whenever a new username or password is given. "! ! !FTPContext methodsFor: 'accessing-contents' stamp: 'lr 9/1/2005 17:38'! contents " Return the contents of the receiver, for non-optimized cases override this method, else have a look at #get:startingAt:. " ^ String new.! ! !FTPContext methodsFor: 'accessing-strings' stamp: 'lr 8/31/2005 20:30'! helpString " Return a help text of the current context, defaults to a human readable list of possible commands. " | commands | commands := Array streamContents: [ :stream | FTPCommand withAllSubclassesDo: [ :each | each command notNil ifTrue: [ stream nextPut: each command ] ] ]. ^ String streamContents: [ :stream | stream nextPutAll: 'The following commands are recognized:'; cr. commands sort withIndexDo: [ :each :index | stream nextPutAll: (each padded: #right to: 8 with: Character space). index \\ 7 == 0 ifTrue: [ stream cr ] ] ].! ! !FTPContext methodsFor: 'accessing-strings' stamp: 'lr 8/31/2005 20:54'! pathString " Return the path of the receiver as a string. " ^ String streamContents: [ :stream | stream nextPut: $/. self path allButFirst do: [ :each | stream nextPutAll: each name ] separatedBy: [ stream nextPut: $/ ] ].! ! !FTPContext methodsFor: 'streaming' stamp: 'lr 9/1/2005 14:20'! get: aWriteStream startingAt: anInteger aWriteStream nextPutAll: (self contents readStream position: anInteger; upToEnd).! ! !FTPContext methodsFor: 'testing' stamp: 'lr 8/31/2005 22:25'! isFile ^ self children isNil.! ! !FTPContext methodsFor: 'testing-permissions' stamp: 'lr 8/29/2005 18:14'! isGroupReadable ^ self isUserReadable.! ! !FTPContext methodsFor: 'testing-permissions' stamp: 'lr 8/29/2005 21:02'! isUserExecutable ^ self isDirectory.! ! !FTPContext methodsFor: 'testing-permissions' stamp: 'lr 8/29/2005 21:03'! isGroupExecutable ^ self isUserExecutable.! ! !FTPContext methodsFor: 'accessing' stamp: 'lr 9/1/2005 11:17'! name " Return the file-name/label of the receiver. " ^ self printString.! ! !FTPContext methodsFor: 'convenience' stamp: 'lr 8/23/2005 23:25'! lookup: aString | stream name next | aString isEmpty ifTrue: [ ^ self ]. aString first = $/ ifTrue: [ ^ self root lookup: aString allButFirst ]. stream := aString readStream. name := stream upTo: $/. next := name = '..' ifTrue: [ self parent ] ifFalse: [ self at: name ifAbsent: nil ]. ^ next notNil ifTrue: [ next lookup: stream upToEnd ].! ! !FTPContext methodsFor: 'events' stamp: 'lr 9/1/2005 15:49'! walkbackException: anException " This message is called whenever an unexpected situation occurs. The default implementation returns a stack trace of the context where anException occured. " | context | ^ String streamContents: [ :stream | stream nextPutAll: anException description; cr. context := anException signalerContext. [ context notNil ] whileTrue: [ stream nextPutAll: context fullPrintString; cr. context := context sender ] ].! ! !FTPContext methodsFor: 'accessing' stamp: 'lr 8/31/2005 21:15'! references " Return the number of references pointing to the receiver. " ^ 1! ! !FTPContext methodsFor: 'accessing-strings' stamp: 'lr 8/31/2005 20:39'! userName " Return the name of the user owning the receiver. " ^ 'ftp'! ! !FTPContext methodsFor: 'accessing' stamp: 'lr 8/31/2005 20:42'! session " Return the current session or nil. " ^ FTPCurrentSession value.! ! !FTPContext methodsFor: 'testing-permissions' stamp: 'lr 8/29/2005 18:14'! isGroupWriteable ^ self isUserWriteable.! ! !FTPContext methodsFor: 'streaming' stamp: 'lr 9/1/2005 11:57'! get: aWriteStream self get: aWriteStream startingAt: 0.! ! !FTPContext methodsFor: 'accessing' stamp: 'lr 8/31/2005 20:41'! timestamp " Return a timestamp of the receiver. " ^ TimeStamp now.! ! !FTPContext methodsFor: 'streaming' stamp: 'lr 9/1/2005 11:57'! put: aReadStream ^ self put: aReadStream startingAt: 0.! ! Object subclass: #FTPProperties instanceVariableNames: 'properties' classVariableNames: '' poolDictionaries: '' category: 'FTP-Server'! FTPProperties subclass: #FTPSettings instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Server'! !FTPSettings methodsFor: 'sockets' stamp: 'lr 9/1/2005 12:29'! backlog: anInteger self propertyAt: #backlog put: anInteger.! ! !FTPSettings methodsFor: 'sockets' stamp: 'lr 9/1/2005 12:30'! priority ^ self propertyAt: #priority ifAbsent: [ Processor userBackgroundPriority ].! ! !FTPSettings methodsFor: 'sockets' stamp: 'lr 9/1/2005 12:29'! backlog ^ self propertyAt: #backlog ifAbsent: [ 10 ].! ! !FTPSettings methodsFor: 'testing' stamp: 'lr 9/1/2005 12:45'! isLogging ^ self logging.! ! !FTPSettings methodsFor: 'server' stamp: 'lr 9/1/2005 12:29'! context: aContext self propertyAt: #context put: aContext.! ! !FTPSettings methodsFor: 'sockets' stamp: 'lr 9/1/2005 12:30'! timeout ^ self propertyAt: #timeout ifAbsent: [ 10 ].! ! !FTPSettings methodsFor: 'server' stamp: 'lr 9/1/2005 12:31'! logging ^ self propertyAt: #logging ifAbsent: [ false ].! ! !FTPSettings methodsFor: 'sockets' stamp: 'lr 9/1/2005 12:30'! port ^ self propertyAt: #port ifAbsent: [ 21 ].! ! !FTPSettings methodsFor: 'sockets' stamp: 'lr 9/1/2005 12:30'! port: aNumber self propertyAt: #port put: aNumber.! ! !FTPSettings methodsFor: 'sockets' stamp: 'lr 9/1/2005 12:30'! timeout: anInteger self propertyAt: #timeout put: anInteger.! ! !FTPSettings methodsFor: 'server' stamp: 'lr 9/1/2005 12:29'! context ^ self propertyAt: #context ifAbsent: [ FTPDispatcher new ].! ! !FTPSettings methodsFor: 'sockets' stamp: 'lr 9/1/2005 12:30'! priority: aNumber self propertyAt: #priority put: aNumber.! ! !FTPSettings methodsFor: 'server' stamp: 'lr 9/1/2005 12:32'! logging: aBoolean self propertyAt: #logging put: aBoolean.! ! !FTPProperties methodsFor: 'copying' stamp: 'lr 9/1/2005 14:17'! postCopy super postCopy. properties := self properties copy.! ! !FTPProperties methodsFor: 'initialization' stamp: 'lr 9/1/2005 12:43'! initialize super initialize. properties := IdentityDictionary new.! ! !FTPProperties methodsFor: 'accessing' stamp: 'lr 9/1/2005 12:09'! propertyAt: aSymbol ^ self properties at: aSymbol.! ! !FTPProperties methodsFor: 'accessing' stamp: 'lr 9/1/2005 12:09'! propertyAt: aSymbol ifAbsent: aBlock ^ self properties at: aSymbol ifAbsent: aBlock.! ! !FTPProperties methodsFor: 'accessing' stamp: 'lr 9/1/2005 12:09'! properties ^ properties! ! !FTPProperties methodsFor: 'accessing' stamp: 'lr 9/1/2005 12:09'! propertyAt: aSymbol put: anObject ^ self properties at: aSymbol put: anObject.! ! FTPProperties subclass: #FTPState instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Server'! !FTPState methodsFor: 'mode' stamp: 'lr 9/1/2005 12:11'! passive: aBoolean self propertyAt: #passive put: aBoolean.! ! !FTPState methodsFor: 'mode' stamp: 'lr 9/1/2005 12:11'! passive ^ self propertyAt: #passive ifAbsent: [ false ].! ! !FTPState methodsFor: 'transfer' stamp: 'lr 9/1/2005 14:19'! position ^ self propertyAt: #position ifAbsent: [ 0 ].! ! !FTPState methodsFor: 'authentication' stamp: 'lr 9/1/2005 12:14'! password: aString self propertyAt: #password put: aString.! ! !FTPState methodsFor: 'authentication' stamp: 'lr 9/1/2005 12:13'! account ^ self propertyAt: #account ifAbsent: [ String new ].! ! !FTPState methodsFor: 'transfer' stamp: 'lr 9/1/2005 14:19'! position: anInteger self propertyAt: #position put: anInteger.! ! !FTPState methodsFor: 'authentication' stamp: 'lr 9/1/2005 12:14'! password ^ self propertyAt: #password ifAbsent: [ String new ].! ! !FTPState methodsFor: 'testing' stamp: 'lr 8/17/2005 18:42'! isBinary ^ self binary.! ! !FTPState methodsFor: 'authentication' stamp: 'lr 9/1/2005 12:14'! username ^ self propertyAt: #username ifAbsent: [ String new ].! ! !FTPState methodsFor: 'address' stamp: 'lr 9/1/2005 12:12'! ip: anArray self propertyAt: #ip put: anArray.! ! !FTPState methodsFor: 'mode' stamp: 'lr 9/1/2005 12:10'! binary ^ self propertyAt: #binary ifAbsent: [ false ].! ! !FTPState methodsFor: 'address' stamp: 'lr 9/1/2005 12:12'! port: anInteger self propertyAt: #port put: anInteger.! ! !FTPState methodsFor: 'authentication' stamp: 'lr 9/1/2005 12:14'! account: aString self propertyAt: #account put: aString.! ! !FTPState methodsFor: 'testing' stamp: 'lr 8/17/2005 18:42'! isPassive ^ self passive.! ! !FTPState methodsFor: 'authentication' stamp: 'lr 9/1/2005 12:14'! username: aString self propertyAt: #username put: aString.! ! !FTPState methodsFor: 'mode' stamp: 'lr 9/1/2005 12:10'! binary: aBoolean self propertyAt: #binary put: aBoolean.! ! !FTPState methodsFor: 'address' stamp: 'lr 9/1/2005 12:12'! port ^ self propertyAt: #port ifAbsent: [ 20 ].! ! !FTPState methodsFor: 'address' stamp: 'lr 9/1/2005 12:12'! ip ^ self propertyAt: #ip ifAbsent: [ #( 127 0 0 1 ) ].! ! FTPServer initialize!