'From Squeak3.8alpha of ''17 July 2004'' [latest update: #5976] on 2 August 2004 at 6:56:59 pm'! !ArrayedCollection methodsFor: 'objects from disk' stamp: 'nk 7/30/2004 17:50'! restoreEndianness "This word object was just read in from a stream. It was stored in Big Endian (Mac) format. Reverse the byte order if the current machine is Little Endian. We only intend this for non-pointer arrays. Do nothing if I contain pointers." self class isPointers | self class isWords not ifTrue: [^self]. SmalltalkImage current isLittleEndian ifTrue: [Bitmap swapBytesIn: self from: 1 to: self basicSize]! ! !Bitmap methodsFor: 'accessing' stamp: 'nk 7/30/2004 17:53'! copyFromByteArray: byteArray "This method should work with either byte orderings" | myHack byteHack | myHack := Form new hackBits: self. byteHack := Form new hackBits: byteArray. SmalltalkImage current isLittleEndian ifTrue: [byteHack swapEndianness]. byteHack displayOn: myHack! ! !CanvasDecoder class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 21:51'! connection: aConnection ^(self new) connection: aConnection; yourself! ! !ChangeSorter methodsFor: 'message list' stamp: 'nk 7/30/2004 17:58'! moveMethodToOther "Place this change in the other changeSet and remove it from this side" | other cls sel | self checkThatSidesDiffer: [^self]. self okToChange ifFalse: [^Beeper beep]. currentSelector ifNotNil: [other := (parent other: self) changeSet. other == myChangeSet ifTrue: [^Beeper beep]. cls := self selectedClassOrMetaClass. sel := currentSelector asSymbol. other absorbMethod: sel class: cls from: myChangeSet. (parent other: self) showChangeSet: other. self forget "removes the method from this side"]! ! !ContextPart methodsFor: 'debugger access' stamp: 'nk 7/29/2004 10:09'! errorReportOn: strm "Write a detailed error report on the stack (above me) on a stream. For both the error file, and emailing a bug report. Suppress any errors while getting printStrings. Limit the length." | cnt aContext startPos | strm print: Date today; space; print: Time now; cr. strm cr. strm nextPutAll: 'VM: '; nextPutAll: SmalltalkImage current platformName asString; nextPutAll: ' - '; nextPutAll: SmalltalkImage current asString; cr. strm nextPutAll: 'Image: '; nextPutAll: SystemVersion current version asString; nextPutAll: ' ['; nextPutAll: SmalltalkImage current lastUpdateString asString; nextPutAll: ']'; cr. strm cr. SecurityManager default printStateOn: strm. "Note: The following is an open-coded version of ContextPart>>stackOfSize: since this method may be called during a low space condition and we might run out of space for allocating the full stack." cnt _ 0. startPos _ strm position. aContext _ self. [aContext notNil and: [(cnt _ cnt + 1) < 5]] whileTrue: [aContext printDetails: strm. "variable values" strm cr. aContext _ aContext sender]. strm cr; nextPutAll: '--- The full stack ---'; cr. aContext _ self. cnt _ 0. [aContext == nil] whileFalse: [cnt _ cnt + 1. cnt = 5 ifTrue: [strm nextPutAll: ' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -'; cr]. strm print: aContext; cr. "just class>>selector" strm position > (startPos+4000) ifTrue: [strm nextPutAll: '...etc...'. ^ self]. "exit early" cnt > 60 ifTrue: [strm nextPutAll: '-- and more not shown --'. ^ self]. aContext _ aContext sender]. ! ! !DummySoundSystem methodsFor: 'playing' stamp: 'nk 7/30/2004 17:52'! playSoundNamedOrBeep: soundName "There is no sound support, so we make the beep." ^Beeper beep! ! !FillInTheBlank class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 21:50'! multiLineRequest: queryString centerAt: aPoint initialAnswer: defaultAnswer answerHeight: answerHeight "Create a multi-line instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. Answer nil if the user cancels. An empty string returned means that the ussr cleared the editing area and then hit 'accept'. Because multiple lines are invited, we ask that the user use the ENTER key, or (in morphic anyway) hit the 'accept' button, to submit; that way, the return key can be typed to move to the next line. NOTE: The ENTER key does not work on Windows platforms." "FillInTheBlank multiLineRequest: 'Enter several lines; end input by accepting or canceling via menu or press Alt+s/Alt+l' centerAt: Display center initialAnswer: 'Once upon a time...' answerHeight: 200" | model fillInView | Smalltalk isMorphic ifTrue: [^self fillInTheBlankMorphClass request: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: self currentWorld onCancelReturn: nil acceptOnCR: false]. model := self new. model contents: defaultAnswer. model responseUponCancel: nil. model acceptOnCR: false. fillInView := self fillInTheBlankViewClass multiLineOn: model message: queryString centerAt: aPoint answerHeight: answerHeight. ^model show: fillInView! ! !FillInTheBlank class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 21:50'! request: queryString initialAnswer: defaultAnswer centerAt: aPoint "Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. Answer the empty string if the user cancels." "FillInTheBlank request: 'Type something, then type CR.' initialAnswer: 'yo ho ho!!' centerAt: Display center" | model fillInView | Smalltalk isMorphic ifTrue: [^self fillInTheBlankMorphClass request: queryString initialAnswer: defaultAnswer centerAt: aPoint]. model := self new. model contents: defaultAnswer. fillInView := self fillInTheBlankViewClass on: model message: queryString centerAt: aPoint. ^model show: fillInView! ! !FillInTheBlank class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 21:50'! requestPassword: queryString "Create an instance of me whose question is queryString. Invoke it centered at the cursor, and answer the string the user accepts. Answer the empty string if the user cancels." "FillInTheBlank requestPassword: 'POP password'" | model fillInView | Smalltalk isMorphic ifTrue: [^self fillInTheBlankMorphClass requestPassword: queryString]. model := self new. model contents: ''. fillInView := self fillInTheBlankViewClass requestPassword: model message: queryString centerAt: Sensor cursorPoint answerHeight: 40. ^model show: fillInView! ! !Flaps class methodsFor: 'predefined flaps' stamp: 'nk 7/29/2004 10:12'! newSqueakFlap "Answer a new default 'Squeak' flap for the left edge of the screen" | aFlap aFlapTab aButton aClock buttonColor anOffset bb aFont | aFlap _ PasteUpMorph newSticky borderWidth: 0. aFlapTab _ FlapTab new referent: aFlap. aFlapTab setName: 'Squeak' translated edge: #left color: Color brown lighter lighter. aFlapTab position: (0 @ ((Display height - aFlapTab height) // 2)). aFlapTab setBalloonText: aFlapTab balloonTextForFlapsMenu. aFlap cellInset: 14@14. aFlap beFlap: true. aFlap color: (Color brown muchLighter lighter "alpha: 0.3"). aFlap extent: 150 @ self currentWorld height. aFlap layoutPolicy: TableLayout new. aFlap wrapCentering: #topLeft. aFlap layoutInset: 2. aFlap listDirection: #topToBottom. aFlap wrapDirection: #leftToRight. "self addProjectNavigationButtonsTo: aFlap." anOffset _ 16. aClock _ ClockMorph newSticky. aClock color: Color red. aClock showSeconds: false. aClock font: (TextStyle default fontAt: 3). aClock step. aClock setBalloonText: 'The time of day. If you prefer to see seconds, check out my menu.' translated. aFlap addCenteredAtBottom: aClock offset: anOffset. buttonColor _ Color cyan muchLighter. bb _ SimpleButtonMorph new target: SmalltalkImage current. bb color: buttonColor. aButton _ bb copy. aButton actionSelector: #saveSession. aButton setBalloonText: 'Make a complete snapshot of the current state of the image onto disk.' translated. aButton label: 'save' translated font: (aFont _ ScriptingSystem fontForTiles). aFlap addCenteredAtBottom: aButton offset: anOffset. aButton _ bb copy target: Utilities. aButton actionSelector: #updateFromServer. aButton label: 'load code updates' translated font: aFont. aButton color: buttonColor. aButton setBalloonText: 'Check the Squeak server for any new code updates, and load any that are found.' translated. aFlap addCenteredAtBottom: aButton offset: anOffset. aButton _ SimpleButtonMorph new target: SmalltalkImage current; actionSelector: #aboutThisSystem; label: 'about this system' translated font: aFont. aButton color: buttonColor. aButton setBalloonText: 'click here to find out version information' translated. aFlap addCenteredAtBottom: aButton offset: anOffset. aFlap addCenteredAtBottom: (Preferences themeChoiceButtonOfColor: buttonColor font: aFont) offset: anOffset. aButton _ TrashCanMorph newSticky. aFlap addCenteredAtBottom: aButton offset: anOffset. aButton startStepping. ^ aFlapTab "Flaps replaceGlobalFlapwithID: 'Squeak' translated "! ! !FlashCodec class methodsFor: 'compressing' stamp: 'nk 7/30/2004 21:51'! compressPoints: points ^(self new compressPoints: points) contents! ! !Form methodsFor: 'resources' stamp: 'nk 7/30/2004 17:53'! readResourceFrom: aStream "Store a resource representation of the receiver on aStream. Must be specific to the receiver so that no code is filed out." | bitsSize msb | (aStream next: 4) asString = self resourceTag ifFalse: [aStream position: aStream position - 4. ^self readNativeResourceFrom: aStream]. width := aStream nextNumber: 4. height := aStream nextNumber: 4. depth := aStream nextNumber: 4. bitsSize := aStream nextNumber: 4. bitsSize = 0 ifFalse: [bits := aStream next: bitsSize. ^self]. msb := (aStream nextNumber: 4) = 1. bitsSize := aStream nextNumber: 4. bits := Bitmap new: self bitsSize. (Form extent: width @ height depth: depth bits: (aStream next: bitsSize * 4)) displayOn: self. msb = SmalltalkImage current isBigEndian ifFalse: [Bitmap swapBytesIn: bits from: 1 to: bits size]! ! !GIFReadWriter class methodsFor: 'examples' stamp: 'nk 7/30/2004 21:40'! grabScreenAndSaveOnDisk "GIFReaderWriter grabScreenAndSaveOnDisk" | form fileName | form := Form fromUser. form bits size = 0 ifTrue: [^Beeper beep]. fileName := FileDirectory default nextNameFor: 'Squeak' extension: 'gif'. Utilities informUser: 'Writing ' , fileName during: [GIFReadWriter putForm: form onFileNamed: fileName]! ! !GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'nk 7/29/2004 10:10'! timeStamp "Append the current time to the receiver as a String." self bufferStream nextChunkPut: "double string quotes and !!s" (String streamContents: [:s | SmalltalkImage current timeStamp: s]) printString. self bufferStream cr! ! !MPEGFile class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 21:50'! openFile: aPath ^self new openFile: aPath! ! !MacFileDirectoryTest methodsFor: 'test' stamp: 'nk 7/30/2004 17:54'! testMacFileFullPathFor "(self run: #testMacFileFullPathFor)" SmalltalkImage current platformName = 'Mac OS' ifTrue: [self assert: (MacFileDirectory isAbsolute: (FileDirectory default fullPathFor: FileDirectory default fullName)). self deny: (MacFileDirectory isAbsolute: (FileDirectory on: 'Data') pathName)]! ! !MailMessage class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 18:08'! empty "return a message with no text and no header" ^self new! ! !MonthMorph methodsFor: 'controls' stamp: 'nk 7/30/2004 17:54'! startMondayOrSundayString ^(Week startDay ifTrue: ['start Sunday'] ifFalse: ['start Monday']) translated! ! !MonthTest methodsFor: 'Tests' stamp: 'nk 7/30/2004 17:52'! testEnumerating | weeks | weeks := OrderedCollection new. month eachWeekDo: [:w | weeks add: w firstDate]. 0 to: 4 do: [:i | weeks remove: (Week starting: ('29 June 1998' asDate addDays: i * 7)) firstDate]. self assert: weeks isEmpty! ! !MonthTest methodsFor: 'Tests' stamp: 'nk 7/30/2004 17:52'! testInstanceCreation | m1 m2 | m1 := Month starting: '4 July 1998' asDate. m2 := Month month: #July year: 1998. self assert: month = m1; assert: month = m2! ! !MorphWorldView class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 21:52'! convertToMVCWiWPasteUpMorph " MorphWorldView convertToMVCWiWPasteUpMorph " | current w newModel topView | Smalltalk isMorphic ifTrue: [^self inform: 'do this in MVC']. current := self allInstances select: [:each | each model class == PasteUpMorph]. current do: [:oldWorldView | w := MVCWiWPasteUpMorph newWorldForProject: nil. w color: oldWorldView model color; addAllMorphs: oldWorldView model submorphs. newModel := CautiousModel new initialExtent: 300 @ 300. topView := self fullColorWhenInactive ifTrue: [ColorSystemView new] ifFalse: [StandardSystemView new]. topView model: newModel; label: oldWorldView topView label; borderWidth: 1; addSubView: (self new model: w); backgroundColor: w color. topView controller openNoTerminate. topView reframeTo: (oldWorldView topView expandedFrame expandBy: (0 @ 0 extent: 0 @ topView labelHeight)). oldWorldView topView controller closeAndUnscheduleNoTerminate]. ScheduledControllers restore. Processor terminateActive! ! !MorphWorldView class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 22:37'! openOn: aWorldMorph label: aString model: aModel "Open a view with the given label on the given WorldMorph." | topView | topView := self fullColorWhenInactive ifTrue: [topView := ColorSystemView new] ifFalse: [topView := StandardSystemView new]. topView model: aModel; label: aString; borderWidth: 1; addSubView: (self new model: aWorldMorph); backgroundColor: aWorldMorph color. "minimumSize: aWorldMorph extent + (2@2); " "add border width" topView controller open! ! !PNGReadWriter methodsFor: 'accessing' stamp: 'nk 7/30/2004 17:51'! nextImage bigEndian := SmalltalkImage current isBigEndian. filtersSeen := Bag new. globalDataChunk := nil. transparentPixelValue := nil. unknownChunks := Set new. stream reset. stream binary. stream skip: 8. [stream atEnd] whileFalse: [self processNextChunk]. "Set up our form" palette ifNotNil: ["Dump the palette if it's the same as our standard palette" palette = (StandardColors copyFrom: 1 to: palette size) ifTrue: [palette := nil]]. (depth <= 8 and: [palette notNil]) ifTrue: [form := ColorForm extent: width @ height depth: depth. form colors: palette] ifFalse: [form := Form extent: width @ height depth: depth]. backColor ifNotNil: [form fillColor: backColor]. chunk := globalDataChunk ifNil: [self error: 'image data is missing']. chunk ifNotNil: [self processIDATChunk]. unknownChunks isEmpty ifFalse: ["Transcript show: ' ',unknownChunks asSortedCollection asArray printString." ]. self debugging ifTrue: [Transcript cr; show: 'form = ' , form printString. Transcript cr; show: 'colorType = ' , colorType printString. Transcript cr; show: 'interlaceMethod = ' , interlaceMethod printString. Transcript cr; show: 'filters = ' , filtersSeen sortedCounts asArray printString]. ^form! ! !PNGReadWriter methodsFor: 'writing' stamp: 'nk 7/30/2004 17:51'! nextPutImage: aForm interlace: aMethod filter: aFilterType "Note: For now we keep it simple - interlace and filtering are simply ignored" | crcStream | bigEndian := SmalltalkImage current isBigEndian. form := aForm. width := aForm width. height := aForm height. aForm depth <= 8 ifTrue: [bitsPerChannel := aForm depth. colorType := 3. bytesPerScanline := (width * aForm depth + 7) // 8] ifFalse: [bitsPerChannel := 8. colorType := 6. bytesPerScanline := width * 4]. self writeFileSignature. crcStream := WriteStream on: (ByteArray new: 1000). crcStream resetToStart. self writeIHDRChunkOn: crcStream. self writeChunk: crcStream. form depth <= 8 ifTrue: [crcStream resetToStart. self writePLTEChunkOn: crcStream. self writeChunk: crcStream. form isColorForm ifTrue: [crcStream resetToStart. self writeTRNSChunkOn: crcStream. self writeChunk: crcStream]]. form depth = 16 ifTrue: [crcStream resetToStart. self writeSBITChunkOn: crcStream. self writeChunk: crcStream]. crcStream resetToStart. self writeIDATChunkOn: crcStream. self writeChunk: crcStream. crcStream resetToStart. self writeIENDChunkOn: crcStream. self writeChunk: crcStream! ! !PRServerDirectory methodsFor: 'private' stamp: 'nk 7/29/2004 10:02'! putSmalltalkInfoInto: args "private - fills args with information from Smalltalk" self flag: #todo. " lastest small-land changeset / small-land version " #(#datedVersion #osVersion #platformName #platformSubtype #vmPath #vmVersion #imageName #changesName #sourcesName #listBuiltinModules #listLoadedModules #getVMParameters ) do: [:each | | value | value := SmalltalkImage current perform: each. args at: 'extra-' , each asString put: {value asString}]! ! !PluggableListMorph methodsFor: 'selection' stamp: 'nk 7/30/2004 17:53'! selectedMorph: aMorph "this shouldn't be used any longer" "self isThisEverCalled ." Beeper beep. true ifTrue: [^self]! ! !PluggableTest class methodsFor: 'example' stamp: 'nk 7/30/2004 21:50'! open "PluggableTest open" | model listView1 topView listView2 | model := self new. listView1 := PluggableListView on: model list: #musicTypeList selected: #musicType changeSelected: #musicType: menu: #musicTypeMenu: keystroke: #musicTypeKeystroke:. listView1 menuTitleSelector: #musicTypeListTitle. listView2 := PluggableListView on: model list: #artistList selected: #artist changeSelected: #artist: menu: nil keystroke: #artistKeystroke:. topView := (StandardSystemView new) label: 'Pluggable Test'; minimumSize: 300 @ 200; borderWidth: 1; addSubView: listView1; addSubView: listView2 toRightOf: listView1. topView borderWidth: 1. topView controller open! ! !Preferences class methodsFor: 'personalization' stamp: 'nk 7/30/2004 21:45'! disableProgrammerFacilities "Warning: do not call this lightly!! It disables all access to menus, debuggers, halos. There is no guaranteed return from this, which is to say, you cannot necessarily reenable these things once they are disabled -- you can only use whatever the UI of the current project affords, and you cannot even snapshot -- you can only quit. You can completely reverse the work of this method by calling the dual Preferences method enableProgrammerFacilities, provided you have left yourself leeway to bring about a call to that method. To set up a system that will come up in such a state, you have to request the snapshot in the same breath as you disable the programmer facilities. To do this, put the following line into the 'do' menu and then evaluate it from that 'do' menu: Preferences disableProgrammerFacilities. You will be prompted for a new image name under which to save the resulting image." Beeper beep. (self confirm: 'CAUTION!!!! This is a drastic step!! Do you really want to do this?') ifFalse: [Beeper beep. ^self inform: 'whew!!']. self disable: #cmdDotEnabled. "No user-interrupt-into-debugger" self compileHardCodedPref: #cmdGesturesEnabled enable: false. "No halos, etc." self compileHardCodedPref: #cmdKeysInText enable: false. "No user commands invokable via cmd-key combos in text editor" self enable: #noviceMode. "No control-menu" self disable: #warnIfNoSourcesFile. self disable: #warnIfNoChangesFile. SmalltalkImage current saveAs! ! !Preferences class methodsFor: 'personalization' stamp: 'nk 7/29/2004 10:12'! personalizeUserMenu: aMenu "The user has clicked on the morphic desktop with the yellow mouse button (option+click on the Mac); a menu is being constructed to present to the user in response; its default target is the current world. In this method, you are invited to add items to the menu as per personal preferences. The default implementation, for illustrative purposes, sets the menu title to 'personal', and adds items for go-to-previous-project, show/hide flaps, and load code updates" aMenu addTitle: 'personal' translated. "Remove or modify this as per personal choice" aMenu addStayUpItem. aMenu add: 'previous project' translated action: #goBack. aMenu add: 'load latest code updates' translated target: Utilities action: #updateFromServer. aMenu add: 'about this system...' translated target: SmalltalkImage current action: #aboutThisSystem. Preferences isFlagship ifTrue: "For benefit of Alan" [aMenu addLine. aMenu add: 'start using vectors' translated target: ActiveWorld action: #installVectorVocabulary. aMenu add: 'stop using vectors' translated target: ActiveWorld action: #abandonVocabularyPreference]. aMenu addLine. aMenu addUpdating: #suppressFlapsString target: CurrentProjectRefactoring action: #currentToggleFlapsSuppressed. aMenu balloonTextForLastItem: 'Whether prevailing flaps should be shown in the project right now or not.' translated! ! !Project methodsFor: 'file in/out' stamp: 'nk 7/30/2004 17:52'! storeSomeSegment "Try all projects to see if any is ready to go out. Send at most three of them. Previous one has to wait for a garbage collection before it can go out." | cnt pList start proj gain | cnt := 0. gain := 0. pList := Project allProjects. start := pList size atRandom. "start in a random place" start to: pList size + start do: [:ii | proj := pList atWrap: ii. proj storeSegment ifTrue: ["Yes, did send its morphs to the disk" gain := gain + (proj projectParameters at: #segmentSize ifAbsent: [0]). "a guess" Beeper beep. (cnt := cnt + 1) >= 2 ifTrue: [^gain]]]. Beeper beep. ^gain! ! !ProjectHistory class methodsFor: 'as yet unclassified' stamp: 'nk 7/30/2004 21:51'! currentHistory ^CurrentHistory ifNil: [CurrentHistory := self new]! ! !Random class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 21:51'! seed: anInteger ^self new seed: anInteger! ! !RemoteControlledHandMorph class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 18:10'! on: aDecoder ^self new decoder: aDecoder! ! !ResourceManager methodsFor: 'backward-compatibility' stamp: 'nk 7/30/2004 21:46'! convertMapNameForBackwardcompatibilityFrom: aString (SmalltalkImage current platformName = 'Mac OS' and: ['10*' match: SmalltalkImage current osVersion]) ifTrue: [^aString convertFromWithConverter: ShiftJISTextConverter new]. ^aString convertFromSystemString! ! !SMLoader methodsFor: 'filters' stamp: 'nk 7/30/2004 17:55'! filterVersion "Ignore spaces in the version string, they're sometimes spurious. Not used anymore." ^ [:package | package categories anySatisfy: [:cat | cat name , '*' match: (SystemVersion current version copyWithout: $ )]]! ! !SMObject class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 10:57'! newIn: aMap "Create a new object in a given map with an UUID to ensure unique identity." ^(self new) map: aMap id: UUID new! ! !SMObject class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 10:56'! newIn: aMap withId: anUUIDString "Create a new object in a given SMSqueakMap with a given UUID as a String. This method is used when we create instances from a logfile etc." ^(self new) map: aMap id: (UUID fromString: anUUIDString)! ! !SMSqueakMap methodsFor: 'private-installation' stamp: 'nk 7/30/2004 17:53'! noteUninstalledPackageWithId: aPackageId autoVersion: aVersion name: aName "The package release was just successfully uninstalled. Can be used to inform SM of an uninstallation not been done using SM, even when the map isn't loaded. We record the fact in our Dictionary of installed packages and log a 'do it' to mark this in the changelog. The doit helps keeping track of the packages when recovering changes etc - not a perfect solution but should help. The map used is the default map. The id of the package is the key and the value is an OrderedCollection of Arrays with the release auto version, the point in time and the current installCounter." | time name id v | v := aVersion isString ifTrue: [aVersion asVersion] ifFalse: [aVersion]. aName ifNil: [name := ''] ifNotNil: [name := aName]. id := UUID fromString: aPackageId. time := Time totalSeconds. self countInstall. "Used for both installs and uninstalls" self clearInstalled: id version: v time: time counter: installCounter. SmalltalkImage current logChange: '"Uninstalled ' , name , ' auto version ' , v versionString , '". (Smalltalk at: #SMSqueakMap ifAbsent: []) ifNotNil:[ SMSqueakMap noteUninstalledPackageWithId: ' , id asString storeString , ' autoVersion: ' , v storeString , ' atSeconds: ' , time asString , ' number: ' , installCounter asString , ']'! ! !ScreenController methodsFor: 'menu messages' stamp: 'nk 7/29/2004 10:12'! aboutThisSystem SmalltalkImage current aboutThisSystem! ! !SecurityManager class methodsFor: 'class initialization' stamp: 'nk 7/30/2004 21:50'! initialize "SecurityManager initialize" "Order: ExternalSettings, SecurityManager, AutoStart" Default := self new. Smalltalk addToStartUpList: self after: ExternalSettings. Smalltalk addToShutDownList: self! ! !SecurityManager class methodsFor: 'accessing' stamp: 'nk 7/30/2004 21:50'! default ^Default ifNil: [Default := self new]! ! !SketchMorph methodsFor: 'e-toy support' stamp: 'nk 7/30/2004 17:51'! acquirePlayerSimilarTo: aSketchMorphsPlayer "Retrofit into the receiver a player derived from the existing scripted player of a different morph. Works only between SketchMorphs. Maddeningly complicated by potential for transformations or native sketch-morph scaling in donor or receiver or both" | myName myTop itsTop newTop newSketch | myTop := self topRendererOrSelf. aSketchMorphsPlayer belongsToUniClass ifFalse: [^Beeper beep]. itsTop := aSketchMorphsPlayer costume. (itsTop renderedMorph isKindOf: SketchMorph) ifFalse: [^Beeper beep]. newTop := itsTop veryDeepCopy. "May be a sketch or a tranformation" myName := myTop externalName. "Snag before the replacement is added to the world, because otherwise that could affect this" newSketch := newTop renderedMorph. newSketch form: self form. newSketch scalePoint: self scalePoint. newSketch bounds: self bounds. myTop owner addMorph: newTop after: myTop. newTop heading ~= myTop heading ifTrue: ["avoids annoying round-off error in what follows" newTop player setHeading: myTop heading]. (newTop isFlexMorph and: [myTop == self]) ifTrue: [newTop removeFlexShell]. newTop := newSketch topRendererOrSelf. newTop bounds: self bounds. (newTop isFlexMorph and: [myTop isFlexMorph]) ifTrue: ["Note: This completely dumps the above #bounds: information. We need to recompute the bounds based on the transform." newTop transform: myTop transform copy. newTop computeBounds]. newTop setNameTo: myName. newTop player class bringScriptsUpToDate. myTop delete! ! !SmalltalkImage methodsFor: 'sources, changes log' stamp: 'nk 7/29/2004 10:03'! datedVersion "Answer the version of this release." ^SystemVersion current datedVersion! ! !SmalltalkImage methodsFor: 'sources, changes log' stamp: 'nk 7/29/2004 10:05'! lastUpdateString "SmalltalkImage current lastUpdateString" ^'latest update: #', SystemVersion current highestUpdate printString! ! !SmalltalkImage methodsFor: 'sources, changes log' stamp: 'nk 7/30/2004 17:57'! 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: [^Smalltalk]. 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) asSqueakPathName. 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! ! !SmalltalkImage methodsFor: 'sources, changes log' stamp: 'nk 7/29/2004 10:09'! systemInformationString "Identify software version" ^ SystemVersion current version, String cr, self lastUpdateString, String cr, self currentChangeSetString " (eToySystem _ self at: #EToySystem ifAbsent: [nil]) ifNotNil: [aString _ aString, ' Squeak-Central version: ', eToySystem version, ' of ', eToySystem versionDate]."! ! !SmalltalkImage methodsFor: 'sources, changes log' stamp: 'nk 7/29/2004 10:09'! timeStamp: aStream "Writes system version and current time on stream aStream." | dateTime | dateTime _ Time dateAndTimeNow. aStream nextPutAll: 'From ', SmalltalkImage current datedVersion, ' [', SmalltalkImage current lastUpdateString, '] on ', (dateTime at: 1) printString, ' at ', (dateTime at: 2) printString! ! !SmartRefStream methodsFor: 'class changed shape' stamp: 'nk 7/29/2004 10:10'! writeConversionMethodIn: newClass fromInstVars: oldList to: newList renamedFrom: oldName "The method convertToCurrentVersion:refStream: was not found in newClass. Write a default conversion method for the author to modify. If method exists, append new info into the end." | code newOthers oldOthers copied newCode | newOthers _ newList asOrderedCollection "copy". oldOthers _ oldList asOrderedCollection "copy". copied _ OrderedCollection new. newList do: [:instVar | (oldList includes: instVar) ifTrue: [ instVar isInteger ifFalse: [copied add: instVar]. newOthers remove: instVar. oldOthers remove: instVar]]. code _ WriteStream on: (String new: 500). code cr; cr; tab; nextPutAll: '"From ', SystemVersion current version, ' [', SmalltalkImage current lastUpdateString; nextPutAll: '] on ', Date today printString, '"'; cr. code tab; nextPutAll: '"These variables are automatically stored into the new instance: '. code nextPutAll: copied asArray printString; nextPut: $.; cr. code tab; nextPutAll: 'Test for this particular conversion.'; nextPutAll: ' Get values using expressions like (varDict at: ''foo'')."'; cr; cr. (newOthers size = 0) & (oldOthers size = 0) & (oldName == nil) ifTrue: [^ self]. "Instance variables are the same. Only the order changed. No conversion needed." (newOthers size > 0) ifTrue: [ code tab; nextPutAll: '"New variables: ', newOthers asArray printString, '. If a non-nil value is needed, please assign it."'; cr]. (oldOthers size > 0) ifTrue: [ code tab; nextPutAll: '"These are going away ', oldOthers asArray printString, '. Possibly store their info in some other variable?"'; cr]. oldName ifNotNil: [ code tab; nextPutAll: '"Test for instances of class ', oldName, '.'; cr. code tab; nextPutAll: 'Instance vars with the same name have been moved here."'; cr. ]. code tab; nextPutAll: '"Move your code above the ^ super... Delete extra comments."'; cr. (newClass includesSelector: #convertToCurrentVersion:refStream:) ifTrue: ["append to old methods" newCode _ (newClass sourceCodeAt: #convertToCurrentVersion:refStream:), code contents] ifFalse: ["new method" newCode _ 'convertToCurrentVersion: varDict refStream: smartRefStrm', code contents, ' ^ super convertToCurrentVersion: varDict refStream: smartRefStrm']. newClass compile: newCode classified: 'object fileIn'. "If you write a conversion method beware that the class may need a version number change. This only happens when two conversion methods in the same class have the same selector name. (A) The inst var lists of the new and old versions intials as some older set of new and old inst var lists. or (B) Twice in a row, the class needs a conversion method, but the inst vars stay the same the whole time. (For an internal format change.) If either is the case, fileouts already written with the old (wrong) version number, say 2. Your method must be able to read files that say version 2 but are really 3, until you expunge the erroneous version 2 files from the universe." ! ! !StandardSourceFileArray class methodsFor: 'initialize-release' stamp: 'nk 7/30/2004 21:50'! install "Replace SourceFiles by an instance of me with the standard sources and changes files. This only works if SourceFiles is either an Array or an instance of this class" "StandardSourceFileArray install" SourceFiles := self new! ! !StrikeFontFixer class methodsFor: 'as yet unclassified' stamp: 'nk 7/30/2004 18:09'! newOn: aStrikeFont ^self new font: aStrikeFont! ! !Symbol class methodsFor: 'class initialization' stamp: 'nk 7/29/2004 10:10'! compareTiming " Symbol compareTiming " | answer t selectorList implementorLists flattenedList md | answer _ WriteStream on: String new. SmalltalkImage current timeStamp: answer. answer cr; cr. answer nextPutAll: MethodDictionary instanceCount printString , ' method dictionaries'; cr; cr. answer nextPutAll: (MethodDictionary allInstances inject: 0 into: [:sum :each | sum + each size]) printString , ' method dictionary entries'; cr; cr. md _ MethodDictionary allInstances. t _ [100 timesRepeat: [md do: [:each | each includesKey: #majorShrink]]] timeToRun. answer nextPutAll: t printString , ' ms to check all method dictionaries for #majorShrink 1000 times'; cr; cr. selectorList _ Symbol selectorsContaining: 'help'. t _ [3 timesRepeat: [selectorList collect: [:each | self systemNavigation allImplementorsOf: each]]] timeToRun. answer nextPutAll: t printString , ' ms to do #allImplementorsOf: for ' , selectorList size printString , ' selectors like *help* 3 times'; cr; cr. t _ [3 timesRepeat: [selectorList do: [:eachSel | md do: [:eachMd | eachMd includesKey: eachSel]]]] timeToRun. answer nextPutAll: t printString , ' ms to do #includesKey: for ' , md size printString , ' methodDicts for ' , selectorList size printString , ' selectors like *help* 3 times'; cr; cr. #('help' 'majorShrink' ) do: [:substr | answer nextPutAll: (Symbol selectorsContaining: substr) size printString , ' selectors containing "' , substr , '"'; cr. t _ [3 timesRepeat: [selectorList _ Symbol selectorsContaining: substr]] timeToRun. answer nextPutAll: t printString , ' ms to find Symbols containing *' , substr , '* 3 times'; cr. t _ [3 timesRepeat: [selectorList _ Symbol selectorsContaining: substr. implementorLists _ selectorList collect: [:each | Smalltalk allImplementorsOf: each]. flattenedList _ SortedCollection new. implementorLists do: [:each | flattenedList addAll: each]]] timeToRun. answer nextPutAll: t printString , ' ms to find implementors of *' , substr , '* 3 times'; cr; cr]. StringHolder new contents: answer contents; openLabel: 'timing'! ! !TTCFont class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 21:51'! newTextStyleFromTT: description "Create a new TextStyle from specified TTFontDescription instance." | array f | array := self pointSizes collect: [:pt | f := self new. f ttcDescription: description. f pointSize: pt]. ^self reorganizeForNewFontArray: array name: array first name asSymbol! ! !TheWorldMenu methodsFor: 'construction' stamp: 'nk 7/29/2004 10:13'! helpMenu "Build the help menu for the world." | menu | menu := self menu: 'help...' translated. self fillIn: menu from: { {'about this system...'. {SmalltalkImage current. #aboutThisSystem}. 'current version information.'}. {'update code from server'. {Utilities. #updateFromServer}. 'load latest code updates via the internet'}. {'preferences...'. {Preferences. #openPreferencesInspector}. 'view and change various options.'}. {'set language...' . {Project. #chooseNaturalLanguage}. 'choose the language in which tiles should be displayed.'} . nil. {'command-key help'. { Utilities . #openCommandKeyHelp}. 'summary of keyboard shortcuts.'} }. self addGestureHelpItemsTo: menu. self fillIn: menu from: { {'world menu help'. { self . #worldMenuHelp}. 'helps find menu items buried in submenus.'}. "{'info about flaps' . { Utilities . #explainFlaps}. 'describes how to enable and use flaps.'}." {'font size summary' . { TextStyle . #fontSizeSummary}. 'summary of names and sizes of available fonts.'}. {'useful expressions' . { Utilities . #openStandardWorkspace}. 'a window full of useful expressions.'}. {'annotation setup...' . { Preferences . #editAnnotations}. 'Click here to get a little window that will allow you to specify which types of annotations, in which order, you wish to see in the annotation panes of browsers and other tools'}. nil. {'graphical imports' . { Imports default . #viewImages}. 'view the global repository called ImageImports; you can easily import external graphics into ImageImports via the FileList'}. {'standard graphics library' . { ScriptingSystem . #inspectFormDictionary}. 'lets you view and change the system''s standard library of graphics.'}. nil. {'telemorphic...' . {self. #remoteDo}. 'commands for doing multi-machine "telemorphic" experiments'}. {#soundEnablingString . { Preferences . #toggleSoundEnabling}. 'turning sound off will completely disable Squeak''s use of sound.'}. {'definition for...' . { Utilities . #lookUpDefinition}. 'if connected to the internet, use this to look up the definition of an English word.'}. nil. {'set author initials...' . { Utilities . #setAuthorInitials }. 'supply initials to be used to identify the author of code and other content.'}. {'vm statistics' . { self . #vmStatistics}. 'obtain some intriguing data about the vm.'}. nil. {'purge undo records' . { CommandHistory . #resetAllHistory }. 'save space by removing all the undo information remembered in all projects.'}. {'space left' . { self . #garbageCollect}. 'perform a full garbage-collection and report how many bytes of space remain in the image.'}. }. ^menu ! ! !ThreadNavigationMorph methodsFor: 'navigation' stamp: 'nk 7/30/2004 21:47'! navigateFromKeystroke: aChar "A character was typed in an effort to do interproject navigation along the receiver's thread" | ascii | ascii := aChar asciiValue. (#(29 31 32) includes: ascii) ifTrue: [^self nextPage]. "right arrow, down arrow, space" (#(8 28 30) includes: ascii) ifTrue: [^self previousPage]. "left arrow, up arrow, backspace" (#(1) includes: ascii) ifTrue: [^self firstPage]. (#(4) includes: ascii) ifTrue: [^self lastPage]. Beeper beep! ! !UUID class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 21:49'! new ^(self new: 16)! ! !UUIDGenerator class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 21:51'! generateDefault Default := self new! ! !UnhandledError methodsFor: 'priv handling' stamp: 'nk 7/29/2004 10:10'! runtimeDefaultAction "Dump the stack trace to a log file, then exit the program (image)." | file | file := FileStream newFileNamed: ('error', Utilities dateTimeSuffix, FileDirectory dot, 'log') asFileName. SmalltalkImage current timeStamp: file. (thisContext sender stackOfSize: 20) do: [:ctx | file cr. ctx printOn: file]. file close. SmalltalkImage current snapshot: false andQuit: true! ! !Vocabulary class methodsFor: 'eToy vocabularies' stamp: 'nk 7/29/2004 10:15'! newSystemVocabulary "Answer a Vocabulary object representing significant requests one can make to the Smalltalk object" | aVocabulary | aVocabulary _ self new. aVocabulary vocabularyName: #System. aVocabulary documentation: 'Useful messages you might want to send to the current Smalltalk image'. aVocabulary initializeFromTable: #( (aboutThisSystem none () none (basic queries) 'put up a message describing the system' unused) (saveAsNewVersion none () none (services) 'advance to the next available image-version number and save the image under that new name' unused znak) (datedVersion none () String (queries) 'the version of the Squeak system') (endianness none () String (queries) 'big or little - the byte-ordering of the hardware Squeak is currently running on') (exitToDebugger none () none (dangerous) 'exits to the host debugger. Do not use this -- I guarantee you will be sorry.') (bytesLeft none () Number (basic services) 'perform a garbage collection and answer the number of bytes of free space remaining in the system') "(browseAllCallsOn: none ((aSelector String)) none (#'queries') 'browse all calls on a selector') (browseAllImplementorsOf: none ((aSelector String)) none (#'queries') 'browse all implementors of a selector')" "(allMethodsWithSourceString:matchCase: none ((aString String) (caseSensitive Boolean)) none (queries) 'browse all methods that have the given source string, making the search case-sensitive or not depending on the argument provided.') (browseMethodsWithString:matchCase: none ((aString String) (caseSensitive Boolean)) none (queries) 'browse all methods that contain the given string in any string literal, making the search case-sensitive or not depending on the argument provided.') (browseAllImplementorsOf:localTo: none ((aSelector String) (aClass Class)) none (#'queries') 'browse all implementors of a selector that are local to a class')" ). "(isKindOf: none ((aClass Class)) Boolean (#'class membership') 'answer whether the receiver''s superclass chain includes aClass')" ^ aVocabulary "Vocabulary initialize" "Vocabulary addStandardVocabulary: Vocabulary newSystemVocabulary" "SmalltalkImage current basicInspect" "SmalltalkImage current beViewed" ! ! !WeekTest methodsFor: 'Tests' stamp: 'nk 7/30/2004 17:52'! testPreviousNext self assert: week next = (Week starting: '6 July 1998' asDate); assert: week previous = (Week starting: '22 June 1998' asDate)! ! !WeekTest methodsFor: 'Running' stamp: 'nk 7/30/2004 21:47'! setUp "June 1998, 5th week" super setUp. Week startDay ifFalse: [Week startDay]. week := Week starting: '4 July 1998' asDate! ! !WriteStream methodsFor: 'fileIn/Out' stamp: 'nk 7/29/2004 10:11'! timeStamp "Append the current time to the receiver as a String." self nextChunkPut: "double string quotes and !!s" (String streamContents: [:s | SmalltalkImage current timeStamp: s]) printString. self cr! ! TestRunner class removeSelector: #new! TestResource class removeSelector: #new! SystemDictionary removeSelector: #aboutThisSystem! SystemDictionary removeSelector: #datedVersion! SystemDictionary removeSelector: #lastUpdateString! SystemDictionary removeSelector: #systemInformationString! SystemDictionary removeSelector: #timeStamp:! SecurityManager initialize! SARInstaller class removeSelector: #new! CompoundTextConverter class removeSelector: #new!