SystemOrganization addCategory: #'FTP-Server'! SystemOrganization addCategory: #'FTP-Verbs'! SystemOrganization addCategory: #'FTP-Authenticator'! SystemOrganization addCategory: #'FTP-Context'! SystemOrganization addCategory: #'FTP-Context-Experimental'! SystemOrganization addCategory: #'FTP-Testing'! !Stream methodsFor: '*ftp' stamp: 'lr 9/15/2005 23:49'! copyFrom: aReadStream self copyFrom: aReadStream bufferSize: 1024.! ! !Stream methodsFor: '*ftp' stamp: 'lr 9/15/2005 22:42'! copyFrom: aReadStream bufferSize: anInteger aReadStream copyInto: self bufferSize: anInteger.! ! !Stream methodsFor: '*ftp' stamp: 'lr 9/15/2005 23:49'! copyInto: aWriteStream self copyInto: aWriteStream bufferSize: 1024.! ! !Stream methodsFor: '*ftp' stamp: 'lr 9/15/2005 22:40'! copyInto: aWriteStream bufferSize: anInteger [ self atEnd ] whileFalse: [ aWriteStream nextPutAll: (self next: anInteger) ]. ! ! SocketStream subclass: #FTPSessionStream instanceVariableNames: 'session' classVariableNames: '' poolDictionaries: '' category: 'FTP-Server'! FTPSessionStream subclass: #FTPActiveConnection instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Server'! FTPSessionStream subclass: #FTPPassiveConnection instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Server'! !FTPSessionStream class methodsFor: 'instance-creation' stamp: 'lr 9/15/2005 21:19'! session: aSession on: aSocket ^ (self on: aSocket) setSession: aSession; yourself.! ! !FTPSessionStream methodsFor: 'actions' stamp: 'lr 9/15/2005 22:20'! run: aBlock aBlock ensure: [ self close ].! ! !FTPSessionStream methodsFor: 'accessing' stamp: 'lr 9/15/2005 21:15'! server ^ self session server.! ! !FTPSessionStream methodsFor: 'accessing' stamp: 'lr 9/15/2005 20:18'! session ^ session! ! !FTPSessionStream methodsFor: 'initialization' stamp: 'lr 9/15/2005 20:19'! setSession: aSession session := aSession! ! !FTPSessionStream methodsFor: 'initialization' stamp: 'lr 9/15/2005 20:20'! setSocket: aSocket socket := aSocket! ! !FTPSessionStream methodsFor: 'accessing' stamp: 'lr 9/15/2005 21:15'! settings ^ self server settings.! ! FTPSessionStream subclass: #FTPTelnetConnection instanceVariableNames: 'process' classVariableNames: '' poolDictionaries: '' category: 'FTP-Server'! !FTPTelnetConnection class methodsFor: 'instance creation' stamp: 'lr 8/19/2005 11:18'! on: aSocket do: aBlock ^ (self on: aSocket) do: aBlock; yourself.! ! !FTPTelnetConnection methodsFor: 'actions' stamp: 'lr 9/5/2005 15:47'! close super close. self isRunning ifTrue: [ self process terminate ].! ! !FTPTelnetConnection methodsFor: 'testing' stamp: 'lr 9/5/2005 09:30'! isRunning ^ self process notNil and: [ self process isTerminated not ].! ! !FTPTelnetConnection methodsFor: 'accessing' stamp: 'lr 8/31/2005 21:25'! process ^ process! ! !FTPTelnetConnection methodsFor: 'actions' stamp: 'lr 9/15/2005 22:18'! run: aBlock process := [ aBlock ensure: [ self session close ] ] forkAt: self settings priority named: (self settings nameFor: 'session').! ! Object subclass: #FTPAuthenticator instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Authenticator'! FTPAuthenticator subclass: #FTPBasicAuthenticator instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Authenticator'! Object subclass: #FTPContext instanceVariableNames: 'parent' classVariableNames: '' poolDictionaries: '' category: 'FTP-Context'! !FTPContext class methodsFor: 'instance-creation' stamp: 'lr 8/22/2005 08:29'! parent: aContext ^ self new setParent: aContext; yourself.! ! !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: 'testing-permissions' stamp: 'lr 9/5/2005 13:05'! canAppend " Return true if data can be appended to the receiver. " ^ self canWrite.! ! !FTPContext methodsFor: 'testing-permissions' stamp: 'lr 9/5/2005 15:06'! canBeDeleted " Return true if the receiver can be deleted. " ^ self hasParent.! ! !FTPContext methodsFor: 'testing-permissions' stamp: 'lr 9/5/2005 13:16'! canBeListed " Return true if the receiver can be browsed. " ^ self isDirectory.! ! !FTPContext methodsFor: 'testing-permissions' stamp: 'lr 9/5/2005 15:07'! canBeRenamed " Return true if the receiver can be renamed. " ^ self hasParent.! ! !FTPContext methodsFor: 'testing-permissions' stamp: 'lr 9/5/2005 14:30'! canCreate " Return true if a file or directory can be created within the receiver. " ^ self isDirectory.! ! !FTPContext methodsFor: 'testing-permissions' stamp: 'lr 9/5/2005 13:04'! canRead " Return true if the receiver can be read. " ^ self isFile.! ! !FTPContext methodsFor: 'testing-permissions' stamp: 'lr 9/5/2005 13:05'! canWrite " Return true if the receiver can be written. " ^ self isFile.! ! !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 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-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 9/15/2005 23:43'! createDirectoryNamed: aString self session return: FTPResponse permissionDenied.! ! !FTPContext methodsFor: 'convenience' stamp: 'lr 9/15/2005 23:43'! createFileNamed: aString self session return: FTPResponse permissionDenied.! ! !FTPContext methodsFor: 'accessing' stamp: 'lr 9/3/2005 15:22'! creation " Return the creation-timestamp of the receiver. " ^ TimeStamp now.! ! !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: 'events' stamp: 'lr 9/1/2005 15:49'! flush " Tells the receiver to flush any cached state, such as children. "! ! !FTPContext methodsFor: 'streaming' stamp: 'lr 9/1/2005 11:57'! get: aWriteStream self get: aWriteStream startingAt: 0.! ! !FTPContext methodsFor: 'streaming' stamp: 'lr 9/1/2005 14:20'! get: aWriteStream startingAt: anInteger aWriteStream nextPutAll: (self contents readStream position: anInteger; upToEnd).! ! !FTPContext methodsFor: 'accessing-strings' stamp: 'lr 9/5/2005 09:43'! goodbyeString " Return a goodbye string to be displayed when the session is quit. " ^ 'Bye'! ! !FTPContext methodsFor: 'accessing-strings' stamp: 'lr 8/31/2005 20:39'! groupName " Return the name of the group owning the receiver. " ^ 'ftp'! ! !FTPContext methodsFor: 'comparing' stamp: 'lr 9/5/2005 12:06'! hash ^ self species hash bitXor: self name hash.! ! !FTPContext methodsFor: 'testing' stamp: 'lr 8/19/2005 18:08'! hasParent ^ self parent notNil.! ! !FTPContext methodsFor: 'accessing-strings' stamp: 'lr 9/5/2005 10:51'! helpString " Return a help text of the current context, defaults to a human readable list of possible commands. " | commands | commands := Array streamContents: [ :stream | FTPVerb withAllSubclassesDo: [ :each | stream nextPutAll: each verbs ] ]. ^ 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 ] ]. stream cr; nextPutAll: 'END' ].! ! !FTPContext methodsFor: 'testing' stamp: 'lr 8/31/2005 23:10'! isDirectory ^ self children notNil.! ! !FTPContext methodsFor: 'testing' stamp: 'lr 9/8/2005 13:54'! isFile ^ self children isNil.! ! !FTPContext methodsFor: 'convenience' stamp: 'lr 9/5/2005 14:33'! lookup: aString | stream name next | (aString isEmpty or: [ aString = '.' ]) 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: 'accessing' stamp: 'lr 9/3/2005 15:22'! modification " Return the modification-timestamp of the receiver. " ^ TimeStamp now.! ! !FTPContext methodsFor: 'accessing' stamp: 'lr 9/1/2005 11:17'! name " Return the file-name/label of the receiver. " ^ self printString.! ! !FTPContext methodsFor: 'accessing-strings' stamp: 'lr 9/5/2005 13:54'! ownerName " Return the name of the user owning the receiver. " ^ 'ftp'! ! !FTPContext methodsFor: 'accessing' stamp: 'lr 8/31/2005 20:40'! parent " Return the parent of the reciever. " ^ parent! ! !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: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 11:57'! put: aReadStream ^ self put: aReadStream startingAt: 0.! ! !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: 'accessing' stamp: 'lr 8/31/2005 21:15'! references " Return the number of references pointing to the receiver. " ^ 1! ! !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: 'accessing' stamp: 'lr 8/31/2005 20:42'! session " Return the current session or nil. " ^ FTPCurrentSession value.! ! !FTPContext methodsFor: 'initialization' stamp: 'lr 8/19/2005 18:09'! setParent: aContext parent := aContext! ! !FTPContext methodsFor: 'accessing' stamp: 'lr 9/7/2005 22:34'! size " Return the size in bytes of the receiver. " ^ 0! ! !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: '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: '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: '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-strings' stamp: 'lr 9/5/2005 09:43'! welcomeString " Return a welcome string to be displayed when a new session is started. " ^ 'SqueakFTP ready'! ! !FTPContext methodsFor: 'comparing' stamp: 'lr 9/5/2005 12:07'! = anObject ^ self species = anObject species and: [ self name = anObject name ].! ! FTPContext subclass: #FTPDispatcher instanceVariableNames: 'children' classVariableNames: '' poolDictionaries: '' category: 'FTP-Context'! !FTPDispatcher methodsFor: 'changing' stamp: 'lr 8/31/2005 22:46'! add: aContext aContext setParent: self. ^ children add: aContext.! ! !FTPDispatcher methodsFor: 'accessing' stamp: 'lr 8/31/2005 20:46'! children ^ children! ! !FTPDispatcher methodsFor: 'initialization' stamp: 'lr 9/6/2005 08:42'! initialize super initialize. children := Set new. name := self asString.! ! !FTPDispatcher methodsFor: 'copying' stamp: 'lr 9/1/2005 18:53'! postCopy super postCopy. children := self children collect: [ :each | each copy setParent: self ].! ! !FTPDispatcher methodsFor: 'changing' stamp: 'lr 8/31/2005 20:45'! remove: aContext ^ children remove: aContext.! ! FTPContext subclass: #FTPFileSystem instanceVariableNames: 'owner entry' classVariableNames: '' poolDictionaries: '' category: 'FTP-Context'! FTPFileSystem subclass: #FTPFileSystemDirectory instanceVariableNames: 'children' classVariableNames: '' poolDictionaries: '' category: 'FTP-Context'! !FTPFileSystemDirectory class methodsFor: 'instance-creation' stamp: 'lr 9/15/2005 19:29'! default ^ self on: FileDirectory default.! ! !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 ] ].! ! !FTPFileSystemDirectory methodsFor: 'conveniance' stamp: 'lr 9/15/2005 23:46'! createFileNamed: aString ^ (self fileClass parent: self) setOwner: self directory; setEntry: { aString. 0. 0. 0. 0. 0 }; yourself.! ! !FTPFileSystemDirectory methodsFor: 'accessing' stamp: 'lr 9/1/2005 11:05'! directory ^ self owner directoryNamed: self name.! ! !FTPFileSystemDirectory methodsFor: 'accessing' stamp: 'lr 9/15/2005 19:27'! entry ^ super entry ifNil: [ entry := self directory ].! ! !FTPFileSystemDirectory methodsFor: 'testing' stamp: 'lr 9/5/2005 15:37'! isDirectory ^ true! ! !FTPFileSystemDirectory methodsFor: 'initialization' stamp: 'lr 9/1/2005 11:10'! setDirectory: aDirectory self setOwner: aDirectory containingDirectory. self setEntry: (self owner entryAt: aDirectory localName).! ! 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/15/2005 22:35'! get: aWriteStream startingAt: anInteger | stream | stream := self directory readOnlyFileNamed: self name. [ stream binary; position: anInteger; copyInto: aWriteStream ] ensure: [ stream close ].! ! !FTPFileSystemFile methodsFor: 'streaming' stamp: 'lr 9/15/2005 23:49'! put: aReadStream startingAt: anInteger | stream | stream := self directory fileNamed: self name. [ stream position: anInteger; copyFrom: aReadStream binary ] ensure: [ stream close ].! ! !FTPFileSystem methodsFor: 'accessing' stamp: 'lr 9/3/2005 15:24'! creation ^ TimeStamp fromSeconds: self entry second.! ! !FTPFileSystem methodsFor: 'accessing-internal' stamp: 'lr 9/1/2005 11:03'! directory self subclassResponsibility.! ! !FTPFileSystem methodsFor: 'accessing-configuration' stamp: 'lr 9/1/2005 10:51'! directoryClass ^ FTPFileSystemDirectory! ! !FTPFileSystem methodsFor: 'accessing-internal' stamp: 'lr 9/1/2005 10:56'! entry ^ entry! ! !FTPFileSystem methodsFor: 'accessing-configuration' stamp: 'lr 9/1/2005 10:51'! fileClass ^ FTPFileSystemFile! ! !FTPFileSystem methodsFor: 'accessing' stamp: 'lr 9/3/2005 15:23'! modification ^ TimeStamp fromSeconds: self entry third.! ! !FTPFileSystem methodsFor: 'accessing' stamp: 'lr 9/1/2005 10:56'! name ^ self entry first.! ! !FTPFileSystem methodsFor: 'accessing-internal' stamp: 'lr 9/1/2005 11:03'! owner ^ owner! ! !FTPFileSystem methodsFor: 'initialization' stamp: 'lr 9/1/2005 10:55'! setEntry: anArray entry := anArray! ! !FTPFileSystem methodsFor: 'initialization' stamp: 'lr 9/1/2005 11:03'! setOwner: aDirectory owner := aDirectory! ! !FTPFileSystem methodsFor: 'accessing' stamp: 'lr 9/1/2005 10:56'! size ^ self entry fifth.! ! FTPContext subclass: #FTPOmniBrowser instanceVariableNames: 'filter node children' classVariableNames: '' poolDictionaries: '' category: 'FTP-Context-Experimental'! !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 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: '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 methodsFor: 'private' stamp: 'lr 9/1/2005 10:12'! filter ^ filter! ! !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 methodsFor: 'private' stamp: 'lr 8/31/2005 23:44'! node ^ node! ! !FTPOmniBrowser methodsFor: 'initialization' stamp: 'lr 8/31/2005 23:55'! setMetaNode: aMetaNode filter := aMetaNode filter monitor: self.! ! !FTPOmniBrowser methodsFor: 'initialization' stamp: 'lr 8/31/2005 23:55'! setNode: aNode node := aNode! ! FTPContext subclass: #FTPSmalltalkContext instanceVariableNames: 'actualClass' classVariableNames: '' poolDictionaries: '' category: 'FTP-Context'! FTPSmalltalkContext subclass: #FTPClassContext instanceVariableNames: 'children' classVariableNames: '' poolDictionaries: '' category: 'FTP-Context'! !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) ] ] ].! ! !FTPClassContext methodsFor: 'events' stamp: 'lr 9/1/2005 17:24'! flush super flush. children := nil.! ! !FTPClassContext methodsFor: 'testing' stamp: 'lr 9/5/2005 15:35'! isDirectory ^ true! ! !FTPClassContext methodsFor: 'accessing' stamp: 'lr 9/1/2005 17:25'! name ^ self actualClass name asString.! ! !FTPClassContext methodsFor: 'events' stamp: 'lr 9/4/2005 17:02'! unknownRequest: aRequest aRequest verb = 'EVAL' ifTrue: [ self session return: (FTPResponse code: 200 string: (Compiler evaluate: aRequest argument for: self actualClass logged: false) asString) ]. super unknownRequest: aRequest.! ! FTPSmalltalkContext subclass: #FTPMethodContext instanceVariableNames: 'selector user modification creation' classVariableNames: '' poolDictionaries: '' category: 'FTP-Context'! !FTPMethodContext methodsFor: 'accessing-contents' stamp: 'lr 8/23/2005 22:28'! contents ^ self actualClass sourceCodeAt: self selector.! ! !FTPMethodContext methodsFor: 'accessing-contents' stamp: 'lr 8/23/2005 22:29'! contents: aString self actualClass compile: aString.! ! !FTPMethodContext methodsFor: 'accessing' stamp: 'lr 9/3/2005 15:48'! creation ^ creation ifNil: [ super creation ].! ! !FTPMethodContext methodsFor: 'events' stamp: 'lr 9/4/2005 17:03'! flush | version | super flush. version := VersionsBrowser new scanVersionsOf: self method class: self actualClass meta: self actualClass isMeta category: nil selector: self selector. version isNil ifTrue: [ ^ self ]. user := version list first copyUpTo: Character space. modification := [ TimeStamp fromString: (version list first copyAfter: Character space) ] ifError: [ nil ]. creation := [ TimeStamp fromString: (version list last copyAfter: Character space) ] ifError: [ nil ].! ! !FTPMethodContext methodsFor: 'testing-permissions' stamp: 'lr 8/29/2005 21:11'! isUserExecutable ^ self actualClass isMeta.! ! !FTPMethodContext methodsFor: 'accessing' stamp: 'lr 9/3/2005 15:33'! method ^ self actualClass compiledMethodAt: self selector ifAbsent: [ nil ].! ! !FTPMethodContext methodsFor: 'accessing' stamp: 'lr 9/3/2005 15:48'! modification ^ modification ifNil: [ super modification ].! ! !FTPMethodContext methodsFor: 'accessing' stamp: 'lr 9/7/2005 07:19'! name ^ self selector collect: [ :each | each = $: ifTrue: [ $_ ] ifFalse: [ each ] ].! ! !FTPMethodContext methodsFor: 'accessing' stamp: 'lr 9/5/2005 13:55'! ownerName ^ user ifNil: [ super ownerName ].! ! !FTPMethodContext methodsFor: 'accessing' stamp: 'lr 8/23/2005 22:24'! selector ^ selector! ! !FTPMethodContext methodsFor: 'initialization' stamp: 'lr 9/3/2005 15:39'! setSelector: aSelector selector := aSelector. self flush.! ! !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! ! FTPContext subclass: #FTPTestContext instanceVariableNames: 'name children contents' classVariableNames: '' poolDictionaries: '' category: 'FTP-Testing'! !FTPTestContext methodsFor: 'accessing' stamp: 'lr 9/6/2005 08:47'! children ^ children! ! !FTPTestContext methodsFor: 'accessing' stamp: 'lr 9/6/2005 08:55'! children: aCollection aCollection do: [ :each | each setParent: self ]. children := aCollection.! ! !FTPTestContext methodsFor: 'accessing' stamp: 'lr 9/6/2005 08:48'! contents ^ contents! ! !FTPTestContext methodsFor: 'accessing' stamp: 'lr 9/6/2005 08:48'! contents: aString contents := aString! ! !FTPTestContext methodsFor: 'accessing' stamp: 'lr 9/6/2005 08:47'! name ^ name! ! !FTPTestContext methodsFor: 'accessing' stamp: 'lr 9/6/2005 08:47'! name: aString name := aString! ! Object subclass: #FTPListener instanceVariableNames: 'process listener' classVariableNames: '' poolDictionaries: '' category: 'FTP-Server'! !FTPListener methodsFor: 'accessing-settings' stamp: 'lr 9/8/2005 21:20'! backlog self subclassResponsibility.! ! !FTPListener methodsFor: 'private' stamp: 'lr 9/8/2005 21:29'! buildListener ^ Socket newTCP listenOn: self port backlogSize: self backlog; yourself.! ! !FTPListener methodsFor: 'listening' stamp: 'lr 9/8/2005 21:11'! createListener Socket initializeNetwork. listener := self buildListener.! ! !FTPListener methodsFor: 'listening' stamp: 'lr 9/8/2005 21:12'! destroyListener self listener isNil ifFalse: [ self listener destroy ].! ! !FTPListener methodsFor: 'actions' stamp: 'lr 9/8/2005 20:46'! handle: aSocket self subclassResponsibility.! ! !FTPListener methodsFor: 'listening' stamp: 'lr 9/8/2005 21:13'! listen [ self createListener; listenLoop ] ensure: [ self destroyListener ].! ! !FTPListener methodsFor: 'listening' stamp: 'lr 9/8/2005 21:13'! listenCycle | socket | self listener isValid ifFalse: [ self destroyListener; createListener ]. socket := self listener waitForAcceptFor: self timeout ifTimedOut: [ nil ]. socket isNil ifTrue: [ ^ self ]. socket isConnected ifTrue: [ self handle: socket ] ifFalse: [ socket destroy ].! ! !FTPListener methodsFor: 'accessing' stamp: 'lr 9/8/2005 20:58'! listener ^ listener! ! !FTPListener methodsFor: 'listening' stamp: 'lr 9/8/2005 21:12'! listenLoop [ self listenCycle ] repeat.! ! !FTPListener methodsFor: 'accessing-settings' stamp: 'lr 9/15/2005 18:47'! name self subclassResponsibility.! ! !FTPListener methodsFor: 'accessing-settings' stamp: 'lr 9/8/2005 21:20'! port self subclassResponsibility.! ! !FTPListener methodsFor: 'printing' stamp: 'lr 9/8/2005 20:49'! printOn: aStream super printOn: aStream. aStream nextPutAll: ' port: '; print: self port.! ! !FTPListener methodsFor: 'accessing-settings' stamp: 'lr 9/8/2005 21:21'! priority self subclassResponsibility.! ! !FTPListener methodsFor: 'accessing' stamp: 'lr 9/8/2005 20:30'! process ^ process! ! !FTPListener methodsFor: 'actions' stamp: 'lr 9/15/2005 18:48'! start process := [ self listen ] forkAt: self priority named: self name.! ! !FTPListener methodsFor: 'actions' stamp: 'lr 9/8/2005 21:19'! stop process terminate.! ! !FTPListener methodsFor: 'accessing-settings' stamp: 'lr 9/8/2005 21:16'! timeout self subclassResponsibility.! ! FTPListener subclass: #FTPPassiveListener instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Server'! FTPListener subclass: #FTPServerListener instanceVariableNames: 'server' classVariableNames: '' poolDictionaries: '' category: 'FTP-Server'! !FTPServerListener class methodsFor: 'instance-creation' stamp: 'lr 9/8/2005 21:23'! server: aServer ^ self new setServer: aServer; yourself.! ! !FTPServerListener methodsFor: 'accessing' stamp: 'lr 9/8/2005 21:21'! backlog ^ server settings backlog.! ! !FTPServerListener methodsFor: 'actions' stamp: 'lr 9/8/2005 21:30'! handle: aSocket server startSession: aSocket.! ! !FTPServerListener methodsFor: 'accessing' stamp: 'lr 9/15/2005 18:49'! name ^ server settings name.! ! !FTPServerListener methodsFor: 'accessing' stamp: 'lr 9/8/2005 21:21'! port ^ server settings port.! ! !FTPServerListener methodsFor: 'accessing' stamp: 'lr 9/8/2005 21:21'! priority ^ server settings priority.! ! !FTPServerListener methodsFor: 'initialization' stamp: 'lr 9/8/2005 21:17'! setServer: aServer server := aServer! ! !FTPServerListener methodsFor: 'accessing' stamp: 'lr 9/8/2005 21:21'! timeout ^ server settings timeout.! ! Object subclass: #FTPMessage instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Server'! !FTPMessage methodsFor: 'printing' stamp: 'lr 9/5/2005 22:19'! log: aSession on: aStream self subclassResponsibility.! ! !FTPMessage methodsFor: 'printing' stamp: 'lr 9/15/2005 22:08'! writeOn: aStream self writeOn: aStream ident: String new.! ! !FTPMessage methodsFor: 'printing' stamp: 'lr 8/19/2005 13:30'! writeOn: aStream ident: aString self subclassResponsibility.! ! FTPMessage subclass: #FTPRequest instanceVariableNames: 'verb argument' classVariableNames: '' poolDictionaries: '' category: 'FTP-Server'! !FTPRequest class methodsFor: 'instance creation' stamp: 'lr 9/2/2005 15:15'! readFrom: aStream | line | line := aStream upTo: Character lf. (line notEmpty and: [ line last = Character cr ]) ifTrue: [ line := line allButLast ]. ^ self new setVerb: (line copyUpTo: $ ); setArgument: (line copyAfter: $ ); yourself.! ! !FTPRequest methodsFor: 'accessing' stamp: 'lr 8/18/2005 09:49'! argument ^ argument! ! !FTPRequest methodsFor: 'printing' stamp: 'lr 9/5/2005 22:20'! log: aSession on: aStream self writeOn: aStream ident: aSession printString , ' >> '.! ! !FTPRequest methodsFor: 'conveniance' stamp: 'lr 9/5/2005 15:41'! normalized ^ self argument withBlanksTrimmed asUppercase.! ! !FTPRequest methodsFor: 'printing' stamp: 'lr 9/2/2005 15:15'! printOn: aStream super printOn: aStream. aStream nextPutAll: ' verb: '; print: self verb. aStream nextPutAll: ' argument: '; print: self argument.! ! !FTPRequest methodsFor: 'initialization' stamp: 'lr 8/19/2005 14:31'! setArgument: aString argument := aString! ! !FTPRequest methodsFor: 'initialization' stamp: 'lr 9/2/2005 19:50'! setVerb: aString verb := aString asUppercase.! ! !FTPRequest methodsFor: 'accessing' stamp: 'lr 9/2/2005 20:02'! verb ^ verb! ! !FTPRequest methodsFor: 'printing' stamp: 'lr 9/2/2005 20:02'! writeOn: aStream ident: aString aStream nextPutAll: aString; nextPutAll: self verb. aStream space; nextPutAll: self argument. aStream nextPutAll: String crlf; flush.! ! FTPMessage subclass: #FTPResponse instanceVariableNames: 'code lines' classVariableNames: '' poolDictionaries: '' category: 'FTP-Server'! !FTPResponse class methodsFor: 'instance creation' stamp: 'lr 9/2/2005 16:54'! code: anInteger ^ self code: anInteger line: 'OK'.! ! !FTPResponse class methodsFor: 'instance creation' stamp: 'lr 8/19/2005 10:56'! code: anInteger lines: aCollection ^ self new setCode: anInteger; setLines: aCollection; yourself.! ! !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 19:21'! code: anInteger string: aString ^ self code: anInteger lines: (aString findTokens: Character cr).! ! !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 class methodsFor: 'instance creation' stamp: 'lr 9/6/2005 08:23'! fromString: aStream | code lines | code := aStream next: 3. code isAllDigits ifFalse: [ self error: 'Invalid status code: ' , code ]. lines := OrderedCollection new. [ aStream atEnd ] whileFalse: [ lines add: (aStream next; nextLine) ]. ^ self code: code asInteger lines: lines.! ! !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: '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: 'errors' stamp: 'lr 9/15/2005 23:25'! notFound ^ self code: 550 line: 'No such file or directory.'.! ! !FTPResponse class methodsFor: 'accepting' stamp: 'lr 8/18/2005 09:21'! okay ^ self code: 200.! ! !FTPResponse class methodsFor: 'errors' stamp: 'lr 9/15/2005 23:31'! permissionDenied ^ self code: 550 line: 'Permission denied.'.! ! !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: '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 9/2/2005 17:04'! code ^ code! ! !FTPResponse methodsFor: 'accessing' stamp: 'lr 8/19/2005 10:49'! lines ^ lines! ! !FTPResponse methodsFor: 'printing' stamp: 'lr 9/5/2005 22:20'! log: aSession on: aStream self writeOn: aStream ident: aSession printString , ' << '.! ! !FTPResponse methodsFor: 'printing' stamp: 'lr 9/2/2005 16:51'! printOn: aStream super printOn: aStream. aStream nextPutAll: ' lines: '; print: self lines.! ! !FTPResponse methodsFor: 'initialization' stamp: 'lr 9/2/2005 16:54'! setCode: anInteger code := anInteger! ! !FTPResponse methodsFor: 'initialization' stamp: 'lr 8/19/2005 10:53'! setLines: aCollection lines := aCollection! ! !FTPResponse methodsFor: 'printing' stamp: 'lr 9/2/2005 20:18'! writeOn: aStream ident: aString 1 to: self lines size do: [ :index | aStream nextPutAll: aString. (index = 1 or: [ index = self lines size ]) ifTrue: [ aStream print: self code ]. (index = 1 and: [ self lines size > 1 ]) ifTrue: [ aStream nextPut: $- ] ifFalse: [ aStream nextPut: Character space ]. aStream nextPutAll: (self lines at: index). aStream nextPutAll: String crlf ].! ! Object subclass: #FTPProperties instanceVariableNames: 'properties' classVariableNames: '' poolDictionaries: '' category: 'FTP-Server'! !FTPProperties methodsFor: 'initialization' stamp: 'lr 9/1/2005 12:43'! initialize super initialize. properties := IdentityDictionary new.! ! !FTPProperties methodsFor: 'copying' stamp: 'lr 9/1/2005 14:17'! postCopy super postCopy. properties := self properties copy.! ! !FTPProperties methodsFor: 'accessing' stamp: 'lr 9/1/2005 12:09'! properties ^ properties! ! !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'! propertyAt: aSymbol put: anObject ^ self properties at: aSymbol put: anObject.! ! FTPProperties subclass: #FTPSettings instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Server'! !FTPSettings methodsFor: 'server' stamp: 'lr 9/8/2005 21:49'! authenticator ^ self propertyAt: #authenticator ifAbsent: [ FTPBasicAuthenticator new ].! ! !FTPSettings methodsFor: 'server' stamp: 'lr 9/8/2005 21:49'! authenticator: anAuthenticator self propertyAt: #authenticator put: anAuthenticator.! ! !FTPSettings methodsFor: 'sockets' stamp: 'lr 9/1/2005 12:29'! backlog ^ self propertyAt: #backlog ifAbsent: [ 10 ].! ! !FTPSettings methodsFor: 'sockets' stamp: 'lr 9/1/2005 12:29'! backlog: anInteger self propertyAt: #backlog put: anInteger.! ! !FTPSettings methodsFor: 'server' stamp: 'lr 9/1/2005 12:29'! context ^ self propertyAt: #context ifAbsent: [ FTPDispatcher new ].! ! !FTPSettings methodsFor: 'server' stamp: 'lr 9/1/2005 12:29'! context: aContext self propertyAt: #context put: aContext.! ! !FTPSettings methodsFor: 'testing' stamp: 'lr 9/1/2005 12:45'! isLogging ^ self logging.! ! !FTPSettings methodsFor: 'server' stamp: 'lr 9/1/2005 12:31'! logging ^ self propertyAt: #logging ifAbsent: [ false ].! ! !FTPSettings methodsFor: 'server' stamp: 'lr 9/1/2005 12:32'! logging: aBoolean self propertyAt: #logging put: aBoolean.! ! !FTPSettings methodsFor: 'sockets' stamp: 'lr 9/15/2005 21:38'! name ^ self propertyAt: #name ifAbsent: [ 'FTP' ].! ! !FTPSettings methodsFor: 'tools' stamp: 'lr 9/15/2005 21:24'! nameFor: aString ^ String streamContents: [ :stream | stream nextPutAll: (self name ifNil: [ 'FTP' ]). stream nextPut: $(; nextPutAll: aString; nextPut: $) ].! ! !FTPSettings methodsFor: 'sockets' stamp: 'lr 9/15/2005 21:37'! name: aString " Set the name of the server process, this should be an unique value. " ^ self propertyAt: #name put: aString.! ! !FTPSettings methodsFor: 'sockets' stamp: 'lr 9/15/2005 21:32'! passive ^ self propertyAt: #passive ifAbsent: [ true ].! ! !FTPSettings methodsFor: 'sockets' stamp: 'lr 9/15/2005 21:34'! passive: aBoolean " Enable or disable support for passive mode of client. Most clients require passive-mode, otherwise they don't work. " self propertyAt: #passive put: aBoolean.! ! !FTPSettings methodsFor: 'sockets' stamp: 'lr 9/1/2005 12:30'! port ^ self propertyAt: #port ifAbsent: [ 21 ].! ! !FTPSettings methodsFor: 'sockets' stamp: 'lr 9/15/2005 21:35'! port: aNumber " Set the port number the server is listening on, most FTP servers are expected to listen on port 21. " self propertyAt: #port put: aNumber.! ! !FTPSettings methodsFor: 'sockets' stamp: 'lr 9/15/2005 18:43'! priority ^ self propertyAt: #priority ifAbsent: [ Processor userBackgroundPriority ].! ! !FTPSettings methodsFor: 'sockets' stamp: 'lr 9/15/2005 21:35'! priority: aNumber " Set the priority the server processes should run in. " self propertyAt: #priority put: aNumber.! ! !FTPSettings methodsFor: 'sockets' stamp: 'lr 9/15/2005 18:43'! range ^ self propertyAt: #range ifAbsent: [ 1024 to: 65536 ].! ! !FTPSettings methodsFor: 'sockets' stamp: 'lr 9/15/2005 21:36'! range: anInterval " Set the range of allowed ports for passive mode. Enlarging the number of ports increases the security of the server. " self propertyAt: #range put: anInterval.! ! !FTPSettings methodsFor: 'sockets' stamp: 'lr 9/1/2005 12:30'! timeout ^ self propertyAt: #timeout ifAbsent: [ 10 ].! ! !FTPSettings methodsFor: 'sockets' stamp: 'lr 9/1/2005 12:30'! timeout: anInteger self propertyAt: #timeout put: anInteger.! ! FTPProperties subclass: #FTPState instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Server'! !FTPState methodsFor: 'authentication' stamp: 'lr 9/1/2005 12:13'! account ^ self propertyAt: #account ifAbsent: [ String new ].! ! !FTPState methodsFor: 'authentication' stamp: 'lr 9/1/2005 12:14'! account: aString self propertyAt: #account put: aString.! ! !FTPState methodsFor: 'mode' stamp: 'lr 9/1/2005 12:10'! binary ^ self propertyAt: #binary ifAbsent: [ false ].! ! !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'! ip ^ self propertyAt: #ip ifAbsent: [ #( 127 0 0 1 ) ].! ! !FTPState methodsFor: 'address' stamp: 'lr 9/1/2005 12:12'! ip: anArray self propertyAt: #ip put: anArray.! ! !FTPState methodsFor: 'testing' stamp: 'lr 8/17/2005 18:42'! isBinary ^ self binary.! ! !FTPState methodsFor: 'testing' stamp: 'lr 8/17/2005 18:42'! isPassive ^ self passive.! ! !FTPState methodsFor: 'mode' stamp: 'lr 9/1/2005 12:11'! passive ^ self propertyAt: #passive ifAbsent: [ false ].! ! !FTPState methodsFor: 'mode' stamp: 'lr 9/1/2005 12:11'! passive: aBoolean self propertyAt: #passive put: aBoolean.! ! !FTPState methodsFor: 'authentication' stamp: 'lr 9/1/2005 12:14'! password ^ self propertyAt: #password ifAbsent: [ String new ].! ! !FTPState methodsFor: 'authentication' stamp: 'lr 9/1/2005 12:14'! password: aString self propertyAt: #password put: aString.! ! !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'! port: anInteger self propertyAt: #port put: anInteger.! ! !FTPState methodsFor: 'transfer' stamp: 'lr 9/1/2005 14:19'! position ^ self propertyAt: #position ifAbsent: [ 0 ].! ! !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'! username ^ self propertyAt: #username ifAbsent: [ String new ].! ! !FTPState methodsFor: 'authentication' stamp: 'lr 9/1/2005 12:14'! username: aString self propertyAt: #username put: aString.! ! Object subclass: #FTPServer instanceVariableNames: 'settings listener sessions' classVariableNames: 'Servers' poolDictionaries: '' category: 'FTP-Server'! !FTPServer commentStamp: 'ijp 1/14/2005 19:09' prior: 0! An FTP Server.! !FTPServer class methodsFor: 'initialization' stamp: 'lr 9/15/2005 19:36'! initialize Smalltalk addToStartUpList: self. Smalltalk addToShutDownList: self.! ! !FTPServer class methodsFor: 'accessing' stamp: 'lr 9/8/2005 21:37'! servers ^ Servers ifNil: [ Servers := Set new ].! ! !FTPServer class methodsFor: 'initialization' stamp: 'lr 9/8/2005 21:35'! shutDown self servers do: [ :each | each shutDown ].! ! !FTPServer class methodsFor: 'starting' stamp: 'lr 9/4/2005 12:21'! startOn: aNumber ^ self startOn: aNumber context: FTPDispatcher new.! ! !FTPServer class methodsFor: 'starting' stamp: 'lr 9/1/2005 13:42'! startOn: aNumber context: aContext | server | server := self new. server settings port: aNumber; context: aContext. ^ server start.! ! !FTPServer class methodsFor: 'initialization' stamp: 'lr 9/15/2005 19:36'! startUp Socket initializeNetwork.! ! !FTPServer methodsFor: 'initialization' stamp: 'lr 9/8/2005 21:27'! initialize super initialize. settings := FTPSettings new. sessions := Set new.! ! !FTPServer methodsFor: 'testing' stamp: 'lr 9/8/2005 21:27'! isConnected ^ self listener notNil.! ! !FTPServer methodsFor: 'accessing' stamp: 'lr 8/24/2005 07:45'! listener ^ listener! ! !FTPServer methodsFor: 'printing' stamp: 'lr 9/8/2005 21:50'! printOn: aStream super printOn: aStream. aStream nextPutAll: ' port: '; print: self settings port.! ! !FTPServer methodsFor: 'actions' stamp: 'lr 11/21/2004 19:45'! restart self stop; start.! ! !FTPServer methodsFor: 'accessing' stamp: 'lr 9/15/2005 19:00'! servers ^ self class servers.! ! !FTPServer methodsFor: 'accessing' stamp: 'lr 8/24/2005 07:44'! sessions ^ sessions! ! !FTPServer methodsFor: 'accessing' stamp: 'lr 9/1/2005 12:28'! settings ^ settings! ! !FTPServer methodsFor: 'private' stamp: 'lr 9/15/2005 19:34'! shutDown self sessions copy do: [ :each | each close ].! ! !FTPServer methodsFor: 'actions' stamp: 'lr 9/8/2005 21:39'! start self isConnected ifTrue: [ ^ self ]. self startServer.! ! !FTPServer methodsFor: 'private' stamp: 'lr 9/15/2005 19:05'! startServer listener := FTPServerListener server: self. listener start. self servers add: self.! ! !FTPServer methodsFor: 'private' stamp: 'lr 9/8/2005 21:54'! startSession: aSocket self sessions add: (FTPSession new setAuthenticator: self settings authenticator; setContext: self settings context; setSocket: aSocket; setServer: self; run).! ! !FTPServer methodsFor: 'actions' stamp: 'lr 9/8/2005 21:44'! stop self isConnected ifFalse: [ ^ self ]. self stopServer; shutDown.! ! !FTPServer methodsFor: 'private' stamp: 'lr 9/15/2005 19:04'! stopServer listener stop. listener := nil. self servers remove: self.! ! !FTPServer methodsFor: 'private' stamp: 'lr 9/15/2005 21:29'! stopSession: aSession self sessions remove: aSession ifAbsent: nil.! ! Object subclass: #FTPSession instanceVariableNames: 'server context authenticator state telnet data escaper' classVariableNames: '' poolDictionaries: '' category: 'FTP-Server'! !FTPSession methodsFor: 'connection-data' stamp: 'lr 9/15/2005 21:25'! activeDataConnection self isDataConnected ifTrue: [ self data close ]. self setData: (FTPActiveConnection session: self on: Socket newTCP). self data socket connectTo: self state ip port: self state port waitForConnectionFor: self settings timeout.! ! !FTPSession methodsFor: 'accessing' stamp: 'lr 9/8/2005 21:51'! authenticator ^ authenticator! ! !FTPSession methodsFor: 'accessing' stamp: 'lr 9/8/2005 21:51'! authenticator: anAuthenticator authenticator := anAuthenticator! ! !FTPSession methodsFor: 'actions' stamp: 'lr 9/8/2005 21:31'! close self server stopSession: self. self isDataConnected ifTrue: [ self data close ]. self telnet close. ! ! !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: 'accessing-reading' stamp: 'lr 8/19/2005 10:23'! data ^ data! ! !FTPSession methodsFor: 'processing' stamp: 'lr 9/15/2005 19:45'! handlerLoop | request | self response: (FTPResponse code: 220 string: self context welcomeString). [ self telnet isConnected ] whileTrue: [ request := FTPRequest readFrom: self telnet. self response: (self responseForRequest: request) ]. self close.! ! !FTPSession methodsFor: 'initialization' stamp: 'lr 8/18/2005 12:14'! initialize super initialize. state := FTPState new.! ! !FTPSession methodsFor: 'testing' stamp: 'lr 9/1/2005 11:53'! isDataConnected ^ self data notNil and: [ self data isConnected ].! ! !FTPSession methodsFor: 'testing' stamp: 'lr 9/1/2005 11:53'! isTelnetConnected ^ self telnet isConnected.! ! !FTPSession methodsFor: 'connection-data' stamp: 'lr 9/15/2005 22:23'! passiveDataConnection self isDataConnected ifTrue: [ self data close ]. self setData: (FTPPassiveConnection session: self on: Socket newTCP). self data socket listenOn: self state port backlogSize: 0.! ! !FTPSession methodsFor: 'processing' stamp: 'lr 9/5/2005 22:19'! performLogging: aMessage self server settings isLogging ifFalse: [ ^ self ]. aMessage log: self on: Transcript. Transcript endEntry.! ! !FTPSession methodsFor: 'processing' stamp: 'lr 9/8/2005 21:52'! performRequest: aRequest | verb | aRequest verb isEmpty ifTrue: [ ^ nil ]. self performLogging: aRequest. verb := FTPVerb in: self for: aRequest ifAbsent: [ self context unknownRequest: aRequest ]. self return: verb execute.! ! !FTPSession methodsFor: 'printing' stamp: 'lr 9/5/2005 22:21'! printOn: aStream super printOn: aStream. aStream nextPut: $[; print: self hash; nextPut: $].! ! !FTPSession methodsFor: 'processing' stamp: 'lr 8/20/2005 15:44'! responseForRequest: aRequest ^ self withEscaperDo: [ self withSessionDo: [ self withHandlerDo: [ self performRequest: aRequest ] ] ].! ! !FTPSession methodsFor: 'connection-telnet' stamp: 'lr 9/15/2005 22:11'! response: aResponse aResponse isNil ifTrue: [ ^ self ]. aResponse writeOn: self telnet. self telnet flush. self performLogging: aResponse. ! ! !FTPSession methodsFor: 'connection-telnet' stamp: 'lr 9/1/2005 15:04'! return: aResponse escaper value: aResponse. ! ! !FTPSession methodsFor: 'actions' stamp: 'lr 9/1/2005 12:17'! run self telnet run: [ self handlerLoop ].! ! !FTPSession methodsFor: 'accessing-reading' stamp: 'lr 8/19/2005 10:19'! server ^ server! ! !FTPSession methodsFor: 'initialization' stamp: 'lr 9/8/2005 21:53'! setAuthenticator: anAuthenticator authenticator := anAuthenticator! ! !FTPSession methodsFor: 'initialization' stamp: 'lr 8/16/2005 14:56'! setContext: aContext context := aContext! ! !FTPSession methodsFor: 'initialization' stamp: 'lr 8/20/2005 13:50'! setData: aConnection data := aConnection! ! !FTPSession methodsFor: 'initialization' stamp: 'lr 8/19/2005 10:20'! setServer: aServer server := aServer! ! !FTPSession methodsFor: 'initialization' stamp: 'lr 9/15/2005 21:18'! setSocket: aSocket telnet := FTPTelnetConnection session: self on: aSocket.! ! !FTPSession methodsFor: 'accessing-reading' stamp: 'lr 9/5/2005 22:46'! settings ^ self server settings.! ! !FTPSession methodsFor: 'accessing-reading' stamp: 'lr 8/17/2005 15:59'! state ^ state! ! !FTPSession methodsFor: 'accessing-reading' stamp: 'lr 8/31/2005 21:30'! telnet ^ telnet! ! !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: 'processing' stamp: 'lr 8/20/2005 15:47'! withSessionDo: aBlock ^ FTPCurrentSession use: self during: aBlock.! ! !FTPSession methodsFor: 'connection-data' stamp: 'lr 9/15/2005 22:25'! withStreamDo: aBlock self state isPassive ifFalse: [ self activeDataConnection ]. self data isConnected ifFalse: [ self error: 'Invalid data connection.' ]. self data run: [ aBlock value: self data ].! ! Object subclass: #FTPVerb instanceVariableNames: 'session request' classVariableNames: 'Features Verbs' poolDictionaries: '' category: 'FTP-Verbs'! FTPVerb subclass: #FTPAuthentication instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Verbs'! FTPAuthentication subclass: #FTPAcctVerb instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Verbs'! !FTPAcctVerb 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.! !FTPAcctVerb class methodsFor: 'accessing' stamp: 'lr 9/2/2005 19:45'! verbs ^ Array with: 'ACCT'.! ! !FTPAcctVerb methodsFor: 'processing' stamp: 'lr 8/31/2005 22:22'! execute self state account: self request argument. self return: (FTPResponse code: 230).! ! !FTPAuthentication methodsFor: 'actions' stamp: 'lr 8/31/2005 22:23'! return: aResponse self context updateAuthentication: self request. super return: aResponse.! ! FTPAuthentication subclass: #FTPPassVerb instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Verbs'! !FTPPassVerb 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.! !FTPPassVerb class methodsFor: 'accessing' stamp: 'lr 9/2/2005 19:45'! verbs ^ Array with: 'PASS'.! ! !FTPPassVerb methodsFor: 'processing' stamp: 'lr 8/31/2005 22:22'! execute self state password: self request argument. self return: (FTPResponse code: 230).! ! FTPAuthentication subclass: #FTPUserVerb instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Verbs'! !FTPUserVerb 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.! !FTPUserVerb class methodsFor: 'accessing' stamp: 'lr 9/2/2005 19:45'! verbs ^ Array with: 'USER'.! ! !FTPUserVerb methodsFor: 'processing' stamp: 'lr 8/31/2005 22:20'! execute self state username: self request argument. self return: (FTPResponse code: 230).! ! FTPVerb subclass: #FTPCdupVerb instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Verbs'! !FTPCdupVerb 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.! !FTPCdupVerb class methodsFor: 'accessing' stamp: 'lr 9/5/2005 10:03'! verbs ^ Array with: 'CDUP' with: 'XCUP'.! ! !FTPCdupVerb 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.! ! FTPVerb subclass: #FTPCwdVerb instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Verbs'! !FTPCwdVerb 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.! !FTPCwdVerb class methodsFor: 'accessing' stamp: 'lr 9/5/2005 10:02'! verbs ^ Array with: 'CWD' with: 'XCWD'.! ! !FTPCwdVerb methodsFor: 'processing' stamp: 'lr 9/1/2005 14:40'! execute self context: (self findContext: self request argument type: #directory). self return: FTPResponse okay.! ! FTPVerb subclass: #FTPFeatVerb instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Verbs'! !FTPFeatVerb class methodsFor: 'accessing' stamp: 'lr 9/2/2005 19:42'! verbs ^ Array with: 'FEAT'.! ! !FTPFeatVerb methodsFor: 'processing' stamp: 'lr 9/2/2005 20:20'! execute self return: (FTPResponse code: 211 string: (String streamContents: [ :stream | stream nextPutAll: 'Extensions supported:'; cr. Features asSortedCollection do: [ :each | stream nextPutAll: each; cr ]. stream nextPutAll: 'END'. ])).! ! FTPVerb subclass: #FTPInformation instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Verbs'! FTPInformation subclass: #FTPHelpVerb instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Verbs'! !FTPHelpVerb 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.! !FTPHelpVerb class methodsFor: 'accessing' stamp: 'lr 9/2/2005 19:42'! verbs ^ Array with: 'HELP'.! ! !FTPHelpVerb methodsFor: 'accessing' stamp: 'lr 8/31/2005 20:11'! contents ^ self context helpString.! ! !FTPHelpVerb methodsFor: 'accessing' stamp: 'lr 8/31/2005 19:56'! status ^ 214! ! !FTPInformation methodsFor: 'accessing' stamp: 'lr 8/31/2005 19:58'! contents self subclassResponsibility.! ! !FTPInformation methodsFor: 'processing' stamp: 'lr 8/31/2005 19:57'! execute self return: (FTPResponse code: self status string: self contents).! ! !FTPInformation methodsFor: 'accessing' stamp: 'lr 8/31/2005 19:56'! status self subclassResponsibility.! ! FTPInformation subclass: #FTPStatVerb instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Verbs'! !FTPStatVerb 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.! !FTPStatVerb class methodsFor: 'accessing' stamp: 'lr 9/2/2005 19:42'! verbs ^ Array with: 'STAT'.! ! !FTPStatVerb methodsFor: 'accessing' stamp: 'lr 8/31/2005 20:12'! contents ^ self context statusString.! ! !FTPStatVerb methodsFor: 'accessing' stamp: 'lr 8/31/2005 19:57'! status ^ 211! ! FTPInformation subclass: #FTPSystVerb instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Verbs'! !FTPSystVerb 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.! !FTPSystVerb class methodsFor: 'accessing' stamp: 'lr 9/2/2005 19:43'! verbs ^ Array with: 'SYST'.! ! !FTPSystVerb methodsFor: 'accessing' stamp: 'lr 9/5/2005 22:39'! contents ^ 'UNIX Type: L8'! ! !FTPSystVerb methodsFor: 'accessing' stamp: 'lr 8/31/2005 19:58'! status ^ 215! ! FTPVerb subclass: #FTPListing instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Verbs'! !FTPListing 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.! !FTPListing methodsFor: 'accessing' stamp: 'lr 9/5/2005 14:36'! children | context | context := self findContext: self request argument. ^ context isFile ifTrue: [ Array with: context ] ifFalse: [ context children ].! ! !FTPListing methodsFor: 'processing' stamp: 'lr 9/15/2005 22:05'! execute self response: (FTPResponse code: 150). self session withStreamDo: [ :stream | self print: self children on: stream ]. self return: (FTPResponse code: 226).! ! !FTPListing methodsFor: 'printing' stamp: 'lr 9/5/2005 14:08'! printContext: aContext on: aStream self subclassResponsibility.! ! !FTPListing methodsFor: 'printing' stamp: 'lr 9/5/2005 13:45'! printGroup: aContext on: aStream aStream nextPutAll: aContext groupName.! ! !FTPListing methodsFor: 'printing' stamp: 'lr 9/5/2005 15:00'! printMode: aContext on: aStream aContext isDirectory ifTrue: [ aStream nextPut: $d. 3 timesRepeat: [ aStream nextPut: (aContext canBeListed ifTrue: [ $r ] ifFalse: [ $- ]). aStream nextPut: (aContext canCreate ifTrue: [ $w ] ifFalse: [ $- ]). aStream nextPut: (aContext canBeListed ifTrue: [ $x ] ifFalse: [ $- ]) ] ] ifFalse: [ aStream nextPut: $-. 3 timesRepeat: [ aStream nextPut: (aContext canRead ifTrue: [ $r ] ifFalse: [ $- ]). aStream nextPut: (aContext canWrite ifTrue: [ $w ] ifFalse: [ $- ]). aStream nextPut: $- ] ].! ! !FTPListing methodsFor: 'printing' stamp: 'lr 9/5/2005 13:38'! printName: aContext on: aStream aStream nextPutAll: aContext name.! ! !FTPListing methodsFor: 'printing' stamp: 'lr 9/5/2005 13:54'! printOwner: aContext on: aStream aStream nextPutAll: aContext ownerName.! ! !FTPListing methodsFor: 'printing' stamp: 'lr 9/5/2005 14:17'! printReferences: aContext on: aStream aStream print: aContext references.! ! !FTPListing methodsFor: 'printing' stamp: 'lr 9/7/2005 22:53'! printSize: aContext on: aStream [ aStream print: aContext size. ] ifError: [ self halt. ]! ! !FTPListing methodsFor: 'printing' stamp: 'lr 9/5/2005 14:18'! printTimestamp: aContext on: aStream aContext modification in: [ :timestamp | aStream nextPutAll: (timestamp monthName copyFrom: 1 to: 3); space. aStream nextPutAll: (timestamp daysInMonth asString padded: #left to: 2 with: $ ); space. 86400 * timestamp asYear daysInYear + timestamp asSeconds < TimeStamp now asSeconds ifTrue: [ aStream nextPutAll: (timestamp year asString padded: #left to: 4 with: $ ) ] ifFalse: [ aStream nextPutAll: (timestamp hours asString padded: #left to: 2 with: $0); nextPut: $:. aStream nextPutAll: (timestamp minutes asString padded: #left to: 2 with: $0) ] ].! ! !FTPListing methodsFor: 'printing' stamp: 'lr 9/5/2005 14:08'! print: aCollection on: aStream aCollection do: [ :each | self printContext: each on: aStream ].! ! FTPListing subclass: #FTPListVerb instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Verbs'! !FTPListVerb class methodsFor: 'accessing' stamp: 'lr 9/2/2005 19:43'! verbs ^ Array with: 'LIST'.! ! !FTPListVerb methodsFor: 'accessing' stamp: 'lr 9/5/2005 15:31'! padding ^ #( none left right right left left none ).! ! !FTPListVerb methodsFor: 'printing' stamp: 'lr 9/5/2005 15:14'! print: aCollection on: aStream | lines sizes | lines := self children collect: [ :child | self selectors collect: [ :selector | String streamContents: [ :stream | self perform: selector with: child with: stream ] ] ]. sizes := (1 to: self selectors size) collect: [ :index | lines inject: 0 into: [ :result :each | result max: (each at: index) size ] ]. lines do: [ :line | (1 to: self selectors size) do: [ :index | aStream nextPutAll: ((line at: index) padded: (self padding at: index) to: (sizes at: index) with: $ ) ] separatedBy: [ aStream nextPut: Character space ]. aStream nextPutAll: String crlf ].! ! !FTPListVerb methodsFor: 'accessing' stamp: 'lr 9/5/2005 14:17'! selectors ^ #( printMode:on: printReferences:on: printOwner:on: printGroup:on: printSize:on: printTimestamp:on: printName:on: ).! ! FTPListing subclass: #FTPModernListing instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Verbs'! !FTPModernListing commentStamp: 'lr 9/5/2005 15:21' prior: 0! The MLST and MLSD commands are intended to standardize the file and directory information returned by the Server-FTP process. These commands differ from the LIST command in that the format of the replies is strictly defined although extensible. Two commands are defined, MLST which provides data about exactly the object named on its command line, and no others. MLSD on the other hand will list the contents of a directory if a directory is named, otherwise a 501 reply will be returned. In either case, if no object is named, the current directory is assumed. That will cause MLST to send a one line response, describing the current directory itself, and MLSD to list the contents of the current directory.! FTPModernListing subclass: #FTPMlsdVerb instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Verbs'! !FTPMlsdVerb class methodsFor: 'accessing' stamp: 'lr 9/2/2005 19:43'! verbs ^ Array with: 'MLSD'.! ! !FTPMlsdVerb methodsFor: 'accessing' stamp: 'lr 9/5/2005 15:26'! children ^ (self findContext: self request argument type: #directory) children.! ! FTPModernListing subclass: #FTPMlstVerb instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Verbs'! !FTPMlstVerb commentStamp: 'lr 9/2/2005 15:06' prior: 0! The MLST and MLSD commands are intended to standardize the file and directory information returned by the Server-FTP process. These commands differ from the LIST command in that the format of the replies is strictly defined although extensible. Two commands are defined, MLST which provides data about exactly the object named on its command line, and no others. MLSD on the other hand will list the contents of a directory if a directory is named, otherwise a 501 reply will be returned. In either case, if no object is named, the current directory is assumed. That will cause MLST to send a one line response, describing the current directory itself, and MLSD to list the contents of the current directory.! !FTPMlstVerb class methodsFor: 'accessing' stamp: 'lr 9/2/2005 19:43'! verbs ^ Array with: 'MLST'.! ! !FTPMlstVerb methodsFor: 'accessing' stamp: 'lr 9/5/2005 14:45'! children ^ Array with: (self findContext: self request argument).! ! !FTPMlstVerb methodsFor: 'processing' stamp: 'lr 9/5/2005 15:22'! execute self return: (FTPResponse code: 250 string: (String streamContents: [ :stream | self print: self children on: stream. stream skip: String crlf size negated ])).! ! !FTPModernListing class methodsFor: 'accessing' stamp: 'lr 9/5/2005 15:18'! features ^ #( 'MLST Size*;Modify*;Create*;Type*;Unique*;Perm*;UNIX.mode*;UNIX.owner*;UNIX.group*;' 'TVFS' )! ! !FTPModernListing methodsFor: 'printing' stamp: 'lr 9/5/2005 15:09'! printContext: aContext on: aStream self selectors do: [ :each | self perform: each with: aContext with: aStream. aStream nextPut: $; ]. self printName: aContext on: aStream. aStream nextPutAll: String crlf.! ! !FTPModernListing methodsFor: 'printing' stamp: 'lr 9/5/2005 15:30'! printCreate: aContext on: aStream self printTag: 'Create' on: aStream. aStream nextPutAll: aContext creation asFtpTimeStamp.! ! !FTPModernListing methodsFor: 'printing' stamp: 'lr 9/5/2005 13:53'! printGroup: aContext on: aStream self printTag: 'UNIX.group' on: aStream. super printGroup: aContext on: aStream.! ! !FTPModernListing methodsFor: 'printing' stamp: 'lr 9/5/2005 13:53'! printMode: aContext on: aStream self printTag: 'UNIX.mode' on: aStream. super printMode: aContext on: aStream.! ! !FTPModernListing methodsFor: 'printing' stamp: 'lr 9/5/2005 14:57'! printModify: aContext on: aStream self printTag: 'Modify' on: aStream. aStream nextPutAll: aContext modification asFtpTimeStamp.! ! !FTPModernListing methodsFor: 'printing' stamp: 'lr 9/5/2005 13:40'! printName: aContext on: aStream aStream nextPut: Character space. super printName: aContext on: aStream.! ! !FTPModernListing methodsFor: 'printing' stamp: 'lr 9/5/2005 13:52'! printOwner: aContext on: aStream self printTag: 'UNIX.owner' on: aStream. super printOwner: aContext on: aStream.! ! !FTPModernListing methodsFor: 'printing' stamp: 'lr 9/5/2005 15:06'! printPerm: aContext on: aStream self printTag: 'Perm' on: aStream. aContext canAppend ifTrue: [ aStream nextPut: $a ]. aContext canCreate ifTrue: [ aStream nextPut: $c ]. aContext canBeDeleted ifTrue: [ aStream nextPut: $d ]. aContext canBeListed ifTrue: [ aStream nextPut: $e ]. aContext canBeRenamed ifTrue: [ aStream nextPut: $f ]. aContext canBeListed ifTrue: [ aStream nextPut: $l ]. aContext canCreate ifTrue: [ aStream nextPut: $m ]. aContext canRead ifTrue: [ aStream nextPut: $r ]. aContext canWrite ifTrue: [ aStream nextPut: $w ].! ! !FTPModernListing methodsFor: 'printing' stamp: 'lr 9/5/2005 13:41'! printSize: aContext on: aStream self printTag: 'Size' on: aStream. super printSize: aContext on: aStream.! ! !FTPModernListing methodsFor: 'printing' stamp: 'lr 9/5/2005 13:41'! printTag: aString on: aStream aStream nextPutAll: aString; nextPut: $=.! ! !FTPModernListing methodsFor: 'printing' stamp: 'lr 9/5/2005 15:07'! printType: aContext on: aStream self printTag: 'Type' on: aStream. aStream nextPutAll: (aContext isDirectory ifTrue: [ 'dir' ] ifFalse: [ 'file' ]).! ! !FTPModernListing methodsFor: 'printing' stamp: 'lr 9/5/2005 14:58'! printUnique: aContext on: aStream self printTag: 'unique' on: aStream. aStream print: aContext hash.! ! !FTPModernListing methodsFor: 'accessing' stamp: 'lr 9/5/2005 15:31'! selectors ^ #( printSize:on: printModify:on: printCreate:on: printType:on: printUnique:on: printPerm:on: printMode:on: printOwner:on: printGroup:on: )! ! FTPListing subclass: #FTPNlstVerb instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Verbs'! !FTPNlstVerb class methodsFor: 'accessing' stamp: 'lr 9/2/2005 19:43'! verbs ^ Array with: 'NLST'.! ! !FTPNlstVerb methodsFor: 'printing' stamp: 'lr 9/5/2005 14:08'! printContext: aContext on: aStream self printName: aContext on: aStream. aStream nextPutAll: String crlf.! ! FTPVerb subclass: #FTPMdtmVerb instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Verbs'! !FTPMdtmVerb class methodsFor: 'accessing' stamp: 'lr 9/5/2005 12:11'! features ^ self verbs.! ! !FTPMdtmVerb class methodsFor: 'accessing' stamp: 'lr 9/5/2005 12:10'! verbs ^ Array with: 'MDTM'.! ! !FTPMdtmVerb methodsFor: 'processing' stamp: 'lr 9/5/2005 12:17'! execute | context | context := self findContext: self request argument. self return: (FTPResponse code: 213 line: context modification asFtpTimeStamp).! ! FTPVerb subclass: #FTPModeVerb instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Verbs'! !FTPModeVerb 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.! !FTPModeVerb class methodsFor: 'accessing' stamp: 'lr 9/2/2005 19:44'! verbs ^ Array with: 'MODE'.! ! !FTPModeVerb methodsFor: 'processing' stamp: 'lr 9/1/2005 15:08'! execute self response: (self request normalized = 'S' ifFalse: [ FTPResponse unsupportedParameter ] ifTrue: [ FTPResponse okay ]).! ! FTPVerb subclass: #FTPNoopVerb instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Verbs'! !FTPNoopVerb 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.! !FTPNoopVerb class methodsFor: 'accessing' stamp: 'lr 9/5/2005 10:01'! verbs ^ Array with: 'ALLO' with: 'NOOP'.! ! !FTPNoopVerb methodsFor: 'processing' stamp: 'lr 8/21/2005 14:32'! execute self return: FTPResponse okay.! ! FTPVerb subclass: #FTPPasvVerb instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Verbs'! !FTPPasvVerb 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. ! !FTPPasvVerb class methodsFor: 'accessing' stamp: 'lr 9/2/2005 19:44'! verbs ^ Array with: 'PASV'.! ! !FTPPasvVerb methodsFor: 'processing' stamp: 'lr 9/15/2005 21:41'! execute self request argument notEmpty ifTrue: [ self return: FTPResponse unsupportedParameter ]. self settings passive ifFalse: [ self return: (FTPResponse error: 'Passive mode refused.') ]. self state passive: true; ip: NetNameResolver localHostAddress; port: self settings range atRandom. self session passiveDataConnection. self return: (FTPResponse code: 227 line: (String streamContents: [ :stream | stream nextPutAll: 'Entering Passive Mode ('. self state ip do: [ :each | stream print: each; nextPut: $, ]. stream print: self state port // 256; nextPut: $,; print: self state port \\ 256. stream nextPutAll: ')' ])).! ! FTPVerb subclass: #FTPPortVerb instanceVariableNames: 'numbers' classVariableNames: '' poolDictionaries: '' category: 'FTP-Verbs'! !FTPPortVerb class methodsFor: 'accessing' stamp: 'lr 9/2/2005 19:44'! verbs ^ Array with: 'PORT'.! ! !FTPPortVerb 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.! ! !FTPPortVerb 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 ].! ! FTPVerb subclass: #FTPPwdVerb instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Verbs'! !FTPPwdVerb class methodsFor: 'accessing' stamp: 'lr 9/5/2005 10:02'! verbs ^ Array with: 'PWD' with: 'XPWD'.! ! !FTPPwdVerb 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' ])).! ! FTPVerb subclass: #FTPQuitVerb instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Verbs'! !FTPQuitVerb 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).! !FTPQuitVerb class methodsFor: 'accessing' stamp: 'lr 9/2/2005 19:44'! verbs ^ Array with: 'QUIT'.! ! !FTPQuitVerb methodsFor: 'processing' stamp: 'lr 9/5/2005 15:44'! execute self response: (FTPResponse code: 221 string: self context goodbyeString). self session close.! ! FTPVerb subclass: #FTPRestVerb instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Verbs'! !FTPRestVerb 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.! !FTPRestVerb class methodsFor: 'accessing' stamp: 'lr 9/5/2005 12:21'! features ^ Array with: 'REST STREAM'.! ! !FTPRestVerb class methodsFor: 'accessing' stamp: 'lr 9/2/2005 19:44'! verbs ^ Array with: 'REST'.! ! !FTPRestVerb methodsFor: 'processing' stamp: 'lr 9/5/2005 12:22'! 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: 'Restarting at ' , self state position asString).! ! FTPVerb subclass: #FTPSiteVerb instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Verbs'! !FTPSiteVerb 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.! !FTPSiteVerb class methodsFor: 'accessing' stamp: 'lr 9/2/2005 19:45'! verbs ^ Array with: 'SITE'.! ! !FTPSiteVerb methodsFor: 'processing' stamp: 'lr 9/5/2005 09:53'! execute | command | command := FTPVerb in: self session for: (FTPRequest readFrom: self request argument) ifAbsent: [self return: FTPResponse invalidCommand ]. self return: command execute.! ! FTPVerb subclass: #FTPSizeVerb instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Verbs'! !FTPSizeVerb class methodsFor: 'accessing' stamp: 'lr 9/2/2005 19:45'! features ^ self verbs.! ! !FTPSizeVerb class methodsFor: 'accessing' stamp: 'lr 9/2/2005 19:45'! verbs ^ Array with: 'SIZE'.! ! !FTPSizeVerb 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).! ! FTPVerb subclass: #FTPStruVerb instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Verbs'! !FTPStruVerb 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.! !FTPStruVerb class methodsFor: 'accessing' stamp: 'lr 9/2/2005 19:45'! verbs ^ Array with: 'STRU'.! ! !FTPStruVerb methodsFor: 'processing' stamp: 'lr 9/1/2005 15:07'! execute self return: (self request normalized = 'F' ifFalse: [ FTPResponse unsupportedParameter ] ifTrue: [ FTPResponse okay ]).! ! FTPVerb subclass: #FTPTransfer instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Verbs'! FTPTransfer subclass: #FTPRetrVerb instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Verbs'! !FTPRetrVerb 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.! !FTPRetrVerb class methodsFor: 'accessing' stamp: 'lr 9/2/2005 19:46'! verbs ^ Array with: 'RETR'.! ! !FTPRetrVerb methodsFor: 'private' stamp: 'lr 9/1/2005 15:42'! cleanup: aContext self state position: 0.! ! !FTPRetrVerb methodsFor: 'private' stamp: 'lr 9/15/2005 23:33'! lookup | context | context := self findContext: self request argument type: #file. context canRead ifFalse: [ self return: FTPResponse permissionDenied ]. ^ context.! ! !FTPRetrVerb methodsFor: 'private' stamp: 'lr 9/15/2005 22:34'! process: aContext on: aStream aContext get: aStream startingAt: self state position.! ! FTPTransfer subclass: #FTPStorVerb instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Verbs'! !FTPStorVerb 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.! FTPStorVerb subclass: #FTPAppeVerb instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Verbs'! !FTPAppeVerb class methodsFor: 'accessing' stamp: 'lr 9/2/2005 19:46'! verbs ^ Array with: 'APPE'.! ! !FTPAppeVerb methodsFor: 'private' stamp: 'lr 9/15/2005 23:35'! lookup | context | context := self findContext: self request argument type: #file new: false. context canAppend ifFalse: [ self return: FTPResponse permissionDenied ]. ^ context.! ! !FTPAppeVerb methodsFor: 'private' stamp: 'lr 9/1/2005 15:40'! process: aContext on: aStream aContext put: aStream startingAt: aContext size.! ! !FTPStorVerb class methodsFor: 'accessing' stamp: 'lr 9/2/2005 19:46'! verbs ^ Array with: 'STOR'.! ! !FTPStorVerb methodsFor: 'private' stamp: 'lr 9/1/2005 15:43'! cleanup: aContext aContext hasParent ifTrue: [ aContext parent flush ].! ! !FTPStorVerb methodsFor: 'private' stamp: 'lr 9/15/2005 23:35'! lookup | context | context := self findContext: self request argument type: #file new: true. context canWrite ifFalse: [ self return: FTPResponse permissionDenied ]. ^ context.! ! !FTPStorVerb methodsFor: 'private' stamp: 'lr 9/1/2005 15:39'! process: aContext on: aStream aContext put: aStream.! ! !FTPTransfer methodsFor: 'private' stamp: 'lr 9/1/2005 15:42'! cleanup: aContext! ! !FTPTransfer 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).! ! !FTPTransfer methodsFor: 'private' stamp: 'lr 9/1/2005 15:36'! lookup self subclassResponsibility.! ! !FTPTransfer methodsFor: 'private' stamp: 'lr 9/1/2005 15:34'! process: aContext on: aStream self subclassResponsibility.! ! FTPVerb subclass: #FTPTypeVerb instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Verbs'! !FTPTypeVerb 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.! !FTPTypeVerb class methodsFor: 'accessing' stamp: 'lr 9/2/2005 19:46'! verbs ^ Array with: 'TYPE'.! ! !FTPTypeVerb methodsFor: 'processing' stamp: 'lr 8/19/2005 14:20'! ascii self state binary: false. self return: (FTPResponse code: 200 line: 'set to ascii').! ! !FTPTypeVerb methodsFor: 'accessing' stamp: 'lr 8/19/2005 14:17'! asciiArguments ^ #( 'A' 'A N' )! ! !FTPTypeVerb methodsFor: 'processing' stamp: 'lr 8/19/2005 14:19'! binary self state binary: true. self return: (FTPResponse code: 200 line: 'set to binary').! ! !FTPTypeVerb methodsFor: 'accessing' stamp: 'lr 8/19/2005 14:17'! binaryArguments ^ #( 'I' 'L 8' )! ! !FTPTypeVerb methodsFor: 'processing' stamp: 'lr 9/5/2005 15:41'! execute (self binaryArguments includes: self request normalized) ifTrue: [ self binary ]. (self asciiArguments includes: self request normalized) ifTrue: [ self ascii ]. self return: FTPResponse invalidParamter.! ! !FTPVerb class methodsFor: 'accessing' stamp: 'lr 9/2/2005 14:36'! features " Return a list of features of the receiver, this method will be queried from the FEAT command. " ^ #()! ! !FTPVerb class methodsFor: 'initialization' stamp: 'lr 9/2/2005 15:45'! initialize " FTPVerb initialize " self initializeVerbs. self initializeFeatures.! ! !FTPVerb class methodsFor: 'initialization' stamp: 'lr 9/2/2005 19:48'! initializeFeatures Features := Set new. self withAllSubclassesDo: [ :class | Features addAll: class features ].! ! !FTPVerb class methodsFor: 'initialization' stamp: 'lr 9/2/2005 14:34'! initializeVerbs Verbs := Dictionary new. self withAllSubclassesDo: [ :class | class verbs do: [ :verb | Verbs at: verb put: class ] ].! ! !FTPVerb class methodsFor: 'instance-creation' stamp: 'lr 9/2/2005 14:50'! in: aSession for: aRequest ifAbsent: aBlock | class | class := Verbs at: aRequest verb ifAbsent: [ ^ aBlock value ]. ^ class new setSession: aSession; setRequest: aRequest; yourself.! ! !FTPVerb class methodsFor: 'accessing' stamp: 'lr 9/2/2005 14:37'! verbs " Return a collection of upper-case command strings (verbs), where the receiver should be used with. " ^ #()! ! !FTPVerb methodsFor: 'accessing' stamp: 'lr 8/19/2005 14:08'! context ^ self session context.! ! !FTPVerb methodsFor: 'accessing' stamp: 'lr 8/19/2005 18:52'! context: aContext ^ self session context: aContext.! ! !FTPVerb methodsFor: 'processing' stamp: 'lr 8/19/2005 17:56'! execute self subclassResponsibility.! ! !FTPVerb methodsFor: 'conveniance' stamp: 'lr 9/1/2005 14:10'! findContext: aString ^ self findContext: aString type: nil.! ! !FTPVerb methodsFor: 'conveniance' stamp: 'lr 9/15/2005 23:13'! findContext: aString type: aSelector ^ self findContext: aString type: aSelector new: false.! ! !FTPVerb methodsFor: 'conveniance' stamp: 'lr 9/15/2005 23:38'! findContext: aString type: aSelector new: aBoolean | target invalid | target := self context lookup: aString. (target isNil and: [ aBoolean ]) ifTrue: [ self context canCreate ifFalse: [ self return: FTPResponse permissionDenied ]. target := aSelector caseOf: { [ #file ] -> [ self context createFileNamed: aString ]. [ #directory ] -> [ self context createDirectoryNamed: 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.! ! !FTPVerb methodsFor: 'accessing-readonly' stamp: 'lr 8/19/2005 10:39'! request ^ request! ! !FTPVerb methodsFor: 'actions' stamp: 'lr 9/1/2005 15:03'! response: aResponse self session response: aResponse.! ! !FTPVerb methodsFor: 'actions' stamp: 'lr 9/1/2005 15:03'! return: aResponse self session return: aResponse.! ! !FTPVerb methodsFor: 'accessing-readonly' stamp: 'lr 8/19/2005 14:44'! server ^ self session server.! ! !FTPVerb methodsFor: 'accessing-readonly' stamp: 'lr 8/19/2005 10:45'! session ^ session! ! !FTPVerb methodsFor: 'initialization' stamp: 'lr 8/19/2005 13:54'! setRequest: aRequest request := aRequest! ! !FTPVerb methodsFor: 'initialization' stamp: 'lr 8/19/2005 13:54'! setSession: aSession session := aSession! ! !FTPVerb methodsFor: 'accessing-readonly' stamp: 'lr 9/2/2005 19:40'! settings ^ self server settings.! ! !FTPVerb methodsFor: 'accessing-readonly' stamp: 'lr 8/19/2005 14:08'! state ^ self session state.! ! !DateAndTime methodsFor: '*ftp-converting' stamp: 'lr 9/5/2005 12:24'! asFtpTimeStamp ^ String streamContents: [ :stream | self dayMonthYearDo: [ :day :month :year | stream nextPutAll: (year asString padded: #left to: 4 with: $0). stream nextPutAll: (month asString padded: #left to: 2 with: $0). stream nextPutAll: (day asString padded: #left to: 2 with: $0) ]. stream nextPutAll: (self hours asString padded: #left to: 2 with: $0). stream nextPutAll: (self minutes asString padded: #left to: 2 with: $0). stream nextPutAll: (self seconds asString padded: #left to: 2 with: $0). self nanoSecond isZero ifFalse: [ stream nextPut: $.; nextPutAll: (self nanoSecond asString padded: #left to: 3 with: $0) ] ].! ! Notification subclass: #FTPCurrentSession instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Server'! !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 ].! ! !FTPCurrentSession class methodsFor: 'as yet unclassified' stamp: 'lr 8/20/2005 15:46'! value ^ self signal.! ! TestCase subclass: #FTPTestCase instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Testing'! FTPTestCase subclass: #FTPBrowsingTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Testing'! !FTPBrowsingTest methodsFor: 'testing-settings' stamp: 'lr 9/6/2005 08:33'! testAscii self open. self shouldnt: [ self client ascii ] raise: TelnetProtocolError.! ! !FTPBrowsingTest methodsFor: 'testing-settings' stamp: 'lr 9/6/2005 08:33'! testBinary self open. self shouldnt: [ self client binary ] raise: TelnetProtocolError.! ! !FTPBrowsingTest methodsFor: 'testing-navigation' stamp: 'lr 9/6/2005 08:58'! testCwd self open. self client changeDirectoryTo: 'd1'. self assert: self client pwd = '/d1'. self client changeDirectoryTo: '/d2'. self assert: self client pwd = '/d2'. self client changeDirectoryTo: '../d3'. self assert: self client pwd = '/d3'. ! ! !FTPBrowsingTest methodsFor: 'testing-navigation' stamp: 'lr 9/7/2005 22:07'! testList self open. self assert: (self client getDirectory includesSubString: 'd1'). self assert: (self client getDirectory includesSubString: 'd2'). self assert: (self client getDirectory includesSubString: 'd3'). self assert: (self client getDirectory includesSubString: 'f3').! ! !FTPBrowsingTest methodsFor: 'testing-navigation' stamp: 'lr 9/7/2005 22:06'! testNlst self open. self assert: (self client getFileList includesSubString: 'd1'). self assert: (self client getFileList includesSubString: 'd2'). self assert: (self client getFileList includesSubString: 'd3'). self assert: (self client getFileList includesSubString: 'f3').! ! !FTPBrowsingTest methodsFor: 'testing-connection' stamp: 'lr 9/7/2005 22:25'! testOpen self open. self assertResponseCode: 220. self assertResponseLine: 'ready'.! ! !FTPBrowsingTest methodsFor: 'testing-settings' stamp: 'lr 9/6/2005 08:35'! testPassive self open. self shouldnt: [ self client passive ] raise: TelnetProtocolError.! ! !FTPBrowsingTest methodsFor: 'testing-navigation' stamp: 'lr 9/6/2005 08:31'! testPwd self open; assert: self client pwd = '/'.! ! !FTPBrowsingTest methodsFor: 'testing-connection' stamp: 'lr 9/7/2005 22:27'! testSessions self assert: self server sessions isEmpty. self open. self assert: self server sessions size = 1. self quit. self assert: self server sessions isEmpty.! ! FTPTestCase subclass: #FTPRequestTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Testing'! !FTPRequestTest methodsFor: 'testing' stamp: 'lr 9/2/2005 20:10'! testNoArgument self assert: (FTPRequest readFrom: 'a') verb = 'A'. self assert: (FTPRequest readFrom: 'a') argument = ''.! ! !FTPRequestTest methodsFor: 'testing' stamp: 'lr 9/2/2005 20:16'! testParseLinefeed self assert: (FTPRequest readFrom: 'a b') verb = 'A'. self assert: (FTPRequest readFrom: 'a b') argument = 'b'. self assert: (FTPRequest readFrom: 'a b' , String lf) verb = 'A'. self assert: (FTPRequest readFrom: 'a b' , String lf) argument = 'b'. self assert: (FTPRequest readFrom: 'a b' , String crlf) verb = 'A'. self assert: (FTPRequest readFrom: 'a b' , String crlf) argument = 'b'! ! !FTPRequestTest methodsFor: 'testing' stamp: 'lr 9/3/2005 18:22'! testVerb self assert: (FTPRequest readFrom: 'foo') verb = 'FOO'. self assert: (FTPRequest readFrom: 'Foo') verb = 'FOO'. self assert: (FTPRequest readFrom: 'FOO') verb = 'FOO'! ! FTPTestCase subclass: #FTPResponseTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FTP-Testing'! !FTPResponseTest methodsFor: 'testing' stamp: 'lr 9/2/2005 20:00'! testCode self assert: (FTPResponse code: 201) code = 201. self assert: (FTPResponse code: 202 line: 'FTP') code = 202.! ! !FTPResponseTest methodsFor: 'testing' stamp: 'lr 9/2/2005 20:00'! testLines self assert: (FTPResponse code: 201) lines = #( 'OK' ). self assert: (FTPResponse code: 202 line: 'FTP') lines = #( 'FTP' ). self assert: (FTPResponse code: 203 lines: #( 'foo' 'bar' )) lines = #( 'foo' 'bar' ).! ! !FTPResponseTest methodsFor: 'testing' stamp: 'lr 9/3/2005 18:21'! testStream self assertStreamOutput: [ :s | (FTPResponse code: 201) writeOn: s ] equals: '201 OK' , String crlf. self assertStreamOutput: [ :s | (FTPResponse code: 202 line: '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 , ' bar' , String crlf , '203 zrk' , String crlf. self assertStreamOutput: [ :s | (FTPResponse code: 204 lines: #( 'foo' 'bar' 'zrk' 'end' )) writeOn: s ] equals: '204-foo' , String crlf , ' bar' , String crlf , ' zrk' , String crlf , '204 end' , String crlf.! ! !FTPTestCase class methodsFor: 'accessing' stamp: 'lr 9/7/2005 21:36'! resources ^ Array with: FTPTestResource.! ! !FTPTestCase methodsFor: 'asserting' stamp: 'lr 9/6/2005 08:36'! assertResponseCode: anInteger self assert: self response code = anInteger description: 'Expected response code ' , anInteger asString , ' but got ' , self response code asString , '.'.! ! !FTPTestCase methodsFor: 'asserting' stamp: 'lr 9/6/2005 08:27'! assertResponseLine: aString self assert: (self response lines anySatisfy: [ :each | each includesSubString: aString ]) description: 'Expected substring "' , aString , '" in response.'.! ! !FTPTestCase methodsFor: 'asserting' stamp: 'lr 9/6/2005 07:45'! assertStreamOutput: aBlock equals: aString | stream | aBlock value: (stream := String new writeStream). self assert: stream contents = aString description: aString , ' expected'.! ! !FTPTestCase methodsFor: 'accessing' stamp: 'lr 9/7/2005 22:04'! client ^ self resource client.! ! !FTPTestCase methodsFor: 'actions' stamp: 'lr 9/7/2005 22:04'! open ^ self resource open.! ! !FTPTestCase methodsFor: 'actions' stamp: 'lr 9/7/2005 22:04'! quit ^ self resource quit.! ! !FTPTestCase methodsFor: 'accessing' stamp: 'lr 9/7/2005 22:04'! resource ^ FTPTestResource current.! ! !FTPTestCase methodsFor: 'accessing' stamp: 'lr 9/6/2005 07:57'! response ^ FTPResponse fromString: self client lastResponse readStream.! ! !FTPTestCase methodsFor: 'accessing' stamp: 'lr 9/7/2005 22:04'! server ^ self resource server.! ! !FTPTestCase methodsFor: 'running' stamp: 'lr 9/6/2005 07:49'! tearDown self quit.! ! TestResource subclass: #FTPTestResource instanceVariableNames: 'server client' classVariableNames: '' poolDictionaries: '' category: 'FTP-Testing'! !FTPTestResource methodsFor: 'accessing' stamp: 'lr 8/17/2005 16:42'! client ^ client! ! !FTPTestResource methodsFor: 'accessing-config' stamp: 'lr 9/7/2005 21:41'! context ^ FTPTestContext new name: 'root'; children: (Array with: (FTPTestContext new name: 'd1'; children: (Array with: (FTPTestContext new name: 'f1'; contents: 'foo'; yourself) with: (FTPTestContext new name: 'f2'; contents: 'bar'; yourself)); yourself) with: (FTPTestContext new name: 'd2'; children: Array new; yourself) with: (FTPTestContext new name: 'd3'; children: Array new; yourself) with: (FTPTestContext new name: 'f3'; yourself)); yourself.! ! !FTPTestResource methodsFor: 'accessing-config' stamp: 'lr 8/17/2005 16:47'! ip ^ ByteArray with: 127 with: 0 with: 0 with: 1.! ! !FTPTestResource methodsFor: 'testing' stamp: 'lr 9/6/2005 07:50'! isClientConnected ^ self client notNil and: [ self client isConnected ].! ! !FTPTestResource methodsFor: 'testing' stamp: 'lr 9/6/2005 07:50'! isServerConnected ^ self server notNil and: [ self server isConnected ].! ! !FTPTestResource methodsFor: 'actions' stamp: 'lr 9/6/2005 07:49'! open client := FTPClient openOnHost: self ip port: self port.! ! !FTPTestResource methodsFor: 'accessing-config' stamp: 'lr 8/17/2005 16:47'! port ^ 31415! ! !FTPTestResource methodsFor: 'actions' stamp: 'lr 9/6/2005 07:51'! quit self isClientConnected ifTrue: [ self client quit ].! ! !FTPTestResource methodsFor: 'accessing' stamp: 'lr 8/17/2005 16:42'! server ^ server! ! !FTPTestResource methodsFor: 'running' stamp: 'lr 9/8/2005 14:00'! setUp server := FTPServer startOn: self port context: self context.! ! !FTPTestResource methodsFor: 'running' stamp: 'lr 9/8/2005 14:00'! tearDown self isClientConnected ifTrue: [ self client close ]. self isServerConnected ifTrue: [ self server stop ].! ! FTPServer initialize! FTPVerb initialize!