'From Squeak3.1alpha of 28 February 2001 [latest update: #4061] on 23 May 2001 at 2:44:06 pm'! "Change Set: notify-sw Date: 23 May 2001 Author: Scott Wallace Transforms numerous senders of #notify: into senders of #inform:. Adds #notifyWithLabel: for cases where a notifier really is wanted but where an explicit message should be shown in the label, rather than the vanilla word 'Notifier', and transforms some of the old #notify: senders such that they now call that. Most residual #notify: senders are now off in ClassBuilder and Encoder-related code, where this appears to remain the appropriate thing to do."! !Object methodsFor: 'error handling' stamp: 'sw 5/23/2001 13:43'! notifyWithLabel: aString "Create and schedule a Notifier with aString as the window label as well as the contents of the window, in order to request confirmation before a process can proceed." Debugger openContext: thisContext label: aString contents: aString "nil notifyWithLabel: 'let us see if this works'"! ! !Behavior methodsFor: 'accessing instances and variables' stamp: 'sw 5/21/2001 22:51'! inspectAllInstances "Inpsect all instances of the receiver. 1/26/96 sw" | all allSize prefix | all _ self allInstances. (allSize _ all size) == 0 ifTrue: [^ self inform: 'There are no instances of ', self name]. prefix _ allSize == 1 ifTrue: ['The lone instance'] ifFalse: ['The ', allSize printString, ' instances']. all asArray inspectWithLabel: (prefix, ' of ', self name)! ! !Behavior methodsFor: 'accessing instances and variables' stamp: 'sw 5/21/2001 22:51'! inspectSubInstances "Inspect all instances of the receiver and all its subclasses. CAUTION - don't do this for something as generic as Object!! 1/26/96 sw" | all allSize prefix | all _ self allSubInstances. (allSize _ all size) == 0 ifTrue: [^ self inform: 'There are no instances of ', self name, ' or any of its subclasses']. prefix _ allSize == 1 ifTrue: ['The lone instance'] ifFalse: ['The ', allSize printString, ' instances']. all asArray inspectWithLabel: (prefix, ' of ', self name, ' & its subclasses')! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 5/23/2001 13:29'! fileOutOn: stream "Write out all the changes the receiver knows about" | classList | (self isEmpty and: [stream isKindOf: FileStream]) ifTrue: [self inform: 'Warning: no changes to file out']. classList _ ChangeSet superclassOrder: self changedClasses asOrderedCollection. "First put out rename, max classDef and comment changes." classList do: [:aClass | self fileOutClassDefinition: aClass on: stream]. "Then put out all the method changes" classList do: [:aClass | self fileOutChangesFor: aClass on: stream]. "Finally put out removals, final class defs and reorganization if any" classList reverseDo: [:aClass | self fileOutPSFor: aClass on: stream]. self classRemoves asSortedCollection do: [:aClassName | stream nextChunkPut: 'Smalltalk removeClassNamed: #', aClassName; cr].! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 5/23/2001 13:29'! mailOut "File out the receiver, to a file whose name is a function of the change-set name and either of the date & time or chosen to have a unique numeric tag, depending on the preference 'sequentialChangeSetRevertableFileNames'." | subjectPrefix slips message compressBuffer compressStream data compressedStream compressTarget | (Smalltalk includesKey: #Celeste) ifFalse: [^ self inform: 'no mail reader present']. subjectPrefix _ self chooseSubjectPrefixForEmail. self checkForConversionMethods. Cursor write showWhile: [ "prepare the message" message := MailMessage empty. message setField: 'from' toString: Celeste userName. message setField: 'to' toString: 'squeak@cs.uiuc.edu'. message setField: 'subject' toString: (subjectPrefix, name). message body: (MIMEDocument contentType: 'text/plain' content: (String streamContents: [ :str | str nextPutAll: 'from preamble:'; cr; cr. self fileOutPreambleOn: str ])). "Prepare the gzipped data" data _ data _ WriteStream on: String new. data header. self fileOutPreambleOn: data. self fileOutOn: data. self fileOutPostscriptOn: data. data trailer. data _ ReadStream on: data contents. compressBuffer _ ByteArray new: 1000. compressStream _ GZipWriteStream on: (compressTarget _ WriteStream on: (ByteArray new: 1000)). [data atEnd] whileFalse: [compressStream nextPutAll: (data nextInto: compressBuffer)]. compressStream close. compressedStream _ ReadStream on: compressTarget contents asString. message addAttachmentFrom: compressedStream withName: (name, '.cs.gz'). CelesteComposition openForCeleste: Celeste current initialText: message text. ]. Preferences suppressCheckForSlips ifTrue: [^ self]. slips _ self checkForSlips. (slips size > 0 and: [self confirm: 'Methods in this fileOut have halts or references to the Transcript or other ''slips'' in them. Would you like to browse them?']) ifTrue: [Smalltalk browseMessageList: slips name: 'Possible slips in ' , name]! ! !Class methodsFor: 'class name' stamp: 'sw 5/23/2001 13:32'! rename: aString "The new name of the receiver is the argument, aString." | newName | (newName _ aString asSymbol) ~= self name ifTrue: [(Smalltalk includesKey: newName) ifTrue: [^self error: newName , ' already exists']. (Undeclared includesKey: newName) ifTrue: [self inform: 'There are references to, ' , aString printString , ' from Undeclared. Check them after this change.']. Smalltalk renameClass: self as: newName. name _ newName]! ! !CodeHolder methodsFor: 'message list' stamp: 'sw 5/23/2001 13:37'! validateMessageSource: sourceString forSelector: aSelector "Check whether there is evidence that method source is invalid" | sourcesName | (self selectedClass compilerClass == Object compilerClass and: [(sourceString asString findString: aSelector keywords first ) ~= 1]) ifTrue: [sourcesName _ FileDirectory localNameFor: Smalltalk sourcesName. self inform: 'There may be a problem with your sources file!! The source code for every method should start with the method selector but this is not the case!! You may proceed with caution but it is recommended that you get a new source file. This can happen if you download the "' , sourcesName , '" file, or the ".changes" file you use, as TEXT. It must be transfered in BINARY mode, even if it looks like a text file, to preserve the CR line ends. Mac users: This may have been caused by Stuffit Expander. To prevent the files above to be converted to Mac line ends when they are expanded, do this: Start the program, then from Preferences... in the File menu, choose the Cross Platform panel, then select "Never" and press OK. Then expand the compressed archive again.'].! ! !Browser methodsFor: 'accessing' stamp: 'sw 5/23/2001 12:37'! contents: input notifying: aController "The retrieved information has changed and its source must now be updated. The information can be a variety of things, depending on the list selections (such as templates for class or message definition, methods) or the user menu commands (such as definition, comment, hierarchy). Answer the result of updating the source." | aString aText theClass | self changed: #annotation. aString _ input asString. aText _ input asText. editSelection == #editSystemCategories ifTrue: [^ self changeSystemCategories: aString]. editSelection == #editClass | (editSelection == #newClass) ifTrue: [^ self defineClass: aString notifying: aController]. editSelection == #editComment ifTrue: [theClass _ self selectedClass. theClass ifNil: [self inform: 'You must select a class before giving it a comment.'. ^ false]. theClass comment: aText stamp: Utilities changeStamp. ^ true]. editSelection == #hierarchy ifTrue: [^ true]. editSelection == #editMessageCategories ifTrue: [^ self changeMessageCategories: aString]. editSelection == #editMessage | (editSelection == #newMessage) ifTrue: [^ self okayToAccept ifFalse: [false] ifTrue: [self compileMessage: aText notifying: aController]]. editSelection == #none ifTrue: [self inform: 'This text cannot be accepted in this part of the browser.'. ^ false]. self error: 'unacceptable accept'! ! !ChangeSorter class methodsFor: 'services' stamp: 'sw 5/23/2001 13:30'! browseChangeSetsWithClass: class selector: selector "Put up a menu comprising a list of change sets that hold changes for the given class and selector. If the user selects one, open a single change-sorter onto it" | hits index | hits _ self allChangeSets select: [:cs | (cs atSelector: selector class: class) ~~ #none]. hits isEmpty ifTrue: [^ self inform: class name, '.', selector , ' is not in any change set']. index _ hits size == 1 ifTrue: [1] ifFalse: [(PopUpMenu labelArray: (hits collect: [:cs | cs name]) lines: #()) startUp]. index = 0 ifTrue: [^ self]. (ChangeSorter new myChangeSet: (hits at: index)) open. ! ! !ChangeSorter class methodsFor: 'services' stamp: 'sw 5/23/2001 13:31'! browseChangeSetsWithSelector: aSelector "Put up a list of all change sets that contain an addition, deletion, or change of any method with the given selector" | hits index | hits _ self allChangeSets select: [:cs | cs hasAnyChangeForSelector: aSelector]. hits isEmpty ifTrue: [^ self inform: aSelector , ' is not in any change set']. index _ hits size == 1 ifTrue: [1] ifFalse: [(PopUpMenu labelArray: (hits collect: [:cs | cs name]) lines: #()) startUp]. index = 0 ifTrue: [^ self]. (ChangeSetBrowser new myChangeSet: (hits at: index)) open "ChangeSorter browseChangeSetsWithSelector: #clearPenTrails" ! ! !Debugger methodsFor: 'accessing' stamp: 'sw 5/23/2001 13:37'! contents: aText notifying: aController "The retrieved information has changed and its source must now be updated. In this case, the retrieved information is the method of the selected context." | selector classOfMethod category method priorMethod parseNode | contextStackIndex = 0 ifTrue: [^ false]. (self selectedContext isKindOf: MethodContext) ifFalse: [(self confirm: 'I will have to revert to the method from which this block originated. Is that OK?') ifTrue: [self resetContext: self selectedContext home] ifFalse: [^ false]]. classOfMethod _ self selectedClass. category _ self selectedMessageCategoryName. Cursor execute showWhile: [method _ classOfMethod compile: aText notifying: aController trailer: #(0 0 0 0) ifFail: [^ false] elseSetSelectorAndNode: [:sel :methodNode | selector _ sel. selector == self selectedMessageName ifFalse: [self inform: 'can''t change selector'. ^ false]. priorMethod _ (classOfMethod includesSelector: selector) ifTrue: [classOfMethod compiledMethodAt: selector] ifFalse: [nil]. sourceMap _ methodNode sourceMap. tempNames _ methodNode tempNames. parseNode _ methodNode]. method cacheTempNames: tempNames]. category isNil ifFalse: "Skip this for DoIts" [method putSource: aText fromParseNode: parseNode class: classOfMethod category: category inFile: 2 priorMethod: priorMethod. classOfMethod organization classify: selector under: category]. contents _ aText copy. self selectedContext restartWith: method. contextVariablesInspector object: nil. self resetContext: self selectedContext. ^true! ! !Debugger methodsFor: 'context stack menu' stamp: 'sw 5/23/2001 13:38'! mailOutBugReport "Compose a useful bug report showing the state of the process as well as vital image statistics as suggested by Chris Norton - 'Squeak could pre-fill the bug form with lots of vital, but oft-repeated, information like what is the image version, last update number, VM version, platform, available RAM, author...' and address it to the list with the appropriate subject prefix." | subjectPrefix messageStrm | (Smalltalk includesKey: #Celeste) ifFalse: [^ self inform: 'no mail reader present']. subjectPrefix _ '[BUG]'. Cursor write showWhile: ["Prepare the message" messageStrm _ WriteStream on: (String new: 30). messageStrm nextPutAll: 'From: '; nextPutAll: Celeste userName; cr; nextPutAll: 'To: squeak@cs.uiuc.edu'; cr; nextPutAll: 'Subject: '; nextPutAll: subjectPrefix; nextPutAll: self interruptedContext printString; cr;cr; nextPutAll: 'here insert explanation of what you were doing, suspect changes youd made and so forth.';cr;cr; nextPutAll: 'Image version: '; nextPutAll: Smalltalk systemInformationString ; cr;cr; nextPutAll: 'VM version: '; nextPutAll: Smalltalk vmVersion asString, String cr, 'for: ', Smalltalk platformName asString; cr;cr; nextPutAll: 'Receiver: '; nextPutAll: receiverInspector object printString; cr;cr; nextPutAll: 'Instance variables: ';cr; nextPutAll: receiverInspector object longPrintString; cr; nextPutAll: 'Method (temp) variables: ';cr; nextPutAll: contextVariablesInspector object tempsAndValues; cr; nextPutAll: 'Stack: '; cr. self contextStackList do: [:e | messageStrm nextPutAll: e; cr]. CelesteComposition openForCeleste: Celeste current initialText: messageStrm contents]. ! ! !EnvelopeEditorMorph methodsFor: 'menu' stamp: 'sw 5/23/2001 14:26'! saveLibToDisk: evt "Save the library to disk" | newName f snd | newName _ FillInTheBlank request: 'Please confirm name for library...' initialAnswer: 'MySounds'. newName isEmpty ifTrue: [^ self]. f _ FileStream newFileNamed: newName , '.fml'. AbstractSound soundNames do: [:name | snd _ AbstractSound soundNamed: name. "snd isStorable" true ifTrue: [f nextChunkPut: 'AbstractSound soundNamed: ' , name , ' put: ' , snd storeString; cr; cr] ifFalse: [self inform: name , ' is not currently storable']]. f close! ! !EventRecorderMorph methodsFor: 'commands' stamp: 'sw 5/23/2001 14:28'! shrink "Shorten the tape by deleting mouseMove events that can just as well be interpolated later at playback time." | oldSize priorSize | self writeCheck. oldSize _ priorSize _ tape size. [self condense. tape size < priorSize] whileTrue: [priorSize _ tape size]. self inform: oldSize printString , ' events reduced to ' , tape size printString. voiceRecorder ifNotNil: [voiceRecorder suppressSilence]. saved _ false. ! ! !FileContentsBrowser methodsFor: 'accessing' stamp: 'sw 5/23/2001 14:28'! contents: input notifying: aController "The retrieved information has changed and its source must now be updated. The information can be a variety of things, depending on the list selections (such as templates for class or message definition, methods) or the user menu commands (such as definition, comment, hierarchy). Answer the result of updating the source." | aString aText theClass | aString _ input asString. aText _ input asText. editSelection == #editComment ifTrue: [theClass _ self selectedClass. theClass ifNil: [self inform: 'You must select a class before giving it a comment.'. ^ false]. theClass comment: aText. ^ true]. editSelection == #editMessageCategories ifTrue: [^ self changeMessageCategories: aString]. self inform:'You cannot change the current selection'. ^false ! ! !FileDirectory class methodsFor: 'system start up' stamp: 'sw 5/23/2001 14:29'! openSources: sourcesName andChanges: changesName forImage: imageName "Initialize the default directory to the image directory and open the sources and changes files, if possible. Look for the changes file in image directory. Look for the system sources (or an alias to it) first in the VM directory, then in the image directory. Open the changes and sources files and install them in SourceFiles." "Note: SourcesName and imageName are full paths; changesName is a local name." | sources changes msg wmsg | msg _ 'Squeak cannot locate &fileRef. Please check that the file is named properly and is in the same directory as this image. Further explanation can found in the startup window, ''How Squeak Finds Source Code''.'. wmsg _ 'Squeak cannot write to &fileRef. Please check that you have write permission for this file. You won''t be able to save this image correctly until you fix this.'. sources _ self openSources: sourcesName forImage: imageName. changes _ self openChanges: changesName forImage: imageName. ((sources == nil or: [sources atEnd]) and: [Preferences valueOfFlag: #warnIfNoSourcesFile]) ifTrue: [self inform: (msg copyReplaceAll: '&fileRef' with: 'the sources file named ' , sourcesName). Smalltalk platformName = 'Mac OS' ifTrue: [self inform: 'Make sure the sources file is not an Alias.']]. (changes == nil and: [Preferences valueOfFlag: #warnIfNoChangesFile]) ifTrue: [self inform: (msg copyReplaceAll: '&fileRef' with: 'the changes file named ' , changesName)]. ((Preferences valueOfFlag: #warnIfNoChangesFile) and:[changes notNil]) ifTrue: [changes isReadOnly ifTrue: [self inform: (wmsg copyReplaceAll: '&fileRef' with: 'the changes file named ' , changesName)]. ((changes next: 200) includesSubString: String crlf) ifTrue: [self inform: 'The changes file named ' , changesName, ' has been injured by an unpacking utility. Crs were changed to CrLfs. Please set the preferences in your decompressing program to "do not convert text files" and unpack the system again.']]. SourceFiles _ Array with: sources with: changes! ! !FileList methodsFor: 'file list menu' stamp: 'sw 5/23/2001 13:44'! renderFile "Render the currently selected file" | map action file renderedFile formatPage | listIndex = 0 ifTrue: [^ self]. map _ URLmap new. action _ RenderedSwikiAction new. action name: '.'. "For image references, refer to this directory" map action: action. map directory: directory. (directory fileExists: 'glossary') ifFalse: [Cursor wait showWhile: [ (directory newFileNamed: 'glossary') close].]. map readGlossary: (directory oldFileNamed: 'glossary'). formatPage _ SwikiPage new. formatPage map: map. formatPage coreID: (fileName allButFirst). formatPage formatted: (HTMLformatter evalEmbedded: (directory oldFileNamed: fileName) contentsOfEntireFile with: formatPage unlessContains: (Set new)). formatPage name isNil ifTrue: [self notifyWithLabel: 'You forgot to name the page!! '. formatPage name: 'defaultName'.]. map pages at: (formatPage name asLowercase) put: formatPage. formatPage formatted: (LessHTMLformatter swikify: (formatPage formatted) linkhandler: [:link | map linkFor: link from: 'Nowhere' storingTo: OrderedCollection new]). "Make a template if one does not exist" (directory fileExists: 'template.html') ifFalse: [Cursor wait showWhile: [ (directory newFileNamed: 'template.html') nextPutAll: (self templateFile); close].]. renderedFile _ (directory pathName),(ServerAction pathSeparator),(formatPage coreID). (directory fileExists: renderedFile) ifTrue: [directory deleteFileNamed: renderedFile]. file _ FileStream fileNamed: renderedFile. file nextPutAll: (HTMLformatter evalEmbedded: (directory oldFileNamed: 'template.html') contentsOfEntireFile with: formatPage). file close. FileDirectory default setMacFileNamed: renderedFile type: 'TEXT' creator: 'MOSS'. map writeGlossary. "Directory is already in the map, so write to the glossary there" self updateFileList. ! ! !FileList methodsFor: 'private' stamp: 'sw 5/23/2001 14:31'! put: aText "Private - put the supplied text onto the file" | ff type | brevityState == #fullFile ifTrue: [ff _ directory newFileNamed: self fullName. Cursor write showWhile: [ff nextPutAll: aText asString; close]. fileName = ff localName ifTrue: [contents _ aText asString] ifFalse: [self updateFileList]. "user renamed the file" ^ true "accepted"]. listIndex = 0 ifTrue: [self inform: 'No fileName is selected'. ^ false "failed"]. type _ 'These'. brevityState = #briefFile ifTrue: [type _ 'Abbreviated']. brevityState = #briefHex ifTrue: [type _ 'Abbreviated']. brevityState = #fullHex ifTrue: [type _ 'Hexadecimal']. brevityState = #FileList ifTrue: [type _ 'Directory']. self inform: type , ' contents cannot meaningfully be saved at present.'. ^ false "failed" ! ! !HTTPSocket class methodsFor: 'get the page' stamp: 'sw 5/23/2001 13:44'! httpFileIn: url "Do a regular file-in of a file that is served from a web site. If the file contains an EToy, then open it. Might just be code instead. tk 7/23/97 17:10" "Notes: To store a file on an HTTP server, use the program 'Fetch'. After indicating what file to store, choose 'Raw Data' from the popup menu that has MacBinary/Text/etc. Use any file extension as long as it is not one of the common ones. The server does not have to know about the .sqo extension in order to send your file. (We do not need a new MIME type and .sqo does not have to be registered with the server.)" " HTTPSocket httpFileIn: 'www.webPage.com/~kaehler2/sample.etoy' " " HTTPSocket httpFileIn: '206.18.68.12/squeak/car.sqo' " " HTTPSocket httpFileIn: 'jumbo/tedk/sample.etoy' " | doc eToyHolder | doc _ self httpGet: url accept: 'application/octet-stream'. doc class == String ifTrue: [self inform: 'Cannot seem to contact the web site']. doc reset. eToyHolder _ doc fileInObjectAndCode. eToyHolder ifNotNil: [eToyHolder open]. "Later may want to return it, instead of open it" ! ! !HTTPSocket class methodsFor: 'get the page' stamp: 'sw 5/23/2001 13:44'! httpFileInNewChangeSet: url "Do a regular file-in of a file that is served from a web site. Put it into a new changeSet." "Notes: To store a file on an HTTP server, use the program 'Fetch'. After indicating what file to store, choose 'Raw Data' from the popup menu that has MacBinary/Text/etc. Use any file extension as long as it is not one of the common ones." " HTTPSocket httpFileInNewChangeSet: '206.18.68.12/squeak/updates/83tk_test.cs' " | doc | doc _ self httpGet: url accept: 'application/octet-stream'. doc class == String ifTrue: [self inform: 'Cannot seem to contact the web site']. doc reset. ChangeSorter newChangesFromStream: doc named: (url findTokens: '/') last.! ! !IRCConnection methodsFor: 'network IO' stamp: 'sw 5/23/2001 13:45'! connect "connect to a server" | addr | Socket initializeNetwork. socket ifNotNil: [ socket destroy ]. self reset. Utilities informUser: 'looking up server address...' during: [addr _ NetNameResolver addressForName: server ]. addr ifNil: [^ self inform: 'could not find address for ', server]. socket _ Socket new. socket connectTo: addr port: port. self sendMessage: (IRCProtocolMessage fromString: 'NICK ', nick). self sendMessage: (IRCProtocolMessage fromString: 'USER ', userName, ' * * :', fullName).! ! !InputSensor methodsFor: 'modifier keys' stamp: 'sw 5/23/2001 13:46'! macOptionKeyPressed "Answer whether the option key on the Macintosh keyboard is being held down. Macintosh specific." Preferences macOptionKeyAllowed ifFalse: [self notifyWithLabel: 'Portability note: InputSensor>>macOptionKeyPressed is not portable. Please use InputSensor>>yellowButtonPressed instead!!']. ^ self primMouseButtons anyMask: 32! ! !Interpreter class methodsFor: 'translation' stamp: 'sw 5/23/2001 14:33'! patchInterp: fileName "Interpreter patchInterp: 'Squeak VM PPC'" "This will patch out the unneccesary range check (a compare and branch) in the inner interpreter dispatch loop." "NOTE: You must edit in the Interpeter file name, and the number of instructions (delta) to count back to find the compare and branch that we want to get rid of." | delta f code len remnant i | delta _ 6. f _ FileStream fileNamed: fileName. f binary. code _ Bitmap new: (len _ f size) // 4. f nextInto: code. remnant _ f next: len - (code size * 4). i _ 0. ["Look for a BCTR instruction" (i _ code indexOf: 16r4E800420 startingAt: i + 1 ifAbsent: [0]) > 0] whileTrue: ["Look for a CMPLWI FF, 6 instrs back" ((code at: i - delta) bitAnd: 16rFFE0FFFF) = 16r280000FF ifTrue: ["Copy dispatch instrs back over the compare" self inform: 'Patching at ', i hex. 0 to: delta - 2 do: [ :j | code at: (i - delta) + j put: (code at: (i - delta) + j + 2)]]]. f position: 0; nextPutAll: code; nextPutAll: remnant. f close. ! ! !Interpreter class methodsFor: 'translation' stamp: 'sw 5/23/2001 14:34'! patchInterpGCCPPC: fileName "Interpreter patchInterpGCCPPC: 'Squeak copy 1'" "This will patch out the unneccesary range check (a compare and branch) in the inner interpreter dispatch loop. for the PPC version of the GCC compiled version of Squeak under MPW" "NOTE: You must edit in the Interpeter file name" | delta f code len remnant i | delta _ 7. f _ FileStream fileNamed: fileName. f binary. code _ Bitmap new: (len _ f size) // 4. f nextInto: code. remnant _ f next: len - (code size * 4). i _ 0. ["Look for a BCTR instruction" (i _ code indexOf: 16r4E800420 startingAt: i + 1 ifAbsent: [0]) > 0] whileTrue: ["Look for a CMPLWI cr1,rxx,FF, 7 instrs back" ((code at: i - delta) bitAnd: 16rFFE0FFFF) = 16r288000FF ifTrue: ["Copy dispatch instrs back over the compare" self inform: 'Patching at ', i hex. 0 to: delta - 2 do: [ :j | code at: (i - delta) + j put: (code at: (i - delta) + j + 2)]]]. f position: 0; nextPutAll: code; nextPutAll: remnant. f close! ! !InterpreterProxy class methodsFor: 'private' stamp: 'sw 5/23/2001 13:47'! validateProxyImplementation: anInterpreter "InterpreterProxy validateProxyImplementation: Interpreter" "InterpreterProxy validateProxyImplementation: DynamicInterpreter" | proxyClass catList | proxyClass _ InterpreterProxy. catList _ proxyClass organization categories copy asOrderedCollection. catList remove: 'initialize' ifAbsent:[]. catList remove: 'private' ifAbsent:[]. catList do:[:categ| (proxyClass organization listAtCategoryNamed: categ) do:[:selector| (anInterpreter canUnderstand: selector) ifFalse: [self notifyWithLabel: selector, ' is not implemented in ', anInterpreter name]]]! ! !JPEGReadWriter methodsFor: 'marker parsing' stamp: 'sw 5/23/2001 13:48'! parseNextMarker "Parse the next marker of the stream" | byte discardedBytes | discardedBytes _ 0. [(byte _ self next) = 16rFF] whileFalse: [discardedBytes _ discardedBytes + 1]. [[(byte _ self next) = 16rFF] whileTrue. byte = 16r00] whileTrue: [discardedBytes _ discardedBytes + 2]. discardedBytes > 0 ifTrue: [self notifyWithLabel: 'warning: extraneous data discarded']. self perform: (JFIFMarkerParser at: byte ifAbsent: [(self okToIgnoreMarker: byte) ifTrue: [#skipMarker] ifFalse: [self error: 'marker ', byte hex , ' cannot be handled']])! ! !MailtoUrl methodsFor: 'downloading' stamp: 'sw 5/23/2001 13:49'! activate "Activate a Celeste window for the receiver" (Smalltalk includesKey: #Celeste) ifFalse: [^ self inform: 'no mail reader present']. ^ CelesteComposition openForCeleste: Celeste current initialText: self composeText! ! !MorphicModel class methodsFor: 'compilation' stamp: 'sw 5/23/2001 13:51'! chooseNewName "Choose a new name for the receiver, persisting until an acceptable name is provided or until the existing name is resubmitted" | oldName newName | oldName _ self name. [newName _ (FillInTheBlank request: 'Please give this Model a name' initialAnswer: oldName) asSymbol. newName = oldName ifTrue: [^ self]. Smalltalk includesKey: newName] whileTrue: [self inform: 'Sorry, that name is already in use.']. self rename: newName.! ! !MoviePlayerMorph methodsFor: 'private' stamp: 'sw 5/23/2001 13:51'! pvtOpenFileNamed: fName "Private - open on the movie file iof the given name" | f w h d n m | self stopRunning. fName = movieFileName ifTrue: [^ self]. "No reopen necessary on same file" movieFileName _ fName. "Read movie file parameters from 128-byte header... (records follow as {N=int32, N words}*)" f _ (FileStream oldFileNamed: movieFileName) binary. f nextInt32. w _ f nextInt32. h _ f nextInt32. d _ f nextInt32. n _ f nextInt32. m _ f nextInt32. f close. pageSize _ frameSize _ w@h. frameDepth _ d. frameCount _ n. frameNumber _ 1. playDirection _ 0. msAtLastSync _ 0. msPerFrame _ m/1000.0. self makeMyPage. (Smalltalk platformName = 'Mac OS') ifTrue:[ (Smalltalk extraVMMemory < self fileByteCountPerFrame) ifTrue: [^ self inform: 'Playing movies in Squeak requires that extra memory be allocated for asynchronous file IO. This particular movie requires a buffer of ' , (self fileByteCountPerFrame printString) , ' bytes, but you only have ' , (Smalltalk extraVMMemory printString) , ' allocated. You can evaluate ''Smalltalk extraVMMemory'' to check your allocation, and ''Smalltalk extraVMMemory: 485000'' or the like to increase your allocation. Note that raising your allocation in this way only marks your image as needing this much, so you must then save, quit, and start over again before you can run this movie. Good luck.']]. ! ! !PDA methodsFor: 'currentItem' stamp: 'sw 5/23/2001 13:52'! acceptCurrentItemText: aText "Accept into the current item from the text provided, and update lists accordingly" currentItem ifNil: [self inform: 'Can''t accept -- no item is selected'. ^ false]. viewDescriptionOnly ifTrue: [currentItem description: aText string. ^ true]. currentItem readFrom: aText. (currentItem isKindOf: PDAEvent) ifTrue: [self updateScheduleList]. (currentItem isMemberOf: PDAToDoItem) ifTrue: [self updateToDoList]. (currentItem isMemberOf: PDAPerson) ifTrue: [self updatePeopleList]. (currentItem isMemberOf: PDARecord) ifTrue: [self updateNotesList]. ^ true! ! !PaintBoxMorph methodsFor: 'initialization' stamp: 'sw 5/23/2001 13:53'! createButtons "Create buttons one at a time and let the user place them over the background. Later can move them again by turning on AuthorModeOwner in ThreePhaseButtonMorph. self createButtons. " | rect button nib | #(erase: eyedropper: fill: paint: rect: ellipse: polygon: line: star: pickup: "pickup: pickup: pickup:" stamp: "stamp: stamp: stamp:" undo: keep: toss: prevStamp: nextStamp:) do: [:sel | (self submorphNamed: sel) ifNil: [self inform: 'Rectangle for ',sel. rect _ Rectangle fromUser. button _ ThreePhaseButtonMorph new. button onImage: nil; bounds: rect. self addMorph: button. button actionSelector: #tool:action:cursor:evt:; arguments: (Array with: button with: sel with: nil). button actWhen: #buttonUp; target: self]]. #(brush1: brush2: brush3: brush4: brush5: brush6: ) doWithIndex: [:sel :ind | (self submorphNamed: sel) ifNil: [self inform: 'Rectangle for ',sel. rect _ Rectangle fromUser. button _ ThreePhaseButtonMorph new. button onImage: nil; bounds: rect. self addMorph: button. nib _ Form dotOfSize: (#(1 2 3 6 11 26) at: ind). button actionSelector: #brush:action:nib:evt:; arguments: (Array with: button with: sel with: nib). button actWhen: #buttonUp; target: self]]. "stamp: Stamps are held in a ScrollingToolHolder. Pickups and stamps and brushes are id-ed by the button == with item from a list." ! ! !PaintBoxMorph methodsFor: 'initialization' stamp: 'sw 5/23/2001 13:54'! loadCursors "Display the form containing the cursors. Transparent is (Color r: 1.0 g: 0 b: 1.0). Grab the forms one at a time, and they are stored away. self loadCursors. " | button transp cursor map | transp _ Color r: 1.0 g: 0 b: 1.0. map _ Color indexedColors copy. "just in case" 1 to: 256 do: [:ind | (map at: ind) = transp ifTrue: [map at: ind put: Color transparent]]. #(erase: eyedropper: fill: paint: rect: ellipse: polygon: line: star: ) do: [:sel | self inform: 'Rectangle for ',sel. cursor _ ColorForm fromUser. cursor colors: map. "share it" button _ self submorphNamed: sel. button arguments at: 3 put: cursor]. ! ! !PaintBoxMorph methodsFor: 'initialization' stamp: 'sw 5/23/2001 13:54'! moveButtons "Move buttons one at a time and let the user place them over the background. Later can move them again by turning on AuthorModeOwner in ThreePhaseButtonMorph. self createButtons. " | rect button | #(erase: eyedropper: fill: paint: rect: ellipse: polygon: line: star: "pickup: pickup: pickup: pickup:" "stamp: stamp: stamp: stamp:" undo: keep: toss: prevStamp: nextStamp:) do: [:sel | self inform: 'Rectangle for ',sel. rect _ Rectangle fromUser. button _ self submorphNamed: sel. button bounds: rect. "image is nil"]. #(brush1: brush2: brush3: brush4: brush5: brush6: ) doWithIndex: [:sel :ind | self inform: 'Rectangle for ',sel. rect _ Rectangle fromUser. button _ self submorphNamed: sel. button bounds: rect. "image is nil"]. "stamp: Stamps are held in a ScrollingToolHolder. Pickups and stamps and brushes are id-ed by the button == with item from a list." " " ! ! !Parser methodsFor: 'error correction' stamp: 'sw 5/23/2001 13:55'! removeUnusedTemps "Scan for unused temp names, and prompt the user about the prospect of removing each one found" | str end start madeChanges | madeChanges _ false. str _ requestor text string. ((tempsMark between: 1 and: str size) and: [(str at: tempsMark) = $|]) ifFalse: [^ self]. encoder unusedTempNames do: [:temp | ((PopUpMenu labels: 'yes\no' withCRs) startUpWithCaption: ((temp , ' appears to be unused in this method. OK to remove it?') asText makeBoldFrom: 1 to: temp size)) = 1 ifTrue: [(encoder encodeVariable: temp) isUndefTemp ifTrue: [end _ tempsMark. ["Beginning at right temp marker..." start _ end - temp size + 1. end < temp size or: [temp = (str copyFrom: start to: end) and: [(str at: start-1) isSeparator & (str at: end+1) isSeparator]]] whileFalse: ["Search left for the unused temp" end _ requestor nextTokenFrom: end direction: -1]. end < temp size ifFalse: [(str at: start-1) = $ ifTrue: [start _ start-1]. requestor correctFrom: start to: end with: ''. str _ str copyReplaceFrom: start to: end with: ''. madeChanges _ true. tempsMark _ tempsMark - (end-start+1)]] ifFalse: [self inform: 'You''ll first have to remove the statement where it''s stored into']]]. madeChanges ifTrue: [ParserRemovedUnusedTemps signal]! ! !Project methodsFor: 'menu messages' stamp: 'sw 5/23/2001 13:56'! exit "Leave the current project and return to the project in which this one was created." self isTopProject ifTrue: [^ self inform: 'Can''t exit the top project']. parentProject enter: false revert: false saveForRevert: false. ! ! !Project methodsFor: 'release' stamp: 'sw 5/23/2001 13:58'! okToChange "Answer whether the window in which the project is housed can be dismissed -- which is destructive. We never clobber a project without confirmation" | ok is list | self subProjects size >0 ifTrue: [self inform: 'The project ', self name printString, ' contains sub-projects. You must remove these explicitly before removing their parent.'. ^ false]. ok _ world isMorph not and: [world scheduledControllers size <= 1]. ok ifFalse: [self isMorphic ifTrue: [self parent == CurrentProject ifFalse: [^ true]]]. "view from elsewhere. just delete it." ok _ (self confirm: 'Really delete the project ', self name printString, ' and all its windows?'). ok ifFalse: [^ false]. world isMorph ifTrue: [Smalltalk at: #WonderlandCameraMorph ifPresent:[:aClass | world submorphs do: "special release for wonderlands" [:m | (m isKindOf: aClass) and: [m getWonderland release]]]. "Remove Player classes and metaclasses owned by project" is _ ImageSegment new arrayOfRoots: (Array with: self). (list _ is rootsIncludingPlayers) ifNotNil: [list do: [:playerCls | (playerCls respondsTo: #isMeta) ifTrue: [playerCls isMeta ifFalse: [playerCls removeFromSystemUnlogged]]]]]. self removeChangeSetIfPossible. "do this last since it will render project inaccessible to #allProjects and their ilk" Project deletingProject: self. ^ true ! ! !Project methodsFor: 'file in/out' stamp: 'sw 5/23/2001 13:59'! saveForRevert "Exit to the parent project. Do a GC. Save the project in a segment. Record the ImageSegment object as the revertToMe in Project parameters" self isTopProject ifTrue: [^ self inform: 'Can''t exit the top project']. parentProject enter: false revert: false saveForRevert: true. "does not return!!" ! ! !Scamper methodsFor: 'changing page' stamp: 'sw 5/23/2001 14:00'! submitFormWithInputs: inputs url: url method: method "Submit the current form with the given arguments" | newUrl newSource | self stopEverything. (method asLowercase ~= 'get' and: [ method asLowercase ~= 'post' ]) ifTrue: [self inform: 'unknown FORM method: ', method. ^ false ]. newUrl _ url asUrlRelativeTo: currentUrl. newUrl schemeName ~= 'http' ifTrue: [self inform: 'I can only submit forms via HTTP'. ^ false]. self status: 'submitting form...'. downloadingProcess _ [method asLowercase = 'get' ifTrue: [newSource _ newUrl retrieveContentsArgs: inputs] ifFalse: [newSource _ newUrl postFormArgs: inputs]. documentQueue nextPut: newSource. downloadingProcess _ nil] newProcess. downloadingProcess resume. ^ true ! ! !Scamper methodsFor: 'changing page' stamp: 'sw 5/23/2001 14:02'! submitFormWithInputs: inputs url: url method: method encoding: encoding "Submit the given form with the provided inputs, url, method, and encoding" | newUrl newSource | self stopEverything. (method asLowercase ~= 'get' and: [ method asLowercase ~= 'post' ]) ifTrue: [self inform: 'unknown FORM method: ', method. ^false ]. newUrl _ url asUrlRelativeTo: currentUrl. newUrl schemeName ~= 'http' ifTrue: [self inform: 'I can only submit forms via HTTP'. ^ false]. self status: 'submitting form...'. downloadingProcess _ [method asLowercase = 'get' ifTrue: [newSource _ newUrl retrieveContentsArgs: inputs] ifFalse: [encoding = MIMEDocument contentTypeMultipart ifTrue: [newSource _ newUrl postMultipartFormArgs: inputs] ifFalse: [newSource _ newUrl postFormArgs: inputs]]. documentQueue nextPut: newSource. downloadingProcess _ nil] newProcess. downloadingProcess resume. ^ true ! ! !ServerDirectory methodsFor: 'updates' stamp: 'sw 5/23/2001 14:03'! putUpdate: fileStrm "Put this file out as an Update on the servers of my group. Each version of the system may have its own set of update files, or they may all share the same files. 'updates.list' holds the master list. Each update is a fileIn whose name begins with a number. See Utilities class readServerUpdatesThrough:saveLocally:updateImage:. When two sets of updates are stored on the same directory, one of them has a * in its serverUrls description. When that is true, the first word of the description is put on the front of 'updates.list', and that index file is used." | myServers updateStrm newName myName response localName seq indexPrefix listContents version versIndex lastNum stripped | localName _ fileStrm localName. fileStrm size = 0 ifTrue: [^ self inform: 'That file has zero bytes!! May have a new name.']. (fileStrm contentsOfEntireFile includes: Character linefeed) ifTrue: [self notifyWithLabel: 'That file contains linefeeds. Proceed if... you know that this is okay (e.g. the file contains raw binary data).']. fileStrm reset. (self checkNames: {localName}) ifFalse: [^ nil]. "illegal characters" myName _ group ifNil: [self moniker] ifNotNil: [group key]. response _ (PopUpMenu labels: 'Install update\Cancel update' withCRs) startUpWithCaption: 'Do you really want to broadcast the file ', localName, '\to every Squeak user who updates from ' withCRs, myName, '?'. response = 1 ifFalse: [^ nil]. "abort" self openGroup. indexPrefix _ (group key includes: $*) ifTrue: [(group key findTokens: ' ') first] "special for internal updates" ifFalse: ['']. "normal" myServers _ self checkServersWithPrefix: indexPrefix andParseListInto: [:x | listContents _ x]. myServers size = 0 ifTrue: [self closeGroup. ^ self]. version _ SystemVersion current version. versIndex _ (listContents collect: [:pair | pair first]) indexOf: version. versIndex = 0 ifTrue: [self inform: 'There is no section in updates.list for your version'. self closeGroup. ^ nil]. "abort" lastNum _ (listContents at: versIndex) last last initialIntegerOrNil. versIndex < listContents size ifTrue: [response _ (PopUpMenu labels: 'Make update for an older version\Cancel update' withCRs) startUpWithCaption: 'This system, ', SystemVersion current version, ' is not the latest version'. response = 1 ifFalse: [self closeGroup. ^ nil]]. "abort" "Save old copy of updates.list on local disk" FileDirectory default deleteFileNamed: indexPrefix , 'updates.list.bk'. Utilities writeList: listContents toStream: (FileStream fileNamed: indexPrefix , 'updates.list.bk'). "append name to updates with new sequence number" seq _ (lastNum + 1) printString padded: #left to: 4 with: $0. "strip off any old seq number" stripped _ localName copyFrom: (localName findFirst: [:c | c isDigit not]) to: localName size. newName _ seq , stripped. listContents at: versIndex put: {version. (listContents at: versIndex) last copyWith: newName}. "Write a new copy on all servers..." updateStrm _ ReadStream on: (String streamContents: [:s | Utilities writeList: listContents toStream: s]). myServers do: [:aServer | fileStrm reset. "reopen" aServer putFile: fileStrm named: newName retry: true. updateStrm reset. aServer putFile: updateStrm named: indexPrefix , 'updates.list' retry: true. Transcript show: 'Update succeeded on server ', aServer moniker; cr]. self closeGroup. Transcript cr; show: 'Be sure to test your new update!!'; cr. "rename the file locally (may fail)" fileStrm directory rename: localName toBe: newName. ! ! !SmartRefStream methodsFor: 'class changed shape' stamp: 'sw 5/23/2001 14:04'! writeClassRenameMethod: sel was: oldName fromInstVars: oldList "The class coming is unknown. Ask the user for the existing class it maps to. If got one, write a method, and restart the obj fileIn. If none, write a dummy method and get the user to complete it later. " | tell choice newName answ code oldVer newList newVer instSel | self flag: #bobconv. tell _ 'Reading an instance of ', oldName, '. Which modern class should it translate to?'. answ _ (PopUpMenu labels: 'Let me type the name now Let me think about it Let me find a conversion file on the disk') startUpWithCaption: tell. answ = 1 ifTrue: [ tell _ 'Name of the modern class that ', oldName, 's should it translate to:'. choice _ FillInTheBlank request: tell. "class name" (choice size = 0) ifTrue: [answ _ 'conversion method needed'] ifFalse: [newName _ choice. answ _ Smalltalk at: newName asSymbol ifAbsent: ['conversion method needed']. answ class == String ifFalse: [renamed at: oldName asSymbol put: answ name]]]. (answ = 3) | (answ = 0) ifTrue: [self close. ^ 'conversion method needed']. answ = 2 ifTrue: [answ _ 'conversion method needed']. answ = 'conversion method needed' ifTrue: [ self close. newName _ 'PutNewClassHere']. answ class == String ifFalse: [ oldVer _ self versionSymbol: (structures at: oldName). newList _ (Array with: answ classVersion), (answ allInstVarNames). newVer _ self versionSymbol: newList. instSel _ 'convert',oldVer,':',newVer, ':'. ]. code _ WriteStream on: (String new: 500). code nextPutAll: sel; cr. answ class == String ifFalse: [ code cr; tab; nextPutAll: 'reshaped at: #', oldName, ' put: #', instSel, '.'. code cr; tab; tab; nextPutAll: '"Be sure to define that conversion method in class ', answ name, '"']. code cr; tab; nextPutAll: '^ ', newName. "Return new class" self class compile: code contents classified: 'conversion'. newName = 'PutNewClassHere' ifTrue: [ self inform: 'Please complete the following method and then read-in the object file again.'. Smalltalk browseAllImplementorsOf: sel asSymbol]. "The class version number only needs to change under one specific circumstance. That is when the first letters of the instance variables have stayed the same, but their meaning has changed. A conversion method is needed, but this system does not know it. If this is true for class Foo, define classVersion in Foo class. Beware of previous object fileouts already written after the change in meaning, but before bumping the version number. They have the old (wrong) version number, say 2. If this is true, your method must be able to test the data and successfully read files that say version 2 but are really 3." ^ answ! ! !SoundRecorder methodsFor: 'trimming' stamp: 'sw 5/23/2001 14:05'! segmentsAbove: threshold normalizedVolume: percentOfMaxVolume "Break the current recording up into a sequence of sound segments separated by silences." | max min sum totalSamples bufSize s dcOffset firstPlace endPlace resultBuf nFactor lastPlace segments gapSize minDur minLull soundSize restSize | stereo ifTrue: [self error: 'stereo trimming is not yet supported']. paused ifFalse: [self error: 'must stop recording before trimming']. (recordedSound == nil or: [recordedSound sounds isEmpty]) ifTrue:[^ self]. "Reconstruct buffers so old trimming code will work" recordedBuffers _ recordedSound sounds collect: [:snd | snd samples]. soundSize _ restSize _ 0. max _ min _ sum _ totalSamples _ 0. recordedBuffers do: [:buf | bufSize _ buf size. totalSamples _ totalSamples + buf size. 1 to: bufSize do: [:i | s _ buf at: i. s > max ifTrue: [max _ s]. s < min ifTrue: [min _ s]. sum _ sum + s]]. dcOffset _ sum // totalSamples. minDur _ (samplingRate/20.0) asInteger. " 1/20 second " minLull _ (samplingRate/4.0) asInteger. " 1/2 second " segments _ SequentialSound new. endPlace _ self endPlace. lastPlace _ #(1 1). [firstPlace _ self scanForStartThreshold: threshold dcOffset: dcOffset minDur: minDur startingAt: lastPlace. firstPlace = endPlace] whileFalse: [firstPlace = lastPlace ifFalse: ["Add a silence equal to the gap size" "Wasteful but simple way to get gap size..." gapSize _ (self copyFrom: lastPlace to: firstPlace normalize: 1000 dcOffset: dcOffset) size - 2. "... -2 makes up for overlap of one sample on either end" segments add: (RestSound dur: gapSize asFloat / samplingRate). restSize _ restSize + gapSize. "Transcript cr; print: firstPlace; space; print: lastPlace; space; print: gapSize; space; show: 'gap'." ]. lastPlace _ self scanForEndThreshold: threshold dcOffset: dcOffset minLull: minLull + minDur startingAt: firstPlace. "Allow room for lead time of next sound" lastPlace _ self place: lastPlace plus: minDur negated. nFactor _ self normalizeFactorFor: percentOfMaxVolume min: min max: max dcOffset: dcOffset. resultBuf _ self copyFrom: firstPlace to: lastPlace normalize: nFactor dcOffset: dcOffset. soundSize _ soundSize + resultBuf size. "Transcript cr; print: firstPlace; space; print: lastPlace; space; print: resultBuf size; space; show: 'sound'." segments add: (codec == nil ifTrue: [SampledSound new setSamples: resultBuf samplingRate: samplingRate] ifFalse: [codec compressSound: (SampledSound new setSamples: resultBuf samplingRate: samplingRate)])]. "Final gap for consistency" gapSize _ (self copyFrom: lastPlace to: self endPlace normalize: 1000 dcOffset: dcOffset) size - 1. segments add: (RestSound dur: gapSize asFloat / samplingRate). restSize _ restSize + gapSize. self inform: ((soundSize+restSize/samplingRate) roundTo: 0.1) printString , ' secs reduced to ' , ((soundSize/samplingRate) roundTo: 0.1) printString. recordedBuffers _ nil. ^ segments! ! !SystemDictionary methodsFor: 'housekeeping' stamp: 'sw 5/23/2001 14:05'! condenseSources "Smalltalk condenseSources" "Move all the changes onto a compacted sources file." | f classCount dir newVersionString | dir _ FileDirectory default. newVersionString _ FillInTheBlank request: 'Please designate the version for the new source code file...' initialAnswer: SourceFileVersionString. newVersionString ifNil: [^ self]. newVersionString = SourceFileVersionString ifTrue: [^ self error: 'The new source file must not be the same as the old.']. SourceFileVersionString _ newVersionString. "Write all sources with fileIndex 1" f _ FileStream newFileNamed: self sourcesName. f header; timeStamp. 'Condensing Sources File...' displayProgressAt: Sensor cursorPoint from: 0 to: Smalltalk classNames size during: [:bar | classCount _ 0. Smalltalk allClassesDo: [:class | bar value: (classCount _ classCount + 1). class fileOutOn: f moveSource: true toFile: 1]]. f trailer; close. "Make a new empty changes file" self closeSourceFiles. dir rename: self changesName toBe: self changesName , '.old'. (FileStream newFileNamed: self changesName) header; timeStamp; close. LastQuitLogPosition _ 0. self setMacFileInfoOn: self changesName. self setMacFileInfoOn: self sourcesName. self openSourceFiles. self inform: 'Source files have been rewritten!! Check that all is well, and then save/quit.'! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'sw 5/23/2001 14:06'! discardMVC "After suitable checks, strip out much of MVC from the system" "Smalltalk discardMVC" | keepers | self flag: #bob. "zapping projects" Smalltalk isMorphic ifFalse: [self inform: 'You must be in a Morphic project to discard MVC.'. ^ self]. "Check that there are no MVC Projects" (Project allProjects allSatisfy: [ :proj | proj isMorphic]) ifFalse: [(self confirm: 'Would you like a chance to remove your MVC projects in an orderly manner?') ifTrue: [^ self]. (self confirm: 'If you wish, I can remove all MVC projects, make this project be the top project, and place all orphaned sub-projects of MVC parents here. Would you like be to do this and proceed to discard all MVC classes?') ifTrue: [self zapMVCprojects] ifFalse: [^ self]]. Smalltalk reclaimDependents. "Remove old Paragraph classes and View classes." (ChangeSet superclassOrder: Paragraph withAllSubclasses asArray) reverseDo: [:c | c removeFromSystem]. (ChangeSet superclassOrder: View withAllSubclasses asArray) reverseDo: [:c | c removeFromSystem]. "Get rid of ParagraphEditor's ScrollController dependence" #(markerDelta viewDelta scrollAmount scrollBar computeMarkerRegion) do: [:sel | ParagraphEditor removeSelector: sel]. ParagraphEditor compile: 'updateMarker'. ParagraphEditor superclass: MouseMenuController . "Get rid of all Controller classes not needed by ParagraphEditor and ScreenController" keepers _ TextMorphEditor withAllSuperclasses copyWith: ScreenController. (ChangeSet superclassOrder: Controller withAllSubclasses asArray) reverseDo: [:c | (keepers includes: c) ifFalse: [c removeFromSystem]]. SystemOrganization removeCategoriesMatching: 'ST80-Paths'. SystemOrganization removeCategoriesMatching: 'ST80-Pluggable Views'. Smalltalk removeClassNamed: 'FormButtonCache'. Smalltalk removeClassNamed: 'WindowingTransformation'. Smalltalk removeClassNamed: 'ControlManager'. Smalltalk removeClassNamed: 'DisplayTextView'. ScheduledControllers _ nil. Undeclared removeUnreferencedKeys. SystemOrganization removeEmptyCategories. Symbol rehash. ! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'sw 5/23/2001 14:08'! majorShrink "Undertake a major shrinkage of the image. This method throws out lots of the system that is not needed for, eg, operation in a hand-held PC. majorShrink produces a 999k image in Squeak 2.8 Smalltalk majorShrink; abandonSources; lastRemoval" | oldDicts newDicts | Smalltalk isMorphic ifTrue: [^ self error: 'You can only run majorShrink in MVC']. Project current isTopProject ifFalse: [^ self error: 'You can only run majorShrink in the top project']. (Smalltalk confirm: 'All sub-projects will be deleted from this image. You should already have made a backup copy, or you must save with a different name after shrinking. Shall we proceed to discard most of the content in this image?') ifFalse: [^ self inform: 'No changes have been made.']. "Remove all projects but the current one. - saves 522k" ProjectView allInstancesDo: [:pv | pv controller closeAndUnscheduleNoTerminate]. Project current setParent: Project current. MorphWorldView allInstancesDo: [:pv | pv topView controller closeAndUnscheduleNoTerminate]. Smalltalk at: #Wonderland ifPresent:[:cls| cls removeActorPrototypesFromSystem]. Player freeUnreferencedSubclasses. MorphicModel removeUninstantiatedModels. Utilities classPool at: #ScrapsBook put: nil. Utilities zapUpdateDownloader. ProjectHistory currentHistory initialize. Project rebuildAllProjects. Smalltalk discardVMConstruction. "755k" Smalltalk discardSoundSynthesis. "544k" Smalltalk discardOddsAndEnds. "227k" Smalltalk discardNetworking. "234k" Smalltalk discard3D. "407k" Smalltalk discardFFI. "33k" Smalltalk discardMorphic. "1372k" Symbol rehash. "40k" "Above by itself saves about 4,238k" "Remove references to a few classes to be deleted, so that they won't leave obsolete versions around." FileList removeSelector: #fileIntoNewChangeSet. ChangeSet class compile: 'defaultName ^ ''Changes'' ' classified: 'initialization'. ScreenController removeSelector: #openChangeManager. ScreenController removeSelector: #exitProject. ScreenController removeSelector: #openProject. ScreenController removeSelector: #viewImageImports. "Now delete various other classes.." SystemOrganization removeSystemCategory: 'Graphics-Files'. SystemOrganization removeSystemCategory: 'System-Object Storage'. Smalltalk removeClassNamed: #ProjectController. Smalltalk removeClassNamed: #ProjectView. "Smalltalk removeClassNamed: #Project." Smalltalk removeClassNamed: #Environment. Smalltalk removeClassNamed: #Component1. Smalltalk removeClassNamed: #FormSetFont. Smalltalk removeClassNamed: #FontSet. Smalltalk removeClassNamed: #InstructionPrinter. Smalltalk removeClassNamed: #ChangeSorter. Smalltalk removeClassNamed: #DualChangeSorter. Smalltalk removeClassNamed: #EmphasizedMenu. Smalltalk removeClassNamed: #MessageTally. StringHolder class removeSelector: #originalWorkspaceContents. CompiledMethod removeSelector: #symbolic. RemoteString removeSelector: #makeNewTextAttVersion. Utilities class removeSelector: #absorbUpdatesFromServer. Smalltalk removeClassNamed: #PenPointRecorder. Smalltalk removeClassNamed: #Path. Smalltalk removeClassNamed: #Base64MimeConverter. "Smalltalk removeClassNamed: #EToySystem. Dont bother - its very small and used for timestamps etc" Smalltalk removeClassNamed: #RWBinaryOrTextStream. Smalltalk removeClassNamed: #AttributedTextStream. Smalltalk removeClassNamed: #WordNet. Smalltalk removeClassNamed: #SelectorBrowser. TextStyle allSubInstancesDo: [:ts | ts newFontArray: (ts fontArray copyFrom: 1 to: (2 min: ts fontArray size))]. ListParagraph initialize. PopUpMenu initialize. StandardSystemView initialize. Smalltalk noChanges. ChangeSorter classPool at: #AllChangeSets put: (OrderedCollection with: Smalltalk changes). SystemDictionary removeSelector: #majorShrink. [Smalltalk removeAllUnSentMessages > 0] whileTrue: [Smalltalk unusedClasses do: [:c | (Smalltalk at: c) removeFromSystem]]. SystemOrganization removeEmptyCategories. Smalltalk allClassesDo: [:c | c zapOrganization]. Smalltalk garbageCollect. 'Rehashing method dictionaries . . .' displayProgressAt: Sensor cursorPoint from: 0 to: MethodDictionary instanceCount during: [:bar | oldDicts _ MethodDictionary allInstances. newDicts _ Array new: oldDicts size. oldDicts withIndexDo: [:d :index | bar value: index. newDicts at: index put: d rehashWithoutBecome. ]. oldDicts elementsExchangeIdentityWith: newDicts. ]. oldDicts _ newDicts _ nil. Project rebuildAllProjects. Smalltalk changes initialize. "seems to take more than one try to gc all the weak refs in SymbolTable" 3 timesRepeat: [ Smalltalk garbageCollect. Symbol compactSymbolTable. ]. ! ! !SystemDictionary methodsFor: 'snapshot and quit' stamp: 'sw 5/23/2001 14:10'! saveAsEmbeddedImage "Save the current state of the system as an embedded image" | dir newName newImageName newImageSegDir oldImageSegDir haveSegs | dir _ FileDirectory default. newName _ FillInTheBlank request: 'Select existing VM file' initialAnswer: (FileDirectory localNameFor: ''). newName = '' ifTrue: [^ self]. newName _ FileDirectory baseNameFor: newName asFileName. newImageName _ newName. (dir includesKey: newImageName) ifFalse: [^ self inform: 'Unable to find name ', newName, ' Please choose another name.']. haveSegs _ false. Smalltalk at: #ImageSegment ifPresent: [:theClass | (haveSegs _ theClass instanceCount ~= 0) ifTrue: [oldImageSegDir _ theClass segmentDirectory]]. self logChange: '----SAVEAS (EMBEDDED) ', newName, '----', Date dateAndTimeNow printString. self imageName: (dir fullNameFor: newImageName). LastImageName _ self imageName. self closeSourceFiles. haveSegs ifTrue: [Smalltalk at: #ImageSegment ifPresent: [:theClass | newImageSegDir _ theClass segmentDirectory. "create the folder" oldImageSegDir fileNames do: [:theName | "copy all segment files" newImageSegDir copyFileNamed: oldImageSegDir pathName, FileDirectory slash, theName toFileNamed: theName]]]. self snapshot: true andQuit: true embedded: true ! ! !Environment class methodsFor: 'system conversion' stamp: 'sw 5/23/2001 14:27'! reorganizeEverything "Undertake a grand reorganization. Environment reorganizeEverything. " | bigCat envt pool s | "First check for clashes between environment names and existing globals..." SystemOrganization categories do: [:cat | bigCat _ (cat asString copyUpTo: '-' first) asSymbol. (Smalltalk kernelCategories includes: bigCat) ifFalse: [(Smalltalk includesKey: bigCat) ifTrue: [^ self error: bigCat , ' cannot be used to name both a package and a class or other global variable. No reorganization will be attempted.']]]. (self confirm: 'Your image is about to be partitioned into environments. Many things may not work after this, so you should be working in a throw-away copy of your working image. Are you really ready to procede? (choose ''no'' to stop here safely)') ifFalse: [^ self inform: 'No changes were made']. Smalltalk newChanges: (ChangeSet basicNewNamed: 'Reorganization'). "Recreate the Smalltalk dictionary as the top-level Environment." Smalltalk _ SmalltalkEnvironment newFrom: Smalltalk. Smalltalk setName: #Smalltalk inOuterEnvt: nil. "Don't hang onto old copy of Smalltalk ." Smalltalk recreateSpecialObjectsArray. Smalltalk allClassesDo: [:c | c environment: nil. "Flush any old values"]. "Run through all categories making up new sub-environments" SystemOrganization categories do: [:cat | bigCat _ (cat asString copyUpTo: '-' first) asSymbol. (Smalltalk kernelCategories includes: bigCat) ifFalse: ["Not a kernel category ..." envt _ Smalltalk at: bigCat ifAbsent: ["... make up a new environment if necessary ..." Smalltalk makeSubEnvironmentNamed: bigCat]. "... and install the member classes in that category" envt transferBindingsNamedIn: (SystemOrganization listAtCategoryNamed: cat) from: Smalltalk]. ]. "Move all shared pools that are only referred to in sub environments" Smalltalk associationsDo: [:assn | ((pool _ assn value) isMemberOf: Dictionary) ifTrue: [s _ IdentitySet new. Smalltalk allClassesAnywhereDo: [:c | c sharedPools do: [:p | p == pool ifTrue: [s add: c environment]]]. (s size = 1 and: [(envt _ s someElement) ~~ Smalltalk]) ifTrue: [envt declare: assn key from: Smalltalk]]]. Smalltalk rewriteIndirectRefs. Smalltalk newChanges: (ChangeSet basicNewNamed: 'PostReorganization'). ChangeSorter initialize. Preferences enable: #browserShowsPackagePane. ! ! !Text class methodsFor: 'class initialization' stamp: 'sw 5/23/2001 14:11'! initTextConstants "Initialize constants shared by classes associated with text display, e.g., Space, Tab, Cr, Bs, ESC." "1/24/96 sw: in exasperation and confusion, changed cmd-g mapping from 231 to 232 to see if I could gain any relief?!!" | letter varAndValue tempArray width | "CtrlA..CtrlZ, Ctrla..Ctrlz" letter _ $A. #( 212 230 228 196 194 226 241 243 214 229 200 217 246 245 216 202 210 239 211 240 197 198 209 215 242 231 1 166 228 132 130 12 232 179 150 165 136 153 182 14 15 138 17 18 19 11 21 134 145 151 178 167 ) do: [:kbd | TextConstants at: ('Ctrl', letter asSymbol) asSymbol put: kbd asCharacter. letter _ letter == $Z ifTrue: [$a] ifFalse: [(letter asciiValue + 1) asCharacter]]. varAndValue _ #( Space 32 Tab 9 CR 13 Enter 3 BS 8 BS2 158 ESC 160 Clear 173 ). varAndValue size odd ifTrue: [self error: 'unpaired text constant']. (2 to: varAndValue size by: 2) do: [:i | TextConstants at: (varAndValue at: i - 1) put: (varAndValue at: i) asCharacter]. varAndValue _ #( CtrlDigits (159 144 143 128 127 129 131 180 149 135) CtrlOpenBrackets (201 7 218 249 219 15) "lparen gottn by ctrl-_ = 201; should be 213 but can't type that on Mac" "location of non-character stop conditions" EndOfRun 257 CrossedX 258 "values for alignment" LeftFlush 0 RightFlush 1 Centered 2 Justified 3 "subscripts for a marginTabsArray tuple" LeftMarginTab 1 RightMarginTab 2 "font faces" Basal 0 Bold 1 Italic 2 "in case font doesn't have a width for space character" "some plausible numbers-- are they the right ones?" DefaultSpace 4 DefaultTab 24 DefaultLineGrid 16 DefaultBaseline 12 DefaultFontFamilySize 3 "basal, bold, italic" ). varAndValue size odd ifTrue: [self error: 'unpaired text constant']. (2 to: varAndValue size by: 2) do: [:i | TextConstants at: (varAndValue at: i - 1) put: (varAndValue at: i)]. TextConstants at: #DefaultRule put: Form over. TextConstants at: #DefaultMask put: Color black. width _ Display width max: 720. tempArray _ Array new: width // DefaultTab. 1 to: tempArray size do: [:i | tempArray at: i put: DefaultTab * i]. TextConstants at: #DefaultTabsArray put: tempArray. tempArray _ Array new: (width // DefaultTab) // 2. 1 to: tempArray size do: [:i | tempArray at: i put: (Array with: (DefaultTab*i) with: (DefaultTab*i))]. TextConstants at: #DefaultMarginTabsArray put: tempArray. "Text initTextConstants "! ! !Time class methodsFor: 'benchmarks' stamp: 'sw 5/23/2001 14:12'! benchmarkMillisecondClock "Benchmark the time spent in a call to Time>>millisecondClockValue. On the VM level this tests the efficiency of calls to ioMSecs(). Time benchmarkMillisecondClock PII/400 Windows 98: 0.725 microseconds per call" | temp1 temp2 temp3 delayTime nLoops time | delayTime _ 5000. "Time to run benchmark is approx. 2*delayTime" "Don't run the benchmark if we have an active delay since we will measure the additional penalty in the primitive dispatch mechanism (see #benchmarkPrimitiveResponseDelay)." Delay anyActive ifTrue:[ ^self inform: 'Some delay is currently active. Running this benchmark will not give any useful result.']. "Flush the cache for this benchmark so we will have a clear cache hit for each send to #millisecondClockValue below" Object flushCache. temp1 _ 0. temp2 _ self. "e.g., temp1 == Time" temp3 _ self millisecondClockValue + delayTime. "Now check how often we can run the following loop in the given time" [temp2 millisecondClockValue < temp3] whileTrue:[temp1 _ temp1 + 1]. nLoops _ temp1. "Remember the loops we have run during delayTime" "Set up the second loop" temp1 _ 0. temp3 _ nLoops. "Now measure how much time we spend without sending #millisecondClockValue" time _ Time millisecondClockValue. [temp1 < temp3] whileTrue:[temp1 _ temp1 + 1]. time _ Time millisecondClockValue - time. "And compute the number of microseconds spent per call to #millisecondClockValue" ^ ((delayTime - time * 1000.0 / nLoops) truncateTo: 0.001) printString, ' microseconds per call to Time>>millisecondClockValue'! ! !Time class methodsFor: 'benchmarks' stamp: 'sw 5/23/2001 14:13'! benchmarkPrimitiveResponseDelay "Benchmark the overhead for primitive dispatches with an active Delay. On the VM level, this tests the efficiency of ioLowResMSecs. Time benchmarkPrimitiveResponseDelay PII/400 Windows98: 0.128 microseconds per prim" "ar 9/6/1999: This value is *extremely* important for stuff like sockets etc. I had a bad surprise when Michael pointed this particular problem out: Using the hardcoded clock() call for ioLowResMSecs on Win32 resulted in an overhead of 157.4 microseconds per primitive call - meaning you can't get more than approx. 6000 primitives per second on my 400Mhz PII system with an active delay!! BTW, it finally explains why Squeak seemed soooo slow when running PWS or other socket stuff. The new version (not using clock() but some Windows function) looks a lot better (see above; approx. 8,000,000 prims per sec with an active delay)." | nLoops bb index baseTime actualTime delayTime | delayTime _ 5000. "Time to run this test is approx. 3*delayTime" Delay anyActive ifTrue:[ ^ self inform: 'Some delay is currently active. Running this benchmark will not give any useful result.']. bb _ Array new: 1. "The object we send the prim message to" "Compute the # of loops we'll run in a decent amount of time" [(Delay forMilliseconds: delayTime) wait] forkAt: Processor userInterruptPriority. nLoops _ 0. [Delay anyActive] whileTrue:[ bb basicSize; basicSize; basicSize; basicSize; basicSize; basicSize; basicSize; basicSize; basicSize; basicSize. nLoops _ nLoops + 1. ]. "Flush the cache and make sure #basicSize is in there" Object flushCache. bb basicSize. "Now run the loop without any active delay for getting an idea about its actual speed." baseTime _ self millisecondClockValue. index _ nLoops. [index > 0] whileTrue:[ bb basicSize; basicSize; basicSize; basicSize; basicSize; basicSize; basicSize; basicSize; basicSize; basicSize. index _ index - 1. ]. baseTime _ self millisecondClockValue - baseTime. "Setup the active delay but try to never make it active" [(Delay forMilliseconds: delayTime + delayTime) wait] forkAt: Processor userInterruptPriority. "And run the loop" actualTime _ self millisecondClockValue. index _ nLoops. [index > 0] whileTrue:[ bb basicSize; basicSize; basicSize; basicSize; basicSize; basicSize; basicSize; basicSize; basicSize; basicSize. index _ index - 1. ]. actualTime _ self millisecondClockValue - actualTime. "And get us some result" ^((actualTime - baseTime) * 1000 asFloat / (nLoops * 10) truncateTo: 0.001) printString, ' microseconds overhead per primitive call'! ! !UserInputEvent methodsFor: 'modifier state' stamp: 'sw 5/23/2001 14:13'! macOptionKeyPressed "Answer whether the option key on the Macintosh keyboard was being held down when this event occurred. Macintosh specific." Preferences macOptionKeyAllowed ifFalse: [self notifyWithLabel: 'Portability note: MorphicEvent>>macOptionKeyPressed is not portable. Please use MorphicEvent>>yellowButtonPressed instead!!']. ^ buttons anyMask: 32! ! !Utilities class methodsFor: 'fetching updates' stamp: 'sw 5/23/2001 14:22'! newUpdatesOn: serverList special: indexPrefix throughNumber: aNumber "Return a list of fully formed URLs of update files we do not yet have. Go to the listed servers and look at the file 'updates.list' for the names of the last N update files. We look backwards for the first one we have, and make the list from there. tk 9/10/97 No updates numbered higher than aNumber (if it is not nil) are returned " | existing doc list out ff raw char maxNumber itsNumber | maxNumber _ aNumber ifNil: [99999]. out _ OrderedCollection new. existing _ SystemVersion current updates. serverList do: [:server | doc _ HTTPClient httpGet: 'http://' , server,indexPrefix,'updates.list'. "test here for server being up" doc class == RWBinaryOrTextStream ifTrue: [raw _ doc reset; contents. "one file name per line" list _ self extractThisVersion: raw. list reverseDo: [:fileName | ff _ (fileName findTokens: '/') last. "allow subdirectories" itsNumber _ ff initialIntegerOrNil. (existing includes: itsNumber) ifFalse: [ (itsNumber == nil or: [itsNumber <= maxNumber]) ifTrue: [out addFirst: server, fileName]] ifTrue: [^ out]]. ((out size > 0) or: [char _ doc reset; skipSeparators; next. (char == $*) | (char == $#)]) ifTrue: [^ out "we have our list"]]. "else got error msg instead of file" "Server was down, try next one"]. self inform: 'All code update servers seem to be unavailable'. ^ out! ! !Utilities class methodsFor: 'fetching updates' stamp: 'sw 5/23/2001 14:22'! objectStrmFromUpdates: fileName "Go to the known servers and look for this file in the updates folder. It is an auxillery file, like .morph or a .gif. Return a RWBinaryOrTextStream on it. Meant to be called from during the getting of updates from the server. That assures that (Utilities serverUrls) returns the right group of servers." | urls doc | Cursor wait showWhile: [urls _ Utilities serverUrls collect: [:url | url, 'updates/', fileName]. urls do: [:aUrl | doc _ HTTPSocket httpGet: aUrl accept: 'application/octet-stream'. "test here for server being up" doc class == RWBinaryOrTextStream ifTrue: [^ doc reset]]]. self inform: 'All update servers are unavailable, or bad file name'. ^ nil! ! !Utilities class methodsFor: 'recent method submissions' stamp: 'sw 5/23/2001 14:22'! browseRecentSubmissions "Open up a browser on the most recent methods submitted in the image. 5/96 sw." "Utilities browseRecentSubmissions" | recentMessages | self recentMethodSubmissions size == 0 ifTrue: [^ self inform: 'There are no recent submissions']. recentMessages _ RecentSubmissions copy reversed. RecentMessageSet openMessageList: recentMessages name: 'Recently submitted methods -- youngest first ' autoSelect: nil! ! !WiWPasteUpMorph methodsFor: 'project transition' stamp: 'sw 5/23/2001 14:23'! goBack "Return to the previous project. For the moment, this is not allowed from inner worlds" self inform: 'Project changes are not yet allowed from inner worlds.'! ! !WiWPasteUpMorph methodsFor: 'project transition' stamp: 'sw 5/23/2001 14:24'! jumpToProject "Jump directly to another project. However, this is not currently allowed for inner worlds" self inform: 'Project changes are not yet allowed from inner worlds.'! ! EToySystem class removeSelector: #newEToysOn:!