--- a/PeekableStream.st Tue Jul 13 09:38:50 2004 +0200
+++ b/PeekableStream.st Tue Jul 13 10:39:04 2004 +0200
@@ -14,7 +14,7 @@
Stream subclass:#PeekableStream
instanceVariableNames:''
- classVariableNames:''
+ classVariableNames:'ErrorDuringFileInSignal CurrentFileInDirectoryQuerySignal'
poolDictionaries:''
category:'Streams'
!
@@ -46,6 +46,47 @@
"
! !
+!PeekableStream class methodsFor:'initialization'!
+
+initialize
+ "setup the signal used to handle errors during fileIn"
+
+ ErrorDuringFileInSignal isNil ifTrue:[
+ ErrorDuringFileInSignal := Error newSignalMayProceed:true.
+ ErrorDuringFileInSignal nameClass:self message:#errorDuringFileInSignal.
+ ErrorDuringFileInSignal notifierString:'error during fileIn'.
+
+ CurrentFileInDirectoryQuerySignal := QuerySignal new.
+ CurrentFileInDirectoryQuerySignal nameClass:self message:#currentFileInDirectoryQuerySignal.
+ CurrentFileInDirectoryQuerySignal notifierString:'query for current directory when filing in'.
+ CurrentFileInDirectoryQuerySignal handlerBlock:[:ex | ex proceedWith:Filename currentDirectory].
+ ]
+
+ "
+ self initialize
+ "
+! !
+
+!PeekableStream class methodsFor:'Signal constants'!
+
+currentFileInDirectoryQuerySignal
+ "return the querySignal, which can be used to ask for the current directory
+ during a fileIn (that is the directory where the filed-in file resides),
+ and in a fileBrowsers doIt.
+ Using this, allows for the loaded code or doIts to ask for the fileBrowsers
+ current directory, by asking this querySignal (which is nice sometimes)."
+
+ ^ CurrentFileInDirectoryQuerySignal
+! !
+
+!PeekableStream class methodsFor:'queries'!
+
+currentFileInDirectory
+ "during a fileIn (if a script), the script can ask for the current directory"
+
+ ^ CurrentFileInDirectoryQuerySignal query
+! !
+
!PeekableStream methodsFor:'chunk input/output'!
nextChunk
@@ -124,6 +165,534 @@
^ theString copyTo:index
! !
+!PeekableStream methodsFor:'fileIn'!
+
+askForDebug:message
+ "launch a box asking if a debugger is wanted - used when an error
+ occurs while filing in"
+
+ ^ self askForDebug:message canContinueForAll:false
+!
+
+askForDebug:message canContinueForAll:canContinueForAll
+ "launch a box asking if a debugger is wanted - used when an error
+ occurs while filing in"
+
+ |labels values|
+
+ Smalltalk isInitialized ifFalse:[
+ 'PositionableStream [warning]: fileIn error during startup: ' errorPrint. message errorPrintCR.
+ ^ #debug
+ ].
+ "/
+ "/ are we in the startup sequence of an image restart ?
+ "/
+ Processor activeProcessIsSystemProcess ifTrue:[
+ 'PositionableStream [warning]: fileIn error during startup: ' errorPrint. message errorPrintCR.
+ ^ #continue
+ ].
+
+ canContinueForAll ifTrue:[
+ labels := #('Cancel' 'Skip' 'Debug' 'Dont ask again' 'Continue').
+ values := #(#abort #skip #debug #continueForAll #continue).
+ ] ifFalse:[
+ labels := #('Cancel' 'Skip' 'Debug' 'Continue').
+ values := #(#abort #skip #debug #continue).
+ ].
+ AbortAllSignal isHandled ifTrue:[
+ labels := #('Cancel All') , labels.
+ values := #(#cancelAll) , values.
+ ].
+
+ ^ OptionBox
+ request:message
+ label:'Error in fileIn'
+ image:(WarningBox iconBitmap)
+ buttonLabels:labels
+ values:values
+ default:#continue
+ onCancel:#abort.
+
+ "Modified: 10.1.1997 / 18:00:56 / cg"
+!
+
+basicFileInNotifying:someone passChunk:passChunk
+ "central method to file in from the receiver, i.e. read chunks and evaluate them -
+ return the value of the last chunk.
+ Someone (which is usually some codeView) is notified of errors."
+
+ |lastValue pkg spc spaces
+ packageQuerySignal nameSpaceQuerySignal usedNameSpaceQuerySignal
+ changeDefaultApplicationNotificationSignal
+ defaultApplicationQuerySignal defaultApplication
+ confirmationQuerySignal handledSignals passedSignals
+ dontAskSignals askSomeoneForPackage redef outerContext|
+
+ self skipSeparators.
+ lastValue := self peek.
+ lastValue == $< ifTrue:[
+ "/ assume, its an xml file
+ ^ self fileInXMLNotifying:someone passChunk:passChunk.
+ ].
+ lastValue == $# ifTrue:[
+ "assume unix interpreter name:
+ '#!!stx -e' or something like this"
+ self nextPeek == $!! ifTrue:[
+ "skip the unix command line"
+ self nextLine
+ ] ifFalse:[
+ self error:'Invalid chunk start'
+ ]
+ ].
+
+ Smalltalk::Compiler isNil ifTrue:[
+ self isFileStream ifTrue:[
+ Transcript show:('[' , self pathName , '] ').
+ ].
+ Transcript showCR:'cannot fileIn (no compiler).'.
+ ^ nil.
+ ].
+
+ "/ support for V'Age applications
+ defaultApplicationQuerySignal := Class defaultApplicationQuerySignal.
+ changeDefaultApplicationNotificationSignal := Class changeDefaultApplicationNotificationSignal.
+
+ "/ support for ST/X's namespaces & packages
+ packageQuerySignal := Class packageQuerySignal.
+ nameSpaceQuerySignal := Class nameSpaceQuerySignal.
+ usedNameSpaceQuerySignal := Class usedNameSpaceQuerySignal.
+
+ (someone respondsTo:#packageToInstall) ifFalse:[
+ pkg := packageQuerySignal query.
+ askSomeoneForPackage := false.
+ ] ifTrue:[
+ pkg := someone packageToInstall.
+ askSomeoneForPackage := true.
+ ].
+ (someone respondsTo:#currentNameSpace) ifFalse:[
+ spc := nameSpaceQuerySignal query.
+ ] ifTrue:[
+ spc := someone currentNameSpace
+ ].
+ (someone respondsTo:#usedNameSpaces) ifFalse:[
+ spaces := usedNameSpaceQuerySignal query.
+ ] ifTrue:[
+ spaces := someone usedNameSpaces
+ ].
+ (someone respondsTo:#defaultApplication) ifFalse:[
+ defaultApplication := defaultApplicationQuerySignal query.
+ ] ifTrue:[
+ defaultApplication := someone defaultApplication
+ ].
+
+ confirmationQuerySignal := Metaclass confirmationQuerySignal.
+
+ passedSignals := IdentitySet new.
+
+ handledSignals := SignalSet new.
+ handledSignals add:changeDefaultApplicationNotificationSignal.
+ passedSignals add:changeDefaultApplicationNotificationSignal.
+ handledSignals add:defaultApplicationQuerySignal.
+ passedSignals add:defaultApplicationQuerySignal.
+
+ handledSignals add:packageQuerySignal.
+ handledSignals add:usedNameSpaceQuerySignal.
+ handledSignals add:nameSpaceQuerySignal.
+
+ handledSignals add:Error.
+ passedSignals add:Error.
+
+ handledSignals add:(Class methodRedefinitionSignal).
+ passedSignals add:(Class methodRedefinitionSignal).
+ handledSignals add:(Class classRedefinitionSignal).
+ passedSignals add:(Class classRedefinitionSignal).
+ handledSignals add:confirmationQuerySignal.
+ passedSignals add:confirmationQuerySignal.
+
+ outerContext := thisContext.
+
+ handledSignals handle:[:ex |
+ |sig action what sender msg param oldPackage newPackage proceedValue
+ canContinueForAll|
+
+ sig := ex signal.
+"/sig == packageQuerySignal ifTrue:[
+"/self halt.
+"/].
+ (passedSignals includes:sig) ifTrue:[
+ (sig isHandledIn:outerContext) ifTrue:[
+ ex reject
+ ]
+ ].
+
+ sig == changeDefaultApplicationNotificationSignal ifTrue:[
+ "/ invoked via #becomeDefault to set the defaultApp and the package.
+ "/ (only when filing in V'Age code)
+ defaultApplication := ex parameter.
+ pkg := defaultApplication name asSymbol.
+ ex proceedWith:nil
+ ].
+ sig == defaultApplicationQuerySignal ifTrue:[
+ "/ query for the application to add classes & methods into
+ "/ (only when filing in V'Age code)
+ ex proceedWith:defaultApplication
+ ].
+ sig == packageQuerySignal ifTrue:[
+ "/ query for the package to use for classes & methods
+ askSomeoneForPackage ifTrue:[
+ ex proceedWith:someone packageToInstall
+ ] ifFalse:[
+ ex proceedWith:pkg
+ ]
+ ].
+ sig == usedNameSpaceQuerySignal ifTrue:[
+ "/ query for the namespaces searched when encountering globals
+ ex proceedWith:spaces
+ ].
+ sig == nameSpaceQuerySignal ifTrue:[
+ "/ query for the namespace to install new classes in
+ ex proceedWith:spc
+ ].
+ sig == confirmationQuerySignal ifTrue:[
+ ex proceedWith:false "/ no dialogs popping up
+ ].
+
+ sig == Stream endOfStreamSignal ifTrue:[
+ ex reject
+ ].
+
+ sig == Signal noHandlerSignal ifTrue:[
+ ex parameter rejected ifTrue:[
+ ex reject
+ ].
+ ].
+
+ (dontAskSignals notNil and:[dontAskSignals includesKey:sig]) ifTrue:[
+ ex proceedWith:(dontAskSignals at:sig)
+ ].
+
+ canContinueForAll := false.
+ redef := false.
+
+ "/ for your convenience ...
+ (sig == Class methodRedefinitionSignal) ifTrue:[
+ param := ex parameter. "/ an association: oldMethod -> newMethod
+ oldPackage := param key package.
+ newPackage := param value package.
+ msg := 'trying to overwrite method:\\ ' , param key whoString , '\\in package '''
+ , oldPackage , ''' with method from package ''' , newPackage , ''''.
+ canContinueForAll := true.
+ ] ifFalse:[
+ (sig == Class classRedefinitionSignal) ifTrue:[
+ param := ex parameter. "/ an association: oldClass -> newClass
+
+ oldPackage := param key package.
+ newPackage := param value package.
+ msg := 'trying to redefine class: ' , param key name allBold , '\\in package '''
+ , oldPackage , ''' with new definition from package ''' , newPackage , ''''.
+ canContinueForAll := true.
+ redef := true.
+ ] ifFalse:[
+ msg := 'error in fileIn: %1'
+ ]
+ ].
+
+ what := ex description.
+ what isNil ifTrue:[
+ what := ex signal notifierString.
+ ].
+
+ msg := msg bindWith:what.
+
+ "/ handle the case where no GUI has been built in,
+ "/ just abort the fileIn with a notification
+
+ Display isNil ifTrue:[
+ sender := ex suspendedContext sender.
+ msg := msg , ('\\in ' , sender receiver class name , '>>>' , sender selector) withCRs.
+ self notify:msg.
+ ex return
+ ].
+
+ sig == HaltInterrupt ifTrue:[
+ sender := ex suspendedContext.
+ msg := msg , ('\\in ' , sender receiver class name , '>>>' , sender selector) withCRs
+ ].
+
+ "/ otherwise ask what should be done now and either
+ "/ continue or abort the fileIn
+
+ redef ifTrue:[
+ action := OptionBox
+ request:(msg withCRs)
+ label:'Class redefinition in fileIn'
+ image:(WarningBox iconBitmap)
+"/ cg: now always keep the old packageID
+"/ buttonLabels:#('cancel' 'skip' 'debug' 'keep' 'keep all' 'continue' 'continue all')
+"/ values:#(#abort #skip #debug #keep #keepAll #continue #continueForAll)
+ buttonLabels:#('Cancel' 'Skip' 'Debug' 'Continue' 'Continue All')
+ values:#(#abort #skip #debug #keep #keepAll)
+ default:#keep
+ onCancel:#abort.
+ ] ifFalse:[
+ action := self askForDebug:msg withCRs canContinueForAll:canContinueForAll.
+ ].
+ action == #continueForAll ifTrue:[
+ dontAskSignals isNil ifTrue:[
+ dontAskSignals := IdentityDictionary new.
+ ].
+ dontAskSignals at:sig put:#continue.
+ action := proceedValue := #continue.
+ ] ifFalse:[
+ action == #keepForAll ifTrue:[
+ dontAskSignals isNil ifTrue:[
+ dontAskSignals := IdentityDictionary new.
+ ].
+ dontAskSignals at:sig put:#keep.
+ action := #continue.
+ proceedValue := #keep.
+ ] ifFalse:[
+ action == #keep ifTrue:[
+ action := #continue.
+ proceedValue := #keep.
+ ].
+ ].
+ ].
+
+ action == #continue ifTrue:[
+ ex proceedWith:proceedValue
+ ].
+ action == #abort ifTrue:[
+ AbortSignal raise.
+ ex return
+ ].
+ action == #cancelAll ifTrue:[
+ AbortAllSignal raise.
+ ex return
+ ].
+ action == #skip ifTrue:[
+ ex proceedWith:nil
+ ].
+ action == #debug ifTrue:[
+ Debugger enter:ex suspendedContext
+ withMessage:ex description
+ mayProceed:true.
+ ex proceedWith:proceedValue
+ ].
+
+ "/ (ex signal) enterDebuggerWith:ex message:what.
+ ex reject
+ ] do:[
+ [self atEnd] whileFalse:[
+ lastValue := self fileInNextChunkNotifying:someone passChunk:passChunk
+ ]
+ ].
+ ^ lastValue
+
+ "Modified: / 10.9.1999 / 16:54:01 / stefan"
+ "Modified: / 16.11.2001 / 16:21:28 / cg"
+!
+
+fileIn
+ "file in from the receiver, i.e. read chunks and evaluate them -
+ return the value of the last chunk."
+
+ |notifiedLoader|
+
+ SourceFileLoader notNil ifTrue:[
+ notifiedLoader := SourceFileLoader on:self.
+ ].
+
+ ^ self fileInNotifying:notifiedLoader passChunk:true.
+!
+
+fileInBinary
+ "file in from the receiver, i.e. read binary stored classes and/or objects.
+ Return the last object."
+
+ |bos obj|
+
+ bos := BinaryObjectStorage onOld:self.
+ Class nameSpaceQuerySignal
+ answer:Smalltalk
+ do:[
+ [self atEnd] whileFalse:[
+ obj := bos next.
+ ]
+ ].
+ bos close.
+ ^ obj
+
+ "Created: / 13.11.2001 / 10:12:30 / cg"
+ "Modified: / 13.11.2001 / 10:14:04 / cg"
+!
+
+fileInNextChunkNotifying:someone
+ "read next chunk, evaluate it and return the result;
+ someone (which is usually some codeView) is notified of errors.
+ Filein is done as follows:
+ read a chunk
+ if it started with an excla, evaluate it, and let the resulting object
+ fileIn more chunks.
+ This is a nice trick, since the methodsFor: expression evaluates to
+ a ClassCategoryReader which reads and compiles chunks for its class.
+ However, other than methodsFor expressions are possible - you can
+ (in theory) create readers for any syntax.
+ "
+
+ ^ self fileInNextChunkNotifying:someone passChunk:false
+!
+
+fileInNextChunkNotifying:someone passChunk:passChunk
+ "read next chunk, evaluate it and return the result;
+ someone (which is usually some codeView) is notified of errors.
+ Filein is done as follows:
+ read a chunk
+ if it started with an excla, evaluate it, and let the resulting object
+ fileIn more chunks.
+ This is a nice trick, since the methodsFor: expression evaluates to
+ a ClassCategoryReader which reads and compiles chunks for its class.
+ However, other than methodsFor expressions are possible - you can
+ (in theory) create readers for any syntax.
+ "
+
+ ^ self fileInNextChunkNotifying:someone passChunk:passChunk silent:nil
+!
+
+fileInNextChunkNotifying:someone passChunk:passChunk silent:beSilent
+ "read next chunk, evaluate it and return the result;
+ someone (which is usually some codeView) is notified of errors.
+ Filein is done as follows:
+ read a chunk
+ if it started with an excla, evaluate it, and let the resulting object
+ fileIn more chunks.
+ This is a nice trick, since the methodsFor: expression evaluates to
+ a ClassCategoryReader which reads and compiles chunks for its class.
+ However, other than methodsFor expressions are possible - you can
+ (in theory) create readers for any syntax.
+ "
+
+ |aString sawExcla rslt done|
+
+ self skipSeparators.
+ self atEnd ifFalse:[
+ sawExcla := self peekFor:(self class chunkSeparator).
+ aString := self nextChunk.
+ "/
+ "/ handle empty chunks;
+ "/ this allows for Squeak code to be filedIn
+ "/
+ [aString size == 0
+ and:[self atEnd not]] whileTrue:[
+ aString := self nextChunk.
+ ].
+ aString size ~~ 0 ifTrue:[
+ passChunk ifTrue:[
+ someone notNil ifTrue:[someone source:aString]
+ ].
+ sawExcla ifFalse:[
+ rslt := Smalltalk::Compiler evaluate:aString notifying:someone.
+ ] ifTrue:[
+ Smalltalk::Compiler emptySourceNotificationSignal handle:[:ex |
+ ^ nil
+ ] do:[
+ rslt := Smalltalk::Compiler evaluate:aString notifying:someone compile:false.
+ ].
+
+ "
+ usually, the above chunk consists of some methodsFor:-expression
+ in this case, the returned value is a ClassCategoryReader,
+ which is used to load & compile the methods ...
+ "
+ rslt isNil ifTrue:[
+ "
+ however, if that was nil (i.e. some error), we skip chunks
+ up to the next empty chunk.
+ "
+ Transcript showCR:'skipping chunks ...'.
+ done := false.
+ [done] whileFalse:[
+ aString := self nextChunk.
+ done := (aString size == 0).
+ ]
+ ] ifFalse:[
+ rslt := rslt
+ fileInFrom:self
+ notifying:someone
+ passChunk:passChunk
+ single:false
+ silent:beSilent
+ ]
+ ]
+ ]
+ ].
+ ^ rslt
+
+ "Modified: 14.10.1997 / 17:10:35 / cg"
+!
+
+fileInNotifying:notifiedLoader passChunk:passChunk
+ "central method to file in from the receiver, i.e. read chunks and evaluate them -
+ return the value of the last chunk.
+ Someone (which is usually some codeView) is notified of errors."
+
+ self isFileStream ifFalse:[
+ ^ self basicFileInNotifying:notifiedLoader passChunk:passChunk.
+ ].
+
+ ^ self fileInNotifying:notifiedLoader passChunk:passChunk inDirectory:(self pathName asFilename directory).
+!
+
+fileInNotifying:notifiedLoader passChunk:passChunk inDirectory:aDirectory
+ "central method to file in from the receiver, i.e. read chunks and evaluate them -
+ return the value of the last chunk.
+ Someone (which is usually some codeView) is notified of errors."
+
+ |oldPath val thisDirectory thisDirectoryPathName|
+
+ thisDirectory := aDirectory asFilename.
+ thisDirectoryPathName := thisDirectory pathName.
+ oldPath := Smalltalk systemPath.
+
+ [
+ Smalltalk systemPath:(oldPath copy addFirst:thisDirectoryPathName; yourself).
+ CurrentFileInDirectoryQuerySignal answer:thisDirectory do:[
+ val := self basicFileInNotifying:notifiedLoader passChunk:passChunk.
+ ]
+ ] ensure:[
+ "take care, someone could have changed SystemPath during fileIn!!"
+ (Smalltalk systemPath copyFrom:2) = oldPath ifTrue:[
+ Smalltalk systemPath:oldPath.
+ ] ifFalse:[
+ (oldPath includes:thisDirectoryPathName) ifFalse:[
+ Smalltalk systemPath remove:thisDirectoryPathName ifAbsent:[].
+ Smalltalk flushPathCaches.
+ ].
+ ].
+ ].
+ ^ val
+!
+
+fileInXMLNotifying:someone passChunk:passChunk
+ "filein an XML source file (format as in campSmalltalk DTD)"
+
+ | builder parser|
+
+ (XML isNil or:[XML::SourceNodeBuilder isNil or:[XML::XMLParser isNil]]) ifTrue:[
+ Smalltalk loadPackage:'stx:goodies/xml/vw'.
+ (XML isNil or:[XML::SourceNodeBuilder isNil or:[XML::XMLParser isNil]]) ifTrue:[
+ self error:'Could not load XML package(s) from ''stx:goodies/xml/vw'''.
+ ]
+ ].
+
+ builder := XML::SourceNodeBuilder new.
+ parser := XML::XMLParser on:self.
+ parser builder:builder.
+ parser validate:false.
+ parser scanDocument.
+ "/ self halt.
+! !
+
!PeekableStream methodsFor:'positioning'!
skipAny:skipCollection
@@ -373,5 +942,7 @@
!PeekableStream class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libbasic/PeekableStream.st,v 1.23 2004-03-15 10:14:27 ca Exp $'
+ ^ '$Header: /cvs/stx/stx/libbasic/PeekableStream.st,v 1.24 2004-07-13 08:38:59 cg Exp $'
! !
+
+PeekableStream initialize!