'From Squeak5.0 of 20 July 2015 [latest update: #15110] on 20 July 2015 at 4:14:07 pm'! ReleaseBuilder prepareNewRelease! ----QUIT----{20 July 2015 . 4:14:16 pm} Squeak5.0-15110.image priorSource: 0! ----STARTUP----{23 July 2015 . 4:29:16 am} as /home/pi/Downloads/Squeak-5.0-All-in-One/Squeak-5.0-All-in-One.app/Contents/Resources/Squeak5.0-15110.image! ----QUIT/NOSAVE----{23 July 2015 . 4:29:25 am} Squeak5.0-15110.image priorSource: 123! ----STARTUP----{23 July 2015 . 4:35:21 am} as /home/pi/Downloads/Squeak-5.0-All-in-One/Squeak-5.0-All-in-One.app/Contents/Resources/Squeak5.0-15110.image! ----QUIT/NOSAVE----{23 July 2015 . 4:35:54 am} Squeak5.0-15110.image priorSource: 123! ----STARTUP----{23 July 2015 . 10:39:38 pm} as /home/cmm/Chris/dev/Squeak/Squeak-5.0-All-in-One/Squeak-5.0-All-in-One.app/Contents/Resources/Squeak5.0-15110.image! ----QUIT/NOSAVE----{23 July 2015 . 10:39:42 pm} Squeak5.0-15110.image priorSource: 123! ----STARTUP----{24 July 2015 . 10:37:42 am} as /home/cmm/Chris/dev/Squeak/Squeak-5.0-All-in-One/Squeak-5.0-All-in-One.app/Contents/Resources/Squeak5.0-15110.image! SystemOrganization addCategory: #UserObjects! ----QUIT----{24 July 2015 . 10:39:02 am} Squeak5.0-15110.image priorSource: 123! ----STARTUP----{24 July 2015 . 10:39:16 am} as /home/cmm/Chris/dev/Squeak/Squeak-5.0-All-in-One/Squeak-5.0-All-in-One.app/Contents/Resources/Squeak5.0-15110.image! FileList initialize! ----QUIT----{24 July 2015 . 10:39:36 am} Squeak5.0-15110.image priorSource: 1160! ----STARTUP----{24 July 2015 . 10:39:44 am} as /home/cmm/Chris/dev/Squeak/Squeak-5.0-All-in-One/Squeak-5.0-All-in-One.app/Contents/Resources/Squeak5.0-15110.image! MCFileBasedRepository flushAllCaches.! ----QUIT----{24 July 2015 . 10:39:56 am} Squeak5.0-15110.image priorSource: 1430! ----STARTUP----{24 July 2015 . 10:46:41 am} as /home/cmm/Chris/dev/Squeak/Squeak-5.0-All-in-One/Squeak-5.0-All-in-One.app/Contents/Resources/Squeak5.0-15110.image! ----QUIT----{24 July 2015 . 10:48 am} Squeak5.0-15110.image priorSource: 1719! ----STARTUP----{24 July 2015 . 1:16:20 pm} as /home/cmm/Chris/dev/Squeak/Squeak5.0-15110.image! ----QUIT/NOSAVE----{24 July 2015 . 3:04:34 pm} Squeak5.0-15110.image priorSource: 1968! ----STARTUP----{28 July 2015 . 2:21:53 pm} as /home/cmm/Chris/dev/Squeak/Squeak5.0-15110.image! ----QUIT/NOSAVE----{28 July 2015 . 2:21:59 pm} Squeak5.0-15110.image priorSource: 1968! ----STARTUP----{2 August 2015 . 10:17:39 pm} as /home/cmm/Chris/dev/Squeak/Squeak5.0-15110.image! ----QUIT/NOSAVE----{3 August 2015 . 1:31:21 am} Squeak5.0-15110.image priorSource: 1968! ----STARTUP----{5 August 2015 . 4:08:17 pm} as /home/cmm/Chris/dev/Squeak/Squeak5.0-15110.image! Display extent! ----STARTUP----{6 August 2015 . 10:23:48 am} as /home/cmm/Chris/dev/Squeak/Squeak5.0-15110.image! !CompiledMethod methodsFor: '*Kernel-tool support' stamp: 'cmm 8/5/2015 19:59' prior: 31510441! hasBreakpoint ^ self class environment at: #BreakpointManager ifPresent: [:bpm | bpm methodHasBreakpoint: self] ifAbsent: [false]! ! "Kernel"! !CompiledMethod methodsFor: '*Kernel-tool support' stamp: 'cmm 8/5/2015 19:59' prior: 33557358! hasBreakpoint ^ self class environment at: #BreakpointManager ifPresent: [:bpm | bpm methodHasBreakpoint: self] ifAbsent: [false]! ! !ReleaseBuilder class methodsFor: 'scripts' stamp: 'cmm 7/24/2015 09:54' prior: 52285267! prepareNewBuild: anMCRepository "ReleaseBuilderTrunk prepareNewBuild" "Prepare everything that should be done for a new image build" MCMcmUpdater updateMissingPackages: true. MCMcmUpdater enableUpdatesForAllPackages. TTCFont registerAll. FileList initialize. RealEstateAgent standardSize: 600 @ 400. SystemVersion newVersion: self versionString. SMLoaderPlus setDefaultFilters: (OrderedCollection with: #filterSafelyAvailable). " Preferences outOfTheBox." "<-- uncomment after #defaultValueTableForCurrentRelease is fixed up." self setDisplayExtent: 800 @ 600 ; switchToNewRepository: anMCRepository ; setPreferences ; "<-- remove this after defaultValueTableForCurrentRelease is fixed up." checkForDirtyPackages ; configureDesktop. Smalltalk cleanUp: true. MCFileBasedRepository flushAllCaches. MCHttpRepository clearCredentials. Utilities setAuthorInitials: String empty. Environment allInstancesDo: [ : env | env purgeUndeclared ]. Undeclared removeUnreferencedKeys. Smalltalk garbageCollect. [ self loadWellKnownPackages "<-- 4.5 is not ready for unloaded / reloaded packages" ]. Compiler recompileAll. self setProjectBackground: Color darkGray ; openWelcomeWorkspaces! ! !ReleaseBuilder class methodsFor: 'scripts' stamp: 'cmm 1/26/2014 22:12' prior: 52287084! prepareNewRelease "This method is run at time of release to transfer the top trunk versions into my releaseRepository, and produce a release image." self transferCurrentPackagesAsUser: Utilities authorInitials password: (UIManager default requestPassword: 'Enter password for ' , self projectUrl). self prepareNewBuild: self releaseRepository! ! !ReleaseBuilder class methodsFor: 'scripts' stamp: 'cmm 8/5/2015 19:41' prior: 52288115! prepareNextVersionAlpha "Prepare the first alpha image for next release." SystemVersion newVersion: ((UIManager default request: 'Please specify the name of the\new version of Squeak.' withCRs initialAnswer: SystemVersion current version) ifEmpty: [^ self inform: 'Aborted.']). MCFileBasedRepository flushAllCaches. MCHttpRepository clearCredentials. Utilities setAuthorInitials: String empty. self switchToNewRepository: self buildRepository! ! !ReleaseBuilder class methodsFor: 'preferences' stamp: 'cmm 7/24/2015 10:27' prior: 52305451! setPreferences "Preferences class defaultValueTableForCurrentRelease" self setProjectBackground: Color darkGray. "General User interaction" Preferences enable: #generalizedYellowButtonMenu ; disable: #mouseOverForKeyboardFocus ; enable: #swapMouseButtons. Morph indicateKeyboardFocus: true. SearchBar useScratchPad: false. "Text input." TextEditor autoEnclose: true ; autoIndent: true ; destructiveBackWord: false ; blinkingCursor: true ; dumbbellCursor: false. Preferences insertionPointColor: Color red. PluggableTextMorph simpleFrameAdornments: false. "Windows" Preferences installUniformWindowColors. SystemWindow reuseWindows: false. Model windowActiveOnFirstClick: false. "Not good for 800x600" Preferences disable: #showSplitterHandles; enable: #fastDragWindowForMorphic. CornerGripMorph drawCornerResizeHandles: false. ProportionalSplitterMorph smartHorizontalSplitters: false ; smartVerticalSplitters: false. "Scroll bars." Preferences enable: #scrollBarsNarrow; enable: #scrollBarsOnRight; disable: #alwaysHideHScrollbar; disable: #alwaysShowHScrollbar; disable: #alwaysShowVScrollbar. ScrollBar scrollBarsWithoutArrowButtons: true; scrollBarsWithoutMenuButton: true. ScrollPane useRetractableScrollBars: false. "Rounded corners." Morph preferredCornerRadius: 6. Preferences disable: #roundedWindowCorners. PluggableButtonMorph roundedButtonCorners: false. FillInTheBlankMorph roundedDialogCorners: false. MenuMorph roundedMenuCorners: false. ScrollBar roundedScrollBarLook: false. "Gradients." Preferences disable: #gradientScrollBars. SystemWindow gradientWindow: false. MenuMorph gradientMenu: false. PluggableButtonMorph gradientButton: false. "Shadows" Preferences enable: #menuAppearance3d. MenuMorph menuBorderWidth: 1; menuBorderColor: Color lightGray; menuLineColor: Color lightGray. Morph useSoftDropShadow: true.. "Lists and Trees" PluggableListMorph filterableLists: true; clearFilterAutomatically: false; highlightHoveredRow: true; menuRequestUpdatesSelection: true. PluggableTreeMorph filterByLabelsOnly: false; maximumSearchDepth: 1. LazyListMorph listSelectionTextColor: Color black; listSelectionColor: (Color r: 0.72 g: 0.72 b: 0.9). "Standard Tools" BalloonMorph setBalloonColorTo: (TranslucentColor r: 0.92 g: 0.92 b: 0.706 alpha: 0.75). Workspace shouldStyle: false. Browser listClassesHierarchically: true; showClassIcons: true; showMessageIcons: true; sortMessageCategoriesAlphabetically: true. Preferences enable: #annotationPanes; enable: #optionalButtons; enable: #diffsWithPrettyPrint; enable: #traceMessages; enable: #alternativeBrowseIt; enable: #menuWithIcons; enable: #visualExplorer. SystemNavigation thoroughSenders: true. "Halo" Preferences enable: #showBoundsInHalo ; disable: #alternateHandlesLook. "System" NetNameResolver enableIPv6: false. Scanner allowUnderscoreAsAssignment: true; prefAllowUnderscoreSelectors: true. "that's all, folks"! ! "ReleaseBuilder"! "Kernel"! ----SNAPSHOT----{6 August 2015 . 10:24:41 am} Squeak5.0-15113.image priorSource: 1968! ----STARTUP----{6 August 2015 . 10:46:02 am} as /home/cmm/Chris/dev/Squeak/Squeak5.0-15113.image! "Morphic"! SystemOrganization removeSystemCategory: 'Morphic-UserObjects'! SystemOrganization removeSystemCategory: 'EToy-UserObjects'! SystemOrganization removeSystemCategory: 'Morphic-Imported'! ReleaseBuilder prepareNewRelease! ----QUIT----{6 August 2015 . 10:50:45 am} Squeak5.0-15113.image priorSource: 8807! ----STARTUP----{9 August 2015 . 10:50:30 am} as /Users/craig/Downloads/squeak release/Squeak-5.0-All-in-One/Squeak-5.0-All-in-One.app/Contents/Resources/Squeak5.0-15113.image! ----QUIT/NOSAVE----{9 August 2015 . 10:50:39 am} Squeak5.0-15113.image priorSource: 9231! ----STARTUP----{9 August 2015 . 10:51:22 am} as /Users/craig/Downloads/squeak release/Squeak-5.0-All-in-One/Squeak-5.0-All-in-One.app/Contents/Resources/Squeak5.0-15113.image! ----QUIT/NOSAVE----{9 August 2015 . 10:51:47 am} Squeak5.0-15113.image priorSource: 9231! ----STARTUP----{10 December 2015 . 4:24:19 pm} as /Users/eliot/oscogvm/image/trunk50.image! !Number methodsFor: 'mathematical functions' stamp: 'ul 5/24/2015 06:22' prior: 56799868! raisedTo: aNumber "Answer the receiver raised to aNumber." aNumber isInteger ifTrue: [ "Do the special case of integer power" ^ self raisedToInteger: aNumber]. aNumber isFraction ifTrue: [ "Special case for fraction power" ^ (self nthRoot: aNumber denominator) raisedToInteger: aNumber numerator ]. self negative ifTrue: [ ^ ArithmeticError signal: 'Negative numbers can''t be raised to float powers.' ]. aNumber isZero ifTrue: [^ self class one]. "Special case of exponent=0" 1 = aNumber ifTrue: [^ self]. "Special case of exponent=1" self isZero ifTrue: [ "Special case of self = 0" aNumber negative ifTrue: [^ (ZeroDivide dividend: self) signal] ifFalse: [^ self]]. ^ (aNumber * self ln) exp "Otherwise use logarithms"! ! !Integer class methodsFor: 'prime numbers' stamp: 'ul 7/20/2015 01:08' prior: 18814397! largePrimesUpTo: max do: aBlock "Evaluate aBlock with all primes up to maxValue. The Algorithm is adapted from http://www.rsok.com/~jrm/printprimes.html It encodes prime numbers much more compactly than #primesUpTo: 38.5 integer per byte (2310 numbers per 60 byte) allow for some fun large primes. (all primes up to SmallInteger maxVal can be computed within ~27MB of memory; the regular #primesUpTo: would require one *GIGA*byte). Note: The algorithm could be re-written to produce the first primes (which require the longest time to sieve) faster but only at the cost of clarity." | n limit flags maskBitIndex bitIndex maskBit byteIndex index primesUpTo2310 indexLimit increments incrementIndex | limit := max asInteger - 1. indexLimit := max asInteger sqrtFloor + 1. "Create the array of flags." flags := ByteArray new: (limit + 2309) // 2310 * 60 + 60. flags atAllPut: 16rFF. "set all to true" "Compute the primes up to 2310" primesUpTo2310 := self primesUpTo: 2310. "Create a mapping from 2310 integers to 480 bits (60 byte)" maskBitIndex := Array new: 2310. bitIndex := -1. "for pre-increment" maskBitIndex at: 1 put: (bitIndex := bitIndex + 1). maskBitIndex at: 2 put: (bitIndex := bitIndex + 1). index := 1. [ index <= 5 ] whileTrue: [ aBlock value: (primesUpTo2310 at: index). index := index + 1 ]. n := 2. [ n <= 2309 ] whileTrue: [ [(primesUpTo2310 at: index) < n] whileTrue:[index := index + 1]. n = (primesUpTo2310 at: index) ifTrue:[ maskBitIndex at: n+1 put: (bitIndex := bitIndex + 1). ] ifFalse:[ "if modulo any of the prime factors of 2310, then could not be prime" (n \\ 2 = 0 or:[n \\ 3 = 0 or:[n \\ 5 = 0 or:[n \\ 7 = 0 or:[n \\ 11 = 0]]]]) ifTrue:[maskBitIndex at: n+1 put: 0] ifFalse:[maskBitIndex at: n+1 put: (bitIndex := bitIndex + 1)]. ]. n := n + 1 ]. "Now the real work begins... Start with 13 since multiples of 2,3,5,7,11 are handled by the storage method; increment by iterating through increments, which enables us to only check about 20.77% of all numbers." n := 13. increments := #[4 2 4 6 2 6 4 2 4 6 6 2 6 4 2 6 4 6 8 4 2 4 2 4 14 4 6 2 10 2 6 6 4 2 4 6 2 10 2 4 2 12 10 2 4 2 4 6 2 6 4 6 6 6 2 6 4 2 6 4 6 8 4 2 4 6 8 6 10 2 4 6 2 6 6 4 2 4 6 2 6 4 2 6 10 2 10 2 4 2 4 6 8 4 2 4 12 2 6 4 2 6 4 6 12 2 4 2 4 8 6 4 6 2 4 6 2 6 10 2 4 6 2 6 4 2 4 2 10 2 10 2 4 6 6 2 6 6 4 6 6 2 6 4 2 6 4 6 8 4 2 6 4 8 6 4 6 2 4 6 8 6 4 2 10 2 6 4 2 4 2 10 2 10 2 4 2 4 8 6 4 2 4 6 6 2 6 4 8 4 6 8 4 2 4 2 4 8 6 4 6 6 6 2 6 6 4 2 4 6 2 6 4 2 4 2 10 2 10 2 6 4 6 2 6 4 2 4 6 6 8 4 2 6 10 8 4 2 4 2 4 8 10 6 2 4 8 6 6 4 2 4 6 2 6 4 6 2 10 2 10 2 4 2 4 6 2 6 4 2 4 6 6 2 6 6 6 4 6 8 4 2 4 2 4 8 6 4 8 4 6 2 6 6 4 2 4 6 8 4 2 4 2 10 2 10 2 4 2 4 6 2 10 2 4 6 8 6 4 2 6 4 6 8 4 6 2 4 8 6 4 6 2 4 6 2 6 6 4 6 6 2 6 6 4 2 10 2 10 2 4 2 4 6 2 6 4 2 10 6 2 6 4 2 6 4 6 8 4 2 4 2 12 6 4 6 2 4 6 2 12 4 2 4 8 6 4 2 4 2 10 2 10 6 2 4 6 2 6 4 2 4 6 6 2 6 4 2 10 6 8 6 4 2 4 8 6 4 6 2 4 6 2 6 6 6 4 6 2 6 4 2 4 2 10 12 2 4 2 10 2 6 4 2 4 6 6 2 10 2 6 4 14 4 2 4 2 4 8 6 4 6 2 4 6 2 6 6 4 2 4 6 2 6 4 2 4 12 2 12]. incrementIndex := 1. [ n <= limit ] whileTrue: [ (maskBit := maskBitIndex at: (n \\ 2310 + 1)) = 0 ifFalse:["not a multiple of 2,3,5,7,11" byteIndex := n // 2310 * 60 + (maskBit-1 bitShift: -3) + 1. bitIndex := 1 bitShift: (maskBit bitAnd: 7). ((flags at: byteIndex) bitAnd: bitIndex) = 0 ifFalse:["not marked -- n is prime" aBlock value: n. "Start with n*n since any integer < n has already been sieved (e.g., any multiple of n with a number k < n has been cleared when k was sieved); add 2 * n to avoid even numbers and mark all multiples of this prime. Note: n < indexLimit below limits running into LargeInts -- nothing more." n < indexLimit ifTrue:[ index := n * n. [index <= limit] whileTrue:[ (maskBit := maskBitIndex at: (index \\ 2310 + 1)) = 0 ifFalse:[ byteIndex := (index // 2310 * 60) + (maskBit-1 bitShift: -3) + 1. maskBit := 255 - (1 bitShift: (maskBit bitAnd: 7)). flags at: byteIndex put: ((flags at: byteIndex) bitAnd: maskBit). ]. index := index + n + n ]. ]. ]. ]. n := n + (increments at: incrementIndex). incrementIndex := incrementIndex + 1. incrementIndex > increments size ifTrue: [ incrementIndex := 1 ] ]! ! !Integer class methodsFor: 'prime numbers' stamp: 'ul 7/17/2015 01:01' prior: 18819189! primesUpTo: max do: aBlock "Compute aBlock with all prime integers up to the given integer." "Integer primesUpTo: 100" | index sieve increment limit limitSqrtFloor | limit := max asInteger. "Fall back into #largePrimesUpTo:do: if we'd require more than 100k of memory; the alternative will only requre 2/77th of the amount we need here and is almost as fast." limit <= 100000 ifFalse: [ ^self largePrimesUpTo: limit do: aBlock ]. limit := limit - 1. "upTo:" limit <= 1 ifTrue: [ ^self ]. aBlock value: 2. limit <= 2 ifTrue: [ ^self ]. aBlock value: 3. sieve := ByteArray new: limit withAll: 1. "1 = prime, 0 = not prime" sieve at: 1 put: 0. "Filter multiples of 2." index := 4. [ index <= limit ] whileTrue: [ sieve at: index put: 0. index := index + 2 ]. "Filter multiples of 3." index := 9. [ index <= limit ] whileTrue: [ sieve at: index put: 0. index := index + 3 ]. "Filter the rest of the primes." limitSqrtFloor := limit sqrtFloor. index := 5. increment := 2. [ index <= limitSqrtFloor ] whileTrue: [ (sieve at: index) = 1 ifTrue: [ | originalIndex originalIncrement | aBlock value: index. originalIndex := index. originalIncrement := increment. increment := index + index. index := index * index. [ index <= limit ] whileTrue: [ sieve at: index put: 0. index := index + increment ]. index := originalIndex. increment := originalIncrement ]. index := index + increment. increment := 6 - increment ]. "No more new primes here." [ index <= limit ] whileTrue: [ (sieve at: index) = 1 ifTrue: [ aBlock value: index ]. index := index + increment. increment := 6 - increment ]! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'eem 8/11/2015 18:17' prior: 25331665! moveChangesTo: newFile "Used in the process of condensing changes, this message requests that the source code of all methods of the receiver that have been changed should be moved to newFile." | changes | changes := self methodDict keys select: [:sel | (self compiledMethodAt: sel) fileIndex > 1]. changes isEmpty ifTrue: [^self]. newFile cr; cr; command: 'H3'; nextChunkPut: self definition; command: '/H3'; cr. self fileOutChangedMessages: changes on: newFile moveSource: #historically toFile: 2! ! !Magnitude methodsFor: 'sorting' stamp: 'ul 5/24/2015 05:11' prior: 19080421! <=> anotherObject "Return a collation order of -1, 0, or 1, indicating whether I should be collated before the receiver, am equal, or after. See also: http://en.wikipedia.org/wiki/Spaceship_operator" self = anotherObject ifTrue: [ ^0 ]. self < anotherObject ifTrue: [ ^-1 ]. ^1! ! "Kernel"! !Text methodsFor: 'sorting' stamp: 'ul 5/24/2015 05:04' prior: 19956261! <=> aCharacterArray "Return a collation order of -1, 0, or 1, indicating whether I should be collated before the receiver, am equal, or after. See also: http://en.wikipedia.org/wiki/Spaceship_operator" aCharacterArray isString ifTrue: [ ^string <=> aCharacterArray ]. ^string <=> aCharacterArray asString! ! !Text methodsFor: 'comparing' stamp: 'ul 5/24/2015 05:05' prior: 19935769! = other "Am I equal to the other Text or String? ***** Warning ***** Two Texts are considered equal if they have the same characters in them. They might have completely different emphasis, fonts, sizes, text actions, or embedded morphs. If you need to find out if one is a true copy of the other, you must do (text1 = text2 and: [text1 runs = text2 runs])." other isText ifTrue: [ ^string = other string ]. other isString ifTrue: [ ^string = other ]. ^false! ! !String methodsFor: 'sorting' stamp: 'ul 5/24/2015 04:14' prior: 22355674! <=> aCharacterArray "Return a collation order of -1, 0, or 1, indicating whether I should be collated before the receiver, am equal, or after. See also: http://en.wikipedia.org/wiki/Spaceship_operator" aCharacterArray isString ifTrue: [ ^(self compare: aCharacterArray) - 2 ]. self = aCharacterArray ifTrue: [ ^0 ]. self < aCharacterArray ifTrue: [ ^-1 ]. ^1! ! !String methodsFor: 'comparing' stamp: 'ul 5/24/2015 04:18' prior: 22192215! = aString "Answer whether the receiver sorts equally as aString. The collation order is simple ascii (with case differences)." self == aString ifTrue: [ ^true ]. aString isString ifFalse: [ ^false ]. self size = aString size ifFalse: [ ^false ]. ^ (self compare: self with: aString collated: AsciiOrder) = 2! ! !String methodsFor: 'converting' stamp: 'ul 5/14/2015 03:16' prior: 22220979! asSignedInteger "Returns the first signed integer it can find or nil." | result character index negative | (self at: 1) isDigit ifTrue: [ index := 1 ] ifFalse: [ index := self findFirst: [ :char | char isDigit ]. index = 0 ifTrue: [ ^nil ] ]. negative := index > 1 and: [ (self at: index - 1) == $- ]. result := 0. [ index <= self size and: [ (character := self at: index) isDigit ] ] whileTrue: [ result := result * 10 + character asciiValue - 48 "$0 asciiValue". index := index + 1 ]. negative ifTrue: [ ^0 - result ]. ^result ! ! !String methodsFor: 'accessing' stamp: 'ul 8/14/2015 18:04' prior: 22167050! findTokens: delimiters includes: subString "Divide self into pieces using delimiters. Return the piece that includes subString anywhere in it. Is case sensitive (say asLowercase to everything beforehand to make insensitive)." ^ (self findTokens: delimiters) detect: [:str | (str includesSubstring: subString)] ifNone: [nil]! ! !String methodsFor: 'testing' stamp: 'ul 8/14/2015 17:59' prior: 22311370! includesSubString: subString self deprecated: 'Use #includesSubstring: instead.'. ^self includesSubstring: subString! ! !String methodsFor: 'testing' stamp: 'ul 8/14/2015 17:57'! includesSubstring: aString ^(self findString: aString startingAt: 1) > 0! ! !Collection methodsFor: 'testing' stamp: 'ul 8/14/2015 18:01' prior: 26900095! includesSubstringAnywhere: testString "Answer whether the receiver includes, anywhere in its nested structure, a string that has testString as a substring" self do: [:element | (element isString) ifTrue: [(element includesSubstring: testString) ifTrue: [^ true]]. (element isCollection) ifTrue: [(element includesSubstringAnywhere: testString) ifTrue: [^ true]]]. ^ false "#(first (second third) ((allSentMessages ('Elvis' includes:)))) includesSubstringAnywhere: 'lvi'"! ! !CharacterSet methodsFor: 'collection ops' stamp: 'ul 8/12/2015 20:48' prior: 21011658! includes: aCharacter | index | (index := aCharacter asInteger + 1) > 256 ifTrue: [ ^false ]. ^(map at: index) > 0! ! !Character class methodsFor: 'class initialization' stamp: 'ul 8/14/2015 18:36' prior: 57880815! initialize "Character initialize" self initializeClassificationTable; initializeDigitValues! ! !Character class methodsFor: 'class initialization' stamp: 'ul 8/14/2015 18:36' prior: 57886940! initializeDigitValues "Initialize the well known digit value of ascii characters. Note that the DigitValues table is 1-based while ascii values are 0-based, thus the offset +1." | newDigitValues | newDigitValues := Array new: 256 withAll: -1. "the digits" 0 to: 9 do: [:i | newDigitValues at: 48 + i + 1 put: i]. "the uppercase letters" 10 to: 35 do: [:i | newDigitValues at: 55 + i + 1 put: i]. "the lowercase letters" 10 to: 35 do: [:i | newDigitValues at: 87 + i + 1 put: i]. DigitValues := newDigitValues! ! !Character methodsFor: 'comparing' stamp: 'ul 8/12/2015 22:06' prior: 57860389! < aCharacter "Answer true if the receiver's value < aCharacter's value." ^self asInteger < aCharacter asInteger! ! !Character methodsFor: 'comparing' stamp: 'ul 8/12/2015 22:06' prior: 57859646! <= aCharacter "Answer true if the receiver's value <= aCharacter's value." ^self asInteger <= aCharacter asInteger! ! !Character methodsFor: 'comparing' stamp: 'ul 8/12/2015 22:06' prior: 57860860! > aCharacter "Answer true if the receiver's value > aCharacter's value." ^self asInteger > aCharacter asInteger! ! !Character methodsFor: 'comparing' stamp: 'ul 8/12/2015 22:06' prior: 57859834! >= aCharacter "Answer true if the receiver's value >= aCharacter's value." ^self asInteger >= aCharacter asInteger! ! !Character methodsFor: 'converting' stamp: 'ul 8/12/2015 22:07' prior: 57862097! asLowercase "Answer the receiver's matching lowercase Character." | integerValue | (integerValue := self asInteger) > 255 ifFalse: [ | result | (result := (ClassificationTable at: integerValue + 1) bitAnd: 16rFF) > 0 ifTrue: [ ^self class value: result ] ]. ^self class value: (self encodedCharSet toLowercaseCode: integerValue)! ! !Character methodsFor: 'converting' stamp: 'ul 8/12/2015 22:10' prior: 57862854! asUnicode "Answer the unicode encoding of the receiver" | integerValue | (integerValue := self asInteger) <= 16r3FFFFF ifTrue: [ ^integerValue ]. ^self encodedCharSet charsetClass convertToUnicode: (integerValue bitAnd: 16r3FFFFF) ! ! !Character methodsFor: 'converting' stamp: 'ul 8/12/2015 22:08' prior: 57863691! asUppercase "Answer the receiver's matching uppercase Character." | integerValue | (integerValue := self asInteger) > 255 ifFalse: [ | result | (result := ((ClassificationTable at: integerValue + 1) bitShift: -8) bitAnd: 16rFF) > 0 ifTrue: [ ^self class value: result ] ]. ^self class value: (self encodedCharSet toUppercaseCode: integerValue)! ! !Character methodsFor: 'accessing' stamp: 'ul 8/12/2015 22:08' prior: 57858686! digitValue "Answer 0-9 if the receiver is $0-$9, 10-35 if it is $A-$Z, and < 0 otherwise. This is used to parse literal numbers of radix 2-36." | integerValue | (integerValue := self asInteger) > 16rFF ifTrue: [^self encodedCharSet digitValueOf: self]. ^DigitValues at: integerValue + 1! ! !Character methodsFor: 'testing' stamp: 'ul 8/12/2015 22:11' prior: 57870412! isAlphaNumeric "Answer whether the receiver is a letter or a digit." | integerValue | (integerValue := self asInteger) > 255 ifFalse: [ ^((ClassificationTable at: integerValue + 1) bitAnd: AlphaNumericMask) > 0 ]. ^self encodedCharSet isAlphaNumeric: self! ! !Character methodsFor: 'testing' stamp: 'ul 8/12/2015 22:14' prior: 57870705! isAscii ^self asInteger < 128! ! !Character methodsFor: 'testing' stamp: 'ul 8/12/2015 22:12' prior: 57871187! isDigit | integerValue | (integerValue := self asInteger) > 255 ifFalse: [ ^((ClassificationTable at: integerValue + 1) bitAnd: DigitBit) > 0 ]. ^self encodedCharSet isDigit: self. ! ! !Character methodsFor: 'testing' stamp: 'ul 8/12/2015 22:13' prior: 57871690! isLetter | integerValue | (integerValue := self asInteger) > 255 ifFalse: [ ^((ClassificationTable at: integerValue + 1) bitAnd: LetterMask) > 0 ]. ^self encodedCharSet isLetter: self! ! !Character methodsFor: 'testing' stamp: 'ul 8/12/2015 22:13' prior: 57872335! isLowercase | integerValue | (integerValue := self asInteger) > 255 ifFalse: [ ^((ClassificationTable at: integerValue + 1) bitAnd: LowercaseBit) > 0 ]. ^self encodedCharSet isLowercase: self. ! ! !Character methodsFor: 'testing' stamp: 'ul 8/14/2015 18:58' prior: 57873004! isSeparator "Answer whether the receiver is one of the separator characters--space, cr, tab, line feed, or form feed." | integerValue | (integerValue := self asInteger) > 32 ifTrue: [ ^false ]. integerValue caseOf: { [ 32 "space" ] -> [ ^true ]. [ 9 "cr" ] -> [ ^true ]. [ 13 "tab"] -> [ ^true ]. [ 10 "line feed" ] -> [ ^true ] } otherwise: [ ^integerValue = 12 "form feed" ]! ! !Character methodsFor: 'testing' stamp: 'ul 8/12/2015 22:14' prior: 57875539! isUppercase | integerValue | (integerValue := self asInteger) > 255 ifFalse: [ ^((ClassificationTable at: integerValue + 1) bitAnd: UppercaseBit) > 0 ]. ^self encodedCharSet isUppercase: self. ! ! !Character methodsFor: 'printing' stamp: 'ul 8/12/2015 22:18' prior: 57867876! printOn: aStream | integerValue | ((integerValue := self asInteger) > 32 and: [ integerValue ~= 127 ]) ifTrue: [ aStream nextPut: $$; nextPut: self. ^self ]. (self class constantNameFor: self) ifNotNil: [ :name | aStream nextPutAll: self class name; space; nextPutAll: name ] ifNil: [ aStream nextPutAll: self class name; nextPutAll: ' value: '; print: integerValue ]! ! !Character methodsFor: 'testing' stamp: 'ul 8/12/2015 22:18' prior: 57875941! shouldBePrintedAsLiteral | integerValue | ^((integerValue := self asInteger) between: 33 and: 255) and: [self asInteger ~= 127]! ! !Character methodsFor: 'printing' stamp: 'ul 8/12/2015 22:18' prior: 57868324! storeBinaryOn: aStream "Store the receiver on a binary (file) stream" | integerValue | (integerValue := self asInteger) < 256 ifTrue: [ aStream basicNextPut: self ] ifFalse: [ aStream nextInt32Put: integerValue ]! ! !Character methodsFor: 'object fileIn' stamp: 'ul 8/12/2015 22:19' prior: 57867457! storeDataOn: aDataStream " Store characters in reference-like way, with value like instvar. This is compatible with various Squeak Memory Systems" aDataStream beginInstance: self class size: 1; nextPut: self asInteger! ! !Character methodsFor: 'printing' stamp: 'ul 8/12/2015 22:21' prior: 57868581! storeOn: aStream "Common character literals are preceded by '$', however special need to be encoded differently: for some this might be done by using one of the shortcut constructor methods for the rest we have to create them by ascii-value." self shouldBePrintedAsLiteral ifTrue: [ aStream nextPut: $$; nextPut: self. ^self ]. (self class constantNameFor: self) ifNotNil: [ :name | aStream nextPutAll: self class name; space; nextPutAll: name. ^self ]. aStream nextPut: $(; nextPutAll: self class name; nextPutAll: ' value: '; print: self asInteger; nextPut: $)! ! "Collections"! !SHMCClassDefinition methodsFor: 'act like a class' stamp: 'ul 7/9/2015 20:59' prior: 50519990! sharedPools | d | d := Set new. classDefinition poolDictionaries do:[:each | d add: (Smalltalk at: each asSymbol ifAbsent:[nil]) ]. ^d! ! !SHTextStylerST80 methodsFor: 'private' stamp: 'ul 5/18/2015 03:40' prior: 24153879! setAttributesIn: aText fromRanges: ranges | defaultAttributes newRuns newValues lastAttributes oldRuns nextIndex lastCount | oldRuns := aText runs. defaultAttributes := self attributesFor: #default. newRuns := OrderedCollection new: ranges size * 2 + 1. newValues := OrderedCollection new: ranges size * 2 + 1. lastAttributes := nil. nextIndex := 1. lastCount := 0. ranges do: [ :range | | attributes | nextIndex < range start ifTrue: [ lastAttributes == defaultAttributes ifTrue: [ lastCount := lastCount + range start - nextIndex. newRuns at: newRuns size put: lastCount ] ifFalse: [ lastCount := range start - nextIndex. newRuns addLast: lastCount. lastAttributes := defaultAttributes. newValues addLast: lastAttributes ]. nextIndex := range start ]. attributes := (self attributesFor: range type) ifNil: [ defaultAttributes ]. lastAttributes == attributes ifTrue: [ lastCount := lastCount + range end - nextIndex + 1. newRuns at: newRuns size put: lastCount ] ifFalse: [ lastCount := range end - nextIndex + 1. newRuns addLast: lastCount. lastAttributes := attributes. newValues addLast: lastAttributes ]. nextIndex := range end + 1 ]. nextIndex <= aText size ifTrue: [ lastAttributes == defaultAttributes ifTrue: [ lastCount := lastCount + aText size - nextIndex + 1. newRuns at: newRuns size put: lastCount ] ifFalse: [ lastCount := aText size - nextIndex + 1. newRuns addLast: lastCount. lastAttributes := defaultAttributes. newValues addLast: lastAttributes ] ]. aText runs: (RunArray runs: newRuns values: newValues). oldRuns withStartStopAndValueDo: [ :start :stop :attribs | (attribs anySatisfy: [ :each | each shoutShouldPreserve ]) ifTrue: [ attribs do: [ :each | aText addAttribute: each from: start to: stop ] ] ]. ! ! !PseudoClass methodsFor: '*ShoutCore' stamp: 'ul 7/26/2015 22:43'! shoutParserClass ^SHParserST80 ! ! "ShoutCore"! SystemOrganization addCategory: #'Regex-Core'! Object subclass: #RxCharSetParser instanceVariableNames: 'source lookahead elements' classVariableNames: '' poolDictionaries: '' category: 'Regex-Core'! !RxCharSetParser commentStamp: 'Tbn 11/12/2010 23:13' prior: 0! -- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov -- I am a parser created to parse the insides of a character set ([...]) construct. I create and answer a collection of "elements", each being an instance of one of: RxsCharacter, RxsRange, or RxsPredicate. Instance Variables: source open on whatever is inside the square brackets we have to parse. lookahead The current lookahead character elements > Parsing result! Object subclass: #RxMatchOptimizer instanceVariableNames: 'ignoreCase prefixes nonPrefixes conditions testBlock methodPredicates nonMethodPredicates predicates nonPredicates lookarounds' classVariableNames: '' poolDictionaries: '' category: 'Regex-Core'! !RxMatchOptimizer commentStamp: 'Tbn 11/12/2010 23:13' prior: 0! -- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov -- A match start optimizer, handy for searching a string. Takes a regex syntax tree and sets itself up so that prefix characters or matcher states that cannot start a match are later recognized with #canStartMatch:in: method. Used by RxMatcher, but can be used by other matchers (if implemented) as well.! Object subclass: #RxMatcher instanceVariableNames: 'matcher ignoreCase startOptimizer stream markerPositions markerCount lastResult' classVariableNames: 'Cr Lf' poolDictionaries: '' category: 'Regex-Core'! !RxMatcher commentStamp: 'Tbn 11/12/2010 23:13' prior: 0! -- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov -- This is a recursive regex matcher. Not strikingly efficient, but simple. Also, keeps track of matched subexpressions. The life cycle goes as follows: 1. Initialization. Accepts a syntax tree (presumably produced by RxParser) and compiles it into a matcher built of other classes in this category. 2. Matching. Accepts a stream or a string and returns a boolean indicating whether the whole stream or its prefix -- depending on the message sent -- matches the regex. 3. Subexpression query. After a successful match, and before any other match, the matcher may be queried about the range of specific stream (string) positions that matched to certain parenthesized subexpressions of the original expression. Any number of queries may follow a successful match, and any number or matches may follow a successful initialization. Note that `matcher' is actually a sort of a misnomer. The actual matcher is a web of Rxm* instances built by RxMatcher during initialization. RxMatcher is just the interface facade of this network. It is also a builder of it, and also provides a stream-like protocol to easily access the stream being matched. Instance variables: matcher The entry point into the actual matcher. stream The stream currently being matched against. markerPositions Positions of markers' matches. markerCount Number of markers. lastResult Whether the latest match attempt succeeded or not. lastChar character last seen in the matcher stream! Object subclass: #RxParser instanceVariableNames: 'input lookahead' classVariableNames: 'BackslashConstants BackslashSpecials' poolDictionaries: '' category: 'Regex-Core'! !RxParser commentStamp: 'Tbn 11/12/2010 23:13' prior: 0! -- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov -- The regular expression parser. Translates a regular expression read from a stream into a parse tree. ('accessing' protocol). The tree can later be passed to a matcher initialization method. All other classes in this category implement the tree. Refer to their comments for any details. Instance variables: input A stream with the regular expression being parsed. lookahead ! Object subclass: #RxmLink instanceVariableNames: 'next' classVariableNames: '' poolDictionaries: '' category: 'Regex-Core'! !RxmLink commentStamp: 'Tbn 11/12/2010 23:14' prior: 0! -- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov -- A matcher is built of a number of links interconnected into some intricate structure. Regardless of fancy stuff, any link (except for the terminator) has the next one. Any link can match against a stream of characters, recursively propagating the match to the next link. Any link supports a number of matcher-building messages. This superclass does all of the above. The class is not necessarily abstract. It may double as an empty string matcher: it recursively propagates the match to the next link, thus always matching nothing successfully. Principal method: matchAgainst: aMatcher Any subclass will reimplement this to test the state of the matcher, most probably reading one or more characters from the matcher's stream, and either decide it has matched and answer true, leaving matcher stream positioned at the end of match, or answer false and restore the matcher stream position to whatever it was before the matching attempt. Instance variables: next The next link in the structure.! RxmLink subclass: #RxmBranch instanceVariableNames: 'loopback alternative' classVariableNames: '' poolDictionaries: '' category: 'Regex-Core'! !RxmBranch commentStamp: 'Tbn 11/12/2010 23:14' prior: 0! -- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov -- This is a branch of a matching process. Either `next' chain should match, or `alternative', if not nil, should match. Since this is also used to build loopbacks to match repetitions, `loopback' variable indicates whether the instance is a loopback: it affects the matcher-building operations (which of the paths through the branch is to consider as the primary when we have to find the "tail" of a matcher construct). Instance variables alternative to match if `next' fails to match. loopback ! RxmLink subclass: #RxmLookahaed instanceVariableNames: 'lookahead positive' classVariableNames: '' poolDictionaries: '' category: 'Regex-Core'! !RxmLookahaed commentStamp: '' prior: 0! Instance holds onto a lookead which matches but does not consume anything. Instance variables: predicate ! RxmLink subclass: #RxmMarker instanceVariableNames: 'index' classVariableNames: '' poolDictionaries: '' category: 'Regex-Core'! !RxmMarker commentStamp: 'Tbn 11/12/2010 23:14' prior: 0! -- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov -- A marker is used to remember positions of match of certain points of a regular expression. The marker receives an identifying key from the Matcher and uses that key to report positions of successful matches to the Matcher. Instance variables: index Something that makes sense for the Matcher. Received from the latter during initalization and later passed to it to identify the receiver.! RxmLink subclass: #RxmPredicate instanceVariableNames: 'predicate' classVariableNames: '' poolDictionaries: '' category: 'Regex-Core'! !RxmPredicate commentStamp: 'Tbn 11/12/2010 23:14' prior: 0! -- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov -- Instance holds onto a one-argument block and matches exactly one character if the block evaluates to true when passed the character as the argument. Instance variables: predicate ! RxmLink subclass: #RxmSpecial instanceVariableNames: 'matchSelector' classVariableNames: '' poolDictionaries: '' category: 'Regex-Core'! !RxmSpecial commentStamp: 'Tbn 11/12/2010 23:14' prior: 0! -- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov -- A special node that matches a specific matcher state rather than any input character. The state is either at-beginning-of-line or at-end-of-line.! RxmLink subclass: #RxmSubstring instanceVariableNames: 'sample compare' classVariableNames: '' poolDictionaries: '' category: 'Regex-Core'! !RxmSubstring commentStamp: 'Tbn 11/12/2010 23:14' prior: 0! -- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov -- Instance holds onto a string and matches exactly this string, and exactly once. Instance variables: string ! Object subclass: #RxmTerminator instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Regex-Core'! !RxmTerminator commentStamp: 'Tbn 11/12/2010 23:14' prior: 0! -- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov -- Instances of this class are used to terminate matcher's chains. When a match reaches this (an instance receives #matchAgainst: message), the match is considered to succeed. Instances also support building protocol of RxmLinks, with some restrictions.! Object subclass: #RxsNode instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Regex-Core'! !RxsNode commentStamp: 'Tbn 11/12/2010 23:14' prior: 0! -- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov -- A generic syntax tree node, provides some common responses to the standard tests, as well as tree structure printing -- handy for debugging.! RxsNode subclass: #RxsBranch instanceVariableNames: 'piece branch' classVariableNames: '' poolDictionaries: '' category: 'Regex-Core'! !RxsBranch commentStamp: 'Tbn 11/12/2010 23:14' prior: 0! -- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov -- A Branch is a Piece followed by a Branch or an empty string. Instance variables: piece branch ! RxsNode subclass: #RxsCharSet instanceVariableNames: 'negated elements' classVariableNames: '' poolDictionaries: '' category: 'Regex-Core'! !RxsCharSet commentStamp: 'Tbn 11/12/2010 23:14' prior: 0! -- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov -- A character set corresponds to a [...] construct in the regular expression. Instance variables: elements An element can be one of: RxsCharacter, RxsRange, or RxsPredicate. negated ! RxsNode subclass: #RxsCharacter instanceVariableNames: 'character' classVariableNames: '' poolDictionaries: '' category: 'Regex-Core'! !RxsCharacter commentStamp: 'Tbn 11/12/2010 23:14' prior: 0! -- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov -- A character is a literal character that appears either in the expression itself or in a character set within an expression. Instance variables: character ! RxsNode subclass: #RxsContextCondition instanceVariableNames: 'kind' classVariableNames: '' poolDictionaries: '' category: 'Regex-Core'! !RxsContextCondition commentStamp: 'Tbn 11/12/2010 23:14' prior: 0! -- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov -- One of a few special nodes more often representing special state of the match rather than a predicate on a character. The ugly exception is the #any condition which *is* a predicate on a character. Instance variables: kind ! RxsNode subclass: #RxsEpsilon instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Regex-Core'! !RxsEpsilon commentStamp: 'Tbn 11/12/2010 23:14' prior: 0! -- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov -- This is an empty string. It terminates some of the recursive constructs.! RxsNode subclass: #RxsLookaround instanceVariableNames: 'piece positive' classVariableNames: '' poolDictionaries: '' category: 'Regex-Core'! !RxsLookaround commentStamp: '' prior: 0! I lookaround is used for lookaheads and lookbehinds. They are used to check if the input matches a certain subexpression without consuming any characters (e.g. not advancing the match position). Lookarounds can be positive or negative. If they are positive the condition fails if the subexpression fails, if they are negative it is inverse.! RxsNode subclass: #RxsMessagePredicate instanceVariableNames: 'selector negated' classVariableNames: '' poolDictionaries: '' category: 'Regex-Core'! !RxsMessagePredicate commentStamp: 'Tbn 11/12/2010 23:14' prior: 0! -- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov -- A message predicate represents a condition on a character that is tested (at the match time) by sending a unary message to the character expecting a Boolean answer. Instance variables: selector ! RxsNode subclass: #RxsPiece instanceVariableNames: 'atom min max' classVariableNames: '' poolDictionaries: '' category: 'Regex-Core'! !RxsPiece commentStamp: '' prior: 0! -- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov -- A piece is an atom, possibly optional or repeated a number of times. Instance variables: atom min max nil means infinity! RxsNode subclass: #RxsPredicate instanceVariableNames: 'predicate negation' classVariableNames: 'EscapedLetterSelectors NamedClassSelectors' poolDictionaries: '' category: 'Regex-Core'! !RxsPredicate commentStamp: 'Tbn 11/12/2010 23:15' prior: 0! -- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov -- This represents a character that satisfies a certain predicate. Instance Variables: predicate A one-argument block. If it evaluates to the value defined by when it is passed a character, the predicate is considered to match. negation A one-argument block that is a negation of .! RxsNode subclass: #RxsRange instanceVariableNames: 'first last' classVariableNames: '' poolDictionaries: '' category: 'Regex-Core'! !RxsRange commentStamp: 'Tbn 11/12/2010 23:15' prior: 0! -- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov -- I represent a range of characters as appear in character classes such as [a-ZA-Z0-9]. I appear in a syntax tree only as an element of RxsCharSet. Instance Variables: first last ! RxsNode subclass: #RxsRegex instanceVariableNames: 'branch regex' classVariableNames: '' poolDictionaries: '' category: 'Regex-Core'! !RxsRegex commentStamp: 'Tbn 11/12/2010 23:15' prior: 0! -- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov -- The body of a parenthesized thing, or a top-level expression, also an atom. Instance variables: branch regex ! SystemOrganization addCategory: #'Regex-Core-Exceptions'! Error subclass: #RegexError instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Regex-Core-Exceptions'! !RegexError commentStamp: 'Tbn 11/12/2010 22:37' prior: 0! This is a common superclass for errors in regular expressions.! RegexError subclass: #RegexCompilationError instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Regex-Core-Exceptions'! !RegexCompilationError commentStamp: 'Tbn 11/12/2010 22:38' prior: 0! This class represents compilation errors in regular expressions.! RegexError subclass: #RegexMatchingError instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Regex-Core-Exceptions'! !RegexMatchingError commentStamp: 'Tbn 11/12/2010 22:38' prior: 0! This class represents matching errors in regular expressions.! RegexError subclass: #RegexSyntaxError instanceVariableNames: 'position' classVariableNames: '' poolDictionaries: '' category: 'Regex-Core-Exceptions'! !RegexSyntaxError commentStamp: 'Tbn 11/12/2010 22:38' prior: 0! This class represents syntax errors in regular expressions.! !RxCharSetParser class methodsFor: 'instance creation' stamp: 'vb 4/11/09 21:56'! on: aStream ^self new initialize: aStream! ! !RxCharSetParser methodsFor: 'parsing' stamp: 'vb 4/11/09 21:56'! addChar: aChar elements add: (RxsCharacter with: aChar)! ! !RxCharSetParser methodsFor: 'parsing' stamp: 'CamilloBruni 10/7/2012 22:52'! addRangeFrom: firstChar to: lastChar firstChar asInteger > lastChar asInteger ifTrue: [RxParser signalSyntaxException: ' bad character range' at: source position]. elements add: (RxsRange from: firstChar to: lastChar)! ! !RxCharSetParser methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! initialize: aStream source := aStream. lookahead := aStream next. elements := OrderedCollection new! ! !RxCharSetParser methodsFor: 'parsing' stamp: 'ul 5/24/2015 22:01'! match: aCharacter aCharacter = lookahead ifTrue: [ ^self next ]. RxParser signalSyntaxException: 'unexpected character: ', (String with: lookahead) at: source position! ! !RxCharSetParser methodsFor: 'parsing' stamp: 'ul 5/24/2015 21:19'! next ^lookahead := source next! ! !RxCharSetParser methodsFor: 'accessing' stamp: 'ul 5/24/2015 21:59'! parse lookahead == $- ifTrue: [ self addChar: $-. self next ]. [ lookahead == nil ] whileFalse: [ self parseStep ]. ^elements! ! !RxCharSetParser methodsFor: 'parsing' stamp: 'ul 5/24/2015 21:20'! parseCharOrRange | firstChar | firstChar := lookahead. self next == $- ifFalse: [ ^self addChar: firstChar ]. self next ifNil: [ ^self addChar: firstChar; addChar: $- ]. self addRangeFrom: firstChar to: lookahead. self next! ! !RxCharSetParser methodsFor: 'parsing' stamp: 'ul 5/24/2015 21:59'! parseEscapeChar self match: $\. $- == lookahead ifTrue: [elements add: (RxsCharacter with: $-)] ifFalse: [elements add: (RxsPredicate forEscapedLetter: lookahead)]. self next! ! !RxCharSetParser methodsFor: 'parsing' stamp: 'ul 5/24/2015 22:00'! parseNamedSet | name | self match: $[; match: $:. name := (String with: lookahead), (source upTo: $:). self next. self match: $]. elements add: (RxsPredicate forNamedClass: name)! ! !RxCharSetParser methodsFor: 'parsing' stamp: 'ul 5/24/2015 21:14'! parseStep lookahead == $[ ifTrue: [source peek == $: ifTrue: [^self parseNamedSet] ifFalse: [^self parseCharOrRange]]. lookahead == $\ ifTrue: [^self parseEscapeChar]. lookahead == $- ifTrue: [RxParser signalSyntaxException: 'invalid range' at: source position]. self parseCharOrRange! ! !RxMatchOptimizer methodsFor: 'accessing' stamp: 'ul 5/14/2015 02:44'! canStartMatch: aCharacter in: aMatcher "Answer whether a match could commence at the given lookahead character, or in the current state of . True answered by this method does not mean a match will definitly occur, while false answered by this method *does* guarantee a match will never occur." aCharacter ifNil: [ ^true ]. testBlock ifNil: [ ^true ]. ^testBlock value: aCharacter value: aMatcher! ! !RxMatchOptimizer methodsFor: 'accessing' stamp: 'ul 5/15/2015 22:49'! conditionTester "#any condition is filtered at the higher level; it cannot appear among the conditions here." | matchConditions | conditions isEmpty ifTrue: [^nil]. conditions size = 1 ifTrue: [ | matchCondition | matchCondition := conditions anyOne. "Special case all of the possible conditions." #atBeginningOfLine == matchCondition ifTrue: [^[:c :matcher | matcher atBeginningOfLine]]. #atEndOfLine == matchCondition ifTrue: [^[:c :matcher | matcher atEndOfLine]]. #atBeginningOfWord == matchCondition ifTrue: [^[:c :matcher | matcher atBeginningOfWord]]. #atEndOfWord == matchCondition ifTrue: [^[:c :matcher | matcher atEndOfWord]]. #atWordBoundary == matchCondition ifTrue: [^[:c :matcher | matcher atWordBoundary]]. #notAtWordBoundary == matchCondition ifTrue: [^[:c :matcher | matcher notAtWordBoundary]]. RxParser signalCompilationException: 'invalid match condition']. "More than one condition. Capture them as an array in scope." matchConditions := conditions asArray. ^[ :c :matcher | matchConditions anySatisfy: [ :conditionSelector | matcher perform: conditionSelector ] ]! ! !RxMatchOptimizer methodsFor: 'private' stamp: 'ul 5/16/2015 01:53'! determineTestMethod "Answer a block closure that will work as a can-match predicate. Answer nil if no viable optimization is possible (too many chars would be able to start a match)." | testers size | (conditions includes: #any) ifTrue: [^nil]. testers := { self prefixTester. self nonPrefixTester. self conditionTester. self methodPredicateTester. self nonMethodPredicateTester. self predicateTester. self nonPredicateTester } reject: [ :each | each isNil ]. (size := testers size) = 0 ifTrue: [ ^nil ]. size = 1 ifTrue: [ ^testers first ]. ^[ :char :matcher | testers anySatisfy: [ :t | t value: char value: matcher ] ]! ! !RxMatchOptimizer methodsFor: 'initialize-release' stamp: 'CamilloBruni 8/28/2013 16:49'! initialize: aRegex ignoreCase: aBoolean "Set `testMethod' variable to a can-match predicate block: two-argument block which accepts a lookahead character and a matcher (presumably built from aRegex) and answers a boolean indicating whether a match could start at the given lookahead. " ignoreCase := aBoolean. prefixes := Set new: 10. nonPrefixes := Set new: 10. conditions := Set new: 3. methodPredicates := Set new: 3. nonMethodPredicates := Set new: 3. predicates := Set new: 3. nonPredicates := Set new: 3. lookarounds := Set new: 3. aRegex dispatchTo: self. "If the whole expression is nullable, end-of-line is an implicit can-match condition!!" aRegex isNullable ifTrue: [conditions add: #atEndOfLine]. testBlock := self determineTestMethod! ! !RxMatchOptimizer methodsFor: 'accessing' stamp: 'ul 5/24/2015 21:38'! methodPredicateTester | p size | (size := methodPredicates size) = 0 ifTrue: [ ^nil ]. size = 1 ifTrue: [ | selector | "might be a pretty common case" selector := methodPredicates anyOne. ^[ :char :matcher | RxParser doHandlingMessageNotUnderstood: [ char perform: selector ] ] ]. p := methodPredicates asArray. ^[ :char :matcher | RxParser doHandlingMessageNotUnderstood: [ p anySatisfy: [ :sel | char perform: sel ] ] ]! ! !RxMatchOptimizer methodsFor: 'accessing' stamp: 'ul 5/24/2015 21:39'! nonMethodPredicateTester | p size | (size := nonMethodPredicates size) = 0 ifTrue: [ ^nil ]. size = 1 ifTrue: [ | selector | selector := nonMethodPredicates anyOne. ^[ :char :matcher | RxParser doHandlingMessageNotUnderstood: [ (char perform: selector) not ] ] ]. p := nonMethodPredicates asArray. ^[:char :m | RxParser doHandlingMessageNotUnderstood: [ (p allSatisfy: [:sel | char perform: sel ]) not ] ]! ! !RxMatchOptimizer methodsFor: 'private' stamp: 'ul 5/24/2015 21:40'! nonPredicateTester | p size | (size := nonPredicates size) = 0 ifTrue: [ ^nil ]. size = 1 ifTrue: [ | predicate | predicate := nonPredicates anyOne. ^[ :char :matcher | (predicate value: char) not] ]. p := nonPredicates asArray. ^[ :char :m | (p allSatisfy: [:some | some value: char ]) not ]! ! !RxMatchOptimizer methodsFor: 'private' stamp: 'ul 5/24/2015 21:41'! nonPrefixTester | size | (size := nonPrefixes size) = 0 ifTrue: [ ^nil ]. size = 1 ifTrue: [ | nonPrefixChar | nonPrefixChar := nonPrefixes anyOne. ^[ :char :matcher | char ~= nonPrefixChar ] ]. ^[ :char : matcher | (nonPrefixes includes: char) not ]! ! !RxMatchOptimizer methodsFor: 'private' stamp: 'vb 4/11/09 21:56'! optimizeSet: aSet "If a set is small, convert it to array to speed up lookup (Array has no hashing overhead, beats Set on small number of elements)." ^aSet size < 10 ifTrue: [aSet asArray] ifFalse: [aSet]! ! !RxMatchOptimizer methodsFor: 'private' stamp: 'ul 5/24/2015 21:43'! predicateTester | p size | (size := predicates size) = 0 ifTrue: [ ^nil ]. size = 1 ifTrue: [ | pred | pred := predicates anyOne. ^[ :char :matcher | pred value: char ] ]. p := predicates asArray. ^[ :char :matcher | p anySatisfy: [:some | some value: char ] ]! ! !RxMatchOptimizer methodsFor: 'private' stamp: 'ul 5/24/2015 21:47'! prefixTester | p size | (size := prefixes size) = 0 ifTrue: [ ^nil ]. size = 1 ifTrue: [ | prefixChar | prefixChar := prefixes anyOne. ignoreCase ifTrue: [ ^[ :char :matcher | char sameAs: prefixChar ] ]. ^[ :char :matcher | char = prefixChar ] ]. ignoreCase ifFalse: [ ^[ :char :matcher | prefixes includes: char ] ]. p := prefixes collect: [ :each | each asUppercase ]. ^[ :char :matcher | p includes: char asUppercase ]! ! !RxMatchOptimizer methodsFor: 'double dispatch' stamp: 'vb 4/11/09 21:56'! syntaxAny "Any special char is among the prefixes." conditions add: #any! ! !RxMatchOptimizer methodsFor: 'double dispatch' stamp: 'vb 4/11/09 21:56'! syntaxBeginningOfLine "Beginning of line is among the prefixes." conditions add: #atBeginningOfLine! ! !RxMatchOptimizer methodsFor: 'double dispatch' stamp: 'vb 4/11/09 21:56'! syntaxBeginningOfWord "Beginning of line is among the prefixes." conditions add: #atBeginningOfWord! ! !RxMatchOptimizer methodsFor: 'double dispatch' stamp: 'vb 4/11/09 21:56'! syntaxBranch: branchNode "If the head piece of the branch is transparent (allows 0 matches), we must recurse down the branch. Otherwise, just the head atom is important." (branchNode piece isNullable and: [branchNode branch notNil]) ifTrue: [branchNode branch dispatchTo: self]. branchNode piece dispatchTo: self! ! !RxMatchOptimizer methodsFor: 'double dispatch' stamp: 'ul 5/16/2015 01:30'! syntaxCharSet: charSetNode "All these (or none of these) characters is the prefix." (charSetNode enumerableSetIgnoringCase: ignoreCase) ifNotNil: [ :enumerableSet | charSetNode isNegated ifTrue: [ nonPrefixes addAll: enumerableSet ] ifFalse: [ prefixes addAll: enumerableSet ] ]. charSetNode predicates ifNotNil: [ :charsetPredicates | charSetNode isNegated ifTrue: [ nonPredicates addAll: charsetPredicates ] ifFalse: [ predicates addAll: charsetPredicates ] ]! ! !RxMatchOptimizer methodsFor: 'double dispatch' stamp: 'vb 4/11/09 21:56'! syntaxCharacter: charNode "This character is the prefix, of one of them." prefixes add: charNode character! ! !RxMatchOptimizer methodsFor: 'double dispatch' stamp: 'vb 4/11/09 21:56'! syntaxEndOfLine "Beginning of line is among the prefixes." conditions add: #atEndOfLine! ! !RxMatchOptimizer methodsFor: 'double dispatch' stamp: 'vb 4/11/09 21:56'! syntaxEndOfWord conditions add: #atEndOfWord! ! !RxMatchOptimizer methodsFor: 'double dispatch' stamp: 'vb 4/11/09 21:56'! syntaxEpsilon "Empty string, terminate the recursion (do nothing)."! ! !RxMatchOptimizer methodsFor: 'double dispatch' stamp: 'CamilloBruni 8/28/2013 16:48'! syntaxLookaround: lookaroundNode lookarounds add: lookaroundNode! ! !RxMatchOptimizer methodsFor: 'double dispatch' stamp: 'vb 4/11/09 21:56'! syntaxMessagePredicate: messagePredicateNode messagePredicateNode negated ifTrue: [nonMethodPredicates add: messagePredicateNode selector] ifFalse: [methodPredicates add: messagePredicateNode selector]! ! !RxMatchOptimizer methodsFor: 'double dispatch' stamp: 'vb 4/11/09 21:56'! syntaxNonWordBoundary conditions add: #notAtWordBoundary! ! !RxMatchOptimizer methodsFor: 'double dispatch' stamp: 'vb 4/11/09 21:56'! syntaxPiece: pieceNode "Pass on to the atom." pieceNode atom dispatchTo: self! ! !RxMatchOptimizer methodsFor: 'double dispatch' stamp: 'vb 4/11/09 21:56'! syntaxPredicate: predicateNode predicates add: predicateNode predicate! ! !RxMatchOptimizer methodsFor: 'double dispatch' stamp: 'vb 4/11/09 21:56'! syntaxRegex: regexNode "All prefixes of the regex's branches should be combined. Therefore, just recurse." regexNode branch dispatchTo: self. regexNode regex notNil ifTrue: [regexNode regex dispatchTo: self]! ! !RxMatchOptimizer methodsFor: 'double dispatch' stamp: 'vb 4/11/09 21:56'! syntaxWordBoundary conditions add: #atWordBoundary! ! !RxMatcher class methodsFor: 'instance creation' stamp: 'vb 4/11/09 21:56'! for: aRegex "Create and answer a matcher that will match a regular expression specified by the syntax tree of which `aRegex' is a root." ^self for: aRegex ignoreCase: false! ! !RxMatcher class methodsFor: 'instance creation' stamp: 'vb 4/11/09 21:56'! for: aRegex ignoreCase: aBoolean "Create and answer a matcher that will match a regular expression specified by the syntax tree of which `aRegex' is a root." ^self new initialize: aRegex ignoreCase: aBoolean! ! !RxMatcher class methodsFor: 'instance creation' stamp: 'vb 4/11/09 21:56'! forString: aString "Create and answer a matcher that will match the regular expression `aString'." ^self for: (RxParser new parse: aString)! ! !RxMatcher class methodsFor: 'instance creation' stamp: 'vb 4/11/09 21:56'! forString: aString ignoreCase: aBoolean "Create and answer a matcher that will match the regular expression `aString'." ^self for: (RxParser new parse: aString) ignoreCase: aBoolean! ! !RxMatcher class methodsFor: 'class initialization' stamp: 'avi 11/30/2003 13:30'! initialize "RxMatcher initialize" Cr := Character cr. Lf := Character lf.! ! !RxMatcher methodsFor: 'private' stamp: 'vb 4/11/09 21:56'! allocateMarker "Answer an integer to use as an index of the next marker." markerCount := markerCount + 1. ^markerCount! ! !RxMatcher methodsFor: 'testing' stamp: 'lr 1/15/2010 21:12'! atBeginningOfLine ^self position = 0 or: [self lastChar = Cr]! ! !RxMatcher methodsFor: 'testing' stamp: 'lr 1/15/2010 21:12'! atBeginningOfWord ^(self isWordChar: self lastChar) not and: [self isWordChar: stream peek]! ! !RxMatcher methodsFor: 'streaming' stamp: 'vb 4/11/09 21:56'! atEnd ^stream atEnd! ! !RxMatcher methodsFor: 'testing' stamp: 'vb 4/11/09 21:56'! atEndOfLine ^self atEnd or: [stream peek = Cr]! ! !RxMatcher methodsFor: 'testing' stamp: 'lr 1/15/2010 21:12'! atEndOfWord ^(self isWordChar: self lastChar) and: [(self isWordChar: stream peek) not]! ! !RxMatcher methodsFor: 'testing' stamp: 'lr 1/15/2010 21:12'! atWordBoundary ^(self isWordChar: self lastChar) xor: (self isWordChar: stream peek)! ! !RxMatcher methodsFor: 'accessing' stamp: 'vb 4/11/09 21:56'! buildFrom: aSyntaxTreeRoot "Private - Entry point of matcher build process." markerCount := 0. "must go before #dispatchTo: !!" matcher := aSyntaxTreeRoot dispatchTo: self. matcher terminateWith: RxmTerminator new! ! !RxMatcher methodsFor: 'match enumeration' stamp: 'vb 4/11/09 21:56'! copy: aString replacingMatchesWith: replacementString "Copy , except for the matches. Replace each match with ." | answer | answer := (String new: 40) writeStream. self copyStream: aString readStream to: answer replacingMatchesWith: replacementString. ^answer contents! ! !RxMatcher methodsFor: 'match enumeration' stamp: 'vb 4/11/09 21:56'! copy: aString translatingMatchesUsing: aBlock "Copy , except for the matches. For each match, evaluate passing the matched substring as the argument. Expect the block to answer a String, and replace the match with the answer." | answer | answer := (String new: 40) writeStream. self copyStream: aString readStream to: answer translatingMatchesUsing: aBlock. ^answer contents! ! !RxMatcher methodsFor: 'match enumeration' stamp: 'lr 1/15/2010 21:45'! copyStream: aStream to: writeStream replacingMatchesWith: aString "Copy the contents of on the , except for the matches. Replace each match with ." | searchStart matchStart matchEnd | stream := aStream. markerPositions := nil. [searchStart := aStream position. self proceedSearchingStream: aStream] whileTrue: [matchStart := (self subBeginning: 1) first. matchEnd := (self subEnd: 1) first. aStream position: searchStart. searchStart to: matchStart - 1 do: [:ignoredPos | writeStream nextPut: aStream next]. writeStream nextPutAll: aString. aStream position: matchEnd. "Be extra careful about successful matches which consume no input. After those, make sure to advance or finish if already at end." matchEnd = searchStart ifTrue: [aStream atEnd ifTrue: [^self "rest after end of whileTrue: block is a no-op if atEnd"] ifFalse: [writeStream nextPut: aStream next]]]. aStream position: searchStart. [aStream atEnd] whileFalse: [writeStream nextPut: aStream next]! ! !RxMatcher methodsFor: 'match enumeration' stamp: 'lr 1/15/2010 21:45'! copyStream: aStream to: writeStream translatingMatchesUsing: aBlock "Copy the contents of on the , except for the matches. For each match, evaluate passing the matched substring as the argument. Expect the block to answer a String, and write the answer to in place of the match." | searchStart matchStart matchEnd match | stream := aStream. markerPositions := nil. [searchStart := aStream position. self proceedSearchingStream: aStream] whileTrue: [matchStart := (self subBeginning: 1) first. matchEnd := (self subEnd: 1) first. aStream position: searchStart. searchStart to: matchStart - 1 do: [:ignoredPos | writeStream nextPut: aStream next]. match := (String new: matchEnd - matchStart + 1) writeStream. matchStart to: matchEnd - 1 do: [:ignoredPos | match nextPut: aStream next]. writeStream nextPutAll: (aBlock value: match contents). "Be extra careful about successful matches which consume no input. After those, make sure to advance or finish if already at end." matchEnd = searchStart ifTrue: [aStream atEnd ifTrue: [^self "rest after end of whileTrue: block is a no-op if atEnd"] ifFalse: [writeStream nextPut: aStream next]]]. aStream position: searchStart. [aStream atEnd] whileFalse: [writeStream nextPut: aStream next]! ! !RxMatcher methodsFor: 'privileged' stamp: 'ul 5/16/2015 01:41'! currentState "Answer an opaque object that can later be used to restore the matcher's state (for backtracking)." ^stream position! ! !RxMatcher methodsFor: 'private' stamp: 'ul 5/15/2015 23:18'! hookBranchOf: regexNode onto: endMarker "Private - Recurse down the chain of regexes starting at regexNode, compiling their branches and hooking their tails to the endMarker node." | rest | rest := regexNode regex ifNotNil: [ :regex | self hookBranchOf: regex onto: endMarker ]. ^RxmBranch new next: ((regexNode branch dispatchTo: self) pointTailTo: endMarker; yourself); alternative: rest; yourself! ! !RxMatcher methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! initialize: syntaxTreeRoot ignoreCase: aBoolean "Compile thyself for the regex with the specified syntax tree. See comment and `building' protocol in this class and #dispatchTo: methods in syntax tree components for details on double-dispatch building. The argument is supposedly a RxsRegex." ignoreCase := aBoolean. self buildFrom: syntaxTreeRoot. startOptimizer := RxMatchOptimizer new initialize: syntaxTreeRoot ignoreCase: aBoolean! ! !RxMatcher methodsFor: 'private' stamp: 'vb 4/11/09 21:56'! isWordChar: aCharacterOrNil "Answer whether the argument is a word constituent character: alphanumeric or _." ^aCharacterOrNil ~~ nil and: [aCharacterOrNil isAlphaNumeric]! ! !RxMatcher methodsFor: 'accessing' stamp: 'lr 1/15/2010 21:14'! lastChar ^ stream position = 0 ifFalse: [ stream skip: -1; next ]! ! !RxMatcher methodsFor: 'accessing' stamp: 'vb 4/11/09 21:56'! lastResult ^lastResult! ! !RxMatcher methodsFor: 'private' stamp: 'vb 4/11/09 21:56'! makeOptional: aMatcher "Private - Wrap this matcher so that the result would match 0 or 1 occurrences of the matcher." | dummy branch | dummy := RxmLink new. branch := (RxmBranch new beLoopback) next: aMatcher; alternative: dummy. aMatcher pointTailTo: dummy. ^branch! ! !RxMatcher methodsFor: 'private' stamp: 'vb 4/11/09 21:56'! makePlus: aMatcher "Private - Wrap this matcher so that the result would match 1 and more occurrences of the matcher." | loopback | loopback := (RxmBranch new beLoopback) next: aMatcher. aMatcher pointTailTo: loopback. ^aMatcher! ! !RxMatcher methodsFor: 'private' stamp: 'CamilloBruni 8/14/2013 16:41'! makeQuantified: anRxmLink min: min max: max "Perform recursive poor-man's transformation of the {,} quantifiers." | aMatcher | "{,} ==> ({1,})?" min = 0 ifTrue: [ ^ self makeOptional: (self makeQuantified: anRxmLink min: 1 max: max) ]. "{,} ==> {-1, -1}+" max ifNil: [ ^ (self makeQuantified: anRxmLink min: 1 max: min-1) pointTailTo: (self makePlus: anRxmLink copy) ]. "{,} ==> ... " min = max ifTrue: [ aMatcher := anRxmLink copy. (min-1) timesRepeat: [ aMatcher pointTailTo: anRxmLink copy ]. ^ aMatcher ]. "{,} ==> {,}({1,-1})?" aMatcher := self makeOptional: anRxmLink copy. (max - min - 1) timesRepeat: [ aMatcher := self makeOptional: (anRxmLink copy pointTailTo: aMatcher) ]. ^ (self makeQuantified: anRxmLink min: min max: min) pointTailTo: aMatcher! ! !RxMatcher methodsFor: 'private' stamp: 'vb 4/11/09 21:56'! makeStar: aMatcher "Private - Wrap this matcher so that the result would match 0 and more occurrences of the matcher." | dummy detour loopback | dummy := RxmLink new. detour := RxmBranch new next: aMatcher; alternative: dummy. loopback := (RxmBranch new beLoopback) next: aMatcher; alternative: dummy. aMatcher pointTailTo: loopback. ^detour! ! !RxMatcher methodsFor: 'privileged' stamp: 'vb 4/11/09 21:56'! markerPositionAt: anIndex add: position "Remember position of another instance of the given marker." (markerPositions at: anIndex) addFirst: position! ! !RxMatcher methodsFor: 'accessing' stamp: 'CamilloBruni 10/10/2012 14:14'! matches: aString "Match against a string. Return true if the complete String matches. If you want to search for occurences anywhere in the String see #search:" ^self matchesStream: aString readStream! ! !RxMatcher methodsFor: 'match enumeration' stamp: 'vb 4/11/09 21:56'! matchesIn: aString "Search aString repeatedly for the matches of the receiver. Answer an OrderedCollection of all matches (substrings)." | result | result := OrderedCollection new. self matchesOnStream: aString readStream do: [:match | result add: match]. ^result! ! !RxMatcher methodsFor: 'match enumeration' stamp: 'vb 4/11/09 21:56'! matchesIn: aString collect: aBlock "Search aString repeatedly for the matches of the receiver. Evaluate aBlock for each match passing the matched substring as the argument, collect evaluation results in an OrderedCollection, and return in. The following example shows how to use this message to split a string into words." "'\w+' asRegex matchesIn: 'Now is the Time' collect: [:each | each asLowercase]" | result | result := OrderedCollection new. self matchesOnStream: aString readStream do: [:match | result add: (aBlock value: match)]. ^result! ! !RxMatcher methodsFor: 'match enumeration' stamp: 'vb 4/11/09 21:56'! matchesIn: aString do: aBlock "Search aString repeatedly for the matches of the receiver. Evaluate aBlock for each match passing the matched substring as the argument." self matchesOnStream: aString readStream do: aBlock! ! !RxMatcher methodsFor: 'match enumeration' stamp: 'vb 4/11/09 21:56'! matchesOnStream: aStream | result | result := OrderedCollection new. self matchesOnStream: aStream do: [:match | result add: match]. ^result! ! !RxMatcher methodsFor: 'match enumeration' stamp: 'vb 4/11/09 21:56'! matchesOnStream: aStream collect: aBlock | result | result := OrderedCollection new. self matchesOnStream: aStream do: [:match | result add: (aBlock value: match)]. ^result! ! !RxMatcher methodsFor: 'match enumeration' stamp: 'cami 9/12/2013 23:48'! matchesOnStream: aStream do: aBlock "Be extra careful about successful matches which consume no input. After those, make sure to advance or finish if already at end." | position subexpression | [ position := aStream position. self searchStream: aStream ] whileTrue: [ subexpression := self subexpression: 1. aBlock value: subexpression. subexpression size = 0 ifTrue: [ aStream atEnd ifTrue: [^self] ifFalse: [aStream next]]]! ! !RxMatcher methodsFor: 'accessing' stamp: 'CamilloBruni 10/10/2012 14:15'! matchesPrefix: aString "Match against a string. Return true if a prefix matches. If you want to match - the full string use #matches: - anywhere in the string use #search:" ^self matchesStreamPrefix: aString readStream! ! !RxMatcher methodsFor: 'accessing' stamp: 'vb 4/11/09 21:56'! matchesStream: theStream "Match thyself against a positionable stream." ^(self matchesStreamPrefix: theStream) and: [stream atEnd]! ! !RxMatcher methodsFor: 'accessing' stamp: 'lr 1/15/2010 21:45'! matchesStreamPrefix: theStream "Match thyself against a positionable stream." stream := theStream. markerPositions := nil. ^self tryMatch! ! !RxMatcher methodsFor: 'match enumeration' stamp: 'vb 4/11/09 21:56'! matchingRangesIn: aString "Search aString repeatedly for the matches of the receiver. Answer an OrderedCollection of ranges of each match (index of first character to: index of last character)." | result | result := OrderedCollection new. self matchesIn: aString do: [:match | result add: (self position - match size + 1 to: self position)]. ^result! ! !RxMatcher methodsFor: 'streaming' stamp: 'lr 1/15/2010 21:13'! next ^ stream next! ! !RxMatcher methodsFor: 'testing' stamp: 'vb 4/11/09 21:56'! notAtWordBoundary ^self atWordBoundary not! ! !RxMatcher methodsFor: 'streaming' stamp: 'vb 4/11/09 21:56'! position ^stream position! ! !RxMatcher methodsFor: 'private' stamp: 'lr 1/15/2010 21:17'! proceedSearchingStream: aStream | position | position := aStream position. [aStream atEnd] whileFalse: [self tryMatch ifTrue: [^true]. aStream position: position; next. position := aStream position]. "Try match at the very stream end too!!" self tryMatch ifTrue: [^true]. ^false! ! !RxMatcher methodsFor: 'privileged' stamp: 'ul 5/16/2015 01:41'! restoreState: streamPosition stream position: streamPosition! ! !RxMatcher methodsFor: 'accessing' stamp: 'CamilloBruni 10/10/2012 14:13'! search: aString "Search anywhere in the String for occurrence of something matching myself. If you want to match the full String see #matches: Answer a Boolean indicating success." ^self searchStream: aString readStream! ! !RxMatcher methodsFor: 'accessing' stamp: 'lr 1/15/2010 21:45'! searchStream: aStream "Search the stream for occurrence of something matching myself. After the search has occurred, stop positioned after the end of the matched substring. Answer a Boolean indicating success." | position | stream := aStream. position := aStream position. markerPositions := nil. [aStream atEnd] whileFalse: [self tryMatch ifTrue: [^true]. aStream position: position; next. position := aStream position]. "Try match at the very stream end too!!" self tryMatch ifTrue: [^true]. ^false! ! !RxMatcher methodsFor: 'accessing' stamp: 'vb 4/11/09 21:56'! subBeginning: subIndex ^markerPositions at: subIndex * 2 - 1! ! !RxMatcher methodsFor: 'accessing' stamp: 'vb 4/11/09 21:56'! subEnd: subIndex ^markerPositions at: subIndex * 2! ! !RxMatcher methodsFor: 'accessing' stamp: 'vb 4/11/09 21:56'! subexpression: subIndex "Answer a string that matched the subexpression at the given index. If there are multiple matches, answer the last one. If there are no matches, answer nil. (NB: it used to answer an empty string but I think nil makes more sense)." | matches | matches := self subexpressions: subIndex. ^matches isEmpty ifTrue: [nil] ifFalse: [matches last]! ! !RxMatcher methodsFor: 'accessing' stamp: 'vb 4/11/09 21:56'! subexpressionCount ^markerCount // 2! ! !RxMatcher methodsFor: 'accessing' stamp: 'ul 5/14/2015 02:41'! subexpressions: subIndex "Answer an array of all matches of the subexpression at the given index. The answer is always an array; it is empty if there are no matches." | originalPosition startPositions stopPositions reply | originalPosition := stream position. startPositions := self subBeginning: subIndex. stopPositions := self subEnd: subIndex. (startPositions isEmpty or: [stopPositions isEmpty]) ifTrue: [^Array new]. reply := Array new: startPositions size. 1 to: reply size do: [ :index | | start stop | start := startPositions at: index. stop := stopPositions at: index. stream position: start. reply at: index put: (stream next: stop - start) ]. stream position: originalPosition. ^reply! ! !RxMatcher methodsFor: 'testing' stamp: 'vb 4/11/09 21:56'! supportsSubexpressions ^true! ! !RxMatcher methodsFor: 'double dispatch' stamp: 'vb 4/11/09 21:56'! syntaxAny "Double dispatch from the syntax tree. Create a matcher for any non-null character." ^RxmPredicate new predicate: [:char | char asInteger ~= 0]! ! !RxMatcher methodsFor: 'double dispatch' stamp: 'vb 4/11/09 21:56'! syntaxBeginningOfLine "Double dispatch from the syntax tree. Create a matcher for beginning-of-line condition." ^RxmSpecial new beBeginningOfLine! ! !RxMatcher methodsFor: 'double dispatch' stamp: 'vb 4/11/09 21:56'! syntaxBeginningOfWord "Double dispatch from the syntax tree. Create a matcher for beginning-of-word condition." ^RxmSpecial new beBeginningOfWord! ! !RxMatcher methodsFor: 'double dispatch' stamp: 'ul 5/15/2015 23:25'! syntaxBranch: branchNode "Double dispatch from the syntax tree. Branch node is a link in a chain of concatenated pieces. First build the matcher for the rest of the chain, then make it for the current piece and hook the rest to it." | piece branch | piece := branchNode piece. branch := branchNode branch ifNil: [ ^piece dispatchTo: self ]. "Optimization: glue a sequence of individual characters into a single string to match." piece isAtomic ifTrue: [ | result next stream | stream := (String new: 40) writeStream. next := branchNode tryMergingInto: stream. result := stream contents. result size > 1 ifTrue: [ "worth merging" ^(RxmSubstring new substring: result ignoreCase: ignoreCase) pointTailTo: (next ifNotNil: [ next dispatchTo: self ]); yourself ] ]. "No optimization possible or worth it, just concatenate all. " ^(piece dispatchTo: self) pointTailTo: (branch dispatchTo: self); yourself! ! !RxMatcher methodsFor: 'double dispatch' stamp: 'vb 4/11/09 21:56'! syntaxCharSet: charSetNode "Double dispatch from the syntax tree. A character set is a few characters, and we either match any of them, or match any that is not one of them." ^RxmPredicate with: (charSetNode predicateIgnoringCase: ignoreCase)! ! !RxMatcher methodsFor: 'double dispatch' stamp: 'vb 4/11/09 21:56'! syntaxCharacter: charNode "Double dispatch from the syntax tree. We get here when no merging characters into strings was possible." | wanted | wanted := charNode character. ^RxmPredicate new predicate: (ignoreCase ifTrue: [[:char | char sameAs: wanted]] ifFalse: [[:char | char = wanted]])! ! !RxMatcher methodsFor: 'double dispatch' stamp: 'vb 4/11/09 21:56'! syntaxEndOfLine "Double dispatch from the syntax tree. Create a matcher for end-of-line condition." ^RxmSpecial new beEndOfLine! ! !RxMatcher methodsFor: 'double dispatch' stamp: 'vb 4/11/09 21:56'! syntaxEndOfWord "Double dispatch from the syntax tree. Create a matcher for end-of-word condition." ^RxmSpecial new beEndOfWord! ! !RxMatcher methodsFor: 'double dispatch' stamp: 'vb 4/11/09 21:56'! syntaxEpsilon "Double dispatch from the syntax tree. Match empty string. This is unlikely to happen in sane expressions, so we'll live without special epsilon-nodes." ^RxmSubstring new substring: String new ignoreCase: ignoreCase! ! !RxMatcher methodsFor: 'double dispatch' stamp: 'CamilloBruni 8/28/2013 17:07'! syntaxLookaround: lookaroundNode "Double dispatch from the syntax tree. Special link can handle lookarounds (look ahead, positive and negative)." | piece | piece := lookaroundNode piece dispatchTo: self. ^ RxmLookahaed with: piece! ! !RxMatcher methodsFor: 'double dispatch' stamp: 'vb 4/11/09 21:56'! syntaxMessagePredicate: messagePredicateNode "Double dispatch from the syntax tree. Special link can handle predicates." ^messagePredicateNode negated ifTrue: [RxmPredicate new bePerformNot: messagePredicateNode selector] ifFalse: [RxmPredicate new bePerform: messagePredicateNode selector]! ! !RxMatcher methodsFor: 'double dispatch' stamp: 'vb 4/11/09 21:56'! syntaxNonWordBoundary "Double dispatch from the syntax tree. Create a matcher for the word boundary condition." ^RxmSpecial new beNotWordBoundary! ! !RxMatcher methodsFor: 'double dispatch' stamp: 'ul 5/15/2015 23:26'! syntaxPiece: pieceNode "Double dispatch from the syntax tree. Piece is an atom repeated a few times. Take care of a special case when the atom is repeated just once." | atom | atom := pieceNode atom dispatchTo: self. pieceNode isSingular ifTrue: [ ^atom ]. pieceNode isStar ifTrue: [ ^self makeStar: atom ]. pieceNode isPlus ifTrue: [ ^self makePlus: atom ]. pieceNode isOptional ifTrue: [ ^self makeOptional: atom ]. ^self makeQuantified: atom min: pieceNode min max: pieceNode max! ! !RxMatcher methodsFor: 'double dispatch' stamp: 'vb 4/11/09 21:56'! syntaxPredicate: predicateNode "Double dispatch from the syntax tree. A character set is a few characters, and we either match any of them, or match any that is not one of them." ^RxmPredicate with: predicateNode predicate! ! !RxMatcher methodsFor: 'double dispatch' stamp: 'vb 4/11/09 21:56'! syntaxRegex: regexNode "Double dispatch from the syntax tree. Regex node is a chain of branches to be tried. Should compile this into a bundle of parallel branches, between two marker nodes." | startIndex endIndex endNode alternatives | startIndex := self allocateMarker. endIndex := self allocateMarker. endNode := RxmMarker new index: endIndex. alternatives := self hookBranchOf: regexNode onto: endNode. ^(RxmMarker new index: startIndex) pointTailTo: alternatives; yourself! ! !RxMatcher methodsFor: 'double dispatch' stamp: 'vb 4/11/09 21:56'! syntaxWordBoundary "Double dispatch from the syntax tree. Create a matcher for the word boundary condition." ^RxmSpecial new beWordBoundary! ! !RxMatcher methodsFor: 'private' stamp: 'ul 5/14/2015 03:04'! tryMatch "Match thyself against the current stream." | oldMarkerPositions | oldMarkerPositions := markerPositions. markerPositions := Array new: markerCount. 1 to: markerCount do: [ :i | | collection | collection := OrderedCollection new. collection resetTo: collection capacity + 1. "We'll add element to the beginning, so make room there." markerPositions at: i put: collection ]. lastResult := startOptimizer isNil ifTrue: [ matcher matchAgainst: self] ifFalse: [ (startOptimizer canStartMatch: stream peek in: self) and: [ matcher matchAgainst: self ] ]. "check for duplicates" (lastResult not or: [ oldMarkerPositions isNil or: [ oldMarkerPositions size ~= markerPositions size ] ]) ifTrue: [ ^ lastResult ]. oldMarkerPositions with: markerPositions do: [ :oldPos :newPos | oldPos size = newPos size ifFalse: [ ^ lastResult ]. oldPos with: newPos do: [ :old :new | old = new ifFalse: [ ^ lastResult ] ] ]. "this is a duplicate" ^ lastResult := false! ! !RxParser class methodsFor: 'DOCUMENTATION' stamp: 'vb 4/11/09 21:56'! a: x introduction: xx " A regular expression is a template specifying a class of strings. A regular expression matcher is an tool that determines whether a string belongs to a class specified by a regular expression. This is a common task of a user input validation code, and the use of regular expressions can GREATLY simplify and speed up development of such code. As an example, here is how to verify that a string is a valid hexadecimal number in Smalltalk notation, using this matcher package: aString matchesRegex: '16r[[:xdigit:]]+' (Coding the same ``the hard way'' is an exercise to a curious reader). This matcher is offered to the Smalltalk community in hope it will be useful. It is free in terms of money, and to a large extent--in terms of rights of use. Refer to `Boring Stuff' section for legalese. The 'What's new in this release' section describes the functionality introduced in 1.1 release. The `Syntax' section explains the recognized syntax of regular expressions. The `Usage' section explains matcher capabilities that go beyond what String>>matchesRegex: method offers. The `Implementation notes' sections says a few words about what is under the hood. Happy hacking, --Vassili Bykov August 6, 1996 April 4, 1999 " self error: 'comment only'! ! !RxParser class methodsFor: 'DOCUMENTATION' stamp: 'lr 1/7/2010 20:10'! b: x whatsNewInThisRelease: xx " VERSION 1.3.1 (September 2008) 1. Updated documentation of character classes, making clear the problems of locale - an area for future improvement VERSION 1.3 (September 2008) 1. \w now matches underscore as well as alphanumerics, in line with most other regex libraries (and our documentation!!). 2. \W rejects underscore as well as alphanumerics 3. added tests for this at end of testSuite 4. updated documentation and added note to old incorrect comments in version 1.1 below VERSION 1.2.3 (November 2007) 1. Regexs with ^ or $ applied to copy empty strings caused infinite loops, e.g. ('' copyWithRegex: '^.*$' matchesReplacedWith: 'foo'). Applied a similar correction to that from version 1.1c, to #copyStream:to:(replacingMatchesWith:|translatingMatchesUsing:). 2. Extended RxParser testing to run each test for #copy:translatingMatchesUsing: as well as #search:. 3. Corrected #testSuite test that a dot does not match a null, which was passing by luck with Smalltalk code in a literal array. 4. Added test to end of test suite for fix 1 above. VERSION 1.2.2 (November 2006) There was no way to specify a backslash in a character set. Now [\\] is accepted. VERSION 1.2.1 (August 2006) 1. Support for returning all ranges (startIndex to: stopIndex) matching a regex - #allRangesOfRegexMatches:, #matchingRangesIn: 2. Added hint to usage documentation on how to get more information about matches when enumerating 3. Syntax description of dot corrected: matches anything but NUL since 1.1a VERSION 1.2 (May 2006) Fixed case-insensitive search for character sets. VERSION 1.1c (December 2004) Fixed the issue with #matchesOnStream:do: which caused infinite loops for matches that matched empty strings. VERSION 1.1b (November 2001) Changes valueNowOrOnUnwindDo: to ensure:, plus incorporates some earlier fixes. VERSION 1.1a (May 2001) 1. Support for keeping track of multiple subexpressions. 2. Dot (.) matches anything but NUL character, as it should per POSIX spec. 3. Some bug fixes. VERSION 1.1 (October 1999) Regular expression syntax corrections and enhancements: 1. Backslash escapes similar to those in Perl are allowed in patterns: \w any word constituent character (equivalent to [a-zA-Z0-9_]) *** underscore only since 1.3 *** \W any character but a word constituent (equivalent to [^a-xA-Z0-9_] *** underscore only since 1.3 *** \d a digit (same as [0-9]) \D anything but a digit \s a whitespace character \S anything but a whitespace character \b an empty string at a word boundary \B an empty string not at a word boundary \< an empty string at the beginning of a word \> an empty string at the end of a word For example, '\w+' is now a valid expression matching any word. 2. The following backslash escapes are also allowed in character sets (between square brackets): \w, \W, \d, \D, \s, and \S. 3. The following grep(1)-compatible named character classes are recognized in character sets as well: [:alnum:] [:alpha:] [:cntrl:] [:digit:] [:graph:] [:lower:] [:print:] [:punct:] [:space:] [:upper:] [:xdigit:] For example, the following patterns are equivalent: '[[:alnum:]_]+' '\w+' '[\w]+' '[a-zA-Z0-9_]+' *** underscore only since 1.3 *** 4. Some non-printable characters can be represented in regular expressions using a common backslash notation: \t tab (Character tab) \n newline (Character lf) \r carriage return (Character cr) \f form feed (Character newPage) \e escape (Character esc) 5. A dot is corectly interpreted as 'any character but a newline' instead of 'anything but whitespace'. 6. Case-insensitive matching. The easiest access to it are new messages CharacterArray understands: #asRegexIgnoringCase, #matchesRegexIgnoringCase:, #prefixMatchesRegexIgnoringCase:. 7. The matcher (an instance of RxMatcher, the result of String>>asRegex) now provides a collection-like interface to matches in a particular string or on a particular stream, as well as substitution protocol. The interface includes the following messages: matchesIn: aString matchesIn: aString collect: aBlock matchesIn: aString do: aBlock matchesOnStream: aStream matchesOnStream: aStream collect: aBlock matchesOnStream: aStream do: aBlock copy: aString translatingMatchesUsing: aBlock copy: aString replacingMatchesWith: replacementString copyStream: aStream to: writeStream translatingMatchesUsing: aBlock copyStream: aStream to: writeStream replacingMatchesWith: aString Examples: '\w+' asRegex matchesIn: 'now is the time' returns an OrderedCollection containing four strings: 'now', 'is', 'the', and 'time'. '\= 32). [:lower:] any lowercase character (including non-ASCII lowercase characters) [:print:] any printable character. In this version, this is the same as [:graph:] [:punct:] any punctuation character: . , !! ? ; : ' - ( ) ` and double quotes [:space:] any whitespace character (space, tab, CR, LF, null, form feed, Ctrl-Z, 16r2000-16r200B, 16r3000) [:upper:] any uppercase character (including non-ASCII uppercase characters) [:xdigit:] any hexadecimal character (same as [a-fA-F0-9]). Note that many of these are only as consistent or inconsistent on issues of locale as the underlying Smalltalk implementation. Values shown here are for VisualWorks 7.6. Note that these elements are components of the character classes, i.e. they have to be enclosed in an extra set of square brackets to form a valid regular expression. For example, a non-empty string of digits would be represented as '[[:digit:]]+'. The above primitive expressions and operators are common to many implementations of regular expressions. The next primitive expression is unique to this Smalltalk implementation. A sequence of characters between colons is treated as a unary selector which is supposed to be understood by Characters. A character matches such an expression if it answers true to a message with that selector. This allows a more readable and efficient way of specifying character classes. For example, `[0-9]' is equivalent to `:isDigit:', but the latter is more efficient. Analogously to character sets, character classes can be negated: `:^isDigit:' matches a Character that answers false to #isDigit, and is therefore equivalent to `[^0-9]'. As an example, so far we have seen the following equivalent ways to write a regular expression that matches a non-empty string of digits: '[0-9]+' '\d+' '[\d]+' '[[:digit:]]+' :isDigit:+' The last group of special primitive expressions includes: . matching any character except a NULL; ^ matching an empty string at the beginning of a line; $ matching an empty string at the end of a line. \b an empty string at a word boundary \B an empty string not at a word boundary \< an empty string at the beginning of a word \> an empty string at the end of a word 'axyzb' matchesRegex: 'a.+b' -- true 'ax zb' matchesRegex: 'a.+b' -- true (space is matched by `.') 'ax zb' matchesRegex: 'a.+b' -- true (carriage return is matched by `.') Again, the dot ., caret ^ and dollar $ characters are special and should be quoted to be matched literally. EXAMPLES As the introductions said, a great use for regular expressions is user input validation. Following are a few examples of regular expressions that might be handy in checking input entered by the user in an input field. Try them out by entering something between the quotes and print-iting. (Also, try to imagine Smalltalk code that each validation would require if coded by hand). Most example expressions could have been written in alternative ways. Checking if aString may represent a nonnegative integer number: '' matchesRegex: ':isDigit:+' or '' matchesRegex: '[0-9]+' or '' matchesRegex: '\d+' Checking if aString may represent an integer number with an optional sign in front: '' matchesRegex: '(\+|-)?\d+' Checking if aString is a fixed-point number, with at least one digit is required after a dot: '' matchesRegex: '(\+|-)?\d+(\.\d+)?' The same, but allow notation like `123.': '' matchesRegex: '(\+|-)?\d+(\.\d*)?' Recognizer for a string that might be a name: one word with first capital letter, no blanks, no digits. More traditional: '' matchesRegex: '[A-Z][A-Za-z]*' more Smalltalkish: '' matchesRegex: ':isUppercase::isAlphabetic:*' A date in format MMM DD, YYYY with any number of spaces in between, in XX century: '' matchesRegex: '(Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)[ ]+(\d\d?)[ ]*,[ ]*19(\d\d)' Note parentheses around some components of the expression above. As `Usage' section shows, they will allow us to obtain the actual strings that have matched them (i.e. month name, day number, and year number). For dessert, coming back to numbers: here is a recognizer for a general number format: anything like 999, or 999.999, or -999.999e+21. '' matchesRegex: '(\+|-)?\d+(\.\d*)?((e|E)(\+|-)?\d+)?' " self error: 'comment only'! ! !RxParser class methodsFor: 'DOCUMENTATION' stamp: 'vb 4/11/09 21:56'! d: x usage: xx " The preceding section covered the syntax of regular expressions. It used the simplest possible interface to the matcher: sending #matchesRegex: message to the sample string, with regular expression string as the argument. This section explains hairier ways of using the matcher. PREFIX MATCHING AND CASE-INSENSITIVE MATCHING A CharacterArray (an EsString in VA) also understands these messages: #prefixMatchesRegex: regexString #matchesRegexIgnoringCase: regexString #prefixMatchesRegexIgnoringCase: regexString #prefixMatchesRegex: is just like #matchesRegex, except that the whole receiver is not expected to match the regular expression passed as the argument; matching just a prefix of it is enough. For example: 'abcde' matchesRegex: '(a|b)+' -- false 'abcde' prefixMatchesRegex: '(a|b)+' -- true The last two messages are case-insensitive versions of matching. ENUMERATION INTERFACE An application can be interested in all matches of a certain regular expression within a String. The matches are accessible using a protocol modelled after the familiar Collection-like enumeration protocol: #regex: regexString matchesDo: aBlock Evaluates a one-argument for every match of the regular expression within the receiver string. #regex: regexString matchesCollect: aBlock Evaluates a one-argument for every match of the regular expression within the receiver string. Collects results of evaluations and anwers them as a SequenceableCollection. #allRegexMatches: regexString Returns a collection of all matches (substrings of the receiver string) of the regular expression. It is an equivalent of . #allRangesOfRegexMatches: regexString Returns a collection of all character ranges (startIndex to: stopIndex) that match the regular expression. REPLACEMENT AND TRANSLATION It is possible to replace all matches of a regular expression with a certain string using the message: #copyWithRegex: regexString matchesReplacedWith: aString For example: 'ab cd ab' copyWithRegex: '(a|b)+' matchesReplacedWith: 'foo' A more general substitution is match translation: #copyWithRegex: regexString matchesTranslatedUsing: aBlock This message evaluates a block passing it each match of the regular expression in the receiver string and answers a copy of the receiver with the block results spliced into it in place of the respective matches. For example: 'ab cd ab' copyWithRegex: '(a|b)+' matchesTranslatedUsing: [:each | each asUppercase] All messages of enumeration and replacement protocols perform a case-sensitive match. Case-insensitive versions are not provided as part of a CharacterArray protocol. Instead, they are accessible using the lower-level matching interface. LOWER-LEVEL INTERFACE Internally, #matchesRegex: works as follows: 1. A fresh instance of RxParser is created, and the regular expression string is passed to it, yielding the expression's syntax tree. 2. The syntax tree is passed as an initialization parameter to an instance of RxMatcher. The instance sets up some data structure that will work as a recognizer for the regular expression described by the tree. 3. The original string is passed to the matcher, and the matcher checks for a match. THE MATCHER If you repeatedly match a number of strings against the same regular expression using one of the messages defined in CharacterArray, the regular expression string is parsed and a matcher is created anew for every match. You can avoid this overhead by building a matcher for the regular expression, and then reusing the matcher over and over again. You can, for example, create a matcher at a class or instance initialization stage, and store it in a variable for future use. You can create a matcher using one of the following methods: - Sending #forString:ignoreCase: message to RxMatcher class, with the regular expression string and a Boolean indicating whether case is ignored as arguments. - Sending #forString: message. It is equivalent to <... forString: regexString ignoreCase: false>. A more convenient way is using one of the two matcher-created messages understood by CharacterArray. - is equivalent to . - is equivalent to . Here are four examples of creating a matcher: hexRecognizer := RxMatcher forString: '16r[0-9A-Fa-f]+' hexRecognizer := RxMatcher forString: '16r[0-9A-Fa-f]+' ignoreCase: false hexRecognizer := '16r[0-9A-Fa-f]+' asRegex hexRecognizer := '16r[0-9A-F]+' asRegexIgnoringCase MATCHING The matcher understands these messages (all of them return true to indicate successful match or search, and false otherwise): matches: aString True if the whole target string (aString) matches. matchesPrefix: aString True if some prefix of the string (not necessarily the whole string) matches. search: aString Search the string for the first occurrence of a matching substring. (Note that the first two methods only try matching from the very beginning of the string). Using the above example with a matcher for `a+', this method would answer success given a string `baaa', while the previous two would fail. matchesStream: aStream matchesStreamPrefix: aStream searchStream: aStream Respective analogs of the first three methods, taking input from a stream instead of a string. The stream must be positionable and peekable. All these methods answer a boolean indicating success. The matcher also stores the outcome of the last match attempt and can report it: lastResult Answers a Boolean -- the outcome of the most recent match attempt. If no matches were attempted, the answer is unspecified. SUBEXPRESSION MATCHES After a successful match attempt, you can query the specifics of which part of the original string has matched which part of the whole expression. A subexpression is a parenthesized part of a regular expression, or the whole expression. When a regular expression is compiled, its subexpressions are assigned indices starting from 1, depth-first, left-to-right. For example, `((ab)+(c|d))?ef' includes the following subexpressions with these indices: 1: ((ab)+(c|d))?ef 2: (ab)+(c|d) 3: ab 4: c|d After a successful match, the matcher can report what part of the original string matched what subexpression. It understandards these messages: subexpressionCount Answers the total number of subexpressions: the highest value that can be used as a subexpression index with this matcher. This value is available immediately after initialization and never changes. subexpression: anIndex An index must be a valid subexpression index, and this message must be sent only after a successful match attempt. The method answers a substring of the original string the corresponding subexpression has matched to. subBeginning: anIndex subEnd: anIndex Answer positions within the original string or stream where the match of a subexpression with the given index has started and ended, respectively. This facility provides a convenient way of extracting parts of input strings of complex format. For example, the following piece of code uses the 'MMM DD, YYYY' date format recognizer example from the `Syntax' section to convert a date to a three-element array with year, month, and day strings (you can select and evaluate it right here): | matcher | matcher := RxMatcher forString: '(Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)[ ]+(:isDigit::isDigit:?)[ ]*,[ ]*(19|20)(:isDigit::isDigit:)'. (matcher matches: 'Aug 6, 1996') ifTrue: [Array with: (matcher subexpression: 5) with: (matcher subexpression: 2) with: (matcher subexpression: 3)] ifFalse: ['no match'] (should answer ` #('96' 'Aug' '6')'). ENUMERATION AND REPLACEMENT The enumeration and replacement protocols exposed in CharacterArray are actually implemented by the matcher. The following messages are understood: #matchesIn: aString #matchesIn: aString do: aBlock #matchesIn: aString collect: aBlock #copy: aString replacingMatchesWith: replacementString #copy: aString translatingMatchesUsing: aBlock #matchingRangesIn: aString #matchesOnStream: aStream #matchesOnStream: aStream do: aBlock #matchesOnStream: aStream collect: aBlock #copy: sourceStream to: targetStream replacingMatchesWith: replacementString #copy: sourceStream to: targetStream translatingMatchesWith: aBlock Note that in those methods that take a block, the block may refer to the rxMatcher itself, e.g. to collect information about the position the match occurred at, or the subexpressions of the match. An example can be seen in #matchingRangesIn: ERROR HANDLING Exception signaling objects (Signals in VisualWorks, Exceptions in VisualAge) are accessible through RxParser class protocol. To handle possible errors, use the protocol described below to obtain the exception objects and use the protocol of the native Smalltalk implementation to handle them. If a syntax error is detected while parsing expression, RxParser>>syntaxErrorSignal is raised/signaled. If an error is detected while building a matcher, RxParser>>compilationErrorSignal is raised/signaled. If an error is detected while matching (for example, if a bad selector was specified using `::' syntax, or because of the matcher's internal error), RxParser>>matchErrorSignal is raised RxParser>>regexErrorSignal is the parent of all three. Since any of the three signals can be raised within a call to #matchesRegex:, it is handy if you want to catch them all. For example: VisualWorks: RxParser regexErrorSignal handle: [:ex | ex returnWith: nil] do: ['abc' matchesRegex: '))garbage['] VisualAge: ['abc' matchesRegex: '))garbage['] when: RxParser regexErrorSignal do: [:signal | signal exitWith: nil] " self error: 'comment only'! ! !RxParser class methodsFor: 'exception signaling' stamp: 'lr 11/4/2009 22:37'! doHandlingMessageNotUnderstood: aBlock "MNU should be trapped and resignaled as a match error in a few places in the matcher. This method factors out this dialect-dependent code to make porting easier." ^ aBlock on: MessageNotUnderstood do: [:ex | RxParser signalMatchException: 'invalid predicate selector']! ! !RxParser class methodsFor: 'DOCUMENTATION' stamp: 'vb 4/11/09 21:56'! e: x implementationNotes: xx " Version: 1.1 Released: October 1999 Mail to: Vassili Bykov , Flames to: /dev/null WHAT IS ADDED The matcher includes classes in two categories: VB-Regex-Syntax VB-Regex-Matcher and a few CharacterArray methods in `VB-regex' protocol. No system classes or methods are modified. WHAT TO LOOK AT FIRST String>>matchesRegex: -- in 90% cases this method is all you need to access the package. RxParser -- accepts a string or a stream of characters with a regular expression, and produces a syntax tree corresponding to the expression. The tree is made of instances of Rxs classes. RxMatcher -- accepts a syntax tree of a regular expression built by the parser and compiles it into a matcher: a structure made of instances of Rxm classes. The RxMatcher instance can test whether a string or a positionable stream of characters matches the original regular expression, or search a string or a stream for substrings matching the expression. After a match is found, the matcher can report a specific string that matched the whole expression, or any parenthesized subexpression of it. All other classes support the above functionality and are used by RxParser, RxMatcher, or both. CAVEATS The matcher is similar in spirit, but NOT in the design--let alone the code--to the original Henry Spencer's regular expression implementation in C. The focus is on simplicity, not on efficiency. I didn't optimize or profile anything. I may in future--or I may not: I do this in my spare time and I don't promise anything. The matcher passes H. Spencer's test suite (see 'test suite' protocol), with quite a few extra tests added, so chances are good there are not too many bugs. But watch out anyway. EXTENSIONS, FUTURE, ETC. With the existing separation between the parser, the syntax tree, and the matcher, it is easy to extend the system with other matchers based on other algorithms. In fact, I have a DFA-based matcher right now, but I don't feel it is good enough to include it here. I might add automata-based matchers later, but again I don't promise anything. HOW TO REACH ME As of today (December 20, 2000), you can contact me at . If this doesn't work, look around comp.lang.smalltalk or comp.lang.lisp. " self error: 'comment only'! ! !RxParser class methodsFor: 'DOCUMENTATION' stamp: 'vb 4/11/09 21:56'! f: x boringStuff: xx " The Regular Expression Matcher (``The Software'') is Copyright (C) 1996, 1999 Vassili Bykov. It is provided to the Smalltalk community in hope it will be useful. 1. This license applies to the package as a whole, as well as to any component of it. By performing any of the activities described below, you accept the terms of this agreement. 2. The software is provided free of charge, and ``as is'', in hope that it will be useful, with ABSOLUTELY NO WARRANTY. The entire risk and all responsibility for the use of the software is with you. Under no circumstances the author may be held responsible for loss of data, loss of profit, or any other damage resulting directly or indirectly from the use of the software, even if the damage is caused by defects in the software. 3. You may use this software in any applications you build. 4. You may distribute this software provided that the software documentation and copyright notices are included and intact. 5. You may create and distribute modified versions of the software, such as ports to other Smalltalk dialects or derived work, provided that: a. any modified version is expressly marked as such and is not misrepresented as the original software; b. credit is given to the original software in the source code and documentation of the derived work; c. the copyright notice at the top of this document accompanies copyright notices of any modified version. " self error: 'comment only'! ! !RxParser class methodsFor: 'class initialization' stamp: 'avi 11/30/2003 13:26'! initialize "self initialize" self initializeBackslashConstants; initializeBackslashSpecials! ! !RxParser class methodsFor: 'class initialization' stamp: 'lr 11/4/2009 22:14'! initializeBackslashConstants "self initializeBackslashConstants" (BackslashConstants := Dictionary new) at: $e put: Character escape; at: $n put: Character lf; at: $r put: Character cr; at: $f put: Character newPage; at: $t put: Character tab! ! !RxParser class methodsFor: 'class initialization' stamp: 'vb 4/11/09 21:56'! initializeBackslashSpecials "Keys are characters that normally follow a \, the values are associations of classes and initialization selectors on the instance side of the classes." "self initializeBackslashSpecials" (BackslashSpecials := Dictionary new) at: $w put: (Association key: RxsPredicate value: #beWordConstituent); at: $W put: (Association key: RxsPredicate value: #beNotWordConstituent); at: $s put: (Association key: RxsPredicate value: #beSpace); at: $S put: (Association key: RxsPredicate value: #beNotSpace); at: $d put: (Association key: RxsPredicate value: #beDigit); at: $D put: (Association key: RxsPredicate value: #beNotDigit); at: $b put: (Association key: RxsContextCondition value: #beWordBoundary); at: $B put: (Association key: RxsContextCondition value: #beNonWordBoundary); at: $< put: (Association key: RxsContextCondition value: #beBeginningOfWord); at: $> put: (Association key: RxsContextCondition value: #beEndOfWord)! ! !RxParser class methodsFor: 'utilities' stamp: 'vb 4/11/09 21:56'! parse: aString "Parse the argument and return the result (the parse tree). In case of a syntax error, the corresponding exception is signaled." ^self new parse: aString! ! !RxParser class methodsFor: 'preferences' stamp: 'vb 4/11/09 21:56'! preferredMatcherClass "The matcher to use. For now just one is available, but in principle this determines the matchers built implicitly, such as by String>>asRegex, or String>>matchesRegex:. This might seem a bit strange place for this preference, but Parser is still more or less `central' thing in the whole package." ^RxMatcher! ! !RxParser class methodsFor: 'utilities' stamp: 'avi 11/30/2003 13:23'! safelyParse: aString "Parse the argument and return the result (the parse tree). In case of a syntax error, return nil. Exception handling here is dialect-dependent." ^ [self new parse: aString] on: RegexSyntaxError do: [:ex | nil]! ! !RxParser class methodsFor: 'exception signaling' stamp: 'avi 11/30/2003 13:25'! signalCompilationException: errorString RegexCompilationError new signal: errorString! ! !RxParser class methodsFor: 'exception signaling' stamp: 'avi 11/30/2003 13:25'! signalMatchException: errorString RegexMatchingError new signal: errorString! ! !RxParser class methodsFor: 'exception signaling' stamp: 'avi 11/30/2003 13:25'! signalSyntaxException: errorString RegexSyntaxError new signal: errorString! ! !RxParser class methodsFor: 'exception signaling' stamp: 'CamilloBruni 10/7/2012 22:50'! signalSyntaxException: errorString at: errorPosition RegexSyntaxError signal: errorString at: errorPosition! ! !RxParser methodsFor: 'recursive descent' stamp: 'ul 5/16/2015 01:45'! atom "An atom is one of a lot of possibilities, see below." | atom | (lookahead == #epsilon or: [ lookahead == $| or: [ lookahead == $) or: [ lookahead == $* or: [ lookahead == $+ or: [ lookahead == $? ]]]]]) ifTrue: [ ^RxsEpsilon new ]. lookahead == $( ifTrue: [ " ::= '(' ')' " self match: $(. atom := self regex. self match: $). ^atom ]. lookahead == $[ ifTrue: [ " ::= '[' ']' " self match: $[. atom := self characterSet. self match: $]. ^atom ]. lookahead == $: ifTrue: [ " ::= ':' ':' " self match: $:. atom := self messagePredicate. self match: $:. ^atom ]. lookahead == $. ifTrue: [ "any non-whitespace character" self next. ^RxsContextCondition new beAny]. lookahead == $^ ifTrue: [ "beginning of line condition" self next. ^RxsContextCondition new beBeginningOfLine]. lookahead == $$ ifTrue: [ "end of line condition" self next. ^RxsContextCondition new beEndOfLine]. lookahead == $\ ifTrue: [ " ::= '\' " self next. lookahead == #epsilon ifTrue: [ self signalParseError: 'bad quotation' ]. (BackslashConstants includesKey: lookahead) ifTrue: [ atom := RxsCharacter with: (BackslashConstants at: lookahead). self next. ^atom]. self ifSpecial: lookahead then: [:node | self next. ^node]]. "If passed through the above, the following is a regular character." atom := RxsCharacter with: lookahead. self next. ^atom! ! !RxParser methodsFor: 'recursive descent' stamp: 'ul 5/16/2015 01:43'! branch " ::= e | " | piece branch | piece := self piece. (lookahead == #epsilon or: [ lookahead == $| or: [ lookahead == $) ]]) ifTrue: [ branch := nil ] ifFalse: [ branch := self branch ]. ^RxsBranch new initializePiece: piece branch: branch! ! !RxParser methodsFor: 'recursive descent' stamp: 'CamilloBruni 8/14/2013 09:19'! characterSet "Match a range of characters: something between `[' and `]'. Opening bracked has already been seen, and closing should not be consumed as well. Set spec is as usual for sets in regexes." | spec errorMessage | errorMessage := ' no terminating "]"'. spec := self inputUpTo: $] nestedOn: $[ errorMessage: errorMessage. (spec isEmpty or: [spec = '^']) ifTrue: [ "This ']' was literal." self next. spec := spec, ']', (self inputUpTo: $] nestedOn: $[ errorMessage: errorMessage)]. ^self characterSetFrom: spec! ! !RxParser methodsFor: 'private' stamp: 'vb 4/11/09 21:56'! characterSetFrom: setSpec " is what goes between the brackets in a charset regex (a String). Make a string containing all characters the spec specifies. Spec is never empty." | negated spec | spec := ReadStream on: setSpec. spec peek = $^ ifTrue: [negated := true. spec next] ifFalse: [negated := false]. ^RxsCharSet new initializeElements: (RxCharSetParser on: spec) parse negated: negated! ! !RxParser methodsFor: 'private' stamp: 'vb 4/11/09 21:56'! ifSpecial: aCharacter then: aBlock "If the character is such that it defines a special node when follows a $\, then create that node and evaluate aBlock with the node as the parameter. Otherwise just return." | classAndSelector | classAndSelector := BackslashSpecials at: aCharacter ifAbsent: [^self]. ^aBlock value: (classAndSelector key new perform: classAndSelector value)! ! !RxParser methodsFor: 'private' stamp: 'ul 5/16/2015 02:05'! inputUpTo: aCharacter errorMessage: aString "Accumulate input stream until is encountered and answer the accumulated chars as String, not including . Signal error if end of stream is encountered, passing as the error description." | accumulator | accumulator := WriteStream on: (String new: 20). [ lookahead == aCharacter or: [lookahead == #epsilon] ] whileFalse: [ accumulator nextPut: lookahead. self next]. lookahead == #epsilon ifTrue: [ self signalParseError: aString ]. ^accumulator contents! ! !RxParser methodsFor: 'private' stamp: 'ul 5/16/2015 01:50'! inputUpTo: aCharacter nestedOn: anotherCharacter errorMessage: aString "Accumulate input stream until is encountered and answer the accumulated chars as String, not including . Signal error if end of stream is encountered, passing as the error description." | accumulator nestLevel | accumulator := WriteStream on: (String new: 20). nestLevel := 0. [lookahead == aCharacter and: [nestLevel = 0]] whileFalse: [#epsilon == lookahead ifTrue: [self signalParseError: aString]. accumulator nextPut: lookahead. lookahead == anotherCharacter ifTrue: [nestLevel := nestLevel + 1]. lookahead == aCharacter ifTrue: [nestLevel := nestLevel - 1]. self next]. ^accumulator contents! ! !RxParser methodsFor: 'private' stamp: 'ul 5/16/2015 02:06'! inputUpToAny: aDelimiterString errorMessage: aString "Accumulate input stream until any character from is encountered and answer the accumulated chars as String, not including the matched characters from the . Signal error if end of stream is encountered, passing as the error description." | accumulator | accumulator := WriteStream on: (String new: 20). [ lookahead == #epsilon or: [ aDelimiterString includes: lookahead ] ] whileFalse: [ accumulator nextPut: lookahead. self next ]. lookahead == #epsilon ifTrue: [ self signalParseError: aString ]. ^accumulator contents! ! !RxParser methodsFor: 'recursive descent' stamp: 'ul 5/16/2015 02:06'! lookAround "Parse a lookaround expression after: (?) ::= !! | =" | lookaround | (lookahead == $!! or: [ lookahead == $=]) ifFalse: [ ^ self signalParseError: 'Invalid lookaround expression ?', lookahead asString ]. self next. lookaround := RxsLookaround with: self regex. lookahead == $!! ifTrue: [ lookaround beNegative ]. ^ lookaround ! ! !RxParser methodsFor: 'private' stamp: 'ul 5/16/2015 01:51'! match: aCharacter " MUST match the current lookeahead. If this is the case, advance the input. Otherwise, blow up." aCharacter == lookahead ifFalse: [ ^self signalParseError ]. "does not return" self next! ! !RxParser methodsFor: 'recursive descent' stamp: 'CamilloBruni 8/14/2013 09:44'! messagePredicate "Match a message predicate specification: a selector (presumably understood by a Character) enclosed in :'s ." | spec negated | spec := self inputUpTo: $: errorMessage: ' no terminating ":"'. negated := false. spec first = $^ ifTrue: [ negated := true. spec := spec copyFrom: 2 to: spec size]. ^RxsMessagePredicate new initializeSelector: spec asSymbol negated: negated! ! !RxParser methodsFor: 'private' stamp: 'ul 5/16/2015 02:07'! next "Advance the input storing the just read character as the lookahead." lookahead := input next ifNil: [ #epsilon ]! ! !RxParser methodsFor: 'accessing' stamp: 'vb 4/11/09 21:56'! parse: aString "Parse input from a string . On success, answers an RxsRegex -- parse tree root. On error, raises `RxParser syntaxErrorSignal' with the current input stream position as the parameter." ^self parseStream: (ReadStream on: aString)! ! !RxParser methodsFor: 'accessing' stamp: 'vb 4/11/09 21:56'! parseStream: aStream "Parse an input from a character stream . On success, answers an RxsRegex -- parse tree root. On error, raises `RxParser syntaxErrorSignal' with the current input stream position as the parameter." | tree | input := aStream. lookahead := nil. self match: nil. tree := self regex. self match: #epsilon. ^tree! ! !RxParser methodsFor: 'recursive descent' stamp: 'ul 5/16/2015 01:44'! piece " ::= | * | + | ? | {,}" | atom | atom := self atom. lookahead == $* ifTrue: [ self next. atom isNullable ifTrue: [ self signalNullableClosureParserError ]. ^ RxsPiece new initializeStarAtom: atom ]. lookahead == $+ ifTrue: [ self next. atom isNullable ifTrue: [ self signalNullableClosureParserError ]. ^ RxsPiece new initializePlusAtom: atom ]. lookahead == $? ifTrue: [ self next. atom isNullable ifTrue: [ ^ self lookAround ]. ^ RxsPiece new initializeOptionalAtom: atom ]. lookahead == ${ ifTrue: [ ^ self quantifiedAtom: atom ]. ^ RxsPiece new initializeAtom: atom! ! !RxParser methodsFor: 'recursive descent' stamp: 'ul 5/16/2015 02:07'! quantifiedAtom: atom "Parse a quanitifer expression which can have one of the following forms {,} match to occurences {} which is the same as with repeated limits: {,} {,} match at least occurences {,} match maximally occurences, which is the same as {0,}" | min max | self next. lookahead == $, ifTrue: [ min := 0 ] ifFalse: [ max := min := (self inputUpToAny: ',}' errorMessage: ' no terminating "}"') asUnsignedInteger ]. lookahead == $, ifTrue: [ self next. max := (self inputUpToAny: ',}' errorMessage: ' no terminating "}"') asUnsignedInteger ]. self match: $}. atom isNullable ifTrue: [ self signalNullableClosureParserError ]. (max notNil and: [ max < min ]) ifTrue: [ self signalParseError: ('wrong quantifier, expected ', min asString, ' <= ', max asString) ]. ^ RxsPiece new initializeAtom: atom min: min max: max! ! !RxParser methodsFor: 'recursive descent' stamp: 'ul 5/16/2015 01:43'! regex " ::= e | `|' " | branch regex | branch := self branch. (lookahead == #epsilon or: [ lookahead == $) ]) ifTrue: [ regex := nil ] ifFalse: [ self match: $|. regex := self regex ]. ^RxsRegex new initializeBranch: branch regex: regex! ! !RxParser methodsFor: 'private' stamp: 'CamilloBruni 8/14/2013 09:39'! signalNullableClosureParserError self signalParseError: ' nullable closure'.! ! !RxParser methodsFor: 'private' stamp: 'CamilloBruni 10/7/2012 22:50'! signalParseError self class signalSyntaxException: 'Regex syntax error' at: input position! ! !RxParser methodsFor: 'private' stamp: 'CamilloBruni 10/7/2012 22:49'! signalParseError: aString self class signalSyntaxException: aString at: input position! ! !RxmBranch methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! alternative: aBranch "See class comment for instance variable description." alternative := aBranch! ! !RxmBranch methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! beLoopback "See class comment for instance variable description." loopback := true! ! !RxmBranch methodsFor: 'initialization' stamp: 'lr 11/4/2009 22:38'! initialize "See class comment for instance variable description." super initialize. loopback := false! ! !RxmBranch methodsFor: 'matching' stamp: 'ul 5/14/2015 02:48'! matchAgainst: aMatcher "Match either `next' or `alternative'. Fail if the alternative is nil." (next matchAgainst: aMatcher) ifTrue: [ ^true ]. ^(alternative ifNil: [ ^false ]) matchAgainst: aMatcher! ! !RxmBranch methodsFor: 'building' stamp: 'CamilloBruni 8/14/2013 12:53'! pointTailTo: aNode "See superclass for explanations." loopback ifTrue: [ alternative == nil ifTrue: [alternative := aNode] ifFalse: [alternative pointTailTo: aNode]] ifFalse: [super pointTailTo: aNode]! ! !RxmBranch methodsFor: 'building' stamp: 'vb 4/11/09 21:56'! terminateWith: aNode "See superclass for explanations." loopback ifTrue: [alternative == nil ifTrue: [alternative := aNode] ifFalse: [alternative terminateWith: aNode]] ifFalse: [super terminateWith: aNode]! ! !RxmLink methodsFor: 'matching' stamp: 'vb 4/11/09 21:56'! matchAgainst: aMatcher "If a link does not match the contents of the matcher's stream, answer false. Otherwise, let the next matcher in the chain match." ^next matchAgainst: aMatcher! ! !RxmLink methodsFor: 'accessing' stamp: 'vb 4/11/09 21:56'! next ^next! ! !RxmLink methodsFor: 'accessing' stamp: 'vb 4/11/09 21:56'! next: aLink "Set the next link, either an RxmLink or an RxmTerminator." next := aLink! ! !RxmLink methodsFor: 'building' stamp: 'vb 4/11/09 21:56'! pointTailTo: anRxmLink "Propagate this message along the chain of links. Point `next' reference of the last link to . If the chain is already terminated, blow up." next == nil ifTrue: [next := anRxmLink] ifFalse: [next pointTailTo: anRxmLink]! ! !RxmLink methodsFor: 'copying' stamp: 'CamilloBruni 8/14/2013 14:33'! postCopy super postCopy. next := next copy! ! !RxmLink methodsFor: 'building' stamp: 'vb 4/11/09 21:56'! terminateWith: aTerminator "Propagate this message along the chain of links, and make aTerminator the `next' link of the last link in the chain. If the chain is already reminated with the same terminator, do not blow up." next == nil ifTrue: [next := aTerminator] ifFalse: [next terminateWith: aTerminator]! ! !RxmLookahaed class methodsFor: 'instance creation' stamp: 'CamilloBruni 8/28/2013 16:44'! with: aPiece ^self new lookahead: aPiece! ! !RxmLookahaed methodsFor: 'initialization' stamp: 'CamilloBruni 8/28/2013 16:52'! initialize super initialize. positive := true.! ! !RxmLookahaed methodsFor: 'accessing' stamp: 'CamilloBruni 8/28/2013 16:43'! lookahead ^ lookahead! ! !RxmLookahaed methodsFor: 'accessing' stamp: 'CamilloBruni 8/28/2013 16:43'! lookahead: anRxmLink lookahead := anRxmLink! ! !RxmLookahaed methodsFor: 'matching' stamp: 'CamilloBruni 8/28/2013 17:02'! matchAgainst: aMatcher "Match if the predicate block evaluates to true when given the current stream character as the argument." | original result | original := aMatcher currentState. result := lookahead matchAgainst: aMatcher. aMatcher restoreState: original. ^ result not and: [ next matchAgainst: aMatcher ]! ! !RxmLookahaed methodsFor: 'building' stamp: 'CamilloBruni 8/28/2013 17:09'! terminateWith: aNode lookahead terminateWith: aNode. super terminateWith: aNode.! ! !RxmMarker methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! index: anIndex "An index is a key that makes sense for the matcher. This key can be passed to marker position getters and setters to access position for this marker in the current matching session." index := anIndex! ! !RxmMarker methodsFor: 'matching' stamp: 'ul 5/14/2015 02:49'! matchAgainst: aMatcher "If the rest of the link chain matches successfully, report the position of the stream *before* the match started to the matcher." | startPosition | startPosition := aMatcher position. (next matchAgainst: aMatcher) ifFalse: [ ^false ]. aMatcher markerPositionAt: index add: startPosition. ^true! ! !RxmPredicate class methodsFor: 'instance creation' stamp: 'vb 4/11/09 21:56'! with: unaryBlock ^self new predicate: unaryBlock! ! !RxmPredicate methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! bePerform: aSelector "Match any single character that answers true to this message." self predicate: [:char | RxParser doHandlingMessageNotUnderstood: [char perform: aSelector]]! ! !RxmPredicate methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! bePerformNot: aSelector "Match any single character that answers false to this message." self predicate: [:char | RxParser doHandlingMessageNotUnderstood: [(char perform: aSelector) not]]! ! !RxmPredicate methodsFor: 'matching' stamp: 'ul 5/14/2015 02:53'! matchAgainst: aMatcher "Match if the predicate block evaluates to true when given the current stream character as the argument." | original | aMatcher atEnd ifTrue: [ ^false ]. original := aMatcher currentState. (predicate value: aMatcher next) ifFalse: [ aMatcher restoreState: original. ^false ]. (next matchAgainst: aMatcher) ifTrue: [ ^true ]. aMatcher restoreState: original. ^false ! ! !RxmPredicate methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! predicate: aBlock "This link will match any single character for which evaluates to true." aBlock numArgs ~= 1 ifTrue: [self error: 'bad predicate block']. predicate := aBlock. ^self! ! !RxmSpecial methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! beBeginningOfLine matchSelector := #atBeginningOfLine! ! !RxmSpecial methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! beBeginningOfWord matchSelector := #atBeginningOfWord! ! !RxmSpecial methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! beEndOfLine matchSelector := #atEndOfLine! ! !RxmSpecial methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! beEndOfWord matchSelector := #atEndOfWord! ! !RxmSpecial methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! beNotWordBoundary matchSelector := #notAtWordBoundary! ! !RxmSpecial methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! beWordBoundary matchSelector := #atWordBoundary! ! !RxmSpecial methodsFor: 'matching' stamp: 'vb 4/11/09 21:56'! matchAgainst: aMatcher "Match without consuming any input, if the matcher is in appropriate state." ^(aMatcher perform: matchSelector) and: [next matchAgainst: aMatcher]! ! !RxmSubstring methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! beCaseInsensitive compare := [:char1 :char2 | char1 sameAs: char2]! ! !RxmSubstring methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! beCaseSensitive compare := [:char1 :char2 | char1 = char2]! ! !RxmSubstring methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! character: aCharacter ignoreCase: aBoolean "Match exactly this character." sample := String with: aCharacter. aBoolean ifTrue: [self beCaseInsensitive]! ! !RxmSubstring methodsFor: 'initialization' stamp: 'lr 11/4/2009 22:38'! initialize super initialize. self beCaseSensitive! ! !RxmSubstring methodsFor: 'matching' stamp: 'ul 5/24/2015 21:50'! matchAgainst: aMatcher "Match if my sample stream is exactly the current prefix of the matcher stream's contents." | originalState sampleStream nextSample | originalState := aMatcher currentState. sampleStream := self sampleStream. [ (nextSample := sampleStream next) == nil or: [ aMatcher atEnd ] ] whileFalse: [ (compare value: nextSample value: aMatcher next) ifFalse: [ aMatcher restoreState: originalState. ^false ] ]. (nextSample == nil and: [ next matchAgainst: aMatcher ]) ifTrue: [ ^true ]. aMatcher restoreState: originalState. ^false! ! !RxmSubstring methodsFor: 'private' stamp: 'vb 4/11/09 21:56'! sampleStream ^sample readStream! ! !RxmSubstring methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! substring: aString ignoreCase: aBoolean "Match exactly this string." sample := aString. aBoolean ifTrue: [self beCaseInsensitive]! ! !RxmTerminator methodsFor: 'matching' stamp: 'vb 4/11/09 21:56'! matchAgainst: aStream "If got here, the match is successful." ^true! ! !RxmTerminator methodsFor: 'building' stamp: 'vb 4/11/09 21:56'! pointTailTo: anRxmLink "Branch tails are never redirected by the build algorithm. Healthy terminators should never receive this." RxParser signalCompilationException: 'internal matcher build error - redirecting terminator tail'! ! !RxmTerminator methodsFor: 'building' stamp: 'vb 4/11/09 21:56'! terminateWith: aTerminator "Branch terminators are never supposed to change. Make sure this is the case." aTerminator ~~ self ifTrue: [RxParser signalCompilationException: 'internal matcher build error - wrong terminator']! ! !RxsBranch methodsFor: 'accessing' stamp: 'vb 4/11/09 21:56'! branch ^branch! ! !RxsBranch methodsFor: 'accessing' stamp: 'vb 4/11/09 21:56'! dispatchTo: aMatcher "Inform the matcher of the kind of the node, and it will do whatever it has to." ^aMatcher syntaxBranch: self! ! !RxsBranch methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! initializePiece: aPiece branch: aBranch "See class comment for instance variables description." piece := aPiece. branch := aBranch! ! !RxsBranch methodsFor: 'testing' stamp: 'vb 4/11/09 21:56'! isNullable ^piece isNullable and: [branch isNil or: [branch isNullable]]! ! !RxsBranch methodsFor: 'accessing' stamp: 'vb 4/11/09 21:56'! piece ^piece! ! !RxsBranch methodsFor: 'optimization' stamp: 'vb 4/11/09 21:56'! tryMergingInto: aStream "Concatenation of a few simple characters can be optimized to be a plain substring match. Answer the node to resume syntax tree traversal at. Epsilon node used to terminate the branch will implement this to answer nil, thus indicating that the branch has ended." piece isAtomic ifFalse: [^self]. aStream nextPut: piece character. ^branch isNil ifTrue: [branch] ifFalse: [branch tryMergingInto: aStream]! ! !RxsCharSet methodsFor: 'accessing' stamp: 'vb 4/11/09 21:56'! dispatchTo: aMatcher "Inform the matcher of the kind of the node, and it will do whatever it has to." ^aMatcher syntaxCharSet: self! ! !RxsCharSet methodsFor: 'privileged' stamp: 'ul 5/16/2015 01:27'! enumerablePartPredicateIgnoringCase: aBoolean | enumeration | enumeration := self enumerableSetIgnoringCase: aBoolean. enumeration ifNil: [ ^nil ]. negated ifTrue: [ ^[ :char | (enumeration includes: char) not ] ]. ^[ :char | enumeration includes: char ]! ! !RxsCharSet methodsFor: 'privileged' stamp: 'ul 5/16/2015 02:25'! enumerableSetIgnoringCase: aBoolean "Answer a collection of characters that make up the portion of me that can be enumerated, or nil if there are no such characters." | size set | size := elements detectSum: [ :each | each enumerateSizeIgnoringCase: aBoolean ]. size = 0 ifTrue: [ ^nil ]. set := Set new: size. elements do: [ :each | each enumerateTo: set ignoringCase: aBoolean ]. ^set! ! !RxsCharSet methodsFor: 'accessing' stamp: 'ul 5/15/2015 22:36'! hasPredicates ^(elements allSatisfy: [ :some | some isEnumerable ]) not! ! !RxsCharSet methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! initializeElements: aCollection negated: aBoolean "See class comment for instance variables description." elements := aCollection. negated := aBoolean! ! !RxsCharSet methodsFor: 'testing' stamp: 'GabrielOmarCotelli 11/28/2013 19:03'! isEnumerable ^elements anySatisfy: [:some | some isEnumerable ]! ! !RxsCharSet methodsFor: 'testing' stamp: 'vb 4/11/09 21:56'! isNegated ^negated! ! !RxsCharSet methodsFor: 'accessing' stamp: 'ul 5/16/2015 01:38'! predicateIgnoringCase: aBoolean | enumerable predicate | enumerable := self enumerablePartPredicateIgnoringCase: aBoolean. predicate := self predicatePartPredicate ifNil: [ "There are no predicates in this set." ^enumerable ifNil: [ "This set is empty." [ :char | negated ] ] ]. enumerable ifNil: [ ^predicate ]. negated ifTrue: [ "enumerable and predicate already negate the result, that's why #not is not needed here." ^[ :char | (enumerable value: char) and: [ predicate value: char ] ] ]. ^[ :char | (enumerable value: char) or: [ predicate value: char ] ]! ! !RxsCharSet methodsFor: 'privileged' stamp: 'ul 5/16/2015 01:37'! predicatePartPredicate "Answer a predicate that tests all of my elements that cannot be enumerated, or nil if such elements don't exist." | predicates size | predicates := elements reject: [ :some | some isEnumerable ]. (size := predicates size) = 0 ifTrue: [ "We could return a real predicate block - like [ :char | negated ] - here, but it wouldn't be used anyway. This way we signal that this character set has no predicates." ^nil ]. size = 1 ifTrue: [ negated ifTrue: [ ^predicates first predicateNegation ]. ^predicates first predicate ]. predicates replace: [ :each | each predicate ]. negated ifTrue: [ ^[ [: char | predicates noneSatisfy: [ :some | some value: char ] ] ] ]. ^[ :char | predicates anySatisfy: [ :some | some value: char ] ] ! ! !RxsCharSet methodsFor: 'accessing' stamp: 'ul 5/16/2015 01:29'! predicates | predicates | predicates := elements reject: [ :some | some isEnumerable ]. predicates isEmpty ifTrue: [ ^nil ]. ^predicates replace: [ :each | each predicate ]! ! !RxsCharacter class methodsFor: 'instance creation' stamp: 'vb 4/11/09 21:56'! with: aCharacter ^self new initializeCharacter: aCharacter! ! !RxsCharacter methodsFor: 'accessing' stamp: 'vb 4/11/09 21:56'! character ^character! ! !RxsCharacter methodsFor: 'accessing' stamp: 'vb 4/11/09 21:56'! dispatchTo: aMatcher "Inform the matcher of the kind of the node, and it will do whatever it has to." ^aMatcher syntaxCharacter: self! ! !RxsCharacter methodsFor: 'accessing' stamp: 'ul 5/15/2015 23:45'! enumerateSizeIgnoringCase: aBoolean aBoolean ifFalse: [ ^1 ]. character isLetter ifTrue: [ ^2 ]. ^1! ! !RxsCharacter methodsFor: 'accessing' stamp: 'ul 5/15/2015 23:44'! enumerateTo: aSet ignoringCase: aBoolean aBoolean ifFalse: [ ^aSet add: character ]. aSet add: character asUppercase; add: character asLowercase! ! !RxsCharacter methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! initializeCharacter: aCharacter "See class comment for instance variable description." character := aCharacter! ! !RxsCharacter methodsFor: 'testing' stamp: 'vb 4/11/09 21:56'! isAtomic "A character is always atomic." ^true! ! !RxsCharacter methodsFor: 'testing' stamp: 'vb 4/11/09 21:56'! isEnumerable ^true! ! !RxsContextCondition methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! beAny "Matches anything but a newline." kind := #syntaxAny! ! !RxsContextCondition methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! beBeginningOfLine "Matches empty string at the beginning of a line." kind := #syntaxBeginningOfLine! ! !RxsContextCondition methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! beBeginningOfWord "Matches empty string at the beginning of a word." kind := #syntaxBeginningOfWord! ! !RxsContextCondition methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! beEndOfLine "Matches empty string at the end of a line." kind := #syntaxEndOfLine! ! !RxsContextCondition methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! beEndOfWord "Matches empty string at the end of a word." kind := #syntaxEndOfWord! ! !RxsContextCondition methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! beNonWordBoundary "Analog of \B." kind := #syntaxNonWordBoundary! ! !RxsContextCondition methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! beWordBoundary "Analog of \w (alphanumeric plus _)." kind := #syntaxWordBoundary! ! !RxsContextCondition methodsFor: 'accessing' stamp: 'vb 4/11/09 21:56'! dispatchTo: aBuilder ^aBuilder perform: kind! ! !RxsContextCondition methodsFor: 'testing' stamp: 'vb 4/11/09 21:56'! isNullable ^#syntaxAny ~~ kind! ! !RxsEpsilon methodsFor: 'building' stamp: 'vb 4/11/09 21:56'! dispatchTo: aBuilder "Inform the matcher of the kind of the node, and it will do whatever it has to." ^aBuilder syntaxEpsilon! ! !RxsEpsilon methodsFor: 'testing' stamp: 'vb 4/11/09 21:56'! isNullable "See comment in the superclass." ^true! ! !RxsLookaround class methodsFor: 'instance creation' stamp: 'CamilloBruni 8/28/2013 16:05'! with: anRsxPiece ^ self new initializePiece: anRsxPiece! ! !RxsLookaround methodsFor: 'initailize-release' stamp: 'CamilloBruni 8/28/2013 16:08'! beNegative positive := false! ! !RxsLookaround methodsFor: 'initailize-release' stamp: 'CamilloBruni 8/28/2013 16:08'! bePositive positive := true! ! !RxsLookaround methodsFor: 'accessing' stamp: 'CamilloBruni 8/28/2013 17:01'! dispatchTo: aBuilder "Inform the matcher of the kind of the node, and it will do whatever it has to." ^aBuilder syntaxLookaround: self! ! !RxsLookaround methodsFor: 'initailize-release' stamp: 'CamilloBruni 8/28/2013 17:01'! initializePiece: anRsxPiece super initialize. piece := anRsxPiece.! ! !RxsLookaround methodsFor: 'accessing' stamp: 'CamilloBruni 8/28/2013 16:04'! piece ^ piece! ! !RxsMessagePredicate methodsFor: 'accessing' stamp: 'vb 4/11/09 21:56'! dispatchTo: aBuilder "Inform the matcher of the kind of the node, and it will do whatever it has to." ^aBuilder syntaxMessagePredicate: self! ! !RxsMessagePredicate methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! initializeSelector: aSelector "The selector must be a one-argument message understood by Character." selector := aSelector! ! !RxsMessagePredicate methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! initializeSelector: aSelector negated: aBoolean "The selector must be a one-argument message understood by Character." selector := aSelector. negated := aBoolean! ! !RxsMessagePredicate methodsFor: 'accessing' stamp: 'vb 4/11/09 21:56'! negated ^negated! ! !RxsMessagePredicate methodsFor: 'accessing' stamp: 'vb 4/11/09 21:56'! selector ^selector! ! !RxsNode methodsFor: 'constants' stamp: 'vb 4/11/09 21:56'! indentCharacter "Normally, #printOn:withIndent: method in subclasses print several characters returned by this method to indicate the tree structure." ^$+! ! !RxsNode methodsFor: 'testing' stamp: 'vb 4/11/09 21:56'! isAtomic "Answer whether the node is atomic, i.e. matches exactly one constant predefined normal character. A matcher may decide to optimize matching of a sequence of atomic nodes by glueing them together in a string." ^false "tentatively"! ! !RxsNode methodsFor: 'testing' stamp: 'vb 4/11/09 21:56'! isNullable "True if the node can match an empty sequence of characters." ^false "for most nodes"! ! !RxsPiece methodsFor: 'accessing' stamp: 'vb 4/11/09 21:56'! atom ^atom! ! !RxsPiece methodsFor: 'accessing' stamp: 'vb 4/11/09 21:56'! character "If this node is atomic, answer the character it represents. It is the caller's responsibility to make sure this node is indeed atomic before using this." ^atom character! ! !RxsPiece methodsFor: 'accessing' stamp: 'vb 4/11/09 21:56'! dispatchTo: aMatcher "Inform the matcher of the kind of the node, and it will do whatever it has to." ^aMatcher syntaxPiece: self! ! !RxsPiece methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! initializeAtom: anAtom "This piece is exactly one occurrence of the specified RxsAtom." self initializeAtom: anAtom min: 1 max: 1! ! !RxsPiece methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! initializeAtom: anAtom min: minOccurrences max: maxOccurrences "This piece is from to occurrences of the specified RxsAtom." atom := anAtom. min := minOccurrences. max := maxOccurrences! ! !RxsPiece methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! initializeOptionalAtom: anAtom "This piece is 0 or 1 occurrences of the specified RxsAtom." self initializeAtom: anAtom min: 0 max: 1! ! !RxsPiece methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! initializePlusAtom: anAtom "This piece is one or more occurrences of the specified RxsAtom." self initializeAtom: anAtom min: 1 max: nil! ! !RxsPiece methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! initializeStarAtom: anAtom "This piece is any number of occurrences of the atom." self initializeAtom: anAtom min: 0 max: nil! ! !RxsPiece methodsFor: 'testing' stamp: 'vb 4/11/09 21:56'! isAtomic "A piece is atomic if only it contains exactly one atom which is atomic (sic)." ^self isSingular and: [atom isAtomic]! ! !RxsPiece methodsFor: 'testing' stamp: 'vb 4/11/09 21:56'! isNullable "A piece is nullable if it allows 0 matches. This is often handy to know for optimization." ^min = 0 or: [atom isNullable]! ! !RxsPiece methodsFor: 'testing' stamp: 'vb 4/11/09 21:56'! isOptional ^min = 0 and: [max = 1]! ! !RxsPiece methodsFor: 'testing' stamp: 'vb 4/11/09 21:56'! isPlus ^min = 1 and: [max == nil]! ! !RxsPiece methodsFor: 'testing' stamp: 'vb 4/11/09 21:56'! isSingular "A piece with a range is 1 to 1 needs can be compiled as a simple match." ^min = 1 and: [max = 1]! ! !RxsPiece methodsFor: 'testing' stamp: 'vb 4/11/09 21:56'! isStar ^min = 0 and: [max == nil]! ! !RxsPiece methodsFor: 'accessing' stamp: 'vb 4/11/09 21:56'! max "The value answered may be nil, indicating infinity." ^max! ! !RxsPiece methodsFor: 'accessing' stamp: 'vb 4/11/09 21:56'! min ^min! ! !RxsPredicate class methodsFor: 'instance creation' stamp: 'vb 4/11/09 21:56'! forEscapedLetter: aCharacter ^self new perform: (EscapedLetterSelectors at: aCharacter ifAbsent: [RxParser signalSyntaxException: 'bad backslash escape'])! ! !RxsPredicate class methodsFor: 'instance creation' stamp: 'vb 4/11/09 21:56'! forNamedClass: aString ^self new perform: (NamedClassSelectors at: aString ifAbsent: [RxParser signalSyntaxException: 'bad character class name'])! ! !RxsPredicate class methodsFor: 'class initialization' stamp: 'vb 4/11/09 21:56'! initialize "self initialize" self initializeNamedClassSelectors; initializeEscapedLetterSelectors! ! !RxsPredicate class methodsFor: 'class initialization' stamp: 'ul 5/24/2015 21:25'! initializeEscapedLetterSelectors "self initializeEscapedLetterSelectors" | newEscapedLetterSelectors | newEscapedLetterSelectors := Dictionary new at: $w put: #beWordConstituent; at: $W put: #beNotWordConstituent; at: $d put: #beDigit; at: $D put: #beNotDigit; at: $s put: #beSpace; at: $S put: #beNotSpace; at: $\ put: #beBackslash; at: $r put: #beCarriageReturn; yourself. EscapedLetterSelectors := newEscapedLetterSelectors! ! !RxsPredicate class methodsFor: 'class initialization' stamp: 'vb 4/11/09 21:56'! initializeNamedClassSelectors "self initializeNamedClassSelectors" (NamedClassSelectors := Dictionary new) at: 'alnum' put: #beAlphaNumeric; at: 'alpha' put: #beAlphabetic; at: 'cntrl' put: #beControl; at: 'digit' put: #beDigit; at: 'graph' put: #beGraphics; at: 'lower' put: #beLowercase; at: 'print' put: #bePrintable; at: 'punct' put: #bePunctuation; at: 'space' put: #beSpace; at: 'upper' put: #beUppercase; at: 'xdigit' put: #beHexDigit! ! !RxsPredicate methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! beAlphaNumeric predicate := [:char | char isAlphaNumeric]. negation := [:char | char isAlphaNumeric not]! ! !RxsPredicate methodsFor: 'initialize-release' stamp: 'lr 11/4/2009 22:29'! beAlphabetic predicate := [:char | char isLetter]. negation := [:char | char isLetter not]! ! !RxsPredicate methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! beBackslash predicate := [:char | char == $\]. negation := [:char | char ~~ $\]! ! !RxsPredicate methodsFor: 'initialize-release' stamp: 'ul 5/24/2015 21:25'! beCarriageReturn | cr | cr := Character cr. predicate := [ :char | char == cr ]. negation := [ :char | char ~~ cr ]! ! !RxsPredicate methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! beControl predicate := [:char | char asInteger < 32]. negation := [:char | char asInteger >= 32]! ! !RxsPredicate methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! beDigit predicate := [:char | char isDigit]. negation := [:char | char isDigit not]! ! !RxsPredicate methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! beGraphics self beControl; negate! ! !RxsPredicate methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! beHexDigit | hexLetters | hexLetters := 'abcdefABCDEF'. predicate := [:char | char isDigit or: [hexLetters includes: char]]. negation := [:char | char isDigit not and: [(hexLetters includes: char) not]]! ! !RxsPredicate methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! beLowercase predicate := [:char | char isLowercase]. negation := [:char | char isLowercase not]! ! !RxsPredicate methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! beNotDigit self beDigit; negate! ! !RxsPredicate methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! beNotSpace self beSpace; negate! ! !RxsPredicate methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! beNotWordConstituent self beWordConstituent; negate! ! !RxsPredicate methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! bePrintable self beControl; negate! ! !RxsPredicate methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! bePunctuation | punctuationChars | punctuationChars := #($. $, $!! $? $; $: $" $' $- $( $) $`). predicate := [:char | punctuationChars includes: char]. negation := [:char | (punctuationChars includes: char) not]! ! !RxsPredicate methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! beSpace predicate := [:char | char isSeparator]. negation := [:char | char isSeparator not]! ! !RxsPredicate methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! beUppercase predicate := [:char | char isUppercase]. negation := [:char | char isUppercase not]! ! !RxsPredicate methodsFor: 'initialize-release' stamp: 'lr 1/7/2010 20:06'! beWordConstituent predicate := [:char | char isAlphaNumeric or: [char == $_]]. negation := [:char | char isAlphaNumeric not and: [char ~~ $_]]! ! !RxsPredicate methodsFor: 'accessing' stamp: 'vb 4/11/09 21:56'! dispatchTo: anObject ^anObject syntaxPredicate: self! ! !RxsPredicate methodsFor: 'accessing' stamp: 'ul 5/15/2015 23:52'! enumerateSizeIgnoringCase: aBoolean ^0 "Not enumerable"! ! !RxsPredicate methodsFor: 'accessing' stamp: 'ul 5/15/2015 23:52'! enumerateTo: aSet ignoringCase: aBoolean ^self "Not enumerable"! ! !RxsPredicate methodsFor: 'testing' stamp: 'vb 4/11/09 21:56'! isEnumerable ^false! ! !RxsPredicate methodsFor: 'private' stamp: 'vb 4/11/09 21:56'! negate | tmp | tmp := predicate. predicate := negation. negation := tmp! ! !RxsPredicate methodsFor: 'accessing' stamp: 'vb 4/11/09 21:56'! negated ^self copy negate! ! !RxsPredicate methodsFor: 'accessing' stamp: 'vb 4/11/09 21:56'! predicate ^predicate! ! !RxsPredicate methodsFor: 'accessing' stamp: 'vb 4/11/09 21:56'! predicateNegation ^negation! ! !RxsPredicate methodsFor: 'accessing' stamp: 'vb 4/11/09 21:56'! value: aCharacter ^predicate value: aCharacter! ! !RxsRange class methodsFor: 'instance creation' stamp: 'vb 4/11/09 21:56'! from: aCharacter to: anotherCharacter ^self new initializeFirst: aCharacter last: anotherCharacter! ! !RxsRange methodsFor: 'accessing' stamp: 'ul 5/15/2015 23:48'! enumerateSizeIgnoringCase: aBoolean "Add all of the elements I represent to the collection." | characterCount | characterCount := last asInteger - first asInteger + 1 max: 0. aBoolean ifFalse: [ ^characterCount ]. (last isLetter or: [ first isLetter ]) ifTrue: [ ^characterCount * 2 "Assume many letters" ]. ^characterCount "Assume no letters"! ! !RxsRange methodsFor: 'accessing' stamp: 'ul 5/15/2015 23:36'! enumerateTo: aSet ignoringCase: aBoolean "Add all of the elements I represent to the collection." aBoolean ifFalse: [ first asInteger to: last asInteger do: [ :charCode | aSet add: charCode asCharacter ]. ^self ]. first asInteger to: last asInteger do: [ :charCode | | character | character := charCode asCharacter. aSet add: character asLowercase; add: character asUppercase ]! ! !RxsRange methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! initializeFirst: aCharacter last: anotherCharacter first := aCharacter. last := anotherCharacter! ! !RxsRange methodsFor: 'testing' stamp: 'vb 4/11/09 21:56'! isEnumerable ^true! ! !RxsRegex methodsFor: 'accessing' stamp: 'vb 4/11/09 21:56'! branch ^branch! ! !RxsRegex methodsFor: 'accessing' stamp: 'vb 4/11/09 21:56'! dispatchTo: aMatcher "Inform the matcher of the kind of the node, and it will do whatever it has to." ^aMatcher syntaxRegex: self! ! !RxsRegex methodsFor: 'initialize-release' stamp: 'vb 4/11/09 21:56'! initializeBranch: aBranch regex: aRegex "See class comment for instance variable description." branch := aBranch. regex := aRegex! ! !RxsRegex methodsFor: 'testing' stamp: 'vb 4/11/09 21:56'! isNullable ^branch isNullable or: [regex notNil and: [regex isNullable]]! ! !RxsRegex methodsFor: 'accessing' stamp: 'vb 4/11/09 21:56'! regex ^regex! ! !String methodsFor: '*Regex-Core' stamp: 'vb 4/11/09 21:56'! allRangesOfRegexMatches: rxString ^rxString asRegex matchingRangesIn: self! ! !String methodsFor: '*Regex-Core' stamp: 'vb 4/11/09 21:56'! allRegexMatches: rxString ^rxString asRegex matchesIn: self! ! !String methodsFor: '*Regex-Core' stamp: 'vb 4/11/09 21:56'! asRegex "Compile the receiver as a regex matcher. May raise RxParser>>syntaxErrorSignal or RxParser>>compilationErrorSignal. This is a part of the Regular Expression Matcher package, (c) 1996, 1999 Vassili Bykov. Refer to `documentation' protocol of RxParser class for details." ^RxParser preferredMatcherClass for: (RxParser new parse: self)! ! !String methodsFor: '*Regex-Core' stamp: 'vb 4/11/09 21:56'! asRegexIgnoringCase "Compile the receiver as a regex matcher. May raise RxParser>>syntaxErrorSignal or RxParser>>compilationErrorSignal. This is a part of the Regular Expression Matcher package, (c) 1996, 1999 Vassili Bykov. Refer to `documentation' protocol of RxParser class for details." ^RxParser preferredMatcherClass for: (RxParser new parse: self) ignoreCase: true! ! !String methodsFor: '*Regex-Core' stamp: 'vb 4/11/09 21:56'! copyWithRegex: rxString matchesReplacedWith: aString ^rxString asRegex copy: self replacingMatchesWith: aString! ! !String methodsFor: '*Regex-Core' stamp: 'vb 4/11/09 21:56'! copyWithRegex: rxString matchesTranslatedUsing: aBlock ^rxString asRegex copy: self translatingMatchesUsing: aBlock! ! !String methodsFor: '*Regex-Core' stamp: 'vb 4/11/09 21:56'! matchesRegex: regexString "Test if the receiver matches a regex. May raise RxParser>>regexErrorSignal or child signals. This is a part of the Regular Expression Matcher package, (c) 1996, 1999 Vassili Bykov. Refer to `documentation' protocol of RxParser class for details." ^regexString asRegex matches: self! ! !String methodsFor: '*Regex-Core' stamp: 'vb 4/11/09 21:56'! matchesRegexIgnoringCase: regexString "Test if the receiver matches a regex. May raise RxParser>>regexErrorSignal or child signals. This is a part of the Regular Expression Matcher package, (c) 1996, 1999 Vassili Bykov. Refer to `documentation' protocol of RxParser class for details." ^regexString asRegexIgnoringCase matches: self! ! !String methodsFor: '*Regex-Core' stamp: 'ul 5/24/2015 21:31'! occurrencesOfRegex: rxString | count | count := 0. self regex: rxString matchesDo: [ :each | count := count + 1 ]. ^count! ! !String methodsFor: '*Regex-Core' stamp: 'vb 4/11/09 21:56'! prefixMatchesRegex: regexString "Test if the receiver's prefix matches a regex. May raise RxParser class>>regexErrorSignal or child signals. This is a part of the Regular Expression Matcher package, (c) 1996, 1999 Vassili Bykov. Refer to `documentation' protocol of RxParser class for details." ^regexString asRegex matchesPrefix: self! ! !String methodsFor: '*Regex-Core' stamp: 'vb 4/11/09 21:56'! prefixMatchesRegexIgnoringCase: regexString "Test if the receiver's prefix matches a regex. May raise RxParser class>>regexErrorSignal or child signals. This is a part of the Regular Expression Matcher package, (c) 1996, 1999 Vassili Bykov. Refer to `documentation' protocol of RxParser class for details." ^regexString asRegexIgnoringCase matchesPrefix: self! ! !String methodsFor: '*Regex-Core' stamp: 'vb 4/11/09 21:56'! regex: rxString matchesCollect: aBlock ^rxString asRegex matchesIn: self collect: aBlock! ! !String methodsFor: '*Regex-Core' stamp: 'vb 4/11/09 21:56'! regex: rxString matchesDo: aBlock ^rxString asRegex matchesIn: self do: aBlock! ! !String methodsFor: '*Regex-Core' stamp: 'EstebanLorenzano 8/17/2012 16:40'! search: aString "compatibility method to make regexp and strings work polymorphicly" ^ aString includesSubstring: self! ! !UIManager methodsFor: '*Regex-Core' stamp: 'CamilloBruni 11/21/2012 00:52'! request: aTitleString regex: initialRegexString "Prompt the user for a valid regex. Return nil on cancel or a valid RxMatcher" | regex | regex := initialRegexString. "loop until we get a valid regex string back" [ regex := UIManager default multiLineRequest: aTitleString initialAnswer: regex answerHeight: 200. "cancelled dialog ==> nil" regex ifNil: [ ^ nil ]. [ ^ regex asRegex ] on: Error do: [ :regexParsingError| self defer: [ self inform: 'Bad Regex: ', regexParsingError asString ]]. ] repeat.! ! !RegexSyntaxError class methodsFor: 'signaling' stamp: 'CamilloBruni 10/7/2012 22:51'! signal: anErrorMessage at: errorPosition ^ (self new) position: errorPosition; signal: anErrorMessage! ! !RegexSyntaxError methodsFor: 'accessing' stamp: 'CamilloBruni 10/7/2012 22:47'! position "return the parsing error location" ^ position! ! !RegexSyntaxError methodsFor: 'accessing' stamp: 'CamilloBruni 10/7/2012 22:51'! position: anInteger position := anInteger.! ! "Regex-Core"! !MultiByteBinaryOrTextStream methodsFor: 'private' stamp: 'ul 8/14/2015 18:03' prior: 23780868! guessConverter ^ (self originalContents includesSubstring: #[27 36] asString) ifTrue: [CompoundTextConverter new] ifFalse: [self class defaultConverter ]! ! "Multilingual"! TestCase subclass: #BitSetTest instanceVariableNames: 'bitset' classVariableNames: '' poolDictionaries: '' category: 'CollectionsTests-Support'! !CharacterSetComplementTest methodsFor: 'testing' stamp: 'ul 8/14/2015 18:01' prior: 21439789! testPrintString |s| s := CharacterSet separators complement printString. self assert: (s includesSubstring: 'complement') description: 'Doesn''t describe its fundamental characteristic'. self assert: (s includesSubstring: 'Character space') description: 'Doesn''t mention an important separator'.! ! !BitSetTest methodsFor: 'helpers' stamp: 'ul 8/22/2015 01:32'! assertBitsetIsEmpty self assert: 0 equals: bitset size. self assert: (bitset bytes allSatisfy: [ :each | each = 0 ]). self assert: #() equals: self bitsetElements ! ! !BitSetTest methodsFor: 'helpers' stamp: 'ul 8/22/2015 01:16'! bitsetElements ^Array new: bitset size streamContents: [ :stream | bitset do: [ :each | stream nextPut: each ] ]! ! !BitSetTest methodsFor: 'helpers' stamp: 'ul 8/22/2015 01:33'! initializeBitset: anInteger self assert: anInteger equals: anInteger // 8 * 8. bitset := Bitset new: anInteger. self assertBitsetIsEmpty. self assert: anInteger equals: bitset capacity! ! !BitSetTest methodsFor: 'testing' stamp: 'ul 8/22/2015 01:39'! testBitManipulationAPI #(0 8 16 24 32) do: [ :each | self testBitManipulationAPI: each ]! ! !BitSetTest methodsFor: 'testing' stamp: 'ul 8/22/2015 01:56'! testBitManipulationAPI: capacity self initializeBitset: capacity. 0 to: capacity - 1 do: [ :index | self assert: 0 equals: (bitset bitAt: index). self assert: #() equals: self bitsetElements. self assert: false equals: (bitset clearBitAt: index). self assert: 0 equals: bitset size. self assert: #() equals: self bitsetElements. self assert: false equals: (bitset clearBitAt: index). self assert: true equals: (bitset setBitAt: index). self assert: 1 equals: (bitset bitAt: index). self assert: 1 equals: bitset size. self assert: { index } equals: self bitsetElements. self assert: false equals: (bitset setBitAt: index). self assert: 1 equals: (bitset bitAt: index). self assert: 1 equals: bitset size. self assert: { index } equals: self bitsetElements. self assert: true equals: (bitset clearBitAt: index). self assert: 0 equals: bitset size. self assert: #() equals: self bitsetElements. self assert: 0 equals: (bitset bitAt: index). self assert: false equals: (bitset clearBitAt: index). self assert: 0 equals: bitset size. self assert: #() equals: self bitsetElements. self assert: 0 equals: (bitset bitAt: index). self assert: capacity equals: bitset capacity ]. self should: [ bitset bitAt: -1 ] raise: Error; should: [ bitset bitAt: capacity ] raise: Error. self should: [ bitset setBitAt: -1 ] raise: Error; should: [ bitset setBitAt: capacity ] raise: Error. self should: [ bitset clearBitAt: -1 ] raise: Error; should: [ bitset clearBitAt: capacity ] raise: Error! ! !BitSetTest methodsFor: 'testing' stamp: 'ul 8/22/2015 01:33'! testCopy #(0 8 16 24 32) do: [ :each | self testCopy: each ]! ! !BitSetTest methodsFor: 'testing' stamp: 'ul 8/22/2015 01:35'! testCopy: n | copy | self initializeBitset: n. copy := bitset copy. self assert: copy equals: bitset. self assert: copy hash equals: bitset hash. self deny: bitset == copy. self deny: bitset bytes == copy bytes! ! !BitSetTest methodsFor: 'testing' stamp: 'ul 8/22/2015 01:40'! testDictionaryAPI #(0 8 16 24 32) do: [ :each | self testDictionaryAPI: each ]! ! !BitSetTest methodsFor: 'testing' stamp: 'ul 8/22/2015 01:57'! testDictionaryAPI: capacity self initializeBitset: capacity. 0 to: capacity - 1 do: [ :index | self assert: 0 equals: (bitset at: index). self assert: #() equals: self bitsetElements. self assert: 0 equals: (bitset at: index put: 0). self assert: 0 equals: bitset size. self assert: #() equals: self bitsetElements. self assert: 0 equals: (bitset at: index put: 0). self assert: 1 equals: (bitset at: index put: 1). self assert: 1 equals: (bitset at: index). self assert: 1 equals: bitset size. self assert: { index } equals: self bitsetElements. self assert: 1 equals: (bitset at: index put: 1). self assert: 1 equals: (bitset at: index). self assert: 1 equals: bitset size. self assert: { index } equals: self bitsetElements. self assert: 0 equals: (bitset at: index put: 0). self assert: 0 equals: bitset size. self assert: #() equals: self bitsetElements. self assert: 0 equals: (bitset at: index). self assert: 0 equals: (bitset at: index put: 0). self assert: 0 equals: bitset size. self assert: #() equals: self bitsetElements. self assert: 0 equals: (bitset at: index). self assert: capacity equals: bitset capacity ]. self should: [ bitset at: capacity ] raise: Error; should: [ bitset at: capacity put: 0 ] raise: Error; should: [ bitset at: capacity put: 1 ] raise: Error. self should: [ bitset at: -1 ] raise: Error; should: [ bitset at: -1 put: 0 ] raise: Error; should: [ bitset at: -1 put: 1 ] raise: Error. self should: [ bitset at: 0 put: -1 ] raise: Error; should: [ bitset at: 0 put: 2 ] raise: Error; should: [ bitset at: 0 put: nil ] raise: Error! ! !BitSetTest methodsFor: 'testing' stamp: 'ul 8/22/2015 01:47'! testNew self should: [ Bitset new ] raise: Error! ! !BitSetTest methodsFor: 'testing' stamp: 'ul 8/22/2015 01:34'! testRemoveAll #(0 8 16 24 32) do: [ :each | self testRemoveAll: each ]! ! !BitSetTest methodsFor: 'testing' stamp: 'ul 8/22/2015 01:32'! testRemoveAll: n self initializeBitset: n. 0 to: n - 1 do: [ :index | bitset setBitAt: index ]. self assert: n equals: bitset size. self assert: (bitset bytes allSatisfy: [ :each | each = 255 ]). bitset removeAll. self assert: 0 equals: bitset size. self assert: #() equals: self bitsetElements. self assert: (bitset bytes allSatisfy: [ :each | each = 0 ]). ! ! !BitSetTest methodsFor: 'testing' stamp: 'ul 8/22/2015 01:23'! testSetAPI #(0 8 16 24 32) do: [ :each | self testSetAPI: each ]! ! !BitSetTest methodsFor: 'testing' stamp: 'ul 8/22/2015 01:53'! testSetAPI: capacity self initializeBitset: capacity. self assert: capacity equals: capacity // 8 * 8 description: 'capacity must be a multiple of eight.'. self assert: capacity equals: bitset capacity. self assert: 0 equals: bitset size. self assert: #() equals: self bitsetElements. 0 to: capacity - 1 do: [ :index | self deny: (bitset includes: index). self assert: #() equals: self bitsetElements. self assert: nil equals: (bitset remove: index ifAbsent: [ nil ]). self assert: 0 equals: bitset size. self assert: #() equals: self bitsetElements. self deny: (bitset includes: index). self assert: index equals: (bitset add: index). self assert: (bitset includes: index). self assert: 1 equals: bitset size. self assert: { index } equals: self bitsetElements. self assert: index equals: (bitset add: index). self assert: (bitset includes: index). self assert: 1 equals: bitset size. self assert: { index } equals: self bitsetElements. self assert: index equals: (bitset remove: index). self assert: 0 equals: bitset size. self assert: #() equals: self bitsetElements. self deny: (bitset includes: index). self assert: nil equals: (bitset remove: index ifAbsent: [ nil ]). self assert: 0 equals: bitset size. self assert: #() equals: self bitsetElements. self deny: (bitset includes: index). self assert: capacity equals: bitset capacity ]. self deny: (bitset includes: -1); deny: (bitset includes: capacity). self should: [ bitset add: capacity ] raise: Error; should: [ bitset add: -1 ] raise: Error; should: [ bitset remove: capacity ] raise: Error; should: [ bitset remove: -1 ] raise: Error! ! !BitSetTest methodsFor: 'testing' stamp: 'ul 8/22/2015 01:45'! testSize #(0 8 16 24 32) do: [ :each | self testSize: each ]! ! !BitSetTest methodsFor: 'testing' stamp: 'ul 8/22/2015 01:45'! testSize: n self initializeBitset: n. 0 to: n - 1 do: [ :index | self assert: index equals: bitset size. bitset setBitAt: index ]. self assert: n equals: bitset size. 0 to: n - 1 do: [ :index | self assert: n - index equals: bitset size. bitset clearBitAt: index ]. self assertBitsetIsEmpty! ! "CollectionsTests"! !SelectorNode methodsFor: 'testing' stamp: 'ul 8/14/2015 18:04' prior: 26969712! isForFFICall ^key includesSubstring: '()/'! ! !MethodNode methodsFor: 'printing' stamp: 'ul 8/14/2015 18:03' prior: 19218748! printWithClosureAnalysisOn: aStream self ensureClosureAnalysisDone. precedence = 1 ifTrue: [(self selector includesSubstring: '()/') ifTrue: [aStream nextPutAll: (self selector copyUpTo: $)). arguments do: [:arg| aStream nextPutAll: arg key] separatedBy: [aStream nextPutAll: ', ']. aStream nextPut: $)] ifFalse: [aStream nextPutAll: self selector]] "no node for method selector" ifFalse: [self selector keywords with: arguments do: [:kwd :arg | aStream nextPutAll: kwd; space. arg printDefinitionForClosureAnalysisOn: aStream. aStream space]]. comment == nil ifFalse: [aStream crtab: 1. self printCommentOn: aStream indent: 1]. temporaries size > 0 ifTrue: [aStream crtab: 1; nextPut: $|. temporaries do: [:temp | aStream space. temp printDefinitionForClosureAnalysisOn: aStream]. aStream space; nextPut: $|]. primitive > 0 ifTrue: [(primitive between: 255 and: 519) ifFalse: "Dont decompile quick prims e.g, ^ self or ^instVar" [aStream crtab: 1. self printPrimitiveOn: aStream]]. self printPropertiesOn: aStream. self printPragmasOn: aStream. aStream crtab: 1. block printWithClosureAnalysisStatementsOn: aStream indent: 0! ! "Compiler"! !Integer class methodsFor: 'class initialization' stamp: 'ul 8/19/2015 23:29'! lowBitPerByteTable ^LowBitPerByteTable! ! !MethodDictionary methodsFor: 'private' stamp: 'ul 8/16/2015 21:40' prior: 17756614! grow | newSelf | newSelf := self species newForCapacity: self basicSize * 2. 1 to: self basicSize do: [ :i | (self basicAt: i) ifNotNil: [ :key | newSelf at: key put: (array at: i) ] ]. self becomeForward: newSelf! ! !InputSensor class methodsFor: 'class initialization' stamp: 'ul 8/14/2015 18:18' prior: 24376179! installKeyDecodeTable "Create a decode table that swaps some keys if Preferences swapControlAndAltKeys is set" KeyDecodeTable := Dictionary new. Preferences duplicateControlAndAltKeys ifTrue: [ self defaultCrossPlatformKeys do: [ :c | self installDuplicateKeyEntryFor: c ] ]. Preferences swapControlAndAltKeys ifTrue: [ self defaultCrossPlatformKeys do: [ :c | self installSwappedKeyEntryFor: c ] ]. Preferences duplicateAllControlAndAltKeys ifTrue: [ (Character allByteCharacters select: [:ea | ea isAlphaNumeric]) do: [ :c | self installDuplicateKeyEntryFor: c ] ]. ! ! !CompiledMethod methodsFor: 'source code management' stamp: 'ul 8/16/2015 21:40' prior: 31453183! putSource: sourceStr fromParseNode: methodNode inFile: fileIndex withPreamble: preambleBlock "Store the source code for the receiver on an external file. If no sources are available, i.e., SourceFile is nil, then store temp names for decompilation at the end of the method. If the fileIndex is 1, print on *.sources; if it is 2, print on *.changes, in each case, storing a 4-byte source code pointer at the method end." | file remoteString | (SourceFiles == nil or: [(file := SourceFiles at: fileIndex) == nil]) ifTrue: [^self becomeForward: (self copyWithTempsFromMethodNode: methodNode)]. Smalltalk assureStartupStampLogged. file setToEnd. preambleBlock value: file. "Write the preamble" remoteString := RemoteString newString: sourceStr onFileNumber: fileIndex toFile: file. file nextChunkPut: ' '. InMidstOfFileinNotification signal ifFalse: [file flush]. self checkOKToAdd: sourceStr size at: remoteString position. self setSourcePosition: remoteString position inFile: fileIndex! ! !BlockClosure methodsFor: 'evaluating' stamp: 'ul 8/14/2015 22:09' prior: 84645875! valueSupplyingAnswers: aListOfPairs "evaluate the block using a list of questions / answers that might be called upon to automatically respond to Object>>confirm: or FillInTheBlank requests" ^self on: ProvideAnswerNotification do: [ :notification | | caption | caption := notification messageText withSeparatorsCompacted. "to remove new lines" aListOfPairs detect: [ :each | caption = each first or: [ (caption includesSubstring: each first caseSensitive: false) or: [ (each first match: caption) or: [ (caption respondsTo: #matchesRegex:) and: [ caption matchesRegex: each first ] ] ] ] ] ifFound: [ :answer | notification resume: answer second ] ifNone: [ (ProvideAnswerNotification signal: notification messageText) ifNil: [ notification resume ] ifNotNil: [ :outerAnswer | notification resume: outerAnswer ] ] ]! ! "Kernel"! !ChangeRecord methodsFor: 'access' stamp: 'ul 8/14/2015 18:05' prior: 29829569! methodClass: anEnvironment | methodClassName methodClass | (#(method #classComment) includes: type) ifFalse: [ ^ nil ]. methodClassName := class substrings ifEmpty: [ ^ nil ] ifNotEmptyDo: [ : parts | parts first asSymbol ]. (anEnvironment includesKey: methodClassName) ifFalse: [ ^ nil ]. methodClass := anEnvironment at: methodClassName. ^ meta ifTrue: [ methodClass class ] ifFalse: [ methodClass ]! ! !ImageSegment methodsFor: 'testing' stamp: 'ul 8/14/2015 18:02' prior: 25927414! findOwnerMap: morphs | st | "Construct a string that has a printout of the owner chain for every morph in the list. Need it as a string so not hold onto them." st := ''. morphs do: [:mm | (st includesSubstring: mm printString) ifFalse: [ st := st, ' ', mm allOwners printString]]. Smalltalk at: #Owners put: st. ! ! !FileDirectory class methodsFor: '*System-Files' stamp: 'ul 8/14/2015 18:02' prior: 33016356! openSources: sourcesName andChanges: changesName forImage: imageName "Open the changes and sources files and install them in SourceFiles. Inform the user of problems regarding write permissions or CR/CRLF mixups." "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.'. 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: [Smalltalk platformName = 'Mac OS' ifTrue: [msg := msg , ' Make sure the sources file is not an Alias.']. self inform: (msg copyReplaceAll: '&fileRef' with: 'the sources file named ' , sourcesName)]. (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! ! !SystemVersion methodsFor: 'testing' stamp: 'ul 8/14/2015 18:05' prior: 18864547! isPharo ^ version includesSubstring: 'Pharo'! ! !SystemVersion methodsFor: 'testing' stamp: 'ul 8/14/2015 18:05' prior: 18864799! isSqueak ^ version includesSubstring: 'Squeak'! ! !ChangeSet class methodsFor: 'scanning' stamp: 'ul 8/14/2015 18:01' prior: 30953104! scanCategory: file "Scan anything that involves more than one chunk; method name is historical only" | itemPosition item tokens stamp isComment anIndex | itemPosition := file position. item := file nextChunk. isComment := (item includesSubstring: 'commentStamp:'). (isComment or: [item includesSubstring: 'methodsFor:']) ifFalse: ["Maybe a preamble, but not one we recognize; bail out with the preamble trick" ^{(ChangeRecord new file: file position: itemPosition type: #preamble)}]. tokens := Scanner new scanTokens: item. tokens size >= 3 ifTrue: [stamp := ''. anIndex := tokens indexOf: #stamp: ifAbsent: [nil]. anIndex ifNotNil: [stamp := tokens at: (anIndex + 1)]. tokens second == #methodsFor: ifTrue: [^ self scanFile: file category: tokens third class: tokens first meta: false stamp: stamp]. tokens third == #methodsFor: ifTrue: [^ self scanFile: file category: tokens fourth class: tokens first meta: true stamp: stamp]]. tokens second == #commentStamp: ifTrue: [stamp := tokens third. item := (ChangeRecord new file: file position: file position type: #classComment class: tokens first category: nil meta: false stamp: stamp). file nextChunk. file skipStyleChunk. ^Array with: item]. ^#()! ! !ResourceLocator class methodsFor: 'utilities' stamp: 'ul 8/14/2015 18:03' prior: 59995382! make: newURLString relativeTo: oldURLString "Local file refs are not handled well, so work around here" ^((oldURLString includesSubstring: '://') not and: [(newURLString includesSubstring: '://') not]) ifTrue: [oldURLString , (UnixFileDirectory localNameFor: newURLString)] ifFalse: [(newURLString asUrlRelativeTo: oldURLString asUrl) asString]! ! "System"! Collection subclass: #Bitset instanceVariableNames: 'bytes tally' classVariableNames: '' poolDictionaries: '' category: 'Collections-Support'! !Bitset commentStamp: 'ul 8/22/2015 00:52' prior: 0! I implement Bitsets, which are dictionary-like data structures mapping 0-1 values to integers between 0 and capacity-1, or in another way they are set-like data structures which can include values between 0 and capacity-1. I implement three different kind of APIs, each corresponding to a way of thinking about this data structure: - A Set-like API with #add:, #remove: and #includes: - A Dictionary-like API with #at:, #at:put: - And a bit-manipulation API with #bitAt:, #clearBitAt: and #setBitAt:. Instance Variables bytes: tally: bytes - a ByteArray which holds the values for each integer key. Each byte holds 8 values. tally - the number of objects in this set, or the number or 1 values in this dictionary. ! Collection subclass: #WideCharacterSet instanceVariableNames: 'map byteArrayMap bitsetCapacity highBitsShift lowBitsMask' classVariableNames: '' poolDictionaries: '' category: 'Collections-Support'! !WideCharacterSet commentStamp: 'nice 12/10/2009 19:17' prior: 19027662! WideCharacterSet is used to store a Set of WideCharacter with fast access and inclusion test. Implementation should be efficient in memory if sets are sufficently sparse. Wide Characters are at most 32bits. We split them into 16 highBits and 16 lowBits. map is a dictionary key: 16 highBits value: map of 16 lowBits. Maps of lowBits are stored as arrays of bits in a ByteArray. If a bit is set to 1, this indicate that corresponding character is present. 8192 bytes are necessary in each lowmap. Empty lowmap are removed from the map Dictionary. A byteArrayMap is maintained in parallel with map for fast handling of ByteString. (byteArrayMap at: i+1) = 0 means that character of asciiValue i is absent, = 1 means present.! !String methodsFor: 'accessing' stamp: 'ul 8/20/2015 21:06' prior: 22170625! indexOf: aCharacter ^self indexOf: aCharacter startingAt: 1 ! ! !String methodsFor: 'accessing' stamp: 'ul 8/20/2015 21:05' prior: 22171067! indexOf: aCharacter startingAt: start ifAbsent: aBlock | index | (index := self indexOf: aCharacter startingAt: start) = 0 ifTrue: [ ^aBlock value ]. ^index! ! !Bitset class methodsFor: 'instance creation' stamp: 'ul 8/19/2015 23:46'! new self error: 'Use #new: instead.'! ! !Bitset class methodsFor: 'instance creation' stamp: 'ul 8/19/2015 23:45'! new: capacity ^self basicNew initialize: capacity! ! !Bitset methodsFor: 'comparing' stamp: 'ul 8/20/2015 02:14'! = anObject self species == anObject species ifFalse: [ ^false ]. anObject size = tally ifFalse: [ ^false ]. ^anObject bytes = bytes! ! !Bitset methodsFor: 'adding' stamp: 'ul 8/22/2015 00:56'! add: anInteger "Add anInteger to this set. Return anInteger." self setBitAt: anInteger. ^anInteger! ! !Bitset methodsFor: 'accessing' stamp: 'ul 8/19/2015 23:37'! at: anInteger ^self bitAt: anInteger ! ! !Bitset methodsFor: 'accessing' stamp: 'ul 8/19/2015 23:48'! at: anInteger put: aBit ^self bitAt: anInteger put: aBit ! ! !Bitset methodsFor: 'bit manipulation' stamp: 'ul 8/22/2015 00:53'! bitAt: anInteger "Return the bit corresponding to anInteger." ^((bytes at: (anInteger bitShift: -3) + 1) bitShift: 0 - (anInteger bitAnd: 7)) bitAnd: 1 ! ! !Bitset methodsFor: 'bit manipulation' stamp: 'ul 8/22/2015 00:55'! bitAt: anInteger put: aBit "Set the value corresponding to anInteger to aBit. Return the new value." aBit caseOf: { [ 0 ] -> [ self clearBitAt: anInteger ]. [ 1 ] -> [ self setBitAt: anInteger ] }. ^aBit ! ! !Bitset methodsFor: 'private' stamp: 'ul 8/20/2015 02:14'! bytes ^bytes! ! !Bitset methodsFor: 'accessing' stamp: 'ul 8/22/2015 00:57'! capacity "Return the highest integer this collection can store plus one." ^bytes size * 8! ! !Bitset methodsFor: 'bit manipulation' stamp: 'ul 8/22/2015 00:54'! clearBitAt: anInteger "Set the value corresponding to anInteger to 0. Return true if the value wasn't 0." | index value mask newValue | index := (anInteger bitShift: -3) + 1. value := bytes at: index. mask := 1 bitShift: (anInteger bitAnd: 7). (newValue := (value bitOr: mask) - mask) = value ifTrue: [ ^false ]. bytes at: index put: newValue. tally := tally - 1. ^true ! ! !Bitset methodsFor: 'enumerating' stamp: 'ul 8/22/2015 01:26'! do: aBlock "Evaluate aBlock with each integer which has its bit set to 1." | byte byteOffset lowBits remainingBits | remainingBits := tally. lowBits := Integer lowBitPerByteTable. 1 to: bytes size do: [ :index | 1 <= remainingBits ifFalse: [ ^self ]. (byte := bytes at: index) = 0 ifFalse: [ byteOffset := (index bitShift: 3) - 9. "- 8 - 1 to make it -1 based." [ aBlock value: (lowBits at: byte) + byteOffset. "byteOffset is -1 based, lowBits is 1-based." remainingBits := remainingBits - 1. "Eliminate the low bit and loop if there're any remaning bits set." (byte := byte bitAnd: byte - 1) = 0 ] whileFalse ] ]! ! !Bitset methodsFor: 'comparing' stamp: 'ul 8/22/2015 00:59'! hash "#hash is implemented, because #= is implemented." ^(self species hash bitXor: tally hashMultiply) bitXor: bytes hash! ! !Bitset methodsFor: 'testing' stamp: 'ul 8/22/2015 01:54'! includes: anInteger anInteger isInteger ifFalse: [ ^false ]. -1 < anInteger ifFalse: [ ^false ]. anInteger < self capacity ifFalse: [ ^false ]. ^(self bitAt: anInteger) = 1! ! !Bitset methodsFor: 'private' stamp: 'ul 8/22/2015 01:04'! initialize: capacity "Capacity is expected to be a non-negative, multiple-of-eight integer." bytes := ByteArray new: capacity // 8. tally := 0! ! !Bitset methodsFor: 'copying' stamp: 'ul 8/22/2015 01:00'! postCopy "Copy bytes as well." bytes := bytes copy! ! !Bitset methodsFor: 'removing' stamp: 'ul 8/20/2015 01:42'! remove: anInteger ifAbsent: absentBlock (self clearBitAt: anInteger) ifTrue: [ ^anInteger ]. ^absentBlock value! ! !Bitset methodsFor: 'removing' stamp: 'ul 8/22/2015 01:08'! removeAll tally = 0 ifTrue: [ ^self ]. bytes atAllPut: 0. "Unlike most #removeAll implementations, we don't allocate a new ByteArray here, because this is a bit more efficient. The VM would have to fill the new array with zeroes anyway." tally := 0! ! !Bitset methodsFor: 'bit manipulation' stamp: 'ul 8/22/2015 00:54'! setBitAt: anInteger "Set the value corresponding to anInteger to 1. Return true if the value wasn't 1." | index value newValue | index := (anInteger bitShift: -3) + 1. value := bytes at: index. (newValue := (1 bitShift: (anInteger bitAnd: 7)) bitOr: value) = value ifTrue: [ ^false ]. bytes at: index put: newValue. tally := tally + 1. ^true! ! !Bitset methodsFor: 'accessing' stamp: 'ul 8/22/2015 00:56'! size "Return the number of 1 values in this collection." ^tally! ! !WideCharacterSet methodsFor: 'collection ops' stamp: 'ul 8/22/2015 12:57' prior: 19030919! add: aCharacter | value highBits lowBits | self migrate. (value := aCharacter asInteger) < 256 ifTrue: [ byteArrayMap at: value + 1 put: 1 ]. highBits := value bitShift: highBitsShift. lowBits := value bitAnd: lowBitsMask. (map at: highBits ifAbsentPut: [ Bitset new: bitsetCapacity ]) setBitAt: lowBits. ^aCharacter! ! !WideCharacterSet methodsFor: 'private' stamp: 'ul 8/22/2015 12:34' prior: 19035142! bitmap: aMap do: aBlock "Execute a block with each value (0 based) corresponding to set bits. Implementation notes: this version works best for sparse maps. It has (byte lowBit) inlined for speed." | byte byteOffset lowBits | lowBits := Integer lowBitPerByteTable. "The lowBits table gives a 1-based bitOffset" 1 to: aMap size do: [:i | (byte := aMap at: i) = 0 ifFalse: [ byteOffset := (i bitShift: 3) - 9. "This byteOffset is -1 based" ["Evaluate the block with 0-based (byteOffset + bitOffset)" aBlock value: (byteOffset + (lowBits at: byte)). "Eliminate the low bit and loop if some bit remain" (byte := byte bitAnd: byte - 1) = 0] whileFalse]]! ! !WideCharacterSet methodsFor: 'comparing' stamp: 'ul 8/20/2015 01:51' prior: 19029206! byteArrayMap "return a ByteArray mapping each ascii value to a 1 if that ascii value is in the set, and a 0 if it isn't. Intended for use by primitives only. (and comparison) This version will answer a subset with only byte characters" ^byteArrayMap! ! !WideCharacterSet methodsFor: 'collection ops' stamp: 'ul 8/22/2015 12:57' prior: 19031603! do: aBlock self migrate. map keysAndValuesDo: [ :index :bitset | | highBits | highBits := index * bitsetCapacity. bitset do: [ :lowBits | aBlock value: (Character value: highBits + lowBits) ] ]! ! !WideCharacterSet methodsFor: 'collection ops' stamp: 'ul 8/22/2015 12:37' prior: 19031901! findFirstInByteString: aByteString startingAt: startIndex "Double dispatching: since we know this is a ByteString, we can use a superfast primitive using a ByteArray map with 0 slots for byte characters not included and 1 for byte characters included in the receiver." ^ByteString findFirstInString: aByteString inSet: byteArrayMap startingAt: startIndex! ! !WideCharacterSet methodsFor: 'comparing' stamp: 'ul 8/22/2015 12:49' prior: 19029915! hash "Answer a hash code aimed at storing and retrieving the receiver in a Set or Dictionary. Two equal objects should have equal hash. Note: as the receiver can be equal to an ordinary CharacterSet, the hash code must reflect this" self hasWideCharacters ifTrue: [ ^map hash ]. ^byteArrayMap hash! ! !WideCharacterSet methodsFor: 'collection ops' stamp: 'ul 8/22/2015 12:57' prior: 19032350! includes: aCharacter | value | (value := aCharacter asInteger) < 256 ifTrue: [ ^(byteArrayMap at: value + 1) ~= 0 ]. self migrate. ^((map at: (value bitShift: highBitsShift) ifAbsent: nil) ifNil: [ ^false ]) includes: (value bitAnd: lowBitsMask)! ! !WideCharacterSet methodsFor: 'initialize-release' stamp: 'ul 8/19/2015 22:18' prior: 19038319! initialize map := PluggableDictionary integerDictionary. byteArrayMap := ByteArray new: 256. self initializeWithLowBits: 8! ! !WideCharacterSet methodsFor: 'initialize-release' stamp: 'ul 8/22/2015 12:33'! initializeWithLowBits: lowBits bitsetCapacity := 1 bitShift: lowBits. highBitsShift := 0 - lowBits. lowBitsMask := bitsetCapacity - 1. ! ! !WideCharacterSet methodsFor: 'private' stamp: 'ul 8/22/2015 12:33'! migrate | newMap | bitsetCapacity ifNotNil: [ ^self "already migrated" ]. self initializeWithLowBits: 8. newMap := PluggableDictionary integerDictionary. map keysAndValuesDo: [ :index :lowmap | | high16Bits | high16Bits := index bitShift: 16. self bitmap: lowmap do: [ :low16Bits | | value highBits lowBits | value := high16Bits + low16Bits. highBits := value bitShift: highBitsShift. lowBits := value bitAnd: lowBitsMask. (newMap at: highBits ifAbsentPut: [ Bitset new: bitsetCapacity ]) setBitAt: lowBits ] ]. map := newMap! ! !WideCharacterSet methodsFor: 'collection ops' stamp: 'ul 8/22/2015 12:39' prior: 19033030! remove: aCharacter "Don't signal an error when aCharacter is not present." ^self remove: aCharacter ifAbsent: aCharacter! ! !WideCharacterSet methodsFor: 'collection ops' stamp: 'ul 8/22/2015 12:58' prior: 19033480! remove: aCharacter ifAbsent: aBlock | value highBits lowBits bitset | (value := aCharacter asInteger) < 256 ifTrue: [ (byteArrayMap at: value + 1) = 0 ifTrue: [ ^aBlock value ]. byteArrayMap at: value + 1 put: 0 ]. self migrate. highBits := value bitShift: highBitsShift. lowBits := value bitAnd: lowBitsMask. bitset := (map at: highBits ifAbsent: nil) ifNil: [ ^aBlock value ]. ((bitset clearBitAt: lowBits) and: [ bitset size = 0 ]) ifTrue: [ map removeKey: highBits ]. ^aCharacter! ! !WideCharacterSet methodsFor: 'collection ops' stamp: 'ul 8/22/2015 12:45' prior: 19033680! removeAll map isEmpty ifTrue: [ ^self ]. map removeAll. byteArrayMap atAllPut: 0! ! !WideCharacterSet methodsFor: 'collection ops' stamp: 'ul 8/22/2015 12:45' prior: 19033823! size ^map detectSum: [ :each | each size ]! ! !Character methodsFor: 'testing' stamp: 'ul 8/16/2015 14:05' prior: 33582126! shouldBePrintedAsLiteral | integerValue | (integerValue := self asInteger) < 33 ifTrue: [ ^false ]. 255 < integerValue ifTrue: [ ^false ]. ^integerValue ~= 127! ! !ByteArray methodsFor: 'accessing' stamp: 'ul 8/19/2015 22:31'! indexOf: anInteger ^self indexOf: anInteger startingAt: 1! ! !ByteArray methodsFor: 'accessing' stamp: 'ul 8/19/2015 22:29' prior: 56716495! indexOf: anInteger startingAt: start anInteger isInteger ifFalse: [ ^0 ]. 0 <= anInteger ifFalse: [ ^0 ]. anInteger <= 255 ifFalse: [ ^0 ]. ^ByteString indexOfAscii: anInteger inString: self startingAt: start! ! !ByteArray methodsFor: 'accessing' stamp: 'ul 8/19/2015 22:32'! indexOf: anInteger startingAt: start ifAbsent: aBlock | index | (index := self indexOf: anInteger startingAt: start) = 0 ifTrue: [ ^aBlock value ]. ^index! ! WideCharacterSet removeSelector: #setBitmap:at:! WideCharacterSet removeSelector: #clearBitmap:at:! WideCharacterSet removeSelector: #bitmap:at:! "Collections"! !InstallerInternetBased methodsFor: 'url' stamp: 'ul 8/14/2015 18:02' prior: 63877545! wasPbwikiSpeedWarning ^ self hasPage and: [pageDataStream contents includesSubstring: 'Please slow down a bit' ] ! ! !InstallerMonticello methodsFor: 'instance creation' stamp: 'ul 8/14/2015 18:02' prior: 21409442! http: aUrl user: name password: secret | url | url := (aUrl includesSubstring: '://') ifTrue: [aUrl] ifFalse: ['http://', aUrl]. mc := self classMCHttpRepository location: url user: name password: secret. root := mc locationWithTrailingSlash ! ! "Installer-Core"! !MethodPragmaTest methodsFor: 'utilities' stamp: 'ul 8/14/2015 18:03' prior: 18157396! assertPragma: aString givesKeyword: aSymbol arguments: anArray | pragma decompiled | pragma := self pragma: aString selector: #zork. self assert: pragma keyword = aSymbol. self assert: pragma arguments = anArray. decompiled := (self class>>#zork) decompile. self assert: (decompiled properties pragmas includes: pragma). self assert: (decompiled asString includesSubstring: pragma asString).! ! !BlockContextTest methodsFor: 'tests' stamp: 'ul 8/14/2015 17:59' prior: 57092455! testNew self should: [ContextPart new: 5] raise: Error. [ContextPart new: 5] on: Error do: [:e| self assert: (e messageText includesSubstring: 'newForMethod:') description: 'Error doesn''t tell you what you did wrong by calling #new:']. self should: [ContextPart new] raise: Error. [ContextPart new] on: Error do: [:e| self assert: (e messageText includesSubstring: 'newForMethod:') description: 'Error doesn''t tell you what you did wrong by calling #new'].! ! !ObjectTest methodsFor: 'as yet unclassified' stamp: 'ul 8/14/2015 18:03' prior: 50776546! testShouldBeImplemented | testClass | testClass := NotImplementedTestData. self should: [testClass new shouldBeImplementedMsg] raise: NotImplemented. [testClass new shouldBeImplementedMsg] ifError: [:errDesc | self assert: (errDesc includesSubstring: testClass name) description: 'Error should include class name'. self assert: (errDesc includesSubstring: #shouldBeImplementedMsg asString) description: 'Error should include selector name'].! ! !ObjectTest methodsFor: 'as yet unclassified' stamp: 'ul 8/14/2015 18:03' prior: 50777076! testShouldNotImplement | testClass | testClass := NotImplementedTestData. self should: [testClass new shouldNotImplementMsg] raise: NotImplemented. [testClass new shouldNotImplementMsg] ifError: [:errDesc | self assert: (errDesc includesSubstring: testClass name) description: 'Error should include class name'. self assert: (errDesc includesSubstring: #shouldNotImplementMsg asString) description: 'Error should include selector name'].! ! "KernelTests"! SqueakSSLTest removeSelector: #testYahooOpenID! "SqueakSSL-Tests"! !FontImporterTool methodsFor: 'accessing' stamp: 'topa 8/21/2015 14:12' prior: 28191754! currentSelection: anObject anObject = currentSelection ifTrue: [^ self]. currentSelection := anObject. self changed: #currentSelection. self changed: #previewText. self changed: #filename. self changed: #copyright.! ! "Morphic"! !BooklikeMorph methodsFor: 'page controls' stamp: 'ul 8/14/2015 18:05' prior: 66484027! makePageControlsFrom: controlSpecs "From the controlSpecs, create a set of page control and return them -- this method does *not* add the controls to the receiver." | c col row | c := (color saturation > 0.1) ifTrue: [color slightlyLighter] ifFalse: [color slightlyDarker]. col := AlignmentMorph newColumn. col color: c; borderWidth: 0; layoutInset: 0. col hResizing: #spaceFill; vResizing: #shrinkWrap; extent: 5@5. row := AlignmentMorph newRow. row color: c; borderWidth: 0; layoutInset: 0. row hResizing: #spaceFill; vResizing: #shrinkWrap; extent: 5@5. controlSpecs do: [:spec | | lastGuy b | spec == #spacer ifTrue: [row addTransparentSpacerOfSize: (10 @ 0)] ifFalse: [spec == #variableSpacer ifTrue: [row addMorphBack: AlignmentMorph newVariableTransparentSpacer] ifFalse: [b := SimpleButtonMorph new target: self; borderWidth: 1; borderColor: Color veryLightGray; color: c. b label: spec first; actionSelector: spec second; borderWidth: 0; setBalloonText: spec third. row addMorphBack: b. (((lastGuy := spec last asLowercase) includesSubstring: 'menu') or: [lastGuy includesSubstring: 'designations']) ifTrue: [b actWhen: #buttonDown]]]]. "pop up menu on mouseDown" col addMorphBack: row. ^ col! ! "MorphicExtras"! !MethodFinder methodsFor: 'initialize' stamp: 'ul 8/14/2015 18:18' prior: 63306631! initialize2 "The methods we are allowed to use. (MethodFinder new initialize) " "Set" #("in class" sizeFor: "testing" "adding" "removing" "enumerating" "private" array scanFor: "accessing" someElement) do: [:sel | Approved add: sel]. "Dictionary, IdentityDictionary, IdentitySet" #("accessing" associationAt: associationAt:ifAbsent: at:ifPresent: keyAtIdentityValue: keyAtIdentityValue:ifAbsent: keyAtValue: keyAtValue:ifAbsent: keys "testing" includesKey: ) do: [:sel | Approved add: sel]. #(removeKey: removeKey:ifAbsent: ) do: [:sel | AddAndRemove add: sel]. "LinkedList, Interval, MappedCollection" #("in class" from:to: from:to:by: "accessing" contents) do: [:sel | Approved add: sel]. #( "adding" addFirst: addLast:) do: [:sel | AddAndRemove add: sel]. "OrderedCollection, SortedCollection" #("accessing" after: before: "copying" copyEmpty "adding" growSize "removing" "enumerating" "private" "accessing" sortBlock) do: [:sel | Approved add: sel]. #("adding" add:after: add:afterIndex: add:before: addAllFirst: addAllLast: addFirst: addLast: "removing" removeAt: removeFirst removeLast "accessing" sortBlock:) do: [:sel | AddAndRemove add: sel]. "Character" #("in class, instance creation" allByteCharacters digitValue: new separators "accessing untypeable characters" backspace cr enter lf linefeed nbsp newPage space tab "constants" alphabet characterTable "accessing" asciiValue digitValue "comparing" "testing" isAlphaNumeric isDigit isLetter isLowercase isSafeForHTTP isSeparator isSpecial isUppercase isVowel tokenish "copying" "converting" asIRCLowercase asLowercase asUppercase ) do: [:sel | Approved add: sel]. "String" #("in class, instance creation" crlf fromPacked: "primitives" findFirstInString:inSet:startingAt: indexOfAscii:inString:startingAt: "internet" valueOfHtmlEntity: "accessing" byteAt: endsWithDigit findAnySubStr:startingAt: findBetweenSubStrs: findDelimiters:startingAt: findString:startingAt: findString:startingAt:caseSensitive: findTokens: findTokens:includes: findTokens:keep: includesSubstring: includesSubstring:caseSensitive: indexOf:startingAt: indexOfAnyOf: indexOfAnyOf:ifAbsent: indexOfAnyOf:startingAt: indexOfAnyOf:startingAt:ifAbsent: lineCorrespondingToIndex: lineCount lineNumber: skipAnySubStr:startingAt: skipDelimiters:startingAt: startsWithDigit "comparing" alike: beginsWith: caseSensitiveLessOrEqual: charactersExactlyMatching: compare: crc16 endsWith: endsWithAnyOf: sameAs: startingAt:match:startingAt: "copying" copyReplaceTokens:with: padded:to:with: "converting" asByteArray asDate asDisplayText asFileName asHtml asLegalSelector asPacked asParagraph asText asTime asUnHtml asUrl asUrlRelativeTo: capitalized compressWithTable: contractTo: correctAgainst: encodeForHTTP initialIntegerOrNil keywords quoted sansPeriodSuffix splitInteger stemAndNumericSuffix substrings surroundedBySingleQuotes truncateWithElipsisTo: withBlanksTrimmed withFirstCharacterDownshifted withNoLineLongerThan: withSeparatorsCompacted withoutLeadingDigits withoutTrailingBlanks "displaying" "printing" "system primitives" compare:with:collated: "Celeste" withCRs "internet" decodeMimeHeader decodeQuotedPrintable unescapePercents withInternetLineEndings withSqueakLineEndings withoutQuoting "testing" isAllSeparators lastSpacePosition "paragraph support" indentationIfBlank: "arithmetic" ) do: [:sel | Approved add: sel]. #(byteAt:put: translateToLowercase match:) do: [:sel | AddAndRemove add: sel]. "Symbol" #("in class, private" hasInterned:ifTrue: "access" morePossibleSelectorsFor: possibleSelectorsFor: selectorsContaining: thatStarts:skipping: "accessing" "comparing" "copying" "converting" "printing" "testing" isInfix isKeyword isPvtSelector isUnary) do: [:sel | Approved add: sel]. "Array" #("comparing" "converting" evalStrings "printing" "private" hasLiteralSuchThat:) do: [:sel | Approved add: sel]. "Array2D" #("access" at:at: atCol: atCol:put: atRow: extent extent:fromArray: height width width:height:type:) do: [:sel | Approved add: sel]. #(at:at:add: at:at:put: atRow:put: ) do: [:sel | AddAndRemove add: sel]. "ByteArray" #("accessing" doubleWordAt: wordAt: "platform independent access" longAt:bigEndian: shortAt:bigEndian: unsignedLongAt:bigEndian: unsignedShortAt:bigEndian: "converting") do: [:sel | Approved add: sel]. #(doubleWordAt:put: wordAt:put: longAt:put:bigEndian: shortAt:put:bigEndian: unsignedLongAt:put:bigEndian: unsignedShortAt:put:bigEndian: ) do: [:sel | AddAndRemove add: sel]. "FloatArray" "Dont know what happens when prims not here" false ifTrue: [#("accessing" "arithmetic" *= += -= /= "comparing" "primitives-plugin" primAddArray: primAddScalar: primDivArray: primDivScalar: primMulArray: primMulScalar: primSubArray: primSubScalar: "primitives-translated" primAddArray:withArray:from:to: primMulArray:withArray:from:to: primSubArray:withArray:from:to: "converting" "private" "user interface") do: [:sel | Approved add: sel]. ]. "IntegerArray, WordArray" "RunArray" #("in class, instance creation" runs:values: scanFrom: "accessing" runLengthAt: "adding" "copying" "private" runs values) do: [:sel | Approved add: sel]. #(coalesce addLast:times: repeatLast:ifEmpty: repeatLastIfEmpty: ) do: [:sel | AddAndRemove add: sel]. "Stream -- many operations change its state" #("testing" atEnd) do: [:sel | Approved add: sel]. #("accessing" next: nextMatchAll: nextMatchFor: upToEnd next:put: nextPut: nextPutAll: "printing" print: printHtml: ) do: [:sel | AddAndRemove add: sel]. "PositionableStream" #("accessing" contentsOfEntireFile originalContents peek peekFor: "testing" "positioning" position ) do: [:sel | Approved add: sel]. #(nextDelimited: nextLine upTo: position: reset resetContents setToEnd skip: skipTo: upToAll: ) do: [:sel | AddAndRemove add: sel]. "Because it is so difficult to test the result of an operation on a Stream (you have to supply another Stream in the same state), we don't support Streams beyond the basics. We want to find the messages that convert Streams to other things." "ReadWriteStream" #("file status" closed) do: [:sel | Approved add: sel]. #("accessing" next: on: ) do: [:sel | AddAndRemove add: sel]. "WriteStream" #("in class, instance creation" on:from:to: with: with:from:to: ) do: [:sel | Approved add: sel]. #("positioning" resetToStart "character writing" crtab crtab:) do: [:sel | AddAndRemove add: sel]. "LookupKey, Association, Link" #("accessing" key nextLink) do: [:sel | Approved add: sel]. #(key: key:value: nextLink:) do: [:sel | AddAndRemove add: sel]. "Point" #("in class, instance creation" r:degrees: x:y: "accessing" x y "comparing" "arithmetic" "truncation and round off" "polar coordinates" degrees r theta "point functions" bearingToPoint: crossProduct: dist: dotProduct: eightNeighbors flipBy:centerAt: fourNeighbors grid: nearestPointAlongLineFrom:to: nearestPointOnLineFrom:to: normal normalized octantOf: onLineFrom:to: onLineFrom:to:within: quadrantOf: rotateBy:centerAt: transposed unitVector "converting" asFloatPoint asIntegerPoint corner: extent: rect: "transforming" adhereTo: rotateBy:about: scaleBy: scaleFrom:to: translateBy: "copying" "interpolating" interpolateTo:at:) do: [:sel | Approved add: sel]. "Rectangle" #("in class, instance creation" center:extent: encompassing: left:right:top:bottom: merging: origin:corner: origin:extent: "accessing" area bottom bottomCenter bottomLeft bottomRight boundingBox center corner corners innerCorners left leftCenter origin right rightCenter top topCenter topLeft topRight "comparing" "rectangle functions" adjustTo:along: amountToTranslateWithin: areasOutside: bordersOn:along: encompass: expandBy: extendBy: forPoint:closestSideDistLen: insetBy: insetOriginBy:cornerBy: intersect: merge: pointNearestTo: quickMerge: rectanglesAt:height: sideNearestTo: translatedToBeWithin: withBottom: withHeight: withLeft: withRight: withSide:setTo: withTop: withWidth: "testing" containsPoint: containsRect: hasPositiveExtent intersects: isTall isWide "truncation and round off" "transforming" align:with: centeredBeneath: newRectFrom: squishedWithin: "copying" ) do: [:sel | Approved add: sel]. "Color" #("in class, instance creation" colorFrom: colorFromPixelValue:depth: fromRgbTriplet: gray: h:s:v: r:g:b: r:g:b:alpha: r:g:b:range: "named colors" black blue brown cyan darkGray gray green lightBlue lightBrown lightCyan lightGray lightGreen lightMagenta lightOrange lightRed lightYellow magenta orange red transparent veryDarkGray veryLightGray veryVeryDarkGray veryVeryLightGray white yellow "other" colorNames indexedColors pixelScreenForDepth: quickHighLight: "access" alpha blue brightness green hue luminance red saturation "equality" "queries" isBitmapFill isBlack isGray isSolidFill isTranslucent isTranslucentColor "transformations" alpha: dansDarker darker lighter mixed:with: muchLighter slightlyDarker slightlyLighter veryMuchLighter alphaMixed:with: "groups of shades" darkShades: lightShades: mix:shades: wheel: "printing" shortPrintString "other" colorForInsets rgbTriplet "conversions" asB3DColor asColor balancedPatternForDepth: bitPatternForDepth: closestPixelValue1 closestPixelValue2 closestPixelValue4 closestPixelValue8 dominantColor halfTonePattern1 halfTonePattern2 indexInMap: pixelValueForDepth: pixelWordFor:filledWith: pixelWordForDepth: scaledPixelValue32 "private" privateAlpha privateBlue privateGreen privateRGB privateRed "copying" ) do: [:sel | Approved add: sel]. " For each selector that requires a block argument, add (selector argNum) to the set Blocks." "ourClasses := #(Object Boolean True False UndefinedObject Behavior ClassDescription Class Metaclass MethodContext BlockContext Message Magnitude Date Time Number Integer SmallInteger LargeNegativeInteger LargePositiveInteger Float Fraction Random Collection SequenceableCollection ArrayedCollection Bag Set Dictionary IdentityDictionary IdentitySet LinkedList Interval MappedCollection OrderedCollection SortedCollection Character String Symbol Array Array2D ByteArray FloatArray IntegerArray WordArray RunArray Stream PositionableStream ReadWriteStream WriteStream LookupKey Association Link Point Rectangle Color). ourClasses do: [:clsName | cls := Smalltalk at: clsName. (cls selectors) do: [:aSel | ((Approved includes: aSel) or: [AddAndRemove includes: aSel]) ifTrue: [ (cls formalParametersAt: aSel) withIndexDo: [:tName :ind | (tName endsWith: 'Block') ifTrue: [ Blocks add: (Array with: aSel with: ind)]]]]]. " #((timesRepeat: 1 ) (indexOf:ifAbsent: 2 ) (pairsCollect: 1 ) (mergeSortFrom:to:by: 3 ) (ifNotNil:ifNil: 1 ) (ifNotNil:ifNil: 2 ) (ifNil: 1 ) (at:ifAbsent: 2 ) (ifNil:ifNotNil: 1 ) (ifNil:ifNotNil: 2 ) (ifNotNil: 1 ) (at:modify: 2 ) (identityIndexOf:ifAbsent: 2 ) (sort: 1 ) (sortBlock: 1 ) (detectMax: 1 ) (repeatLastIfEmpty: 1 ) (allSubclassesWithLevelDo:startingLevel: 1 ) (keyAtValue:ifAbsent: 2 ) (in: 1 ) (ifTrue: 1 ) (or: 1 ) (select: 1 ) (inject:into: 2 ) (forPoint:closestSideDistLen: 2 ) (value:ifError: 2 ) (selectorsDo: 1 ) (removeAllSuchThat: 1 ) (keyAtIdentityValue:ifAbsent: 2 ) (detectMin: 1 ) (detect:ifNone: 1 ) (ifTrue:ifFalse: 1 ) (ifTrue:ifFalse: 2 ) (detect:ifNone: 2 ) (hasLiteralSuchThat: 1 ) (indexOfAnyOf:ifAbsent: 2 ) (reject: 1 ) (newRectFrom: 1 ) (removeKey:ifAbsent: 2 ) (at:ifPresent: 2 ) (associationAt:ifAbsent: 2 ) (withIndexCollect: 1 ) (repeatLast:ifEmpty: 2 ) (findLast: 1 ) (indexOf:startingAt:ifAbsent: 3 ) (remove:ifAbsent: 2 ) (ifFalse:ifTrue: 1 ) (ifFalse:ifTrue: 2 ) (caseOf:otherwise: 2 ) (count: 1 ) (collect: 1 ) (sortBy: 1 ) (and: 1 ) (asSortedCollection: 1 ) (with:collect: 2 ) (sourceCodeAt:ifAbsent: 2 ) (detect: 1 ) (collectWithIndex: 1 ) (compiledMethodAt:ifAbsent: 2 ) (bindWithTemp: 1 ) (detectSum: 1 ) (indexOfSubCollection:startingAt:ifAbsent: 3 ) (findFirst: 1 ) (sourceMethodAt:ifAbsent: 2 ) (collect:thenSelect: 1 ) (collect:thenSelect: 2 ) (select:thenCollect: 1 ) (select:thenCollect: 2 ) (ifFalse: 1 ) (indexOfAnyOf:startingAt:ifAbsent: 3 ) (indentationIfBlank: 1 ) ) do: [:anArray | Blocks add: anArray]. self initialize3. " MethodFinder new initialize. MethodFinder new organizationFiltered: TranslucentColor class " "Do not forget class messages for each of these classes" ! ! !Debugger class methodsFor: 'opening' stamp: 'ul 8/14/2015 18:01' prior: 54928686! openInterrupt: aString onProcess: interruptedProcess "Open a notifier in response to an interrupt. An interrupt occurs when the user types the interrupt key (cmd-. on Macs, ctrl-c or alt-. on other systems) or when the low-space watcher detects that memory is low." | debugger | "Simulation guard" debugger := self new. debugger process: interruptedProcess controller: ((Smalltalk isMorphic not and: [ScheduledControllers activeControllerProcess == interruptedProcess]) ifTrue: [ScheduledControllers activeController]) context: interruptedProcess suspendedContext. debugger externalInterrupt: true. Preferences logDebuggerStackToFile ifTrue: [(aString includesSubstring: 'Space') & (aString includesSubstring: 'low') ifTrue: [Smalltalk logError: aString inContext: debugger interruptedContext to: 'LowSpaceDebug.log'] "logging disabled for 4.3 release, see http://lists.squeak.org/pipermail/squeak-dev/2011-December/162503.html" "ifFalse: [Smalltalk logSqueakError: aString inContext: debugger interruptedContext]"]. Preferences eToyFriendly ifTrue: [World stopRunningAll]. ^debugger openNotifierContents: nil label: aString; yourself ! ! !ProcessBrowser methodsFor: 'process list' stamp: 'ul 8/14/2015 18:03' prior: 58775175! nextContext | initialProcessIndex initialStackIndex | searchString isEmpty ifTrue: [ ^false ]. initialProcessIndex := self processListIndex. initialStackIndex := self stackListIndex. initialProcessIndex to: self processList size do: [:pi | self processListIndex: pi. self stackNameList withIndexDo: [:name :si | (pi ~= initialProcessIndex or: [si > initialStackIndex]) ifTrue: [(name includesSubstring: searchString) ifTrue: [self stackListIndex: si. ^true]]]]. self processListIndex: initialProcessIndex. self stackListIndex: initialStackIndex. ^ false! ! !MessageSet class methodsFor: 'utilities' stamp: 'ul 8/14/2015 18:02' prior: 29140874! parse: methodRef toClassAndSelector: csBlock "Decode strings of the form [class] ." | tuple cl | self flag: #mref. "compatibility with pre-MethodReference lists" methodRef ifNil: [^ csBlock value: nil value: nil]. methodRef isString ifFalse: [^methodRef setClassAndSelectorIn: csBlock]. methodRef isEmpty ifTrue: [^csBlock value: nil value: nil]. tuple := (methodRef asString includesSubstring: '>>') ifTrue: [(methodRef findTokens: '>>') fold: [:a :b| (a findTokens: ' '), {b first = $# ifTrue: [b allButFirst] ifFalse: [b]}]] ifFalse: [methodRef asString findTokens: ' .']. cl := Smalltalk at: tuple first asSymbol ifAbsent: [^ csBlock value: nil value: nil]. ^(tuple size = 2 or: [tuple size > 2 and: [(tuple at: 2) ~= 'class']]) ifTrue: [csBlock value: cl value: (tuple at: 2) asSymbol] ifFalse: [csBlock value: cl class value: (tuple at: 3) asSymbol]! ! !ChangeList methodsFor: 'scanning' stamp: 'ul 8/14/2015 18:00' prior: 23585147! scanCategory "Scan anything that involves more than one chunk; method name is historical only" | itemPosition item tokens stamp anIndex | itemPosition := file position. item := file nextChunk. ((item includesSubstring: 'commentStamp:') or: [(item includesSubstring: 'methodsFor:') or: [item endsWith: 'reorganize']]) ifFalse: ["Maybe a preamble, but not one we recognize; bail out with the preamble trick" ^ self addItem: (ChangeRecord new file: file position: itemPosition type: #preamble) text: ('preamble: ' , item contractTo: 50)]. tokens := Scanner new scanTokens: item. tokens size >= 3 ifTrue: [stamp := ''. anIndex := tokens indexOf: #stamp: ifAbsent: [nil]. anIndex ifNotNil: [stamp := tokens at: (anIndex + 1)]. tokens second == #methodsFor: ifTrue: [^ self scanCategory: tokens third class: tokens first meta: false stamp: stamp]. tokens third == #methodsFor: ifTrue: [^ self scanCategory: tokens fourth class: tokens first meta: true stamp: stamp]]. tokens second == #commentStamp: ifTrue: [stamp := tokens third. self addItem: (ChangeRecord new file: file position: file position type: #classComment class: tokens first category: nil meta: false stamp: stamp) text: 'class comment for ' , tokens first, (stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp]). file nextChunk. ^ file skipStyleChunk]. self assert: tokens last == #reorganize. self addItem: (ChangeRecord new file: file position: file position type: #reorganize class: tokens first category: nil meta: false stamp: stamp) text: 'organization for ' , tokens first, (tokens second == #class ifTrue: [' class'] ifFalse: ['']). file nextChunk! ! !ChangeList methodsFor: 'menu actions' stamp: 'ul 8/14/2015 18:00' prior: 23573971! selectContentsMatching | pattern | pattern := UIManager default request: 'pattern to match'. pattern isEmpty ifTrue: [^self]. ^Cursor execute showWhile: [self selectSuchThat: ((pattern includesAnyOf: '?*') ifTrue: [[ :change | pattern match: change string]] ifFalse: [[ :change | change string includesSubstring: pattern]])]! ! !ClassListBrowser class methodsFor: 'examples' stamp: 'ul 8/14/2015 18:01' prior: 52222686! example1 "Put up a ClassListBrowser that shows all classes that have the string 'Pluggable' in their names" self browseClassesSatisfying: [:cl | cl name includesSubstring: 'Pluggable'] title: 'Pluggables' "ClassListBrowser example1" ! ! "Tools"! !StringType methodsFor: 'initialization' stamp: 'ul 8/14/2015 18:04' prior: 17209283! initialize "Initialize the receiver (automatically called when instances are created via 'new')" super initialize. self vocabularyName: #String. #((accessing 'The basic info' (at: at:put: size endsWithDigit findString: findTokens: includesSubstring: indexOf: indexOf:startingAt: indexOf:startingAt:ifAbsent: lineCorrespondingToIndex: lineCount lineNumber: startsWithDigit numArgs)) (#'more accessing' 'More basic info' (allButFirst allButFirst: allButLast allButLast: at:ifAbsent: atAllPut: atPin: atRandom: atWrap: atWrap:put: fifth first first: fourth from:to:put: last last: lastIndexOf: lastIndexOf:ifAbsent: middle replaceAll:with: replaceFrom:to:with: replaceFrom:to:with:startingAt: second sixth third)) (comparing 'Determining which comes first alphabeticly' (< <= = > >= beginsWith: endsWith: endsWithAnyOf: howManyMatch: match:)) (testing 'Testing' (includes: isEmpty ifNil: ifNotNil: isAllDigits isAllSeparators isString lastSpacePosition)) (converting 'Converting it to another form' (asCharacter asDate asInteger asLowercase asNumber asString asStringOrText asSymbol asText asTime asUppercase asUrl capitalized keywords numericSuffix romanNumber reversed splitInteger surroundedBySingleQuotes withBlanksTrimmed withSeparatorsCompacted withoutTrailingBlanks withoutTrailingDigits asSortedCollection)) (copying 'Make another one like me' (copy copyFrom:to: copyUpTo: copyUpToLast: shuffled)) (enumerating 'Passing over the letters' (collect: collectWithIndex: do: from:to:do: reverseDo: select: withIndexDo: detect: detect:ifNone:)) ) do: [:item | | aMethodCategory | aMethodCategory := ElementCategory new categoryName: item first. aMethodCategory documentation: item second. item third do: [:aSelector | | aMethodInterface | aMethodInterface := MethodInterface new initializeFor: aSelector. self atKey: aSelector putMethodInterface: aMethodInterface. aMethodCategory elementAt: aSelector put: aMethodInterface]. self addCategory: aMethodCategory]. ! ! "Protocols"! !SMLoaderPlus class methodsFor: 'class initialization' stamp: 'ul 8/14/2015 18:04' prior: 27290740! initialize "Hook us up in the world menu." "self initialize" Smalltalk at: #ToolBuilder ifPresent: [ : tb | self registerInFlapsRegistry. (Preferences windowColorFor: #SMLoader) = Color white "note set" ifTrue: [ #(#SMLoader #SMReleaseBrowser ) do: [ : each | Preferences setWindowColorFor: each to: (Color colorFrom: self windowColorSpecification brightColor) ] ]. (TheWorldMenu respondsTo: #registerOpenCommand:) ifTrue: [ | oldCmds | oldCmds := TheWorldMenu registry select: [ : cmd | cmd first includesSubstring: 'Package Loader' ]. oldCmds do: [ : cmd | TheWorldMenu unregisterOpenCommand: cmd first ]. TheWorldMenu registerOpenCommand: {self openMenuString. {self. #open}} ] ]. DefaultFilters := OrderedCollection new. DefaultCategoriesToFilterIds := OrderedCollection new! ! !SMLoader class methodsFor: 'class initialization' stamp: 'ul 8/14/2015 18:04' prior: 27461822! initialize "Hook us up in the world menu." "self initialize" Smalltalk at: #ToolBuilder ifAbsent: [self registerInFlapsRegistry. (Preferences windowColorFor: #SMLoader) = Color white ifTrue: ["not set" Preferences setWindowColorFor: #SMLoader to: (Color colorFrom: self windowColorSpecification brightColor)]. (TheWorldMenu respondsTo: #registerOpenCommand:) ifTrue: [| oldCmds | oldCmds := TheWorldMenu registry select: [:cmd | cmd first includesSubstring: 'Package Loader']. oldCmds do: [:cmd | TheWorldMenu unregisterOpenCommand: cmd first]. TheWorldMenu registerOpenCommand: {self openMenuString. {self. #open}}]]. DefaultFilters := OrderedCollection new. DefaultCategoriesToFilterIds := OrderedCollection new! ! "SMLoader"! !TestCase methodsFor: 'private' stamp: 'ul 8/14/2015 18:05' prior: 19103539! executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionContaining: aString ^[aBlock value. false] on: anExceptionalEvent do: [:ex | ex return: (ex description includesSubstring: aString) ] ! ! !TestCase methodsFor: 'private' stamp: 'ul 8/14/2015 18:05' prior: 19103814! executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionNotContaining: aString ^[aBlock value. false] on: anExceptionalEvent do: [:ex | ex return: (ex description includesSubstring: aString) not ] ! ! !SUnitTest methodsFor: 'testing' stamp: 'ul 8/14/2015 18:04' prior: 28216224! testAssertIdentical | a b | a := 'foo'. b := 'bar'. self should: [self assert: a identical: b] raise: TestFailure. [self assert: a identical: b] on: TestFailure do: [:e | |error| error := e messageText. self assert: (error includesSubstring: a) description: 'Error message doesn''t include the expected value'. self assert: (error includesSubstring: b) description: 'Error message doesn''t include the expected value'].! ! !SUnitTest methodsFor: 'testing' stamp: 'ul 8/14/2015 18:04' prior: 28216721! testAssertIdenticalDescription | a b | a := 'foo'. b := a copy. self should: [self assert: a identical: b description: 'A desciption'] raise: TestFailure. [self assert: a identical: b description: 'A desciption'] on: TestFailure do: [:e | |error| error := e messageText. self assert: (error includesSubstring: 'A desciption') description: 'Error message doesn''t give you the description'].! ! !SUnitTest methodsFor: 'testing' stamp: 'ul 8/14/2015 18:04' prior: 28217187! testAssertIdenticalWithEqualObjects | a b | a := 'foo'. b := a copy. self should: [self assert: a identical: b] raise: TestFailure. [self assert: a identical: b] on: TestFailure do: [:e | |error| error := e messageText. self assert: (error includesSubstring: 'not identical') description: 'Error message doesn''t say the two things aren''t identical'].! ! !SUnitTest methodsFor: 'testing' stamp: 'ul 8/14/2015 18:04' prior: 28220762! testWithExceptionDo self should: [self error: 'foo'] raise: TestResult error withExceptionDo: [:exception | self assert: (exception description includesSubstring: 'foo') ] ! ! "SUnit"! !ImageSegmentTest class methodsFor: 'Accessing' stamp: 'topa 8/21/2015 09:46'! testSelectors Smalltalk isRunningSpur ifTrue: [ "The ImageSegment Test is known to not work on SPUR VMs with the prospect of crashing. #expectedFailure does not cut it here, don't even try to run them" ^ #()]. ^ super testSelectors! ! !ImageSegmentTest methodsFor: 'testing' stamp: 'eem 2/2/2015 17:23' prior: 62186248! testImageSegmentsShouldBeWritableToaFile "This should not throw an exception" | classes | classes := UIManager subclasses reject: [:sc| sc isActiveManager]. ImageSegment new copyFromRoots: classes asArray sizeHint: 100; extract; writeToFile: 'InactiveUIManagers'; yourself. "TODO: write assertions showing that something meaningful actually happened." "now bring them back in again" classes do: [:ea| ea new]! ! !CompilerTest methodsFor: 'limits' stamp: 'ul 8/21/2015 01:07' prior: 28438153! testMaxLiterals "Document the maximum number of literals in a compiled method" | maxLiterals stringThatCanBeCompiled stringWithOneTooManyLiterals | maxLiterals := 250. stringThatCanBeCompiled := '{ ', (String streamContents: [:strm | 1 to: maxLiterals do: [:e | strm nextPutAll: '''', e asString, '''', ' . ']]), '}'. stringWithOneTooManyLiterals := '{ ', (String streamContents: [:strm | 1 to: maxLiterals + 1 do: [:e | strm nextPutAll: '''', e asString, '''', ' . ']]), '}'. self assert: ((1 to: maxLiterals) collect: #printString) equals: (Compiler evaluate: stringThatCanBeCompiled). "If the following test fails, it means that the limit has been raised or eliminated, and this test should be updated to reflect the improvement." self should: [Compiler evaluate: stringWithOneTooManyLiterals] raise: Error. ! ! !CompilerTest methodsFor: 'limits' stamp: 'ul 8/21/2015 01:07' prior: 28441329! testMaxLiteralsWithClassReferenceInClosure "Document the maximum number of literals in a compiled method. A class reference in a closure reduces the maximum literals." | maxLiterals stringThatCanBeCompiled stringWithOneTooManyLiterals | maxLiterals := 245. stringThatCanBeCompiled := '[ DateAndTime now. Date today. Time ]. { ', (String streamContents: [:strm | 1 to: maxLiterals do: [:e | strm nextPutAll: '''', e asString, '''', ' . ']]), '}'. stringWithOneTooManyLiterals := '[ DateAndTime now. Date today. Time ]. { ', (String streamContents: [:strm | 1 to: maxLiterals + 1 do: [:e | strm nextPutAll: '''', e asString, '''', ' . ']]), '}'. self assert: maxLiterals equals: (Compiler evaluate: stringThatCanBeCompiled) size. "If the following test fails, it means that the limit has been raised or eliminated, and this test should be updated to reflect the improvement." self should: [Compiler evaluate: stringWithOneTooManyLiterals] raise: Error. ! ! !BitmapStreamTests class methodsFor: 'Accessing' stamp: 'topa 8/21/2015 10:44'! testSelectors "The ImageSegment-based Bitmap Test is known to not work on SPUR VMs with the prospect of crashing. #expectedFailure does not cut it here, don't even try to run them" ^ super testSelectors copyWithout: #testMatrixTransform2x3WithImageSegment! ! !DecompilerTests methodsFor: 'utilities' stamp: 'ul 8/21/2015 19:00' prior: 84146603! decompilerFailures "Here is the list of failures: either a syntax error, a hard error or some failure to decompile correctly. Collected via DecompilerTestFailuresCollector new computeFailures." "class name, selector, error class name or nil" ^#( (Behavior toolIconSelector: TestFailure) (BrowserCommentTextMorph showPane SyntaxErrorNotification) (ClassDescription replaceSilently:to: SyntaxErrorNotification) (CodeHolder getSelectorAndSendQuery:to:with: SyntaxErrorNotification) (Date printOn: TestFailure) (DecompilerTests testDecompileUnreachableParameter Error) (FontImporterTool fontFromFamily: SyntaxErrorNotification) "same-name block-local temps in optimized blocks" (HttpUrl checkAuthorization:retry: TestFailure) (LargeNegativeIntegerTest testReplaceFromToWithStartingAt SyntaxErrorNotification) "same-name block-local temps in optimized blocks" (LargePositiveIntegerTest testReplaceFromToWithStartingAt SyntaxErrorNotification) "same-name block-local temps in optimized blocks" (MailComposition breakLinesInMessage: SyntaxErrorNotification) (MCConfigurationBrowser post SyntaxErrorNotification) (MVCToolBuilder setLayout:in: SyntaxErrorNotification) "same-name block-local temps in optimized blocks" (ParagraphEditor inOutdent:delta: SyntaxErrorNotification) (PNGReadWriter copyPixelsGray: SyntaxErrorNotification) (ScaledDecimalTest testConvertFromFraction SyntaxErrorNotification) "local/non-local temps" (SHMCClassDefinition withAllSuperclassesDo: SyntaxErrorNotification) "same-name block-local temps in optimized blocks" (StandardScriptingSystem holderWithAlphabet SyntaxErrorNotification) "same-name block-local temps in optimized blocks" (SystemWindow convertAlignment SyntaxErrorNotification) (TextEditor inOutdent:delta: SyntaxErrorNotification) (TextURL actOnClickFor: TestFailure) (TTContourConstruction segmentsDo: SyntaxErrorNotification) "Worth fixing; these two are mistaken conversion from a whileTrue: to a to:do: but the index is used outside the whileTrue:" (TTFontReader processHorizontalMetricsTable:length: SyntaxErrorNotification))! ! "Tests"! !BrowserTest methodsFor: 'as yet unclassified' stamp: 'ul 8/14/2015 18:00' prior: 57756947! testClassCommentAnnotation | annotation | browser selectSystemCategory: browser class category. browser selectClass: browser class. annotation := browser annotationForClassCommentFor: browser class. self assert: (annotation includesSubstring: browser class organization commentStamp). self assert: (annotation includesSubstring: 'class comment for'). self assert: (annotation includesSubstring: browser className).! ! !BrowserTest methodsFor: 'as yet unclassified' stamp: 'ul 8/14/2015 18:00' prior: 57757449! testClassCommentAnnotationIgnoresParameter | annotation | browser selectSystemCategory: browser class category. browser selectClass: browser class. "And the method ignores the parameter:" annotation := browser annotationForClassCommentFor: browser class superclass. self assert: (annotation includesSubstring: browser className).! ! !BrowserTest methodsFor: 'as yet unclassified' stamp: 'ul 8/14/2015 18:00' prior: 57767173! testLabelStringAlwaysShowsBrowserType browser selectSystemCategory: browser class category. self assert: (browser labelString includesSubstring: 'System Browser'). browser selectClass: browser class. self assert: (browser labelString includesSubstring: 'System Browser'). browser selectSystemCategory: DependencyBrowser category. browser selectClass: DependencyBrowser. self assert: (browser labelString includesSubstring: 'System Browser').! ! !BrowserTest methodsFor: 'as yet unclassified' stamp: 'ul 8/14/2015 18:00' prior: 57767886! testLabelStringShowsBrowsedClassName browser selectSystemCategory: DependencyBrowser category. browser selectClass: DependencyBrowser. self assert: (browser labelString includesSubstring: DependencyBrowser name).! ! !BrowserTest methodsFor: 'as yet unclassified' stamp: 'ul 8/14/2015 22:06' prior: 57778960! testSelectClassNamedPreservesPlace | commonCategory commonSelector otherClass | browser selectSystemCategory: browser class category. otherClass := HierarchyBrowser. "Unlikely to move out of Browser's package!!" browser selectClassNamed: browser class name. commonCategory := (browser class organization categories intersection: otherClass organization categories) detect: [ :each | each == #'class list' ]. commonSelector := #classList. browser selectMessageCategoryNamed: commonCategory. browser selectMessageNamed: commonSelector. browser selectClass: otherClass. self assert: browser selectedClassName = otherClass name. self assert: browser selectedMessageCategoryName = commonCategory. self assert: browser selectedMessageName = commonSelector.! ! "ToolsTests"! !UpdateStreamDownloader class methodsFor: 'fetching updates' stamp: 'ul 8/14/2015 18:05' prior: 21144378! retrieveUrls: urls ontoQueue: queue withWaitSema: waitSema "download the given list of URLs. The queue will be loaded alternately with url's and with the retrieved contents. If a download fails, the contents will be #failed. If all goes well, a special pair with an empty URL and the contents #finished will be put on the queue. waitSema is waited on every time before a new document is downloaded; this keeps the downloader from getting too far ahead of the main process" "kill the existing downloader if there is one" | updateCounter | UpdateDownloader ifNotNil: [UpdateDownloader terminate]. updateCounter := 0. "fork a new downloading process" UpdateDownloader := [ 'Downloading updates' displayProgressFrom: 0 to: urls size during: [:bar | urls do: [:url | | front canPeek doc | waitSema wait. queue nextPut: url. doc := HTTPClient httpGet: url. doc isString ifTrue: [queue nextPut: #failed. UpdateDownloader := nil. Processor activeProcess terminate] ifFalse: [canPeek := 120 min: doc size. front := doc next: canPeek. doc skip: -1 * canPeek. (front beginsWith: '_segs. If your image is called "Squeak2.6.image", the folder "Squeak2.6_segs" must accompany the image whenever your move, copy, or rename it. Whenever a Class is in arrayOfRoots, its class (aClass class) must also be in the arrayOfRoots. There are two kinds of image segments. Normal image segments are a piece of a specific Squeak image, and can only be read back into that image. The image holds the array of outPointers that are necessary to turn the bits in the file into objects. To put out a normal segment that holds a Project (not the current project), execute (Project named: 'xxx') storeSegment. arrayOfRoots The objects that head the tree we will trace. segment The WordArray of raw bits of all objects in the tree. outPointers Oops of all objects outside the segment pointed to from inside. state (see below) segmentName Its basic name. Often the name of a Project. fileName The local name of the file. 'Foo-23.seg' userRootCnt number of roots submitted by caller. Extras are added in preparation for saving. state that an ImageSegment may exist in... #activeCopy (has been copied, with the intent to become active) arrayOfRoots, segment, and outPointers have been created by copyFromRoots:. The tree of objects has been encoded in the segment, but those objects are still present in the Squeak system. #active (segment is actively holding objects) The segment is now the only holder of tree of objects. Each of the original roots has been transmuted into an ImageSegmentRootStub that refers back to this image segment. The original objects in the segment will all be garbageCollected. #onFile The segment has been written out to a file and replaced by a file pointer. Only ImageSegmentRootStubs and the array of outPointers remains in the image. To get this far: (ImageSegment new copyFromRoots: (Array with: Baz with: Baz class)) writeToFile: 'myFile.seg'. #inactive The segment has been brought back into memory and turned back into objects. rootsArray is set, but the segment is invalid. #onFileWithSymbols The segment has been written out to a file, along with the text of all the symbols in the outPointers array, and replaced by a file pointer. This reduces the size of the outPointers array, and also allows the system to reclaim any symbols that are not referred to from elsewhere in the image. The specific format used is that of a literal array as follows: #(symbol1 symbol2 # symbol3 symbol4 'symbolWithSpaces' # symbol5). In this case, the original outPointers array was 8 long, but the compacted table of outPointers retains only two entries. These get inserted in place of the #'s in the array of symbols after it is read back in. Symbols with embedded spaces or other strange characters are written as strings, and converted back to symbols when read back in. The symbol # is never written out. NOTE: All IdentitySets or dictionaries must be rehashed when being read back from this format. The symbols are effectively internal. (No, not if read back into same image. If a different image, then use #imported. -tk) #imported The segment is on an external file or just read in from one. The segment and outPointers are meant to be read into a foreign image. In this form, the image segment can be read from a URL, and installed. A copy of the original array of root objects is constructed, with former outPointers bound to existing objects in the host system. (Any Class inside the segment MUST be in the arrayOfRoots. This is so its association can be inserted into Smalltalk. The class's metaclass must be in roots also. Methods that are in outPointers because blocks point at them, were found and added to the roots. All IdentitySets and dictionaries are rehashed when being read back from exported segments.) To discover why only some of the objects in a project are being written out, try this (***Destructive Test***). This breaks lots of backpointers in the target project, and puts up an array of suspicious objects, a list of the classes of the outPointers, and a debugger. "Close any transcripts in the target project" World currentHand objectToPaste ifNotNil: [ self inform: 'Hand is holding a Morph in its paste buffer:\' withCRs, World currentHand objectToPaste printString]. PV := Project named: 'xxxx'. (IS := ImageSegment new) findRogueRootsImSeg: (Array with: PV world presenter with: PV world). IS findOwnersOutPtrs. "Optionally: write a file with owner chains" "Quit and DO NOT save" When an export image segment is brought into an image, it is like an image starting up. Certain startUp messages need to be run. These are byte and word reversals for nonPointer data that comes from a machine of the opposite endianness. #startUpProc passes over all objects in the segment, and: The first time an instance of class X is encountered, (msg _ X startUpFrom: anImageSegment) is sent. If msg is nil, the usual case, it means that instances of X do not need special work. X is included in the IdentitySet, noStartUpNeeded. If msg is not nil, store it in the dictionary, startUps (aClass -> aMessage). When a later instance of X is encountered, if X is in noStartUpNeeded, do nothing. If X is in startUps, send the message to the instance. Typically this is a message like #swapShortObjects. Every class that implements #startUp, should see if it needs a parallel implementation of #startUpFrom:. ! !ImageSegment methodsFor: 'access' stamp: 'eem 8/21/2015 19:09' prior: 25688236! allObjectsDo: aBlock "Enumerate all objects that came from this segment. NOTE this assumes that the segment was created (and extracted). After the segment has been installed (install), this method allows you to enumerate its objects." self checkAndReportLoadError. segment do: aBlock! ! !ImageSegment methodsFor: 'error checking' stamp: 'eem 8/21/2015 19:08'! checkAndReportLoadError "Check that the load has occurred. A side-efect of the load primitive is to become the segment into an Array of the loaded objects, so they can be enumerated. If this hasn't happened also check if the segment is a zero-length word array which indicates we're running on an older Spur VM that doesn't do the become." segment isArray ifTrue: [^self]. "ok" (segment class == WordArrayForSegment and: [segment size = 0]) ifTrue: [^self error: 'The load primitive has not becomed segment into an Array of the loaded objects. \Please upgrade your virtual machine to one that does this.' withCRs]. ^self error: 'Segment has not been becommed into the loaded objects'! ! !ImageSegment methodsFor: 'fileIn/Out' stamp: 'eem 8/21/2015 19:09' prior: 25727587! comeFullyUpOnReload: smartRefStream "fix up the objects in the segment that changed size. An object in the segment is the wrong size for the modern version of the class. Construct a fake class that is the old size. Replace the modern class with the old one in outPointers. Load the segment. Traverse the instances, making new instances by copying fields, and running conversion messages. Keep the new instances. Bulk forward become the old to the new. Let go of the fake objects and classes. After the install (below), arrayOfRoots is filled in. Globalize new classes. Caller may want to do some special install on certain objects in arrayOfRoots. May want to write the segment out to disk in its new form." | mapFakeClassesToReal receiverClasses rootsToUnhiberhate myProject forgetDoItsClasses | forgetDoItsClasses := Set new. RecentlyRenamedClasses := nil. "in case old data hanging around" mapFakeClassesToReal := smartRefStream reshapedClassesIn: outPointers. "Dictionary of just the ones that change shape. Substitute them in outPointers." self fixCapitalizationOfSymbols. arrayOfRoots := self loadSegmentFrom: segment outPointers: outPointers. self checkAndReportLoadError. "Can't use install. Not ready for rehashSets" mapFakeClassesToReal isEmpty ifFalse: [ self reshapeClasses: mapFakeClassesToReal refStream: smartRefStream ]. "When a Project is stored, arrayOfRoots has all objects in the project, except those in outPointers" arrayOfRoots do: [:importedObject | | existing | ((importedObject isMemberOf: WideString) or: [importedObject isMemberOf: WideSymbol]) ifTrue: [ importedObject mutateJISX0208StringToUnicode. importedObject class = WideSymbol ifTrue: [ "self halt." Symbol hasInterned: importedObject asString ifTrue: [:multiSymbol | multiSymbol == importedObject ifFalse: [ importedObject becomeForward: multiSymbol. ]. ]. ]. ]. (importedObject isKindOf: TTCFontSet) ifTrue: [ existing := TTCFontSet familyName: importedObject familyName pointSize: importedObject pointSize. "supplies default" existing == importedObject ifFalse: [importedObject becomeForward: existing]. ]. ]. "Smalltalk garbageCollect. MultiSymbol rehash. These take time and are not urgent, so don't to them. In the normal case, no bad MultiSymbols will be found." receiverClasses := self restoreEndianness. "rehash sets" smartRefStream checkFatalReshape: receiverClasses. "Classes in this segment." arrayOfRoots do: [:importedObject | importedObject class class == Metaclass ifTrue: [ forgetDoItsClasses add: importedObject. self declare: importedObject]]. arrayOfRoots do: [:importedObject | importedObject isCompiledMethod ifTrue: [ importedObject sourcePointer > 0 ifTrue: [importedObject zapSourcePointer]]. (importedObject isKindOf: Project) ifTrue: [ myProject := importedObject. importedObject ensureChangeSetNameUnique. Project addingProject: importedObject. importedObject restoreReferences. self dependentsRestore: importedObject]]. rootsToUnhiberhate := arrayOfRoots select: [:importedObject | importedObject respondsTo: #unhibernate "ScriptEditors and ViewerFlapTabs" ]. myProject ifNotNil: [ myProject world setProperty: #thingsToUnhibernate toValue: rootsToUnhiberhate asArray. ]. mapFakeClassesToReal isEmpty ifFalse: [ mapFakeClassesToReal keysAndValuesDo: [:aFake :aReal | aFake removeFromSystemUnlogged. "do not assign the fake's hash to the real class" aFake becomeForward: aReal copyHash: false]. SystemOrganization removeEmptyCategories]. forgetDoItsClasses do: [:c | c forgetDoIts]. "^ self" ! ! !ImageSegment methodsFor: 'read/write segment' stamp: 'eem 8/21/2015 18:33' prior: 25802854! copyFromRoots: aRootArray sizeHint: segSizeHint areUnique: areUnique "Copy a tree of objects into a WordArray segment. The copied objects in the segment are not in the normal Squeak space. [1] For exporting a project. Objects were enumerated by ReferenceStream and aRootArray has them all. [2] For exporting some classes. See copyFromRootsForExport:. (Caller must hold Symbols, or they will not get registered in the target system.) [3] For 'local segments'. outPointers are kept in the image. If this method yields a very small segment, it is because objects just below the roots are pointed at from the outside. (See findRogueRootsImSeg: for a *destructive* diagnostic of who is pointing in.)" | segmentWordArray outPointerArray segSize rootSet uniqueRoots | aRootArray ifNil: [self errorWrongState]. uniqueRoots := areUnique ifTrue: [aRootArray] ifFalse: [rootSet := IdentitySet new: aRootArray size * 3. uniqueRoots := OrderedCollection new. 1 to: aRootArray size do: [:ii | "Don't include any roots twice" (rootSet includes: (aRootArray at: ii)) ifFalse: [ uniqueRoots addLast: (aRootArray at: ii). rootSet add: (aRootArray at: ii)] ifTrue: [userRootCnt ifNotNil: ["adjust the count" ii <= userRootCnt ifTrue: [userRootCnt := userRootCnt - 1]]]]. uniqueRoots]. arrayOfRoots := uniqueRoots asArray. rootSet := uniqueRoots := nil. "be clean" userRootCnt ifNil: [userRootCnt := arrayOfRoots size]. outPointers := nil. "may have used this instance before" segSize := segSizeHint > 0 ifTrue: [segSizeHint *3 //2] ifFalse: [50000]. ["Guess a reasonable segment size" segmentWordArray := WordArrayForSegment new: segSize. outPointerArray := [Array new: segSize // 20] ifError: [ state := #tooBig. ^ self]. "Smalltalk garbageCollect." (self storeSegmentFor: arrayOfRoots into: segmentWordArray outPointers: outPointerArray) == nil] whileTrue: ["Double the segment size and try again" segmentWordArray := outPointerArray := nil. segSize := segSize * 2]. segment := segmentWordArray. outPointers := outPointerArray. state := #activeCopy ! ! !ImageSegment methodsFor: 'read/write segment' stamp: 'eem 8/21/2015 19:10' prior: 25841263! install "This operation retrieves the segment if necessary from file storage, installs it in memory, and replaces (using become:) all the root stubs with the reconstructed roots of the segment." | newRoots | state = #onFile ifTrue: [self readFromFile]. state = #onFileWithSymbols ifTrue: [self readFromFileWithSymbols]. (state = #active) | (state = #imported) ifFalse: [self errorWrongState]. newRoots := self loadSegmentFrom: segment outPointers: outPointers. self checkAndReportLoadError. state = #imported ifTrue: ["just came in from exported file" arrayOfRoots := newRoots] ifFalse: [ arrayOfRoots elementsForwardIdentityTo: newRoots]. state := #inactive. Beeper beepPrimitive! ! !ImageSegment methodsFor: 'primitives' stamp: 'eem 8/21/2015 18:56' prior: 25793817! loadSegmentFrom: segmentWordArray outPointers: outPointerArray "This primitive will install a binary image segment and return as its value the array of roots of the tree of objects represented. Upon successful completion, the wordArray will have been becomed into anArray of the loaded objects. If this primitive should fail, it will have destroyed the contents of the segment wordArray." "successful completion returns the array of roots" ^nil "failure returns nil"! ! !ImageSegment methodsFor: 'read/write segment' stamp: 'eem 8/21/2015 18:35' prior: 25845723! readFromFile "Read in a simple segment. Use folder of this image, even if remembered as previous location of this image" | ff realName | realName := self class folder, FileDirectory slash, self localName. ff := FileStream readOnlyFileNamed: realName. segment := ff nextWordsInto: (WordArrayForSegment new: ff size//4). ff close. state := #active! ! !ImageSegment methodsFor: 'fileIn/Out' stamp: 'eem 8/21/2015 18:46' prior: 25760095! rehashSets "I have just been brought in and converted to live objects. Find all Sets and Dictionaries in the newly created objects and rehash them. Segment is near then end of memory, since is was newly brought in (and a new object created for it). Also, collect all classes of receivers of blocks. Return them. Caller will check if they have been reshaped." | hashedCollections receiverClasses | hashedCollections := OrderedCollection new. "have to collect them, because Dictionary makes a copy, and that winds up at the end of memory and gets rehashed and makes another one." receiverClasses := IdentitySet new. self allObjectsDo: [:object| object isInMemory ifTrue: [(object isCollection and: [object isKindOf: HashedCollection]) ifTrue: [hashedCollections add: object]. (object isBlock or: [object isContext]) ifTrue: [receiverClasses add: object receiver class]]]. hashedCollections do: [ :each | each compact ]. "our purpose" ^receiverClasses "our secondary job"! ! !ImageSegment methodsFor: 'fileIn/Out' stamp: 'eem 8/21/2015 11:31' prior: 25764158! reshapeClasses: mapFakeClassesToReal refStream: smartRefStream | bads allVarMaps partials in out perfect | self flag: #bobconv. partials := OrderedCollection new. bads := OrderedCollection new. allVarMaps := IdentityDictionary new. mapFakeClassesToReal keysAndValuesDo: [ :aFakeClass :theRealClass | aFakeClass allInstances do: [ :misShapen | perfect := smartRefStream convert1: misShapen to: theRealClass allVarMaps: allVarMaps. bads detect: [ :x | x == misShapen] ifNone: [ bads add: misShapen. partials add: perfect ]. ]. ]. bads isEmpty ifFalse: [ bads asArray elementsForwardIdentityTo: partials asArray ]. in := OrderedCollection new. out := OrderedCollection new. partials do: [ :each | perfect := smartRefStream convert2: each allVarMaps: allVarMaps. in detect: [ :x | x == each] ifNone: [ in add: each. out add: perfect ] ]. in isEmpty ifFalse: [ in asArray elementsForwardIdentityTo: out asArray ]. ! ! !ImageSegment methodsFor: 'fileIn/Out' stamp: 'eem 8/21/2015 18:46' prior: 25773715! restoreEndianness "Fix endianness (byte order) of any objects not already fixed. Do this by discovering classes that need a startUp message sent to each instance, and sending it. I have just been brought in and converted to live objects. Find all Sets and Dictionaries in the newly created objects and rehash them. Segment is near then end of memory, since is was newly brought in (and a new object created for it). Also, collect all classes of receivers of blocks which refer to instance variables. Return them. Caller will check if they have been reshaped." | hashedCollections receiverClasses noStartUpNeeded startUps | hashedCollections := OrderedCollection new. receiverClasses := IdentitySet new. noStartUpNeeded := IdentitySet new. "classes that don't have a per-instance startUp message" startUps := IdentityDictionary new. "class -> MessageSend of a startUp message" self allObjectsDo: [:object| | cls msg | object isInMemory ifTrue: [(object isCollection and: [object isKindOf: HashedCollection]) ifTrue: [hashedCollections add: object]. (object isContext and: [object hasInstVarRef]) ifTrue: [receiverClasses add: object receiver class]]. (noStartUpNeeded includes: object class) ifFalse: [cls := object class. (msg := startUps at: cls ifAbsent: nil) ifNil: [msg := cls startUpFrom: self. "a Message, if we need to swap bytes this time" msg ifNil: [noStartUpNeeded add: cls] ifNotNil: [startUps at: cls put: msg]]. msg ifNotNil: [msg sentTo: object]]]. hashedCollections do: [ :each | each compact ]. "our purpose" ^ receiverClasses "our secondary job"! ! !ImageSegment methodsFor: 'read/write segment' stamp: 'eem 8/21/2015 18:47' prior: 25849042! revert "Pretend this segment was never brought in. Check that it has a fileName. Replace (using become:) all the original roots of a segment with segmentRootStubs. Thus the original objects will be reclaimed, and the root stubs will remain to bring the segment back in if it is needed. How to use revert: In the project, choose 'save for reverting'. ReEnter the project. Make changes. Either exit normally, and change will be kept, or Choose 'Revert to saved version'." fileName ifNil: [^ self]. (state = #inactive) | (state = #onFile) ifFalse: [^ self]. Cursor write showWhile: [ arrayOfRoots elementsForwardIdentityTo: (arrayOfRoots collect: [:r | r rootStubInImageSegment: self]). state := #onFile. segment := nil] "Old version: How to use revert: In the project, execute (Project current projectParameters at: #frozen put: true) Leave the project. Check that the project went out to disk (it is gray in the Jump to Project list). ReEnter the project. Hear a plink as it comes in from disk. Make a change. Exit the project. Choose 'Revert to previous version' in the dialog box. Check that the project went out to disk (it is gray in the Jump to Project list). ReEnter the project and see that it is in the original state."! ! !ImageSegment methodsFor: 'testing' stamp: 'eem 8/21/2015 11:28' prior: 25955982! verify: ob1 matches: ob2 knowing: matchDict | priorMatch first | ob1 == ob2 ifTrue: ["If two pointers are same, they must be immediates or in outPointers" (ob1 class isImmediateClass and: [ob1 = ob2]) ifTrue: [^self]. (outPointers includes: ob1) ifTrue: [^ self]. self halt]. priorMatch := matchDict at: ob1 ifAbsent: [nil]. priorMatch == nil ifTrue: [matchDict at: ob1 put: ob2] ifFalse: [priorMatch == ob2 ifTrue: [^ self] ifFalse: [self halt]]. self verify: ob1 class matches: ob2 class knowing: matchDict. ob1 class isVariable ifTrue: [ob1 basicSize = ob2 basicSize ifFalse: [self halt]. first := 1. ob1 isCompiledMethod ifTrue: [first := ob1 initialPC]. first to: ob1 basicSize do: [:i | self verify: (ob1 basicAt: i) matches: (ob2 basicAt: i) knowing: matchDict]]. ob1 class instSize = ob2 class instSize ifFalse: [self halt]. 1 to: ob1 class instSize do: [:i | self verify: (ob1 instVarAt: i) matches: (ob2 instVarAt: i) knowing: matchDict]. ob1 isCompiledMethod ifTrue: [ob1 header = ob2 header ifFalse: [self halt]. ob1 numLiterals = ob2 numLiterals ifFalse: [self halt]. 1 to: ob1 numLiterals do: [:i | self verify: (ob1 literalAt: i) matches: (ob2 literalAt: i) knowing: matchDict]]! ! !ImageSegment methodsFor: 'read/write segment' stamp: 'eem 8/21/2015 18:47' prior: 25871320! writeForExport: shortName "Write the segment on the disk with all info needed to reconstruct it in a new image. For export. Out pointers are encoded as normal objects on the disk." | fileStream | state = #activeCopy ifFalse: [self error: 'wrong state']. fileStream := FileStream newFileNamed: (FileDirectory fileName: shortName extension: self class fileExtension). fileStream fileOutClass: nil andObject: self. "remember extra structures. Note class names."! ! !ImageSegment methodsFor: 'read/write segment' stamp: 'eem 8/21/2015 18:50' prior: 25881019! writeForExportWithSources: fName inDirectory: aDirectory "Write the segment on the disk with all info needed to reconstruct it in a new image. For export. Out pointers are encoded as normal objects on the disk. Append the source code of any classes in roots. Target system will quickly transfer the sources to its changes file." "this is the old version which I restored until I solve the gzip problem" | fileStream tempFileName zipper allClassesInRoots classesToWriteEntirely methodsWithSource | state = #activeCopy ifFalse: [self error: 'wrong state']. (fName includes: $.) ifFalse: [ ^ self inform: 'Please use ''.pr'' or ''.extSeg'' at the end of the file name'.]. tempFileName := aDirectory nextNameFor: 'SqProject' extension: 'temp'. zipper := [ ProgressNotification signal: '3:uncompressedSaveComplete'. (aDirectory oldFileNamed: tempFileName) compressFile. "makes xxx.gz" aDirectory rename: (tempFileName, FileDirectory dot, 'gz') toBe: fName. aDirectory deleteFileNamed: tempFileName ifAbsent: [] ]. fileStream := aDirectory newFileNamed: tempFileName. fileStream fileOutClass: nil andObject: self. "remember extra structures. Note class names." "append sources" allClassesInRoots := arrayOfRoots select: [:cls | cls isBehavior]. classesToWriteEntirely := allClassesInRoots select: [ :cls | cls theNonMetaClass isSystemDefined]. methodsWithSource := OrderedCollection new. allClassesInRoots do: [ :cls | (classesToWriteEntirely includes: cls) ifFalse: [ cls selectorsAndMethodsDo: [ :sel :meth | meth sourcePointer = 0 ifFalse: [methodsWithSource add: {cls. sel. meth}]. ]. ]. ]. (classesToWriteEntirely isEmpty and: [methodsWithSource isEmpty]) ifTrue: [zipper value. ^ self]. fileStream reopen; setToEnd. fileStream nextPutAll: '\\!!ImageSegment new!!\\' withCRs. methodsWithSource do: [ :each | fileStream nextPut: $!!. "try to pacify ImageSegment>>scanFrom:" fileStream nextChunkPut: 'RenamedClassSourceReader formerClassName: ', each first name printString,' methodsFor: ', (each first organization categoryOfElement: each second) asString printString, ' stamp: ',(each third timeStamp) printString; cr. fileStream nextChunkPut: (each third getSourceFor: each second in: each first) asString. fileStream nextChunkPut: ' '; cr. ]. classesToWriteEntirely do: [:cls | cls isMeta ifFalse: [fileStream nextPutAll: (cls name, ' category: ''', cls category, '''.!!'); cr; cr]. cls organization putCommentOnFile: fileStream numbered: 0 moveSource: false forClass: cls. "does nothing if metaclass" cls organization categories do: [:heading | cls fileOutCategory: heading on: fileStream moveSource: false toFile: 0]]. "no class initialization -- it came in as a real object" fileStream close. zipper value! ! !ImageSegment methodsFor: 'read/write segment' stamp: 'eem 8/21/2015 18:52' prior: 25894024! writeForExportWithSources: fName inDirectory: aDirectory changeSet: aChangeSetOrNil "Write the segment on the disk with all info needed to reconstruct it in a new image. For export. Out pointers are encoded as normal objects on the disk. Append the source code of any classes in roots. Target system will quickly transfer the sources to its changes file." "Files out a changeSet first, so that a project can contain classes that are unique to the project." | fileStream tempFileName zipper allClassesInRoots classesToWriteEntirely methodsWithSource | state = #activeCopy ifFalse: [self error: 'wrong state']. (fName includes: $.) ifFalse: [ ^ self inform: 'Please use ''.pr'' or ''.extSeg'' at the end of the file name']. tempFileName := aDirectory nextNameFor: 'SqProject' extension: 'temp'. zipper := [ Preferences debugPrintSpaceLog ifTrue:[ fileStream := aDirectory newFileNamed: (fName copyFrom: 1 to: (fName lastIndexOf: $.)), 'space'. self printSpaceAnalysisOn: fileStream. fileStream close]. ProgressNotification signal: '3:uncompressedSaveComplete'. (aDirectory oldFileNamed: tempFileName) compressFile. "makes xxx.gz" aDirectory rename: (tempFileName, FileDirectory dot, 'gz') toBe: fName. aDirectory deleteFileNamed: tempFileName ifAbsent: [] ]. fileStream := aDirectory newFileNamed: tempFileName. fileStream fileOutChangeSet: aChangeSetOrNil andObject: self. "remember extra structures. Note class names." "append sources" allClassesInRoots := arrayOfRoots select: [:cls | cls isBehavior]. classesToWriteEntirely := allClassesInRoots select: [ :cls | cls theNonMetaClass isSystemDefined]. methodsWithSource := OrderedCollection new. allClassesInRoots do: [ :cls | (classesToWriteEntirely includes: cls) ifFalse: [ cls selectorsAndMethodsDo: [ :sel :meth | meth sourcePointer = 0 ifFalse: [methodsWithSource add: {cls. sel. meth}]. ]. ]. ]. (classesToWriteEntirely isEmpty and: [methodsWithSource isEmpty]) ifTrue: [zipper value. ^ self]. fileStream reopen; setToEnd. fileStream nextPutAll: '\\!!ImageSegment new!!\\' withCRs. methodsWithSource do: [ :each | fileStream nextPut: $!!. "try to pacify ImageSegment>>scanFrom:" fileStream nextChunkPut: 'RenamedClassSourceReader formerClassName: ', each first name printString,' methodsFor: ', (each first organization categoryOfElement: each second) asString printString, ' stamp: ',(each third timeStamp) printString; cr. fileStream nextChunkPut: (each third getSourceFor: each second in: each first) asString. fileStream nextChunkPut: ' '; cr. ]. classesToWriteEntirely do: [:cls | cls isMeta ifFalse: [fileStream nextPutAll: (cls name, ' category: ''', cls category, '''.!!'); cr; cr]. cls organization putCommentOnFile: fileStream numbered: 0 moveSource: false forClass: cls. "does nothing if metaclass" cls organization categories do: [:heading | cls fileOutCategory: heading on: fileStream moveSource: false toFile: 0]]. "no class initialization -- it came in as a real object" fileStream close. zipper value ! ! !ImageSegment methodsFor: 'read/write segment' stamp: 'eem 8/21/2015 18:52' prior: 25905962! writeForExportWithSourcesGZ: fName inDirectory: aDirectory "Write the segment on the disk with all info needed to reconstruct it in a new image. For export. Out pointers are encoded as normal objects on the disk. Append the source code of any classes in roots. Target system will quickly transfer the sources to its changes file." "this is the gzipped version which I have temporarily suspended until I can get resolve the problem with forward references tring to reposition the stream - RAA 11 june 2000" | fileStream allClassesInRoots classesToWriteEntirely methodsWithSource | state = #activeCopy ifFalse: [self error: 'wrong state']. (fName includes: $.) ifFalse: [ ^ self inform: 'Please use ''.pr'' or ''.extSeg'' at the end of the file name'.]. fileStream := GZipSurrogateStream newFileNamed: fName inDirectory: aDirectory. fileStream fileOutClass: nil andObject: self. "remember extra structures. Note class names." "append sources" allClassesInRoots := arrayOfRoots select: [:cls | cls isBehavior]. classesToWriteEntirely := allClassesInRoots select: [ :cls | cls theNonMetaClass isSystemDefined]. methodsWithSource := OrderedCollection new. allClassesInRoots do: [ :cls | (classesToWriteEntirely includes: cls) ifFalse: [ cls selectorsAndMethodsDo: [ :sel :meth | meth sourcePointer = 0 ifFalse: [methodsWithSource add: {cls. sel. meth}]. ]. ]. ]. (classesToWriteEntirely isEmpty and: [methodsWithSource isEmpty]) ifTrue: [ fileStream reallyClose. "since #close is ignored" ^ self ]. "fileStream reopen; setToEnd." "<--not required with gzipped surrogate stream" fileStream nextPutAll: '\\!!ImageSegment new!!\\' withCRs. methodsWithSource do: [ :each | fileStream nextPut: $!!. "try to pacify ImageSegment>>scanFrom:" fileStream nextChunkPut: 'RenamedClassSourceReader formerClassName: ', each first name printString,' methodsFor: ', (each first organization categoryOfElement: each second) asString printString, ' stamp: ',(each third timeStamp) printString; cr. fileStream nextChunkPut: (each third getSourceFor: each second in: each first) asString. fileStream nextChunkPut: ' '; cr. ]. classesToWriteEntirely do: [:cls | cls isMeta ifFalse: [fileStream nextPutAll: (cls name, ' category: ''', cls category, '''.!!'); cr; cr]. cls organization putCommentOnFile: fileStream numbered: 0 moveSource: false forClass: cls. "does nothing if metaclass" cls organization categories do: [:heading | cls fileOutCategory: heading on: fileStream moveSource: false toFile: 0]]. "no class initialization -- it came in as a real object" fileStream reallyClose "since #close is ignored" ! ! !ImageSegment methodsFor: 'read/write segment' stamp: 'eem 8/21/2015 18:53' prior: 25909965! writeToFile state = #active ifFalse: [self error: 'wrong state'. ^ self]. Cursor write showWhile: [ segmentName ifNil: [ segmentName := (FileDirectory localNameFor: fileName) sansPeriodSuffix]. "OK that still has number on end. This is an unusual case" fileName := self class uniqueFileNameFor: segmentName. "local name" (self class segmentDirectory newFileNamed: fileName) nextPutAll: segment; close. segment := nil. state := #onFile].! ! ImageSegment removeSelector: #remapCompactClasses:refStrm:! ImageSegment removeSelector: #cc:new:current:fake:refStrm:! "System"! !WideCharacterSet methodsFor: 'collection ops' stamp: 'ul 8/22/2015 12:32' prior: 33742387! add: aCharacter | value highBits lowBits | (value := aCharacter asInteger) < 256 ifTrue: [ byteArrayMap at: value + 1 put: 1 ]. highBits := value bitShift: highBitsShift. lowBits := value bitAnd: lowBitsMask. (map at: highBits ifAbsentPut: [ Bitset new: bitsetCapacity ]) setBitAt: lowBits. ^aCharacter! ! !WideCharacterSet methodsFor: 'collection ops' stamp: 'ul 8/22/2015 12:33' prior: 33743920! do: aBlock map keysAndValuesDo: [ :index :bitset | | highBits | highBits := index * bitsetCapacity. bitset do: [ :lowBits | aBlock value: (Character value: highBits + lowBits) ] ]! ! !WideCharacterSet methodsFor: 'collection ops' stamp: 'ul 8/22/2015 12:47' prior: 33745077! includes: aCharacter | value | (value := aCharacter asInteger) < 256 ifTrue: [ ^(byteArrayMap at: value + 1) ~= 0 ]. ^((map at: (value bitShift: highBitsShift) ifAbsent: nil) ifNil: [ ^false ]) includes: (value bitAnd: lowBitsMask)! ! !WideCharacterSet methodsFor: 'collection ops' stamp: 'ul 8/22/2015 12:46' prior: 33746749! remove: aCharacter ifAbsent: aBlock | value highBits lowBits bitset | (value := aCharacter asInteger) < 256 ifTrue: [ (byteArrayMap at: value + 1) = 0 ifTrue: [ ^aBlock value ]. byteArrayMap at: value + 1 put: 0 ]. highBits := value bitShift: highBitsShift. lowBits := value bitAnd: lowBitsMask. bitset := (map at: highBits ifAbsent: nil) ifNil: [ ^aBlock value ]. ((bitset clearBitAt: lowBits) and: [ bitset size = 0 ]) ifTrue: [ map removeKey: highBits ]. ^aCharacter! ! WideCharacterSet removeSelector: #migrate! WideCharacterSet removeSelector: #bitmap:do:! "Collections"! LargeNegativeIntegerTest removeSelector: #testCompactClassIndex! LargePositiveIntegerTest removeSelector: #testCompactClassIndex! "KernelTests"! !MethodFinder methodsFor: 'initialize' stamp: 'eem 8/21/2015 11:25' prior: 63270811! initialize "The methods we are allowed to use. (MethodFinder new initialize) " Approved := Set new. AddAndRemove := Set new. Blocks := Set new. "These modify an argument and are not used by the MethodFinder: longPrintOn: printOn: storeOn: sentTo: storeOn:base: printOn:base: absPrintExactlyOn:base: absPrintOn:base: absPrintOn:base:digitCount: writeOn: writeScanOn: possibleVariablesFor:continuedFrom: printOn:format:" "Object" #("in class, instance creation" categoryForUniclasses chooseUniqueClassName initialInstance isSystemDefined newFrom: officialClass readCarefullyFrom: "accessing" at: basicAt: basicSize bindWithTemp: in: size yourself "testing" basicType ifNil: ifNil:ifNotNil: ifNotNil: ifNotNil:ifNil: isColor isFloat isFraction isInMemory isInteger isMorph isNil isNumber isPoint isPseudoContext isText isTransparent isWebBrowser knownName notNil pointsTo: wantsSteps "comparing" = == closeTo: hash identityHash identityHashPrintString ~= ~~ "copying" clone copy shallowCopy "dependents access" canDiscardEdits dependents hasUnacceptedEdits "updating" changed changed: okToChange update: windowIsClosing "printing" fullPrintString isLiteral longPrintString printString storeString stringForReadout stringRepresentation "class membership" class isKindOf: isKindOf:orOf: isMemberOf: respondsTo: xxxClass "error handling" "user interface" addModelMenuItemsTo:forMorph:hand: defaultBackgroundColor defaultLabelForInspector fullScreenSize initialExtent modelWakeUp mouseUpBalk: newTileMorphRepresentative windowActiveOnFirstClick windowReqNewLabel: "system primitives" asOop instVarAt: instVarNamed: "private" "associating" -> "converting" as: asOrderedCollection asString "casing" caseOf: caseOf:otherwise: "binding" bindingOf: "macpal" contentsChanged currentEvent currentHand currentWorld flash instanceVariableValues scriptPerformer "flagging" flag: "translation support" "objects from disk" "finalization" ) do: [:sel | Approved add: sel]. #(at:add: at:modify: at:put: basicAt:put: "NOT instVar:at:" "message handling" perform: perform:orSendTo: perform:with: perform:with:with: perform:with:with:with: perform:withArguments: perform:withArguments:inSuperclass: ) do: [:sel | AddAndRemove add: sel]. "Boolean, True, False, UndefinedObject" #("logical operations" & eqv: not xor: | "controlling" and: ifFalse: ifFalse:ifTrue: ifTrue: ifTrue:ifFalse: or: "copying" "testing" isEmptyOrNil) do: [:sel | Approved add: sel]. "Behavior" #("initialize-release" "accessing" compilerClass decompilerClass evaluatorClass format methodDict parserClass sourceCodeTemplate subclassDefinerClass "testing" instSize instSpec isBits isBytes isFixed isPointers isVariable isWeak isWords "copying" "printing" defaultNameStemForInstances printHierarchy "creating class hierarchy" "creating method dictionary" "instance creation" basicNew basicNew: new new: "accessing class hierarchy" allSubclasses allSubclassesWithLevelDo:startingLevel: allSuperclasses subclasses superclass withAllSubclasses withAllSuperclasses "accessing method dictionary" allSelectors changeRecordsAt: compiledMethodAt: compiledMethodAt:ifAbsent: firstCommentAt: lookupSelector: selectors selectorsDo: selectorsWithArgs: "slow but useful ->" sourceCodeAt: sourceCodeAt:ifAbsent: sourceMethodAt: sourceMethodAt:ifAbsent: "accessing instances and variables" allClassVarNames allInstVarNames allSharedPools classVarNames instVarNames instanceCount sharedPools someInstance subclassInstVarNames "testing class hierarchy" inheritsFrom: kindOfSubclass "testing method dictionary" canUnderstand: classThatUnderstands: hasMethods includesSelector: whichClassIncludesSelector: whichSelectorsAccess: whichSelectorsReferTo: whichSelectorsReferTo:special:byte: whichMethodsStoreInto: "enumerating" "user interface") do: [:sel | Approved add: sel]. "ClassDescription" #("initialize-release" "accessing" classVersion isMeta name theNonMetaClass "copying" "printing" classVariablesString instanceVariablesString sharedPoolsString "instance variables" checkForInstVarsOK: "method dictionary" "organization" category organization whichCategoryIncludesSelector: "compiling" acceptsLoggingOfCompilation wantsChangeSetLogging "fileIn/Out" definition "private" ) do: [:sel | Approved add: sel]. "Class" #("initialize-release" "accessing" classPool "testing" "copying" "class name" "instance variables" "class variables" classVarAt: classVariableAssociationAt: "pool variables" "compiling" "subclass creation" "fileIn/Out" ) do: [:sel | Approved add: sel]. "Metaclass" #("initialize-release" "accessing" isSystemDefined soleInstance "copying" "instance creation" "instance variables" "pool variables" "class hierarchy" "compiling" "fileIn/Out" nonTrivial ) do: [:sel | Approved add: sel]. "Context, BlockContext" #(receiver client method receiver tempAt: "debugger access" pc selector sender shortStack sourceCode tempNames tempsAndValues "controlling" "printing" "system simulation" "initialize-release" "accessing" hasMethodReturn home numArgs "evaluating" value value:ifError: value:value: value:value:value: value:value:value:value: valueWithArguments: "controlling" "scheduling" "instruction decoding" "printing" "private" "system simulation" ) do: [:sel | Approved add: sel]. #(value: "<- Association has it as a store" ) do: [:sel | AddAndRemove add: sel]. "Message" #("inclass, instance creation" selector: selector:argument: selector:arguments: "accessing" argument argument: arguments sends: "printing" "sending" ) do: [:sel | Approved add: sel]. #("private" setSelector:arguments:) do: [:sel | AddAndRemove add: sel]. "Magnitude" #("comparing" < <= > >= between:and: "testing" max: min: min:max: ) do: [:sel | Approved add: sel]. "Date, Time" #("in class, instance creation" fromDays: fromSeconds: fromString: newDay:month:year: newDay:year: today "in class, general inquiries" dateAndTimeNow dayOfWeek: daysInMonth:forYear: daysInYear: firstWeekdayOfMonth:year: indexOfMonth: leapYear: nameOfDay: nameOfMonth: "accessing" day leap monthIndex monthName weekday year "arithmetic" addDays: subtractDate: subtractDays: "comparing" "inquiries" dayOfMonth daysInMonth daysInYear daysLeftInYear firstDayOfMonth previous: "converting" asSeconds "printing" mmddyyyy printFormat: "private" weekdayIndex "in class, instance creation" fromSeconds: now "in class, general inquiries" dateAndTimeFromSeconds: dateAndTimeNow millisecondClockValue millisecondsToRun: totalSeconds "accessing" hours minutes seconds "arithmetic" addTime: subtractTime: "comparing" "printing" intervalString print24 "converting") do: [:sel | Approved add: sel]. #("private" ) do: [:sel | AddAndRemove add: sel]. "Number" #("in class" readFrom:base: "arithmetic" * + - / // \\ abs negated quo: reciprocal rem: "mathematical functions" arcCos arcSin arcTan arcTan: cos exp floorLog: ln log log: raisedTo: raisedToInteger: sin sqrt squared tan "truncation and round off" ceiling detentBy:atMultiplesOf:snap: floor roundTo: roundUpTo: rounded truncateTo: truncated "comparing" "testing" even isDivisibleBy: isInfinite isNaN isZero negative odd positive sign strictlyPositive "converting" @ asInteger asNumber asPoint asSmallAngleDegrees degreesToRadians radiansToDegrees "intervals" to: to:by: "printing" printStringBase: storeStringBase: ) do: [:sel | Approved add: sel]. "Integer" #("in class" primesUpTo: "testing" isPowerOfTwo "arithmetic" alignedTo: "comparing" "truncation and round off" atRandom normalize "enumerating" timesRepeat: "mathematical functions" degreeCos degreeSin factorial gcd: lcm: take: "bit manipulation" << >> allMask: anyMask: bitAnd: bitClear: bitInvert bitInvert32 bitOr: bitShift: bitXor: lowBit noMask: "converting" asCharacter asColorOfDepth: asFloat asFraction asHexDigit "printing" asStringWithCommas hex hex8 radix: "system primitives" lastDigit replaceFrom:to:with:startingAt: "private" "benchmarks" ) do: [:sel | Approved add: sel]. "SmallInteger, LargeNegativeInteger, LargePositiveInteger" #("arithmetic" "bit manipulation" highBit "testing" "comparing" "copying" "converting" "printing" "system primitives" digitAt: digitLength "private" fromString:radix: ) do: [:sel | Approved add: sel]. #(digitAt:put: ) do: [:sel | AddAndRemove add: sel]. "Float" #("arithmetic" "mathematical functions" reciprocalLogBase2 timesTwoPower: "comparing" "testing" "truncation and round off" exponent fractionPart integerPart significand significandAsInteger "converting" asApproximateFraction asIEEE32BitWord asTrueFraction "copying") do: [:sel | Approved add: sel]. "Fraction, Random" #(denominator numerator reduced next nextValue) do: [:sel | Approved add: sel]. #(setNumerator:denominator:) do: [:sel | AddAndRemove add: sel]. "Collection" #("accessing" anyOne "testing" includes: includesAllOf: includesAnyOf: includesSubstringAnywhere: isEmpty isSequenceable occurrencesOf: "enumerating" collect: collect:thenSelect: count: detect: detect:ifNone: detectMax: detectMin: detectSum: inject:into: reject: select: select:thenCollect: intersection: "converting" asBag asCharacterSet asSet asSortedArray asSortedCollection asSortedCollection: "printing" "private" maxSize "arithmetic" "math functions" average max median min range sum) do: [:sel | Approved add: sel]. #("adding" add: addAll: addIfNotPresent: "removing" remove: remove:ifAbsent: removeAll: removeAllFoundIn: removeAllSuchThat: remove:ifAbsent:) do: [:sel | AddAndRemove add: sel]. "SequenceableCollection" #("comparing" hasEqualElements: "accessing" allButFirst allButLast at:ifAbsent: atAll: atPin: atRandom: atWrap: fifth first fourth identityIndexOf: identityIndexOf:ifAbsent: indexOf: indexOf:ifAbsent: indexOf:startingAt:ifAbsent: indexOfSubCollection:startingAt: indexOfSubCollection:startingAt:ifAbsent: last second sixth third "removing" "copying" , copyAfterLast: copyAt:put: copyFrom:to: copyReplaceAll:with: copyReplaceFrom:to:with: copyUpTo: copyUpToLast: copyWith: copyWithout: copyWithoutAll: forceTo:paddingWith: shuffled sortBy: "enumerating" collectWithIndex: findFirst: findLast: pairsCollect: with:collect: withIndexCollect: polynomialEval: "converting" asArray asDictionary asFloatArray asIntegerArray asStringWithCr asWordArray reversed "private" copyReplaceAll:with:asTokens: ) do: [:sel | Approved add: sel]. #( swap:with:) do: [:sel | AddAndRemove add: sel]. "ArrayedCollection, Bag" #("private" defaultElement "sorting" isSorted "accessing" cumulativeCounts sortedCounts sortedElements "testing" "adding" add:withOccurrences: "removing" "enumerating" ) do: [:sel | Approved add: sel]. #( mergeSortFrom:to:by: sort sort: add: add:withOccurrences: "private" setDictionary ) do: [:sel | AddAndRemove add: sel]. "Other messages that modify the receiver" #(atAll:put: atAll:putAll: atAllPut: atWrap:put: replaceAll:with: replaceFrom:to:with: removeFirst removeLast) do: [:sel | AddAndRemove add: sel]. self initialize2. " MethodFinder new initialize. MethodFinder new organizationFiltered: Set " ! ! !MethodFinder methodsFor: 'initialize' stamp: 'eem 8/21/2015 11:18' prior: 63330291! noteDangerous "Remember the methods with really bad side effects." Dangerous := Set new. "Object accessing, testing, copying, dependent access, macpal, flagging" #(addInstanceVarNamed:withValue: haltIfNil copyAddedStateFrom: veryDeepCopy veryDeepCopyWith: veryDeepFixupWith: veryDeepInner: addDependent: evaluate:wheneverChangeIn: codeStrippedOut: playSoundNamed: isThisEverCalled isThisEverCalled: logEntry logExecution logExit) do: [:sel | Dangerous add: sel]. "Object error handling" #(cannotInterpret: caseError confirm: confirm:orCancel: doesNotUnderstand: error: halt halt: notify: notify:at: primitiveFailed shouldNotImplement subclassResponsibility) do: [:sel | Dangerous add: sel]. "Object user interface" #(basicInspect beep inform: inspect inspectWithLabel: notYetImplemented inspectElement ) do: [:sel | Dangerous add: sel]. "Object system primitives" #(become: becomeForward: instVarAt:put: instVarNamed:put: nextInstance nextObject rootStubInImageSegment: someObject tryPrimitive:withArgs:) do: [:sel | Dangerous add: sel]. "Object private" #(errorImproperStore errorNonIntegerIndex errorNotIndexable errorSubscriptBounds: mustBeBoolean primitiveError: species storeAt:inTempFrame:) do: [:sel | Dangerous add: sel]. "Object, translation support" #(cCode: cCode:inSmalltalk: cCoerce:to: export: inline: returnTypeC: sharedCodeNamed:inCase: var:declareC:) do: [:sel | Dangerous add: sel]. "Object, objects from disk, finalization. And UndefinedObject" #(comeFullyUpOnReload: objectForDataStream: readDataFrom:size: rehash saveOnFile storeDataOn: actAsExecutor executor finalize retryWithGC:until: suspend) do: [:sel | Dangerous add: sel]. "No Restrictions: Boolean, False, True, " "Morph" #() do: [:sel | Dangerous add: sel]. "Behavior" #(obsolete confirmRemovalOf: copyOfMethodDictionary literalScannedAs:notifying: storeLiteral:on: addSubclass: removeSubclass: superclass: "creating method dictionary" addSelector:withMethod: compile: compile:notifying: compileAll compileAllFrom: compress decompile: defaultSelectorForMethod: methodDictionary: recompile:from: recompileChanges removeSelector: compressedSourceCodeAt: selectorAtMethod:setClass: allInstances allSubInstances inspectAllInstances inspectSubInstances thoroughWhichSelectorsReferTo:special:byte: "enumerating" allInstancesDo: allSubInstancesDo: allSubclassesDo: allSuperclassesDo: selectSubclasses: selectSuperclasses: subclassesDo: withAllSubclassesDo: "too slow->" crossReference removeUninstantiatedSubclassesSilently "too slow->" unreferencedInstanceVariables "private" flushCache format:variable:words:pointers: format:variable:words:pointers:weak: printSubclassesOn:level: basicRemoveSelector: addSelector:withMethod:notifying: addSelectorSilently:withMethod:) do: [:sel | Dangerous add: sel]. "CompiledMethod" #(defaultSelector) do: [:sel | Dangerous add: sel]. "Others " #("no tangible result" do: associationsDo: "private" adaptToCollection:andSend: adaptToNumber:andSend: adaptToPoint:andSend: adaptToString:andSend: instVarAt:put: asDigitsToPower:do: combinations:atATimeDo: doWithIndex: pairsDo: permutationsDo: reverseDo: reverseWith:do: with:do: withIndexDo: asDigitsAt:in:do: combinationsAt:in:after:do: errorOutOfBounds permutationsStartingAt:do: fromUser) do: [:sel | Dangerous add: sel]. #( fileOutPrototype addSpareFields makeFileOutFile ) do: [:sel | Dangerous add: sel]. #(recompile:from: recompileAllFrom: recompileChanges asPrototypeWithFields: asPrototype addInstanceVarNamed:withValue: addInstanceVariable addClassVarName: removeClassVarName: findOrAddClassVarName: instanceVariableNames: ) do: [:sel | Dangerous add: sel]. ! ! "Tools"! !ImageSegment methodsFor: '*SMBase-export' stamp: 'eem 8/21/2015 18:48' prior: 25958792! writeForExportOn: fileStream "Write the segment on the disk with all info needed to reconstruct it in a new image. For export. Out pointers are encoded as normal objects on the disk." state = #activeCopy ifFalse: [self error: 'wrong state']. fileStream fileOutClass: nil andObject: self. "remember extra structures. Note class names."! ! "SMBase"! !Behavior methodsFor: 'testing' stamp: 'eem 12/1/2014 11:46' prior: 29585991! isCompiledMethodClass "Answer whether the receiver has compiled method instances that mix pointers and bytes." ^self instSpec >= 24! ! !CompiledMethod methodsFor: 'accessing' stamp: 'eem 5/14/2015 17:30'! at: index ifAbsent: exceptionBlock "Answer the element at my position index. If I do not contain an element at index, answer the result of evaluating the argument, exceptionBlock." (index <= self size and: [self initialPC <= index]) ifTrue: [^self at: index]. ^exceptionBlock value! ! !ClassBuilder methodsFor: 'class format' stamp: 'eem 8/21/2015 11:22'! computeFormat: type instSize: newInstSize forSuper: newSuper "Compute the new format for making oldClass a subclass of newSuper. Answer the format or nil if there is any problem." | instSize isVar isWords isPointers isWeak | type == #compiledMethod ifTrue: [newInstSize > 0 ifTrue: [self error: 'A compiled method class cannot have named instance variables'. ^nil]. ^CompiledMethod format]. instSize := newInstSize + (newSuper ifNil:[0] ifNotNil:[newSuper instSize]). instSize > 65535 ifTrue: [self error: 'Class has too many instance variables (', instSize printString,')'. ^nil]. type == #normal ifTrue:[isVar := isWeak := false. isWords := isPointers := true]. type == #bytes ifTrue:[isVar := true. isWords := isPointers := isWeak := false]. type == #words ifTrue:[isVar := isWords := true. isPointers := isWeak := false]. type == #variable ifTrue:[isVar := isPointers := isWords := true. isWeak := false]. type == #weak ifTrue:[isVar := isWeak := isWords := isPointers := true]. type == #ephemeron ifTrue:[isVar := false. isWeak := isWords := isPointers := true]. type == #immediate ifTrue:[isVar := isWeak := isPointers := false. isWords := true]. (isPointers not and: [instSize > 0]) ifTrue: [self error: 'A non-pointer class cannot have named instance variables'. ^nil]. ^self format: instSize variable: isVar words: isWords pointers: isPointers weak: isWeak! ! !ClassBuilder methodsFor: 'class definition' stamp: 'eem 8/21/2015 11:24' prior: 53343266! needsSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass "Answer whether we need a new subclass to conform to the requested changes" | newFormat | "Compute the format of the new class" newFormat := self computeFormat: type instSize: instVars size forSuper: newSuper. newFormat ifNil: [^nil]. "Check if we really need a new subclass" oldClass ifNil:[^true]. "yes, it's a new class" newSuper == oldClass superclass ifFalse:[^true]. "yes, it's a superclass change" newFormat = oldClass format ifFalse:[^true]. "yes, it's a format change" instVars = oldClass instVarNames ifFalse:[^true]. "yes, it's an iVar change" ^false ! ! !ClassBuilder methodsFor: 'class definition' stamp: 'eem 8/21/2015 11:24' prior: 53345532! newSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass "Create a new subclass of the given superclass with the given specification." | newFormat newClass | "Compute the format of the new class" newFormat := self computeFormat: type instSize: instVars size forSuper: newSuper. newFormat ifNil: [^nil]. (oldClass == nil or:[oldClass isMeta not]) ifTrue:[newClass := self privateNewSubclassOf: newSuper from: oldClass] ifFalse:[newClass := oldClass clone]. newClass superclass: newSuper methodDictionary: (oldClass ifNil: [MethodDictionary new] ifNotNil: [oldClass methodDict copy]) format: newFormat; setInstVarNames: instVars. oldClass ifNotNil:[ newClass organization: oldClass organization. "Recompile the new class" oldClass hasMethods ifTrue:[newClass compileAllFrom: oldClass]. oldClass hasTraitComposition ifTrue: [ newClass setTraitComposition: oldClass traitComposition copyTraitExpression ]. oldClass class hasTraitComposition ifTrue: [ newClass class setTraitComposition: oldClass class traitComposition copyTraitExpression ]. self recordClass: oldClass replacedBy: newClass. ]. (oldClass == nil or:[oldClass isObsolete not]) ifTrue:[newSuper addSubclass: newClass] ifFalse:[newSuper addObsoleteSubclass: newClass]. ^newClass! ! !ClassBuilder methodsFor: 'private' stamp: 'eem 8/21/2015 11:24' prior: 53396956! privateNewSubclassOf: newSuper from: oldClass "Create a new meta and non-meta subclass of newSuper using oldClass as template" "WARNING: This method does not preserve the superclass/subclass invariant!!" | newSuperMeta oldMeta newMeta | oldClass ifNil:[^self privateNewSubclassOf: newSuper]. newSuperMeta := newSuper ifNil:[Class] ifNotNil:[newSuper class]. oldMeta := oldClass class. newMeta := oldMeta clone. newMeta superclass: newSuperMeta methodDictionary: oldMeta methodDict copy format: (self computeFormat: oldMeta typeOfClass instSize: oldMeta instVarNames size forSuper: newSuperMeta); setInstVarNames: oldMeta instVarNames; organization: oldMeta organization. "Recompile the meta class" oldMeta hasMethods ifTrue:[newMeta compileAllFrom: oldMeta]. "Record the meta class change" self recordClass: oldMeta replacedBy: newMeta. "And create a new instance" ^newMeta adoptInstance: oldClass from: oldMeta! ! !ClassBuilder methodsFor: 'class mutation' stamp: 'eem 8/21/2015 11:13' prior: 53359269! reshapeClass: oldClass toSuper: newSuper "Reshape the given class to the new super class. Recompile all the methods in the newly created class. Answer the new class." | instVars | instVars := instVarMap at: oldClass name ifAbsent: [oldClass instVarNames]. ^self newSubclassOf: newSuper type: oldClass typeOfClass instanceVariables: instVars from: oldClass! ! ClassBuilder removeSelector: #computeFormat:instSize:forSuper:ccIndex:! Behavior removeSelector: #isCompact! Behavior removeSelector: #indexIfCompact! Behavior removeSelector: #becomeUncompact! Behavior removeSelector: #becomeCompactSimplyAt:! Behavior removeSelector: #becomeCompact! Object removeSelector: #indexIfCompact! "Kernel"! !Character methodsFor: 'comparing' stamp: 'ul 8/22/2015 21:23' prior: 57860184! sameAs: aCharacter "Answer whether the receiver is equal to aCharacter, ignoring case" self == aCharacter ifTrue: [ ^true ]. ^self asLowercase == aCharacter asLowercase! ! "Collections"! Object subclass: #RxMatchOptimizer instanceVariableNames: 'ignoreCase prefixes nonPrefixes conditions testBlock methodPredicates nonMethodPredicates predicates nonPredicates' classVariableNames: '' poolDictionaries: '' category: 'Regex-Core'! !RxMatchOptimizer commentStamp: 'Tbn 11/12/2010 23:13' prior: 33586996! -- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov -- A match start optimizer, handy for searching a string. Takes a regex syntax tree and sets itself up so that prefix characters or matcher states that cannot start a match are later recognized with #canStartMatch:in: method. Used by RxMatcher, but can be used by other matchers (if implemented) as well.! Object subclass: #RxMatcher instanceVariableNames: 'matcher ignoreCase startOptimizer stream markerPositions markerCount lastResult oldMarkerPositions' classVariableNames: 'Cr Lf' poolDictionaries: '' category: 'Regex-Core'! !RxMatcher commentStamp: 'Tbn 11/12/2010 23:13' prior: 33587637! -- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov -- This is a recursive regex matcher. Not strikingly efficient, but simple. Also, keeps track of matched subexpressions. The life cycle goes as follows: 1. Initialization. Accepts a syntax tree (presumably produced by RxParser) and compiles it into a matcher built of other classes in this category. 2. Matching. Accepts a stream or a string and returns a boolean indicating whether the whole stream or its prefix -- depending on the message sent -- matches the regex. 3. Subexpression query. After a successful match, and before any other match, the matcher may be queried about the range of specific stream (string) positions that matched to certain parenthesized subexpressions of the original expression. Any number of queries may follow a successful match, and any number or matches may follow a successful initialization. Note that `matcher' is actually a sort of a misnomer. The actual matcher is a web of Rxm* instances built by RxMatcher during initialization. RxMatcher is just the interface facade of this network. It is also a builder of it, and also provides a stream-like protocol to easily access the stream being matched. Instance variables: matcher The entry point into the actual matcher. stream The stream currently being matched against. markerPositions Positions of markers' matches. markerCount Number of markers. lastResult Whether the latest match attempt succeeded or not. lastChar character last seen in the matcher stream! RxmLink subclass: #RxmLookahead instanceVariableNames: 'lookahead positive' classVariableNames: '' poolDictionaries: '' category: 'Regex-Core'! !RxmLookahead commentStamp: '' prior: 0! Instance holds onto a lookead which matches but does not consume anything. Instance variables: predicate ! RxmLink subclass: #RxmSubstring instanceVariableNames: 'sampleStream caseSensitive ignoreCase' classVariableNames: '' poolDictionaries: '' category: 'Regex-Core'! !RxmSubstring commentStamp: 'Tbn 11/12/2010 23:14' prior: 33594110! -- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov -- Instance holds onto a string and matches exactly this string, and exactly once. Instance variables: string ! !RxmPredicate methodsFor: 'matching' stamp: 'ul 8/22/2015 22:18' prior: 33687722! matchAgainst: aMatcher "Match if the predicate block evaluates to true when given the current stream character as the argument." | nextCharacter originalState | originalState := aMatcher currentState. nextCharacter := aMatcher next ifNil: [ aMatcher restoreState: originalState. ^false ]. (predicate value: nextCharacter) ifTrue: [ (next matchAgainst: aMatcher) ifTrue: [ ^true ] ]. aMatcher restoreState: originalState. ^false ! ! !RxsPredicate class methodsFor: 'class initialization' stamp: 'ul 8/22/2015 18:01' prior: 33705154! initializeEscapedLetterSelectors "self initializeEscapedLetterSelectors" | newEscapedLetterSelectors | newEscapedLetterSelectors := Dictionary new at: $w put: #beWordConstituent; at: $W put: #beNotWordConstituent; at: $d put: #beDigit; at: $D put: #beNotDigit; at: $s put: #beSpace; at: $S put: #beNotSpace; at: $\ put: #beBackslash; at: $r put: #beCarriageReturn; at: $n put: #beLineFeed; at: $t put: #beTab; yourself. EscapedLetterSelectors := newEscapedLetterSelectors! ! !RxsPredicate methodsFor: 'initialize-release' stamp: 'ul 8/22/2015 17:59' prior: 33706591! beBackslash self beCharacter: $\! ! !RxsPredicate methodsFor: 'initialize-release' stamp: 'ul 8/22/2015 17:59' prior: 33706753! beCarriageReturn self beCharacter: Character cr! ! !RxsPredicate methodsFor: 'initialize-release' stamp: 'ul 8/22/2015 17:59'! beCharacter: aCharacter predicate := [ :char | char == aCharacter ]. negation := [ :char | char ~~ aCharacter ]! ! !RxsPredicate methodsFor: 'initialize-release' stamp: 'ul 8/22/2015 18:00'! beLineFeed self beCharacter: Character lf! ! !RxsPredicate methodsFor: 'initialize-release' stamp: 'ul 8/22/2015 18:00'! beTab self beCharacter: Character tab! ! !RxMatchOptimizer methodsFor: 'private' stamp: 'ul 8/22/2015 17:51'! addCondition: aSymbol ^(conditions ifNil: [ conditions := IdentitySet new: 1 ]) add: aSymbol! ! !RxMatchOptimizer methodsFor: 'private' stamp: 'ul 8/22/2015 17:53'! addMethodPredicate: aSelector ^(methodPredicates ifNil: [ methodPredicates := IdentitySet new: 1 ]) add: aSelector! ! !RxMatchOptimizer methodsFor: 'private' stamp: 'ul 8/22/2015 17:53'! addNonMethodPredicate: aSelector ^(nonMethodPredicates ifNil: [ nonMethodPredicates := IdentitySet new: 1 ]) add: aSelector! ! !RxMatchOptimizer methodsFor: 'private' stamp: 'ul 8/22/2015 17:47'! addNonPredicate: nonPredicate ^(nonPredicates ifNil: [ nonPredicates := Set new: 1 ]) add: nonPredicate! ! !RxMatchOptimizer methodsFor: 'private' stamp: 'ul 8/22/2015 17:42'! addNonPrefix: aCharacter ^(nonPrefixes ifNil: [ nonPrefixes := CharacterSet new ]) add: aCharacter! ! !RxMatchOptimizer methodsFor: 'private' stamp: 'ul 8/22/2015 17:47'! addPredicate: predicate ^(predicates ifNil: [ predicates := Set new: 1 ]) add: predicate! ! !RxMatchOptimizer methodsFor: 'private' stamp: 'ul 8/22/2015 17:42'! addPrefix: aCharacter ^(prefixes ifNil: [ prefixes := CharacterSet new ]) add: aCharacter! ! !RxMatchOptimizer methodsFor: 'accessing' stamp: 'ul 8/22/2015 17:48' prior: 33787937! conditionTester "#any condition is filtered at the higher level; it cannot appear among the conditions here." | matchConditions size | conditions ifNil: [ ^nil ]. (size := conditions size) = 0 ifTrue: [ ^nil ]. size = 1 ifTrue: [ | matchCondition | matchCondition := conditions anyOne. "Special case all of the possible conditions." #atBeginningOfLine == matchCondition ifTrue: [^[:c :matcher | matcher atBeginningOfLine]]. #atEndOfLine == matchCondition ifTrue: [^[:c :matcher | matcher atEndOfLine]]. #atBeginningOfWord == matchCondition ifTrue: [^[:c :matcher | matcher atBeginningOfWord]]. #atEndOfWord == matchCondition ifTrue: [^[:c :matcher | matcher atEndOfWord]]. #atWordBoundary == matchCondition ifTrue: [^[:c :matcher | matcher atWordBoundary]]. #notAtWordBoundary == matchCondition ifTrue: [^[:c :matcher | matcher notAtWordBoundary]]. RxParser signalCompilationException: 'invalid match condition']. "More than one condition. Capture them as an array in scope." matchConditions := conditions asArray. ^[ :c :matcher | matchConditions anySatisfy: [ :conditionSelector | matcher perform: conditionSelector ] ]! ! !RxMatchOptimizer methodsFor: 'private' stamp: 'ul 8/22/2015 17:50' prior: 33605841! determineTestMethod "Answer a block closure that will work as a can-match predicate. Answer nil if no viable optimization is possible (too many chars would be able to start a match)." | testers size | conditions ifNotNil: [ (conditions includes: #any) ifTrue: [ ^nil ] ]. testers := { self prefixTester. self nonPrefixTester. self conditionTester. self methodPredicateTester. self nonMethodPredicateTester. self predicateTester. self nonPredicateTester } reject: [ :each | each isNil ]. (size := testers size) = 0 ifTrue: [ ^nil ]. size = 1 ifTrue: [ ^testers first ]. ^[ :char :matcher | testers anySatisfy: [ :t | t value: char value: matcher ] ]! ! !RxMatchOptimizer methodsFor: 'initialize-release' stamp: 'ul 8/22/2015 17:52' prior: 33789163! initialize: aRegex ignoreCase: aBoolean "Set `testMethod' variable to a can-match predicate block: two-argument block which accepts a lookahead character and a matcher (presumably built from aRegex) and answers a boolean indicating whether a match could start at the given lookahead. " ignoreCase := aBoolean. aRegex dispatchTo: self. "If the whole expression is nullable, end-of-line is an implicit can-match condition!!" aRegex isNullable ifTrue: [ self addCondition: #atEndOfLine ]. testBlock := self determineTestMethod! ! !RxMatchOptimizer methodsFor: 'accessing' stamp: 'ul 8/22/2015 17:44' prior: 33790047! methodPredicateTester | p size | methodPredicates ifNil: [ ^nil ]. (size := methodPredicates size) = 0 ifTrue: [ ^nil ]. size = 1 ifTrue: [ | selector | "might be a pretty common case" selector := methodPredicates anyOne. ^[ :char :matcher | RxParser doHandlingMessageNotUnderstood: [ char perform: selector ] ] ]. p := methodPredicates asArray. ^[ :char :matcher | RxParser doHandlingMessageNotUnderstood: [ p anySatisfy: [ :sel | char perform: sel ] ] ]! ! !RxMatchOptimizer methodsFor: 'accessing' stamp: 'ul 8/22/2015 17:48' prior: 33607949! nonMethodPredicateTester | p size | nonMethodPredicates ifNil: [ ^nil ]. (size := nonMethodPredicates size) = 0 ifTrue: [ ^nil ]. size = 1 ifTrue: [ | selector | selector := nonMethodPredicates anyOne. ^[ :char :matcher | RxParser doHandlingMessageNotUnderstood: [ (char perform: selector) not ] ] ]. p := nonMethodPredicates asArray. ^[:char :m | RxParser doHandlingMessageNotUnderstood: [ (p allSatisfy: [:sel | char perform: sel ]) not ] ]! ! !RxMatchOptimizer methodsFor: 'private' stamp: 'ul 8/22/2015 17:38' prior: 33608453! nonPredicateTester | p size | nonPredicates ifNil: [ ^nil ]. (size := nonPredicates size) = 0 ifTrue: [ ^nil ]. size = 1 ifTrue: [ | predicate | predicate := nonPredicates anyOne. ^[ :char :matcher | (predicate value: char) not] ]. p := nonPredicates asArray. ^[ :char :m | (p allSatisfy: [:some | some value: char ]) not ]! ! !RxMatchOptimizer methodsFor: 'private' stamp: 'ul 8/22/2015 17:43' prior: 33608831! nonPrefixTester | size | nonPrefixes ifNil: [ ^nil ]. (size := nonPrefixes size) = 0 ifTrue: [ ^nil ]. size = 1 ifTrue: [ | nonPrefixChar | nonPrefixChar := nonPrefixes anyOne. ^[ :char :matcher | char ~~ nonPrefixChar ] ]. ^[ :char : matcher | (nonPrefixes includes: char) not ]! ! !RxMatchOptimizer methodsFor: 'private' stamp: 'ul 8/22/2015 17:33' prior: 33609445! predicateTester | p size | predicates ifNil: [ ^nil ]. (size := predicates size) = 0 ifTrue: [ ^nil ]. size = 1 ifTrue: [ | pred | pred := predicates anyOne. ^[ :char :matcher | pred value: char ] ]. p := predicates asArray. ^[ :char :matcher | p anySatisfy: [:some | some value: char ] ]! ! !RxMatchOptimizer methodsFor: 'private' stamp: 'ul 8/22/2015 17:40' prior: 33609791! prefixTester | p size | prefixes ifNil: [ ^nil ]. (size := prefixes size) = 0 ifTrue: [ ^nil ]. size = 1 ifTrue: [ | prefixChar | prefixChar := prefixes anyOne. ignoreCase ifTrue: [ ^[ :char :matcher | char sameAs: prefixChar ] ]. ^[ :char :matcher | char == prefixChar ] ]. ignoreCase ifFalse: [ ^[ :char :matcher | prefixes includes: char ] ]. p := prefixes collect: [ :each | each asUppercase ]. ^[ :char :matcher | p includes: char asUppercase ]! ! !RxMatchOptimizer methodsFor: 'double dispatch' stamp: 'ul 8/22/2015 17:51' prior: 33610307! syntaxAny "Any special char is among the prefixes." self addCondition: #any! ! !RxMatchOptimizer methodsFor: 'double dispatch' stamp: 'ul 8/22/2015 17:51' prior: 33610461! syntaxBeginningOfLine "Beginning of line is among the prefixes." self addCondition: #atBeginningOfLine! ! !RxMatchOptimizer methodsFor: 'double dispatch' stamp: 'ul 8/22/2015 17:51' prior: 33610642! syntaxBeginningOfWord "Beginning of line is among the prefixes." self addCondition: #atBeginningOfWord! ! !RxMatchOptimizer methodsFor: 'double dispatch' stamp: 'ul 8/22/2015 17:42' prior: 33611224! syntaxCharSet: charSetNode "All these (or none of these) characters is the prefix." (charSetNode enumerableSetIgnoringCase: ignoreCase) ifNotNil: [ :enumerableSet | charSetNode isNegated ifTrue: [ enumerableSet do: [ :each | self addNonPrefix: each ] ] ifFalse: [ enumerableSet do: [ :each | self addPrefix: each ] ] ]. charSetNode predicates ifNotNil: [ :charsetPredicates | charSetNode isNegated ifTrue: [ charsetPredicates do: [ :each | self addNonPredicate: each ] ] ifFalse: [ charsetPredicates do: [ :each | self addPredicate: each ] ] ]! ! !RxMatchOptimizer methodsFor: 'double dispatch' stamp: 'ul 8/22/2015 17:41' prior: 33611785! syntaxCharacter: charNode "This character is the prefix, of one of them." self addPrefix: charNode character! ! !RxMatchOptimizer methodsFor: 'double dispatch' stamp: 'ul 8/22/2015 17:51' prior: 33611973! syntaxEndOfLine "Beginning of line is among the prefixes." self addCondition: #atEndOfLine! ! !RxMatchOptimizer methodsFor: 'double dispatch' stamp: 'ul 8/22/2015 17:51' prior: 33612142! syntaxEndOfWord self addCondition: #atEndOfWord! ! !RxMatchOptimizer methodsFor: 'double dispatch' stamp: 'ul 8/22/2015 17:32' prior: 33612426! syntaxLookaround: lookaroundNode "Do nothing."! ! !RxMatchOptimizer methodsFor: 'double dispatch' stamp: 'ul 8/22/2015 17:47' prior: 33612574! syntaxMessagePredicate: messagePredicateNode messagePredicateNode negated ifTrue: [ ^self addNonMethodPredicate: messagePredicateNode selector ]. self addMethodPredicate: messagePredicateNode selector! ! !RxMatchOptimizer methodsFor: 'double dispatch' stamp: 'ul 8/22/2015 17:51' prior: 33612860! syntaxNonWordBoundary self addCondition: #notAtWordBoundary! ! !RxMatchOptimizer methodsFor: 'double dispatch' stamp: 'ul 8/22/2015 17:35' prior: 33613156! syntaxPredicate: predicateNode self addPredicate: predicateNode predicate! ! !RxMatchOptimizer methodsFor: 'double dispatch' stamp: 'ul 8/22/2015 17:51' prior: 33613601! syntaxWordBoundary self addCondition: #atWordBoundary! ! !RxMatcher methodsFor: 'match enumeration' stamp: 'ul 8/22/2015 21:47' prior: 33616200! copy: aString replacingMatchesWith: replacementString "Copy , except for the matches. Replace each match with ." ^String new: (aString size min: 1000) streamContents: [ :stream | self copyStream: aString readStream to: stream replacingMatchesWith: replacementString ]! ! !RxMatcher methodsFor: 'match enumeration' stamp: 'ul 8/22/2015 21:44' prior: 33617047! copyStream: aStream to: writeStream replacingMatchesWith: aString "Copy the contents of on the , except for the matches. Replace each match with ." | searchStart matchStart matchEnd | stream := aStream. oldMarkerPositions := markerPositions := nil. [searchStart := aStream position. self proceedSearchingStream: aStream] whileTrue: [matchStart := (self subBeginning: 1) first. matchEnd := (self subEnd: 1) first. aStream position: searchStart. searchStart to: matchStart - 1 do: [:ignoredPos | writeStream nextPut: aStream next]. writeStream nextPutAll: aString. aStream position: matchEnd. "Be extra careful about successful matches which consume no input. After those, make sure to advance or finish if already at end." matchEnd = searchStart ifTrue: [aStream atEnd ifTrue: [^self "rest after end of whileTrue: block is a no-op if atEnd"] ifFalse: [writeStream nextPut: aStream next]]]. aStream position: searchStart. [aStream atEnd] whileFalse: [writeStream nextPut: aStream next]! ! !RxMatcher methodsFor: 'match enumeration' stamp: 'ul 8/22/2015 21:44' prior: 33618158! copyStream: aStream to: writeStream translatingMatchesUsing: aBlock "Copy the contents of on the , except for the matches. For each match, evaluate passing the matched substring as the argument. Expect the block to answer a String, and write the answer to in place of the match." | searchStart matchStart matchEnd match | stream := aStream. oldMarkerPositions := markerPositions := nil. [searchStart := aStream position. self proceedSearchingStream: aStream] whileTrue: [matchStart := (self subBeginning: 1) first. matchEnd := (self subEnd: 1) first. aStream position: searchStart. searchStart to: matchStart - 1 do: [:ignoredPos | writeStream nextPut: aStream next]. match := (String new: matchEnd - matchStart + 1) writeStream. matchStart to: matchEnd - 1 do: [:ignoredPos | match nextPut: aStream next]. writeStream nextPutAll: (aBlock value: match contents). "Be extra careful about successful matches which consume no input. After those, make sure to advance or finish if already at end." matchEnd = searchStart ifTrue: [aStream atEnd ifTrue: [^self "rest after end of whileTrue: block is a no-op if atEnd"] ifFalse: [writeStream nextPut: aStream next]]]. aStream position: searchStart. [aStream atEnd] whileFalse: [writeStream nextPut: aStream next]! ! !RxMatcher methodsFor: 'accessing' stamp: 'ul 8/22/2015 21:53' prior: 33626638! matchesStreamPrefix: theStream "Match thyself against a positionable stream." stream := theStream. oldMarkerPositions := markerPositions := nil. ^self tryMatch! ! !RxMatcher methodsFor: 'accessing' stamp: 'ul 8/22/2015 21:53' prior: 33628363! searchStream: aStream "Search the stream for occurrence of something matching myself. After the search has occurred, stop positioned after the end of the matched substring. Answer a Boolean indicating success." | position | stream := aStream. position := aStream position. oldMarkerPositions := markerPositions := nil. [aStream atEnd] whileFalse: [self tryMatch ifTrue: [^true]. aStream position: position; next. position := aStream position]. "Try match at the very stream end too!!" ^self tryMatch! ! !RxMatcher methodsFor: 'double dispatch' stamp: 'ul 8/22/2015 18:05' prior: 33632632! syntaxCharacter: charNode "Double dispatch from the syntax tree. We get here when no merging characters into strings was possible." | wanted | wanted := charNode character. ^RxmPredicate new predicate: (ignoreCase ifTrue: [[:char | char sameAs: wanted]] ifFalse: [[:char | char == wanted]])! ! !RxMatcher methodsFor: 'double dispatch' stamp: 'ul 8/22/2015 21:30' prior: 33633738! syntaxLookaround: lookaroundNode "Double dispatch from the syntax tree. Special link can handle lookarounds (look ahead, positive and negative)." | piece | piece := lookaroundNode piece dispatchTo: self. ^ RxmLookahead with: piece! ! !RxMatcher methodsFor: 'private' stamp: 'ul 8/22/2015 21:48' prior: 33636284! tryMatch "Match thyself against the current stream." | newMarkerPositions | newMarkerPositions := oldMarkerPositions. oldMarkerPositions := markerPositions. markerPositions := newMarkerPositions. markerPositions ifNil: [ markerPositions := Array new: markerCount. 1 to: markerCount do: [ :i | | collection | collection := OrderedCollection new: 2. "There are usually 0 or 1 objects to store." collection resetTo: 3. "We'll add elements to the beginning, so make room there." markerPositions at: i put: collection ] ] ifNotNil: [ 1 to: markerCount do: [ :i | | collection | collection := markerPositions at: i. collection resetTo: collection capacity + 1 ] ]. lastResult := startOptimizer ifNil: [ matcher matchAgainst: self] ifNotNil: [ (startOptimizer canStartMatch: stream peek in: self) and: [ matcher matchAgainst: self ] ]. "check for duplicates" lastResult ifFalse: [ ^false ]. oldMarkerPositions ifNil: [ ^true ]. (oldMarkerPositions hasEqualElements: markerPositions) ifFalse: [ ^true ]. "this is a duplicate" ^ lastResult := false! ! !RxmLookahead class methodsFor: 'instance creation' stamp: 'CamilloBruni 8/28/2013 16:44'! with: aPiece ^self new lookahead: aPiece! ! !RxmLookahead methodsFor: 'initialization' stamp: 'CamilloBruni 8/28/2013 16:52'! initialize super initialize. positive := true.! ! !RxmLookahead methodsFor: 'accessing' stamp: 'CamilloBruni 8/28/2013 16:43'! lookahead ^ lookahead! ! !RxmLookahead methodsFor: 'accessing' stamp: 'CamilloBruni 8/28/2013 16:43'! lookahead: anRxmLink lookahead := anRxmLink! ! !RxmLookahead methodsFor: 'matching' stamp: 'CamilloBruni 8/28/2013 17:02'! matchAgainst: aMatcher "Match if the predicate block evaluates to true when given the current stream character as the argument." | original result | original := aMatcher currentState. result := lookahead matchAgainst: aMatcher. aMatcher restoreState: original. ^ result not and: [ next matchAgainst: aMatcher ]! ! !RxmLookahead methodsFor: 'building' stamp: 'CamilloBruni 8/28/2013 17:09'! terminateWith: aNode lookahead terminateWith: aNode. super terminateWith: aNode.! ! !RxmSubstring methodsFor: 'initialize-release' stamp: 'ul 8/22/2015 22:33' prior: 33689758! character: aCharacter ignoreCase: aBoolean "Match exactly this character." sampleStream := (String with: aCharacter) readStream. ignoreCase := aBoolean! ! !RxmSubstring methodsFor: 'initialization' stamp: 'ul 8/22/2015 22:33' prior: 33689989! initialize super initialize. ignoreCase := false! ! !RxmSubstring methodsFor: 'matching' stamp: 'ul 8/22/2015 22:33' prior: 33690110! matchAgainst: aMatcher "Match if my sample stream is exactly the current prefix of the matcher stream's contents." | nextSample nextFromMatcher originalState | originalState := aMatcher currentState. sampleStream reset. ignoreCase ifFalse: [ [ (nextSample := sampleStream next) == nil or: [ (nextFromMatcher := aMatcher next) == nil ] ] whileFalse: [ nextSample == nextFromMatcher ifFalse: [ aMatcher restoreState: originalState. ^false ] ] ] ifTrue: [ [ (nextSample := sampleStream next) == nil or: [ (nextFromMatcher := aMatcher next) == nil ] ] whileFalse: [ (nextSample sameAs: nextFromMatcher) ifFalse: [ aMatcher restoreState: originalState. ^false ] ] ]. (nextSample == nil and: [ next matchAgainst: aMatcher ]) ifTrue: [ ^true ]. aMatcher restoreState: originalState. ^false! ! !RxmSubstring methodsFor: 'initialize-release' stamp: 'ul 8/22/2015 22:33' prior: 33690850! substring: aString ignoreCase: aBoolean "Match exactly this string." sampleStream := aString readStream. ignoreCase := aBoolean! ! RxmSubstring removeSelector: #sampleStream! RxmSubstring removeSelector: #beCaseSensitive! RxmSubstring removeSelector: #beCaseInsensitive! RxmLookahaed removeSelector: #terminateWith:! RxmLookahaed removeSelector: #matchAgainst:! RxmLookahaed removeSelector: #lookahead:! RxmLookahaed removeSelector: #lookahead! RxmLookahaed removeSelector: #initialize! RxmLookahaed class removeSelector: #with:! Smalltalk removeClassNamed: #RxmLookahaed! "Regex-Core"! SystemOrganization addCategory: #'Regex-Tests-Core'! TestCase subclass: #RxMatcherTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Regex-Tests-Core'! !RxMatcherTest commentStamp: 'Tbn 11/12/2010 22:31' prior: 0! This class provides tests for the regular expression matcher.! TestCase subclass: #RxParserTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Regex-Tests-Core'! !RxParserTest commentStamp: 'Tbn 11/12/2010 22:31' prior: 0! This class provides tests for the regular expression parser.! !RxMatcherTest class methodsFor: 'accessing' stamp: 'lr 1/15/2010 19:48'! packageNamesUnderTest ^ #('VB-Regex')! ! !RxMatcherTest methodsFor: 'utilties' stamp: 'MarcusDenker 4/29/2013 17:13'! compileRegex: aString "Compile the regex and answer the matcher, or answer nil if compilation fails." | syntaxTree | syntaxTree := RxParser safelyParse: aString. ^ syntaxTree isNil ifFalse: [ self matcherClass for: syntaxTree ]! ! !RxMatcherTest methodsFor: 'testing-henry' stamp: 'lr 1/15/2010 19:46'! henryReadme self error: 'The tests in this category are based on the ones in Henry Spencer''s regexp.c package.'! ! !RxMatcherTest methodsFor: 'accessing' stamp: 'lr 1/15/2010 18:47'! matcherClass ^ RxMatcher! ! !RxMatcherTest methodsFor: 'utilties' stamp: 'TestRunner 1/15/2010 21:02'! runMatcher: aMatcher with: aString expect: aBoolean withSubexpressions: anArray | copy got | copy := aMatcher copy: aString translatingMatchesUsing: [ :each | each ]. self assert: copy = aString description: 'Copying: expected ' , aString printString , ', but got ' , copy printString. got := aMatcher search: aString. self assert: got = aBoolean description: 'Searching: expected ' , aBoolean printString , ', but got ' , got printString. (anArray isNil or: [ aMatcher supportsSubexpressions not ]) ifTrue: [ ^ self ]. 1 to: anArray size by: 2 do: [ :index | | sub subExpect subGot | sub := anArray at: index. subExpect := anArray at: index + 1. subGot := aMatcher subexpression: sub. self assert: subExpect = subGot description: 'Subexpression ' , sub printString , ': expected ' , subExpect printString , ', but got ' , subGot printString ]! ! !RxMatcherTest methodsFor: 'utilties' stamp: 'lr 1/15/2010 19:31'! runRegex: anArray "Run a clause anArray against a set of tests. Each clause is an array with a regex source string followed by sequence of 3-tuples. Each three-element group is one test to try against the regex, and includes: 1) test string; 2) expected result; 3) expected subexpression as an array of (index, substring), or nil." | source matcher | source := anArray first. matcher := self compileRegex: source. matcher isNil ifTrue: [ (anArray at: 2) isNil ifFalse: [ self signalFailure: 'Compilation failed, should have succeeded: ' , source printString ] ] ifFalse: [ (anArray at: 2) isNil ifTrue: [ self signalFailure: 'Compilation succeeded, should have failed: ' , source printString ] ifFalse: [ 2 to: anArray size by: 3 do: [ :index | self runMatcher: matcher with: (anArray at: index) expect: (anArray at: index + 1) withSubexpressions: (anArray at: index + 2) ] ] ]! ! !RxMatcherTest methodsFor: 'testing-protocol' stamp: 'lr 1/15/2010 20:28'! testCaseInsensitive | matcher | matcher := self matcherClass forString: 'the quick brown fox' ignoreCase: true. self assert: (matcher search: 'the quick brown fox'). self assert: (matcher search: 'The quick brown FOX'). self assert: (matcher search: 'What do you know about the quick brown fox?'). self assert: (matcher search: 'What do you know about THE QUICK BROWN FOX?')! ! !RxMatcherTest methodsFor: 'testing-protocol' stamp: 'lr 1/15/2010 20:28'! testCaseSensitive | matcher | matcher := self matcherClass forString: 'the quick brown fox' ignoreCase: false. self assert: (matcher search: 'the quick brown fox'). self deny: (matcher search: 'The quick brown FOX'). self assert: (matcher search: 'What do you know about the quick brown fox?'). self deny: (matcher search: 'What do you know about THE QUICK BROWN FOX?')! ! !RxMatcherTest methodsFor: 'testing-protocol' stamp: 'lr 1/15/2010 20:38'! testCopyReplacingMatches "See that the match context is preserved while copying stuff between matches:" | matcher | matcher := self matcherClass forString: '\<\d\D+'. self assert: (matcher copy: '9aaa1bbb 8ccc' replacingMatchesWith: 'foo') = 'foo1bbb foo'! ! !RxMatcherTest methodsFor: 'testing-protocol' stamp: 'hfm 4/2/2010 13:52'! testCopyTranslatingMatches | matcher | matcher := self matcherClass forString: '\w+'. self assert: (matcher copy: 'now is the time ' translatingMatchesUsing: [ :each | each reversed ]) = 'won si eht emit '! ! !RxMatcherTest methodsFor: 'testing-empty' stamp: 'lr 1/15/2010 21:46'! testEmptyStringAtBeginningOfLine | matcher | matcher := self matcherClass forString: '^'. self assert: (matcher copy: 'foo1 bar1' , String cr , 'foo2 bar2' replacingMatchesWith: '*') = ('*foo1 bar1' , String cr , '*foo2 bar2') description: 'An empty string at the beginning of a line'! ! !RxMatcherTest methodsFor: 'testing-empty' stamp: 'lr 1/15/2010 20:05'! testEmptyStringAtBeginningOfWord | matcher | matcher := self matcherClass forString: '\<'. self assert: (matcher copy: 'foo bar' replacingMatchesWith: '*') = '*foo *bar' description: 'An empty string at the beginning of a word'! ! !RxMatcherTest methodsFor: 'testing-empty' stamp: 'TestRunner 1/15/2010 21:18'! testEmptyStringAtEndOfLine | matcher | matcher := self matcherClass forString: '$'. self assert: (matcher copy: 'foo1 bar1' , String cr , 'foo2 bar2' replacingMatchesWith: '*') = ('foo1 bar1*', String cr , 'foo2 bar2*') description: 'An empty string at the end of a line'! ! !RxMatcherTest methodsFor: 'testing-empty' stamp: 'TestRunner 1/15/2010 21:18'! testEmptyStringAtEndOfWord | matcher | matcher := self matcherClass forString: '\>'. self assert: (matcher copy: 'foo bar' replacingMatchesWith: '*') = 'foo* bar*' description: 'An empty string at the end of a word'! ! !RxMatcherTest methodsFor: 'testing-empty' stamp: 'TestRunner 1/15/2010 21:18'! testEmptyStringAtWordBoundary | matcher | matcher := self matcherClass forString: '\b'. self assert: (matcher copy: 'foo bar' replacingMatchesWith: '*') = '*foo* *bar*' description: 'An empty string at a word boundary'! ! !RxMatcherTest methodsFor: 'testing-empty' stamp: 'TestRunner 1/15/2010 21:19'! testEmptyStringNotAtWordBoundary | matcher | matcher := self matcherClass forString: '\B'. self assert: (matcher copy: 'foo bar' replacingMatchesWith: '*') = 'f*o*o b*a*r' description: 'An empty string not at a word boundary'! ! !RxMatcherTest methodsFor: 'testing-henry' stamp: 'lr 1/15/2010 19:46'! testHenry001 self runRegex: #('abc' 'abc' true (1 'abc') 'xbc' false nil 'axc' false nil 'abx' false nil 'xabcy' true (1 'abc') 'ababc' true (1 'abc'))! ! !RxMatcherTest methodsFor: 'testing-henry' stamp: 'lr 1/15/2010 19:46'! testHenry002 self runRegex: #('ab*c' 'abc' true (1 'abc'))! ! !RxMatcherTest methodsFor: 'testing-henry' stamp: 'lr 1/15/2010 19:46'! testHenry003 self runRegex: #('ab*bc' 'abc' true (1 'abc') 'abbc' true (1 'abbc') 'abbbbc' true (1 'abbbbc'))! ! !RxMatcherTest methodsFor: 'testing-henry' stamp: 'lr 1/15/2010 19:46'! testHenry004 self runRegex: #('ab+bc' 'abbc' true (1 'abbc') 'abc' false nil 'abq' false nil 'abbbbc' true (1 'abbbbc'))! ! !RxMatcherTest methodsFor: 'testing-henry' stamp: 'lr 1/15/2010 19:46'! testHenry005 self runRegex: #('ab?bc' 'abbc' true (1 'abbc') 'abc' true (1 'abc') 'abbbbc' false nil 'abc' true (1 'abc'))! ! !RxMatcherTest methodsFor: 'testing-henry' stamp: 'lr 1/15/2010 19:46'! testHenry006 self runRegex: #('^abc$' 'abc' true (1 'abc') 'abcc' false nil 'aabc' false nil)! ! !RxMatcherTest methodsFor: 'testing-henry' stamp: 'lr 1/15/2010 19:46'! testHenry007 self runRegex: #('^abc' 'abcc' true (1 'abc'))! ! !RxMatcherTest methodsFor: 'testing-henry' stamp: 'lr 1/15/2010 19:46'! testHenry008 self runRegex: #('abc$' 'aabc' true (1 'abc'))! ! !RxMatcherTest methodsFor: 'testing-henry' stamp: 'lr 1/15/2010 19:46'! testHenry009 self runRegex: #('^' 'abc' true nil)! ! !RxMatcherTest methodsFor: 'testing-henry' stamp: 'lr 1/15/2010 19:46'! testHenry010 self runRegex: #('$' 'abc' true nil)! ! !RxMatcherTest methodsFor: 'testing-henry' stamp: 'lr 1/15/2010 19:46'! testHenry011 self runRegex: #('a.c' 'abc' true (1 'abc') 'axc' true (1 'axc'))! ! !RxMatcherTest methodsFor: 'testing-henry' stamp: 'lr 1/15/2010 19:46'! testHenry012 "Need to get creative to include the null character..." self runRegex: #('a.*c' 'axyzc' true (1 'axyzc') 'axy zc' true (1 'axy zc') "testing that a dot matches a space" ), (Array with: 'axy', (String with: 0 asCharacter), 'zc'), #(false nil "testing that a dot does not match a null" 'axyzd' false nil)! ! !RxMatcherTest methodsFor: 'testing-henry' stamp: 'lr 1/15/2010 19:46'! testHenry013 self runRegex: #('.a.*' '1234abc' true (1 '4abc') 'abcd' false nil)! ! !RxMatcherTest methodsFor: 'testing-henry' stamp: 'lr 1/15/2010 19:46'! testHenry014 self runRegex: #('a\w+c' ' abbbbc ' true (1 'abbbbc') 'abb bc' false nil)! ! !RxMatcherTest methodsFor: 'testing-henry' stamp: 'lr 1/15/2010 19:46'! testHenry015 self runRegex: #('\w+' ' foobar quux' true (1 'foobar') ' ~!!@#$%^&*()-+=\|/?.>,<' false nil)! ! !RxMatcherTest methodsFor: 'testing-henry' stamp: 'lr 1/15/2010 19:46'! testHenry016 self runRegex: #('a\W+c' 'a c' true (1 'a c') 'a bc' false nil)! ! !RxMatcherTest methodsFor: 'testing-henry' stamp: 'lr 1/15/2010 19:46'! testHenry017 self runRegex: #('\W+' 'foo!!@#$bar' true (1 '!!@#$') 'foobar' false nil)! ! !RxMatcherTest methodsFor: 'testing-henry' stamp: 'lr 1/15/2010 19:46'! testHenry018 self runRegex: #('a\s*c' 'a c' true (1 'a c') 'a bc' false nil)! ! !RxMatcherTest methodsFor: 'testing-henry' stamp: 'lr 1/15/2010 19:46'! testHenry019 self runRegex: #('\s+' 'abc3457 sd' true (1 ' ') '1234$^*^&asdfb' false nil)! ! !RxMatcherTest methodsFor: 'testing-henry' stamp: 'lr 1/15/2010 19:46'! testHenry020 self runRegex: #('a\S*c' 'aqwertyc' true (1 'aqwertyc') 'ab c' false nil)! ! !RxMatcherTest methodsFor: 'testing-henry' stamp: 'lr 1/15/2010 19:46'! testHenry021 self runRegex: #('\S+' ' asdf ' true (1 'asdf') ' ' false nil)! ! !RxMatcherTest methodsFor: 'testing-henry' stamp: 'lr 1/15/2010 19:46'! testHenry022 self runRegex: #('a\d+c' 'a0123456789c' true (1 'a0123456789c') 'a12b34c' false nil)! ! !RxMatcherTest methodsFor: 'testing-henry' stamp: 'lr 1/15/2010 19:46'! testHenry023 self runRegex: #('\d+' 'foo@#$%123ASD #$$%^&' true (1 '123') 'foo!!@#$asdfl;' false nil)! ! !RxMatcherTest methodsFor: 'testing-henry' stamp: 'lr 1/15/2010 19:46'! testHenry024 self runRegex: #('a\D+c' 'aqwertyc' true (1 'aqwertyc') 'aqw6ertc' false nil)! ! !RxMatcherTest methodsFor: 'testing-henry' stamp: 'lr 1/15/2010 19:46'! testHenry025 self runRegex: #('\D+' '1234 abc 456' true (1 ' abc ') '1234567890' false nil)! ! !RxMatcherTest methodsFor: 'testing-henry' stamp: 'lr 1/15/2010 19:46'! testHenry026 self runRegex: #('(f|o)+\b' 'foo' true (1 'foo') ' foo ' true (1 'foo'))! ! !RxMatcherTest methodsFor: 'testing-henry' stamp: 'lr 1/15/2010 19:46'! testHenry027 self runRegex: #('\ba\w+' "a word beginning with an A" 'land ancient' true (1 'ancient') 'antique vase' true (1 'antique') 'goofy foobar' false nil)! ! !RxMatcherTest methodsFor: 'testing-henry' stamp: 'lr 1/15/2010 19:46'! testHenry028 self runRegex: #('(f|o)+\B' 'quuxfoobar' true (1 'foo') 'quuxfoo ' true (1 'fo'))! ! !RxMatcherTest methodsFor: 'testing-henry' stamp: 'lr 1/15/2010 19:46'! testHenry029 self runRegex: #('\Ba\w+' "a word with an A in the middle, match at A and further" 'land ancient' true (1 'and') 'antique vase' true (1 'ase') 'smalltalk shall overcome' true (1 'alltalk') 'foonix is better' false nil)! ! !RxMatcherTest methodsFor: 'testing-henry' stamp: 'lr 1/15/2010 19:46'! testHenry030 self runRegex: #('fooa\>.*' 'fooa ' true nil 'fooa123' false nil 'fooa bar' true nil 'fooa' true nil 'fooargh' false nil)! ! !RxMatcherTest methodsFor: 'testing-henry' stamp: 'lr 1/15/2010 19:46'! testHenry031 self runRegex: #('\>.+abc' ' abcde fg' false nil 'foo abcde' true (1 ' abc') 'abcde' false nil)! ! !RxMatcherTest methodsFor: 'testing-henry' stamp: 'lr 1/15/2010 19:46'! testHenry032 self runRegex: #('\' prior: 21010020! A set of characters. Lookups for inclusion are very fast.! !CharacterSet methodsFor: 'comparison' stamp: 'ul 8/23/2015 22:17' prior: 21012395! = anObject self species == anObject species ifFalse: [ ^false ]. self size. "to migrate existing instances" anObject size = tally ifFalse: [ ^false ]. ^self byteArrayMap = anObject byteArrayMap! ! !CharacterSet methodsFor: 'collection ops' stamp: 'ul 8/23/2015 22:13' prior: 21010573! add: aCharacter "I automatically become a WideCharacterSet if you add a wide character to myself" | index | (index := aCharacter asInteger + 1) <= 256 ifFalse: [ | wide | wide := WideCharacterSet new. wide addAll: self. wide add: aCharacter. self becomeForward: wide. ^aCharacter ]. (map at: index) = 1 ifTrue: [ ^aCharacter ]. self size. "to migrate existing instances." map at: index put: 1. tally := tally + 1. ^aCharacter! ! !CharacterSet methodsFor: 'collection ops' stamp: 'ul 8/23/2015 22:16' prior: 21010981! do: aBlock "evaluate aBlock with each character in the set" | index | self size. "to migrate existing instances" tally >= 128 ifTrue: [ "dense" index := 0. [ (index := index + 1) <= 256 ] whileTrue: [ (map at: index) = 1 ifTrue: [ aBlock value: (Character value: index - 1) ] ]. ^self ]. "sparse" index := 0. [ (index := map indexOf: 1 startingAt: index + 1) = 0 ] whileFalse: [ aBlock value: (Character value: index - 1) ]. ! ! !CharacterSet methodsFor: 'private' stamp: 'ul 8/23/2015 22:05' prior: 21014188! initialize map := ByteArray new: 256. tally := 0! ! !CharacterSet methodsFor: 'collection ops' stamp: 'ul 8/23/2015 22:16' prior: 21011883! remove: aCharacter ^self remove: aCharacter ifAbsent: aCharacter! ! !CharacterSet methodsFor: 'collection ops' stamp: 'ul 8/23/2015 22:13' prior: 21012114! remove: aCharacter ifAbsent: aBlock | index | (index := aCharacter asciiValue + 1) <= 256 ifFalse: [ ^aBlock value ]. (map at: index) = 0 ifTrue: [ ^aBlock value ]. self size. "to migrate existing instances." map at: index put: 0. tally := tally - 1. ^aCharacter! ! !CharacterSet methodsFor: 'removing' stamp: 'ul 8/23/2015 22:19' prior: 21014741! removeAll map atAllPut: 0. tally := 0! ! !CharacterSet methodsFor: 'collection ops' stamp: 'ul 8/23/2015 22:12' prior: 21012308! size ^tally ifNil: [ | index count | index := count := 0. [ (index := map indexOf: 1 startingAt: index + 1) = 0 ] whileFalse: [ count := count + 1 ]. tally := count ]! ! "Collections"! !Installer methodsFor: 'package-definitions' stamp: 'cmm 7/28/2015 14:20' prior: 20562042! maInstaller "Select from a family of related packages for application development." ^ { #ss -> 'Ma-Installer'. 'Ma-Installer-Core' }! ! !Installer methodsFor: 'package-definitions' stamp: 'cmm 7/28/2015 15:20' prior: 20565248! webClientSsp "WebClient supports NTLM/SPNEGO authentication via the Microsoft SSP interface (Windows only)." ^ { self ffiTests. #ss3 -> 'WebClient'. 'WebClient-SSP' }! ! Installer removeSelector: #webClientTests! Installer removeSelector: #webClientCore! Installer removeSelector: #squeakSslTests! Installer removeSelector: #squeakSslCore! "Installer-Core"! !TextEditor methodsFor: 'menu messages' stamp: 'dtl 8/23/2015 21:20'! sendContentsToPrinterWithLabel: label | textToPrint printer | textToPrint := paragraph text. textToPrint size = 0 ifTrue: [^self inform: 'nothing to print.']. printer := TextPrinter defaultTextPrinter. printer documentTitle: (label ifNil: ['Untitled']). printer printText: textToPrint! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'dtl 8/23/2015 21:15' prior: 18409024! sendContentsToPrinter self handleEdit: [textMorph editor sendContentsToPrinterWithLabel: owner knownName]! ! "Morphic"! Object subclass: #RxMatcher instanceVariableNames: 'matcher ignoreCase startOptimizer stream markerPositions markerCount lastResult oldMarkerPositions firstTry' classVariableNames: 'Cr Lf' poolDictionaries: '' category: 'Regex-Core'! !RxMatcher commentStamp: 'Tbn 11/12/2010 23:13' prior: 33850942! -- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov -- This is a recursive regex matcher. Not strikingly efficient, but simple. Also, keeps track of matched subexpressions. The life cycle goes as follows: 1. Initialization. Accepts a syntax tree (presumably produced by RxParser) and compiles it into a matcher built of other classes in this category. 2. Matching. Accepts a stream or a string and returns a boolean indicating whether the whole stream or its prefix -- depending on the message sent -- matches the regex. 3. Subexpression query. After a successful match, and before any other match, the matcher may be queried about the range of specific stream (string) positions that matched to certain parenthesized subexpressions of the original expression. Any number of queries may follow a successful match, and any number or matches may follow a successful initialization. Note that `matcher' is actually a sort of a misnomer. The actual matcher is a web of Rxm* instances built by RxMatcher during initialization. RxMatcher is just the interface facade of this network. It is also a builder of it, and also provides a stream-like protocol to easily access the stream being matched. Instance variables: matcher The entry point into the actual matcher. stream The stream currently being matched against. markerPositions Positions of markers' matches. markerCount Number of markers. lastResult Whether the latest match attempt succeeded or not. lastChar character last seen in the matcher stream! !RxmBranch methodsFor: 'copying' stamp: 'ul 8/23/2015 13:00'! postCopy super postCopy. alternative := alternative copy! ! !RxMatcher methodsFor: 'match enumeration' stamp: 'ul 8/23/2015 21:29' prior: 33865118! copyStream: aStream to: writeStream replacingMatchesWith: aString "Copy the contents of on the , except for the matches. Replace each match with ." | searchStart matchStart matchEnd | stream := aStream. self resetMarkerPositions. [searchStart := aStream position. self proceedSearchingStream: aStream] whileTrue: [matchStart := (self subBeginning: 1) last. matchEnd := (self subEnd: 1) last. aStream position: searchStart. searchStart to: matchStart - 1 do: [:ignoredPos | writeStream nextPut: aStream next]. writeStream nextPutAll: aString. aStream position: matchEnd. "Be extra careful about successful matches which consume no input. After those, make sure to advance or finish if already at end." matchEnd = searchStart ifTrue: [aStream atEnd ifTrue: [^self "rest after end of whileTrue: block is a no-op if atEnd"] ifFalse: [writeStream nextPut: aStream next]]]. aStream position: searchStart. [aStream atEnd] whileFalse: [writeStream nextPut: aStream next]! ! !RxMatcher methodsFor: 'match enumeration' stamp: 'ul 8/23/2015 21:29' prior: 33866267! copyStream: aStream to: writeStream translatingMatchesUsing: aBlock "Copy the contents of on the , except for the matches. For each match, evaluate passing the matched substring as the argument. Expect the block to answer a String, and write the answer to in place of the match." | searchStart matchStart matchEnd match | stream := aStream. self resetMarkerPositions. [searchStart := aStream position. self proceedSearchingStream: aStream] whileTrue: [matchStart := (self subBeginning: 1) last. matchEnd := (self subEnd: 1) last. aStream position: searchStart. searchStart to: matchStart - 1 do: [:ignoredPos | writeStream nextPut: aStream next]. match := (String new: matchEnd - matchStart + 1) writeStream. matchStart to: matchEnd - 1 do: [:ignoredPos | match nextPut: aStream next]. writeStream nextPutAll: (aBlock value: match contents). "Be extra careful about successful matches which consume no input. After those, make sure to advance or finish if already at end." matchEnd = searchStart ifTrue: [aStream atEnd ifTrue: [^self "rest after end of whileTrue: block is a no-op if atEnd"] ifFalse: [writeStream nextPut: aStream next]]]. aStream position: searchStart. [aStream atEnd] whileFalse: [writeStream nextPut: aStream next]! ! !RxMatcher methodsFor: 'privileged' stamp: 'ul 8/23/2015 01:37' prior: 33623338! markerPositionAt: anIndex add: position "Remember position of another instance of the given marker." (markerPositions at: anIndex) addLast: position! ! !RxMatcher methodsFor: 'accessing' stamp: 'ul 8/23/2015 21:29' prior: 33867701! matchesStreamPrefix: theStream "Match thyself against a positionable stream." stream := theStream. self resetMarkerPositions. ^self tryMatch! ! !RxMatcher methodsFor: 'private' stamp: 'ul 8/23/2015 21:30'! resetMarkerPositions "This method should be sent before the first #tryMatch send." firstTry := true. markerPositions ifNotNil: [ markerPositions do: [ :each | each resetTo: 1 ] ]! ! !RxMatcher methodsFor: 'accessing' stamp: 'ul 8/23/2015 21:30' prior: 33867949! searchStream: aStream "Search the stream for occurrence of something matching myself. After the search has occurred, stop positioned after the end of the matched substring. Answer a Boolean indicating success." | position | stream := aStream. position := aStream position. self resetMarkerPositions. [aStream atEnd] whileFalse: [self tryMatch ifTrue: [^true]. aStream position: position; next. position := aStream position]. "Try match at the very stream end too!!" ^self tryMatch! ! !RxMatcher methodsFor: 'accessing' stamp: 'ul 8/23/2015 01:41' prior: 33629739! subexpressions: subIndex "Answer an array of all matches of the subexpression at the given index. The answer is always an array; it is empty if there are no matches." | originalPosition startPositions stopPositions reply | originalPosition := stream position. startPositions := self subBeginning: subIndex. stopPositions := self subEnd: subIndex. (startPositions isEmpty or: [stopPositions isEmpty]) ifTrue: [^Array new]. reply := Array new: startPositions size. 1 to: reply size do: [ :index | | start stop | start := startPositions at: index. stop := stopPositions at: index. stream position: start. reply at: reply size - index + 1 put: (stream next: stop - start) ]. stream position: originalPosition. ^reply! ! !RxMatcher methodsFor: 'private' stamp: 'ul 8/23/2015 21:30' prior: 33869269! tryMatch "Match thyself against the current stream." | newMarkerPositions wasFirstTry | wasFirstTry := firstTry. firstTry := false. newMarkerPositions := oldMarkerPositions. oldMarkerPositions := markerPositions. markerPositions := newMarkerPositions. markerPositions ifNil: [ markerPositions := Array new: markerCount. 1 to: markerCount do: [ :i | "There are usually 0 or 1 objects to store." markerPositions at: i put: (OrderedCollection new: 2) ] ] ifNotNil: [ 1 to: markerCount do: [ :i | (markerPositions at: i) resetTo: 1 ] ]. lastResult := startOptimizer ifNil: [ matcher matchAgainst: self] ifNotNil: [ (startOptimizer canStartMatch: stream peek in: self) and: [ matcher matchAgainst: self ] ]. "check for duplicates" lastResult ifFalse: [ ^false ]. wasFirstTry ifTrue: [ ^true ]. (oldMarkerPositions hasEqualElements: markerPositions) ifFalse: [ ^true ]. "this is a duplicate match" ^ lastResult := false! ! !RxMatchOptimizer methodsFor: 'private' stamp: 'ul 8/23/2015 21:46'! addNonPrefixes: aSet ^nonPrefixes ifNil: [ nonPrefixes := aSet ] ifNotNil: [ nonPrefixes addAll: aSet ]! ! !RxMatchOptimizer methodsFor: 'private' stamp: 'ul 8/23/2015 21:46'! addPrefixes: aSet ^prefixes ifNil: [ prefixes := aSet ] ifNotNil: [ prefixes addAll: aSet ]! ! !RxMatchOptimizer methodsFor: 'double dispatch' stamp: 'ul 8/23/2015 21:45' prior: 33862585! syntaxCharSet: charSetNode "All these (or none of these) characters is the prefix." (charSetNode enumerableSetIgnoringCase: ignoreCase) ifNotNil: [ :enumerableSet | charSetNode isNegated ifTrue: [ self addNonPrefixes: enumerableSet ] ifFalse: [ self addPrefixes: enumerableSet ] ]. charSetNode predicates ifNotNil: [ :charsetPredicates | charSetNode isNegated ifTrue: [ charsetPredicates do: [ :each | self addNonPredicate: each ] ] ifFalse: [ charsetPredicates do: [ :each | self addPredicate: each ] ] ]! ! !RxmLink methodsFor: 'as yet unclassified' stamp: 'ul 8/23/2015 12:55'! printOn: stream super printOn: stream. stream nextPut: $(; print: self identityHash; nextPutAll: ', '; print: (next ifNotNil: [ next identityHash ]); nextPut: $)! ! !RxsCharSet methodsFor: 'privileged' stamp: 'ul 8/23/2015 22:21' prior: 33791079! enumerablePartPredicateIgnoringCase: aBoolean | set | set := (self enumerableSetIgnoringCase: aBoolean) ifNil: [ ^nil ]. set size = 1 ifTrue: [ | p | p := set anyOne. negated ifTrue: [ ^[ :character | character ~~ p ] ]. ^[ :character | character == p ] ]. negated ifTrue: [ ^[ :char | (set includes: char) not ] ]. ^[ :char | set includes: char ]! ! "Regex-Core"! !RxMatcherTest methodsFor: 'utilties' stamp: 'ul 8/23/2015 15:06' prior: 33875761! runRegex: anArray "Run a clause anArray against a set of tests. Each clause is an array with a regex source string followed by sequence of 3-tuples. Each three-element group is one test to try against the regex, and includes: 1) test string; 2) expected result; 3) expected subexpression as an array of (index, substring), or nil." | source matcher | source := anArray first. matcher := self compileRegex: source. matcher isNil ifTrue: [ (anArray at: 2) isNil ifFalse: [ self signalFailure: 'Compilation failed, should have succeeded: ' , source printString ] ] ifFalse: [ (anArray at: 2) isNil ifTrue: [ self signalFailure: 'Compilation succeeded, should have failed: ' , source printString ] ifFalse: [ anArray allButFirst groupsDo: [ :input :shouldMatch :expectedOutput | self runMatcher: matcher with: input expect: shouldMatch withSubexpressions: expectedOutput ] ] ]! ! !RxMatcherTest methodsFor: 'testing' stamp: 'ul 8/23/2015 15:03'! testOptionalNestedIntoMultipleQuantified self runRegex: #('(aa?){2}' '' false nil 'a' false nil 'aa' true (1 'aa') 'baaa' true (2 'aaa'))! ! "Regex-Tests-Core"! !Form methodsFor: 'scaling, rotation' stamp: 'mt 8/25/2015 10:41' prior: 65407734! scaledToSize: numberOrPoint ^ self scaledToSize: numberOrPoint smoothing: 2! ! !Form methodsFor: 'scaling, rotation' stamp: 'mt 8/25/2015 10:41'! scaledToSize: numberOrPoint smoothing: factor | scale newExtent | newExtent := numberOrPoint asPoint. newExtent = self extent ifTrue: [^ self copy]. (self height isZero or: [self width isZero]) ifTrue: [^ self species extent: newExtent depth: self depth]. scale := newExtent x / self width min: newExtent y / self height. ^ self magnify: self boundingBox by: scale smoothing: factor! ! "Graphics"! WeakFinalizersTest removeSelector: #testNewFinalizationSupported! WeakFinalizersTest removeSelector: #expectedFailures! "CollectionsTests"! Exception subclass: #UnhandledError instanceVariableNames: 'exception' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Exceptions'! !UnhandledError commentStamp: 'mt 8/25/2015 14:42' prior: 0! This is a wrapper for an unhandled error. Having this, process stepping is able to correctly fire other unhandled errors. See Process >> #stepToHome: for further explanations.! UnhandledError subclass: #UnhandledWarning instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Exceptions'! !Process methodsFor: 'changing suspended state' stamp: 'mt 8/25/2015 14:36' prior: 20168855! stepToHome: aContext "Resume self until the home of top context is aContext. Top context may be a block context. Catch any UnhandledErrors that are created while stepping, answering the relevant signalerContext if so. Note that this will cause weird effects if using through to step through UnhandledError code, but as the doctor ordered, don't do that; use over or into instead." ^Processor activeProcess evaluate: [| home anError | home := aContext home. [suspendedContext := suspendedContext step. home == suspendedContext home or: [home isDead]] whileFalse: [(suspendedContext selector == #signalForException: and: [(suspendedContext receiver isBehavior and: [ suspendedContext receiver includesBehavior: UnhandledError]) and: [anError := suspendedContext tempAt: 1. ((suspendedContext objectClass: anError) includesBehavior: Exception) and: [anError canSearchForSignalerContext]]]) ifTrue: [anError signalerContext ifNotNil: [:unhandledErrorSignalerContext| [unhandledErrorSignalerContext == suspendedContext] whileFalse: [self completeStep: suspendedContext]. "Give a debugger a chance to update its title to reflect the new exception" Notification new tag: {unhandledErrorSignalerContext. anError}; signal. ^unhandledErrorSignalerContext]]]. suspendedContext] onBehalfOf: self! ! !UnhandledError class methodsFor: 'as yet unclassified' stamp: 'mt 8/25/2015 14:42' prior: 55999530! signalForException: anError "Very important entry point for analysis stack when stepping in a debugging session. See Process >> #stepToHome: for further explanations." ^ self new exception: anError; signal! ! !UnhandledError methodsFor: 'accessing' stamp: 'ajh 9/4/2002 19:15' prior: 55996975! exception ^ exception! ! !UnhandledError methodsFor: 'accessing' stamp: 'ajh 9/4/2002 19:15' prior: 55997363! exception: anError exception := anError! ! "Kernel"! Object subclass: #WeakFinalizationList instanceVariableNames: 'first' classVariableNames: '' poolDictionaries: '' category: 'System-Finalization'! !WeakFinalizationList commentStamp: 'Igor.Stasenko 9/22/2010 21:09' prior: 54294419! IMPORTANT!!!!!! This class is a special object, recognized by VM. Its only purpose is to a) identify a special kind of objects who usually having a weak references but also having an instance of me held by first non-weak fixed slot (instance variable). b) a 'first' instance variable points to the head of a list of items, reported by VM which has weak references which became garbage during last garbage collection At my class side, there are some public behavior, which is used by finalization process to detect if VM supports new finalization scheme or should use the old one. Weak registry using #hasNewFinalization for switching to correct finalization logic, depending on VM it currently runs on. ! !WeakRegistry methodsFor: '*System-Finalization' stamp: 'eem 8/25/2015 10:36' prior: 20712364! finalizeValues "Finalize any values, which happen to stocked in our list, due to some weak references become garbage" | finalizer | self protected: [valueDictionary finalizeValues. finalizer := executors. executors := nil ]. finalizer ifNotNil: [finalizer do: [ :each | each finalizeValues]]! ! !WeakRegistry methodsFor: 'initialize-release' stamp: 'eem 8/25/2015 10:34' prior: 20701176! installFinalizer valueDictionary finalizer: [:executor| (executors ifNil: [executors := OrderedCollection new]) add: executor]! ! !Warning methodsFor: '*System-exceptionDescription' stamp: 'mt 8/25/2015 14:31' prior: 59265607! defaultAction "Inform the user of a Warning, giving them the choice of ignoring the warning (proceeding), debugging, or terminating the computation." UnhandledWarning signalForException: self! ! !UnhandledWarning methodsFor: '*System-priv handling' stamp: 'mt 8/25/2015 14:40'! defaultAction ^ ToolSet debugContext: self exception signalerContext label: 'Warning' contents: self exception messageText , '\\Select Proceed to continue, or close this window to cancel the operation.' withCRs! ! !WeakFinalizationList class methodsFor: 'vm capability test' stamp: 'eem 8/25/2015 10:33' prior: 54297068! hasNewFinalization ^false! ! !UnhandledError methodsFor: '*System-priv handling' stamp: 'mt 8/25/2015 14:43' prior: 55998869! defaultAction "The current computation is terminated. The cause of the error should be logged or reported to the user. If the program is operating in an interactive debugging environment the computation should be suspended and the debugger activated." ^ToolSet debugError: self exception! ! !WeakArray class methodsFor: '*System-Finalization' stamp: 'eem 8/25/2015 10:29' prior: 24564895! finalizationProcess [FinalizationSemaphore wait. FinalizationLock critical: [FinalizationDependents do: [ :weakDependent | weakDependent ifNotNil: [weakDependent finalizeValues]]] ifError: [:msg :rcvr | rcvr error: msg]] repeat! ! WeakFinalizationList class removeSelector: #initialize! WeakFinalizationList class removeSelector: #initTestPair! WeakFinalizationList class removeSelector: #checkTestPair! "System"! !CharacterSet methodsFor: 'comparison' stamp: 'ul 8/23/2015 23:56' prior: 33921212! = anObject self species == anObject species ifFalse: [ ^false ]. anObject size = tally ifFalse: [ ^false ]. ^self byteArrayMap = anObject byteArrayMap! ! !CharacterSet methodsFor: 'collection ops' stamp: 'ul 8/23/2015 23:57' prior: 33921503! add: aCharacter "I automatically become a WideCharacterSet if you add a wide character to myself" | index | (index := aCharacter asInteger + 1) <= 256 ifFalse: [ | wide | wide := WideCharacterSet new. wide addAll: self. wide add: aCharacter. self becomeForward: wide. ^aCharacter ]. (map at: index) = 1 ifFalse: [ map at: index put: 1. tally := tally + 1 ]. ^aCharacter! ! !CharacterSet methodsFor: 'collection ops' stamp: 'ul 8/23/2015 23:58' prior: 33922042! do: aBlock "evaluate aBlock with each character in the set" | index | tally >= 128 ifTrue: [ "dense" index := 0. [ (index := index + 1) <= 256 ] whileTrue: [ (map at: index) = 1 ifTrue: [ aBlock value: (Character value: index - 1) ] ]. ^self ]. "sparse" index := 0. [ (index := map indexOf: 1 startingAt: index + 1) = 0 ] whileFalse: [ aBlock value: (Character value: index - 1) ]. ! ! !CharacterSet methodsFor: 'collection ops' stamp: 'ul 8/23/2015 23:58' prior: 33922877! remove: aCharacter ifAbsent: aBlock | index | (index := aCharacter asciiValue + 1) <= 256 ifFalse: [ ^aBlock value ]. (map at: index) = 0 ifTrue: [ ^aBlock value ]. map at: index put: 0. tally := tally - 1. ^aCharacter! ! !CharacterSet methodsFor: 'collection ops' stamp: 'ul 8/23/2015 23:58' prior: 33923365! size ^tally! ! "Collections"! !Installer methodsFor: 'package-definitions' stamp: 'cmm 8/25/2015 11:04' prior: 33923656! maInstaller "Select from a family of related packages for application development." ^ { #ss -> 'MaInstaller'. 'Ma-Installer-Core' }! ! "Installer-Core"! !Form methodsFor: '*Morphic' stamp: 'mt 8/25/2015 10:43' prior: 65455861! scaledIntoFormOfSize: aNumberOrPoint ^ self scaledIntoFormOfSize: aNumberOrPoint smoothing: 8! ! !Form methodsFor: '*Morphic' stamp: 'mt 8/25/2015 10:42'! scaledIntoFormOfSize: aNumberOrPoint smoothing: factor "Scale and center the receiver into a form of a given size" | extent scaledForm result | extent := aNumberOrPoint asPoint. extent = self extent ifTrue: [^ self copy]. scaledForm := self scaledToSize: extent smoothing: factor. result := self species extent: extent depth: 32. result getCanvas translucentImage: scaledForm at: extent - scaledForm extent // 2. ^ result ! ! !SystemWindow methodsFor: 'panes' stamp: 'mt 8/25/2015 11:49' prior: 51394317! addMorph: aMorph fullFrame: aLayoutFrame "Add aMorph according to aLayoutFrame." super addMorph: aMorph fullFrame: aLayoutFrame. paneMorphs := paneMorphs copyReplaceFrom: 1 to: 0 with: (Array with: aMorph). aMorph isImageMorph ifFalse: [aMorph adoptPaneColor: self paneColor].! ! "Morphic"! !Debugger methodsFor: 'initialize' stamp: 'mt 8/25/2015 13:35' prior: 54869224! openNotifierContents: msgString label: label "Create, schedule and answer a notifier view with the given label and message. A notifier view shows just the message or the first several lines of the stack, with a menu that allows the user to open a full debugger if so desired." "NOTE: When this method returns, a new process has been scheduled to run the windows, and thus this notifier, but the previous active process has not been suspended. The sender will do this." | msg builder spec | Sensor flushKeyboard. savedCursor := Cursor currentCursor. Cursor currentCursor: Cursor normal. msg := (label beginsWith: 'Space is low') ifTrue: [self lowSpaceChoices, (msgString ifNil: [String empty])] ifFalse: [msgString]. builder := ToolBuilder default. spec := self buildNotifierWith: builder label: label message: msg. self expandStack. ^[builder openDebugger: spec] ensure: [errorWasInUIProcess := Project current spawnNewProcessIfThisIsUI: interruptedProcess] ! ! "Tools"! PluggableListMorph subclass: #PluggableListMorphPlus instanceVariableNames: 'dragItemSelector dropItemSelector wantsDropSelector getHelpSelector dragTypeSelector' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Morphic'! !PluggableListMorphPlus commentStamp: 'ar 7/15/2005 11:10' prior: 24621634! Extensions for PluggableListMorph needed by ToolBuilder! SimpleHierarchicalListMorph subclass: #PluggableTreeMorph instanceVariableNames: 'rootWrappers selectedWrapper getRootsSelector getChildrenSelector hasChildrenSelector getLabelSelector getIconSelector getSelectedPathSelector setSelectedParentSelector getHelpSelector dropItemSelector wantsDropSelector dragItemSelector dragTypeSelector nodeClass lastKeystrokeTime lastKeystrokes' classVariableNames: 'FilterByLabelsOnly MaximumSearchDepth' poolDictionaries: '' category: 'ToolBuilder-Morphic'! !PluggableTreeMorph commentStamp: 'ar 2/12/2005 04:38' prior: 53736077! A pluggable tree morph.! !PluggableListMorphPlus methodsFor: 'accessing' stamp: 'mt 6/10/2015 10:18'! dragTypeSelector ^dragTypeSelector! ! !PluggableListMorphPlus methodsFor: 'accessing' stamp: 'mt 6/10/2015 10:18'! dragTypeSelector: aSymbol dragTypeSelector := aSymbol.! ! !PluggableListMorphPlus methodsFor: 'drag and drop' stamp: 'mt 6/10/2015 10:20' prior: 24630236! startDrag: evt dragItemSelector ifNil:[^self]. evt hand hasSubmorphs ifTrue: [^ self]. [ | dragIndex draggedItem ddm | (self dragEnabled and: [model okToChange]) ifFalse: [^ self]. dragIndex := self rowAtLocation: evt position. dragIndex = 0 ifTrue:[^self]. draggedItem := model perform: dragItemSelector with: (self modelIndexFor: dragIndex). draggedItem ifNil:[^self]. ddm := TransferMorph withPassenger: draggedItem from: self. ddm dragTransferType: (self dragTypeSelector ifNil: [#dragTransferPlus] ifNotNil: [:s | self model perform: s with: (self modelIndexFor: dragIndex)]). evt hand grabMorph: ddm] ensure: [Cursor normal show. evt hand releaseMouseFocus: self]! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'mt 6/10/2015 10:05'! dragTypeSelector ^dragTypeSelector! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'mt 6/10/2015 10:04'! dragTypeSelector: aSymbol dragTypeSelector := aSymbol.! ! !PluggableTreeMorph methodsFor: 'morphic' stamp: 'mt 6/10/2015 10:06' prior: 53766005! startDrag: evt | ddm itemMorph passenger | self dragEnabled ifTrue: [itemMorph := scroller submorphs detect: [:any | any highlightedForMouseDown] ifNone: []]. (itemMorph isNil or: [evt hand hasSubmorphs]) ifTrue: [^ self]. itemMorph highlightForMouseDown: false. itemMorph ~= self selectedMorph ifTrue: [self setSelectedMorph: itemMorph]. passenger := self model perform: dragItemSelector with: itemMorph withoutListWrapper. passenger ifNotNil: [ddm := TransferMorph withPassenger: passenger from: self. ddm dragTransferType: (self dragTypeSelector ifNil: [#dragTransferPlus] ifNotNil: [:s | self model perform: s with: itemMorph withoutListWrapper]). Preferences dragNDropWithAnimation ifTrue: [self model dragAnimationFor: itemMorph transferMorph: ddm]. evt hand grabMorph: ddm]. evt hand releaseMouseFocus: self! ! "ToolBuilder-Morphic"! !CompiledMethod class methodsFor: 'constants' stamp: 'di 1/11/1999 22:13' prior: 31510700! fullFrameSize "CompiledMethod fullFrameSize" ^ LargeFrame! ! !CompiledMethod class methodsFor: 'constants' stamp: 'eem 8/25/2015 15:35'! maxNumLiterals "The current header format and the VM's interpretation of it allows for a maximum of 32767 literals." ^32767! ! !CompiledMethod class methodsFor: 'instance creation' stamp: 'ul 8/25/2015 22:43' prior: 31516432! newBytes: numberOfBytes trailerBytes: trailer nArgs: nArgs nTemps: nTemps nStack: stackSize nLits: nLits primitive: primitiveIndex "Answer an instance of me. The header is specified by the message arguments. The remaining parts are not as yet determined." | method pc | nArgs > 15 ifTrue: [^self error: 'Cannot compile -- too many arguments']. nTemps > 63 ifTrue: [^self error: 'Cannot compile -- too many temporary variables']. nLits > 32767 ifTrue: [^self error: 'Cannot compile -- too many literals']. method := trailer createMethod: numberOfBytes class: self header: (nArgs bitShift: 24) + (nTemps bitShift: 18) + ((nTemps + stackSize) > SmallFrame ifTrue: [1 bitShift: 17] ifFalse: [0]) + nLits + (primitiveIndex > 0 ifTrue: [1 bitShift: 16] ifFalse: [0]). primitiveIndex > 0 ifTrue: [pc := method initialPC. method at: pc + 0 put: method encoderClass callPrimitiveCode; at: pc + 1 put: (primitiveIndex bitAnd: 16rFF); at: pc + 2 put: (primitiveIndex bitShift: -8)]. ^method! ! !CompiledMethod class methodsFor: 'instance creation' stamp: 'ul 8/25/2015 22:43' prior: 31517572! newBytes: numberOfBytes trailerBytes: trailer nArgs: nArgs nTemps: nTemps nStack: stackSize nLits: nLits primitive: primitiveIndex flag: flag "Answer an instance of me. The header is specified by the message arguments. The remaining parts are not as yet determined." | method pc | nArgs > 15 ifTrue: [^self error: 'Cannot compile -- too many arguments']. nTemps > 63 ifTrue: [^self error: 'Cannot compile -- too many temporary variables']. nLits > 32767 ifTrue: [^self error: 'Cannot compile -- too many literals']. method := trailer createMethod: numberOfBytes class: self header: (nArgs bitShift: 24) + (nTemps bitShift: 18) + ((nTemps + stackSize) > SmallFrame ifTrue: [1 bitShift: 17] ifFalse: [0]) + nLits + (primitiveIndex > 0 ifTrue: [1 bitShift: 16] ifFalse: [0]) + (flag ifTrue: [1 bitShift: 29] ifFalse: [0]). primitiveIndex > 0 ifTrue: [pc := method initialPC. method at: pc + 0 put: method encoderClass callPrimitiveCode; at: pc + 1 put: (primitiveIndex bitAnd: 16rFF); at: pc + 2 put: (primitiveIndex bitShift: -8)]. ^method! ! !CompiledMethod class methodsFor: 'constants' stamp: 'ajh 7/18/2001 02:04' prior: 31512686! smallFrameSize ^ SmallFrame! ! "Kernel"! !EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 8/25/2015 15:38'! maxIndexableLiterals "This bytecode set can index up to 256 literals." ^256! ! !Encoder methodsFor: 'results' stamp: 'eem 8/25/2015 15:42' prior: 57068682! allLiterals addedSelectorAndMethodClassLiterals ifFalse: [addedSelectorAndMethodClassLiterals := true. "Put the optimized selectors in literals so as to browse senders more easily" optimizedSelectors := optimizedSelectors reject: [:e| literalStream originalContents hasLiteral: e]. optimizedSelectors isEmpty ifFalse: [ "Use one entry per literal if enough room, else make anArray" literalStream position + optimizedSelectors size + 2 >= self maxNumLiterals ifTrue: [self litIndex: optimizedSelectors asArray] ifFalse: [optimizedSelectors do: [:e | self litIndex: e]]]. "Add a slot for selector or MethodProperties" self litIndex: nil. self litIndex: self associationForClass]. ^literalStream contents! ! !Encoder methodsFor: 'encoding' stamp: 'eem 8/25/2015 15:45' prior: 57054455! litIndex: literal | p | p := literalStream position. p = self maxNumLiterals ifTrue: [self notify: 'More than ', self maxNumLiterals printString, ' literals referenced.\You must split or otherwise simplify this method.\The ' withCRs, (self maxNumLiterals + 1) printString, 'th literal is: ', literal printString. ^nil]. "Would like to show where it is in the source code, but that info is hard to get." literalStream nextPut: literal. ^p! ! !Encoder methodsFor: 'accessing' stamp: 'eem 8/25/2015 15:39'! maxIndexableLiterals "Answer the maximum number of literals supported by the receiver's bytecode set. This is a nominal value based on the Blue Book bytecode set; subclasses answer a more accurate value." ^63! ! !Encoder methodsFor: 'accessing' stamp: 'eem 8/25/2015 15:39'! maxNumLiterals ^CompiledMethod maxNumLiterals min: self maxIndexableLiterals! ! "Compiler"! !Class methodsFor: 'subclass creation' stamp: 'eem 8/25/2015 16:37'! ephemeronSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat "This is the standard initialization message for creating a new class as a subclass of an existing class (the receiver) in which the subclass is to have ephemeron semantics, i.e. where the object will be queued for finalization when the key (first) inst var is not reachable other than through the other fields of ephemerons with unreachable keys." ^ClassBuilder new superclass: self ephemeronSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat! ! !ClassBuilder methodsFor: 'public' stamp: 'eem 8/25/2015 16:42'! superclass: aClass ephemeronSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat "This is the standard initialization message for creating a new class as a subclass of an existing class (the receiver) in which the subclass is to have ephemeron semantics, i.e. where the object will be queued for finalization when the key (first) inst var is not reachable other than through the other fields of ephemerons with unreachable keys." | env | aClass isPointers ifFalse: [^self error: 'cannot make a pointer subclass of a class with non-pointer fields']. aClass instSize + (f subStrings: ' \' withCRs) size < 2 ifTrue: [^self error: 'cannot make an ephemeron class with less than two named instance varaibles']. env := CurrentEnvironment signal ifNil: [aClass environment]. ^self name: t inEnvironment: env subclassOf: aClass type: #ephemeron instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat! ! "Kernel"! !CompilerTest methodsFor: 'limits' stamp: 'eem 8/25/2015 16:00' prior: 33778318! testMaxLiterals "Document the maximum number of literals in a compiled method" | maxLiterals stringThatCanBeCompiled stringWithOneTooManyLiterals | "Why 6? It's rather implementation dependent. But the {... construct is compiled as (Array braceStream: size) nextPut: expr; ...; braceArray where nextPut: is a special selector. So one each for Array binding, #braceStream, #braceArray and the size, one for the selector and one for the methodClass makes 6." maxLiterals := thisContext method encoderClass new maxNumLiterals - 6. stringThatCanBeCompiled := '{ ', (String streamContents: [:strm | 1 to: maxLiterals do: [:e | strm nextPutAll: '''', e asString, '''', ' . ']]), '}'. stringWithOneTooManyLiterals := '{ ', (String streamContents: [:strm | 1 to: maxLiterals + 1 do: [:e | strm nextPutAll: '''', e asString, '''', ' . ']]), '}'. self assert: ((1 to: maxLiterals) collect: #printString) equals: (Compiler evaluate: stringThatCanBeCompiled). "If the following test fails, it means that the limit has been raised or eliminated, and this test should be updated to reflect the improvement." self should: [Compiler evaluate: stringWithOneTooManyLiterals] raise: Error. ! ! "Tests"! !ServerDirectory class methodsFor: 'server prefs' stamp: 'mt 8/26/2015 17:55' prior: 85400426! releaseExternalSettings "Release for server configurations" "ServerDirectory releaseExternalSettings" (Preferences valueOfFlag: #externalServerDefsOnly) ifTrue: [ self resetLocalProjectDirectories. Servers := Dictionary new]! ! "Network"! Object subclass: #Preferences instanceVariableNames: '' classVariableNames: 'DesktopColor Parameters' poolDictionaries: '' category: 'System-Preferences'! !Preferences commentStamp: 'eem 6/30/2015 15:10' prior: 21531352! A general mechanism to store preference choices. The default setup treats any symbol as a potential boolean flag; flags unknown to the preference dictionary are always answered as false. To open the control panel: PreferenceBrowser open To read how to use the panel (and how to make a preference be per-project): Preferences giveHelpWithPreferences All messages are on the class side. There are two kinds of preference definition, preference pragmas (which are preferred) and preferences local to Preferences. Preference Pragmas Preferences can be local to a class or system of classes using preference pragmas. Look at senders of #preference:category:description:type: and #preference:categoryList:description:type: for examples: (self systemNavigation browseAllSelect: [:m| #(preference:category:description:type: preference:categoryList:description:type:) anySatisfy: [:s| (m pragmaAt: s) notNil]]) With a preference pragma, the preference is typically kept in a class variable, local to the class whose method(s) contain(s) the pragma. Good style is to put the preference pragma in the accessor for the variable; see for example BitBlt class>>#subPixelRenderColorFonts. The pragma serves to declare the preference to Preferences. Preference-local Preferences To query a a preference: Preferences logDebuggerStackToFile or some people prefer the more verbose Preferences valueOfFlag: #logDebuggerStackToFile You can make up a new preference any time. Do not define a new message in Preferences class. Accessor methods are compiled automatically when you add a preference, either as as illustrated below, or by using To add a non-pragma preference (e.g. in the Postscript of a fileout): Preferences addPreference: #samplePreference categories: #(general browsing) default: true balloonHelp: 'This is an example of a preference added by a do-it' projectLocal: false changeInformee: nil changeSelector: nil. To change a preference programatically: Preferences disable: #logDebuggerStackToFile. Or to turn it on, Preferences enable: #logDebuggerStackToFile. ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'jmv 8/4/2009 15:09' prior: 21564257! aaFontsColormapDepth "Adjust balance between colored AA text quality (especially if subpixel AA is used) and space / performance. 5 is optimal quality. Each colorMap takes 128kB of RAM, and takes several seconds to build. 4 is a reasonable balance. Each colorMap takes 16kB of RAM and builds fast on a fast machine. 3 is good for slow hardware or memory restrictions. Each colorMap takes 2 kb of RAM." ^self valueOfFlag: #aaFontsColormapDepth ifAbsent: [4]! ! !Preferences class methodsFor: 'support - misc' stamp: 'sw 2/24/1999 12:26' prior: 21737925! acceptAnnotationsFrom: aSystemWindow "This intricate extraction is based on the precise structure of the annotation-request window. Kindly avert your eyes." | aList | aList := aSystemWindow paneMorphs first firstSubmorph submorphs collect: [:m | m contents asSymbol]. self defaultAnnotationRequests: aList ! ! !Preferences class methodsFor: 'add/remove - specific' stamp: 'mt 8/26/2015 17:26' prior: 21536872! addBooleanPreference: prefSymbol categories: categoryList default: defaultValue balloonHelp: helpString "Add an item repreesenting the given preference symbol to the system. Default view for this preference is boolean to keep backward compatibility" ^ self addPreference: prefSymbol categories: categoryList default: defaultValue balloonHelp: helpString projectLocal: false changeInformee: nil changeSelector: nil type: #Boolean! ! !Preferences class methodsFor: 'add/remove - specific' stamp: 'mt 8/26/2015 17:26' prior: 21540364! addBooleanPreference: prefSymbol category: categorySymbol default: defaultValue balloonHelp: helpString "Add an item repreesenting the given preference symbol to the system. Default view for this preference is boolean to keep backward compatibility" ^ self addPreference: prefSymbol categories: {categorySymbol} default: defaultValue balloonHelp: helpString projectLocal: false changeInformee: nil changeSelector: nil type: #Boolean! ! !Preferences class methodsFor: 'add/remove - specific' stamp: 'mt 8/26/2015 17:25' prior: 21541988! addColorPreference: prefSymbol categories: categoryList default: defaultValue balloonHelp: helpString "Add an item repreesenting the given preference symbol to the system. Default view for this preference is boolean to keep backward compatibility" ^ self addPreference: prefSymbol categories: categoryList default: defaultValue balloonHelp: helpString projectLocal: false changeInformee: nil changeSelector: nil type: #Color! ! !Preferences class methodsFor: 'add/remove - specific' stamp: 'mt 8/26/2015 17:25' prior: 21543611! addColorPreference: prefSymbol category: categorySymbol default: defaultValue balloonHelp: helpString "Add an item repreesenting the given preference symbol to the system. Default view for this preference is boolean to keep backward compatibility" ^ self addPreference: prefSymbol categories: {categorySymbol} default: defaultValue balloonHelp: helpString projectLocal: false changeInformee: nil changeSelector: nil type: #Color! ! !Preferences class methodsFor: 'add/remove - specific' stamp: 'mt 8/26/2015 17:25' prior: 21545227! addFontPreference: prefSymbol categories: categoryList default: defaultValue balloonHelp: helpString "Add an item repreesenting the given preference symbol to the system. Default view for this preference is boolean to keep backward compatibility" ^ self addPreference: prefSymbol categories: categoryList default: defaultValue balloonHelp: helpString projectLocal: false changeInformee: nil changeSelector: nil type: #Font! ! !Preferences class methodsFor: 'add/remove - specific' stamp: 'mt 8/26/2015 17:25' prior: 21546844! addFontPreference: prefSymbol category: categorySymbol default: defaultValue balloonHelp: helpString "Add an item repreesenting the given preference symbol to the system. Default view for this preference is boolean to keep backward compatibility" ^ self addPreference: prefSymbol categories: {categorySymbol} default: defaultValue balloonHelp: helpString projectLocal: false changeInformee: nil changeSelector: nil type: #Font! ! !Preferences class methodsFor: 'support - misc' stamp: 'sw 10/6/1999 15:20' prior: 21678368! addModelItemsToWindowMenu: aMenu aMenu addLine. aMenu add: 'restore default preference settings' target: self action: #chooseInitialSettings. aMenu add: 'restore default text highlighting' target: self action: #initializeTextHighlightingParameters! ! !Preferences class methodsFor: 'add/remove - specific' stamp: 'mt 8/26/2015 17:25' prior: 21548321! addNumericPreference: prefSymbol categories: categoryList default: defaultValue balloonHelp: helpString "Add an item repreesenting the given preference symbol to the system. " ^ self addPreference: prefSymbol categories: categoryList default: defaultValue balloonHelp: helpString projectLocal: false changeInformee: nil changeSelector: nil type: #Number! ! !Preferences class methodsFor: 'add/remove - specific' stamp: 'mt 8/26/2015 17:25' prior: 21549730! addNumericPreference: prefSymbol category: categorySymbol default: defaultValue balloonHelp: helpString "Add an item repreesenting the given preference symbol to the system." ^ self addPreference: prefSymbol categories: {categorySymbol} default: defaultValue balloonHelp: helpString projectLocal: false changeInformee: nil changeSelector: nil type: #Number! ! !Preferences class methodsFor: 'add/remove' stamp: 'topa 8/27/2015 23:35'! addPragmaPreference: pragma "Note that there will be no accessor method generated because the pragma's method does already govern that." | preference | ((pragma keyword beginsWith: #preference:) and: [self respondsTo: pragma keyword]) ifFalse: [ "no pragma pref to be defined. do nothing" ^ self]. self assert: pragma methodClass isMeta. preference := self perform: pragma keyword withArguments: pragma arguments. preference provider: pragma methodClass theNonMetaClass getter: pragma method selector setter: pragma method selector asMutator. self atomicUpdatePreferences: [ :copyOfDictionaryOfPreferences | copyOfDictionaryOfPreferences at: preference id put: preference]. ^ preference! ! !Preferences class methodsFor: 'add/remove - convenience' stamp: 'mt 8/26/2015 17:25' prior: 21550631! addPreference: prefSymbol categories: categoryList default: defaultValue balloonHelp: helpString "Add an item repreesenting the given preference symbol to the system." ^ self addPreference: prefSymbol categories: categoryList default: defaultValue balloonHelp: helpString projectLocal: false changeInformee: nil changeSelector: nil! ! !Preferences class methodsFor: 'add/remove - convenience' stamp: 'mt 8/26/2015 17:25' prior: 21551694! addPreference: prefSymbol categories: categoryList default: aValue balloonHelp: helpString projectLocal: localBoolean changeInformee: informeeSymbol changeSelector: aChangeSelector "Add an item representing the given preference symbol to the system." ^ self addPreference: prefSymbol categories: categoryList default: aValue balloonHelp: helpString projectLocal: localBoolean changeInformee: informeeSymbol changeSelector: aChangeSelector type: (self typeForValue: aValue) ! ! !Preferences class methodsFor: 'add/remove' stamp: 'mt 8/27/2015 09:29' prior: 21556747! addPreference: aName categories: categoryList default: aValue balloonHelp: helpString projectLocal: localBoolean changeInformee: informeeSymbol changeSelector: aChangeSelector type: aType "Add or replace a preference as indicated. Reuses the preexisting Preference object for this symbol, if there is one, so that UI artifacts that interact with it will remain valid." | newPreference aPreference | newPreference := Preference new name: aName asSymbol defaultValue: aValue helpString: helpString localToProject: localBoolean categoryList: categoryList changeInformee: informeeSymbol changeSelector: aChangeSelector type: aType; yourself. aPreference := preferencesDictionary at: newPreference name ifAbsent: [newPreference]. aPreference == newPreference ifTrue: "Atomically add the new preference to the dictionary." [self atomicUpdatePreferences: [:preferenceDictionaryCopy| preferenceDictionaryCopy at: newPreference name put: newPreference]] ifFalse: "Use the copyFrom: primitive to atomically update the existing preference." [aPreference copyFrom: newPreference]. self compileAccessorForPreference: aPreference. ^ aPreference! ! !Preferences class methodsFor: 'add/remove - convenience' stamp: 'mt 8/26/2015 17:25'! addPreference: prefSymbol category: categorySymbol default: defaultValue "Add the given preference, putting it in the given category, with the given default value, and with the given balloon help." ^ self addPreference: prefSymbol category: categorySymbol default: defaultValue balloonHelp: nil.! ! !Preferences class methodsFor: 'add/remove - convenience' stamp: 'mt 8/26/2015 17:25' prior: 21558498! addPreference: prefSymbol category: categorySymbol default: defaultValue balloonHelp: helpString "Add the given preference, putting it in the given category, with the given default value, and with the given balloon help." ^ self addPreference: prefSymbol categories: {categorySymbol} default: defaultValue balloonHelp: helpString.! ! !Preferences class methodsFor: 'add/remove - convenience' stamp: 'mt 8/27/2015 09:03'! addPreference: prefSymbol default: defaultValue ^ self addPreference: prefSymbol category: self unclassifiedCategory default: defaultValue balloonHelp: nil.! ! !Preferences class methodsFor: 'add/remove - specific' stamp: 'mt 8/26/2015 17:25' prior: 21560074! addTextPreference: prefSymbol categories: categoryList default: defaultValue balloonHelp: helpString "Add an item repreesenting the given preference symbol to the system. Default view for this preference is boolean to keep backward compatibility" ^ self addPreference: prefSymbol categories: categoryList default: defaultValue balloonHelp: helpString projectLocal: false changeInformee: nil changeSelector: nil type: #String! ! !Preferences class methodsFor: 'add/remove - specific' stamp: 'mt 8/26/2015 17:25' prior: 21561695! addTextPreference: prefSymbol category: categorySymbol default: defaultValue balloonHelp: helpString "Add an item repreesenting the given preference symbol to the system. Default view for this preference is boolean to keep backward compatibility" ^ self addPreference: prefSymbol categories: {categorySymbol} default: defaultValue balloonHelp: helpString projectLocal: false changeInformee: nil changeSelector: nil type: #String! ! !Preferences class methodsFor: 'accessing' stamp: 'mt 8/27/2015 10:41' prior: 21792912! allPreferenceObjects "Answer a list of all the Preference objects registered in the system" self flag: #deprecated. "mt: Use #allPreferences since all preferences are objects." ^ self allPreferences! ! !Preferences class methodsFor: 'accessing' stamp: 'mt 8/27/2015 10:40'! allPreferences ^preferencesDictionary values! ! !Preferences class methodsFor: 'support - misc' stamp: 'tfel 3/27/2010 13:34' prior: 21742979! annotationEditingWindow "Answer a window affording editing of annotations" | aPanel ins outs current aWindow aButton info standardHeight standardWidth | standardHeight := 200. standardWidth := (2 sqrt reciprocal * standardHeight) rounded. Smalltalk isMorphic ifFalse: [self error: 'annotations can be edited only in morphic']. aPanel := AlignmentMorph newRow extent: 2 * standardWidth @ standardHeight. ins := AlignmentMorph newColumn extent: standardWidth @ standardHeight. ins color: Color green muchLighter. ins enableDrop: true; beSticky. outs := AlignmentMorph newColumn extent: standardWidth @ standardHeight. outs color: Color red muchLighter. outs enableDrop: true; beSticky. aPanel addMorph: outs; addMorphFront: ins. outs position: ins position + (standardWidth @ 0). current := self defaultAnnotationRequests. info := self annotationInfo. current do: [:sym | | pair aMorph | pair := info detect: [:aPair | aPair first == sym]. aMorph := StringMorph new contents: pair first. aMorph setBalloonText: pair last. aMorph enableDrag: true. aMorph on: #startDrag send: #startDrag:with: to: aMorph. ins addMorphBack: aMorph]. info do: [:aPair | (current includes: aPair first) ifFalse: [| aMorph | aMorph := StringMorph new contents: aPair first. aMorph setBalloonText: aPair last. aMorph enableDrag: true. aMorph on: #startDrag send: #startDrag:with: to: aMorph. outs addMorph: aMorph]]. aPanel layoutChanged. aWindow := SystemWindowWithButton new setLabel: 'Annotations'. aButton := SimpleButtonMorph new target: Preferences; actionSelector: #acceptAnnotationsFrom:; arguments: (Array with: aWindow); label: 'apply'; borderWidth: 0; borderColor: Color transparent; color: Color transparent. aButton submorphs first color: Color blue. aButton setBalloonText: 'After moving all the annotations you want to the left (green) side, and all the ones you do NOT want to the right (pink) side, hit this "apply" button to have your choices take effect.'. aWindow buttonInTitle: aButton; adjustExtraButton. ^ aPanel wrappedInWindow: aWindow"Preferences annotationEditingWindow openInHand"! ! !Preferences class methodsFor: 'prefs - annotations' stamp: 'sw 7/12/2001 18:18' prior: 21746562! annotationInfo "Answer a list of pairs characterizing all the available kinds of annotations; in each pair, the first element is a symbol representing the info type, and the second element is a string providing the corresponding balloon help" ^ #( (timeStamp 'The time stamp of the last submission of the method.') (firstComment 'The first comment in the method, if any.') (masterComment 'The comment at the beginning of the supermost implementor of the method if any.') (documentation 'Comment at beginning of the method or, if it has none, comment at the beginning of a superclass''s implementation of the method') (messageCategory 'Which method category the method lies in') (sendersCount 'A report of how many senders there of the message.') (implementorsCount 'A report of how many implementors there are of the message.') (recentChangeSet 'The most recent change set bearing the method.') (allChangeSets 'A list of all change sets bearing the method.') (priorVersionsCount 'A report of how many previous versions there are of the method' ) (priorTimeStamp 'The time stamp of the penultimate submission of the method, if any'))! ! !Preferences class methodsFor: 'updating - system' stamp: 'sw 6/12/2001 20:17' prior: 21796223! annotationPanesChanged "The setting of the annotationPanes preference changed; react. Formerly, we replaced prototypes in flaps but this is no longer necessary"! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'nice 12/27/2009 03:11' prior: 21566741! attemptToRestoreClassicFonts "If certain fonts formerly used in early versions of Squeak happen to be present in the image, restore them to their corresponding roles. Not called by any other method -- intended to be invoked via do-it, possibly in a postscript" "Preferences attemptToRestoreClassicFonts" #( (setButtonFontTo: NewYork 12) (setCodeFontTo: NewYork 12) (setFlapsFontTo: ComicBold 16) (setEToysFontTo: ComicBold 16) (setListFontTo: NewYork 12) (setMenuFontTo: NewYork 12) (setWindowTitleFontTo: NewYork 15) (setSystemFontTo: NewYork 12)) do: [:triplet | | aTextStyle | (aTextStyle := TextStyle named: triplet second) ifNotNil: [self perform: triplet first with: (aTextStyle fontOfSize: triplet third). Transcript cr; show: triplet second, ' installed as ', (triplet first copyFrom: 4 to: triplet first size - 3)]]! ! !Preferences class methodsFor: 'support - misc' stamp: 'dgd 8/31/2003 18:07' prior: 21624149! automaticFlapLayoutString "Answer a string for the automaticFlapLayout menu item" ^ (self automaticFlapLayout ifTrue: [''] ifFalse: ['']) , 'automatic flap layout' translated! ! !Preferences class methodsFor: 'prefs - misc' stamp: 'dgd 9/7/2004 18:35' prior: 21678947! balloonHelpDelayTime "Answer the number of milliseconds before a balloon help should be put up on morphs." ^ Parameters at: #balloonHelpDelayTime ifAbsent: [800]! ! !Preferences class methodsFor: 'prefs - misc' stamp: 'sw 2/15/1999 19:44' prior: 21747938! borderColorWhenRunning ^ Color green! ! !Preferences class methodsFor: 'themes - tools' stamp: 'fbs 12/6/2013 20:03' prior: 21679952! browseThemes "Open up a message-category browser on the theme-defining methods" ToolSet browse: Preferences class selector: #outOfTheBox.! ! !Preferences class methodsFor: 'prefs - text' stamp: 'lr 7/12/2006 09:25' prior: 21859667! caretWidth ^ Parameters at: #caretWidth! ! !Preferences class methodsFor: 'prefs - text' stamp: 'lr 7/12/2006 09:25' prior: 21859959! caretWidth: anInteger ^ Parameters at: #caretWidth put: anInteger! ! !Preferences class methodsFor: 'support' stamp: 'mt 8/27/2015 10:42'! categoryList "Return all available categories. No duplicates." | aSet | aSet := Set new. self allPreferences do: [ :aPreference | aSet addAll: ( aPreference categoryList collect: [ :aCategory | aCategory asSymbol ]) ]. aSet add: self unclassifiedCategory. ^aSet! ! !Preferences class methodsFor: 'support' stamp: 'mt 8/27/2015 09:09'! categoryListOfPreference: prefSymbol "Return a list of all categories in which the preference occurs" ^ (self preferenceAt: prefSymbol ifAbsent: [^ Error signal: 'Preference not found!!']) categoryList! ! !Preferences class methodsFor: 'prefs - window colors' stamp: 'mt 8/27/2015 10:42' prior: 21868063! checkForWindowColors (self allPreferences noneSatisfy: [:aPref | aPref name endsWith: 'WindowColor']) ifTrue: [self installBrightWindowColors].! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'bp 6/13/2004 17:20' prior: 21567839! chooseBalloonHelpFont BalloonMorph chooseBalloonFont! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'tween 8/7/2007 01:59' prior: 21568829! chooseCodeFont "Not currently sent, but once protocols are sorted out so that we can disriminate on whether a text object being launched is for code or not, will be reincorporated" self chooseFontWithPrompt: 'Code font...' translated andSendTo: self withSelector: #setCodeFontTo: highlightSelector: #standardCodeFont.! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'tween 8/7/2007 02:00' prior: 21569857! chooseEToysFont "present a menu with the possible fonts for the eToys" self chooseFontWithPrompt: 'eToys font...' translated andSendTo: self withSelector: #setEToysFontTo: highlightSelector: #standardEToysFont! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'tween 8/7/2007 02:00' prior: 21570816! chooseEToysTitleFont "present a menu with the possible fonts for the eToys" self chooseFontWithPrompt: 'eToys Title font...' translated andSendTo: self withSelector: #setEToysTitleFontTo: highlightSelector: #standardEToysTitleFont! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'tween 8/7/2007 02:00' prior: 21571631! chooseFlapsFont self chooseFontWithPrompt: 'Flaps font...' translated andSendTo: self withSelector: #setFlapsFontTo: highlightSelector: #standardFlapFont! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'ar 8/30/2009 16:44' prior: 21572194! chooseFontWithPrompt: aPrompt andSendTo: aReceiver withSelector: aSelector highlightSelector: highlightSelector ^UIManager default chooseFont: aPrompt for: aReceiver setSelector: aSelector getSelector: highlightSelector ! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'tween 8/7/2007 02:00' prior: 21573137! chooseHaloLabelFont "present a menu with the possible fonts for label in halo" self chooseFontWithPrompt: 'Halo Label font...' andSendTo: self withSelector: #setHaloLabelFontTo: highlightSelector: #standardHaloLabelFont! ! !Preferences class methodsFor: 'initialization' stamp: 'mt 8/27/2015 10:42' prior: 21664492! chooseInitialSettings "Restore the default choices for all of the standard Preferences." self allPreferences do: [:aPreference | aPreference restoreDefaultValue]. Project current installProjectPreferences! ! !Preferences class methodsFor: 'prefs - text' stamp: 'sw 9/6/2000 18:45' prior: 21860567! chooseInsertionPointColor "Let the user indicate what color he wishes to have used for insertion points in text" ColorPickerMorph new choseModalityFromPreference; sourceHand: self currentHand; target: self; selector: #insertionPointColor:; originalColor: self insertionPointColor; putUpFor: self currentHand near: self currentHand cursorBounds! ! !Preferences class methodsFor: 'prefs - text' stamp: 'sw 12/7/2001 00:44' prior: 21861465! chooseKeyboardFocusColor "Let the user indicate what color he wishes to have used for keyboard-focus feedback" ColorPickerMorph new choseModalityFromPreference; sourceHand: self currentHand; target: self; selector: #keyboardFocusColor:; originalColor: self keyboardFocusColor; putUpFor: self currentHand near: self currentHand cursorBounds! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'tween 8/7/2007 02:01' prior: 21573946! chooseListFont self chooseFontWithPrompt: 'List font...' translated andSendTo: self withSelector: #setListFontTo: highlightSelector: #standardListFont! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'tween 8/7/2007 02:01' prior: 21574688! chooseMenuFont self chooseFontWithPrompt: 'Menu font...' translated andSendTo: self withSelector: #setMenuFontTo: highlightSelector: #standardMenuFont! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'tween 8/7/2007 02:01' prior: 21575458! chooseStandardButtonFont self chooseFontWithPrompt: 'Button font...' translated andSendTo: self withSelector: #setButtonFontTo: highlightSelector: #standardButtonFont ! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'tween 8/7/2007 02:01' prior: 21576258! chooseSystemFont self chooseFontWithPrompt: 'Default font...' translated andSendTo: self withSelector: #setSystemFontTo: highlightSelector: #standardSystemFont! ! !Preferences class methodsFor: 'prefs - text' stamp: 'sw 9/6/2000 18:45' prior: 21862318! chooseTextHighlightColor "Let the user choose the text-highlight color" ColorPickerMorph new choseModalityFromPreference; sourceHand: self currentHand; target: self; selector: #textHighlightColor:; originalColor: self textHighlightColor; putUpFor: self currentHand near: self currentHand cursorBounds! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'tween 8/7/2007 02:01' prior: 21577042! chooseWindowTitleFont self chooseFontWithPrompt: 'Window Title font...' translated andSendTo: self withSelector: #setWindowTitleFontTo: highlightSelector: #windowTitleFont! ! !Preferences class methodsFor: 'prefs - halos' stamp: 'sw 12/30/2004 01:42' prior: 21635196! classicHaloSpecs "Non-iconic halos with traditional placements" "Preferences installClassicHaloSpecs" "Preferences resetHaloSpecifications" " <- will result in the standard default halos being reinstalled" "NB: listed below in clockwise order" ^ #( " selector horiz vert color info icon key --------- ------ ----------- ------------------------------- ---------------" (addMenuHandle: left top (red) none) (addDismissHandle: leftCenter top (red muchLighter) 'Halo-Dismiss') (addGrabHandle: center top (black) none) (addDragHandle: rightCenter top (brown) none) (addDupHandle: right top (green) none) (addMakeSiblingHandle: right top (green muchDarker) 'Halo-Dup') (addDebugHandle: right topCenter (blue veryMuchLighter) none) (addPoohHandle: right center (white) none) (addPaintBgdHandle: right center (lightGray) none) (addRepaintHandle: right center (lightGray) none) (addGrowHandle: right bottom (yellow) none) (addScaleHandle: right bottom (lightOrange) none) (addFontEmphHandle: rightCenter bottom (lightBrown darker) none) (addFontStyleHandle: center bottom (lightRed) none) (addFontSizeHandle: leftCenter bottom (lightGreen) none) (addRecolorHandle: right bottomCenter (magenta darker) none) (addRotateHandle: left bottom (blue) none)) ! ! !Preferences class methodsFor: 'prefs - halos' stamp: 'hpt 9/24/2004 23:34' prior: 21636899! classicHalosInForce ^ (self preferenceAt: #haloTheme) preferenceValue == #classicHaloSpecs! ! !Preferences class methodsFor: 'updating - system' stamp: 'em 3/24/2005 15:34' prior: 21796936! classicTilesSettingToggled "The current value of the largeTiles flag has changed; now react" Smalltalk isMorphic ifTrue: [Preferences universalTiles ifFalse: [self inform: 'note that this will only have a noticeable effect if the universalTiles preference is set to true, which it currently is not' translated] ifTrue: [World recreateScripts]]! ! !Preferences class methodsFor: 'initialization' stamp: 'fbs 4/17/2013 17:08' prior: 21910216! cleanUp self removeObsolete.! ! !Preferences class methodsFor: 'prefs - misc' stamp: 'programmatic 7/15/1999 09:55' prior: 21659989! cmdKeysInText "compiled programatically -- return hard-coded preference value" ^ true! ! !Preferences class methodsFor: 'private' stamp: 'mt 8/27/2015 09:27'! compileAccessorForPreference: aPreference "Compile an accessor method for the given preference" self class compileSilently: ( '{1} ^self valueOfFlag: {2} ifAbsent: [ {3} ]' format: { aPreference name asString. aPreference name asSymbol printString. aPreference defaultValue storeString }) classified: '*autogenerated - standard queries'! ! !Preferences class methodsFor: 'private' stamp: 'mt 8/27/2015 09:28'! compileAccessorForPreferenceNamed: name value: value "Compile a method that returns a simple true or false (depending on the value of aBoolean) when Preferences is sent prefName as a message" self class compileSilently: ( '{1} ^{2}' format: { name asString. value storeString }) classified: 'prefs - misc'. "Preferences compileAccessorForPreferenceNamed: #testing value: false"! ! !Preferences class methodsFor: 'prefs - halos' stamp: 'laza 3/24/2000 16:05' prior: 21639687! customHaloSpecs "Intended for you to modify to suit your personal preference. What is implemented in the default here is just a skeleton; in comment at the bottom of this method are some useful lines you may wish to paste in to the main body here, possibly modifying positions, colors, etc.. Note that in this example, we include: Dismiss handle, at top-left Menu handle, at top-right Resize handle, at bottom-right Rotate handle, at bottom-left Drag handle, at top-center Recolor handle, at left-center. (this one is NOT part of the standard formulary -- it is included here to illustrate how to add non-standard halos) Note that the optional handles for specialized morphs, such as Sketch, Text, PasteUp, are also included" ^ #( (addDismissHandle: left top (red muchLighter) 'Halo-Dismiss') (addMenuHandle: right top (red) 'Halo-Menu') (addDragHandle: center top (brown) 'Halo-Drag') (addGrowHandle: right bottom (yellow) 'Halo-Scale') (addScaleHandle: right bottom (lightOrange) 'Halo-Scale') (addRecolorHandle: left center (green muchLighter lighter) 'Halo-Recolor') (addPaintBgdHandle: right center (lightGray) 'Halo-Paint') (addRepaintHandle: right center (lightGray) 'Halo-Paint') (addFontSizeHandle: leftCenter bottom (lightGreen) 'Halo-FontSize') (addFontStyleHandle: center bottom (lightRed) 'Halo-FontStyle') (addFontEmphHandle: rightCenter bottom (lightBrown darker) 'Halo-FontEmph') (addRotateHandle: left bottom (blue) 'Halo-Rot') (addDebugHandle: right topCenter (blue veryMuchLighter) 'Halo-Debug') (addPoohHandle: right center (white) 'Halo-Pooh') ) " Other useful handles... selector horiz vert color info icon key --------- ------ ----------- ------------------------------- --------------- (addTileHandle: left bottomCenter (lightBrown) 'Halo-Tile') (addViewHandle: left center (cyan) 'Halo-View') (addGrabHandle: center top (black) 'Halo-Grab') (addDragHandle: rightCenter top (brown) 'Halo-Drag') (addDupHandle: right top (green) 'Halo-Dup') (addHelpHandle: center bottom (lightBlue) 'Halo-Help') (addFewerHandlesHandle: left topCenter (paleBuff) 'Halo-FewerHandles') (addPaintBgdHandle: right center (lightGray) 'Halo-Paint') (addRepaintHandle: right center (lightGray) 'Halo-Paint') " ! ! !Preferences class methodsFor: 'prefs - halos' stamp: 'hpt 9/24/2004 23:34' prior: 21642471! customHalosInForce ^ (self preferenceAt: #haloTheme) preferenceValue == #customHaloSpecs! ! !Preferences class methodsFor: 'prefs - window colors' stamp: 'mt 8/27/2015 10:42' prior: 21868733! darkenStandardWindowPreferences "Make all window-color preferences one shade darker" (self allPreferences select: [:aPref | (aPref name endsWith: 'WindowColor') and: [aPref preferenceValue isColor]]) do: [:aPref | aPref preferenceValue: aPref preferenceValue darker]. "Preferences darkenStandardWindowPreferences" ! ! !Preferences class methodsFor: 'prefs - misc' stamp: 'sw 12/1/1999 13:04' prior: 21660466! debugMenuItemsInvokableFromScripts "If true, then items occurring in an object's debug menu will be included in the alternatives offered as arguments to a doMenuItem: tile in the scripting system" ^ false! ! !Preferences class methodsFor: 'prefs - annotations' stamp: 'mt 8/27/2015 10:03'! defaultAnnotationInfo ^ #(timeStamp messageCategory implementorsCount allChangeSets)! ! !Preferences class methodsFor: 'prefs - annotations' stamp: 'sw 2/17/1999 00:40' prior: 21748283! defaultAnnotationRequests ^ Parameters at: #MethodAnnotations ifAbsent: [self setDefaultAnnotationInfo] "Preferences annotationInfo"! ! !Preferences class methodsFor: 'prefs - annotations' stamp: 'sw 2/8/1999 10:14' prior: 21748673! defaultAnnotationRequests: newList ^ Parameters at: #MethodAnnotations put: newList! ! !Preferences class methodsFor: 'prefs - misc' stamp: 'sma 6/1/2000 12:08' prior: 21749174! defaultAuthorName "Answer the author name to be planted, by default, in a changeset-preamble template. You can hard-code this to hold your name, thus saving you time when writing the preambles of subsequent changesets" ^ Utilities authorName! ! !Preferences class methodsFor: 'prefs - misc' stamp: 'sw 2/1/2000 14:05' prior: 21749802! defaultPaintingExtent "Answer the preferred size for the onion-skin paint area when launching a new painting within a paste-up morph. Feel free to change the parameters to suit your configuration." ^ 800 @ 600! ! !Preferences class methodsFor: 'defaults' stamp: 'kfr 5/5/2015 18:21' prior: 21707524! defaultValueTableForCurrentRelease "Answer a table defining default values for all the preferences in the release. Returns a list of (pref-symbol, boolean-symbol) pairs" ^ #( (abbreviatedBrowserButtons false) (alternativeBrowseIt false) (annotationPanes false) (areaFillsAreTolerant false) (areaFillsAreVeryTolerant false) (automaticFlapLayout true) (automaticKeyGeneration false) (automaticPlatformSettings true) (automaticViewerPlacement true) (balloonHelpEnabled true) (balloonHelpInMessageLists false) (batchPenTrails false) (capitalizedReferences true) (caseSensitiveFinds false) (cautionBeforeClosing false) (changeSetVersionNumbers true) (checkForSlips true) (checkForUnsavedProjects true) (classicNavigatorEnabled false) (cmdDotEnabled true) (collapseWindowsInPlace false) (compactViewerFlaps false) (compressFlashImages false) (confirmFirstUseOfStyle true) (conversionMethodsAtFileOut false) (debugHaloHandle true) (debugPrintSpaceLog false) (debugShowDamage false) (decorateBrowserButtons true) (diffsInChangeList true) (diffsWithPrettyPrint false) (dismissAllOnOptionClose false) (dragNDropWithAnimation false) (eToyFriendly false) (eToyLoginEnabled false) (enableLocalSave true) (extractFlashInHighQuality true) (extractFlashInHighestQuality false) (fastDragWindowForMorphic true) (fenceEnabled true) (fullScreenLeavesDeskMargins true) (haloTransitions false) (higherPerformance false) (honorDesktopCmdKeys true) (includeSoundControlInNavigator false) (infiniteUndo false) (logDebuggerStackToFile true) (magicHalos false) (menuButtonInToolPane false) (menuColorFromWorld false) (menuKeyboardControl false) (modalColorPickers true) (mouseOverForKeyboardFocus false) (mouseOverHalos false) (mvcProjectsAllowed true) (navigatorOnLeftEdge true) (noviceMode false) (okToReinitializeFlaps true) (optionalButtons true) (passwordsOnPublish false) (personalizedWorldMenu true) (postscriptStoredAsEPS false) (projectViewsInWindows true) (projectZoom true) (projectsSentToDisk false) (propertySheetFromHalo false) (readDocumentAtStartup true) (restartAlsoProceeds false) (reverseWindowStagger true) (roundedMenuCorners true) (roundedWindowCorners true) (scrollBarsNarrow false) (scrollBarsOnRight true) (gradientScrollBars true) (securityChecksEnabled false) (selectiveHalos false) (showBoundsInHalo false) (showDirectionForSketches false) (showDirectionHandles false) (showFlapsWhenPublishing false) (showProjectNavigator false) (showSecurityStatus true) (showSharedFlaps true) (signProjectFiles true) (simpleMenus false) (smartUpdating true) (startInUntrustedDirectory false) (systemWindowEmbedOK false) (tileTranslucentDrag true) (timeStampsInMenuTitles true) (turnOffPowerManager false) (twentyFourHourFileStamps true) (typeCheckingInTileScripting true) (uniTilesClassic true) (uniqueNamesInHalos false) (universalTiles false) (unlimitedPaintArea false) (useButtonPropertiesToFire false) (useUndo true) (viewersInFlaps true) (warnAboutInsecureContent true) (warnIfNoChangesFile true) (warnIfNoSourcesFile true)) " Preferences defaultValueTableForCurrentRelease do: [:pair | (Preferences preferenceAt: pair first ifAbsent: [nil]) ifNotNilDo: [:pref | pref defaultValue: (pair last == true)]]. Preferences chooseInitialSettings. "! ! !Preferences class methodsFor: 'prefs - misc' stamp: 'dgd 9/5/2004 16:17' prior: 21673444! defaultWorldColor ^ Parameters at: #defaultWorldColor ifAbsent: [ Color r: 0.937 g: 0.937 b: 0.937 ]. ! ! !Preferences class methodsFor: 'prefs - misc' stamp: 'jhm 10/15/97 17:31' prior: 21750574! desktopColor "Answer the desktop color. Initialize it if necessary." DesktopColor == nil ifTrue: [DesktopColor := Color gray]. ^ DesktopColor ! ! !Preferences class methodsFor: 'prefs - misc' stamp: 'jhm 10/15/97 17:31' prior: 21751164! desktopColor: aColor "Record a new desktop color preference." DesktopColor := aColor. ! ! !Preferences class methodsFor: 'prefs - misc' stamp: 'sw 9/6/2000 05:26' prior: 21661147! desktopMenuTitle "Answer the title to be used for the 'meta menu'. For now, you can hard-code this, later someone should make this be a parameter the user can easily change. sw 9/6/2000" ^ 'World' "This is what it has always been" "^ 'Desktop' ^ 'Squeak' ^ 'Mike''s Control Panel'"! ! !Preferences class methodsFor: 'get/set - flags' stamp: 'mt 8/26/2015 17:34' prior: 21625922! disable: aSymbol "Shorthand access to enabling a preference of the given name. If there is none in the image, conjure one up" ^ self setFlag: aSymbol toValue: false! ! !Preferences class methodsFor: 'initialization - misc' stamp: 'mt 8/27/2015 09:30' prior: 21763609! 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 compileAccessorForPreferenceNamed: #cmdGesturesEnabled value: false. "No halos, etc." self compileAccessorForPreferenceNamed: #cmdKeysInText value: false. "No user commands invokable via cmd-key combos in text editor" self enable: #noviceMode. "No control-menu" self disable: #warnIfNoSourcesFile. self disable: #warnIfNoChangesFile. Smalltalk saveAs! ! !Preferences class methodsFor: 'updating - system' stamp: 'ar 7/21/2010 20:20' prior: 21798194! displaySizeChanged self flag: #todo. "only change font on small-land image" self smallLandFonts. self tinyDisplay ifTrue: [self enable: #scrollBarsNarrow] ifFalse: [self disable: #scrollBarsNarrow]. self tinyDisplay ifTrue:[self disable: #biggerHandles] ifFalse:[self enable: #biggerHandles]! ! !Preferences class methodsFor: 'get/set' stamp: 'topa 8/27/2015 23:45' prior: 21626697! doesNotUnderstand: aMessage "Interpret unary message selectors as preference id." ^ aMessage arguments size > 0 ifTrue: [super doesNotUnderstand: aMessage] ifFalse: [ self valueOfPreference: aMessage selector ifAbsent: [super doesNotUnderstand: aMessage]]! ! !Preferences class methodsFor: 'updating - system' stamp: 'sw 4/12/2001 01:31' prior: 21798820! eToyFriendlyChanged "The eToyFriendly preference changed; React" ScriptingSystem customizeForEToyUsers: Preferences eToyFriendly! ! !Preferences class methodsFor: 'support - misc' stamp: 'sw 6/13/2001 19:40' prior: 21752026! editAnnotations "Put up a window that allows the user to edit annotation specifications" | aWindow | self currentWorld addMorphCentered: (aWindow := self annotationEditingWindow). aWindow activateAndForceLabelToShow "Preferences editAnnotations" ! ! !Preferences class methodsFor: 'prefs - halos' stamp: 'ar 9/27/2005 20:32' prior: 21642802! editCustomHalos ToolSet browse: Preferences class selector: #customHaloSpecs! ! !Preferences class methodsFor: 'get/set - flags' stamp: 'mt 8/26/2015 17:34' prior: 21629463! enable: aSymbol "Shorthand access to enabling a preference of the given name. If there is none in the image, conjure one up" ^ self setFlag: aSymbol toValue: true! ! !Preferences class methodsFor: 'initialization - misc' stamp: 'mt 8/27/2015 09:30' prior: 21765702! enableProgrammerFacilities "Meant as a one-touch recovery from a #disableProgrammerFacilities call." "Preferences enableProgrammerFacilities" self enable: #cmdDotEnabled. self compileAccessorForPreferenceNamed: #cmdGesturesEnabled value: true. self compileAccessorForPreferenceNamed: #cmdKeysInText value: true. self disable: #noviceMode. self enable: #warnIfNoSourcesFile. self enable: #warnIfNoChangesFile.! ! !Preferences class methodsFor: 'prefs - misc' stamp: 'sw 7/13/2001 21:34' prior: 21628272! enableProjectNavigator "Answer whether the project-navigator menu item should be enabled" ^ true! ! !Preferences class methodsFor: 'support - file list services' stamp: 'kfr 4/28/2015 06:59' prior: 21918339! fileReaderServicesForFile: fullName suffix: suffix ^(suffix = 'prefs') | (suffix = '*') ifTrue: [ self services ] ifFalse: [ #() ]! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'kfr 4/29/2015 12:15' prior: 21586989! fontConfigurationMenu | aMenu | aMenu := MenuMorph new defaultTarget: Preferences. ^self fontConfigurationMenu: aMenu. ! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'kfr 4/29/2015 16:47' prior: 21587190! fontConfigurationMenu: aMenu aMenu removeAllMorphs. aMenu addTitle: 'Standard System Fonts' translated. aMenu addStayUpIcons. aMenu add: 'default text font...' translated action: #chooseSystemFont. aMenu lastItem font: Preferences standardDefaultTextFont. aMenu balloonTextForLastItem: 'Choose the default font to be used for code and in workspaces, transcripts, etc.' translated. aMenu add: 'list font...' translated action: #chooseListFont. aMenu lastItem font: Preferences standardListFont. aMenu balloonTextForLastItem: 'Choose the font to be used in list panes' translated. aMenu add: 'flaps font...' translated action: #chooseFlapsFont. aMenu lastItem font: Preferences standardFlapFont. aMenu balloonTextForLastItem: 'Choose the font to be used on textual flap tabs' translated. aMenu add: 'eToys font...' translated action: #chooseEToysFont. aMenu lastItem font: Preferences standardEToysFont. aMenu balloonTextForLastItem: 'Choose the font to be used on eToys environment' translated. aMenu add: 'eToys title font...' translated action: #chooseEToysTitleFont. aMenu lastItem font: Preferences standardEToysTitleFont. aMenu balloonTextForLastItem: 'Choose the font to be used in titles on eToys environment' translated. aMenu add: 'halo label font...' translated action: #chooseHaloLabelFont. aMenu lastItem font: Preferences standardHaloLabelFont. aMenu balloonTextForLastItem: 'Choose the font to be used on labels ih halo' translated. aMenu add: 'menu font...' translated action: #chooseMenuFont. aMenu lastItem font: Preferences standardMenuFont. aMenu balloonTextForLastItem: 'Choose the font to be used in menus' translated. aMenu add: 'window-title font...' translated action: #chooseWindowTitleFont. aMenu lastItem font: Preferences windowTitleFont. aMenu balloonTextForLastItem: 'Choose the font to be used in window titles.' translated. aMenu add: 'balloon-help font...' translated action: #chooseBalloonHelpFont. aMenu lastItem font: Preferences standardBalloonHelpFont. aMenu balloonTextForLastItem: 'choose the font to be used when presenting balloon help.' translated. aMenu add: 'code font...' translated action: #chooseCodeFont. aMenu lastItem font: Preferences standardCodeFont. aMenu balloonTextForLastItem: 'Choose the font to be used in code panes.' translated. aMenu add: 'button font...' translated action: #chooseStandardButtonFont. aMenu lastItem font: Preferences standardButtonFont. aMenu balloonTextForLastItem: 'Choose the font to be used in buttons.' translated. aMenu addLine. aMenu add: 'demo mode' translated action: #setDemoFonts. aMenu balloonTextForLastItem: 'Set Fonts usable for giving a presentation' translated. aMenu addLine. aMenu add: 'restore default font choices' translated action: #restoreDefaultFonts. aMenu balloonTextForLastItem: 'Use the standard system font defaults' translated. aMenu add: 'print default font choices' translated action: #printStandardSystemFonts. aMenu balloonTextForLastItem: 'Print the standard system font defaults to the Transcript' translated. aMenu addLine. aMenu add: 'refresh this menu' translated target: self selector: #fontConfigurationMenu: argument: aMenu. aMenu balloonTextForLastItem: 'Update this menu to reflect the current fonts' translated. MenuIcons decorateMenu: aMenu. ^ aMenu! ! !Preferences class methodsFor: 'support' stamp: 'mt 8/27/2015 10:42' prior: 21720165! giveHelpWithPreferences "Open up a workspace with explanatory info in it about Preferences" | aString | aString := String streamContents: [:aStream | aStream nextPutAll: 'Many aspects of the system are governed by the settings of various "Preferences". Click on any of brown tabs at the top of the panel to see all the preferences in that category. Or type in to the box above the Search button, then hit Search, and all Preferences matching whatever you typed in will appear in the "search results" category. A preference is considered to match your search if either its name matches the characters *or* if anything in the balloon help provided for the preferences matches the search text. To find out more about any particular Preference, hold the mouse over it for a moment and balloon help will appear. Also, a complete list of all the Preferences, with documentation for each, is included below. Preferences whose names are in shown in bold in the Preferences Panel are designated as being allowed to vary from project to project; those whose name are not in bold are "global", which is to say, they apply equally whatever project you are in. Click on the name of any preference to get a menu which allows you to *change* whether the preference should vary from project to project or should be global, and also allows you to browse all the senders of the preference, and to discover all the categories under which the preference has been classified, and to be handed a button that you can drop wherever you please that will control the preference. If you like all your current Preferences settings, you may wish to hit the "Save Current Settings as my Personal Preferences" button. Once you have done that, you can at any point in the future hit "Restore my Personal Preferences" and all your saved settings will get restored immediately. Also, you can use "themes" to set multiple preferences all at once; click on the "change theme..." button in the Squeak flap or in the Preferences panel, or seek out the themes item in the Appearance menu.' translated. aStream cr; cr; nextPutAll: '-----------------------------------------------------------------'; cr; cr; nextPutAll: 'Alphabetical listing of all Preferences' translated; cr; cr. (Preferences allPreferences asSortedCollection: [:a :b | a name < b name]) do: [:pref | | aHelpString | aStream nextPutAll: pref name; cr. aHelpString := pref helpString translated. (aHelpString beginsWith: pref name) ifTrue: [aHelpString := aHelpString copyFrom: (pref name size ) to: aHelpString size]. aHelpString := (aHelpString copyReplaceAll: String cr with: ' ') copyWithout: Character tab. aStream nextPutAll: aHelpString capitalized. (aHelpString isEmpty or: [aHelpString last == $.]) ifFalse: [aStream nextPut: $.]. aStream cr; cr]]. UIManager default edit: aString label: 'About Preferences' translated "Preferences giveHelpWithPreferences"! ! !Preferences class methodsFor: 'prefs - halos' stamp: 'sw 10/30/2000 13:32' prior: 21643399! haloSpecifications "Answer a list of HaloSpecs that describe which halos are to be used, what they should look like, and where they should be situated" ^ Parameters at: #HaloSpecs ifAbsent: [self installHaloTheme: #iconicHaloSpecifications. ^ Parameters at: #HaloSpecs] "Preferences haloSpecifications" "Preferences resetHaloSpecifications" ! ! !Preferences class methodsFor: 'prefs - halos' stamp: 'dgd 10/21/2004 12:17' prior: 21644934! haloSpecificationsForWorld | desired | "Answer a list of HaloSpecs that describe which halos are to be used on a world halo, what they should look like, and where they should be situated" "Preferences resetHaloSpecifications" desired := #(addDebugHandle: addMenuHandle: addTileHandle: addViewHandle: addHelpHandle: addScriptHandle: addPaintBgdHandle: addRecolorHandle:). ^ self haloSpecifications select: [:spec | desired includes: spec addHandleSelector]! ! !Preferences class methodsFor: 'prefs - halos' stamp: '' prior: 21645588! haloTheme ^ self valueOfFlag: #haloTheme ifAbsent: [ #iconicHaloSpecifications ]! ! !Preferences class methodsFor: 'prefs - halos' stamp: 'sw 12/29/2004 22:16' prior: 21647875! iconicHaloSpecifications "Answer an array that characterizes the locations, colors, icons, and selectors of the halo handles that may be used in the iconic halo scheme" "Preferences resetHaloSpecifications" ^ #( " selector horiz vert color info icon key --------- ------ ----------- ------------------------------- ---------------" (addCollapseHandle: left topCenter (tan) 'Halo-Collapse') (addPoohHandle: right center (white) 'Halo-Pooh') (addDebugHandle: right topCenter (blue veryMuchLighter) 'Halo-Debug') (addDismissHandle: left top (red muchLighter) 'Halo-Dismiss') (addRotateHandle: left bottom (blue) 'Halo-Rot') (addMenuHandle: leftCenter top (red) 'Halo-Menu') (addTileHandle: left bottomCenter (lightBrown) 'Halo-Tile') (addViewHandle: left center (cyan) 'Halo-View') (addGrabHandle: center top (black) 'Halo-Grab') (addDragHandle: rightCenter top (brown) 'Halo-Drag') (addDupHandle: right top (green) 'Halo-Dup') (addMakeSiblingHandle: right top (green muchDarker) 'Halo-Dup') (addHelpHandle: center bottom (lightBlue) 'Halo-Help') (addGrowHandle: right bottom (yellow) 'Halo-Scale') (addScaleHandle: right bottom (lightOrange) 'Halo-Scale') (addScriptHandle: rightCenter bottom (green muchLighter) 'Halo-Script') (addPaintBgdHandle: right center (lightGray) 'Halo-Paint') (addViewingHandle: leftCenter bottom (lightGreen lighter) 'Halo-View') (addRepaintHandle: right center (lightGray) 'Halo-Paint') (addFontSizeHandle: leftCenter bottom (lightGreen) 'Halo-FontSize') (addFontStyleHandle: center bottom (lightRed) 'Halo-FontStyle') (addFontEmphHandle: rightCenter bottom (lightBrown darker) 'Halo-FontEmph') (addRecolorHandle: right bottomCenter (magenta darker) 'Halo-Recolor') (addChooseGraphicHandle: right bottomCenter (green muchLighter) 'Halo-ChooseGraphic') ) ! ! !Preferences class methodsFor: 'prefs - halos' stamp: 'hpt 9/24/2004 23:34' prior: 21650175! iconicHalosInForce ^ (self preferenceAt: #haloTheme) preferenceValue == #iconicHaloSpecifications! ! !Preferences class methodsFor: 'updating - system' stamp: 'sw 4/12/2001 01:32' prior: 21799270! infiniteUndoChanged "The infiniteUndo preference changed; react" self infiniteUndo ifFalse: [CommandHistory resetAllHistory]! ! !Preferences class methodsFor: 'support - misc' stamp: 'md 2/24/2006 21:26' prior: 21787717! initialExtent ^ Smalltalk isMorphic ifFalse: [219 @ 309] ifTrue: [232 @ 309]! ! !Preferences class methodsFor: 'prefs - text' stamp: 'lr 7/12/2006 09:42' prior: 21863079! initializeTextHighlightingParameters "Preferences initializeTextHighlightingParameters" self caretWidth: 2; insertionPointColor: (TranslucentColor r: 0.0 g: 0.0 b: 0.8 alpha: 0.8); textHighlightColor: (TranslucentColor r: 0.0 g: 0.0 b: 0.8 alpha: 0.2)! ! !Preferences class methodsFor: 'prefs - text' stamp: 'sw 9/7/1999 12:53' prior: 21863581! insertionPointColor ^ Parameters at: #insertionPointColor! ! !Preferences class methodsFor: 'prefs - text' stamp: 'sw 9/7/1999 12:54' prior: 21863899! insertionPointColor: aColor Parameters at: #insertionPointColor put: aColor! ! !Preferences class methodsFor: 'support - misc' stamp: 'eem 6/30/2015 15:26' prior: 21789246! inspectPreferences "Open a window on the current preferences dictionary, allowing the user to inspect and change the current preference settings. This is fallen back upon if Morphic is not present. This is dangerous, the dictionary of preferences should not be accessed concurrently." "Preferences inspectPreferences" preferencesDictionary inspectWithLabel: 'Preferences'! ! !Preferences class methodsFor: 'prefs - window colors' stamp: 'sw 2/26/2002 13:56' prior: 21869443! installBrightWindowColors "Install the factory-provided default window colors for all tools" "Preferences installBrightWindowColors" self installWindowColorsVia: [:aSpec | aSpec brightColor]! ! !Preferences class methodsFor: 'prefs - halos' stamp: 'sw 1/28/2000 10:35' prior: 21650795! installClassicHaloSpecs "Install an alternative set of halos, rather more based on the old placements, and without icons, , and lacking the scripting-relating handles.." "Preferences installClassicHaloSpecs" "Preferences resetHaloSpecifications" " <- will result in the standard default halos being reinstalled" self installHaloTheme: #classicHaloSpecs! ! !Preferences class methodsFor: 'prefs - halos' stamp: 'sw 1/28/2000 10:36' prior: 21651484! installCustomHaloSpecs "Install an alternative set of halos, as customized by the user" "Preferences installCustomHaloSpecs" self installHaloTheme: #customHaloSpecs! ! !Preferences class methodsFor: 'prefs - halos' stamp: 'nice 12/27/2009 03:11' prior: 21652649! installHaloSpecsFromArray: anArray ^ Parameters at: #HaloSpecs put: (anArray collect: [:quin | | aColor | aColor := Color. quin fourth do: [:sel | aColor := aColor perform: sel]. HaloSpec new horizontalPlacement: quin second verticalPlacement: quin third color: aColor iconSymbol: quin fifth addHandleSelector: quin first])! ! !Preferences class methodsFor: 'prefs - halos' stamp: 'hpt 9/24/2004 23:35' prior: 21653341! installHaloTheme: themeSymbol self installHaloSpecsFromArray: (self perform: themeSymbol). (self preferenceAt: #haloTheme) preferenceValue: themeSymbol. ! ! !Preferences class methodsFor: 'prefs - halos' stamp: 'sw 1/28/2000 10:36' prior: 21653917! installIconicHaloSpecs "Install an alternative set of halos, rather more based on the old placements, and without icons, , and lacking the scripting-relating handles.." "Preferences installIconicHaloSpecs" self installHaloTheme: #iconicHaloSpecifications! ! !Preferences class methodsFor: 'prefs - window colors' stamp: 'mt 4/3/2015 16:59' prior: 21869718! installNormalWindowColors "Install the factory-provided default window colors for all tools" "Preferences installNormalWindowColors" self installWindowColorsVia: [:aSpec | aSpec normalColor]! ! !Preferences class methodsFor: 'prefs - window colors' stamp: 'bp 1/8/2011 13:00' prior: 21870588! installPastelWindowColors "Install the factory-provided default pastel window colors for all tools" "Preferences installPastelWindowColors" self installWindowColorsVia: [:aSpec | aSpec pastelColor]! ! !Preferences class methodsFor: 'prefs - halos' stamp: 'sw 1/28/2000 10:36' prior: 21654451! installSimpleHaloSpecs "Preferences installSimpleHaloSpecs" self installHaloTheme: #simpleFullHaloSpecifications! ! !Preferences class methodsFor: 'themes - tools' stamp: 'yo 7/2/2004 19:44' prior: 21723703! installTheme: aSymbol "Install the theme represented by aSymbol. The code that makes the theme-specific changes is lodged in a method of the same name as aSymbol, which must reside in category #themes in Preferences class" self perform: aSymbol. self inform: ('Theme {1} is now installed. Many of the changes will only be noticeable in new windows that you create from now on.' translated format: {aSymbol translated}).! ! !Preferences class methodsFor: 'prefs - window colors' stamp: 'laza 4/26/2010 10:22' prior: 21871756! installUniformWindowColors "Install the factory-provided uniform window colors for all tools" "Preferences installUniformWindowColors" self installWindowColorsVia: [:aQuad | self uniformWindowColor]! ! !Preferences class methodsFor: 'prefs - window colors' stamp: 'mt 4/4/2015 13:04' prior: 21874487! installWindowColorsVia: colorSpecBlock "Install windows colors using colorSpecBlock to deliver the color source for each element; the block is handed a WindowColorSpec object" "Preferences installBrightWindowColors" WindowColorRegistry refresh. self windowColorTable do: [:aColorSpec | | color | color := (Color colorFrom: (colorSpecBlock value: aColorSpec)). self setWindowColorFor: aColorSpec classSymbol to: color]. SystemWindow refreshAllWindows. TheWorldMainDockingBar updateInstances.! ! !Preferences class methodsFor: 'prefs - text' stamp: 'dew 1/8/2002 01:07' prior: 21864393! keyboardFocusColor "Answer the keyboard focus color, initializing it if necessary" ^ Parameters at: #keyboardFocusColor ifAbsentPut: [Color lightGray] " Parameters removeKey: #keyboardFocusColor. Preferences keyboardFocusColor "! ! !Preferences class methodsFor: 'prefs - text' stamp: 'sw 12/7/2001 00:44' prior: 21864918! keyboardFocusColor: aColor "Set the keyboard focus color" Parameters at: #keyboardFocusColor put: aColor! ! !Preferences class methodsFor: 'updating - system' stamp: 'em 3/24/2005 15:34' prior: 21799949! largeTilesSettingToggled "The current value of the largeTiles flag has changed; now react" Smalltalk isMorphic ifTrue: [Preferences universalTiles ifFalse: [self inform: 'note that this will only have a noticeable effect if the universalTiles preference is set to true, which it currently is not' translated] ifTrue: [World recreateScripts]]! ! !Preferences class methodsFor: 'support - misc' stamp: 'ar 9/27/2005 20:32' prior: 21766533! letUserPersonalizeMenu "Invoked from menu, opens up a single-msg browser on the message that user is invited to customize for rapid morphic access via option-click on morphic desktop" ToolSet browse: Preferences class selector: #personalizeUserMenu:! ! !Preferences class methodsFor: 'prefs - window colors' stamp: 'mt 8/27/2015 10:42' prior: 21875514! lightenStandardWindowPreferences "Make all window-color preferences one shade darker" (self allPreferences select: [:aPref | (aPref name endsWith: 'WindowColor') and: [aPref preferenceValue isColor]]) do: [:aPref | aPref preferenceValue: aPref preferenceValue lighter]. "Preferences lightenStandardWindowPreferences" ! ! !Preferences class methodsFor: 'initialization - save/load' stamp: 'kfr 4/28/2015 07:17' prior: 21770214! loadPreferencesFrom: aFile | stream params dict desktopColor | stream := ReferenceStream fileNamed: aFile. params := stream next. self assert: (params isKindOf: IdentityDictionary). params removeKey: #PersonalDictionaryOfPreferences. dict := stream next. self assert: (dict isKindOf: IdentityDictionary). desktopColor := stream next. stream close. dict keysAndValuesDo: [:key :value | (self preferenceAt: key ifAbsent: [nil]) ifNotNil: [:pref | pref preferenceValue: value preferenceValue]]. params keysAndValuesDo: [ :key :value | self setParameter: key to: value ]. Smalltalk isMorphic ifTrue: [ World fillStyle: desktopColor ] ifFalse: [ self desktopColor: desktopColor. ScheduledControllers updateGray ]. ! ! !Preferences class methodsFor: 'updating' stamp: 'tak 8/3/2005 21:17' prior: 21667731! localeChanged LocaleID current isoLanguage = 'ja' ifTrue: [Preferences enable: #useFormsInPaintBox] ifFalse: [Preferences disable: #useFormsInPaintBox]! ! !Preferences class methodsFor: 'prefs - misc' stamp: 'sw 11/5/1998 16:49' prior: 21754613! maxBalloonHelpLineLength ^ Parameters at: #maxBalloonHelpLineLength! ! !Preferences class methodsFor: 'prefs - menus' stamp: 'di 1/14/1999 20:16' prior: 21673828! menuBorderColor Display depth <= 2 ifTrue: [^ Color black]. ^ Parameters at: #menuBorderColor! ! !Preferences class methodsFor: 'prefs - menus' stamp: 'sw 11/3/1998 11:16' prior: 21674155! menuBorderWidth ^ Parameters at: #menuBorderWidth! ! !Preferences class methodsFor: 'prefs - menus' stamp: 'di 1/14/1999 20:17' prior: 21674470! menuColor Display depth <= 2 ifTrue: [^ Color white]. ^ Parameters at: #menuColor! ! !Preferences class methodsFor: 'support - misc' stamp: 'dgd 9/21/2003 13:51' prior: 21724444! menuColorString ^ ((self valueOfFlag: #menuColorFromWorld) ifTrue: ['stop menu-color-from-world'] ifFalse: ['start menu-color-from-world']) translated! ! !Preferences class methodsFor: 'prefs - menus' stamp: 'dgd 3/23/2003 11:06' prior: 21674838! menuLineColor ^ Parameters at: #menuLineColor ifAbsentPut: [Preferences menuBorderColor lighter]! ! !Preferences class methodsFor: 'prefs - menus' stamp: 'dgd 8/30/2004 20:59' prior: 21675199! menuSelectionColor ^ Parameters at: #menuSelectionColor ifAbsent: [nil]! ! !Preferences class methodsFor: 'prefs - menus' stamp: 'di 1/14/1999 20:19' prior: 21675562! menuTitleBorderColor Display depth <= 2 ifTrue: [^ Color black]. ^ Parameters at: #menuTitleBorderColor! ! !Preferences class methodsFor: 'prefs - menus' stamp: 'sw 11/3/1998 11:16' prior: 21675909! menuTitleBorderWidth ^ Parameters at: #menuTitleBorderWidth! ! !Preferences class methodsFor: 'prefs - menus' stamp: 'di 1/14/1999 20:18' prior: 21676286! menuTitleColor Display depth = 1 ifTrue: [^ Color white]. Display depth = 2 ifTrue: [^ Color gray]. ^ Parameters at: #menuTitleColor! ! !Preferences class methodsFor: 'prefs - misc' stamp: 'sw 8/11/2002 02:18' prior: 21661679! messengersInViewers "A coming technology..." ^ false! ! !Preferences class methodsFor: 'prefs - misc' stamp: 'sw 8/18/2000 13:26' prior: 21662200! metaMenuDisabled "If true, then click/cmd-click on the desktop will not bring up the World menu. Can be changed manually right here, and can be programattically changed via a call of the following form: Preferences compileHardCodedPref: #metaMenuDisabled enable: true" ^ false! ! !Preferences class methodsFor: 'updating - system' stamp: 'mir 9/12/2001 15:15' prior: 21800569! mouseOverHalosChanged World wantsMouseOverHalos: self mouseOverHalos! ! !Preferences class methodsFor: 'support - misc' stamp: 'dgd 8/31/2003 18:03' prior: 21630238! navigatorShowingString "Answer a string for the show-project-navigator menu item" ^ (self showProjectNavigator ifTrue: [''] ifFalse: ['']) , 'show navigator (N)' translated! ! !Preferences class methodsFor: 'updating - system' stamp: 'bp 1/8/2011 12:59' prior: 21802028! noviceModeSettingChanged "The current value of the noviceMode flag has changed; now react" TheWorldMainDockingBar updateInstances. PasteUpMorph allSubInstances select: [:each | each isWorldMorph] thenDo: [:each | each initializeDesktopCommandKeySelectors]. Smalltalk at: #ParagraphEditor ifPresent: [:aClass| aClass initialize]! ! !Preferences class methodsFor: 'themes - tools' stamp: 'em 3/24/2005 14:11' prior: 21726976! offerThemesMenu "Put up a menu offering the user a choice of themes. Each theme is represented by a method in category #themes in Preferences class. The comment at the front of each method is used as the balloon help for the theme" "Preferences offerThemesMenu" | selectors aMenu | selectors := self class allMethodsInCategory: #themes. selectors := selectors select: [:sel | sel numArgs = 0]. aMenu := MenuMorph new defaultTarget: self. aMenu addTitle: 'Choose a theme to install' translated. selectors do: [:sel | aMenu add: sel target: self selector: #installTheme: argument: sel. aMenu balloonTextForLastItem: (self class firstCommentAt: sel)]. aMenu addLine. aMenu add: 'browse themes' translated target: self action: #browseThemes. aMenu balloonTextForLastItem: 'Puts up a tool that will allow you to view and edit the code underlying all of the available themes' translated. aMenu popUpInWorld. "(Workspace new contents: 'here is an example of a new window with your new theme installed' translated) openLabel: 'Testing one two three'"! ! !Preferences class methodsFor: 'support' stamp: 'sw 4/24/2001 12:02' prior: 21728509! okayToChangeProjectLocalnessOf: prefSymbol "Answer whether it would be okay to allow the user to switch the setting of whether or not the preference symbol is local to a project. Formerly useful and perhaps again will be, though to be sure this is a non-modular design." ^ (#() includes: prefSymbol) not! ! !Preferences class methodsFor: 'updating - system' stamp: 'sw 6/12/2001 20:18' prior: 21802717! optionalButtonsChanged "The setting of the optionalButtons preference changed; react. Formerly, we replaced prototypes in flaps but this is no longer necessary" ! ! !Preferences class methodsFor: 'support - misc' stamp: 'fbs 12/6/2013 21:01' prior: 21774613! 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: MCMcmUpdater action: #updateFromServer. aMenu add: 'about this system...' translated target: Smalltalk action: #aboutThisSystem. aMenu addLine. aMenu addUpdating: #suppressFlapsString target: Project current action: #toggleFlapsSuppressed. aMenu balloonTextForLastItem: 'Whether prevailing flaps should be shown in the project right now or not.' translated! ! !Preferences class methodsFor: 'updating' stamp: 'mt 8/27/2015 10:42' prior: 21893732! prefEvent: anEvent "Check if this system event defines or removes a preference." | class selector method | self flag: #performance. "mt: Maybe defer preference dictionary update?" anEvent itemKind = SystemChangeNotifier classKind ifTrue: [ anEvent isRemoved ifTrue: [ self removeAllPreferencesSuchThat: [:pref | pref provider == anEvent item]]. anEvent isRenamed ifTrue: [ self atomicUpdatePreferences: [ :prefs | self allPreferences select: [:pref | pref provider == anEvent item] thenDo: [:pref | prefs at: pref id put: pref]. prefs keys select: [:id | id beginsWith: anEvent oldName] thenDo: [:id | prefs removeKey: id] ] ] ]. anEvent itemKind = SystemChangeNotifier methodKind ifTrue: [ "ignore instance methods" anEvent itemClass isMeta ifFalse: [^ self]. class := anEvent itemClass theNonMetaClass. selector := anEvent itemSelector. method := anEvent item. anEvent isRemoved ifTrue: [ self atomicUpdatePreferences: [ :prefs | "See PragmaPreference >> #id." prefs removeKey: (class name,'>>', selector) asSymbol ifAbsent: []]]. (anEvent isAdded or: [anEvent isModified]) ifTrue: [ method pragmas do: [:pragma | self addPragmaPreference: pragma] ] ].! ! !Preferences class methodsFor: 'private' stamp: 'mt 8/27/2015 08:55' prior: 21896642! preference: prefName category: categoryName description: helpString type: typeSymbol "Create a preference for a preference pragma in a method." ^ self preference: prefName categoryList: (categoryName isArray "Alas pragma users are not always careful" ifTrue: [categoryName] ifFalse: [{categoryName}]) description: helpString type: typeSymbol! ! !Preferences class methodsFor: 'private' stamp: 'mt 8/27/2015 08:54' prior: 21897178! preference: prefName categoryList: categoryList description: helpString type: typeSymbol "Create a preference for a preference pragma in a method." ^ PragmaPreference new name: prefName defaultValue: nil "always nil" helpString: helpString localToProject: false "governed by the method" categoryList: categoryList changeInformee: nil changeSelector: nil type: typeSymbol! ! !Preferences class methodsFor: 'accessing' stamp: 'ul 1/10/2011 16:22' prior: 21793643! preferenceAt: aSymbol "Answer the Preference object at the given symbol, or nil if not there" ^self preferenceAt: aSymbol ifAbsent: [ nil ]! ! !Preferences class methodsFor: 'accessing' stamp: 'eem 6/30/2015 15:22' prior: 21795687! preferenceAt: aSymbol ifAbsent: aBlock "Answer the Preference object at the given symbol, or the value of aBlock if not present" ^preferencesDictionary at: aSymbol ifAbsent: aBlock! ! !Preferences class methodsFor: 'support' stamp: 'mt 8/27/2015 10:44'! preferencesInCategory: aCategorySymbol "Answer a list of Preference objects that reside in the given category." ^ self allPreferences select: [ :aPreference | aPreference categoryList includes: aCategorySymbol ]! ! !Preferences class methodsFor: 'prefs - misc' stamp: 'sw 8/29/2000 15:01' prior: 21662957! preserveCommandExcursions "An architecture is in place for storing command excursions to which access is otherwise cut off by having taken a variant branch, but it is not accessible unless you hand-code this preference to true -- which I suggest you do only with fingers crossed." ^ false! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'nk 9/1/2004 11:37' prior: 21592215! printStandardSystemFonts "self printStandardSystemFonts" | string | string := String streamContents: [ :s | #(standardDefaultTextFont standardListFont standardFlapFont standardEToysFont standardMenuFont windowTitleFont standardBalloonHelpFont standardCodeFont standardButtonFont) do: [:selector | | font | font := Preferences perform: selector. s nextPutAll: selector; space; nextPutAll: font familyName; space; nextPutAll: (AbstractFont emphasisStringFor: font emphasis); nextPutAll: ' points: '; print: font pointSize; nextPutAll: ' height: '; print: font height; cr ]]. (StringHolder new) contents: string; openLabel: 'Current system font settings' translated. ! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'nk 7/18/2004 15:34' prior: 21593742! refreshFontSettings "Try to update all the current font settings to make things consistent." self setFlapsFontTo: (self standardFlapFont); setEToysFontTo: (self standardEToysFont); setWindowTitleFontTo: (self windowTitleFont); setListFontTo: (self standardListFont); setMenuFontTo: (self standardMenuFont); setSystemFontTo: (TextStyle defaultFont); setCodeFontTo: (self standardCodeFont); setBalloonHelpFontTo: (BalloonMorph balloonFont). SystemWindow allSubInstancesDo: [ :s | | rawLabel | rawLabel := s getRawLabel. rawLabel owner vResizing: #spaceFill. rawLabel font: rawLabel font. s setLabel: s label. s replaceBoxes ].! ! !Preferences class methodsFor: 'initialization' stamp: 'mt 8/27/2015 08:38' prior: 21900593! registerForEvents "Preferences registerForEvents" "Do not register pragma preferences with any preferences holder but this one." self == Preferences ifFalse: [^ self]. SystemChangeNotifier uniqueInstance noMoreNotificationsFor: self; notify: self ofAllSystemChangesUsing: #prefEvent:. Smalltalk allClassesDo: [:aClass | aClass class methodsDo: [:method | method pragmas do: [:pragma | self addPragmaPreference: pragma] ] ].! ! !Preferences class methodsFor: 'add/remove' stamp: 'mt 8/26/2015 16:58'! removeAllPreferencesSuchThat: block self atomicUpdatePreferences: [ :copyOfDictionaryOfPreferences | | map | map := copyOfDictionaryOfPreferences select: block. map keysDo: [ :prefName | copyOfDictionaryOfPreferences removeKey: prefName]]! ! !Preferences class methodsFor: 'add/remove' stamp: 'mt 8/26/2015 17:26' prior: 21671101! removePreference: aSymbol "Remove all memory of the given preference symbol in my various structures." | pref | pref := self preferenceAt: aSymbol ifAbsent: [^self]. pref localToProject ifTrue: [ Project allProjects do: [ :proj | proj projectPreferenceFlagDictionary ifNotNil: [ :projectpreferences | projectpreferences removeKey: aSymbol ifAbsent: [] ] ] ]. self atomicUpdatePreferences: [ :copyOfDictionaryOfPreferences | copyOfDictionaryOfPreferences removeKey: aSymbol ifAbsent: nil ]. "Remove auto-generated accessor method." self class removeSelector: aSymbol. ^ pref! ! !Preferences class methodsFor: 'prefs - halos' stamp: 'sw 1/25/2000 20:10' prior: 21654839! resetHaloSpecifications "Preferences resetHaloSpecifications" ^ Parameters removeKey: #HaloSpecs ifAbsent: []! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'ul 11/25/2010 23:37' prior: 21597398! restoreDefaultFonts "Since this is called from menus, we can take the opportunity to prompt for missing font styles." " Preferences restoreDefaultFonts " self setDefaultFonts: #( (setSystemFontTo: 'Bitmap DejaVu Sans' 9) (setListFontTo: 'Bitmap DejaVu Sans' 9) (setFlapsFontTo: Accushi 12) (setEToysFontTo: BitstreamVeraSansBold 9) (setPaintBoxButtonFontTo: BitstreamVeraSansBold 9) (setMenuFontTo: 'Bitmap DejaVu Sans' 9) (setWindowTitleFontTo: 'Bitmap DejaVu Sans Bold' 9) (setBalloonHelpFontTo: 'Bitmap DejaVu Sans' 7) (setCodeFontTo: 'Bitmap DejaVu Sans' 9) (setButtonFontTo: 'Bitmap DejaVu Sans' 7) )! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'yo 7/28/2004 21:25' prior: 21599347! restoreDefaultFontsForJapanese "Preferences restoreDefaultFontsForJapanese" #( "(setButtonFontTo: ComicBold 15)" "(setTextButtonFontTo: NewYork 12)" "(setCodeFontTo: NewYork 12)" "Later" (setFlapsFontTo: NewYork 15) (setListFontTo: NewYork 12) (setMenuFontTo: NewYork 12) (setWindowTitleFontTo: NewYork 15) (setSystemFontTo: NewYork 12)) do: [:triplet | self perform: triplet first with: (StrikeFontSet familyName: triplet second size: triplet third)]. self setButtonFontTo: (StrikeFont familyName: #ComicBold size: 16). Smalltalk at: #BalloonMorph ifPresent: [:thatClass | thatClass setBalloonFontTo: (StrikeFontSet familyName: #NewYork size: 12)]. "Note: The standardCodeFont is not currently used -- the default font is instead; later hopefully we can split the code font out as a separate choice, but only after we're able to have the protocols reorganized such that we can know whether it's code or not when we launch the text object. Note: The standard button font is reset by this code but is not otherwise settable by a public UI (too many things can go afoul) "! ! !Preferences class methodsFor: 'initialization - misc' stamp: 'dgd 3/23/2003 11:11' prior: 21677281! restoreDefaultMenuParameters "Restore the four color choices of the original implementors of MorphicMenus" " Preferences restoreDefaultMenuParameters " Parameters at: #menuColor put: (Color r: 0.97 g: 0.97 b: 0.97). Parameters at: #menuBorderColor put: (Color r: 0.167 g: 0.167 b: 1.0). Parameters at: #menuBorderWidth put: 2. Parameters at: #menuTitleColor put: (Color r: 0.4 g: 0.8 b: 0.9) twiceDarker. Parameters at: #menuTitleBorderColor put: (Color r: 0.333 g: 0.667 b: 0.751). Parameters at: #menuTitleBorderWidth put: 1. Parameters at: #menuLineColor put: (Preferences menuBorderColor lighter)! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'ar 7/21/2010 20:13' prior: 21601824! restoreFontsAfter: aBlock "Restore the currently chosen set of standard fonts after evaluating aBlock. Used for tests that modify the default fonts." | standardDefaultTextFont standardListFont standardEToysFont standardMenuFont windowTitleFont standardBalloonHelpFont standardCodeFont standardButtonFont | standardDefaultTextFont := Preferences standardDefaultTextFont. standardListFont := Preferences standardListFont. standardEToysFont := Preferences standardEToysFont. standardMenuFont := Preferences standardMenuFont. windowTitleFont := Preferences windowTitleFont. standardBalloonHelpFont := Preferences standardBalloonHelpFont. standardCodeFont := Preferences standardCodeFont. standardButtonFont := Preferences standardButtonFont. ^aBlock ensure: [ Preferences setSystemFontTo: standardDefaultTextFont. Preferences setListFontTo: standardListFont. Preferences setEToysFontTo: standardEToysFont. Preferences setMenuFontTo: standardMenuFont. Preferences setWindowTitleFontTo: windowTitleFont. Preferences setBalloonHelpFontTo: standardBalloonHelpFont. Preferences setCodeFontTo: standardCodeFont. Preferences setButtonFontTo: standardButtonFont. ]. ! ! !Preferences class methodsFor: 'initialization - save/load' stamp: 'ul 12/12/2009 14:07' prior: 21776829! restorePersonalPreferences "Restore all the user's saved personal preference settings" | savedPrefs | savedPrefs := self parameterAt: #PersonalDictionaryOfPreferences ifAbsent: [^ self inform: 'There are no personal preferences saved in this image yet']. savedPrefs associationsDo: [:assoc | (self preferenceAt: assoc key ifAbsent: [nil]) ifNotNil: [:pref | pref preferenceValue: assoc value preferenceValue]]! ! !Preferences class methodsFor: 'initialization - save/load' stamp: 'nk 11/17/2002 12:07' prior: 21778448! restorePreferencesFromDisk (FileDirectory default fileExists: 'my.prefs') ifTrue: [ Cursor wait showWhile: [ [ self loadPreferencesFrom: 'my.prefs' ] on: Error do: [ :ex | self inform: 'there was an error restoring the preferences' ] ] ] ifFalse: [ self inform: 'you haven''t saved your preferences yet!!' ]. ! ! !Preferences class methodsFor: 'initialization - save/load' stamp: 'kfr 1/9/2015 13:48' prior: 21778851! restorePreferencesFromDisk: aFile Cursor wait showWhile: [[self loadPreferencesFrom: aFile] on: Error do: [:ex | self inform: 'there was an error restoring the preferences' translated]]! ! !Preferences class methodsFor: 'support - misc' stamp: 'yo 2/10/2005 16:15' prior: 21729125! roundedCornersString ^ (((self valueOfFlag: #roundedWindowCorners) ifTrue: ['stop'] ifFalse: ['start']) , ' rounding window corners') translated! ! !Preferences class methodsFor: 'updating - system' stamp: 'sw 4/12/2001 01:11' prior: 21803204! roundedWindowCornersChanged "The user changed the value of the roundedWindowCorners preference. React" ActiveWorld fullRepaintNeeded! ! !Preferences class methodsFor: 'initialization - save/load' stamp: 'eem 6/30/2015 15:23' prior: 21780476! savePersonalPreferences "Save the current list of Preference settings as the user's personal choices" self setParameter: #PersonalDictionaryOfPreferences to: preferencesDictionary deepCopy! ! !Preferences class methodsFor: 'prefs - misc' stamp: '' prior: 21757456! scrollBarColor "Answer the preferred color for scroll bar elevators." ^ Color gray! ! !Preferences class methodsFor: 'prefs - misc' stamp: '' prior: 21757724! scrollBarWidth "Answer the preferred width for scroll bars." ^ 8! ! !Preferences class methodsFor: 'support - file list services' stamp: 'kfr 4/28/2015 06:54' prior: 21918564! serviceLoadPreferencesFromDisk ^ SimpleServiceEntry provider: self label: 'load preferences from a saved file' selector: #restorePreferencesFromDisk: description: 'restore all saved personal preference settings' buttonLabel: 'load preferences'! ! !Preferences class methodsFor: 'support - file list services' stamp: 'kfr 4/28/2015 06:49' prior: 21918907! services ^ Array with: self serviceLoadPreferencesFromDisk! ! !Preferences class methodsFor: 'support - misc' stamp: 'sw 3/2/2004 22:11' prior: 21730250! setArrowheads "Let the user edit the size of arrowheads" | aParameter result | aParameter := self parameterAt: #arrowSpec ifAbsent: [5 @ 4]. result := Morph obtainArrowheadFor: 'Default size of arrowheads on pen trails ' translated defaultValue: aParameter asString. result ifNotNil: [self setParameter: #arrowSpec to: result] ifNil: [Beeper beep]! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'bp 6/13/2004 17:46' prior: 21603294! setBalloonHelpFontTo: aFont Smalltalk at: #BalloonMorph ifPresent: [:thatClass | thatClass setBalloonFontTo: aFont]! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'sw 12/8/1999 22:06' prior: 21603644! setButtonFontTo: aFont Parameters at: #standardButtonFont put: aFont! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'sw 7/25/2004 17:26' prior: 21603969! setCodeFontTo: aFont "Establish the code font." Parameters at: #standardCodeFont put: aFont! ! !Preferences class methodsFor: 'initialization - misc' stamp: 'mt 8/27/2015 10:03' prior: 21758130! setDefaultAnnotationInfo "Preferences setDefaultAnnotationInfo" ^ Parameters at: #MethodAnnotations put: self defaultAnnotationInfo! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'ar 9/7/2009 15:00' prior: 21605959! setDefaultFonts: defaultFontsSpec "Since this is called from menus, we can take the opportunity to prompt for missing font styles." | fontNames map emphases | fontNames := defaultFontsSpec collect: [:array | array second]. map := IdentityDictionary new. emphases := IdentityDictionary new. fontNames do: [:originalName | | decoded style | decoded := TextStyle decodeStyleName: originalName. style := map at: originalName put: (TextStyle named: decoded second). emphases at: originalName put: decoded first. style ifNil: [map at: originalName put: TextStyle default]]. defaultFontsSpec do: [:triplet | self perform: triplet first with: (((map at: triplet second) fontOfPointSize: triplet third) emphasized: (emphases at: triplet second))]! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'md 3/7/2006 10:27' prior: 21607436! setDemoFonts "Preferences setDemoFonts" self setDefaultFonts: #( (setSystemFontTo: BitstreamVeraSans 12) (setListFontTo: BitstreamVeraSans 14) (setFlapsFontTo: Accushi 12) (setEToysFontTo: BitstreamVeraSansBold 9) (setPaintBoxButtonFontTo: BitstreamVeraSansBold 9) (setMenuFontTo: BitstreamVeraSans 14) (setWindowTitleFontTo: BitstreamVeraSansBold 12) (setBalloonHelpFontTo: Accujen 18) (setCodeFontTo: BitstreamVeraSans 18) (setButtonFontTo: BitstreamVeraSansMono 14) ) ! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'dgd 7/12/2003 11:52' prior: 21608264! setEToysFontTo: aFont "change the font used in eToys environment" Parameters at: #eToysFont put: aFont! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'dgd 11/3/2004 15:03' prior: 21608648! setEToysTitleFontTo: aFont "change the font used in eToys environment" Parameters at: #eToysTitleFont put: aFont! ! !Preferences class methodsFor: 'get/set - flags' stamp: 'mt 8/26/2015 17:34'! setFlag: prefSymbol toValue: aBoolean "Convenience method for consistency." ^ self setPreference: prefSymbol toValue: aBoolean! ! !Preferences class methodsFor: 'get/set - flags' stamp: 'mt 8/26/2015 17:32' prior: 21731560! setFlag: prefSymbol toValue: aBoolean during: aBlock "Set the flag to the given value for the duration of aBlock" (self valueOfFlag: prefSymbol) in: [:previous | self setFlag: prefSymbol toValue: aBoolean. aBlock ensure: [self setFlag: prefSymbol toValue: previous]].! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'sw 12/8/1999 18:15' prior: 21609065! setFlapsFontTo: aFont Parameters at: #standardFlapFont put: aFont. FlapTab allSubInstancesDo: [:aFlapTab | aFlapTab reformatTextualTab]! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'mir 8/24/2004 12:34' prior: 21609482! setHaloLabelFontTo: aFont "change the font used in eToys environment" Parameters at: #haloLabelFont put: aFont! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'dtl 2/12/2010 22:21' prior: 21610232! setListFontTo: aFont "Set the list font as indicated" Parameters at: #standardListFont put: aFont. Smalltalk at: #ListParagraph ifPresent: [:lp | lp initialize]. Smalltalk at: #Flaps ifPresent: [:flaps | flaps replaceToolsFlap]! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'ar 8/6/2009 18:30' prior: 21611220! setMenuFontTo: aFont "rbb 2/18/2005 12:54 - How should this be changed to work with the UIManager, if at all?" Parameters at: #standardMenuFont put: aFont. Smalltalk at: #PopUpMenu ifPresent:[:aClass| aClass setMenuFontTo: aFont]. TheWorldMainDockingBar updateInstances.! ! !Preferences class methodsFor: 'initialization - misc' stamp: 'nice 12/27/2009 03:11' prior: 21806109! setNotificationParametersForStandardPreferences "Set up the notification parameters for the standard preferences that require need them. When adding new Preferences that require use of the notification mechanism, users declare the notifcation info as part of the call that adds the preference, or afterwards -- the two relevant methods for doing that are: Preferences.addPreference:categories:default:balloonHelp:projectLocal:changeInformee:changeSelector: and Preference changeInformee:changeSelector:" "Preferences setNotificationParametersForStandardPreferences" #( (annotationPanes annotationPanesChanged) (eToyFriendly eToyFriendlyChanged) (infiniteUndo infiniteUndoChanged) (uniTilesClassic classicTilesSettingToggled) (optionalButtons optionalButtonsChanged) (roundedWindowCorners roundedWindowCornersChanged) (showProjectNavigator showProjectNavigatorChanged) (smartUpdating smartUpdatingChanged) (universalTiles universalTilesSettingToggled) (showSharedFlaps sharedFlapsSettingChanged) (noviceMode noviceModeSettingChanged) ) do: [:pair | | aPreference | aPreference := self preferenceAt: pair first. aPreference changeInformee: self changeSelector: pair second]! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'yo 1/12/2005 22:43' prior: 21611787! setPaintBoxButtonFontTo: aFont "change the font used in the buttons in PaintBox." Parameters at: #paintBoxButtonFont put: aFont! ! !Preferences class methodsFor: 'get/set' stamp: 'mt 8/26/2015 17:23' prior: 21630791! setPreference: prefSymbol toValue: anObject "Set the given preference to the given value, and answer that value" ^ (self preferenceAt: prefSymbol ifAbsent: [^ self addPreference: prefSymbol default: anObject]) preferenceValue: anObject; yourself! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'sw 4/17/2001 11:34' prior: 21612934! setSystemFontTo: aFont "Establish the default text font and style" | aStyle newDefaultStyle | aFont ifNil: [^ self]. aStyle := aFont textStyle ifNil: [^ self]. newDefaultStyle := aStyle copy. newDefaultStyle defaultFontIndex: (aStyle fontIndexOf: aFont). TextConstants at: #DefaultTextStyle put: newDefaultStyle. Flaps replaceToolsFlap. ScriptingSystem resetStandardPartsBin! ! !Preferences class methodsFor: 'prefs - window colors' stamp: 'ar 8/9/2009 15:16' prior: 21877482! setWindowColorFor: modelSymbol to: incomingColor | aColor aPrefSymbol aColorSpec | aColorSpec := WindowColorRegistry registeredWindowColorSpecFor: modelSymbol. aColorSpec ifNil: [^self]. aColor := incomingColor asNontranslucentColor. (aColor = ColorPickerMorph perniciousBorderColor or: [aColor = Color black]) ifTrue: [^ self]. aPrefSymbol := self windowColorPreferenceForClassNamed: aColorSpec classSymbol. self addPreference: aPrefSymbol categories: { #'window colors' } default: aColor balloonHelp: aColorSpec helpMessage translated projectLocal: false changeInformee: nil changeSelector: nil type: #WindowColor! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'dtl 2/10/2010 22:52' prior: 21614071! setWindowTitleFontTo: aFont "Set the window-title font to be as indicated" Parameters at: #windowTitleFont put: aFont. (Smalltalk hasClassNamed: #StandardSystemView) ifTrue: [(Smalltalk at: #StandardSystemView) setLabelStyle]. (Smalltalk hasClassNamed: #Flaps) ifTrue: [(Smalltalk at: #Flaps) replaceToolsFlap] ! ! !Preferences class methodsFor: 'updating - system' stamp: 'sw 4/30/2001 20:39' prior: 21807874! sharedFlapsSettingChanged "The current value of the showSharedFlaps flag has changed; now react" self showSharedFlaps "viz. the new setting" ifFalse: [Flaps globalFlapTabsIfAny do: [:aFlapTab | Flaps removeFlapTab: aFlapTab keepInList: true]] ifTrue: [Smalltalk isMorphic ifTrue: [self currentWorld addGlobalFlaps]]! ! !Preferences class methodsFor: 'prefs - halos' stamp: 'sw 11/6/2000 10:02' prior: 21655306! showChooseGraphicHaloHandle "Hard-coded; reimplement to change behavior. If this preference is set to true, then a choose-graphic halo handle may appear on the halo of SketchMorphs" ^ false! ! !Preferences class methodsFor: 'updating - system' stamp: 'sw 4/12/2001 01:33' prior: 21808550! showProjectNavigatorChanged "The showProjectNavigatorChanged preference changed; react" Project current assureNavigatorPresenceMatchesPreference! ! !Preferences class methodsFor: 'prefs - halos' stamp: 'sw 7/28/2004 16:26' prior: 21657495! simpleFullHaloSpecifications "This method gives the specs for the 'full' handles variant when simple halos are in effect" "Preferences resetHaloSpecifications" ^ #( " selector horiz vert color info icon key --------- ------ ----------- ------------------------------- ---------------" (addDebugHandle: right topCenter (blue veryMuchLighter) 'Halo-Debug') (addPoohHandle: right center (white) 'Halo-Pooh') (addDismissHandle: left top (red muchLighter) 'Halo-Dismiss') (addRotateHandle: left bottom (blue) 'Halo-Rot') (addMenuHandle: leftCenter top (red) 'Halo-Menu') (addTileHandle: left bottomCenter (lightBrown) 'Halo-Tile') (addViewHandle: left center (cyan) 'Halo-View') (addGrabHandle: center top (black) 'Halo-Grab') (addDragHandle: rightCenter top (brown) 'Halo-Drag') (addDupHandle: right top (green) 'Halo-Dup') (addMakeSiblingHandle: right top (green muchDarker) 'Halo-Dup') (addHelpHandle: center bottom (lightBlue) 'Halo-Help') (addGrowHandle: right bottom (yellow) 'Halo-Scale') (addScaleHandle: right bottom (lightOrange) 'Halo-Scale') (addFewerHandlesHandle: left topCenter (paleBuff) 'Halo-FewerHandles') (addScriptHandle: right bottomCenter (green muchLighter) 'Halo-Script') (addPaintBgdHandle: right center (lightGray) 'Halo-Paint') (addRepaintHandle: right center (lightGray) 'Halo-Paint') (addFontSizeHandle: leftCenter bottom (lightGreen) 'Halo-FontSize') (addFontStyleHandle: center bottom (lightRed) 'Halo-FontStyle') (addFontEmphHandle: rightCenter bottom (lightBrown darker) 'Halo-FontEmph') (addRecolorHandle: right bottomCenter (magenta darker) 'Halo-Recolor') ) ! ! !Preferences class methodsFor: 'prefs - halos' stamp: 'hpt 9/24/2004 23:34' prior: 21659595! simpleHalosInForce ^ (self preferenceAt: #haloTheme) preferenceValue == #simpleFullHaloSpecifications! ! !Preferences class methodsFor: 'updating - system' stamp: 'sw 4/12/2001 01:30' prior: 21809130! smartUpdatingChanged "The smartUpdating preference changed. React" SystemWindow allSubInstancesDo: [:aWindow | aWindow amendSteppingStatus] "NOTE: This makes this preference always behave like a global preference, which is problematical"! ! !Preferences class methodsFor: 'support - misc' stamp: 'dgd 9/21/2003 13:46' prior: 21732294! staggerPolicyString "Answer the string to be shown in a menu to represent the stagger-policy status" ^ ((self valueOfFlag: #reverseWindowStagger) ifTrue: [''] ifFalse: ['']), 'stagger windows' translated! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'bp 6/13/2004 17:19' prior: 21614603! standardBalloonHelpFont ^BalloonMorph balloonFont! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'md 12/22/2006 14:20' prior: 21615395! standardButtonFont "Answer an attractive font to use for buttons" "Answer the font to be used for textual flap tab labels" ^ Parameters at: #standardButtonFont ifAbsentPut: [StrikeFont familyName: #ComicBold size: 16]! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'md 12/22/2006 14:23' prior: 21616170! standardCodeFont "Answer the font to be used in code" ^ Parameters at: #standardCodeFont ifAbsentPut: [TextStyle defaultFont]! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'bp 6/13/2004 17:24' prior: 21616507! standardDefaultTextFont ^TextStyle defaultFont! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'md 12/22/2006 14:21' prior: 21617119! standardEToysFont "Answer the font to be used in the eToys environment" ^ Parameters at: #eToysFont ifAbsentPut: [self standardButtonFont]! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'md 12/22/2006 14:21' prior: 21617848! standardEToysTitleFont "Answer the font to be used in the eToys environment" ^ Parameters at: #eToysTitleFont ifAbsentPut: [self standardEToysFont]! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'md 12/22/2006 14:21' prior: 21618585! standardFlapFont "Answer the font to be used for textual flap tab labels" ^ Parameters at: #standardFlapFont ifAbsentPut: [self standardButtonFont]! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'md 12/22/2006 14:22' prior: 21619316! standardHaloLabelFont "Answer the font to be used in the eToys environment" ^ Parameters at: #haloLabelFont ifAbsentPut: [TextStyle defaultFont]! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'md 12/22/2006 14:22' prior: 21620011! standardListFont "Answer the font to be used in lists" ^ Parameters at: #standardListFont ifAbsentPut: [TextStyle defaultFont]! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'md 12/22/2006 14:23' prior: 21620689! standardMenuFont "Answer the font to be used in menus" ^ Parameters at: #standardMenuFont ifAbsentPut: [TextStyle defaultFont]! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'md 12/22/2006 14:23' prior: 21621428! standardPaintBoxButtonFont "Answer the font to be used in the eToys environment" ^ Parameters at: #paintBoxButtonFont ifAbsentPut: [self standardButtonFont]! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'tween 8/4/2007 14:30' prior: 21621859! standardSystemFont "Answer the standard system font " ^(TextConstants at: #DefaultTextStyle) defaultFont! ! !Preferences class methodsFor: 'initialization - save/load' stamp: 'mt 8/26/2015 14:29' prior: 21784422! storePreferencesIn: aFileName | stream prefsSnapshot | #(Prevailing PersonalPreferences) do: [:ea | Parameters removeKey: ea ifAbsent: []]. stream := ReferenceStream fileNamed: aFileName. stream nextPut: Parameters. prefsSnapshot := preferencesDictionary copy. prefsSnapshot keysAndValuesDo: [:key :pref | prefsSnapshot at: key put: pref asPreference]. stream nextPut: prefsSnapshot. stream nextPut: (Smalltalk isMorphic ifTrue:[World fillStyle] ifFalse:[self desktopColor]). stream close! ! !Preferences class methodsFor: 'initialization - save/load' stamp: 'nk 11/17/2002 12:08' prior: 21786094! storePreferencesToDisk Cursor wait showWhile: [ [ self storePreferencesIn: 'my.prefs' ] on: Error do: [ :ex | self inform: 'there was an error storing your preferences to disk' ]]! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'jmv 8/5/2009 23:11' prior: 21622222! subPixelRenderColorFonts ^ self valueOfFlag: #subPixelRenderColorFonts ifAbsent: [ true ]! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'jmv 8/5/2009 23:11' prior: 21622562! subPixelRenderFonts ^ self valueOfFlag: #subPixelRenderFonts ifAbsent: [ true ]! ! !Preferences class methodsFor: 'prefs - misc' stamp: 'sw 11/15/2001 08:37' prior: 21663582! suppressWindowTitlesInInstanceBrowsers "Hard-coded for the moment: answer whether instance browsers should suppresss their window titles" ^ false! ! !Preferences class methodsFor: 'prefs - text' stamp: 'sw 9/7/1999 12:53' prior: 21865265! textHighlightColor ^ Parameters at: #textHighlightColor! ! !Preferences class methodsFor: 'prefs - text' stamp: 'sw 9/7/1999 12:54' prior: 21865579! textHighlightColor: aColor Parameters at: #textHighlightColor put: aColor! ! !Preferences class methodsFor: 'themes - tools' stamp: 'dgd 9/1/2003 11:43' prior: 21734315! themeChoiceButtonOfColor: aColor font: aFont "Answer a button inviting the user to choose a theme" | aButton | aButton := SimpleButtonMorph new target: self; actionSelector: #offerThemesMenu. aButton label: 'change theme...' translated font: aFont. aButton color: aColor. aButton setBalloonText: 'Numerous "Preferences" govern many things about the way Squeak looks and behaves. Set individual preferences using a "Preferences" panel. Set an entire "theme" of many Preferences all at the same time by pressing this "change theme" button and choosing a theme to install. Look in category "themes" in Preferences class to see what each theme does; add your own methods to the "themes" category and they will show up in the list of theme choices.' translated. ^ aButton! ! !Preferences class methodsFor: 'get/set - flags' stamp: 'mt 8/26/2015 17:40'! toggle: flagName "Toggle the given preference. prefSymbol must be of a boolean preference" ^ self setFlag: flagName toValue: (self valueOfFlag: flagName) not! ! !Preferences class methodsFor: 'get/set - flags' stamp: 'mt 8/27/2015 10:59' prior: 21631374! togglePreference: flagName self flag: #deprecated. ^ self toggle: flagName.! ! !Preferences class methodsFor: 'support' stamp: 'mt 8/26/2015 15:20'! typeForValue: anObject "Returns the preference type for the given value to be distinguished in tools." { AbstractFont -> #Font. Boolean -> #Boolean. Color -> #Color. String -> #String. Number -> #Number } do: [:spec | (anObject isKindOf: spec key) ifTrue: [^ spec value]]. ^ #Object ! ! !Preferences class methodsFor: 'defaults' stamp: 'mt 8/27/2015 09:02'! unclassifiedCategory "Generic category to be used when no specific alternative is provided." ^ #unclassified! ! !Preferences class methodsFor: 'prefs - window colors' stamp: 'laza 4/26/2010 10:22' prior: 21878357! uniformWindowColor ^Color veryVeryLightGray! ! !Preferences class methodsFor: 'updating - system' stamp: 'sw 4/13/2001 11:22' prior: 21810768! universalTilesSettingToggled "The current value of the universalTiles flag has changed; now react" (self preferenceAt: #universalTiles ifAbsent: [^ self]) localToProject ifFalse: [^ self inform: 'This is troubling -- you may regret having done that, because the change will apply to *all projects*, including pre-existing ones. Unfortunately this check is done after the damage is done, so you may be hosed. Fortunately, however, you can simply reverse your choice right now and perhaps no deep damage will have been done.']. self universalTiles "User just switched project to classic tiles" ifFalse: [self inform: 'CAUTION -- if you had any scripted objects in this project that already used universal tiles, there is no reasonable way to go back to classic tiles. Recommended course of action in that case: just toggle this preference right back to true.'] ifTrue: [Preferences capitalizedReferences ifFalse: [Preferences enable: #capitalizedReferences. self inform: 'Note that the "capitalizedReferences" flag has now been automatically set to true for you, since this is required for the use of universal tiles.']. World isMorph ifTrue: [World recreateScripts]]! ! !Preferences class methodsFor: 'prefs - misc' stamp: 'sw 2/16/1999 11:24' prior: 21664003! useCategoryListsInViewers "Temporarily hard-coded pending viewer work underway" ^ false! ! !Preferences class methodsFor: 'prefs - misc' stamp: 'mt 8/27/2015 10:01'! useFormsInPaintBox ^ self valueOfFlag: #useFormsInPaintBox! ! !Preferences class methodsFor: 'prefs - misc' stamp: 'yo 1/13/2005 11:05' prior: 21736940! useFormsInPaintBox: aBoolean self setPreference: #useFormsInPaintBox toValue: aBoolean ! ! !Preferences class methodsFor: 'get/set - flags' stamp: 'mt 8/26/2015 17:14' prior: 21631927! valueOfFlag: aFlagName "Utility method for all the preferences that are boolean, and for backward compatibility" ^self valueOfFlag: aFlagName ifAbsent: [false]! ! !Preferences class methodsFor: 'get/set - flags' stamp: 'hpt 9/26/2004 16:48' prior: 21632412! valueOfFlag: aFlagName ifAbsent: booleanValuedBlock "the same as in #valueOfFlag:" ^self valueOfPreference: aFlagName ifAbsent: booleanValuedBlock.! ! !Preferences class methodsFor: 'get/set' stamp: 'mt 8/26/2015 17:04' prior: 21633377! valueOfPreference: aPreferenceSymbol ifAbsent: block "Answer the value of the given preference" ^ (self preferenceAt: aPreferenceSymbol ifAbsent: [^ block value]) preferenceValue! ! !Preferences class methodsFor: 'updating - system' stamp: 'sw 7/10/2005 03:06' prior: 21812451! vectorVocabularySettingChanged "The current value of the useVectorVocabulary flag has changed; now react. No senders, but invoked by the Preference object associated with the #useVectorVocabulary preference." Smalltalk isMorphic ifTrue: [ActiveWorld makeVectorUseConformToPreference]! ! !Preferences class methodsFor: 'support - misc' stamp: 'sw 8/29/2000 16:12' prior: 21736402! wantsChangeSetLogging "Answer whether method changes in the receiver should be logged to current change set. This circumlocution avoids such logging for programmatically-compiled methods in Preferences, removing an annoyance" ^ Utilities authorInitialsPerSe ~= 'programmatic'! ! !Preferences class methodsFor: 'prefs - window colors' stamp: 'mt 4/3/2015 16:35' prior: 21879645! windowColorFor: aModelClassName | classToCheck prefSymbol | self checkForWindowColors. classToCheck := Smalltalk at: aModelClassName. prefSymbol := self windowColorPreferenceForClassNamed: classToCheck name. [(classToCheck ~~ Object) and: [(self preferenceAt: prefSymbol) isNil]] whileTrue: [classToCheck := classToCheck superclass. prefSymbol := self windowColorPreferenceForClassNamed: classToCheck name]. ^self valueOfPreference: prefSymbol ifAbsent: [self uniformWindowColor].! ! !Preferences class methodsFor: 'prefs - window colors' stamp: 'tfel 2/27/2010 19:34' prior: 21882239! windowColorHelp "Provide help for the window-color panel" | helpString | helpString := 'The "Window Colors" panel lets you select colors for many kinds of standard Squeak windows. You can change your color preference for any particular tool by clicking on the color swatch and then selecting the desired color from the resulting color-picker. The three buttons entitled "Bright", "Pastel", and "Gray" let you revert to any of three different standard color schemes. The choices you make in the Window Colors panel only affect the colors of new windows that you open. You can make other tools have their colors governed by this panel by simply implementing #windowColorSpecification on the class side of the model -- consult implementors of that method to see examples of how to do this.'. (StringHolder new contents: helpString) openLabel: 'About Window Colors' "Preferences windowColorHelp"! ! !Preferences class methodsFor: 'prefs - window colors' stamp: 'hpt 10/9/2005 23:28' prior: 21883975! windowColorPreferenceForClassNamed: aClassName | aColorSpec wording | aColorSpec := WindowColorRegistry registeredWindowColorSpecFor: aClassName. wording := aColorSpec ifNil: [aClassName] ifNotNil: [aColorSpec wording]. ^(wording, 'WindowColor') asLegalSelector asSymbol.! ! !Preferences class methodsFor: 'prefs - window colors' stamp: 'hpt 10/9/2005 23:17' prior: 21884728! windowColorTable "Answer a list of WindowColorSpec objects, one for each tool to be represented in the window-color panel" ^ (WindowColorRegistry registeredWindowColorSpecs asSortedCollection: [:specOne :specTwo | specOne wording < specTwo wording]) asArray. "Preferences windowColorTable"! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'md 12/22/2006 14:23' prior: 21623257! windowTitleFont "Answer the standard font to use for window titles" ^ Parameters at: #windowTitleFont ifAbsentPut: [StrikeFont familyName: #NewYork size: 15]! ! !Preferences class methodsFor: 'prefs - fonts' stamp: 'sw 12/8/1999 22:18' prior: 21623684! windowTitleStyle "Answer the standard style to use for window titles" ^ self windowTitleFont textStyle! ! !PragmaPreference methodsFor: 'converting' stamp: 'mt 8/26/2015 16:09' prior: 20023056! asPreference | preference | preference := Preference new. preference name: name defaultValue: defaultValue helpString: helpString localToProject: self localToProject categoryList: categoryList changeInformee: changeInformee changeSelector: changeSelector type: type. preference rawValue: self preferenceValue. ^preference! ! !PragmaPreference methodsFor: 'accessing' stamp: 'mt 8/26/2015 16:48'! id ^ (self provider name, '>>', getter) asSymbol! ! !PragmaPreference methodsFor: 'as yet unclassified' stamp: 'mt 8/26/2015 16:09'! localToProject "Pragma preferences are stored and accessed outside the scope of the preference mechanism. Hence, they cannot be project-local." ^ false! ! !Project methodsFor: 'project parameters' stamp: 'mt 8/27/2015 10:43' prior: 60825425! initializeProjectPreferences "Initialize the project's preferences from currently-prevailing preferences that are currently being held in projects in this system" projectPreferenceFlagDictionary := Project current projectPreferenceFlagDictionary deepCopy. "Project overrides in the new project start out being the same set of overrides in the calling project" Preferences allPreferences do: "in case we missed some" [:aPreference | aPreference localToProject ifTrue: [(projectPreferenceFlagDictionary includesKey: aPreference name) ifFalse: [projectPreferenceFlagDictionary at: aPreference name put: aPreference preferenceValue]]]. (Project current projectParameterAt: #disabledGlobalFlapIDs ifAbsent: [nil]) ifNotNil: [:idList | self projectParameterAt: #disabledGlobalFlapIDs put: idList copy] ! ! !Project methodsFor: 'menu messages' stamp: 'mt 8/27/2015 10:43' prior: 60816137! installProjectPreferences "Install the settings of all preferences presently held individually by projects in the receiver's projectPreferenceFlagDictionary" Preferences allPreferences do: [:aPreference | | localValue | aPreference localToProject ifTrue: [localValue := self projectPreferenceFlagDictionary at: aPreference name ifAbsent: [nil]. localValue ifNotNil: [aPreference rawValue: localValue]]]! ! !Project methodsFor: 'menu messages' stamp: 'mt 8/27/2015 10:43' prior: 60819485! saveProjectPreferences "Preserve the settings of all preferences presently held individually by projects in the receiver's projectPreferenceFlagDictionary" Preferences allPreferences do: [:aPreference | aPreference localToProject ifTrue: [projectPreferenceFlagDictionary at: aPreference name put: aPreference preferenceValue]]! ! !Preference methodsFor: 'accessing' stamp: 'mt 8/26/2015 16:48'! id ^ self name asSymbol! ! !Preference methodsFor: 'local to project' stamp: 'mt 8/26/2015 16:09' prior: 66904743! isProjectLocalString "Answer a string representing whether sym is a project-local preference or not" | aStr | aStr := 'each project has its own setting'. ^ self localToProject ifTrue: ['', aStr] ifFalse: ['', aStr]! ! PreferenceExample class removeSelector: #textPref:! PreferenceExample class removeSelector: #textPref! PreferenceExample class removeSelector: #numericPref:! PreferenceExample class removeSelector: #numericPref! PreferenceExample class removeSelector: #initialize! PreferenceExample class removeSelector: #colorPref:! PreferenceExample class removeSelector: #colorPref! PreferenceExample class removeSelector: #booleanPref:! PreferenceExample class removeSelector: #booleanPref! Smalltalk removeClassNamed: #PreferenceExample! Preferences class removeSelector: #useServicesInBrowserButtonBar! Preferences class removeSelector: #useOnlyServicesInMenu! Preferences class removeSelector: #toggleWindowPolicy! Preferences class removeSelector: #toggleRoundedCorners! Preferences class removeSelector: #toggleMenuColorPolicy! Preferences class removeSelector: #respondToPreferencePragmasInMethod:class:! Preferences class removeSelector: #removePreferencesFor:! Preferences class removeSelector: #preferenceObjectsInCategory:! Preferences class removeSelector: #listOfCategories! Preferences class removeSelector: #inlineServicesInMenu! Preferences class removeSelector: #fontFactor! Preferences class removeSelector: #enableOrDisable:asPer:! Preferences class removeSelector: #enableGently:! Preferences class removeSelector: #disableGently:! Preferences class removeSelector: #createPreference:categoryList:description:type:! Preferences class removeSelector: #compileHardCodedPref:enable:! Preferences class removeSelector: #compileAccessMethodForPreference:! Preferences class removeSelector: #categoryNames! Preferences class removeSelector: #categoriesContainingPreference:! Preferences class removeSelector: #addBooleanPreference:categories:default:balloonHelp:projectLocal:changeInformee:changeSelector:! "System"! !Installer class methodsFor: 'repositories' stamp: 'topa 8/27/2015 23:22' prior: 20578902! gemsource ^ self monticello http: 'http://seaside.gemtalksystems.com/ss'! ! "Installer-Core"! !TheWorldMenu methodsFor: 'construction' stamp: 'mt 8/27/2015 10:14' prior: 85178490! appearanceMenu "Build the appearance menu for the world." ^self fillIn: (self menu: 'appearance...') from: { {'preferences...' . { self . #openPreferencesBrowser} . 'Opens a "Preferences Browser" which allows you to alter many settings' } . {'choose theme...' . { Preferences . #offerThemesMenu} . 'Presents you with a menu of themes; each item''s balloon-help will tell you about the theme. If you choose a theme, many different preferences that come along with that theme are set at the same time; you can subsequently change any settings by using a Preferences Panel'} . nil . {'system fonts...' . { self . #standardFontDo} . 'Choose the standard fonts to use for code, lists, menus, window titles, etc.'}. {'text highlight color...' . { Preferences . #chooseTextHighlightColor} . 'Choose which color should be used for text highlighting in Morphic.'}. {'insertion point color...' . { Preferences . #chooseInsertionPointColor} . 'Choose which color to use for the text insertion point in Morphic.'}. {'keyboard focus color' . { Preferences . #chooseKeyboardFocusColor} . 'Choose which color to use for highlighting which pane has the keyboard focus'}. nil. {#menuColorString . { self . #toggleMenuColorPolicy} . 'Governs whether menu colors should be derived from the desktop color.'}. {#roundedCornersString . { self . #toggleRoundedCorners} . 'Governs whether morphic windows and menus should have rounded corners.'}. nil. {'full screen on' . { Project current . #fullScreenOn} . 'puts you in full-screen mode, if not already there.'}. {'full screen off' . { Project current . #fullScreenOff} . 'if in full-screen mode, takes you out of it.'}. nil. {'set display depth...' . {self. #setDisplayDepth} . 'choose how many bits per pixel.'}. {'set desktop color...' . {self. #changeBackgroundColor} . 'choose a uniform color to use as desktop background.'}. {'set gradient color...' . {self. #setGradientColor} . 'choose second color to use as gradient for desktop background.'}. {'use texture background' . { #myWorld . #setStandardTexture} . 'apply a graph-paper-like texture background to the desktop.'}. nil. {'clear turtle trails from desktop' . { #myWorld . #clearTurtleTrails} . 'remove any pigment laid down on the desktop by objects moving with their pens down.'}. {'pen-trail arrowhead size...' . { Preferences. #setArrowheads} . 'choose the shape to be used in arrowheads on pen trails.'}. }! ! !TheWorldMenu methodsFor: 'action' stamp: 'mt 8/27/2015 10:14'! toggleMenuColorPolicy Preferences toggle: #menuColorFromWorld.! ! !TheWorldMenu methodsFor: 'action' stamp: 'mt 8/27/2015 10:13'! toggleRoundedCorners Preferences toggle: #roundedWindowCorners.! ! !TheWorldMenu methodsFor: 'action' stamp: 'mt 8/27/2015 10:12' prior: 85153138! toggleWindowPolicy Preferences toggle: #reverseWindowStagger.! ! !Morph methodsFor: 'testing' stamp: 'eem 8/27/2015 16:42'! isMenuItemMorph ^false! ! !ScrollPane methodsFor: 'geometry' stamp: 'mt 8/27/2015 11:57' prior: 32689381! extent: aPoint self handleResizeAction: [ (bounds extent closeTo: aPoint) ifTrue: [false] ifFalse: [ super extent: aPoint. owner ifNotNil: [owner layoutChanged]. true]].! ! !MenuItemMorph methodsFor: 'testing' stamp: 'eem 8/27/2015 16:42'! isMenuItemMorph ^true! ! !StandardScriptingSystem methodsFor: 'utilities' stamp: 'mt 8/26/2015 17:44' prior: 23819735! customizeForEToyUsers: aBoolean "If aBoolean is true, set things up for etoy users. If it's false, unset some of those things. Some things are set when switching into etoy mode but not reversed when switching out of etoy mode." #( (allowEtoyUserCustomEvents no reverse) (balloonHelpEnabled yes dontReverse) (debugHaloHandle no reverse) (modalColorPickers yes dontReverse) (oliveHandleForScriptedObjects no dontReverse) (uniqueNamesInHalos yes reverse) (useUndo yes dontReverse) (infiniteUndo no dontReverse) (warnIfNoChangesFile no reverse) (warnIfNoSourcesFile no reverse)) do: [:trip | (aBoolean or: [trip third == #reverse]) ifTrue: [Preferences setFlag: trip first toValue: ((trip second == #yes) & aBoolean) | ((trip second == #no) & aBoolean not)]]! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'mt 8/26/2015 17:41' prior: 61516677! toggleClassicNavigatorIfAppropriate "If appropriate, toggle the presence of classic navigator" Preferences classicNavigatorEnabled ifTrue: [^ Preferences toggle: #showProjectNavigator]! ! "Morphic"! !TheWorldMenu methodsFor: '*MorphicExtras-windows & flaps menu' stamp: 'mt 8/26/2015 17:42' prior: 85236533! formulateFlapsMenu: aMenu "Fill aMenu with appropriate content" aMenu addTitle: 'flaps' translated. aMenu addStayUpItem. Preferences classicNavigatorEnabled ifTrue: [aMenu addUpdating: #navigatorShowingString enablementSelector: #enableProjectNavigator target: Preferences selector: #toggle: argumentList: #(showProjectNavigator). aMenu balloonTextForLastItem: (Preferences preferenceAt: #showProjectNavigator) helpString translated]. Flaps sharedFlapsAllowed ifTrue: [self fillIn: aMenu from: {{#suppressFlapsString. {Project current. #toggleFlapsSuppressed}. 'Whether prevailing flaps should be shown in the project right now or not.'}}. aMenu addUpdating: #automaticFlapLayoutString target: Preferences selector: #toggle: argumentList: #(automaticFlapLayout). aMenu balloonTextForLastItem: (Preferences preferenceAt: #automaticFlapLayout) helpString translated. aMenu addLine. Flaps addIndividualGlobalFlapItemsTo: aMenu]. self fillIn: aMenu from: { nil. {'make a new flap'. {Flaps. #addLocalFlap}. 'Create a new flap. You can later make it into a shared flap is you wish.'}. nil.}. Flaps sharedFlapsAllowed ifTrue: [aMenu addWithLabel: 'put shared flaps on bottom' translated enablementSelector: #showSharedFlaps target: Flaps selector: #sharedFlapsAlongBottom argumentList: #(). aMenu balloonTextForLastItem: 'Group all the standard shared flaps along the bottom edge of the screen' translated. self fillIn: aMenu from: { {'destroy all shared flaps'. {Flaps. #disableGlobalFlaps}. 'Destroy all the shared flaps and disable their use in all projects.'}}] ifFalse: [aMenu add: 'install default shared flaps' translated target: Flaps action: #enableGlobalFlaps. aMenu balloonTextForLastItem: 'Create the default set of shared flaps' translated. aMenu add: 'install etoy flaps' translated target: Flaps action: #enableEToyFlaps. aMenu balloonTextForLastItem: 'Put up the default etoy flaps: a custom Suplies flap and the Navigator flap' translated. aMenu addLine]. self fillIn: aMenu from: { nil. {'about flaps...'. {Flaps . #explainFlaps}. 'Gives a window full of details about how to use flaps.'}}! ! "MorphicExtras"! !PreferenceBrowser methodsFor: 'accessing' stamp: 'mt 8/27/2015 10:42' prior: 66252927! allPreferences ^ preferences allPreferences asSortedCollection: [:pref1 :pref2 | pref1 viewRegistry viewOrder >booleanPref)' type: #Boolean> ^BooleanPref! ! !PreferencesTestExample class methodsFor: 'preferences' stamp: 'ar 3/3/2009 22:35'! booleanPref: aBool BooleanPref := aBool. self inform: 'The new preference value is: ', aBool asString.! ! !PreferencesTestExample class methodsFor: 'preferences' stamp: 'ar 8/4/2009 20:52'! colorPref >colorPref)' type: #Color> ^ColorPref! ! !PreferencesTestExample class methodsFor: 'preferences' stamp: 'ar 3/3/2009 22:36'! colorPref: aColor ColorPref := aColor. self inform: 'The new preference value is: ', aColor asString.! ! !PreferencesTestExample class methodsFor: 'preferences' stamp: 'ar 3/5/2009 20:09'! initialize "PreferenceExample initialize" "Initialize the default values and register preferences" TextPref := 'Hello World'. NumericPref := 1234. BooleanPref := true. ColorPref := Color green.! ! !PreferencesTestExample class methodsFor: 'preferences' stamp: 'ar 8/4/2009 20:52'! numericPref >numericPref)' type: #Number> ^NumericPref! ! !PreferencesTestExample class methodsFor: 'preferences' stamp: 'ar 3/3/2009 22:36'! numericPref: aNumber NumericPref := aNumber. self inform: 'The new preference value is: ', aNumber asString.! ! !PreferencesTestExample class methodsFor: 'preferences' stamp: 'ar 8/4/2009 20:52'! textPref >textPref)' type: #String> ^TextPref! ! !PreferencesTestExample class methodsFor: 'preferences' stamp: 'mt 8/27/2015 08:50'! textPref: aString TextPref := aString.! ! !PreferencesTest methodsFor: 'running' stamp: 'mt 8/26/2015 15:30'! setUp super setUp. sut := PreferencesTestPreferences.! ! !PreferencesTest methodsFor: 'running' stamp: 'mt 8/27/2015 10:43'! tearDown sut allPreferences do: [:pref | sut removePreference: pref id]. sut class organization removeEmptyCategories. super tearDown.! ! !PreferencesTest methodsFor: 'tests' stamp: 'mt 8/26/2015 15:31'! test01Empty self assert: sut dictionaryOfPreferences isEmpty.! ! !PreferencesTest methodsFor: 'tests' stamp: 'mt 8/26/2015 16:51'! test02AddSetRemovePreference self assert: (sut valueOfPreference: #foo ifAbsent: []) isNil. self assert: (sut respondsTo: #foo) not. "auto-generated accessor" sut addPreference: #foo category: #bar default: false. self assert: (sut valueOfPreference: #foo ifAbsent: []) = false. self assert: (sut perform: #foo) = false. sut setPreference: #foo toValue: true. self assert: (sut valueOfPreference: #foo ifAbsent: []) = true. self assert: (sut perform: #foo) = true. sut removePreference: #foo. self assert: (sut valueOfPreference: #foo ifAbsent: []) isNil. self assert: (sut respondsTo: #foo) not.! ! !PreferencesTest methodsFor: 'tests' stamp: 'mt 8/26/2015 17:09'! test03Type sut addPreference: #foo default: true. self assert: (sut preferenceAt: #foo) type == #Boolean. sut addPreference: #foo default: 123. self assert: (sut preferenceAt: #foo) type == #Number. sut addPreference: #foo default: 'Hello, World'. self assert: (sut preferenceAt: #foo) type == #String. sut addPreference: #foo default: Color red. self assert: (sut preferenceAt: #foo) type == #Color. sut addPreference: #foo default: 1@5. self assert: (sut preferenceAt: #foo) type == #Object. ! ! !PreferencesTest methodsFor: 'tests' stamp: 'mt 8/26/2015 17:15'! test04TypeNoUpdate sut addPreference: #foo default: true. sut setPreference: #foo toValue: 123. self assert: (sut preferenceAt: #foo) type == #Boolean.! ! !PreferencesTest methodsFor: 'tests' stamp: 'mt 8/26/2015 17:24'! test05AutoAdd | pref | self assert: (sut valueOfPreference: #foo ifAbsent: []) isNil. pref := sut setPreference: #foo toValue: 123. self assert: pref preferenceValue = 123.! ! !PreferencesTest methodsFor: 'tests' stamp: 'mt 8/26/2015 17:45'! test06Flags "Flags are boolean preferences." self assert: (sut valueOfFlag: #isHappy) == false. "Not known but false for default." sut setFlag: #isHappy toValue: true. self assert: (sut valueOfFlag: #isHappy) == true. self assert: (sut perform: #isHappy) == true. sut disable: #useIt. self assert: (sut valueOfFlag: #useIt) == false. self assert: (sut perform: #useIt) == false. sut enable: #useIt. self assert: (sut valueOfFlag: #useIt) == true. self assert: (sut perform: #useIt) == true. sut toggle: #useIt. self assert: (sut valueOfFlag: #useIt) == false. ! ! !PreferencesTest methodsFor: 'tests' stamp: 'mt 8/26/2015 17:45'! test07UnknownPreference self assert: (sut valueOfPreference: #notKnown) isNil. self assert: (sut valueOfPreference: #notKnown ifAbsent: [#default]) = #default.! ! !PreferencesTest methodsFor: 'tests' stamp: 'mt 8/27/2015 07:49'! test08DNUFallback sut setPreference: #foo toValue: 123. sut class removeSelectorSilently: #foo. self assert: (sut perform: #foo) = 123. self assert: (sut perform: #unknownSelector) isNil.! ! !PreferencesTest methodsFor: 'tests' stamp: 'mt 8/27/2015 08:49'! test09AddSetRemovePragmaPreference | id pref | id := PreferencesTestExample name, '>>', #textPref. pref := sut addPragmaPreference: (PreferencesTestExample class >> #textPref) pragmas first. self assert: id equals: pref id. self assert: (sut preferenceAt: pref id) == pref. "Reset the preference explicitely." PreferencesTestExample textPref: ''. self assert: '' equals: PreferencesTestExample textPref. sut setPreference: pref id toValue: 'foo'. self assert: 'foo' equals: (sut valueOfPreference: pref id). self assert: 'foo' equals: PreferencesTestExample textPref. sut removePreference: pref id. self assert: (sut preferenceAt: pref id ifAbsent: []) isNil.! ! !PreferencesTest methodsFor: 'tests' stamp: 'mt 8/27/2015 09:04'! test10Unclassified | pref | pref := sut addPreference: #foobar default: 123. self assert: sut unclassifiedCategory equals: pref categoryList first.! ! !PreferencesTest methodsFor: 'tests' stamp: 'mt 8/27/2015 09:11'! test11CategoryList sut addPreference: #foo category: #blubb default: 123. self assert: #(blubb) equals: (sut categoryListOfPreference: #foo). ! ! !PreferencesTest methodsFor: 'tests' stamp: 'mt 8/27/2015 09:35'! test12HardCodedPreference self assert: (sut respondsTo: #someStaticFoo) not. sut compileAccessorForPreferenceNamed: #someStaticFoo value: 42. self assert: 42 equals: (sut perform: #someStaticFoo). self assert: (sut valueOfPreference: #someStaticFoo ifAbsent: []) isNil. "Hard-coded preferences have their value only in the source code. We must leave them in the same package." self deny: ((sut class organization categoryOfElement: #someStaticFoo) beginsWith: '*'). sut class removeSelectorSilently: #someStaticFoo.! ! "Tests"! SystemOrganization classify: #PBColorPreferenceView under: #PreferenceBrowser! SystemOrganization classify: #PBWindowColorPreferenceView under: #PreferenceBrowser! !PBColorPreferenceView class methodsFor: 'class initialization' stamp: 'hpt 12/6/2004 20:49' prior: 59985283! initialize PreferenceViewRegistry ofColorPreferences register: self.! ! !PBColorPreferenceView class methodsFor: 'class initialization' stamp: 'ar 1/2/2010 16:33' prior: 59985887! unload "Unload order is not guaranteed so guard against failure" [PreferenceViewRegistry ofColorPreferences unregister: self] on: Error do:[]! ! !PBColorPreferenceView methodsFor: 'user interface' stamp: 'hpt 12/6/2004 21:24' prior: 59983840! colorSwatch ^UpdatingRectangleMorph new target: self preference; getSelector: #preferenceValue; putSelector: #preferenceValue:; extent: 22@22; setBalloonText: 'click here to change the color' translated; yourself.! ! !PBColorPreferenceView methodsFor: 'user interface' stamp: 'kfr 5/6/2015 14:29' prior: 59984570! representativeButtonWithColor: aColor inPanel: aPreferenceBrowser ^self horizontalPanel layoutInset: 2; color: aColor; cellInset: 20; cellPositioning: #center; addMorphBack: (StringMorph contents: self preference name); addMorphBack: self horizontalFiller; addMorphBack: self colorMenuButton; yourself! ! !PBWindowColorPreferenceView class methodsFor: 'class initialization' stamp: 'hpt 12/8/2004 18:40' prior: 63052110! initialize self viewRegistry register: self.! ! !PBWindowColorPreferenceView class methodsFor: 'class initialization' stamp: 'ar 1/2/2010 16:34' prior: 63052660! unload "Unload order is not guaranteed so guard against failure" [self viewRegistry unregister: self] on: Error do:[]! ! !PBWindowColorPreferenceView class methodsFor: 'class initialization' stamp: 'hpt 12/8/2004 18:40' prior: 63053108! viewRegistry ^(PreferenceViewRegistry registryOf: #windowColorPreferences) viewOrder: 6; yourself.! ! !PBWindowColorPreferenceView methodsFor: 'initialization' stamp: 'tfel 2/27/2010 19:34' prior: 63051166! initialize super initialize. self addActionTitled: 'Bright' target: Preferences selector: #installBrightWindowColors arguments: {} balloonText: 'Use standard bright colors for all windows' translated. self addActionTitled: 'Pastel' target: Preferences selector: #installPastelWindowColors arguments: {} balloonText: 'Use standard pastel colors for all windows' translated. self addActionTitled: 'Gray' target: Preferences selector: #installUniformWindowColors arguments: {} balloonText: 'Use gray backgrounds for all standard windows' translated.! ! !Bezier3Segment class methodsFor: 'instance creation' stamp: 'DSM 10/15/1999 15:23' prior: 54246901! from: p1 to: p2 ^ self new from: p1 via: (p1 interpolateTo: p2 at: 0.3333) and: (p1 interpolateTo: p2 at: 0.66667) to: p2! ! !Bezier3Segment class methodsFor: 'instance creation' stamp: 'DSM 10/15/1999 15:24' prior: 54247113! from: p1 via: p2 and: p3 to: p4 ^ self new from: p1 via: p2 and: p3 to: p4! ! !CompressedBoundaryShape methodsFor: 'accessing' stamp: 'ls 10/10/1999 13:52' prior: 54727832! bounds | min max width | points isEmpty ifTrue:[^0@0 corner: 1@1]. min := max := points first. points do:[:pt| min := min min: pt. max := max max: pt ]. width := 0. lineWidths valuesDo:[:w| width := width max: w]. ^(min corner: max) insetBy: (width negated asPoint)! ! "Balloon"! !ZipArchiveMember methodsFor: 'private-writing' stamp: 'cmm 7/16/2015 15:34'! openStreamWhile: aBlock ^ aBlock value! ! !ZipArchiveMember methodsFor: 'writing' stamp: 'cmm 7/16/2015 15:35' prior: 59800730! writeTo: aStream self openStreamWhile: [ self rewindData. writeLocalHeaderRelativeOffset := aStream position. self writeLocalFileHeaderTo: aStream ; writeDataTo: aStream ; refreshLocalFileHeaderTo: aStream ]! ! !ZipNewFileMember methodsFor: 'initialization' stamp: 'cmm 7/16/2015 15:29' prior: 55274125! from: aFileName | entry | compressionMethod := CompressionStored. "Now get the size, attributes, and timestamps, and see if the file exists" stream := StandardFileStream readOnlyFileNamed: aFileName. self localFileName: (externalFileName := stream name). entry := stream directoryEntry. compressedSize := uncompressedSize := entry fileSize. desiredCompressionMethod := compressedSize > 0 ifTrue: [ CompressionDeflated ] ifFalse: [ CompressionStored ]. self setLastModFileDateTimeFrom: entry modificationTime. stream close! ! !ZipNewFileMember methodsFor: 'private-writing' stamp: 'cmm 7/16/2015 15:41'! openStreamWhile: aBlock stream open. ^ aBlock ensure: [ stream close ]! ! "Compression"! SystemOrganization classify: #TextPrinter under: #'Graphics-Text'! !HostWindowProxy class methodsFor: 'system startup' stamp: 'tpr 10/1/2004 16:07' prior: 84521795! isActiveHostWindowProxyClass "subclasses must override this" self subclassResponsibility! ! !HostWindowProxy class methodsFor: 'initialize-release' stamp: 'tpr 10/1/2004 16:35' prior: 84522919! on: aSourceForm "Build a new window proxy by finding the appropriate platform specific subclass and setting it up for this Form-like argument" ^ActiveProxyClass new on: aSourceForm! ! !ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'tk 9/13/97 16:13' prior: 17008368! putForm: aForm onStream: aWriteStream "Store the given form on a file of the given name." | writer | writer := self on: aWriteStream. Cursor write showWhile: [writer nextPutImage: aForm]. writer close. ! ! !TextPrinter class methodsFor: 'accessing' stamp: 'ar 4/30/98 18:31' prior: 51832403! defaultPaperSize ^DefaultPaperSize! ! !TextPrinter class methodsFor: 'accessing' stamp: 'ar 4/30/98 18:31' prior: 51832656! defaultPaperSize: aPoint DefaultPaperSize := aPoint! ! !TextPrinter class methodsFor: 'accessing' stamp: 'dew 3/7/2000 20:39' prior: 51833288! defaultTextPrinter "This is the global default TextPrinter instance." DefaultTextPrinter isNil ifTrue: [DefaultTextPrinter := self new]. ^DefaultTextPrinter! ! !TextPrinter class methodsFor: 'class initialization' stamp: 'ar 4/30/98 18:30' prior: 51833714! initialize "TextPrinter initialize" self defaultPaperSize: self paperSizeA4.! ! !TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:30' prior: 51834037! mm2in: aPoint "Convert aPoint from millimeters to inches" ^aPoint / 25.4! ! !TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:27' prior: 51834307! paperSize10x14 ^10.0@14.0! ! !TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:27' prior: 51834529! paperSize11x17 ^11.0@17.0! ! !TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:27' prior: 51834758! paperSizeA3 ^self mm2in: 297@420! ! !TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:27' prior: 51834994! paperSizeA4 ^self mm2in: 210@297! ! !TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:27' prior: 51835230! paperSizeA5 ^self mm2in: 148@210! ! !TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:27' prior: 51835466! paperSizeB4 ^self mm2in: 250@354! ! !TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:27' prior: 51835702! paperSizeB5 ^self mm2in: 182@257! ! !TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:28' prior: 51835932! paperSizeCSheet ^17.0@22.0! ! !TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:28' prior: 51836156! paperSizeDSheet ^22.0@34.0! ! !TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29' prior: 51836380! paperSizeESheet ^34.0@44.0! ! !TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:28' prior: 51836609! paperSizeEnvelope10 ^4.125@9.5 ! ! !TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:28' prior: 51836843! paperSizeEnvelope11 ^4.5@10.375! ! !TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:28' prior: 51837074! paperSizeEnvelope12 ^4.75@11! ! !TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:28' prior: 51837303! paperSizeEnvelope14 ^5.0@11.5! ! !TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:28' prior: 51837535! paperSizeEnvelope9 ^3.875@8.875! ! !TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:28' prior: 51837778! paperSizeEnvelopeB4 ^self mm2in: 250@353! ! !TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:28' prior: 51838030! paperSizeEnvelopeB5 ^self mm2in: 176@250! ! !TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:28' prior: 51838282! paperSizeEnvelopeB6 ^self mm2in: 176@125! ! !TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:28' prior: 51838534! paperSizeEnvelopeC3 ^self mm2in: 324@458! ! !TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29' prior: 51838786! paperSizeEnvelopeC4 ^self mm2in: 229@324! ! !TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29' prior: 51839038! paperSizeEnvelopeC5 ^self mm2in: 162@229! ! !TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29' prior: 51839290! paperSizeEnvelopeC6 ^self mm2in: 114@162! ! !TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29' prior: 51839543! paperSizeEnvelopeC65 ^self mm2in: 114@229! ! !TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29' prior: 51839815! paperSizeFanfoldGerman "German standard fanfold" ^8.5@12.0! ! !TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29' prior: 51840107! paperSizeFanfoldLegalGerman "German legal fanfold" ^8.5@13.0! ! !TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29' prior: 51840394! paperSizeFanfoldUS "US standard fanfold" ^14.875@11.0! ! !TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29' prior: 51840644! paperSizeFolio ^8.5@13.0! ! !TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29' prior: 51840864! paperSizeLegal ^8.5@14.0! ! !TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29' prior: 51841085! paperSizeLetter ^8.5@11.0! ! !TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29' prior: 51841305! paperSizeNote ^8.5@11.0! ! !TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:30' prior: 51841527! paperSizeTabloid ^11.0@17.0! ! !TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 18:42' prior: 51811077! bestColor "Set the reproduction quality to true color" depth := 32.! ! !TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 18:42' prior: 51811377! blackAndWhite "Set the reproduction quality to black and white" depth := 1.! ! !TextPrinter methodsFor: 'formatting' stamp: 'ar 4/30/98 19:25' prior: 51818433! columnRect: n "Return a rectangle describing the n-th column" | area left right | area := self textArea. left := area left + ((n-1) * self columnWidth). left := left + ((n-1) * self columnSkip). right := left + self columnWidth. ^(self in2pix: left @ area top) corner: (self in2pix: right @ area bottom)! ! !TextPrinter methodsFor: 'formatting' stamp: 'ar 4/30/98 19:20' prior: 51818979! columnSkip "Return the separating space between two columns in inches" ^0.2! ! !TextPrinter methodsFor: 'formatting' stamp: 'ar 4/30/98 19:21' prior: 51819296! columnWidth ^(self textWidth - ((self columns-1) * self columnSkip)) / self columns! ! !TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 18:50' prior: 51811625! columns ^columns! ! !TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 18:50' prior: 51811850! columns: aNumber columns := aNumber asInteger max: 1.! ! !TextPrinter methodsFor: 'initialize' stamp: 'ar 4/30/98 19:26' prior: 51825611! defaultPaperSize "Return the default paper size (inches) for printing" ^self class defaultPaperSize! ! !TextPrinter methodsFor: 'initialize' stamp: 'nk 4/2/2004 11:32' prior: 51825973! defaultResolution "Return the default resolution (DPI) for printing" ^TextStyle pixelsPerInch asPoint! ! !TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 20:14' prior: 51812082! documentTitle ^docTitle! ! !TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 20:14' prior: 51812303! documentTitle: aString docTitle := aString! ! !TextPrinter methodsFor: 'printing' stamp: 'ar 4/30/98 20:41' prior: 51829240! flushPage "The current page has been set up. Send it to the printer." form primPrintHScale: self resolution x vScale: self resolution y landscape: self landscape. "Uncomment the following for testing" "form displayOn: Display. (Delay forSeconds: 5) wait." ! ! !TextPrinter methodsFor: 'footer' stamp: 'ar 4/30/98 19:23' prior: 51815704! footerHeight "Return the (additional) height of the footer in inches." self noFooter ifTrue:[^0.0]. ^(self pix2in: 0@TextStyle default lineGrid) y * 2! ! !TextPrinter methodsFor: 'footer' stamp: 'dtl 2/12/2010 20:15' prior: 51816879! footerParagraph "Return a paragraph for the footer" | fPara rect paragraphClass | paragraphClass := Smalltalk at: #Paragraph ifAbsent: [^ self notify: 'MVC class Paragraph not present']. fPara := paragraphClass new. fPara destinationForm: form. rect := (self in2pix: self textArea bottomLeft) corner: (self in2pix: self textArea bottomRight + (0.0@self footerHeight)). fPara clippingRectangle: rect. fPara compositionRectangle: rect. ^fPara! ! !TextPrinter methodsFor: 'formatting' stamp: 'ar 4/30/98 19:29' prior: 51820402! formatColumn: columnNum startingWith: anIndex "Format a new column starting at the given string index. Return the string index indicating the start of the next column or nil if no more columns need printing." | colRect blk | colRect := self columnRect: columnNum. anIndex > 1 ifTrue:[para text: (para text copyFrom: anIndex to: para text size)]. para compositionRectangle: colRect. para clippingRectangle: colRect. para composeAll. para displayOn: form. para visibleRectangle corner y <= colRect extent y ifTrue:[^nil]. "More columns -- find the character block of the last line and adjust clip rect" blk := para characterBlockAtPoint: para visibleRectangle bottomLeft. para clearVisibleRectangle. "Make sure that the background is clean" para clippingRectangle: (colRect topLeft corner: colRect right@blk top). para displayOn: form. ^blk stringIndex.! ! !TextPrinter methodsFor: 'formatting' stamp: 'ar 4/30/98 19:29' prior: 51821799! formatPage: pageNum startingWith: anIndex "Format a new page starting at the given string index. Return the string index indicating the start of the next page or nil if no more pages need printing." | nextIndex | nextIndex := anIndex. 1 to: self columns do:[:i| nextIndex := self formatColumn: i startingWith: nextIndex. nextIndex isNil ifTrue:[^nil]. ]. ^nextIndex! ! !TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 18:42' prior: 51812575! goodColor "Set the reproduction quality to 8 bit color depth" depth := 8.! ! !TextPrinter methodsFor: 'header' stamp: 'ar 4/30/98 19:23' prior: 51823142! headerHeight "Return the (additional) height of the header in inches." self noHeader ifTrue:[^0.0]. ^(self pix2in: 0@TextStyle default lineGrid) y * 2! ! !TextPrinter methodsFor: 'header' stamp: 'dtl 2/12/2010 20:15' prior: 51824305! headerParagraph "Return a paragraph for the footer" | hPara rect paragraphClass | paragraphClass := Smalltalk at: #Paragraph ifAbsent: [^ self notify: 'MVC class Paragraph not present']. hPara := paragraphClass new. hPara destinationForm: form. rect := (self in2pix: self textArea topLeft - (0.0@self headerHeight)) corner: (self in2pix: self textArea topRight). hPara clippingRectangle: rect. hPara compositionRectangle: rect. ^hPara! ! !TextPrinter methodsFor: 'other' stamp: 'ar 4/30/98 18:39' prior: 51827095! in2mm: aPoint "Convert aPoint from millimeters to inches" ^aPoint * 25.4! ! !TextPrinter methodsFor: 'other' stamp: 'ar 4/30/98 18:38' prior: 51827413! in2pix: aPoint "Convert aPoint from inches to actual pixels" ^(aPoint * self resolution) rounded! ! !TextPrinter methodsFor: 'initialize' stamp: 'ar 4/30/98 19:39' prior: 51826553! initialize self paperSize: self defaultPaperSize. self resolution: self defaultResolution. self blackAndWhite. self landscape: false. self offsetRect: (1.0@1.0 corner: 1.0@1.0). self columns: 1. self noHeader: false. self noFooter: false. self documentTitle: 'Squeak Document (from ', Date today printString,')'.! ! !TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 18:42' prior: 51812825! landscape ^landscape! ! !TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 18:42' prior: 51813042! landscape: aBoolean landscape := aBoolean! ! !TextPrinter methodsFor: 'other' stamp: 'ar 4/30/98 18:38' prior: 51827731! mm2in: aPoint "Convert aPoint from millimeters to inches" ^aPoint / 25.4! ! !TextPrinter methodsFor: 'other' stamp: 'ar 4/30/98 18:40' prior: 51828053! mm2pix: aPoint "Convert aPoint from millimeters to actual pixels" ^self in2pix: (self mm2in: aPoint)! ! !TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 19:23' prior: 51813257! noFooter ^noFooter! ! !TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 19:22' prior: 51813499! noFooter: aBoolean "Turn off footer printing" noFooter := aBoolean.! ! !TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 19:22' prior: 51813741! noHeader ^noHeader! ! !TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 19:22' prior: 51813983! noHeader: aBoolean "Turn off header printing" noHeader := aBoolean.! ! !TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 19:27' prior: 51814225! offsetRect ^offset! ! !TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 19:27' prior: 51814470! offsetRect: aRectangle "Set the offset rectangle" offset := aRectangle! ! !TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 18:42' prior: 51814717! paperSize ^paperSize! ! !TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 18:42' prior: 51814930! paperSize: aPoint paperSize := aPoint! ! !TextPrinter methodsFor: 'other' stamp: 'ar 4/30/98 18:39' prior: 51828389! pix2in: aPoint "Convert aPoint from a pixel value to inches" ^aPoint / self resolution! ! !TextPrinter methodsFor: 'other' stamp: 'ar 4/30/98 18:40' prior: 51828725! pix2mm: aPoint "Convert aPoint from a pixel value to millimeters" ^self in2mm: (self pix2in: aPoint)! ! !TextPrinter methodsFor: 'private' stamp: 'ar 4/30/98 19:40' prior: 51831652! pixelSize "Return the size of the page in pixels" ^self in2pix: (self realPaperSize)! ! !TextPrinter methodsFor: 'footer' stamp: 'ar 4/30/98 19:24' prior: 51817724! printFooter: pageNumber "Print the footer for the given page number" | fPara | self noFooter ifTrue:[^self]. fPara := self footerParagraph. fPara centered. fPara text: ('Page ', pageNumber printString) asText. fPara displayOn: form.! ! !TextPrinter methodsFor: 'header' stamp: 'ar 4/30/98 19:23' prior: 51825129! printHeader: pageNumber "Print the header for the given page number" | fPara | self noHeader ifTrue:[^self]. fPara := self headerParagraph. fPara centered. fPara text: self documentTitle asText. fPara displayOn: form.! ! !TextPrinter methodsFor: 'printing' stamp: 'ar 4/30/98 19:19' prior: 51829973! printParagraph | pageNum nextIndex | para destinationForm: form. pageNum := 1. nextIndex := 1. [form fillColor: Color white. self printHeader: pageNum. self printFooter: pageNum. nextIndex := self formatPage: pageNum startingWith: nextIndex. self flushPage. nextIndex isNil] whileFalse:[pageNum := pageNum + 1].! ! !TextPrinter methodsFor: 'printing' stamp: 'dtl 2/12/2010 20:16' prior: 51831077! printText: aText "Print aText" | paragraphClass | form isNil ifTrue:[ form := Form extent: self pixelSize depth: depth. ]. paragraphClass := Smalltalk at: #Paragraph ifAbsent: [^ self notify: 'MVC class Paragraph not present']. para := paragraphClass withText: aText asText. Cursor wait showWhile:[ self printParagraph. ].! ! !TextPrinter methodsFor: 'private' stamp: 'ar 4/30/98 19:39' prior: 51831992! realPaperSize ^self landscape ifTrue:[self paperSize y @ self paperSize x] ifFalse:[self paperSize]! ! !TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 18:43' prior: 51815145! resolution ^resolution! ! !TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 18:43' prior: 51815362! resolution: aPoint resolution := aPoint! ! !TextPrinter methodsFor: 'formatting' stamp: 'ar 4/30/98 19:58' prior: 51822473! textArea ^(self offsetRect origin + (0.0@self headerHeight)) corner: (self realPaperSize - self offsetRect corner - (0.0@self footerHeight))! ! !TextPrinter methodsFor: 'formatting' stamp: 'ar 4/30/98 19:23' prior: 51822806! textWidth ^self textArea extent x! ! "Graphics"! !ByteArrayTest methodsFor: 'testing - platform independent access' stamp: 'ul 9/6/2015 16:11'! byteArrayFor: signedValue bits: bits bigEndian: bigEndian | unsignedValue size result | unsignedValue := signedValue negative ifTrue: [ signedValue + (1 bitShift: bits) ] ifFalse: [ signedValue ]. size := bits // 8. result := ByteArray new: size. 1 to: size do: [ :index | result at: index put: (unsignedValue digitAt: index) ]. bigEndian ifTrue: [ result reverseInPlace ]. ^result ! ! !ByteArrayTest methodsFor: 'testing - platform independent access' stamp: 'ul 9/6/2015 16:18'! testPlatformIndepentendIntegerAccessorsAtBitBorders #( shortAt:put:bigEndian: shortAt:bigEndian: false 16 longAt:put:bigEndian: longAt:bigEndian: false 32 unsignedShortAt:put:bigEndian: unsignedShortAt:bigEndian: true 16 unsignedLongAt:put:bigEndian: unsignedLongAt:bigEndian: true 32 unsignedLong64At:put:bigEndian: unsignedLong64At:bigEndian: true 64 ) groupsDo: [ :setter :getter :unsigned :storageBits | self verifyPlatformIndepentendIntegerAccessorsAtBitBordersSetter: setter getter: getter unsigned: unsigned storageBits: storageBits ]! ! !ByteArrayTest methodsFor: 'testing - platform independent access' stamp: 'ul 9/6/2015 16:18'! testPlatformIndepentendIntegerAccessorsWithRandomValues | random | random := Random seed: 36rSqueak. #( shortAt:put:bigEndian: shortAt:bigEndian: false 16 longAt:put:bigEndian: longAt:bigEndian: false 32 unsignedShortAt:put:bigEndian: unsignedShortAt:bigEndian: true 16 unsignedLongAt:put:bigEndian: unsignedLongAt:bigEndian: true 32 unsignedLong64At:put:bigEndian: unsignedLong64At:bigEndian: true 64 ) groupsDo: [ :setter :getter :unsigned :storageBits | self verifyPlatformIndepentendIntegerAccessorsWithRandomValuesSetter: setter getter: getter unsigned: unsigned storageBits: storageBits random: random ]! ! !ByteArrayTest methodsFor: 'testing - platform independent access' stamp: 'ul 9/9/2015 20:14'! verifyPlatformIndepentendIntegerAccessorsAtBitBordersSetter: setter getter: getter unsigned: unsigned storageBits: storageBits | byteArray minValue maxValue baseValues | byteArray := ByteArray new: storageBits // 8 * 2. unsigned ifTrue: [ minValue := 0. maxValue := 1 << storageBits - 1. baseValues := #(0 1) ] ifFalse: [ minValue := -1 << (storageBits - 1). maxValue := 1 << (storageBits - 1) - 1. baseValues := #(-1 0 1) ]. #(true false) do: [ :bigEndian | 0 to: storageBits - 1 do: [ :bits | baseValues do: [ :baseValue | | centerValue | centerValue := baseValue << bits. centerValue - 1 to: centerValue + 1 do: [ :value | (value between: minValue and: maxValue) ifTrue: [ self verifyPlatformIndepentendIntegerAccessorsMatch: byteArray for: value setter: setter getter: getter storageBits: storageBits bigEndian: bigEndian ] ] ] ] ] ! ! !ByteArrayTest methodsFor: 'testing - platform independent access' stamp: 'ul 9/9/2015 20:14'! verifyPlatformIndepentendIntegerAccessorsMatch: byteArray for: value setter: setter getter: getter storageBits: storageBits bigEndian: bigEndian | expectedSetterResult getterResult bytes | expectedSetterResult := self byteArrayFor: value bits: storageBits bigEndian: bigEndian. bytes := storageBits // 8. 1 to: byteArray size - bytes + 1 do: [ :index | byteArray perform: setter with: index with: value with: bigEndian. 1 to: bytes do: [ :byteIndex | self assert: (expectedSetterResult at: byteIndex) equals: (byteArray at: index + byteIndex - 1) ]. getterResult := byteArray perform: getter with: index with: bigEndian. self assert: value equals: getterResult ]! ! !ByteArrayTest methodsFor: 'testing - platform independent access' stamp: 'ul 9/9/2015 20:14'! verifyPlatformIndepentendIntegerAccessorsWithRandomValuesSetter: setter getter: getter unsigned: unsigned storageBits: storageBits random: random | byteArray randomMax randomOffset | byteArray := ByteArray new: storageBits // 8 * 2. randomMax := 1 << storageBits. randomOffset := unsigned ifTrue: [ -1 ] ifFalse: [ -1 << (storageBits - 1) - 1 ]. 10000 timesRepeat: [ | value | value := (random nextInt: randomMax) + randomOffset. #(true false) do: [ :bigEndian | self verifyPlatformIndepentendIntegerAccessorsMatch: byteArray for: value setter: setter getter: getter storageBits: storageBits bigEndian: bigEndian ] ]! ! ByteArrayTest removeSelector: #testByteArrayLongAtPreservesSign! "CollectionsTests"! !Encoder methodsFor: 'temps' stamp: 'eem 7/8/2015 09:09' prior: 57078867! bindTemp: name "Declare a temporary; error not if a field or class variable." scopeTable at: name ifPresent:[:node| "When non-interactive raise the error only if its a duplicate" node isTemp ifTrue:[^self notify:'Name already used in this method'] ifFalse:[self warnAboutShadowed: name]]. ^self reallyBind: name! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 7/14/2015 20:12' prior: 20219603! nilReadBeforeWrittenTemps | visitor readBeforeWritten | temporaries isEmpty ifTrue: [^self]. self accept: (visitor := OptimizedBlockLocalTempReadBeforeWrittenVisitor new). readBeforeWritten := visitor readBeforeWritten. temporaries reverseDo: [:temp| ((readBeforeWritten includes: temp) and: [temp isRemote not]) ifTrue: [statements addFirst: (AssignmentNode new variable: temp value: NodeNil)]]! ! !Scanner methodsFor: 'public access' stamp: 'eem 8/9/2014 09:54'! typedScan: textOrString do: aBinaryBlock "Evaluate aBinaryBlock with the token and its type for the first token in input, mapping literals to type #literal and anything else to type #word." | theTokensType atNumber theToken | self initScannerForTokenization. self scan: (ReadStream on: textOrString asString). atNumber := hereChar notNil and: [hereChar isDigit]. theTokensType := tokenType. theToken := self advance. (theToken == #- and: [atNumber and: [token isNumber]]) ifTrue: [theToken := self advance negated]. theToken isNumber ifTrue: [theTokensType := #number]. ^aBinaryBlock value: theToken value: ((#(number string literal) includes: theTokensType) ifTrue: [#literal] ifFalse: [#word])! ! !Decompiler methodsFor: 'control' stamp: 'eem 4/8/2015 11:24' prior: 18013845! blockTo: end "Decompile a range of code as in statementsTo:, but return a block node." | exprs block oldBase lastStatementOfBlockIsNil | oldBase := blockStackBase. blockStackBase := stack size. exprs := self statementsTo: end. lastStatementOfBlockIsNil := pc < method endPC and: [exprs notEmpty and: [exprs last == (constTable at: 4)]]. lastStatementOfBlockIsNil ifTrue: [exprs := exprs allButLast]. block := constructor codeBlock: exprs returns: lastReturnPc = lastPc. blockStackBase := oldBase. lastReturnPc := -1. "So as not to mislead outer calls" ^block! ! !BytecodeEncoder class methodsFor: 'instruction stream support' stamp: 'eem 10/10/2014 09:32' prior: 33499216! extensionsFor: pc in: aCompiledMethod into: trinaryBlock "If the bytecode at pc is an extension, or if the bytecode at pc is preceeded by extensions, then evaluate aTrinaryBlock with the values of extA and extB and number of extension *bytes*. If the bytecode at pc is neither an extension or extended then evaluate with 0, 0, 0." | prevPC | "If there is what appears to be an extension bytecode before this bytecode then scan for the previous pc to confirm." (pc - 2 >= aCompiledMethod initialPC and: [self isExtension: (aCompiledMethod at: pc - 2)]) ifTrue: [prevPC := aCompiledMethod pcPreviousTo: pc. (self nonExtensionPcAt: prevPC in: aCompiledMethod) = pc ifTrue: [^self extensionsAt: prevPC in: aCompiledMethod into: trinaryBlock]]. ^self extensionsAt: pc in: aCompiledMethod into: trinaryBlock! ! !BytecodeEncoder class methodsFor: 'instruction stream support' stamp: 'eem 10/10/2014 09:24'! nonExtensionPcAt: pc in: method "Answer the pc of the actual bytecode at pc in method, skipping past any preceeding extensions." | thePC bytecode | thePC := pc. [self isExtension: (bytecode := method at: thePC)] whileTrue: [thePC := thePC + (self bytecodeSize: bytecode)]. ^thePC! ! BytecodeEncoder removeSelector: #generateMethodOfClass:trailer:from:! EncoderForV3 removeSelector: #generateMethodOfClass:trailer:from:! EncoderForV3PlusClosures removeSelector: #generateMethodOfClass:trailer:from:! "Compiler"! !Deprecation class methodsFor: 'utilities' stamp: 'eem 8/28/2015 12:09'! maybeSignalDeprecationFor: context message: messageString explanation: explanationString ShowDeprecationWarnings == true ifTrue: [self signal: context method reference, ' has been deprecated', messageString, '. ', explanationString]! ! !MethodContext methodsFor: 'instruction decoding' stamp: 'eem 9/16/2015 09:08'! callPrimitive: primNumber "Evaluate the primitive, either normal or inlined, and answer the new context resulting from that (either the sender if a successful non-inlined primitive, or the current context, if not)." | maybePrimFailToken | primNumber >= (1 << 15) ifTrue: "Inlined primitive, cannot fail" [^self callInlinedPrimitive: primNumber]. maybePrimFailToken := self doPrimitive: primNumber method: method receiver: receiver args: self arguments. "Normal primitive. Always at the beginning of methods." (self isPrimFailToken: maybePrimFailToken) ifFalse: "On success return the result" [^self methodReturnTop]. "On failure, store the error code if appropriate and keep interpreting the method" (method encoderClass isStoreAt: pc in: method) ifTrue: [self at: stackp put: maybePrimFailToken last]. ^self! ! !ClassDescription methodsFor: 'accessing comment' stamp: 'eem 4/21/2015 09:06' prior: 25243686! classCommentBlank ^String streamContents: [:stream| stream nextPutAll: 'A'; nextPutAll: (self name first isVowel ifTrue: ['n '] ifFalse: [' ']); nextPutAll: self name; nextPutAll: ' is xxxxxxxxx.'; cr; cr; nextPutAll: 'Instance Variables'. self instVarNames asSortedCollection do: [:each | stream crtab; nextPutAll: each; nextPut: $:; tab: 2; nextPutAll: '']. stream cr. self instVarNames asSortedCollection do: [:each | stream cr; nextPutAll: each; crtab; nextPutAll: '- xxxxx'; cr]]! ! !Object methodsFor: 'error handling' stamp: 'eem 8/28/2015 12:04' prior: 66626489! backwardCompatibilityOnly: explanationString "Warn that the sending method has been deprecated. Methods that are tagt with #backwardCompatibility: are kept for compatibility." Deprecation maybeSignalDeprecationFor: thisContext sender message: ' (but will be kept for compatibility)' explanation: explanationString! ! !Object methodsFor: 'error handling' stamp: 'eem 8/28/2015 12:04' prior: 66627338! deprecated: explanationString "Warn that the sending method has been deprecated." Deprecation maybeSignalDeprecationFor: thisContext sender message: '' explanation: explanationString! ! !Object methodsFor: 'error handling' stamp: 'eem 8/28/2015 12:04' prior: 66627642! deprecated: explanationString block: aBlock "Warn that the sender has been deprecated. Answer the value of aBlock on resumption. (Note that #deprecated: is usually the preferred method.)" Deprecation maybeSignalDeprecationFor: thisContext sender message: '' explanation: explanationString. ^ aBlock value. ! ! !InstructionStream methodsFor: 'decoding' stamp: 'eem 8/11/2014 13:22' prior: 55736948! skipCallPrimitive "If the receiver's method starts with a callPrimitive: bytecode, skip it." | method encoderClass callPrimitiveCode | method := self method. encoderClass := method encoderClass. callPrimitiveCode := encoderClass callPrimitiveCode. (method byteAt: pc) = callPrimitiveCode ifTrue: [pc := pc + (encoderClass bytecodeSize: callPrimitiveCode)]! ! !ProtoObject methodsFor: 'comparing' stamp: 'eem 8/27/2015 17:35' prior: 23926463! ~~ anObject "Answer whether the receiver and the argument are not the same object (do not have the same object pointer). Primitive. Optional." self == anObject ifTrue: [^false]. ^true! ! "Kernel"! Object subclass: #MCMcmUpdater instanceVariableNames: 'updateMapName lastUpdateMap' classVariableNames: 'DefaultUpdateURL SkipPackages UpdateFromServerAtStartup UpdateMissingPackages Updaters' poolDictionaries: '' category: 'MonticelloConfigurations'! !MCMcmUpdater commentStamp: 'dtl 8/28/2015 22:07' prior: 60580960! MCMcmUpdater provides utility methods for updating Monticello packages from Monticello configurations. When Monticello configurations are stored in a repository (or repositories), MCMcmUpdater acts as an update stream. It first ensures that each configuration map has been loaded in sequence, then updates the last configuration map to the most recent version for each specified package, and finally loads these versions to produce a fully updated configuration. Currently if a set of packages are unloaded from the image, using this class to reload them may cause problems, depending on what dependencies those classes have. Success is not assured. Removing packages via SmalltalkImage>>unloadAllKnownPackages will be successful, it flags the packages removed so that they are not loaded by this utility. If you wish to not have MCMcmUpdater update packages, there are two ways to handle this: 1) To have MCMcmUpdater not update any packages not currently in the image set the UpdateMissingPackages preference to false: MCMcmUpdater updateMissingPackages: false Note that any new packages added to the repositories will not be picked up when this is turned off. 2) To have MCMcmUpdater not update a specific package, evaluate MCMcmUpdater disableUpdatesOfPackage: Class Variables definitions: DefaultUpdateURL - String: the URL that will be checked by default for updates. This would be set for a common standard location to check. Updaters - A dictionary of MCMcmUpdater instances keyed by repository URL. SkipPackages - Set of Strings: names of packages to not update in MCMcmUpdater (empty by default). UpdateMissingPackages - Boolean: if true (default), new packages in the update config map will be loaded unless they are in SkipPackages. If false, packages not currently loaded in the image will not be loaded by MCMcmUpdater. (This can be dangerous if packages are split - use at your own risk). Instance Variables: updateMapName - Base name of the files used for this updater, typically a name such as 'update' or 'update.spur'. lastUpdateMap - Dictionary of Integer: version number of the last loaded update map per repository. Keeps track of the last configuration map, so that the utility will not have to run through the full history in the repositories each time you ask to update. ! !MCMcmUpdater class methodsFor: 'instance creation' stamp: 'dtl 8/28/2015 20:20' prior: 60618653! default "The default instance for system updates. Uses a default update map name that may be set as a preference to enable a specific update stream for a repository." ^ self updaters at: self defaultUpdateURL ifAbsentPut: [self updateMapNamed: self updateMapName]! ! !MCMcmUpdater class methodsFor: 'class initialization' stamp: 'topa 9/24/2015 14:47' prior: 60612351! initialize "MCMcmUpdater initialize" DefaultUpdateURL ifNil:[ DefaultUpdateURL := MCHttpRepository trunkUrlString. ]. "Call MCMcmUpdater resetUpdaters manually if necessary"! ! !MCMcmUpdater class methodsFor: 'class initialization' stamp: 'topa 9/24/2015 14:46'! resetUpdaters Updaters := nil.! ! !MCMcmUpdater class methodsFor: 'updating' stamp: 'dtl 8/27/2015 20:37' prior: 60608292! updateFromRepositories: repositoryUrls using: updaterUrlKey baseName: baseName "Update all repositoryUrls using an MCMcmUpdater identified by updaterUrlKey, and using update map baseName" ^ (self updateMapNamed: baseName repository: updaterUrlKey) updateFromRepositories: repositoryUrls! ! !MCMcmUpdater class methodsFor: 'updating' stamp: 'dtl 8/27/2015 20:37' prior: 60610060! updateFromRepository: updaterUrlKey baseName: baseName "Update using an MCMcmUpdater identified by updaterUrlKey, and using update map baseName" ^ (self updateMapNamed: baseName repository: updaterUrlKey) updateFrom: updaterUrlKey! ! !MCMcmUpdater class methodsFor: 'preferences' stamp: 'dtl 8/28/2015 22:04' prior: 60616824! updateMapName "The default update map name" ^ 'update'! ! !MCMcmUpdater class methodsFor: 'preferences' stamp: 'dtl 8/28/2015 22:05' prior: 60619206! updateMapName: mapName "The default update map name for the default updater. If this is changed, then the default updater must be replaced because its remembered position in the update map sequence will not be valid for the new update map." self default updateMapName = mapName ifFalse: [(self confirm: 'Initializing updater for ' , DefaultUpdateURL , ' to use new update stream ' , mapName) ifTrue: [self updaters at: self defaultUpdateURL put: (self updateMapNamed: mapName)]]! ! !MCMcmUpdater class methodsFor: 'instance creation' stamp: 'dtl 8/28/2015 21:15'! updateMapNamed: baseName "Answer a new instance with a base update name baseName such as 'update' or 'update.oscog' " ^ self new updateMapName: baseName; lastUpdateMap: Dictionary new! ! !MCMcmUpdater class methodsFor: 'instance creation' stamp: 'dtl 8/27/2015 20:38'! updateMapNamed: baseName repository: url "Answer an instance for the given repository URL with a base update name baseName. The instance will be updated in the Updaters dictionary if baseName has changed." | updater | updater := self updaters at: url ifAbsentPut: [ self updateMapNamed: baseName ]. updater updateMapName = baseName ifFalse: [ ^ self updaters at: url put: (self updateMapNamed: baseName )]. ^ updater ! ! MCMcmUpdater class removeSelector: #updateMapName:repository:! "MonticelloConfigurations"! !SmartRefStream methodsFor: 'import image segment' stamp: 'tk 11/26/2004 05:53' prior: 66313290! applyConversionMethodsTo: objectIn className: className varMap: varMap "Modify the object's instance vars to have the proper values for its new shape. Mostly, fill in defaut values of new inst vars. Can substitute an object of a different class. (Beware: if substituted, varMap will not be correct when the new object is asked to convert.)" | anObject prevObject | self flag: #bobconv. anObject := objectIn. [ prevObject := anObject. anObject := anObject convertToCurrentVersion: varMap refStream: self. prevObject == anObject ] whileFalse. ^anObject! ! !Preferences class methodsFor: 'get/set' stamp: 'mt 8/28/2015 10:00'! setPreference: prefSymbol toValue: anObject during: aBlock (self valueOfPreference: prefSymbol) in: [:previous | self setPreference: prefSymbol toValue: anObject. aBlock ensure: [self setPreference: prefSymbol toValue: previous]].! ! !DataStream methodsFor: 'write and read' stamp: 'tk 6/9/1997 08:18 ' prior: 57391318! objectAt: anInteger "PRIVATE -- Read & return the object at a given stream position. anInteger is a relative file position. " | savedPosn anObject refPosn | savedPosn := byteStream position. "absolute" refPosn := self getCurrentReference. "relative position" byteStream position: anInteger + basePos. "was relative" anObject := self next. self setCurrentReference: refPosn. "relative position" byteStream position: savedPosn. "absolute" ^ anObject! ! !FilePackage methodsFor: 'accessing' stamp: 'pnm 8/23/2000 17:10' prior: 59012063! fullName: aString fullName := aString! ! !FilePackage methodsFor: 'initialize' stamp: 'pnm 8/23/2000 14:48' prior: 59023196! initialize classes := Dictionary new. classOrder := OrderedCollection new. sourceSystem := ''. doIts := OrderedCollection new.! ! !FilePackage methodsFor: 'accessing' stamp: 'pnm 8/23/2000 17:12' prior: 59013277! packageName ^FileDirectory localNameFor: self fullPackageName! ! "System"! !PluggableDictionary class methodsFor: 'instance creation' stamp: 'dvf 6/10/2000 18:13' prior: 51977254! integerDictionary ^ self new hashBlock: [:integer | integer hash \\ 1064164 * 1009]! ! !PluggableSet class methodsFor: 'instance creation' stamp: 'dvf 6/10/2000 18:13' prior: 26604909! integerSet ^self new hashBlock: [:integer | integer hash \\ 1064164 * 1009]! ! !ByteArray methodsFor: 'platform independent access' stamp: 'ul 9/9/2015 20:28' prior: 56718871! longAt: index bigEndian: bigEndian "Return a 32-bit integer quantity starting from the given byte index. Use #normalize where necessary to ensure compatibility with non-30-bit SmallIntegers." | byte result | bigEndian ifFalse: [ (byte := self at: index + 3) <= 16r7F ifTrue: [ "Is the result non-negative?" byte <= 16r3F ifTrue: [ ^(((byte bitShift: 8) + (self at: index + 2) bitShift: 8) + (self at: index + 1) bitShift: 8) + (self at: index) ]. ^(LargePositiveInteger new: 4) replaceFrom: 1 to: 4 with: self startingAt: index; normalize ]. "Negative" byte >= 16rC0 ifTrue: [ ^-1 - (((((byte bitShift: 8) + (self at: index + 2) bitShift: 8) + (self at: index + 1) bitXor: 16rFFFFFF) bitShift: 8) + ((self at: index) bitXor: 16rFF)) ]. (result := LargeNegativeInteger new: 4) digitAt: 4 put: ((self at: index + 3) bitXor: 16rFF); digitAt: 3 put: ((self at: index + 2) bitXor: 16rFF); digitAt: 2 put: ((self at: index + 1) bitXor: 16rFF). (byte := ((self at: index) bitXor: 16rFF) + 1) <= 16rFF ifTrue: [ ^result digitAt: 1 put: byte; normalize ]. ^result digitAt: 1 put: 16rFF; - 1 "It's tempting to do the subtraction in a loop to avoid the LargeInteger creation, but it's actually slower than this." ]. (byte := self at: index) <= 16r7F ifTrue: [ "Is the result non-negative?" byte <= 16r3F ifTrue: [ ^(((byte bitShift: 8) + (self at: index + 1) bitShift: 8) + (self at: index + 2) bitShift: 8) + (self at: index + 3) ]. ^(LargePositiveInteger new: 4) digitAt: 1 put: (self at: index + 3); digitAt: 2 put: (self at: index + 2); digitAt: 3 put: (self at: index + 1); digitAt: 4 put: byte; normalize ]. "Negative" 16rC0 <= byte ifTrue: [ ^-1 - (((((byte bitShift: 8) + (self at: index + 1) bitShift: 8) + (self at: index + 2) bitXor: 16rFFFFFF) bitShift: 8) + ((self at: index + 3) bitXor: 16rFF)) ]. (result := LargeNegativeInteger new: 4) digitAt: 4 put: (byte bitXor: 16rFF); digitAt: 3 put: ((self at: index + 1) bitXor: 16rFF); digitAt: 2 put: ((self at: index + 2) bitXor: 16rFF). (byte := ((self at: index + 3) bitXor: 16rFF) + 1) <= 16rFF ifTrue: [ ^result digitAt: 1 put: byte; normalize ]. ^result digitAt: 1 put: 16rFF; - 1 "It's tempting to do the subtraction in a loop to avoid the LargeInteger creation, but it's actually slower than this."! ! !ByteArray methodsFor: 'platform independent access' stamp: 'ul 9/6/2015 17:13' prior: 56719505! longAt: index put: value bigEndian: bigEndian "Store a 32-bit signed integer quantity starting from the given byte index" | v v2 | value isLarge ifTrue: [ bigEndian ifFalse: [ value positive ifTrue: [ self replaceFrom: index to: index + 3 with: value startingAt: 1. ^value ]. v := 0. [ v <= 3 and: [ (v2 := ((value digitAt: v + 1) bitXor: 16rFF) + 1) = 16r100 ] ] whileTrue: [ self at: index + v put: 0. v := v + 1 ]. self at: index + v put: v2. v := v + 1. [ v <= 3 ] whileTrue: [ self at: index + v put: ((value digitAt: (v := v + 1)) bitXor: 16rFF) ]. ^value ]. value positive ifTrue: [ self at: index put: (value digitAt: 4); at: index + 1 put: (value digitAt: 3); at: index + 2 put: (value digitAt: 2); at: index + 3 put: (value digitAt: 1). ^value ]. v := 3. [ 0 <= v and: [ (v2 := ((value digitAt: 4 - v) bitXor: 16rFF) + 1) = 16r100 ] ] whileTrue: [ self at: index + v put: 0. v := v - 1 ]. self at: index + v put: v2. [ 0 <= (v := v - 1) ] whileTrue: [ self at: index + v put: ((value digitAt: 4 - v) bitXor: 16rFF) ]. ^value ]. v := value bitShift: -24. 0 <= (v := (v bitAnd: 16r7F) - (v bitAnd: 16r80)) ifFalse: [ v := v + 16r100 ]. bigEndian ifFalse: [ self at: index put: (value bitAnd: 16rFF); at: index + 1 put: ((value bitShift: -8) bitAnd: 16rFF); at: index + 2 put: ((value bitShift: -16) bitAnd: 16rFF); at: index + 3 put: v. ^value ]. self at: index put: v; at: index + 1 put: ((value bitShift: -16) bitAnd: 16rFF); at: index + 2 put: ((value bitShift: -8) bitAnd: 16rFF); at: index + 3 put: (value bitAnd: 16rFF). ^value! ! !ByteArray methodsFor: 'platform independent access' stamp: 'ul 9/6/2015 23:16' prior: 56720199! shortAt: index bigEndian: bigEndian "Return a 16-bit signed integer quantity starting from the given byte index" | result | result := bigEndian ifFalse: [ ((self at: index + 1) bitShift: 8) + (self at: index) ] ifTrue: [ ((self at: index) bitShift: 8) + (self at: index + 1) ]. result < 16r8000 ifTrue: [ ^result ]. ^result - 16r10000! ! !ByteArray methodsFor: 'platform independent access' stamp: 'ul 9/6/2015 23:16' prior: 56720511! shortAt: index put: value bigEndian: bigEndian "Store a 16-bit signed integer quantity starting from the given byte index" | unsignedValue | (unsignedValue := value) < 0 ifTrue: [ unsignedValue := unsignedValue + 16r10000 ]. bigEndian ifFalse: [ self at: index + 1 put: (unsignedValue bitShift: -8); at: index put: (unsignedValue bitAnd: 16rFF). ^value ]. self at: index put: (unsignedValue bitShift: -8); at: index + 1 put: (unsignedValue bitAnd: 16rFF). ^value! ! !ByteArray methodsFor: 'platform independent access' stamp: 'ul 9/9/2015 20:23'! unsignedLong64At: index bigEndian: bigEndian "Return a 64-bit unsigned integer quantity starting from the given byte index. Use #normalize where necessary to ensure compatibility with non-30-bit SmallIntegers." | v | bigEndian ifFalse: [ (v := self at: index + 7) = 0 ifFalse: [ ^(LargePositiveInteger new: 8) replaceFrom: 1 to: 8 with: self startingAt: index; normalize ]. (v := self at: index + 6) = 0 ifFalse: [ ^(LargePositiveInteger new: 7) replaceFrom: 1 to: 7 with: self startingAt: index; normalize ]. (v := self at: index + 5) = 0 ifFalse: [ ^(LargePositiveInteger new: 6) replaceFrom: 1 to: 6 with: self startingAt: index; normalize ]. (v := self at: index + 4) = 0 ifFalse: [ ^(LargePositiveInteger new: 5) replaceFrom: 1 to: 5 with: self startingAt: index; normalize ]. (v := self at: index + 3) <= 16r3F ifFalse: [ ^(LargePositiveInteger new: 4) replaceFrom: 1 to: 4 with: self startingAt: index; normalize ]. ^(((v bitShift: 8) + (self at: index + 2) bitShift: 8) + (self at: index + 1) bitShift: 8) + (self at: index) ]. (v := self at: index) = 0 ifFalse: [ ^(LargePositiveInteger new: 8) digitAt: 1 put: (self at: index + 7); digitAt: 2 put: (self at: index + 6); digitAt: 3 put: (self at: index + 5); digitAt: 4 put: (self at: index + 4); digitAt: 5 put: (self at: index + 3); digitAt: 6 put: (self at: index + 2); digitAt: 7 put: (self at: index + 1); digitAt: 8 put: v; normalize ]. (v := self at: index + 1) = 0 ifFalse: [ ^(LargePositiveInteger new: 7) digitAt: 1 put: (self at: index + 7); digitAt: 2 put: (self at: index + 6); digitAt: 3 put: (self at: index + 5); digitAt: 4 put: (self at: index + 4); digitAt: 5 put: (self at: index + 3); digitAt: 6 put: (self at: index + 2); digitAt: 7 put: v; normalize ]. (v := self at: index + 2) = 0 ifFalse: [ ^(LargePositiveInteger new: 6) digitAt: 1 put: (self at: index + 7); digitAt: 2 put: (self at: index + 6); digitAt: 3 put: (self at: index + 5); digitAt: 4 put: (self at: index + 4); digitAt: 5 put: (self at: index + 3); digitAt: 6 put: v; normalize ]. (v := self at: index + 3) = 0 ifFalse: [ ^(LargePositiveInteger new: 5) digitAt: 1 put: (self at: index + 7); digitAt: 2 put: (self at: index + 6); digitAt: 3 put: (self at: index + 5); digitAt: 4 put: (self at: index + 4); digitAt: 5 put: v; normalize ]. (v := self at: index + 4) <= 16r3F ifFalse: [ ^(LargePositiveInteger new: 4) digitAt: 1 put: (self at: index + 7); digitAt: 2 put: (self at: index + 6); digitAt: 3 put: (self at: index + 5); digitAt: 4 put: v; normalize ]. ^(((v bitShift: 8) + (self at: index + 5) bitShift: 8) + (self at: index + 6) bitShift: 8) + (self at: index + 7)! ! !ByteArray methodsFor: 'platform independent access' stamp: 'ul 9/9/2015 20:18'! unsignedLong64At: index put: value bigEndian: bigEndian "Store a 64-bit unsigned integer quantity starting from the given byte index" | i j | value isLarge ifTrue: [ i := value digitLength. bigEndian ifFalse: [ self replaceFrom: index to: index + i - 1 with: value startingAt: 1; replaceFrom: index + i to: index + 7 with: #[0 0 0 0 0 0 0 0] startingAt: 1. ^value ]. j := index + 8. i <= 7 ifTrue: [ self replaceFrom: index to: j - i - 1 with: #[0 0 0 0 0 0 0 0] startingAt: 1 ]. [ 1 <= i ] whileTrue: [ self at: j - i put: (value digitAt: i). i := i - 1 ]. ^value ]. bigEndian ifFalse: [ j := index - 1. i := value. [ 1 <= i ] whileTrue: [ self at: (j := j + 1) put: (i bitAnd: 16rFF). i := i bitShift: -8 ]. self replaceFrom: j + 1 to: index + 7 with: #[0 0 0 0 0 0 0 0] startingAt: 1. ^value ]. j := index + 8. i := value. [ 1 <= i ] whileTrue: [ self at: (j := j - 1) put: (i bitAnd: 16rFF). i := i bitShift: -8 ]. self replaceFrom: index to: j - 1 with: #[0 0 0 0 0 0 0 0] startingAt: 1. ^value! ! !ByteArray methodsFor: 'platform independent access' stamp: 'ul 9/6/2015 23:05' prior: 56720821! unsignedLongAt: index bigEndian: bigEndian "Return a 32-bit unsigned integer quantity starting from the given byte index. Use #normalize where necessary to ensure compatibility with non-30-bit SmallIntegers." | byte | bigEndian ifTrue: [ (byte := self at: index) <= 16r3F ifTrue: [ ^(((byte bitShift: 8) + (self at: index + 1) bitShift: 8) + (self at: index + 2) bitShift: 8) + (self at: index + 3) ]. ^(LargePositiveInteger new: 4) digitAt: 1 put: (self at: index + 3); digitAt: 2 put: (self at: index + 2); digitAt: 3 put: (self at: index + 1); digitAt: 4 put: byte; normalize ]. (byte := self at: index + 3) <= 16r3F ifTrue: [ ^(((byte bitShift: 8) + (self at: index + 2) bitShift: 8) + (self at: index + 1) bitShift: 8) + (self at: index) ]. ^(LargePositiveInteger new: 4) replaceFrom: 1 to: 4 with: self startingAt: index; normalize ! ! !ByteArray methodsFor: 'platform independent access' stamp: 'ul 9/3/2015 01:33' prior: 56721453! unsignedLongAt: index put: value bigEndian: bigEndian "Store a 32-bit unsigned integer quantity starting from the given byte index" value isLarge ifTrue: [ bigEndian ifFalse: [ self replaceFrom: index to: index + 3 with: value startingAt: 1. ^value ]. self at: index put: (value digitAt: 4); at: index + 1 put: (value digitAt: 3); at: index + 2 put: (value digitAt: 2); at: index +3 put: (value digitAt: 1) ] ifFalse: [ bigEndian ifFalse: [ self at: index put: (value bitAnd: 16rFF); at: index + 1 put: ((value bitShift: -8) bitAnd: 16rFF); at: index + 2 put: ((value bitShift: -16) bitAnd: 16rFF); at: index + 3 put: (value bitShift: -24). ^value ]. self at: index put: (value bitShift: -24); at: index + 1 put: ((value bitShift: -16) bitAnd: 16rFF); at: index + 2 put: ((value bitShift: -8) bitAnd: 16rFF); at: index + 3 put: (value bitAnd: 16rFF) ]. ^value! ! !ByteArray methodsFor: 'platform independent access' stamp: 'ul 9/3/2015 01:33' prior: 56722082! unsignedShortAt: index bigEndian: bigEndian "Return a 16-bit unsigned integer quantity starting from the given byte index" bigEndian ifFalse: [ ^((self at: index + 1) bitShift: 8) + (self at: index) ]. ^((self at: index) bitShift: 8) + (self at: index + 1) ! ! !ByteArray methodsFor: 'platform independent access' stamp: 'ul 9/3/2015 15:29' prior: 56722425! unsignedShortAt: index put: value bigEndian: bigEndian "Store a 16-bit unsigned integer quantity starting from the given byte index" bigEndian ifFalse: [ self at: index + 1 put: (value bitShift: -8); at: index put: (value bitAnd: 16rFF). ^value ]. self at: index put: (value bitShift: -8); at: index+1 put: (value bitAnd: 16rFF). ^value! ! WeakArray class removeSelector: #pvtCreateTemporaryObjectIn:! "Collections"! !ChangeSorter methodsFor: '*Monticello-changeSet menu' stamp: 'eem 8/27/2015 16:59'! deleteMonticelloChangeSets "Destroy all change sets from Monticello loads, provided the currently selected change set is not one of those, and the user really wants to do this." myChangeSet isForPackageLoad ifTrue: "forms current changes for current project" [^self inform: 'current change set is a Monticello load change set.\Please select some other change set before deleting Monticello load change sets.' withCRs]. (self confirm: 'Are you sure you want to delete all change sets due to Monticello package loads?') ifFalse: [^self]. (ChangesOrganizer allChangeSets select: [:cs| cs isForPackageLoad]) do: [:cs| ChangesOrganizer removeChangeSet: cs]. self changed: #changeSetList. self showChangeSet: ChangeSet current! ! !ChangeSorter methodsFor: '*Monticello-changeSet menu' stamp: 'eem 8/27/2015 16:51'! monticelloChangeSetMenu: aMenu "Sigh, when implementing menu pragmas this is not what I had in mind..." aMenu add: 'delete Monticello load change sets' action: #deleteMonticelloChangeSets. (aMenu submorphs detect: [:m| m isMenuItemMorph and: [m contents beginsWith: 'destroy change set']] ifNone: []) ifNotNil: [:destroyItem| | item | aMenu removeMorph: (item := aMenu submorphs last). aMenu addMorph: item after: destroyItem]. ^aMenu! ! !ChangeSet methodsFor: '*Monticello-testing' stamp: 'eem 8/27/2015 16:17'! isForPackageLoad | packageName | ^(name includes: $-) and: [name last isDigit and: [packageName := name first: ((name indexOf: $. ifAbsent: [name size]) min: (name lastIndexOf: $-)) - 1. MCWorkingCopy allManagers anySatisfy: [:wc| wc packageName = packageName]]]! ! "Monticello"! !Player methodsFor: 'slot getters/setters' stamp: 'cmm 9/9/2015 17:41' prior: 62405677! getAllowEtoyUserCustomEvents "Answer whether to use the vector vocabulary." ^ Preferences valueOfFlag: #allowEtoyUserCustomEvents! ! !Morph class methodsFor: '*eToys-customevents-user events' stamp: 'cmm 9/9/2015 14:24' prior: 32587717! additionsToViewerCategoryUserEvents "Answer further viewer additions relating to user-defined events; these appear in the 'scripting' category" ^ (Preferences valueOfFlag: #allowEtoyUserCustomEvents) ifTrue: [ #(scripting ( (command triggerCustomEvent: 'trigger a user-defined (global) event' CustomEvents) (slot triggeringObject 'the object that is triggering an event, either user-defined or pre-defined' Player readOnly Player getTriggeringObject unused unused)))] ifFalse: [#(scripting ())]! ! !Morph methodsFor: '*Etoys-support' stamp: 'cmm 9/9/2015 14:25' prior: 32507835! enforceTileColorPolicy (Preferences valueOfFlag: #coloredTilesEnabled) ifTrue: [self makeAllTilesColored] ifFalse: [self makeAllTilesGreen]! ! !ScriptEditorMorph methodsFor: 'objects from disk' stamp: 'tk 11/29/2004 17:27' prior: 16873451! fixUponLoad: aProject seg: anImageSegment "We are in an old project that is being loaded from disk. Fix up conventions that have changed." (aProject projectParameters at: #substitutedFont ifAbsent: [#none]) ~~ #none ifTrue: [ self setProperty: #needsLayoutFixed toValue: true ]. ^ super fixUponLoad: aProject seg: anImageSegment! ! !ScriptInstantiation methodsFor: 'customevents-status control' stamp: 'cmm 9/9/2015 17:41' prior: 24209639! presentScriptStatusPopUp "Put up a menu of status alternatives and carry out the request" | reply m menu submenu | menu := MenuMorph new. self addStatusChoices: #( normal " -- run when called" ) toMenu: menu. self addStatusChoices: #( paused "ready to run all the time" ticking "run all the time" ) toMenu: menu. self addStatusChoices: (ScriptingSystem standardEventStati copyFrom: 1 to: 3) toMenu: menu. self addStatusChoices: (ScriptingSystem standardEventStati allButFirst: 3) toMenu: menu. self addStatusChoices: #(opening "when I am being opened" closing "when I am being closed" ) toMenu: menu. submenu := MenuMorph new. self addStatusChoices: (ScriptingSystem globalCustomEventNamesFor: player) toSubMenu: submenu forMenu: menu. menu add: 'more... ' translated subMenu: submenu. (Preferences valueOfFlag: #allowEtoyUserCustomEvents) ifTrue: [ submenu addLine. self addStatusChoices: ScriptingSystem userCustomEventNames toSubMenu: submenu forMenu: menu. submenu addLine. self addStatusChoices: (Array streamContents: [ :s | s nextPut: { 'define a new custom event'. #defineNewEvent }. ScriptingSystem userCustomEventNames isEmpty ifFalse: [ s nextPut: { 'delete a custom event'. #deleteCustomEvent } ]]) toSubMenu: submenu forMenu: menu ]. menu addLine. self addStatusChoices: #( ('what do these mean?'explainStatusAlternatives) ('apply my status to all siblings' assignStatusToAllSiblings) ) toMenu: menu. menu addTitle: 'When should this script run?' translated. menu submorphs last delete. menu invokeModal. reply := menu modalSelection. reply == #explainStatusAlternatives ifTrue: [^ self explainStatusAlternatives]. reply == #assignStatusToAllSiblings ifTrue: [^ self assignStatusToAllSiblings]. reply == #defineNewEvent ifTrue: [ ^self defineNewEvent ]. reply == #deleteCustomEvent ifTrue: [ ^self deleteCustomEvent ]. reply ifNotNil: [self status: reply. "Gets event handlers fixed up" reply == #paused ifTrue: [m := player costume. (m isKindOf: SpeakerMorph) ifTrue: [m stopSound]]. self updateAllStatusMorphs] ! ! !StandardScriptingSystem methodsFor: '*Etoys-customevents-help dictionary' stamp: 'cmm 9/9/2015 17:41' prior: 23889077! statusHelpStringFor: aPlayer ^String streamContents: [ :stream | stream nextPutAll: 'normal -- run when called paused -- ready to run all the time ticking -- run all the time mouseDown -- run when mouse goes down on me mouseStillDown -- while mouse still down mouseUp -- when mouse comes back up mouseEnter -- when mouse enters my bounds, button up mouseLeave -- when mouse exits my bounds, button up mouseEnterDragging -- when mouse enters my bounds, button down mouseLeaveDragging -- when mouse exits my bounds, button down opening -- when I am being opened closing -- when I am being closed' translated. "'keyStroke -- run when user hits a key' " stream cr; cr; nextPutAll: 'More events:' translated; cr. (self customEventNamesAndHelpStringsFor: aPlayer) do: [ :array | stream cr; nextPutAll: array first; nextPutAll: ' -- '. array second do: [ :help | stream nextPutAll: help translated ] separatedBy: [ stream nextPutAll: ' or ' translated ]]. (Preferences valueOfFlag: #allowEtoyUserCustomEvents) ifTrue: [ self userCustomEventNames isEmpty ifFalse: [ stream cr; cr; nextPutAll: 'User custom events:' translated; cr. self currentWorld userCustomEventsRegistry keysAndValuesDo: [ :key :value | stream cr; nextPutAll: key; nextPutAll: ' -- '; nextPutAll: value ]]]]! ! !HandMorph methodsFor: 'grabbing/dropping' stamp: 'mt 9/10/2015 14:33' prior: 19298493! dropMorph: aMorph event: anEvent "Drop the given morph which was carried by the hand" | event dropped | (anEvent isMouseUp and:[aMorph shouldDropOnMouseUp not]) ifTrue:[^self]. "Note: For robustness in drag and drop handling we remove the morph BEFORE we drop him, but we keep his owner set to the hand. This prevents system lockups when there is a problem in drop handling (for example if there's an error in #wantsToBeDroppedInto:). THIS TECHNIQUE IS NOT RECOMMENDED FOR CASUAL USE." self privateRemove: aMorph. aMorph privateOwner: self. dropped := aMorph. (dropped hasProperty: #addedFlexAtGrab) ifTrue:[dropped := aMorph removeFlexShell]. event := DropEvent new setPosition: self position contents: dropped hand: self. [ "In case of an error, ensure that the morph-to-be-dropped will be disposed. Otherwise it may confuse garbage handler. See the sends of #privateRemove: and #privateOwner: above." self sendEvent: event focus: nil. event wasHandled ifFalse: [aMorph rejectDropMorphEvent: event] ] ensure: [ aMorph owner == self ifTrue: [aMorph delete] ]. self mouseOverHandler processMouseOver: anEvent.! ! !FormCanvas methodsFor: 'drawing-rectangles' stamp: 'mt 9/4/2015 08:35' prior: 52009420! frameRoundRect: aRectangle radius: radius width: borderWidth color: borderColor "Frame a rounded rectangle with the given attributes." | innerRect | (borderWidth isZero or:[borderColor isTransparent]) ifTrue:[^self]. radius asPoint <= (0@0) ifTrue:[^self frameRectangle: aRectangle width: borderWidth color: borderColor]. "decompose inner rectangle into bezier shape" innerRect := aRectangle insetBy: borderWidth. innerRect area <= 0 ifTrue:[^self fillRoundRect: aRectangle radius: radius fillStyle: borderColor]. self setFillColor: borderColor. port frameRoundRect: (aRectangle translateBy: origin) truncated radius: radius truncated borderWidth: borderWidth truncated. ! ! !MorphicModel methodsFor: 'initialization' stamp: 'jm 8/20/1998 09:08' prior: 29953326! model: anObject "Set my model and make me me a dependent of the given object." model ifNotNil: [model removeDependent: self]. anObject ifNotNil: [anObject addDependent: self]. model := anObject. ! ! !BalloonCanvas methodsFor: 'drawing-rectangles' stamp: 'mt 9/4/2015 08:36' prior: 61986152! frameRoundRect: aRectangle radius: radius width: borderWidth color: borderColor | outerPoints innerRect innerRadius innerPoints | (borderWidth isZero or:[borderColor isTransparent]) ifTrue:[^self]. radius asPoint <= (0@0) ifTrue:[^self frameRectangle: aRectangle width: borderWidth color: borderColor]. "decompose inner rectangle into bezier shape" innerRect := aRectangle insetBy: borderWidth. innerRect area <= 0 ifTrue:[^self fillRoundRect: aRectangle radius: radius fillStyle: borderColor]. innerRadius := (radius - borderWidth) asPoint. innerPoints := self makeRoundRectShape: innerRect radius: innerRadius. "decompose outer rectangle into bezier shape" outerPoints := self makeRoundRectShape: aRectangle radius: radius. self drawGeneralBezierShape: (Array with: outerPoints with: innerPoints) color: borderColor borderWidth: 0 borderColor: nil.! ! "Morphic"! !SocketTest methodsFor: 'setup' stamp: 'topa 9/8/2015 00:02' prior: 28082875! listenerAddress ^NetNameResolver addressForName: 'localhost' ! ! !SocketTest methodsFor: 'tests' stamp: 'topa 9/7/2015 23:39' prior: 28085437! testPeerName "None of these should throw an exception." "This can actually take a while, depending on networks availability" Socket new peerName. self testServerAccept. listenerSocket peerName. clientSocket peerName. serverSocket peerName.! ! "NetworkTests"! !PBColorPreferenceView methodsFor: 'user interface' stamp: 'kfr 5/6/2015 20:42'! adjustLabelColor | textColor | (self preference preferenceValue luminance < 0.5) ifTrue:[ textColor := Color white] ifFalse:[ textColor := Color black]. button allMorphsDo: [:m | (m isKindOf: StringMorph) ifTrue: [ m color: textColor]]. ! ! !PBColorPreferenceView methodsFor: 'user interface' stamp: 'mt 8/28/2015 10:40'! borderStyleMenu "Add border-style menu items" | aMenu | aMenu := MenuMorph new defaultTarget: self. aMenu addStayUpItemSpecial. aMenu add: 'border color...' translated target: self selector:#changeColor: argument: button. aMenu addLine. BorderStyle borderStyleChoices do: [:sym | (aMenu borderStyleForSymbol: sym) ifNotNil: [aMenu add: sym translated target: self selector: #setBorderStyle: argument: sym]]. ^aMenu popUpInWorld ! ! !PBColorPreferenceView methodsFor: 'user interface' stamp: 'kfr 5/6/2015 20:43'! changeColor: aButton aButton changeColor. self preference preferenceValue: aButton fillStyle. button label: self preference preferenceValue asString. self adjustLabelColor ! ! !PBColorPreferenceView methodsFor: 'user interface' stamp: 'mt 8/28/2015 10:28'! colorMenuButton | selector name | name := self preference name. (name includesSubstring: 'border' caseSensitive: false) ifTrue: [ selector := #borderStyleMenu] ifFalse:[ selector := #fillStyleMenu]. button := SimpleButtonMorph new label: self preference preferenceValue asString; actionSelector: selector; target: self. name = #menuBorderColor ifTrue:[ ^button borderColor: MenuMorph menuBorderColor; borderWidth: MenuMorph menuBorderWidth]. name = #menuTitleBorderColor ifTrue:[ ^button borderColor: MenuMorph menuTitleBorderColor; borderWidth: MenuMorph menuTitleBorderWidth]. self adjustLabelColor. ^button color: self preference preferenceValue "UpdatingRectangleMorph new target: self preference; getSelector: #preferenceValue; putSelector: #preferenceValue:; extent: 22@22; setBalloonText: 'click here to change the color' translated; yourself."! ! !PBColorPreferenceView methodsFor: 'user interface' stamp: 'mt 8/28/2015 10:40'! fillStyleMenu "Add the items for changing the current fill style of the Morph" | aMenu | "self canHaveFillStyles ifFalse:[^aMenu add: 'change color...' translated target: self action: #changeColor]." aMenu := MenuMorph new defaultTarget: self. "self preference preferenceValue addFillStyleMenuItems: aMenu hand: nil from: self." aMenu add: 'change color...' translated target: self selector:#changeColor: argument: button. aMenu addLine. aMenu add: 'solid fill' translated action: #useSolidFill. "aMenu add: 'gradient fill' translated action: #useGradientFill. aMenu add: 'bitmap fill' translated action: #useBitmapFill. aMenu add: 'default fill' translated action: #useDefaultFill." ^aMenu popUpInWorld ! ! !PBColorPreferenceView methodsFor: 'user interface' stamp: 'kfr 5/6/2015 18:37'! setBorderStyle: aBorderStyle self preference name = #menuBorderColor ifTrue: [button color: MenuMorph menuColor; borderWidth: MenuMorph menuBorderWidth]. self preference name = #menuTitleBorderColor ifTrue: [button color: MenuMorph menuTitleColor; borderWidth: MenuMorph menuTitleBorderWidth]. self preference preferenceValue: aBorderStyle. button label: self preference preferenceValue asString; borderColor: aBorderStyle. ! ! !PBColorPreferenceView methodsFor: 'user interface' stamp: 'kfr 5/6/2015 18:55'! useGradientFill "Make receiver use a solid fill style (e.g., a simple color)" | color1 color2 fill | self preference preferenceValue isGradientFill ifTrue:[^self]. "Already done" color1 := Color white darker. color2 := self preference preferenceValue asColor. fill := GradientFillStyle ramp: {0.0 -> color1. 1.0 -> color2}. fill origin: ActiveWorld topLeft. fill direction: 0 @ ActiveWorld bounds extent y. fill normal: ActiveWorld bounds extent x @ 0. fill radial: false. self preference preferenceValue: fill. button label: self preference preferenceValue asString; color: self preference preferenceValue! ! !PBColorPreferenceView methodsFor: 'user interface' stamp: 'kfr 5/6/2015 18:48'! useSolidFill "Make receiver use a solid fill style (e.g., a simple color)" self preference preferenceValue isSolidFill ifTrue:[^self]. "Already done" self preference preferenceValue: self preference preferenceValue asColor. "Try minimizing changes" button label: self preference preferenceValue asString; color: self preference preferenceValue ! ! !Vocabulary class methodsFor: 'type vocabularies' stamp: 'cmm 9/9/2015 17:42' prior: 53486040! typeChoices "Answer a list of all user-choosable data types" | vocabulariesForType | vocabulariesForType := self allStandardVocabularies select: [:e | e representsAType]. (Preferences valueOfFlag: #allowEtoyUserCustomEvents) ifFalse: [vocabulariesForType removeKey: #CustomEvents ifAbsent: []]. ^vocabulariesForType keys sort! ! "Protocols"! !PluggableTextView methodsFor: 'model access' stamp: 'jm 8/20/1998 11:55' prior: 33435842! model: aLockedModel "Refer to the comment in View|model:." self model: aLockedModel controller: controller. self editString: self getText. ! ! MCTestCase subclass: #MCSnapshotBrowserTest instanceVariableNames: 'model morph originalAnnotationPanePref' classVariableNames: '' poolDictionaries: '' category: 'Tests-Monticello'! !MCSnapshotBrowserTest methodsFor: 'running' stamp: 'topa 9/8/2015 00:25' prior: 17506329! setUp "to not disturb the tests" originalAnnotationPanePref := Preferences annotationPanes. Preferences disable: #annotationPanes. model := MCSnapshotBrowser forSnapshot: MCSnapshotResource current snapshot. self buildWindow! ! !MCSnapshotBrowserTest methodsFor: 'running' stamp: 'topa 9/8/2015 00:26'! tearDown originalAnnotationPanePref ifTrue: [Preferences enable: #annotationPanes]. super tearDown.! ! !PackageDependencyTest methodsFor: 'tests' stamp: 'topa 9/1/2015 14:30' prior: 85019128! testNetwork self testPackage: 'Network' dependsExactlyOn: #( Collections Compiler Compression Files Graphics Kernel Morphic System 'ToolBuilder-Kernel' 'WebClient-Core' ).! ! "Tests"! !TTCFontReader methodsFor: 'as yet unclassified' stamp: 'vv 8/29/2015 00:52' prior: 23512246! processCharMap: assoc "Process the given character map" | glyph cmap encode0 encode1 char value null | cmap := assoc value. null := (glyphs at: (cmap at: Character space asUnicode + 1) + 1) copy. null contours: #(). encode0 := Array new: 256 withAll: glyphs first. encode1 := Array new: 65536 withAll: glyphs first. 0 to: 255 do: [:i | char := Character value: i. glyph := glyphs at: (cmap at: char asUnicode + 1) + 1. encode0 at: i+1 put: glyph. ]. Character separators do: [:c | encode0 at: (c asciiValue + 1) put: null. ]. 0 to: 65536 - 1 do: [:i | value := cmap at: i+1. value = 65535 ifFalse: [ "???" | g | g := glyphs at: value+1 ifAbsent: [ null. ]. (g isKindOf: TTCompositeGlyph) ifFalse: [ encode1 at: i+1 put: g. ] ifTrue: [ g basicGlyphs: (((glyphs at: value+1) basicGlyphs) collect: [:t | t key->(glyphs at: (t value glyphIndex+1))]). encode1 at: i+1 put: g ]. ] ]. ^ {encode0. encode1}. ! ! !TTFontReader methodsFor: 'private' stamp: 'topa 9/1/2015 20:14' prior: 31321294! decodeCmapFmtTable: entry | cmapFmt length entryCount segCount segments offset cmap firstCode | cmapFmt := entry nextUShort. length := entry nextUShort. entry skip: 2. "skip version" cmapFmt = 0 ifTrue: "byte encoded table" [length := length - 6. "should be always 256" length <= 0 ifTrue: [^ nil]. "but sometimes, this table is empty" cmap := Array new: length. entry nextBytes: length into: cmap startingAt: entry offset. ^ cmap]. cmapFmt = 4 ifTrue: "segment mapping to deltavalues" [segCount := entry nextUShort // 2. entry skip: 6. "skip searchRange, entrySelector, rangeShift" segments := Array new: segCount. segments := (1 to: segCount) collect: [:e | Array new: 4]. 1 to: segCount do: [:i | (segments at: i) at: 2 put: entry nextUShort]. "endCount" entry skip: 2. "skip reservedPad" 1 to: segCount do: [:i | (segments at: i) at: 1 put: entry nextUShort]. "startCount" 1 to: segCount do: [:i | (segments at: i) at: 3 put: entry nextShort]. "idDelta" offset := entry offset. 1 to: segCount do: [:i | (segments at: i) at: 4 put: entry nextUShort]. "idRangeOffset" entryCount := segments inject: 0 into: [:max :seg | max max: seg second]. cmap := Array new: entryCount+1 withAll: 0.. segments withIndexDo: [:seg :si | | code | seg first to: seg second do: [:i | seg last > 0 ifTrue: ["offset to glypthIdArray - this is really C-magic!!" entry offset: i - seg first - 1 * 2 + seg last + si + si + offset. code := entry nextUShort. code > 0 ifTrue: [code := code + seg third]] ifFalse: ["simple offset" code := i + seg third]. cmap at: i + 1 put: code]]. ^ cmap]. cmapFmt = 6 ifTrue: "trimmed table" [firstCode := entry nextUShort. entryCount := entry nextUShort. cmap := Array new: entryCount + firstCode withAll: 0. entryCount timesRepeat: [cmap at: (firstCode := firstCode + 1) put: entry nextUShort]. ^ cmap]. ^ nil! ! "TrueType"! Object subclass: #RxMatcher instanceVariableNames: 'matcher ignoreCase startOptimizer stream markerPositions previousMarkerPositions markerCount lastResult firstTryMatch' classVariableNames: 'Cr Lf' poolDictionaries: '' category: 'Regex-Core'! !RxMatcher commentStamp: 'ul 8/28/2015 14:18' prior: 33925138! -- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov -- This is a recursive regex matcher. Not strikingly efficient, but simple. Also, keeps track of matched subexpressions. The life cycle goes as follows: 1. Initialization. Accepts a syntax tree (presumably produced by RxParser) and compiles it into a matcher built of other classes in this category. 2. Matching. Accepts a stream or a string and returns a boolean indicating whether the whole stream or its prefix -- depending on the message sent -- matches the regex. 3. Subexpression query. After a successful match, and before any other match, the matcher may be queried about the range of specific stream (string) positions that matched to certain parenthesized subexpressions of the original expression. Any number of queries may follow a successful match, and any number or matches may follow a successful initialization. Note that `matcher' is actually a sort of a misnomer. The actual matcher is a web of Rxm* instances built by RxMatcher during initialization. RxMatcher is just the interface facade of this network. It is also a builder of it, and also provides a stream-like protocol to easily access the stream being matched. Instance variables: matcher The entry point into the actual matcher. igoreCase Whether the matching algorithm should be case sensitive or not. startOptimizer An object which can quickly decide whether the next character can be the prefix of a match or not. stream The stream currently being matched against. markerPositions Positions of markers' matches. previousMarkerPositions Positions of markers from the previous #tryMatch send. markerCount Number of markers. lastResult Whether the latest match attempt succeeded or not. firtTryMatch True if there hasn't been any send of #tryMatch during the current matching.! !RxMatcher methodsFor: 'match enumeration' stamp: 'ul 8/27/2015 21:34' prior: 33926970! copyStream: aStream to: writeStream replacingMatchesWith: aString "Copy the contents of on the , except for the matches. Replace each match with ." | searchStart matchStart matchEnd | stream := aStream. firstTryMatch := true. [searchStart := aStream position. self proceedSearchingStream: aStream] whileTrue: [matchStart := (self subBeginning: 1) last. matchEnd := (self subEnd: 1) last. aStream position: searchStart. searchStart to: matchStart - 1 do: [:ignoredPos | writeStream nextPut: aStream next]. writeStream nextPutAll: aString. aStream position: matchEnd. "Be extra careful about successful matches which consume no input. After those, make sure to advance or finish if already at end." matchEnd = searchStart ifTrue: [aStream atEnd ifTrue: [^self "rest after end of whileTrue: block is a no-op if atEnd"] ifFalse: [writeStream nextPut: aStream next]]]. aStream position: searchStart. [aStream atEnd] whileFalse: [writeStream nextPut: aStream next]! ! !RxMatcher methodsFor: 'match enumeration' stamp: 'ul 8/27/2015 21:34' prior: 33928098! copyStream: aStream to: writeStream translatingMatchesUsing: aBlock "Copy the contents of on the , except for the matches. For each match, evaluate passing the matched substring as the argument. Expect the block to answer a String, and write the answer to in place of the match." | searchStart matchStart matchEnd match | stream := aStream. firstTryMatch := true. [searchStart := aStream position. self proceedSearchingStream: aStream] whileTrue: [matchStart := (self subBeginning: 1) last. matchEnd := (self subEnd: 1) last. aStream position: searchStart. searchStart to: matchStart - 1 do: [:ignoredPos | writeStream nextPut: aStream next]. match := (String new: matchEnd - matchStart + 1) writeStream. matchStart to: matchEnd - 1 do: [:ignoredPos | match nextPut: aStream next]. writeStream nextPutAll: (aBlock value: match contents). "Be extra careful about successful matches which consume no input. After those, make sure to advance or finish if already at end." matchEnd = searchStart ifTrue: [aStream atEnd ifTrue: [^self "rest after end of whileTrue: block is a no-op if atEnd"] ifFalse: [writeStream nextPut: aStream next]]]. aStream position: searchStart. [aStream atEnd] whileFalse: [writeStream nextPut: aStream next]! ! !RxMatcher methodsFor: 'initialize-release' stamp: 'ul 8/25/2015 17:01' prior: 33620254! initialize: syntaxTreeRoot ignoreCase: aBoolean "Compile thyself for the regex with the specified syntax tree. See comment and `building' protocol in this class and #dispatchTo: methods in syntax tree components for details on double-dispatch building. The argument is supposedly a RxsRegex." ignoreCase := aBoolean. self buildFrom: syntaxTreeRoot. self initializeMarkerPositions. startOptimizer := RxMatchOptimizer new initialize: syntaxTreeRoot ignoreCase: aBoolean! ! !RxMatcher methodsFor: 'initialize-release' stamp: 'ul 8/25/2015 17:03'! initializeMarkerPositions markerPositions := Array new: markerCount. previousMarkerPositions := Array new: markerCount.. 3 to: markerCount do: [ :index | markerPositions at: index put: (OrderedCollection new: 1). previousMarkerPositions at: index put: (OrderedCollection new: 1) ].! ! !RxMatcher methodsFor: 'private' stamp: 'ul 8/27/2015 21:46' prior: 33620765! isWordChar: aCharacterOrNil "Answer whether the argument is a word constituent character: alphanumeric or _." aCharacterOrNil ifNil: [ ^false ]. ^aCharacterOrNil isAlphaNumeric! ! !RxMatcher methodsFor: 'privileged' stamp: 'ul 8/25/2015 15:01' prior: 33929512! markerPositionAt: index add: position "Remember position of another instance of the given marker." index <= 2 ifTrue: [ markerPositions at: index put: position. ^self ]. (markerPositions at: index) addLast: position! ! !RxMatcher methodsFor: 'accessing' stamp: 'ul 8/27/2015 21:35' prior: 33929747! matchesStreamPrefix: theStream "Match thyself against a positionable stream." stream := theStream. firstTryMatch := true. ^self tryMatch! ! !RxMatcher methodsFor: 'private' stamp: 'ul 8/27/2015 21:41' prior: 33627569! proceedSearchingStream: aStream | position | [ position := aStream position. self tryMatch ifTrue: [ ^true ]. (aStream position: position; next) ifNil: [ "Try match at the very stream end too!!" ^self tryMatch ] ] repeat! ! !RxMatcher methodsFor: 'private' stamp: 'ul 8/27/2015 21:36' prior: 33929958! resetMarkerPositions "Reset the marker positions. This method should only be sent from #tryMatch. When this is after the first #tryMatch send, then the marker positions must be swapped." firstTryMatch ifTrue: [ firstTryMatch := false ] ifFalse: [ | temp | temp := previousMarkerPositions. previousMarkerPositions := markerPositions. markerPositions := temp ]. markerPositions at: 1 put: nil; at: 2 put: nil. 3 to: markerCount do: [ :index | (markerPositions at: index) resetTo: 1 ]! ! !RxMatcher methodsFor: 'accessing' stamp: 'ul 8/27/2015 21:35' prior: 33930226! searchStream: aStream "Search the stream for occurrence of something matching myself. After the search has occurred, stop positioned after the end of the matched substring. Answer a Boolean indicating success." | position | stream := aStream. position := aStream position. firstTryMatch := true. [aStream atEnd] whileFalse: [self tryMatch ifTrue: [^true]. aStream position: position; next. position := aStream position]. "Try match at the very stream end too!!" ^self tryMatch! ! !RxMatcher methodsFor: 'accessing' stamp: 'ul 8/25/2015 15:05' prior: 33628948! subBeginning: subIndex subIndex = 1 ifTrue: [ (markerPositions at: 1) ifNil: [ ^#()] ifNotNil: [ :mp | ^{ mp } ] ]. ^markerPositions at: subIndex * 2 - 1! ! !RxMatcher methodsFor: 'accessing' stamp: 'ul 8/25/2015 15:05' prior: 33629076! subEnd: subIndex subIndex = 1 ifTrue: [ (markerPositions at: 2) ifNil: [ ^#()] ifNotNil: [ :mp | ^{ mp } ] ]. ^markerPositions at: subIndex * 2! ! !RxMatcher methodsFor: 'private' stamp: 'ul 8/27/2015 21:34' prior: 33931623! tryMatch "Match thyself against the current stream." | wasFirstTryMatch | wasFirstTryMatch := firstTryMatch. self resetMarkerPositions. lastResult := startOptimizer ifNil: [ matcher matchAgainst: self ] ifNotNil: [ (startOptimizer canStartMatch: stream peek in: self) and: [ matcher matchAgainst: self ] ]. "check for duplicates" lastResult ifFalse: [ ^false ]. wasFirstTryMatch ifTrue: [ ^true ]. (previousMarkerPositions hasEqualElements: markerPositions) ifFalse: [ ^true ]. "this is a duplicate match" ^ lastResult := false! ! "Regex-Core"! "ST80"! "EToys"! "PreferenceBrowser"! !CompiledMethod methodsFor: 'comparing' stamp: 'eem 9/16/2015 16:39' prior: 31379448! = method "Answer whether the receiver implements the same code as the argument, method. Here ``same code'' means that if the receiver's source is compiled with the same compiler it should produce the same sequence of bytecodes and literals, same trailer and same properties. Hence this definition of #= (only one of many plausible definitions) can be used to quickly identify changes in the compiler's output." | numLits | method isCompiledMethod ifFalse: [^false]. self size = method size ifFalse: [^false]. self header = method header ifFalse: [^false]. "N.B. includes numLiterals comparison." self initialPC to: self endPC do: [:i | (self at: i) = (method at: i) ifFalse: [^false]]. numLits := self numLiterals. 1 to: numLits do: [:i| | lit1 lit2 | lit1 := self literalAt: i. lit2 := method literalAt: i. (lit1 == lit2 or: [lit1 literalEqual: lit2]) ifFalse: [(i = 1 and: [#(117 120) includes: self primitive]) ifTrue: [lit1 isArray ifTrue: [(lit2 isArray and: [(lit1 first: 2) = (lit2 first: 2)]) ifFalse: [^false]] ifFalse: "ExternalLibraryFunction" [(lit1 analogousCodeTo: lit2) ifFalse: [^false]]] ifFalse: [i = (numLits - 1) ifTrue: "properties" [(self properties analogousCodeTo: method properties) ifFalse: [^false]] ifFalse: "last literal (methodClassAssociation) of class-side methods is not unique" [(i = numLits and: [lit1 isVariableBinding and: [lit2 isVariableBinding and: [lit1 key == lit2 key and: [lit1 value == lit2 value]]]]) ifFalse: [^false]]]]]. ^true! ! "Kernel"! !TempVariableNode methodsFor: 'code generation (closures)' stamp: 'eem 7/14/2015 20:19'! absorbHoistedTemp: aTempVar "Collapse aTempVar into the receiver, being sure to update any closure analysis." aTempVar copyScopeAccessTo: self. aTempVar becomeForward: self! ! !TempVariableNode methodsFor: 'code generation (closures)' stamp: 'eem 7/14/2015 20:19'! copyScopeAccessTo: aTempVar "For absorbHoistedTemp:, copy the receiver's reads and writes into the record in aTempVar." readingScopes ifNotNil: [readingScopes keysAndValuesDo: [:scopeBlock :reads| reads do: [:location| aTempVar addReadWithin: scopeBlock "" at: location]]]. writingScopes ifNotNil: [writingScopes keysAndValuesDo: [:scopeBlock :writes| writes do: [:location| aTempVar addWriteWithin: scopeBlock "" at: location]]]! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 7/14/2015 20:20' prior: 20206278! addHoistedTemps: additionalTemporaries "" | tempsToBeMerged additionalTempsToAdd | additionalTemporaries do: [:temp| temp definingScope ifNil: [temp definingScope: self]]. (temporaries isNil or: [temporaries isEmpty]) ifTrue: [temporaries := additionalTemporaries copy. ^self]. tempsToBeMerged := additionalTemporaries select: [:t| t isBlockArg and: [temporaries anySatisfy: [:existing| existing isBlockArg and: [existing key = t key]]]]. additionalTempsToAdd := tempsToBeMerged isEmpty ifTrue: [additionalTemporaries copy] ifFalse: [additionalTemporaries reject: [:temp| tempsToBeMerged identityIncludes: temp]]. temporaries := (temporaries isNil or: [temporaries isEmpty]) ifTrue: [additionalTempsToAdd] ifFalse: [temporaries last isIndirectTempVector ifTrue: [temporaries allButLast, additionalTempsToAdd, { temporaries last }] ifFalse: [temporaries, additionalTempsToAdd]]. tempsToBeMerged do: [:t| | merge | merge := temporaries detect: [:existing| existing isBlockArg and: [existing key = t key]]. merge absorbHoistedTemp: t]! ! !BytecodeEncoder methodsFor: 'temps' stamp: 'eem 7/8/2015 09:08' prior: 33478586! bindTemp: name "Declare a temporary; error not if a field or class variable or out-of-scope temp. Read the comment in Encoder>>bindBlockArg:within: and subclass implementations." self supportsClosureOpcodes ifFalse: [^super bindTemp: name]. scopeTable at: name ifPresent: [:node| "When non-interactive raise the error only if it is a duplicate" node isTemp ifTrue:[node scope >= 0 ifTrue: [^self notify: 'Name already used in this method']] ifFalse:[self warnAboutShadowed: name]]. ^self reallyBind: name! ! "Compiler"! !Dictionary methodsFor: '*50Deprecated-accessing' stamp: 'nice 10/21/2009 01:50' prior: 30409312! fasterKeys "Contrary to old version of #keys, this method returned an Array rather than a Set. This was faster because no lookup: was performed. But now, #keys also return an Array, so don't use #fasterKeys anymore." self deprecated: 'use #keys'. ^self keys. ! ! !Dictionary methodsFor: '*50Deprecated-accessing' stamp: 'ul 1/25/2010 18:56' prior: 30411536! keyForIdentity: anObject "If anObject is one of the values of the receive, return its key, else return nil. Contrast #keyAtValue: in which there is only an equality check, here there is an identity check" self deprecated: 'Use #keyAtIdentityValue:ifAbsent:'. ^self keyAtIdentityValue: anObject ifAbsent: nil! ! !MorphicProject methodsFor: 'docking bars support' stamp: 'mt 9/20/2015 16:11' prior: 29249269! showWorldMainDockingBar: aBoolean "Change the receiver to show the main docking bar" self projectPreferenceFlagDictionary at: #showWorldMainDockingBar put: aBoolean. self assureMainDockingBarPresenceMatchesPreference! ! "Morphic"! !Debugger methodsFor: 'accessing' stamp: 'eem 9/17/2015 12:54' prior: 54802831! 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." | result selector classOfMethod category h ctxt newMethod | contextStackIndex = 0 ifTrue: [^false]. self selectedContext isExecutingBlock ifTrue: [h := self selectedContext activeHome. h ifNil: [self inform: 'Method for block not found on stack, can''t edit and continue'. ^false]. (self confirm: 'I will have to revert to the method from\which this block originated. Is that OK?' withCRs) ifFalse: [^false]. self resetContext: h changeContents: false. "N.B. Only reset the contents if the compilation succeeds. If contents are reset when compilation fails both compiler error message and modifications are lost." (result := self contents: aText notifying: aController) ifTrue: [self contentsChanged]. ^result]. classOfMethod := self selectedClass. category := self selectedMessageCategoryName. selector := self selectedClass newParser parseSelector: aText. (selector == self selectedMessageName or: [(self selectedMessageName beginsWith: 'DoIt') and: [selector numArgs = self selectedMessageName numArgs]]) ifFalse: [self inform: 'can''t change selector'. ^false]. selector := classOfMethod compile: aText classified: category notifying: aController. selector ifNil: [^false]. "compile cancelled" contents := aText. newMethod := classOfMethod compiledMethodAt: selector. newMethod isQuick ifTrue: [self cutBackExecutionToSenderContext]. ctxt := interruptedProcess popTo: self selectedContext. ctxt == self selectedContext ifFalse: [self inform: 'Method saved, but current context unchanged\because of unwind error. Click OK to see error' withCRs] ifTrue: [newMethod isQuick ifFalse: [interruptedProcess restartTopWith: newMethod; stepToSendOrReturn]. contextVariablesInspector object: nil]. self resetContext: ctxt. Smalltalk isMorphic ifTrue: [World addAlarm: #changed: withArguments: #(contentsSelection) for: self at: (Time millisecondClockValue + 200)]. ^true! ! !Debugger methodsFor: 'private' stamp: 'eem 9/17/2015 13:11'! cutBackExecutionToSenderContext "When accepting a new version of a method which can't be simulated (i.e. a quick method) we must cut back to the sender. But this is non-trivial. If the quick method has been reached via a perform: (as it is when one uses Create toi implement a method from an MNU) then the relevant arguments won't be on the stack and we can't simply proceed without crashing the VM." | oldContext context sel | oldContext := self selectedContext. self down. context := self selectedContext. context jump: (context previousPc - context pc). sel := context selectorToSendOrSelf. sel numArgs = oldContext method numArgs ifTrue: [context push: oldContext receiver. oldContext arguments do: [:arg| context push: arg]] ifFalse: [context privRefresh; stepToSendOrReturn]! ! "Tools"! !RxParser methodsFor: 'recursive descent' stamp: 'ul 9/25/2015 10:05' prior: 33672124! atom "An atom is one of a lot of possibilities, see below." | atom | (lookahead == nil or: [ lookahead == $| or: [ lookahead == $) or: [ lookahead == $* or: [ lookahead == $+ or: [ lookahead == $? ]]]]]) ifTrue: [ ^RxsEpsilon new ]. lookahead == $( ifTrue: [ " ::= '(' ')' " self match: $(. atom := self regex. self match: $). ^atom ]. lookahead == $[ ifTrue: [ " ::= '[' ']' " self match: $[. atom := self characterSet. self match: $]. ^atom ]. lookahead == $: ifTrue: [ " ::= ':' ':' " self match: $:. atom := self messagePredicate. self match: $:. ^atom ]. lookahead == $. ifTrue: [ "any non-whitespace character" self next. ^RxsContextCondition new beAny]. lookahead == $^ ifTrue: [ "beginning of line condition" self next. ^RxsContextCondition new beBeginningOfLine]. lookahead == $$ ifTrue: [ "end of line condition" self next. ^RxsContextCondition new beEndOfLine]. lookahead == $\ ifTrue: [ " ::= '\' " self next ifNil: [ self signalParseError: 'bad quotation' ]. (BackslashConstants includesKey: lookahead) ifTrue: [ atom := RxsCharacter with: (BackslashConstants at: lookahead). self next. ^atom]. self ifSpecial: lookahead then: [:node | self next. ^node]]. "If passed through the above, the following is a regular character." atom := RxsCharacter with: lookahead. self next. ^atom! ! !RxParser methodsFor: 'recursive descent' stamp: 'ul 9/24/2015 08:24' prior: 33673776! branch " ::= e | " | piece branch | piece := self piece. (lookahead == nil or: [ lookahead == $| or: [ lookahead == $) ]]) ifTrue: [ branch := nil ] ifFalse: [ branch := self branch ]. ^RxsBranch new initializePiece: piece branch: branch! ! !RxParser methodsFor: 'private' stamp: 'ul 9/24/2015 08:25' prior: 33675681! inputUpTo: aCharacter errorMessage: aString "Accumulate input stream until is encountered and answer the accumulated chars as String, not including . Signal error if end of stream is encountered, passing as the error description." | accumulator | accumulator := WriteStream on: (String new: 20). [ lookahead == aCharacter or: [lookahead == nil ] ] whileFalse: [ accumulator nextPut: lookahead. self next]. lookahead ifNil: [ self signalParseError: aString ]. ^accumulator contents! ! !RxParser methodsFor: 'private' stamp: 'ul 9/25/2015 10:06' prior: 33676298! inputUpTo: aCharacter nestedOn: anotherCharacter errorMessage: aString "Accumulate input stream until is encountered and answer the accumulated chars as String, not including . Signal error if end of stream is encountered, passing as the error description." | accumulator nestLevel | accumulator := WriteStream on: (String new: 20). nestLevel := 0. [ lookahead == aCharacter and: [ nestLevel = 0 ] ] whileFalse: [ lookahead ifNil: [ self signalParseError: aString ]. lookahead == $\ ifTrue: [ self next ifNil: [ self signalParseError: aString ]. BackslashConstants at: lookahead ifPresent: [ :unescapedCharacter | accumulator nextPut: unescapedCharacter ] ifAbsent: [ accumulator nextPut: $\; nextPut: lookahead ] ] ifFalse: [ accumulator nextPut: lookahead. lookahead == anotherCharacter ifTrue: [ nestLevel := nestLevel + 1 ]. lookahead == aCharacter ifTrue: [ nestLevel := nestLevel - 1 ] ]. self next ]. ^accumulator contents! ! !RxParser methodsFor: 'private' stamp: 'ul 9/24/2015 08:24' prior: 33677093! inputUpToAny: aDelimiterString errorMessage: aString "Accumulate input stream until any character from is encountered and answer the accumulated chars as String, not including the matched characters from the . Signal error if end of stream is encountered, passing as the error description." | accumulator | accumulator := WriteStream on: (String new: 20). [ lookahead == nil or: [ aDelimiterString includes: lookahead ] ] whileFalse: [ accumulator nextPut: lookahead. self next ]. lookahead ifNil: [ self signalParseError: aString ]. ^accumulator contents! ! !RxParser methodsFor: 'private' stamp: 'ul 9/25/2015 10:02' prior: 33679041! next "Advance the input storing the just read character as the lookahead." ^lookahead := input next! ! !RxParser methodsFor: 'accessing' stamp: 'ul 9/24/2015 08:25' prior: 33679551! parseStream: aStream "Parse an input from a character stream . On success, answers an RxsRegex -- parse tree root. On error, raises `RxParser syntaxErrorSignal' with the current input stream position as the parameter." | tree | input := aStream. self next. tree := self regex. self match: nil. ^tree! ! !RxParser methodsFor: 'recursive descent' stamp: 'ul 9/24/2015 08:26' prior: 33681798! regex " ::= e | `|' " | branch regex | branch := self branch. (lookahead == nil or: [ lookahead == $) ]) ifTrue: [ regex := nil ] ifFalse: [ self match: $|. regex := self regex ]. ^RxsRegex new initializeBranch: branch regex: regex! ! !RxCharSetParser methodsFor: 'parsing' stamp: 'ul 9/25/2015 09:31' prior: 33603272! parseEscapeChar self match: $\. elements add: ((RxsPredicate forEscapedLetter: lookahead) ifNil: [ RxsCharacter with: lookahead ]). self next! ! !RxsPredicate class methodsFor: 'instance creation' stamp: 'ul 9/25/2015 09:32' prior: 33704473! forEscapedLetter: aCharacter "Return a predicate instance for the given character, or nil if there's no such predicate." ^EscapedLetterSelectors at: aCharacter ifPresent: [ :selector | self new perform: selector ]! ! !RxsPredicate class methodsFor: 'class initialization' stamp: 'ul 9/25/2015 09:25' prior: 33853935! initializeEscapedLetterSelectors "self initializeEscapedLetterSelectors" EscapedLetterSelectors := Dictionary new at: $w put: #beWordConstituent; at: $W put: #beNotWordConstituent; at: $d put: #beDigit; at: $D put: #beNotDigit; at: $s put: #beSpace; at: $S put: #beNotSpace; yourself! ! !RxsPredicate class methodsFor: 'class initialization' stamp: 'ul 9/25/2015 09:26' prior: 33705689! initializeNamedClassSelectors "self initializeNamedClassSelectors" NamedClassSelectors := Dictionary new at: 'alnum' put: #beAlphaNumeric; at: 'alpha' put: #beAlphabetic; at: 'cntrl' put: #beControl; at: 'digit' put: #beDigit; at: 'graph' put: #beGraphics; at: 'lower' put: #beLowercase; at: 'print' put: #bePrintable; at: 'punct' put: #bePunctuation; at: 'space' put: #beSpace; at: 'upper' put: #beUppercase; at: 'xdigit' put: #beHexDigit; yourself! ! RxsPredicate removeSelector: #beTab! RxsPredicate removeSelector: #beLineFeed! RxsPredicate removeSelector: #beCarriageReturn! RxsPredicate removeSelector: #beBackslash! "Regex-Core"! !RxParserTest methodsFor: 'tests' stamp: 'ul 9/25/2015 17:38'! testCharacterSetWithEscapedCharacters "self debug: #testCharacterSetRange" { '[\r]'. String cr. String space. '[\n]'. String lf. String space. '[\t]'. String tab. String space. '[\e]'. Character escape asString. String space. '[\f]'. Character newPage asString. String space. '[\]]+'. ']]]'. '[[['. '[\S]+[\s]+=[\s]+#[^\[(]'. 'foo = #bar'. 'foo = #[1 2 3]'. '[\d]+'. '123'. 'abc'. '[\D]+'. 'abc'. '123'. '[\w]+'. 'a1_b2'. '...'. '[\W]+'. '...'. 'a1_b2'. } groupsDo: [ :regexString :inputToAccept :inputToReject | | regex | regex := regexString asRegex. self assert: (regex search: inputToAccept); deny: (regex search: inputToReject) ]! ! "Regex-Tests-Core"! "50Deprecated"! !Dictionary methodsFor: '*51deprecated-accessing' stamp: 'nice 10/21/2009 01:50' prior: 34174810! fasterKeys "Contrary to old version of #keys, this method returned an Array rather than a Set. This was faster because no lookup: was performed. But now, #keys also return an Array, so don't use #fasterKeys anymore." self deprecated: 'use #keys'. ^self keys. ! ! !Dictionary methodsFor: '*51deprecated-accessing' stamp: 'ul 1/25/2010 18:56' prior: 34175176! keyForIdentity: anObject "If anObject is one of the values of the receive, return its key, else return nil. Contrast #keyAtValue: in which there is only an equality check, here there is an identity check" self deprecated: 'Use #keyAtIdentityValue:ifAbsent:'. ^self keyAtIdentityValue: anObject ifAbsent: nil! ! !DictionaryTest methodsFor: 'basic tests' stamp: 'eem 9/25/2015 11:32'! testAtIfPresentIfAbsentPut "Test at:ifPresent:ifAbsentPut:" | dict present absent | dict := Dictionary new. present := absent := false. self assert: (dict at: #foo ifPresent:[:v| present := true. v] ifAbsentPut:[absent := true. #present]) equals: #present. self deny: present. self assert: absent. present := absent := false. self assert: (dict at: #foo ifPresent:[:v| present := true. v] ifAbsentPut:[absent := true. #absent]) equals: #present. self assert: present. self deny: absent.! ! "CollectionsTests"! !Encoder methodsFor: 'temps' stamp: 'topa 10/7/2015 20:29' prior: 57079780! bindTemp: name in: methodSelector "Declare a temporary; error not if a field or class variable." scopeTable at: name ifPresent:[:node| "When non-interactive raise the error only if its a duplicate" (node isTemp or:[requestor interactive]) ifTrue:[^self notify:'Name already used in this method'] ifFalse:[Transcript show: '(', name, ' is shadowed in "' , cue getClass printString , '>>' , methodSelector printString , '")']]. ^self reallyBind: name! ! "Compiler"! !Behavior methodsFor: 'instance creation' stamp: 'topa 10/7/2015 20:41' prior: 29528928! basicNew: sizeRequested "Primitive. Answer an instance of this class with the number of indexable variables specified by the argument, sizeRequested. Fail if this class is not indexable or if the argument is not a positive Integer, or if there is not enough memory available. Essential. See Object documentation whatIsAPrimitive. If the primitive fails because space is low then the scavenger will run before the method is activated. Check args and retry via handleFailingBasicNew: if they're OK." (ec == #'insufficient object memory' or: [ec == #'bad argument']) ifTrue: [^self handleFailingBasicNew: sizeRequested]. self isVariable ifFalse: [self error: self printString, ' cannot have variable sized instances']. self primitiveFailed! ! "Kernel"! !FilePackage methodsFor: 'reading' stamp: 'topa 10/7/2015 19:52' prior: 59024831! fileInFrom: aStream | changes | changes := ChangeSet scanFile: aStream from: 0 to: aStream size. aStream close. ('Processing ', self packageName) displayProgressFrom: 1 to: changes size during:[:bar| | chgRec | 1 to: changes size do:[:i| bar value: i. chgRec := changes at: i. self perform: chgRec type asMutator with: chgRec. ]. ].! ! !FilePackage methodsFor: 'reading' stamp: 'topa 10/7/2015 20:54' prior: 59026718! fromStream: aStream named: aName | changes | changes := ChangeSet scanFile: aStream from: 0 to: aStream size. aStream close. ('Processing ', aName) displayProgressFrom: 1 to: changes size during:[:bar| | chgRec | 1 to: changes size do:[:i| bar value: i. chgRec := changes at: i. self perform: chgRec type asMutator with: chgRec. ]. ].! ! "System"! !Text methodsFor: 'comparing' stamp: 'topa 10/7/2015 23:07'! hashWithInitialHash: initialHash "Implemented to be polymorphic with String" ^ self string hashWithInitialHash: initialHash ! ! !Dictionary methodsFor: 'accessing' stamp: 'eem 9/25/2015 11:30'! at: key ifPresent: oneArgBlock ifAbsentPut: absentBlock "Lookup the given key in the receiver. If it is present, answer the value of evaluating oneArgBlock with the value associated with the key. Otherwise add the value of absentBlock under the key, and answer that value." | index value | index := self scanFor: key. (array at: index) ifNotNil: [:element| ^oneArgBlock value: element value]. value := absentBlock value. self atNewIndex: index put: (Association key: key value: value). ^value! ! String removeSelector: #findLastOccuranceOfString:startingAt:! "Collections"! !FileStream class methodsFor: 'file reader services' stamp: 'mt 10/7/2015 10:04' prior: 84854272! fileReaderServicesForFile: fullName suffix: suffix "Answer services for the given file" ^ self servicesWithSuffixes select: [:spec | spec key anySatisfy: [:pattern | suffix = '*' or: [pattern match: suffix]]] thenCollect: [:spec | spec value]! ! !FileStream class methodsFor: 'file reader services' stamp: 'mt 10/7/2015 10:03'! serviceFileInSuffixes ^ self sourceFileSuffixes! ! !FileStream class methodsFor: 'file reader services' stamp: 'mt 10/7/2015 10:03'! serviceRemoveLineFeedsSuffixes ^ self sourceFileSuffixes! ! !FileStream class methodsFor: 'file reader services' stamp: 'mt 10/7/2015 09:56' prior: 84856389! services ^ (((self class selectors copyWithout: #services) select: [:symbol | symbol beginsWith: #service]) reject: [:symbol | symbol endsWith: #Suffixes]) collect: [:selector | self perform: selector]! ! !FileStream class methodsFor: 'file reader services' stamp: 'mt 10/7/2015 09:57'! servicesWithSuffixes ^ (((self class selectors copyWithout: #services) select: [:symbol | symbol beginsWith: #service]) reject: [:symbol | symbol endsWith: #Suffixes]) collect: [:selector | (self perform: (selector, #Suffixes) asSymbol) -> (self perform: selector)]! ! "Files"! MorphicModel subclass: #SystemWindow instanceVariableNames: 'labelString stripes label closeBox collapseBox activeOnlyOnTop paneMorphs paneRects collapsedFrame fullFrame isCollapsed menuBox mustNotClose labelWidgetAllowance updatablePanes allowReframeHandles labelArea expandBox' classVariableNames: 'ClickOnLabelToEdit CloseBoxFrame CloseBoxImageFlat CloseBoxImageGradient CollapseBoxImageFlat CollapseBoxImageGradient DoubleClickOnLabelToExpand ExpandBoxFrame ExpandBoxImageFlat ExpandBoxImageGradient FocusFollowsMouse GradientWindow HideExpandButton MenuBoxFrame MenuBoxImageFlat MenuBoxImageGradient ResizeAlongEdges ReuseWindows TopWindow WindowsRaiseOnClick' poolDictionaries: '' category: 'Morphic-Windows'! !SystemWindow commentStamp: '' prior: 51310770! SystemWindow is the Morphic equivalent of StandardSystemView -- a labelled container for rectangular views, with iconic facilities for close, collapse/expand, and resizing. The attribute onlyActiveOnTop, if set to true (and any call to activate will set this), determines that only the top member of a collection of such windows on the screen shall be active. To be not active means that a mouse click in any region will only result in bringing the window to the top and then making it active.! !HandMorph methodsFor: 'events-processing' stamp: 'cmm 9/1/2015 18:06' prior: 19284545! handleEvent: anEvent | evt ofs | owner ifNil:[^self]. evt := anEvent. EventStats ifNil:[EventStats := IdentityDictionary new]. EventStats at: #count put: (EventStats at: #count ifAbsent:[0]) + 1. EventStats at: evt type put: (EventStats at: evt type ifAbsent:[0]) + 1. evt isMouseOver ifTrue:[^self sendMouseEvent: evt]. ShowEvents == true ifTrue:[ Display fill: (0@0 extent: 300@120) rule: Form over fillColor: Color white. ofs := (owner hands indexOf: self) - 1 * 60. evt isKeyboard ifTrue: [ 'key: ', evt printString displayAt: (0@ofs) + (0@30) ] ifFalse: [ 'evt: ', evt printString displayAt: (0@ofs) + (0@0) ]. 'kf: ', self keyboardFocus printString displayAt: (0@ofs)+(0@45). ]. "Notify listeners" self sendListenEvent: evt to: self eventListeners. evt isWindowEvent ifTrue: [ self sendEvent: evt focus: nil. ^self mouseOverHandler processMouseOver: lastMouseEvent]. evt isKeyboard ifTrue:[ self sendListenEvent: evt to: self keyboardListeners. self sendKeyboardEvent: evt. ^self mouseOverHandler processMouseOver: lastMouseEvent]. evt isDropEvent ifTrue:[ self sendEvent: evt focus: nil. ^self mouseOverHandler processMouseOver: lastMouseEvent]. evt isMouse ifTrue:[ self sendListenEvent: evt to: self mouseListeners. lastMouseEvent := evt]. "Check for pending drag or double click operations." mouseClickState ifNotNil:[ (mouseClickState handleEvent: evt from: self) ifFalse:[ "Possibly dispatched #click: or something and will not re-establish otherwise" ^self mouseOverHandler processMouseOver: lastMouseEvent]]. evt isMove ifTrue:[ self position: evt position. self sendMouseEvent: evt. ] ifFalse:[ "Issue a synthetic move event if we're not at the position of the event" (evt position = self position) ifFalse:[self moveToEvent: evt]. "Drop submorphs on button events" (self hasSubmorphs) ifTrue:[self dropMorphs: evt] ifFalse:[self sendMouseEvent: evt]. ]. ShowEvents == true ifTrue:['mf: ', self mouseFocus printString displayAt: (0@ofs) + (0@15)]. self mouseOverHandler processMouseOver: lastMouseEvent. "self handleDragOutside: anEvent." ! ! !HandMorph methodsFor: 'accessing' stamp: 'cmm 9/9/2015 14:32'! windowUnderneath ActiveWorld submorphsDo: [ : each | (each isSystemWindow and: [ each containsPoint: self position ]) ifTrue: [ ^ each ] ]. ^ nil! ! !Morph methodsFor: 'drawing' stamp: 'mt 10/6/2015 13:45' prior: 31950819! boundsWithinCorners "Return a single sub-rectangle that lies entirely inside corners that are made by me. Used to identify large regions of window that do not need to be redrawn." ^ self wantsRoundedCorners ifTrue: [self bounds insetBy: 0@self cornerRadius] ifFalse: [self bounds] ! ! !Morph methodsFor: 'rounding' stamp: 'mt 10/6/2015 13:38'! cornerRadius ^ self valueOfProperty: #cornerRadius ifAbsent: [self class preferredCornerRadius]! ! !Morph methodsFor: 'rounding' stamp: 'mt 10/6/2015 13:38'! cornerRadius: radius self setProperty: #cornerRadius toValue: radius. self changed.! ! !Morph methodsFor: 'rounding' stamp: 'mk 8/7/2005 10:02' prior: 32376079! cornerStyle "Returns one of the following symbols: #square #rounded according to the current corner style." ^ self valueOfProperty: #cornerStyle ifAbsent: [#square]! ! !Morph methodsFor: 'drawing' stamp: 'mt 10/6/2015 13:45' prior: 31953143! drawDropHighlightOn: aCanvas self highlightedForDrop ifTrue: [ self wantsRoundedCorners ifTrue: [aCanvas frameRoundRect: self fullBounds radius: self cornerRadius width: 1 color: self dropHighlightColor] ifFalse: [aCanvas frameRectangle: self fullBounds color: self dropHighlightColor]].! ! !Morph methodsFor: 'drawing' stamp: 'mt 10/6/2015 13:45' prior: 31954751! drawDropShadowOn: aCanvas "Rectangular shadow with support for rounded corners." | shadowBounds | shadowBounds := self shadowOffset isRectangle ifTrue: [self bounds outsetBy: self shadowOffset] ifFalse: [self bounds translateBy: (self shadowOffset negated max: 0@0)]. "Only redraw the shadow if the shadow area is affected." ((aCanvas clipRect intersects: shadowBounds) and: [((self bounds insetBy: (self wantsRoundedCorners ifFalse: [0] ifTrue: [self cornerRadius])) containsRect: aCanvas clipRect) not]) ifTrue: [ (self hasProperty: #dropShadow) ifFalse: [self updateDropShadowCache]. aCanvas translucentImage: (self valueOfProperty: #dropShadow) at: shadowBounds topLeft].! ! !Morph methodsFor: 'drawing' stamp: 'mt 10/6/2015 13:45' prior: 31956487! drawKeyboardFocusIndicationOn: aCanvas self wantsRoundedCorners ifTrue: [aCanvas frameRoundRect: self bounds radius: self cornerRadius width: 3 "self borderStyle width" color: self keyboardFocusColor] ifFalse: [aCanvas frameRectangle: self bounds width: 3 "self borderStyle width" color: self keyboardFocusColor].! ! !Morph methodsFor: 'drawing' stamp: 'mt 10/6/2015 13:45' prior: 31957112! drawMouseDownHighlightOn: aCanvas self highlightedForMouseDown ifTrue: [ self wantsRoundedCorners ifTrue: [aCanvas frameRoundRect: self fullBounds radius: self cornerRadius width: 1 color: self color darker darker] ifFalse: [aCanvas frameRectangle: self fullBounds color: self color darker darker]].! ! !Morph methodsFor: 'drawing' stamp: 'mt 10/6/2015 13:41' prior: 31957688! drawOn: aCanvas self wantsRoundedCorners ifTrue: [aCanvas frameAndFillRoundRect: self bounds radius: self cornerRadius fillStyle: self fillStyle borderWidth: self borderStyle width borderColor: self borderStyle color] ifFalse: [aCanvas fillRectangle: self bounds fillStyle: self fillStyle borderStyle: self borderStyle]. ! ! !Morph methodsFor: 'events-processing' stamp: 'cmm 9/14/2015 13:48' prior: 32036651! handleMouseDown: anEvent "System level event handling." anEvent wasHandled ifTrue:[^self]. "not interested" anEvent hand removePendingBalloonFor: self. anEvent hand removePendingHaloFor: self. anEvent wasHandled: true. (anEvent controlKeyPressed and: [anEvent blueButtonChanged not and: [Preferences cmdGesturesEnabled]]) ifTrue: [^ self invokeMetaMenu: anEvent]. "Make me modal during mouse transitions" anEvent hand newMouseFocus: self event: anEvent. anEvent blueButtonChanged ifTrue:[^self blueButtonDown: anEvent]. "this mouse down could be the start of a gesture, or the end of a gesture focus" (self isGestureStart: anEvent) ifTrue: [^ self gestureStart: anEvent]. "Filter events sent to the subwidgets of non-MorphicModels in inactive windows, if they are not supposed to receive them due to windowActiveOnFirstClick being set to false. I don't like having this check for owningWindow here, is there another way?" SystemWindow allWindowsAcceptInput ifTrue: [ self owningWindow ifNil: [ self mouseDown: anEvent ] ifNotNil: [ : owningWindow | (owningWindow canProcessMouseDown: anEvent) ifTrue: [ self mouseDown: anEvent ] ifFalse: [ owningWindow activate ] ] ] ifFalse: [ self mouseDown: anEvent ]. Preferences maintainHalos ifFalse:[ anEvent hand removeHaloFromClick: anEvent on: self ]. (self handlesMouseStillDown: anEvent) ifTrue:[ self startStepping: #handleMouseStillDown: at: Time millisecondClockValue + self mouseStillDownThreshold arguments: {anEvent copy resetHandlerFields} stepTime: self mouseStillDownStepRate ]. ! ! !Morph methodsFor: 'event handling' stamp: 'cmm 9/11/2015 22:06' prior: 32014286! keyboardFocusChange: aBoolean "The message is sent to a morph when its keyboard focus change. The given argument indicates that the receiver is gaining keyboard focus (versus losing) the keyboard focus. Morphs that accept keystrokes should change their appearance in some way when they are the current keyboard focus." self eventHandler ifNotNil: [ : h | h keyboardFocusChange: aBoolean fromMorph: self ]. "Support for 'Focus Follows Mouse'. Want the window to maintain focus even after the pointer moves into its title bar." self owningWindow ifNotNil: [ : window | window lookFocused: (aBoolean or: [ window containsPoint: ActiveHand position]) ]. self indicateKeyboardFocus ifTrue: [ self changed ]! ! !Morph methodsFor: 'private' stamp: 'cmm 9/9/2015 13:36'! owningWindow self withAllOwnersDo: [ : each | each isSystemWindow ifTrue: [ ^ each ] ]. ^ nil! ! !Morph methodsFor: 'drawing' stamp: 'mt 10/6/2015 13:45' prior: 31972081! updateDropShadowCache | shadowBounds offset form canvas drawBlock localBounds mask maskCanvas | shadowBounds := self shadowOffset isRectangle ifTrue: [0@0 corner: (self bounds outsetBy: self shadowOffset) extent] ifFalse: [0@0 corner: self extent + self shadowOffset abs]. offset := self shadowOffset isRectangle ifTrue: [0@0] ifFalse: [self shadowOffset max: 0@0]. localBounds := self shadowOffset isRectangle ifTrue: [self shadowOffset topLeft extent: self extent] ifFalse: [(self shadowOffset negated max: 0@0) extent: self extent]. form := Form extent: shadowBounds extent depth: Display depth. canvas := form getCanvas. drawBlock := self useSoftDropShadow ifFalse: [ [:c | self wantsRoundedCorners ifTrue: [c fillRoundRect: localBounds radius: self cornerRadius fillStyle: self shadowColor] ifFalse: [c fillRectangle: localBounds fillStyle: self shadowColor]]] ifTrue: [ [:c | self wantsRoundedCorners ifTrue: [0 to: 9 do: [:i | c fillRoundRect: (shadowBounds insetBy: i) radius: (self cornerRadius max: 20) -i fillStyle: (self shadowColor alpha: self shadowColor alpha * (i+1))]] ifFalse: [0 to: 9 do: [:i | c fillRoundRect: (shadowBounds insetBy: i) radius: 20-i fillStyle: (self shadowColor alpha: self shadowColor alpha * (i+1))]]]]. canvas translateBy: offset during: [ :shadowCanvas | drawBlock value: shadowCanvas]. "Support transparent morph colors without having the shadow to shine through.." mask := Form extent: shadowBounds extent depth: Display depth. maskCanvas := mask getCanvas. self wantsRoundedCorners ifTrue: [maskCanvas fillRoundRect: (localBounds insetBy: self borderWidth) radius: self cornerRadius fillStyle: Color black] ifFalse: [maskCanvas fillRectangle: (localBounds insetBy: self borderWidth) fillStyle: Color black]. mask displayOn: form at: 0@0 rule: Form erase. self setProperty: #dropShadow toValue: form.! ! !UserDialogBoxMorph methodsFor: 'drawing' stamp: 'mt 10/6/2015 13:43' prior: 59087278! drawSubmorphsOn: aCanvas super drawSubmorphsOn: aCanvas. self wantsRoundedCorners ifTrue: [ "Overdraw lower part of title bar to hide bottom corners." aCanvas fillRectangle: (self submorphs first "titleRow" bottomLeft - (-1 @ self submorphs first cornerRadius) corner: self submorphs first "titleRow" bottomRight - (1@0)) color: self color].! ! !UserDialogBoxMorph methodsFor: 'initialization' stamp: 'mt 10/6/2015 13:42' prior: 59083883! initialize | titleRow cc | super initialize. self color: Color white. self listDirection: #topToBottom; wrapCentering: #center; hResizing: #shrinkWrap; vResizing: #shrinkWrap. self layoutInset: -1 @ -1; cellInset: 5@5. self borderStyle: BorderStyle thinGray. self setProperty: #indicateKeyboardFocus: toValue: #never. FillInTheBlankMorph roundedDialogCorners ifTrue: [self useRoundedCorners]. self hasDropShadow: Preferences menuAppearance3d. self useSoftDropShadow ifFalse: [ self shadowColor: (TranslucentColor r: 0.0 g: 0.0 b: 0.0 alpha: 0.666); shadowOffset: 1 @ 1] ifTrue: [ self shadowColor: (TranslucentColor r: 0.0 g: 0.0 b: 0.0 alpha: 0.01); shadowOffset: (10@8 corner: 10@12)]. cc := Color gray: 0.8. titleRow := AlignmentMorph newRow. titleRow hResizing: #spaceFill; vResizing: #shrinkWrap. self cornerStyle == #rounded ifTrue: [titleRow useRoundedCorners]. titleRow borderStyle: BorderStyle thinGray. titleRow layoutInset: (5@5 corner: (2@ (5 + (titleRow cornerStyle == #rounded ifTrue: [titleRow cornerRadius] ifFalse: [0])))). titleRow color: cc. titleRow fillStyle: self titleGradient. titleMorph := StringMorph new. titleMorph emphasis: 1. titleRow addMorph: titleMorph. labelMorph := TextMorph new. labelMorph margins: (Preferences standardButtonFont widthOf: $x) * 2 @ 0. labelMorph lock. buttonRow := AlignmentMorph newRow vResizing: #rigid; height: (Preferences standardButtonFont height + 20); hResizing: #spaceFill; layoutInset: (((Preferences standardButtonFont widthOf: $x) * 2 @ 0) corner: ((Preferences standardButtonFont widthOf: $x) * 2 @ 10)); cellInset: (Preferences standardButtonFont widthOf: $x) * 2. buttonRow color: Color transparent. self addMorphBack: titleRow ; addMorphBack: labelMorph ; addMorphBack: buttonRow. keyMap := Dictionary new! ! !PluggableTextMorph methodsFor: 'event handling' stamp: 'cmm 9/11/2015 20:18' prior: 18382894! mouseEnter: event super mouseEnter: event. selectionInterval ifNotNil: [textMorph editor selectInterval: selectionInterval; setEmphasisHere]. textMorph selectionChanged. (SystemWindow allWindowsAcceptInput or: [ Preferences mouseOverForKeyboardFocus ]) ifTrue:[ event hand newKeyboardFocus: self]! ! !PluggableTextMorph methodsFor: 'event handling' stamp: 'cmm 9/11/2015 20:18' prior: 18383963! mouseLeave: event "The mouse has left the bounds of the receiver" textMorph ifNotNil: [selectionInterval := textMorph editor selectionInterval]. super mouseLeave: event. (SystemWindow allWindowsAcceptInput or: [ Preferences mouseOverForKeyboardFocus ]) ifTrue: [event hand releaseKeyboardFocus: self]! ! !PluggableListMorph methodsFor: 'events' stamp: 'cmm 9/11/2015 20:18' prior: 66974570! mouseEnter: event super mouseEnter: event. (SystemWindow allWindowsAcceptInput or: [ Preferences mouseOverForKeyboardFocus ]) ifTrue: [ event hand newKeyboardFocus: self ]! ! !PluggableListMorph methodsFor: 'events' stamp: 'cmm 9/11/2015 20:18' prior: 66976143! mouseLeave: event "The mouse has left the bounds of the receiver" super mouseLeave: event. self hoverRow: nil. (SystemWindow allWindowsAcceptInput or: [ Preferences mouseOverForKeyboardFocus ]) ifTrue: [ event hand releaseKeyboardFocus: self ]! ! !NewBalloonMorph methodsFor: 'drawing' stamp: 'mt 10/6/2015 13:44' prior: 56732875! drawDropShadowOn: aCanvas aCanvas translateBy: self shadowOffset during: [ :shadowCanvas | (shadowCanvas isVisible: self bubbleBounds) ifTrue: [ self wantsRoundedCorners ifTrue: [shadowCanvas fillRoundRect: self bubbleBounds radius: self cornerRadius fillStyle: self shadowColor] ifFalse: [shadowCanvas fillRectangle: self bubbleBounds fillStyle: self shadowColor]]. self hasTail ifTrue: [ shadowCanvas drawPolygon: self verticesForTail fillStyle: self shadowColor]]. ! ! !NewBalloonMorph methodsFor: 'drawing' stamp: 'mt 10/6/2015 13:44' prior: 56733483! drawOn: aCanvas "Bubble." self wantsRoundedCorners ifTrue: [aCanvas frameAndFillRoundRect: self bubbleBounds radius: self cornerRadius fillStyle: self fillStyle borderWidth: self borderStyle width borderColor: self borderStyle color] ifFalse: [aCanvas fillRectangle: self bubbleBounds fillStyle: self fillStyle borderStyle: self borderStyle]. "Tail." self hasTail ifTrue: [ self verticesForTail in: [:points | | pixelOffset | pixelOffset := points first y < points second y ifFalse: [points first x < points second x ifTrue: [self borderStyle width negated @ self borderStyle width] "bottomLeft" ifFalse: [self borderStyle width @ self borderStyle width]] "bottomRight" ifTrue: [points first x < points second x ifTrue: [self borderStyle width negated @ self borderStyle width negated] "topLeft" ifFalse: [self borderStyle width @ self borderStyle width negated]]. "topRight" aCanvas drawPolygon: points fillStyle: self fillStyle. aCanvas line: points first to: points second + pixelOffset width: self borderStyle width color: self borderStyle color. aCanvas line: points first to: points third + pixelOffset width: self borderStyle width color: self borderStyle color]]! ! !NewBalloonMorph methodsFor: 'drawing' stamp: 'mt 10/6/2015 13:44' prior: 56734849! verticesForTail | offset factorX factorY tpos bpos | offset := 5 + (self wantsRoundedCorners ifTrue: [self cornerRadius] ifFalse: [0]). tpos := self tailPosition. factorX := tpos x < self center x ifTrue: [1] ifFalse: [-1]. factorY := tpos y > self center y ifTrue: [1] ifFalse: [-1]. bpos := self bubbleBounds perform: self orientation. ^ { tpos. bpos + (((offset + self tailWidth) * factorX) @ (self borderStyle width negated * factorY)). bpos + ((offset * factorX) @ (self borderStyle width negated * factorY)).}! ! !SystemWindowButton methodsFor: 'visual properties' stamp: 'cmm 9/14/2015 13:43' prior: 59483635! mouseEnter: evt | classicSqueakBehavior | classicSqueakBehavior := SystemWindow allWindowsAcceptInput not. classicSqueakBehavior ifTrue: [ self highlight ] ifFalse: [ self owningWindow ifNotNil: [ : window | (window isActive or: [ Model windowActiveOnFirstClick ]) ifTrue: [ self highlight ] ] ]! ! !SimpleHierarchicalListMorph methodsFor: 'event handling' stamp: 'cmm 9/11/2015 20:18' prior: 56191405! mouseLeave: aMouseEvent super mouseLeave: aMouseEvent. (SystemWindow allWindowsAcceptInput or: [ Preferences mouseOverForKeyboardFocus ]) ifTrue: [ aMouseEvent hand releaseKeyboardFocus: self ]! ! !CornerGripMorph methodsFor: 'as yet unclassified' stamp: 'cmm 9/11/2015 17:53' prior: 25646853! mouseMove: anEvent | delta | target ifNil: [^ self]. target fastFramingOn ifTrue: [delta := target doFastWindowReframe: self ptName] ifFalse: [ delta := lastMouse ifNil: [0@0] ifNotNil: [anEvent cursorPoint - lastMouse]. lastMouse := anEvent cursorPoint. self apply: delta. self bounds: (self bounds origin + delta extent: self bounds extent)].! ! !MorphicModel methodsFor: 'events-processing' stamp: 'cmm 9/12/2015 16:18'! handleMouseDown: aMouseEvent SystemWindow allWindowsAcceptInput ifTrue: [ "This override is needed so that, when 'Window Active On First Click' is false, clicking on a PluggableListMorph of an inactive window will, correctly, NOT update the selection in the list; it will only activate the window." aMouseEvent blueButtonChanged ifFalse: [ self owningWindow ifNotNil: [ : window | (window canProcessMouseDown: aMouseEvent) ifFalse: [ ^ window activate ]. Model windowActiveOnFirstClick ifTrue: [ window activate ] ] ] ]. super handleMouseDown: aMouseEvent! ! !SystemWindow class methodsFor: 'private' stamp: 'cmm 9/11/2015 20:17'! allWindowsAcceptInput "With either of these two preferences settings, inactive windows will not have their widgets locked. All windows accept input as if they were active." ^ self focusFollowsMouse or: [ self windowsRaiseOnClick not ]! ! !SystemWindow class methodsFor: 'preferences' stamp: 'cmm 9/9/2015 21:17'! focusFollowsMouse ^ FocusFollowsMouse ifNil: [ false ]! ! !SystemWindow class methodsFor: 'preferences' stamp: 'cmm 9/12/2015 15:03'! focusFollowsMouse: aBoolean (FocusFollowsMouse := aBoolean) == true. self reconfigureWindowsForFocus! ! !SystemWindow class methodsFor: 'private' stamp: 'cmm 9/12/2015 15:02'! reconfigureWindowsForFocus self withAllSubclasses do: [ : eachSubclass | eachSubclass allInstances do: [ : eachInstance | eachInstance configureFocus ] ]! ! !SystemWindow class methodsFor: 'preferences' stamp: 'cmm 9/11/2015 22:12'! windowsRaiseOnClick ^ WindowsRaiseOnClick ifNil: [ true ]! ! !SystemWindow class methodsFor: 'preferences' stamp: 'cmm 9/12/2015 15:02'! windowsRaiseOnClick: aBoolean (WindowsRaiseOnClick := aBoolean == true). self reconfigureWindowsForFocus! ! !SystemWindow methodsFor: 'top window' stamp: 'cmm 9/9/2015 23:48' prior: 51420091! activate "Activate the owner too." |mo mc| mo := self modalOwner. mc := self modalChild. mc isNil ifFalse: [mc owner notNil ifTrue: [ mc activate. ^mc modalChild isNil ifTrue: [mc flash]]]. (isCollapsed not and: [ self paneMorphs size > 1 and: [ self splitters isEmpty ] ]) ifTrue: [ self addPaneSplitters ]. self activateWindow. self rememberedKeyboardFocus ifNil: [(self respondsTo: #navigateFocusForward) ifTrue: [self navigateFocusForward]] ifNotNil: [:m | m world ifNil: [self rememberKeyboardFocus: nil] "deleted" ifNotNil: [:w | m wantsKeyboardFocus ifTrue: [m takeKeyboardFocus] ifFalse: [(self respondsTo: #navigateFocusForward) ifTrue: [self navigateFocusForward]]]]. (mo notNil and: [mo isSystemWindow]) ifTrue: [mo bringBehind: self]! ! !SystemWindow methodsFor: 'top window' stamp: 'cmm 9/14/2015 14:22' prior: 51423616! activateWindow "Bring me to the front and make me able to respond to mouse and keyboard. Was #activate (sw 5/18/2001 23:20)" | oldTop outerMorph sketchEditor pal windowUnderneath | outerMorph := self topRendererOrSelf. outerMorph owner ifNil: [^ self "avoid spurious activate when drop in trash"]. self hasDropShadow: Preferences menuAppearance3d. oldTop := TopWindow. oldTop = self ifTrue: [^self]. TopWindow := self. oldTop ifNotNil: [oldTop passivate]. outerMorph owner firstSubmorph == outerMorph ifFalse: ["Bring me (with any flex) to the top if not already" outerMorph owner addMorphFront: outerMorph]. self configureFocus. self isCollapsed ifFalse: [model modelWakeUpIn: self. self positionSubmorphs. labelArea ifNil: [self adjustBorderUponActivationWhenLabeless]]. (sketchEditor := self extantSketchEditor) ifNotNil: [sketchEditor comeToFront. (pal := self world findA: PaintBoxMorph) ifNotNil: [pal comeToFront]]. self updatePaneColors. "Newly spawned windows are normally active, but if focusFollowsMouse is set, then the focused window can only be the one under the hand." (self class allWindowsAcceptInput not or: [ (windowUnderneath := ActiveHand windowUnderneath) isNil or: [ windowUnderneath == self ] ]) ifTrue: [ self lookFocused ] ifFalse: [ self lookUnfocused ]! ! !SystemWindow methodsFor: 'top window' stamp: 'cmm 9/11/2015 18:09'! canProcessMouseDown: anEvent "In case 'Focus Follows Mouse' is set, then there are two possibilities for mouse input on a background window: if 'Window Active On First Click' is set, it must be honored and the window must be activated. If it is not set, then the behavior depends on 'Windows Raise On Click' setting. If its true, then just activate the window and DON'T process aMouseEvent. If false, then process the event in any case." ^ self isActive or: [ Model windowActiveOnFirstClick or: [ SystemWindow windowsRaiseOnClick not ] ]! ! !SystemWindow methodsFor: 'top window' stamp: 'cmm 9/14/2015 14:20'! configureFocus "Make me unable to respond to mouse and keyboard unless allWindowsAcceptInput is set or 'Window Active On First Click' is unset. Otherwise, the classic Squeak behavior of Control boxes remaining active, except in novice mode." self submorphsDo: [ : each | each lock: (self isActive not and: [ each == labelArea ifTrue: [ self class windowsRaiseOnClick not ] ifFalse: [ self class allWindowsAcceptInput not ] ]) ]. labelArea ifNil: [ "i.e. label area is nil, so we're titleless" self adjustBorderUponDeactivationWhenLabeless ] ifNotNil: [ labelArea submorphsDo: [ : each | | classicSqueakBehavior | classicSqueakBehavior := self class allWindowsAcceptInput not. each lock: (classicSqueakBehavior ifTrue: [ self isActive not and: [ Preferences noviceMode or: [ each ~~ closeBox and: [ each ~~ collapseBox ] ] ] ] ifFalse: [ self isActive not and: [ Model windowActiveOnFirstClick not ] ]) ] ]! ! !SystemWindow methodsFor: 'events' stamp: 'cmm 9/14/2015 14:20' prior: 51314132! handleListenEvent: evt "Make sure we lock our contents after DnD has finished" evt isMouse ifFalse:[^self]. evt hand hasSubmorphs ifTrue:[^self]. "still dragging" (self isActive and: [ self class allWindowsAcceptInput not ]) ifFalse: [self configureFocus]. evt hand removeMouseListener: self.! ! !SystemWindow methodsFor: 'events' stamp: 'cmm 9/9/2015 13:51'! handlesMouseOver: anEvent ^ true! ! !SystemWindow methodsFor: 'top window' stamp: 'cmm 9/12/2015 17:32'! lookFocused label ifNotNil: [ label color: Color black ]. (self isActive or: [Model windowActiveOnFirstClick]) ifTrue: [ self undimWindowButtons ]. self updatePaneColors ; adoptPaneColor: self paneColorToUse! ! !SystemWindow methodsFor: 'top window' stamp: 'cmm 9/11/2015 20:14'! lookFocused: aBoolean aBoolean ifTrue: [ self lookFocused ] ifFalse: [ self lookUnfocused ]! ! !SystemWindow methodsFor: 'top window' stamp: 'cmm 10/5/2015 13:35'! lookUnfocused label ifNotNil: [ label color: Color darkGray ]. self dimWindowButtons. self paneColorToUseWhenNotActive in: [ : col | self setStripeColorsFrom: col ; adoptPaneColor: col ]! ! !SystemWindow methodsFor: 'events' stamp: 'cmm 9/11/2015 20:19'! mouseEnter: anEvent "Handle a mouseEnter event, meaning the mouse just entered my bounds with no button pressed. The default response is to let my eventHandler, if any, handle it." super mouseEnter: anEvent. self class allWindowsAcceptInput ifTrue: [ self lookFocused ]! ! !SystemWindow methodsFor: 'events' stamp: 'cmm 9/11/2015 20:19'! mouseLeave: anEvent "Handle a mouseEnter event, meaning the mouse just entered my bounds with no button pressed. The default response is to let my eventHandler, if any, handle it." super mouseLeave: anEvent. self class allWindowsAcceptInput ifTrue: [ self lookUnfocused ]! ! !SystemWindow methodsFor: 'events' stamp: 'cmm 9/14/2015 14:20' prior: 51317309! mouseLeaveDragging: evt "lock children after drop operations" (self isActive and:[evt hand hasSubmorphs and: [self class allWindowsAcceptInput not]]) ifTrue:[ self configureFocus. evt hand removeMouseListener: self. ].! ! !SystemWindow methodsFor: 'top window' stamp: 'cmm 9/14/2015 14:20' prior: 51430242! passivate "Lose my drop shadlow and reconfigure my focus according to preferences." self hasDropShadow: false ; configureFocus ; lookUnfocused. model modelSleep! ! !TextMorphForEditView methodsFor: 'event handling' stamp: 'cmm 9/11/2015 21:18' prior: 84347165! mouseUp: evt super mouseUp: evt. self stopSteppingSelector: #autoScrollView:. SystemWindow allWindowsAcceptInput ifFalse: [editView scrollSelectionIntoView: evt]. self setCompositionWindow. ! ! !PluggableButtonMorph methodsFor: 'drawing' stamp: 'mt 10/6/2015 13:44' prior: 17414071! drawBackgroundOn: aCanvas | cc gradient borderColor fill | cc := self color. cc isTransparent ifTrue:[cc := Color gray: 0.9]. self enabled ifFalse:[cc := Color lightGray]. cc brightness > 0.9 ifTrue:[cc := cc adjustBrightness: 0.9 - cc brightness]. showSelectionFeedback ifTrue:[ borderColor := cc muchDarker. gradient := GradientFillStyle ramp: { 0.0 -> cc muchDarker. 0.1-> (cc adjustBrightness: -0.2). 0.5 -> cc. 0.9-> (cc adjustBrightness: -0.1). 1 -> cc muchDarker}. cc := cc muchDarker. ] ifFalse:[ borderColor := Color lightGray. gradient := GradientFillStyle ramp: { 0.0 -> Color white. 0.1-> (cc adjustBrightness: 0.05). 0.6 -> (cc darker)}. ]. gradient origin: bounds topLeft. gradient direction: 0@self height. PluggableButtonMorph gradientButton ifFalse: [fill := SolidFillStyle color: cc] ifTrue: [fill := gradient]. ^ self wantsRoundedCorners ifTrue: [aCanvas frameAndFillRoundRect: self bounds radius: self cornerRadius fillStyle: fill borderWidth: 1 borderColor: borderColor] ifFalse: [aCanvas frameAndFillRectangle: self bounds fillColor: fill asColor borderWidth: 1 borderColor: borderColor darker; fillRectangle: self innerBounds fillStyle: fill]! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'mt 9/30/2015 14:07' prior: 17398171! font: aFont font = aFont ifTrue: [^ self]. font := aFont. self updateMinimumExtent. self changed.! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'mt 9/30/2015 14:07' prior: 17399861! label: aStringOrTextOrMorph label = aStringOrTextOrMorph ifTrue: [^ self]. label := aStringOrTextOrMorph isText ifTrue: [aStringOrTextOrMorph asMorph] ifFalse: [aStringOrTextOrMorph]. self updateMinimumExtent. self changed.! ! !ScrollPane methodsFor: 'event handling' stamp: 'cmm 9/11/2015 20:18' prior: 32683318! mouseEnter: event (SystemWindow allWindowsAcceptInput or: [ Preferences mouseOverForKeyboardFocus ]) ifTrue:[hasFocus := true]. (owner isSystemWindow) ifTrue: [owner paneTransition: event]. retractableScrollBar ifTrue:[ self hideOrShowScrollBars ]. ! ! !ScrollPane methodsFor: 'event handling' stamp: 'cmm 9/11/2015 20:18' prior: 32684088! mouseLeave: event (SystemWindow allWindowsAcceptInput or: [ Preferences mouseOverForKeyboardFocus ]) ifTrue:[hasFocus := false]. retractableScrollBar ifTrue: [self hideScrollBars]. (owner isSystemWindow) ifTrue: [owner paneTransition: event] ! ! !ProportionalSplitterMorph methodsFor: 'layout' stamp: 'cmm 9/11/2015 20:18' prior: 24859647! proposedCorrectionWouldCauseFocusChange: correction ^ (SystemWindow allWindowsAcceptInput or: [ Preferences mouseOverForKeyboardFocus ]) and: [ | edge | splitsTopAndBottom ifTrue: [ edge := correction positive ifTrue: [ self bottom + 3 ] ifFalse: [ self top - 3 ]. ActiveHand position y inRangeOf: edge and: edge + correction ] ifFalse: [ edge := correction positive ifTrue: [ self right ] ifFalse: [ self left ]. ActiveHand position x inRangeOf: edge and: edge + correction ] ]! ! SystemWindow removeSelector: #lockInactivePortions! "Morphic"! !FileStream class methodsFor: '*Tools-Changes' stamp: 'mt 10/7/2015 09:26'! edit: fullNameOrStream ^ (fullNameOrStream isString ifTrue: [self fileNamed: fullNameOrStream] ifFalse: [fullNameOrStream]) edit! ! !FileStream class methodsFor: '*Tools-Changes' stamp: 'mt 10/7/2015 10:17'! serviceEditFile ^ SimpleServiceEntry provider: self label: 'edit as text file' selector: #edit: description: 'edit as text file' buttonLabel: 'edit'! ! !FileStream class methodsFor: '*Tools-Changes' stamp: 'mt 10/7/2015 10:17'! serviceEditFileSuffixes ^ #('*')! ! !Model methodsFor: '*Tools-pluggable menus' stamp: 'topa 10/8/2015 00:10'! buildMenu: aMenu withBuilders: builders shifted: aBoolean " We let every builder modify the menu. The builder should indicate whether to abort by returning nil." | menu | menu := aMenu. builders do: [:builder | menu := self perform: builder method selector withEnoughArguments: { menu . aBoolean }. menu ifNil: [^ aMenu]]. ^ menu ! ! !Model methodsFor: '*Tools-pluggable menus' stamp: 'topa 10/8/2015 00:10'! menu: aMenu for: aMenuSymbolOrCollection ^ self menu: aMenu for: aMenuSymbolOrCollection shifted: false! ! !Model methodsFor: '*Tools-pluggable menus' stamp: 'topa 10/8/2015 00:10'! menu: aMenu for: aMenuSymbolOrCollection shifted: aBoolean | builders | builders := self menuBuildersFor: aMenuSymbolOrCollection in: self class shifted: aBoolean. builders := self sortMenuBuilders: builders. ^ self buildMenu: aMenu withBuilders: builders shifted: aBoolean ! ! !Model methodsFor: '*Tools-pluggable menus' stamp: 'topa 10/8/2015 00:10'! menuBuildersFor: someMenus in: aClass shifted: aBoolean "Find all builders but reject the ones not matching the shift state " | pragmas | pragmas := (self menuPragmasFor: someMenus in: aClass) . ^ aBoolean ifTrue: [pragmas reject: [:builder | builder arguments = #(false)]] ifFalse: [pragmas reject: [:builder | builder arguments = #(true)]]. ! ! !Model methodsFor: '*Tools-pluggable menus' stamp: 'topa 10/8/2015 00:10'! menuPragmasFor: aMenuSymbolOrCollection in: aClass ^ aMenuSymbolOrCollection isCollection ifTrue: [aMenuSymbolOrCollection gather: [:aMenuSymbol | Pragma allNamed: aMenuSymbol from: aClass to: Object]] ifFalse: [Pragma allNamed: aMenuSymbolOrCollection from: aClass to: Object]! ! !Model methodsFor: '*Tools-pluggable menus' stamp: 'topa 10/8/2015 00:10'! methodMenuPriority: aMethod "The pirority of a menu method indicated by a pragma. Defaults to 500" ^ (aMethod pragmas detect: [:p | p keyword == #menuPriority: ] ifNone: [^ 500]) argumentAt: 1 ! ! !Model methodsFor: '*Tools-pluggable menus' stamp: 'topa 10/8/2015 00:10'! sortMenuBuilders: builders " Sort them by 1. Priority (default 500) 2. selector name " ^ builders sorted: [:a :b | | ma mb pa pb | ma := a method. mb := b method. pa := self methodMenuPriority: ma. pb := self methodMenuPriority: mb. pa < pb or: [pa = pb and: [ma selector <= mb selector]]] ! ! !Browser methodsFor: 'code pane' stamp: 'cmm 9/24/2015 15:04' prior: 62734831! compileMessage: aText notifying: aController "Compile the code that was accepted by the user, placing the compiled method into an appropriate message category. Return true if the compilation succeeded, else false." | fallBackCategoryName originalSelectorName result fallBackMethodName | self selectedMessageCategoryName = ClassOrganizer allCategory ifTrue: [ "User tried to save a method while the ALL category was selected" fallBackCategoryName := selectedMessageCategoryName. fallBackMethodName := selectedMessageName. editSelection == #newMessage ifTrue: [ "Select the 'as yet unclassified' category" selectedMessageCategoryName := nil. (result := self defineMessageFrom: aText notifying: aController) ifNil: ["Compilation failure: reselect the original category & method" selectedMessageCategoryName := fallBackCategoryName. selectedMessageName := fallBackMethodName] ifNotNil: [self setSelector: result]] ifFalse: [originalSelectorName := self selectedMessageName. self setOriginalCategoryIndexForCurrentMethod. selectedMessageName := fallBackMethodName := originalSelectorName. (result := self defineMessageFrom: aText notifying: aController) ifNotNil: [self setSelector: result] ifNil: [ "Compilation failure: reselect the original category & method" selectedMessageCategoryName := fallBackCategoryName. selectedMessageName := fallBackMethodName. ^ result notNil]]. self changed: #messageCategoryList. ^ result notNil] ifFalse: [ "User tried to save a method while the ALL category was NOT selected" ^ (self defineMessageFrom: aText notifying: aController) notNil]! ! StringHolder removeSelector: #sortMenuBuilders:! StringHolder removeSelector: #methodMenuPriority:! StringHolder removeSelector: #menuPragmasFor:in:! StringHolder removeSelector: #menuBuildersFor:in:shifted:! StringHolder removeSelector: #menu:for:shifted:! StringHolder removeSelector: #menu:for:! StringHolder removeSelector: #buildMenu:withBuilders:shifted:! "Tools"! !ImageSegmentTest class methodsFor: 'testing' stamp: 'topa 10/8/2015 01:19'! shouldInheritSelectors ^ false! ! !CompilerNotifyingTest methodsFor: 'testing' stamp: 'abc 10/7/2015 16:24' prior: 29195655! testATempShadowingAnotherTemp self setUpForErrorsIn: '| x | x := 1. ^[ | ` Name already used in this method ->`x | x ]'. self enumerateAllSelections! ! !CompilerNotifyingTest methodsFor: 'testing' stamp: 'abc 10/7/2015 16:24' prior: 29204730! testTempDoubledDefined self setUpForErrorsIn: '| x ` Name already used in this method ->`x | x := 1. ^x'. self enumerateAllSelections! ! !PreferencesTest methodsFor: 'tests' stamp: 'topa 10/7/2015 23:35' prior: 34085067! test08DNUFallback sut setPreference: #foo toValue: 123. sut class removeSelectorSilently: #foo. self assert: (sut perform: #foo) = 123. self should: [sut perform: #'_unlikelyAndUnknownSelector'] raise: MessageNotUnderstood.! ! "Tests"! "51Deprecated"! UVersionTestCase removeSelector: #testReversedComparisons! UVersionTestCase removeSelector: #testHash! UVersionTestCase removeSelector: #testFullOrder! UVersionTestCase removeSelector: #testCompare! UVersionTestCase removeSelector: #setUp! Smalltalk removeClassNamed: #UVersionTestCase! Smalltalk removeClassNamed: #UUniverseServerTestCase! UPackageTestCase removeSelector: #testXML! UPackageTestCase removeSelector: #testEncoding! UPackageTestCase removeSelector: #testCompare! UPackageTestCase removeSelector: #setUp! Smalltalk removeClassNamed: #UPackageTestCase! UGlobalInstallerTest removeSelector: #testBrokenDependency! UGlobalInstallerTest removeSelector: #testBasicDependency! UGlobalInstallerTest removeSelector: #setUp! Smalltalk removeClassNamed: #UGlobalInstallerTest! StringSocket class removeSelector: #spaceToEncode:! StringSocket class removeSelector: #encodeStringArray:! StringSocket class removeSelector: #decodeStringArray:! UUniverseBrowser removeSelector: #update:! UUniverseBrowser removeSelector: #universe:! UUniverseBrowser removeSelector: #titleAreaText! UUniverseBrowser removeSelector: #subcategoriesOf:! UUniverseBrowser removeSelector: #sortedPackages! UUniverseBrowser removeSelector: #selectedPackageIndex:! UUniverseBrowser removeSelector: #selectedPackageIndex! UUniverseBrowser removeSelector: #selectedPackageDescription! UUniverseBrowser removeSelector: #selectedPackage! UUniverseBrowser removeSelector: #selectPackageOrCategory:! UUniverseBrowser removeSelector: #rootCategoriesAndPackages! UUniverseBrowser removeSelector: #returnTrue! UUniverseBrowser removeSelector: #requestPackageList! UUniverseBrowser removeSelector: #packagesChanged! UUniverseBrowser removeSelector: #packageOneLineDescription:! UUniverseBrowser removeSelector: #packageDescriptions! UUniverseBrowser removeSelector: #open! UUniverseBrowser removeSelector: #morphicView! UUniverseBrowser removeSelector: #makeButtonWithAction:andLabel:! UUniverseBrowser removeSelector: #makeButtonWithAction:andGetState:andLabel:! UUniverseBrowser removeSelector: #isCategory:! UUniverseBrowser removeSelector: #installSet! UUniverseBrowser removeSelector: #installSelectedPackage! UUniverseBrowser removeSelector: #initialize! UUniverseBrowser removeSelector: #doInstall! UUniverseBrowser removeSelector: #configuration:! UUniverseBrowser removeSelector: #chooseUpgrades! UUniverseBrowser removeSelector: #categoriesAndPackagesIn:! UUniverseBrowser removeSelector: #categories! UUniverseBrowser removeSelector: #canMarkSelectionForInstallation! UUniverseBrowser removeSelector: #anyPackagesToInstall! UUniverseBrowser removeSelector: #anyPackageSelected! UUniverseBrowser class removeSelector: #unload! UUniverseBrowser class removeSelector: #orderPackagesByDependency:! UUniverseBrowser class removeSelector: #open! UUniverseBrowser class removeSelector: #initialize! UUniverseBrowser class removeSelector: #forUniverse:! Smalltalk removeClassNamed: #UUniverseBrowser! UUniverse removeSelector: #updatePackagesViaWWW! UUniverse removeSelector: #standardUniverses! UUniverse removeSelector: #shortName:! UUniverse removeSelector: #shortName! UUniverse removeSelector: #removePackageNamed:withVersion:! UUniverse removeSelector: #packagesNamed:! UUniverse removeSelector: #packages! UUniverse removeSelector: #packageNames! UUniverse removeSelector: #newestPackageNamed:! UUniverse removeSelector: #initialize! UUniverse removeSelector: #hasPackageNamed:! UUniverse removeSelector: #description:! UUniverse removeSelector: #description! UUniverse removeSelector: #buildPackageCache! UUniverse removeSelector: #addPackages:! UUniverse class removeSelector: #systemUniverse! UUniverse class removeSelector: #switchSystemToUniverse:! UUniverse class removeSelector: #squeak39Universe! UUniverse class removeSelector: #squeak37Universe! UUniverse class removeSelector: #squeak310Universe! UUniverse class removeSelector: #initialize! UUniverse class removeSelector: #homeMoviesUniverse! UUniverse class removeSelector: #exampleCompoundUniverse! UUniverse class removeSelector: #developmentUniverse! UUniverse class removeSelector: #betadevUniverse! UUniverse class removeSelector: #betaUniverse! UStandardUniverse removeSelector: #updatePackagesViaWWW! UStandardUniverse removeSelector: #standardUniverses! UStandardUniverse removeSelector: #serverPort:! UStandardUniverse removeSelector: #serverPort! UStandardUniverse removeSelector: #serverName:! UStandardUniverse removeSelector: #serverName! UStandardUniverse removeSelector: #removePackage:! UStandardUniverse removeSelector: #packagesURL:! UStandardUniverse removeSelector: #packagesURL! UStandardUniverse removeSelector: #packages:! UStandardUniverse removeSelector: #packages! UStandardUniverse removeSelector: #initialize! UStandardUniverse removeSelector: #addPackage:! Smalltalk removeClassNamed: #UStandardUniverse! UCompoundUniverse removeSelector: #updatePackagesViaWWW! UCompoundUniverse removeSelector: #update:! UCompoundUniverse removeSelector: #standardUniverses! UCompoundUniverse removeSelector: #packages! UCompoundUniverse removeSelector: #components:! UCompoundUniverse class removeSelector: #composedOf:! Smalltalk removeClassNamed: #UCompoundUniverse! Smalltalk removeClassNamed: #UUniverse! UPackageEditor removeSelector: #window! UPackageEditor removeSelector: #versionString:! UPackageEditor removeSelector: #versionString! UPackageEditor removeSelector: #urlString:! UPackageEditor removeSelector: #urlString! UPackageEditor removeSelector: #submit! UPackageEditor removeSelector: #stringForPackageNames:! UPackageEditor removeSelector: #smidString:! UPackageEditor removeSelector: #smidString! UPackageEditor removeSelector: #returnTrue! UPackageEditor removeSelector: #providesString:! UPackageEditor removeSelector: #providesString! UPackageEditor removeSelector: #packageNamesFromString:! UPackageEditor removeSelector: #packageName:! UPackageEditor removeSelector: #packageName! UPackageEditor removeSelector: #package:whenComplete:! UPackageEditor removeSelector: #package! UPackageEditor removeSelector: #openInMorphic! UPackageEditor removeSelector: #noteField:! UPackageEditor removeSelector: #morphicView! UPackageEditor removeSelector: #makeGuessSMIDButton! UPackageEditor removeSelector: #makeFieldGet:set:! UPackageEditor removeSelector: #maintainer:! UPackageEditor removeSelector: #maintainer! UPackageEditor removeSelector: #homepageString:! UPackageEditor removeSelector: #homepageString! UPackageEditor removeSelector: #guessSqueakMapID! UPackageEditor removeSelector: #description:! UPackageEditor removeSelector: #description! UPackageEditor removeSelector: #dependsString:! UPackageEditor removeSelector: #dependsString! UPackageEditor removeSelector: #categoryString:! UPackageEditor removeSelector: #categoryString! UPackageEditor removeSelector: #acceptFields! UPackageEditor class removeSelector: #package:whenComplete:! UPackageEditor class removeSelector: #initialize! Smalltalk removeClassNamed: #UPackageEditor! UAccountEditor removeSelector: #window! UAccountEditor removeSelector: #username:password:email:whenDone:! UAccountEditor removeSelector: #username! UAccountEditor removeSelector: #submit! UAccountEditor removeSelector: #returnTrue! UAccountEditor removeSelector: #password:! UAccountEditor removeSelector: #password2:! UAccountEditor removeSelector: #password2! UAccountEditor removeSelector: #password1:! UAccountEditor removeSelector: #password1! UAccountEditor removeSelector: #password! UAccountEditor removeSelector: #openInMorphic! UAccountEditor removeSelector: #noteField:! UAccountEditor removeSelector: #newEmail:! UAccountEditor removeSelector: #newEmail! UAccountEditor removeSelector: #morphicView! UAccountEditor removeSelector: #acceptFields! UAccountEditor class removeSelector: #username:password:email:whenDone:! UAccountEditor class removeSelector: #initialize! Smalltalk removeClassNamed: #UAccountEditor! Smalltalk removeClassNamed: #UUtilities! UUniverseServer removeSelector: #universe! UUniverseServer removeSelector: #stopListening! UUniverseServer removeSelector: #step! UUniverseServer removeSelector: #startListening! UUniverseServer removeSelector: #sendMessage:onConnection:! UUniverseServer removeSelector: #sendError:onConnection:! UUniverseServer removeSelector: #savePackageList! UUniverseServer removeSelector: #saveDirectory:! UUniverseServer removeSelector: #saveCheckpoint! UUniverseServer removeSelector: #processRawMessage:fromConnection:! UUniverseServer removeSelector: #processNetworking! UUniverseServer removeSelector: #processConnections! UUniverseServer removeSelector: #processConnection:! UUniverseServer removeSelector: #possiblySaveCheckpointAndPackageList! UUniverseServer removeSelector: #policy:! UUniverseServer removeSelector: #packageListFilename:! UUniverseServer removeSelector: #openStepperMorph! UUniverseServer removeSelector: #logToFileNamed:! UUniverseServer removeSelector: #logMessage:! UUniverseServer removeSelector: #loadFromCheckpoint! UUniverseServer removeSelector: #initializeForUniverse:! UUniverseServer removeSelector: #destroyConnection:! UUniverseServer removeSelector: #connection:requestedForUsername:andPassword:toRemovePackageNamed:withVersion:! UUniverseServer removeSelector: #connection:requestedForUsername:andPassword:toAddPackage:! UUniverseServer removeSelector: #connection:requestedAccountWithUsername:password:email:! UUniverseServer removeSelector: #connection:requestedAccountChangeForUsername:password:newPassword:newEmail:! UUniverseServer removeSelector: #comancheServiceName! UUniverseServer removeSelector: #checkForNewConnections! UUniverseServer removeSelector: #acceptConnectionOn:! UUniverseServer removeSelector: #acceptConnection:! UUniverseServer class removeSelector: #new! UUniverseServer class removeSelector: #forUniverse:! UUniverseServer class removeSelector: #forSaveDirectory:! Smalltalk removeClassNamed: #UUniverseServer! UUniverseMultiServer removeSelector: #switchConnection:toServerNamed:! UUniverseMultiServer removeSelector: #stopListening! UUniverseMultiServer removeSelector: #step! UUniverseMultiServer removeSelector: #startListening! UUniverseMultiServer removeSelector: #processRawMessage:fromConnection:! UUniverseMultiServer removeSelector: #processNetworking! UUniverseMultiServer removeSelector: #processConnections! UUniverseMultiServer removeSelector: #processConnection:! UUniverseMultiServer removeSelector: #initialize! UUniverseMultiServer removeSelector: #destroyConnection:! UUniverseMultiServer removeSelector: #checkForNewConnections! UUniverseMultiServer removeSelector: #addServers:! UUniverseMultiServer removeSelector: #addServer:! UUniverseMultiServer removeSelector: #acceptConnectionOn:! UUniverseMultiServer removeSelector: #acceptConnection:! UUniverseMultiServer class removeSelector: #defaultPort! Smalltalk removeClassNamed: #UUniverseMultiServer! UUniverseEditor removeSelector: #wantsSteps! UUniverseEditor removeSelector: #username:! UUniverseEditor removeSelector: #username! UUniverseEditor removeSelector: #update:! UUniverseEditor removeSelector: #universeDescription! UUniverseEditor removeSelector: #stepTimeIn:! UUniverseEditor removeSelector: #step! UUniverseEditor removeSelector: #sortedPackages! UUniverseEditor removeSelector: #sendMessage:! UUniverseEditor removeSelector: #selectedPackageIndex:! UUniverseEditor removeSelector: #selectedPackageIndex! UUniverseEditor removeSelector: #selectedPackage! UUniverseEditor removeSelector: #returnTrue! UUniverseEditor removeSelector: #requestPackageList! UUniverseEditor removeSelector: #removeVersion! UUniverseEditor removeSelector: #processNetworking! UUniverseEditor removeSelector: #password:! UUniverseEditor removeSelector: #password! UUniverseEditor removeSelector: #packagesChanged! UUniverseEditor removeSelector: #packageDescriptions! UUniverseEditor removeSelector: #open! UUniverseEditor removeSelector: #noteField:! UUniverseEditor removeSelector: #newPackageVersion! UUniverseEditor removeSelector: #newPackage! UUniverseEditor removeSelector: #morphicView! UUniverseEditor removeSelector: #makeButtonWithAction:andLabel:! UUniverseEditor removeSelector: #makeButtonWithAction:andGetState:andLabel:! UUniverseEditor removeSelector: #initialize:! UUniverseEditor removeSelector: #editAccount! UUniverseEditor removeSelector: #createNewPackage! UUniverseEditor removeSelector: #createAccount! UUniverseEditor removeSelector: #closeEditorForPackage:! UUniverseEditor removeSelector: #closeAccountEditor! UUniverseEditor removeSelector: #anyPackageSelected! UUniverseEditor removeSelector: #accountUpdatedWithUsername:password:email:! UUniverseEditor removeSelector: #acceptFields! UUniverseEditor class removeSelector: #unload! UUniverseEditor class removeSelector: #open! UUniverseEditor class removeSelector: #new! UUniverseEditor class removeSelector: #initialize! UUniverseEditor class removeSelector: #forUniverse:! Smalltalk removeClassNamed: #UUniverseEditor! UUniverseClient removeSelector: #waitForMessage! UUniverseClient removeSelector: #startConnecting! UUniverseClient removeSelector: #sendMessage:! UUniverseClient removeSelector: #removedPackageNamed:withVersion:! UUniverseClient removeSelector: #receivedMessagesDo:! UUniverseClient removeSelector: #processIO! UUniverseClient removeSelector: #packageAdded:! UUniverseClient removeSelector: #newPackageList:! UUniverseClient removeSelector: #newInMessage:! UUniverseClient removeSelector: #initialize:! UUniverseClient removeSelector: #disconnect! UUniverseClient class removeSelector: #new! UUniverseClient class removeSelector: #initialize! UUniverseClient class removeSelector: #forUniverse:! Smalltalk removeClassNamed: #UUniverseClient! USqueakMapUtil class removeSelector: #browsePackageID:! Smalltalk removeClassNamed: #USqueakMapUtil! UPolicyResponse removeSelector: #reason:! UPolicyResponse removeSelector: #reason! UPolicyResponse removeSelector: #allowed:! UPolicyResponse removeSelector: #allowed! UPolicyResponse class removeSelector: #new! UPolicyResponse class removeSelector: #denied:! UPolicyResponse class removeSelector: #denied! UPolicyResponse class removeSelector: #allowed:reason:! UPolicyResponse class removeSelector: #allowed:! UPolicyResponse class removeSelector: #allowed! Smalltalk removeClassNamed: #UPolicyResponse! UPolicy removeSelector: #packageNamed:withVersion:mayBeRemovedBy:withPassword:! UPolicy removeSelector: #package:mayBeAddedBy:withPassword:! UPolicy removeSelector: #changeUser:withPassword:toHavePassword:andNewEmail:! UPolicy removeSelector: #addUser:withPassword:andEmail:! UPermissivePolicy removeSelector: #packageNamed:withVersion:mayBeRemovedBy:withPassword:! UPermissivePolicy removeSelector: #package:mayBeAddedBy:withPassword:! UPermissivePolicy removeSelector: #changeUser:withPassword:toHavePassword:andNewEmail:! UPermissivePolicy removeSelector: #addUser:withPassword:andEmail:! Smalltalk removeClassNamed: #UPermissivePolicy! UPWild removeSelector: #tryToGivePackageName:toUsername:withPassword:! UPWild removeSelector: #superUser:! UPWild removeSelector: #packageNamed:withVersion:mayBeRemovedBy:withPassword:! UPWild removeSelector: #package:mayBeAddedBy:withPassword:! UPWild removeSelector: #initialize! UPWild removeSelector: #findAccount:withPassword:! UPWild removeSelector: #changeUser:withPassword:toHavePassword:andNewEmail:! UPWild removeSelector: #addUser:withPassword:andEmail:! UPWild class removeSelector: #isReasonableUsername:! UPWild class removeSelector: #isReasonablePackageName:! Smalltalk removeClassNamed: #UPWild! UPStable removeSelector: #packageNamed:withVersion:mayBeRemovedBy:withPassword:! UPStable removeSelector: #package:mayBeAddedBy:withPassword:! UPStable removeSelector: #masterUser:! UPStable removeSelector: #masterPassword:! UPStable removeSelector: #changeUser:withPassword:toHavePassword:andNewEmail:! UPStable removeSelector: #addUser:withPassword:andEmail:! Smalltalk removeClassNamed: #UPStable! Smalltalk removeClassNamed: #UPolicy! UPackageSpec removeSelector: #version! UPackageSpec removeSelector: #printOn:! UPackageSpec removeSelector: #name:version:! UPackageSpec removeSelector: #name! UPackageSpec removeSelector: #initialize! UPackageSpec removeSelector: #hash! UPackageSpec removeSelector: #=! UPackageSpec class removeSelector: #new! UPackageSpec class removeSelector: #name:version:! Smalltalk removeClassNamed: #UPackageSpec! Smalltalk removeClassNamed: #UPackageSerializer! UPackageInstaller removeSelector: #installFileNamed:! UPackageInstaller removeSelector: #install:usingBaseName:! UPackageInstaller removeSelector: #hash! UPackageInstaller removeSelector: #handlesFilename:! UPackageInstaller removeSelector: #handlesFileEnding:! UPackageInstaller removeSelector: #=! UPackageInstaller class removeSelector: #registeredInstallers! UPackageInstaller class removeSelector: #registerInstaller:! UPackageInstaller class removeSelector: #installerForFilename:! UPackageInstaller class removeSelector: #installFileNamed:! UPackageInstaller class removeSelector: #initialize! UISar removeSelector: #installFileNamed:! UISar removeSelector: #handlesFileEnding:! Smalltalk removeClassNamed: #UISar! UIProject removeSelector: #installFileNamed:! UIProject removeSelector: #handlesFileEnding:! Smalltalk removeClassNamed: #UIProject! UIMpeg removeSelector: #install:usingBasename:! UIMpeg removeSelector: #handlesFileEnding:! Smalltalk removeClassNamed: #UIMpeg! UIMonticello removeSelector: #mcmReaderClassName! UIMonticello removeSelector: #mcmReader! UIMonticello removeSelector: #isMCMReaderAvailable! UIMonticello removeSelector: #installFileNamed:! UIMonticello removeSelector: #handlesFileEnding:! Smalltalk removeClassNamed: #UIMonticello! UIFileOut removeSelector: #install:usingBaseName:! UIFileOut removeSelector: #handlesFilename:! Smalltalk removeClassNamed: #UIFileOut! Smalltalk removeClassNamed: #UPackageInstaller! UPackageCategory removeSelector: #printOn:! UPackageCategory removeSelector: #isUPackageCategory! UPackageCategory removeSelector: #isSubcategoryOf:! UPackageCategory removeSelector: #isPackageCategory! UPackageCategory removeSelector: #initialize:! UPackageCategory removeSelector: #initialize! UPackageCategory removeSelector: #hash! UPackageCategory removeSelector: #components! UPackageCategory removeSelector: #=! UPackageCategory class removeSelector: #withComponents:! UPackageCategory class removeSelector: #root! UPackageCategory class removeSelector: #readFrom:! Smalltalk removeClassNamed: #UPackageCategory! UPackage removeSelector: #xmlForExport! UPackage removeSelector: #version:! UPackage removeSelector: #version! UPackage removeSelector: #url:! UPackage removeSelector: #url! UPackage removeSelector: #stringArrayEncoding! UPackage removeSelector: #squeakMapID:! UPackage removeSelector: #squeakMapID! UPackage removeSelector: #provides:! UPackage removeSelector: #provides! UPackage removeSelector: #printXMLPackageList:on:! UPackage removeSelector: #printOn:! UPackage removeSelector: #packageSpec! UPackage removeSelector: #name:! UPackage removeSelector: #name! UPackage removeSelector: #maintainer:! UPackage removeSelector: #maintainer! UPackage removeSelector: #longDescription! UPackage removeSelector: #isUPackage! UPackage removeSelector: #isPackageCategory! UPackage removeSelector: #install! UPackage removeSelector: #initialize! UPackage removeSelector: #homepage:! UPackage removeSelector: #homepage! UPackage removeSelector: #hash! UPackage removeSelector: #description:! UPackage removeSelector: #description! UPackage removeSelector: #depends:! UPackage removeSelector: #depends! UPackage removeSelector: #defaultCategory! UPackage removeSelector: #categoryString:! UPackage removeSelector: #category:! UPackage removeSelector: #category! UPackage removeSelector: #cachedCopyFilename! UPackage removeSelector: #addDependency:! UPackage removeSelector: #=! UPackage class removeSelector: #savePackageList:onFileNamed:! UPackage class removeSelector: #readPackageListFromFileNamed:! UPackage class removeSelector: #getXMLPartNamed:from:! UPackage class removeSelector: #getXMLPackageList:from:! UPackage class removeSelector: #decodePackagesFromXMLStream:! UPackage class removeSelector: #decodeFromXMLElement:! UPackage class removeSelector: #decodeFromStringStream:! Smalltalk removeClassNamed: #UPackage! UOneShotConnection removeSelector: #processIO! UOneShotConnection removeSelector: #nextPut:! UOneShotConnection removeSelector: #nextOrNil! UOneShotConnection removeSelector: #isConnected! UOneShotConnection removeSelector: #initializeWithInMessage:andOutQueue:! UOneShotConnection removeSelector: #destroy! UOneShotConnection class removeSelector: #withInMessage:andOutQueue:! Smalltalk removeClassNamed: #UOneShotConnection! UMessage removeSelector: #maybeLogMessage! UMessage removeSelector: #asStringArray! UMessage removeSelector: #applyToServer:forConnection:! UMessage removeSelector: #applyToMultiServer:forConnection:! UMessage removeSelector: #applyToEditor:! UMessage removeSelector: #applyToClient:! UMessage class removeSelector: #fromStringArray:! UMSelectServer removeSelector: #shortName:! UMSelectServer removeSelector: #asStringArray! UMSelectServer removeSelector: #applyToServer:forConnection:! UMSelectServer removeSelector: #applyToMultiServer:forConnection:! UMSelectServer class removeSelector: #shortName:! UMSelectServer class removeSelector: #fromStringArray:! Smalltalk removeClassNamed: #UMSelectServer! UMRequestPackages removeSelector: #asStringArray! UMRequestPackages removeSelector: #applyToServer:forConnection:! UMRequestPackages class removeSelector: #fromStringArray:! Smalltalk removeClassNamed: #UMRequestPackages! UMRemovePackage removeSelector: #username:password:packageName:packageVersion:! UMRemovePackage removeSelector: #maybeLogMessage! UMRemovePackage removeSelector: #asStringArray! UMRemovePackage removeSelector: #applyToServer:forConnection:! UMRemovePackage class removeSelector: #username:password:packageName:packageVersion:! UMRemovePackage class removeSelector: #fromStringArray:! Smalltalk removeClassNamed: #UMRemovePackage! UMProtocolVersion removeSelector: #version:! UMProtocolVersion removeSelector: #version! UMProtocolVersion removeSelector: #asStringArray! UMProtocolVersion removeSelector: #applyToServer:forConnection:! UMProtocolVersion removeSelector: #applyToMultiServer:forConnection:! UMProtocolVersion removeSelector: #applyToEditor:! UMProtocolVersion removeSelector: #applyToClient:! UMProtocolVersion class removeSelector: #version:! UMProtocolVersion class removeSelector: #fromStringArray:! Smalltalk removeClassNamed: #UMProtocolVersion! UMPackageRemoved removeSelector: #packageName:version:! UMPackageRemoved removeSelector: #asStringArray! UMPackageRemoved removeSelector: #applyToClient:! UMPackageRemoved class removeSelector: #packageName:version:! UMPackageRemoved class removeSelector: #fromStringArray:! Smalltalk removeClassNamed: #UMPackageRemoved! UMPackageList removeSelector: #packages:! UMPackageList removeSelector: #asStringArray! UMPackageList removeSelector: #applyToClient:! UMPackageList class removeSelector: #packages:! UMPackageList class removeSelector: #fromStringArray:! Smalltalk removeClassNamed: #UMPackageList! UMPackageAdded removeSelector: #package:! UMPackageAdded removeSelector: #asStringArray! UMPackageAdded removeSelector: #applyToEditor:! UMPackageAdded removeSelector: #applyToClient:! UMPackageAdded class removeSelector: #package:! UMPackageAdded class removeSelector: #fromStringArray:! Smalltalk removeClassNamed: #UMPackageAdded! UMMalformed removeSelector: #stringArray:! UMMalformed removeSelector: #asStringArray! UMMalformed class removeSelector: #fromStringArray:! Smalltalk removeClassNamed: #UMMalformed! UMError removeSelector: #description:! UMError removeSelector: #asStringArray! UMError removeSelector: #applyToServer:forConnection:! UMError removeSelector: #applyToEditor:! UMError class removeSelector: #fromStringArray:! UMError class removeSelector: #description:! Smalltalk removeClassNamed: #UMConnectionFailed! Smalltalk removeClassNamed: #UMError! UMEditedAccount removeSelector: #username:newPassword:newEmail:! UMEditedAccount removeSelector: #asStringArray! UMEditedAccount removeSelector: #applyToEditor:! UMEditedAccount class removeSelector: #username:newPassword:newEmail:! UMEditedAccount class removeSelector: #fromStringArray:! Smalltalk removeClassNamed: #UMEditedAccount! UMEditAccount removeSelector: #username:password:newPassword:newEmail:! UMEditAccount removeSelector: #asStringArray! UMEditAccount removeSelector: #applyToServer:forConnection:! UMEditAccount class removeSelector: #username:password:newPassword:newEmail:! UMEditAccount class removeSelector: #fromStringArray:! Smalltalk removeClassNamed: #UMEditAccount! UMAddPackage removeSelector: #username:password:package:! UMAddPackage removeSelector: #printOn:! UMAddPackage removeSelector: #maybeLogMessage! UMAddPackage removeSelector: #asStringArray! UMAddPackage removeSelector: #applyToServer:forConnection:! UMAddPackage class removeSelector: #username:password:package:! UMAddPackage class removeSelector: #fromStringArray:! Smalltalk removeClassNamed: #UMAddPackage! UMAddAccount removeSelector: #username:password:email:! UMAddAccount removeSelector: #maybeLogMessage! UMAddAccount removeSelector: #asStringArray! UMAddAccount removeSelector: #applyToServer:forConnection:! UMAddAccount class removeSelector: #username:password:email:! UMAddAccount class removeSelector: #fromStringArray:! Smalltalk removeClassNamed: #UMAddAccount! Smalltalk removeClassNamed: #UMessage! UInterfaceUtilities class removeSelector: #makeFieldRowNamed:getSelector:setSelector:isPassword:for:! UInterfaceUtilities class removeSelector: #makeFieldRowNamed:getSelector:setSelector:for:! UInterfaceUtilities class removeSelector: #makeFieldGet:set:for:! UInterfaceUtilities class removeSelector: #makeButtonWithAction:andLabel:for:! UInterfaceUtilities class removeSelector: #makeButtonWithAction:andGetState:andLabel:for:! Smalltalk removeClassNamed: #UInterfaceUtilities! UGlobalInstaller removeSelector: #universe:! UGlobalInstaller removeSelector: #universe! UGlobalInstaller removeSelector: #selectedPackageVersions! UGlobalInstaller removeSelector: #selectAllUpgrades! UGlobalInstaller removeSelector: #requestPackageList! UGlobalInstaller removeSelector: #planToInstallPackageNamed:! UGlobalInstaller removeSelector: #planToInstallPackage:! UGlobalInstaller removeSelector: #packagesForCategory:! UGlobalInstaller removeSelector: #packageVersionsForPackage:! UGlobalInstaller removeSelector: #orderPackagesByDependency:! UGlobalInstaller removeSelector: #isPackageVersionSelected:! UGlobalInstaller removeSelector: #isPackageVersionInstalled:! UGlobalInstaller removeSelector: #isPackageSelected:! UGlobalInstaller removeSelector: #isPackageInstalled:! UGlobalInstaller removeSelector: #installedPackageVersions! UGlobalInstaller removeSelector: #initializeSelectedPackageVersions! UGlobalInstaller removeSelector: #initialize! UGlobalInstaller removeSelector: #doInstall! UGlobalInstaller removeSelector: #deselectPackageVersion:! UGlobalInstaller removeSelector: #deselectPackageNamed:! UGlobalInstaller removeSelector: #containsAnyUpgrade! UGlobalInstaller removeSelector: #configuration:! UGlobalInstaller removeSelector: #anyPackageSelected! UGlobalInstaller removeSelector: #allPossibleUpgrades! UGlobalInstaller removeSelector: #allPackagesNeededToInstall:orIfImpossible:! UGlobalInstaller removeSelector: #allPackages! UGlobalInstaller removeSelector: #allCategories! UGlobalInstaller class removeSelector: #universe:configuration:! UGlobalInstaller class removeSelector: #universe:! Smalltalk removeClassNamed: #UGlobalInstaller! UConfiguration removeSelector: #packageNamed:! UConfiguration removeSelector: #installedPackages! UConfiguration removeSelector: #installPackage:! UConfiguration removeSelector: #initialize! UConfiguration removeSelector: #includesPackageSpec:! UConfiguration removeSelector: #includesPackageNamed:! UConfiguration class removeSelector: #forSystem! Smalltalk removeClassNamed: #UConfiguration! UAccount removeSelector: #username:! UAccount removeSelector: #username! UAccount removeSelector: #printOn:! UAccount removeSelector: #password:! UAccount removeSelector: #password! UAccount removeSelector: #ownsPackageName:! UAccount removeSelector: #initialize! UAccount removeSelector: #email:! UAccount removeSelector: #addPackageName:! Smalltalk removeClassNamed: #UAccount! Object removeSelector: #isUPackageCategory! Object removeSelector: #isUPackage! UVersion removeSelector: #printOn:! UVersion removeSelector: #hash! UVersion removeSelector: #components:! UVersion removeSelector: #components! UVersion removeSelector: #asUVersion! UVersion removeSelector: #=! UVersion removeSelector: #' prior: 17807503! This class handles all paragraph surgery in VI. In general, subclasses of EditCommand should be able to rely on the super class' undo/redo machinery -- only the repeat command needs to be overridden in most cases. This assumes, of course, that the newText, replacedText, newTextInterval, and replacedTextInterval have been set correctly. When setting the interval, use normal mode style selections, not insert mode selections (see class comment of VIMorphEditor). Possible useful expressions for doIt or printIt. Structure: instVar1 type -- comment about the purpose of instVar1 instVar2 type -- comment about the purpose of instVar2 Any further useful comments about the general approach of this implementation.! !CrLfFileStream class methodsFor: 'class initialization' stamp: 'ar 1/20/98 16:10' prior: 25601890! defaultToCR "CrLfFileStream defaultToCR" LineEndDefault := #cr.! ! !CrLfFileStream class methodsFor: 'class initialization' stamp: 'ar 1/20/98 16:10' prior: 25602044! defaultToCRLF "CrLfFileStream defaultToCRLF" LineEndDefault := #crlf.! ! !CrLfFileStream class methodsFor: 'class initialization' stamp: 'ar 1/20/98 16:10' prior: 25602204! defaultToLF "CrLfFileStream defaultToLF" LineEndDefault := #lf.! ! !CrLfFileStream class methodsFor: 'class initialization' stamp: 'fbs 7/25/2013 07:08' prior: 25603606! guessDefaultLineEndConvention "Lets try to guess the line end convention from what we know about the path name delimiter from FileDirectory." FileDirectory pathNameDelimiter = $: ifTrue: [^ self defaultToCR]. FileDirectory pathNameDelimiter = $/ ifTrue: [((Smalltalk osVersion) beginsWith: 'darwin') ifTrue: [^ self defaultToCR] ifFalse: [^ self defaultToLF]]. FileDirectory pathNameDelimiter = $\ ifTrue: [^ self defaultToCRLF]. "in case we don't know" ^ self defaultToCR! ! !CrLfFileStream class methodsFor: 'class initialization' stamp: 'di 2/4/1999 09:16' prior: 25604189! initialize "CrLfFileStream initialize" Cr := Character cr. Lf := Character lf. CrLf := String with: Cr with: Lf. LineEndStrings := Dictionary new. LineEndStrings at: #cr put: (String with: Character cr). LineEndStrings at: #lf put: (String with: Character lf). LineEndStrings at: #crlf put: (String with: Character cr with: Character lf). LookAheadCount := 2048. Smalltalk addToStartUpList: self. self startUp.! ! !CrLfFileStream class methodsFor: 'class initialization' stamp: 'dtl 4/4/2015 15:28' prior: 25605148! new self deprecated: 'This class is now obsolete, use MultiByteFileStream instead.'. ^ (MultiByteFileStream new ascii) wantsLineEndConversion: true; yourself. ! ! !CrLfFileStream class methodsFor: 'class initialization' stamp: 'djp 1/28/1999 22:08' prior: 25605403! startUp self guessDefaultLineEndConvention! ! !CrLfFileStream methodsFor: 'access' stamp: 'ar 1/20/98 16:16' prior: 25591799! ascii super ascii. self detectLineEndConvention! ! !CrLfFileStream methodsFor: 'access' stamp: 'ar 1/20/98 16:16' prior: 25592063! binary super binary. lineEndConvention := nil! ! !CrLfFileStream methodsFor: 'private' stamp: 'ar 1/20/98 16:21' prior: 25599827! convertStringFromCr: aString | inStream outStream | lineEndConvention ifNil: [^ aString]. lineEndConvention == #cr ifTrue: [^ aString]. lineEndConvention == #lf ifTrue: [^ aString copy replaceAll: Cr with: Lf]. "lineEndConvention == #crlf" inStream := ReadStream on: aString. outStream := WriteStream on: (String new: aString size). [inStream atEnd] whileFalse: [outStream nextPutAll: (inStream upTo: Cr). (inStream atEnd not or: [aString last = Cr]) ifTrue: [outStream nextPutAll: CrLf]]. ^ outStream contents! ! !CrLfFileStream methodsFor: 'private' stamp: 'ar 1/20/98 16:21' prior: 25601111! convertStringToCr: aString | inStream outStream | lineEndConvention ifNil: [^ aString]. lineEndConvention == #cr ifTrue: [^ aString]. lineEndConvention == #lf ifTrue: [^ aString copy replaceAll: Lf with: Cr]. "lineEndConvention == #crlf" inStream := ReadStream on: aString. outStream := WriteStream on: (String new: aString size). [inStream atEnd] whileFalse: [outStream nextPutAll: (inStream upTo: Cr). (inStream atEnd not or: [aString last = Cr]) ifTrue: [outStream nextPut: Cr. inStream peek = Lf ifTrue: [inStream next]]]. ^ outStream contents! ! !CrLfFileStream methodsFor: 'access' stamp: 'ls 7/10/1998 23:35' prior: 25593062! detectLineEndConvention "Detect the line end convention used in this stream. The result may be either #cr, #lf or #crlf." | char numRead pos | self isBinary ifTrue: [^ self error: 'Line end conventions are not used on binary streams']. lineEndConvention := LineEndDefault. "Default if nothing else found" numRead := 0. pos := super position. [super atEnd not and: [numRead < LookAheadCount]] whileTrue: [char := super next. char = Lf ifTrue: [super position: pos. ^ lineEndConvention := #lf]. char = Cr ifTrue: [super peek = Lf ifTrue: [lineEndConvention := #crlf] ifFalse: [lineEndConvention := #cr]. super position: pos. ^ lineEndConvention]. numRead := numRead + 1]. super position: pos. ^ lineEndConvention! ! !CrLfFileStream methodsFor: 'access' stamp: 'nk 9/5/2004 12:58' prior: 25593914! lineEndConvention ^lineEndConvention! ! !CrLfFileStream methodsFor: 'access' stamp: 'ls 11/5/1998 23:37' prior: 25594395! next | char secondChar | char := super next. self isBinary ifTrue: [^char]. char == Cr ifTrue: [secondChar := super next. secondChar ifNotNil: [secondChar == Lf ifFalse: [self skip: -1]]. ^Cr]. char == Lf ifTrue: [^Cr]. ^char! ! !CrLfFileStream methodsFor: 'access' stamp: 'ls 12/29/1998 17:15' prior: 25595447! next: n | string peekChar | string := super next: n. string size = 0 ifTrue: [ ^string ]. self isBinary ifTrue: [ ^string ]. "if we just read a CR, and the next character is an LF, then skip the LF" ( string last = Character cr ) ifTrue: [ peekChar := super next. "super peek doesn't work because it relies on #next" peekChar ~= Character lf ifTrue: [ super position: (super position - 1) ]. ]. string := string withSqueakLineEndings. string size = n ifTrue: [ ^string ]. "string shrunk due to embedded crlfs; make up the difference" ^string, (self next: n - string size)! ! !CrLfFileStream methodsFor: 'access' stamp: 'ar 1/20/98 16:18' prior: 25596124! nextPut: char (lineEndConvention notNil and: [char = Cr]) ifTrue: [super nextPutAll: (LineEndStrings at: lineEndConvention)] ifFalse: [super nextPut: char]. ^ char! ! !CrLfFileStream methodsFor: 'access' stamp: 'ar 1/20/98 16:18' prior: 25596363! nextPutAll: aString super nextPutAll: (self convertStringFromCr: aString). ^ aString ! ! !CrLfFileStream methodsFor: 'open/close' stamp: 'ar 1/20/98 16:15' prior: 25598568! open: aFileName forWrite: writeMode "Open the receiver. If writeMode is true, allow write, else access will be read-only. " | result | result := super open: aFileName forWrite: writeMode. result ifNotNil: [self detectLineEndConvention]. ^ result! ! !CrLfFileStream methodsFor: 'access' stamp: 'wod 6/18/1998 13:52' prior: 25596866! peek "Answer what would be returned if the message next were sent to the receiver. If the receiver is at the end, answer nil. " | next pos | self atEnd ifTrue: [^ nil]. pos := self position. next := self next. self position: pos. ^ next! ! !CrLfFileStream methodsFor: 'access' stamp: 'wod 11/5/1998 14:15' prior: 25597484! upTo: aCharacter | newStream char | newStream := WriteStream on: (String new: 100). [(char := self next) isNil or: [char == aCharacter]] whileFalse: [newStream nextPut: char]. ^ newStream contents ! ! !CrLfFileStream methodsFor: 'access' stamp: 'nice 12/7/2009 08:26' prior: 25597760! upToAnyOf: delimiters do: aBlock ^String new: 1000 streamContents: [ :stream | | ch | [ (ch := self next) == nil or: [ (delimiters includes: ch) and: [aBlock value: ch. true] ] ] whileFalse: [ stream nextPut: ch ] ]! ! !CrLfFileStream methodsFor: 'access' stamp: 'ar 1/20/98 16:18' prior: 25598054! verbatim: aString super verbatim: (self convertStringFromCr: aString). ^ aString! ! !StringMorph methodsFor: '*51Deprecated-Tools' stamp: 'mt 11/7/2015 12:17' prior: 55951262! balloonTextForClassAndMethodString "Answer suitable balloon text for the receiver thought of as an encoding of the form [ class ] " | aComment | self deprecated: 'Balloon texts for tools are defined in their respective model classes. For example, see Browser >> #messageHelpAt:'. Preferences balloonHelpInMessageLists ifFalse: [^ nil]. MessageSet parse: self contents asString toClassAndSelector: [:aClass :aSelector | (aClass notNil and: [aSelector notNil]) ifTrue: [aComment := aClass precodeCommentOrInheritedCommentFor: aSelector]]. ^ aComment ! ! !StringMorph methodsFor: '*51Deprecated-Tools' stamp: 'mt 11/7/2015 12:17' prior: 55952517! balloonTextForLexiconString "Answer suitable balloon text for the receiver thought of as an encoding (used in Lexicons) of the form (>)" | aComment contentsString aSelector aClassName | self deprecated: 'Balloon texts for tools are defined in their respective model classes. For example, see Browser >> #messageHelpAt:'. Preferences balloonHelpInMessageLists ifFalse: [^ nil]. contentsString := self contents asString. aSelector := contentsString upTo: $ . aClassName := contentsString copyFrom: ((contentsString indexOf: $() + 1) to: ((contentsString indexOf: $)) - 1). MessageSet parse: (aClassName, ' dummy') toClassAndSelector: [:cl :sel | cl ifNotNil: [aComment := cl precodeCommentOrInheritedCommentFor: aSelector]]. ^ aComment ! ! !StringMorph methodsFor: '*51Deprecated-Tools' stamp: 'mt 11/7/2015 12:17' prior: 55953914! balloonTextForMethodString "Answer suitable balloon text for the receiver thought of as a method belonging to the currently-selected class of a browser tool." | aWindow aCodeHolder aClass | self deprecated: 'Balloon texts for tools are defined in their respective model classes. For example, see Browser >> #messageHelpAt:'. Preferences balloonHelpInMessageLists ifFalse: [^ nil]. aWindow := self ownerThatIsA: SystemWindow. (aWindow isNil or: [((aCodeHolder := aWindow model) isKindOf: CodeHolder) not]) ifTrue: [^ nil]. ((aClass := aCodeHolder selectedClassOrMetaClass) isNil or: [(aClass includesSelector: contents asSymbol) not]) ifTrue: [^ nil]. ^ aClass precodeCommentOrInheritedCommentFor: contents asSymbol ! ! !TransferMorphAnimation class methodsFor: 'instance creation' stamp: 'mir 5/14/2000 00:07' prior: 17896099! on: aTransferMorph ^self new on: aTransferMorph! ! !TransferMorphAnimation methodsFor: 'initialization' stamp: 'ar 3/17/2001 23:43' prior: 17895305! on: aTransferMorph self flag: #bob. "there was a reference to World, but the class seems to be unused" self color: Color transparent. transferMorph := aTransferMorph. transferMorph addDependent: self. ActiveWorld addMorph: self "or perhaps aTransferMorph world"! ! !TransferMorphAnimation methodsFor: 'accessing' stamp: 'mir 5/14/2000 00:10' prior: 17894817! transferMorph ^transferMorph! ! !TransferMorphAnimation methodsFor: 'updating' stamp: 'mir 5/15/2000 18:05' prior: 17895753! update: aSymbol aSymbol == #deleted ifTrue: [self delete]. aSymbol == #position ifTrue: [self updateAnimation]. self changed! ! !TransferMorphAnimation methodsFor: 'update' stamp: 'mir 5/15/2000 18:02' prior: 17895655! updateAnimation! ! !TransferMorphLineAnimation methodsFor: 'initialization' stamp: 'di 9/9/2000 09:59' prior: 54300011! initPolygon polygon := (LineMorph from: self transferMorph source bounds center to: self transferMorph bounds center color: Color black width: 2) dashedBorder: {10. 10. Color white}. self addMorph: polygon ! ! !TransferMorphLineAnimation methodsFor: 'initialization' stamp: 'mir 5/14/2000 00:12' prior: 54300322! on: aTransferMorph super on: aTransferMorph. self initPolygon! ! !TransferMorphLineAnimation methodsFor: 'update' stamp: 'di 9/9/2000 09:46' prior: 54300468! updateAnimation polygon verticesAt: 2 put: self transferMorph center! ! !WriteStream methodsFor: '*51Deprecated-character writing' stamp: 'topa 10/8/2015 20:46' prior: 57010661! nextPutKeyword: keyword withArg: argValue "Emit a keyword/value pair in the alternate syntax" self deprecated. self nextPutAll: (keyword copyWithout: $:); nextPut: $(; store: argValue; nextPut: $)! ! !Preferences class methodsFor: '*51Deprecated-accessing' stamp: 'topa 10/8/2015 20:49' prior: 33970955! allPreferenceObjects "Answer a list of all the Preference objects registered in the system" self deprecated: 'Use #allPreferences since all preferences are objects.'. ^ self allPreferences! ! !Preferences class methodsFor: '*51Deprecated-get/set - flags' stamp: 'topa 10/8/2015 20:50' prior: 34057915! togglePreference: flagName self deprecated: 'Use #toggle:'. ^ self toggle: flagName.! ! !EditCommand class methodsFor: 'instance creation' stamp: 'sps 7/24/2003 17:08' prior: 17813621! textMorph: tm replacedText: replacedText replacedTextInterval: replacedTextInterval newText: newText newTextInterval: newTextInterval ^(self new) textMorph: tm replacedText: replacedText replacedTextInterval: replacedTextInterval newText: newText newTextInterval: newTextInterval; yourself ! ! !EditCommand methodsFor: 'command execution' stamp: 'sps 1/7/2002 21:37' prior: 17810992! doCommand ^self redoCommand ! ! !EditCommand methodsFor: 'selection' stamp: 'sps 1/7/2002 19:54' prior: 17812425! doSelectionInterval ^self redoSelectionInterval! ! !EditCommand methodsFor: 'accessors' stamp: 'sps 1/11/2002 17:12' prior: 17808294! iEditCommand ^true! ! !EditCommand methodsFor: 'accessors' stamp: 'sps 1/5/2002 14:05' prior: 17808384! lastSelectionInterval ^lastSelectionInterval! ! !EditCommand methodsFor: 'accessors' stamp: 'sps 1/5/2002 16:36' prior: 17808500! newText ^newText! ! !EditCommand methodsFor: 'accessors' stamp: 'sps 1/5/2002 16:36' prior: 17809070! newText: aText ^newText := aText! ! !EditCommand methodsFor: 'accessors' stamp: 'sps 1/4/2002 22:37' prior: 17808588! newTextInterval ^newTextInterval! ! !EditCommand methodsFor: 'accessors' stamp: 'sps 1/5/2002 16:36' prior: 17808829! newTextInterval: anInterval ^newText := anInterval! ! !EditCommand methodsFor: 'accessors' stamp: 'sps 7/24/2003 17:01' prior: 17809175! pEditor ^textMorph editor ! ! !EditCommand methodsFor: 'accessors' stamp: 'sps 7/24/2003 13:40' prior: 17809274! phase ^phase ! ! !EditCommand methodsFor: 'accessors' stamp: 'sps 7/24/2003 13:40' prior: 17809482! phase: aSymbol ^phase := aSymbol ! ! !EditCommand methodsFor: 'accessors' stamp: 'sps 1/11/2002 20:58' prior: 17809588! printOn: aStream | | aStream nextPutAll: self class name; nextPut: $[; nextPutAll: ('new: ', newTextInterval asString,' -> "', newText, '", rText: ', replacedTextInterval asString,' -> "', replacedText, '"'); nextPut: $].! ! !EditCommand methodsFor: 'command execution' stamp: 'sps 7/24/2003 17:04' prior: 17811104! redoCommand | | "Debug dShow: ('rInterval: ', replacedTextInterval asString, '. rText: ', replacedText string, ' nInterval: ', newTextInterval asString, ' nText: ', newText string)." self textMorphEditor noUndoReplace: replacedTextInterval with: newText. "Debug dShow: ('lastSelInt: ', lastSelectionInterval asString)." ! ! !EditCommand methodsFor: 'selection' stamp: 'sps 7/24/2003 17:34' prior: 17812545! redoSelectionInterval "Return an interval to be displayed as a subtle selection after undo, or nil" ^newTextInterval ! ! !EditCommand methodsFor: 'accessors' stamp: 'sps 1/5/2002 16:37' prior: 17809892! replacedText ^replacedText! ! !EditCommand methodsFor: 'accessors' stamp: 'sps 1/5/2002 16:37' prior: 17810528! replacedText: aText ^replacedText := aText! ! !EditCommand methodsFor: 'accessors' stamp: 'sps 1/4/2002 22:30' prior: 17809990! replacedTextInterval ^replacedTextInterval! ! !EditCommand methodsFor: 'accessors' stamp: 'sps 1/5/2002 16:36' prior: 17810259! replacedTextInterval: anInterval ^replacedTextInterval := anInterval! ! !EditCommand methodsFor: 'initialization' stamp: 'sps 7/24/2003 17:01' prior: 17812112! textMorph: tm replacedText: rText replacedTextInterval: rInterval newText: nText newTextInterval: nInterval textMorph := tm. replacedText := rText. replacedTextInterval := rInterval. newText := nText. newTextInterval := nInterval. ! ! !EditCommand methodsFor: 'accessors' stamp: 'sps 7/24/2003 17:04' prior: 17810643! textMorphEditor ^textMorph editor ! ! !EditCommand methodsFor: 'accessors' stamp: 'sps 7/24/2003 17:05' prior: 17810750! textMorphString ^textMorph text string ! ! !EditCommand methodsFor: 'accessors' stamp: 'sps 7/24/2003 17:02' prior: 17810863! textMorphStringSize ^textMorph text string size ! ! !EditCommand methodsFor: 'command execution' stamp: 'sps 7/24/2003 17:04' prior: 17811513! undoCommand "Debug dShow: ('new Interval: ', newTextInterval asString, '. rText: ', replacedText string)." self textMorphEditor noUndoReplace: newTextInterval with: replacedText. ! ! !EditCommand methodsFor: 'selection' stamp: 'sps 7/24/2003 17:36' prior: 17812736! undoSelection "Return an interval to be displayed as a selection after undo, or nil" ^replacedTextInterval first to: (replacedTextInterval first + replacedText size - 1) ! ! !EditCommand methodsFor: 'selection' stamp: 'sps 7/24/2003 17:03' prior: 17813248! undoSelectionInterval "Return an interval to be displayed as a selection after undo, or nil" | i | i := (replacedTextInterval first min: self textMorphStringSize). ^i to: i - 1 ! ! !Object methodsFor: '*51Deprecated' stamp: 'mir 5/16/2000 11:35' prior: 66624874! dragAnimationFor: item transferMorph: transferMorph "Default do nothing"! ! !KeyedSet methodsFor: '*51Deprecated-private' stamp: 'ar 2/1/2010 21:19' prior: 63849018! noCheckAdd: anObject self deprecated: 'This method should not be used anymore.'. array at: (self scanFor: (keyBlock value: anObject)) put: anObject asSetElement. tally := tally + 1! ! !PositionableStream methodsFor: '*51Deprecated-accessing' stamp: 'topa 10/8/2015 20:31' prior: 26665651! oldBack "Go back one element and return it. Use indirect messages in case I am a StandardFileStream" "The method is a misconception about what a stream is. A stream contains a pointer *between* elements with past and future elements. This method considers that the pointer is *on* an element. Please consider unit tests which verifies #back and #oldBack behavior. (Damien Cassou - 1 August 2007)" self deprecated: 'Use #back'. self position = 0 ifTrue: [self errorCantGoBack]. self position = 1 ifTrue: [self position: 0. ^ nil]. self skip: -2. ^ self next ! ! "51Deprecated"! ShortIntegerArray variableWordSubclass: #ShortPointArray instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Balloon-Collections'! !ShortPointArray commentStamp: 'nice 11/12/2015 23:50' prior: 51308635! This class stores points that are in short integer range (e.g., -32768 <= value <= 32767). It is used to pass data efficiently to the primitive level during high-bandwidth 2D graphics operations.! !ShortIntegerArray class methodsFor: 'class initialization' stamp: 'nice 11/13/2015 00:23' prior: 55989061! startUpFrom: endiannessHasToBeFixed "In this case, do we need to swap word halves when reading this segement?" ^endiannessHasToBeFixed ifTrue: [Message selector: #swapShortObjects] "will be run on each instance" ifFalse: [nil]. ! ! !ShortRunArray class methodsFor: 'class initialization' stamp: 'nice 11/13/2015 00:23' prior: 33139392! startUpFrom: endiannessHasToBeFixed "In this case, do we need to swap word halves when reading this segement?" ^endiannessHasToBeFixed ifTrue: [Message selector: #swapRuns "will be run on each instance"] ifFalse: [nil]! ! "Balloon"! Object subclass: #UUIDGenerator instanceVariableNames: '' classVariableNames: 'Default TheRandom TheSemaphore' poolDictionaries: '' category: 'Network-UUID'! !UUIDGenerator commentStamp: 'topa 10/19/2015 23:23:19' prior: 31597186! I generate a pseudo-random UUID by asking Random for a 128 bit value. See https://tools.ietf.org/html/rfc4122.html#section-4.4 for reference.! !NetNameResolver class methodsFor: 'lookups' stamp: 'ul 10/10/2015 17:08' prior: 50596222! addressForName: hostName timeout: secs "Look up the given host name and return its address. Return nil if the address is not found in the given number of seconds." "NetNameResolver addressForName: 'create.ucsb.edu' timeout: 30" "NetNameResolver addressForName: '100000jobs.de' timeout: 30" "NetNameResolver addressForName: '1.7.6.4' timeout: 30" "NetNameResolver addressForName: '' timeout: 30 (This seems to return nil?)" | deadline | self initializeNetwork. self useOldNetwork ifFalse: [^self addressForName: hostName]. "check if this is a valid numeric host address (e.g. 1.2.3.4)" (self addressFromString: hostName) ifNotNil: [ :numericHostAddress | ^numericHostAddress ]. "Look up a host name, including ones that start with a digit (e.g. 100000jobs.de or squeak.org)" deadline := Time primUTCMicrosecondClock + (secs * 1000000). "Protect the execution of this block, as the ResolverSemaphore is used for both parts of the transaction." ^(self resolverMutex critical: [ (self waitForResolverReadyUntil: deadline) ifTrue: [ self primStartLookupOfName: hostName. (self waitForCompletionUntil: deadline) ifTrue: [ self primNameLookupResult. ] ] ]) ifNil: [ (NameLookupFailure hostName: hostName) signal: 'Could not resolve the server named: ', hostName ] ! ! !NetNameResolver class methodsFor: 'lookups' stamp: 'ul 10/9/2015 21:20'! nameForAddress: hostAddress ^self nameForAddress: hostAddress timeout: 60! ! !NetNameResolver class methodsFor: 'lookups' stamp: 'ul 10/10/2015 17:06' prior: 50601118! nameForAddress: hostAddress timeout: secs "Look up the given host address and return its name. Return nil if the lookup fails or is not completed in the given number of seconds. Depends on the given host address being known to the gateway, which may not be the case for dynamically allocated addresses." "NetNameResolver nameForAddress: (NetNameResolver addressFromString: '128.111.92.2') timeout: 30" | deadline | self initializeNetwork. deadline := Time primUTCMicrosecondClock + (secs * 1000000). "Protect the execution of this block, as the ResolverSemaphore is used for both parts of the transaction." ^self resolverMutex critical: [ (self waitForResolverReadyUntil: deadline) ifTrue: [ self primStartLookupOfAddress: hostAddress. (self waitForCompletionUntil: deadline) ifTrue: [ self primAddressLookupResult ] ] ]! ! !NetNameResolver class methodsFor: 'private' stamp: 'ul 10/9/2015 22:20' prior: 50614856! waitForCompletionUntil: deadline "Wait until deadlien for the resolver to be ready to accept a new request. Return true if the resolver is ready, false if the network is not initialized or the resolver has not become free within the given time period." | status millisecondsLeft | status := self resolverStatus. [ status = ResolverBusy and: [ millisecondsLeft := deadline isLarge ifTrue: [ (deadline - Time primUTCMicrosecondClock) // 1000 ] ifFalse: [ deadline - Time millisecondClockValue ]. millisecondsLeft > 0 ] ] whileTrue: [ "wait for resolver to be available" ResolverSemaphore waitTimeoutMSecs: millisecondsLeft. status := self resolverStatus ]. status = ResolverReady ifTrue: [ ^true ]. status = ResolverBusy ifTrue: [ self primAbortLookup ]. ^false ! ! !NetNameResolver class methodsFor: 'private' stamp: 'ul 10/9/2015 22:20' prior: 50616364! waitForResolverReadyUntil: deadline "Wait until deadline for the resolver to be ready to accept a new request. Return true if the resolver is not busy, false if the network is not initialized or the resolver has not become free within the given time period." | status millisecondsLeft | (status := self resolverStatus) = ResolverUninitialized ifTrue: [ ^false ]. [ status = ResolverBusy and: [ millisecondsLeft := deadline isLarge ifTrue: [ (deadline - Time primUTCMicrosecondClock) // 1000 ] ifFalse: [ deadline - Time millisecondClockValue ]. millisecondsLeft > 0 ] ] whileTrue: [ "wait for resolver to be available" ResolverSemaphore waitTimeoutMSecs: millisecondsLeft. status := self resolverStatus ]. ^status ~= ResolverBusy! ! !UUIDGenerator class methodsFor: 'instance creation' stamp: 'topa 10/21/2015 20:16:02' prior: 31605500! default ^ Default ifNil: [Default := self new] ! ! !UUIDGenerator class methodsFor: 'class initialization' stamp: 'topa 10/21/2015 20:11:17' prior: 31605239! initialize TheRandom := Random new. TheSemaphore := Semaphore forMutualExclusion. Smalltalk addToStartUpList: self! ! !UUIDGenerator class methodsFor: 'class initialization' stamp: 'topa 10/21/2015 20:16:32'! resetDefault Default := nil.! ! !UUIDGenerator class methodsFor: 'class initialization' stamp: 'topa 10/21/2015 20:11:28' prior: 31605387! startUp "Reseed the random" TheSemaphore critical: [TheRandom seed: nil].! ! !UUIDGenerator methodsFor: 'instance creation' stamp: 'topa 10/21/2015 20:13:35'! fillRandomly: aUUID TheSemaphore critical: [ TheRandom nextBytes: 16 "128 bit" into: aUUID startingAt: 1].! ! !UUIDGenerator methodsFor: 'instance creation' stamp: 'topa 10/21/2015 20:15:12' prior: 31600116! generateBytes: aUUID forVersion: aVersion | versionID fixedValue | aVersion = 4 ifFalse: [^ self error: 'Unsupported version']. self fillRandomly: aUUID. versionID := ((aUUID at: 7) bitAnd: 16r0F) bitOr: 16r40. "Version 4" fixedValue := ((aUUID at: 9) bitAnd: 16r3F) bitOr: 16r80. "Fixed 8..b value" aUUID at: 7 put: versionID; at: 9 put: fixedValue.! ! !String methodsFor: '*network-uuid' stamp: 'topa 10/19/2015 22:45:24' prior: 22329211! asAlphaNumeric: totalSize extraChars: additionallyAllowed mergeUID: minimalSizeOfRandomPart "Generates a String with unique identifier ( UID ) qualities, the difference to a UUID is that its beginning is derived from the receiver, so that it has a meaning for a human reader. Answers a String of totalSize, which consists of 3 parts 1.part: the beginning of the receiver only consisting of a-z, A-Z, 0-9 and extraChars in Collection additionallyAllowed ( which can be nil ) 2.part: a single _ 3.part: a ( random ) UID of size >= minimalSizeOfRandomPart consisting of a-z, A-Z, 0-9 Starting letters are capitalized. TotalSize must be at least 1. Exactly 1 occurrence of $_ is guaranteed ( unless additionallyAllowed includes $_ ). The random part has even for small sizes good UID qualitites for many practical purposes. If only lower- or uppercase letters are demanded, simply convert the answer with say #asLowercase. The probability of a duplicate will rise only moderately ( see below ). Example: size of random part = 10 in n generated UIDs the chance p of having non-unique UIDs is n = 10000 -> p < 1e-10 if answer is reduced to lowerCase: p < 1.4 e-8 n = 100000 -> p < 1e-8 at the bottom is a snippet for your own calculations Note: the calculated propabilites are theoretical, for the actually used random generator they may be much worse" | stream out sizeOfFirstPart index ascii ch skip array random | totalSize > minimalSizeOfRandomPart ifFalse: [ self errorOutOfBounds ]. stream := ReadStream on: self. out := WriteStream on: ( String new: totalSize ). index := 0. skip := true. sizeOfFirstPart := totalSize - minimalSizeOfRandomPart - 1. [ stream atEnd or: [ index >= sizeOfFirstPart ]] whileFalse: [ ((( ascii := ( ch := stream next ) asciiValue ) >= 65 and: [ ascii <= 90 ]) or: [ ( ascii >= 97 and: [ ascii <= 122 ]) or: [ ch isDigit or: [ additionallyAllowed notNil and: [ additionallyAllowed includes: ch ]]]]) ifTrue: [ skip ifTrue: [ out nextPut: ch asUppercase ] ifFalse: [ out nextPut: ch ]. index := index + 1. skip := false ] ifFalse: [ skip := true ]]. out nextPut: $_. array := Array new: 62. 1 to: 26 do: [ :i | array at: i put: ( i + 64 ) asCharacter. array at: i + 26 put: ( i + 96 ) asCharacter ]. 53 to: 62 do: [ :i | array at: i put: ( i - 5 ) asCharacter ]. random := ThreadSafeRandom value. totalSize - index - 1 timesRepeat: [ out nextPut: ( array atRandom: random )]. ^out contents " calculation of probability p for failure of uniqueness in n UIDs Note: if answer will be converted to upper or lower case replace 62 with 36 | n i p all | all := 62 raisedTo: sizeOfRandomPart. i := 1. p := 0.0 . n := 10000. [ i <= n ] whileTrue: [ p := p + (( i - 1 ) / all ). i := i + 1 ]. p approximation formula: n squared / ( 62.0 raisedTo: sizeOfRandomPart ) / 2 " "'Crop SketchMorphs and Grab Screen Rect to JPG' asAlphaNumeric: 31 extraChars: nil mergeUID: 10 'CropSketchMorphsAndG_iOw94jquN6' 'Monticello' asAlphaNumeric: 31 extraChars: nil mergeUID: 10 'Monticello_kp6aV2l0IZK9uBULGOeG' 'version-', ( '1.1.2' replaceAll: $. with: $- ) asAlphaNumeric: 31 extraChars: #( $- ) mergeUID: 10 'Version-1-1-2_kuz2tMg2xX9iRLDVR'" ! ! !SocketAddress methodsFor: 'printing' stamp: 'dtl 11/7/2015 15:50' prior: 66863547! printOn: aStream [aStream nextPutAll: self hostNumber; nextPut: $(; nextPutAll: self hostName; nextPut: $); nextPut: $,; nextPutAll: self serviceNumber; nextPut: $(; nextPutAll: self serviceName; nextPut: $)] on: Error "e.g. inspector on address from a previous session" do: [aStream nextPutAll: 'an invalid '; nextPutAll: self class name; nextPut: Character space. ^super printOn: aStream]! ! !UUID methodsFor: 'initalize-release' stamp: 'topa 10/19/2015 22:46:41' prior: 26311499! initialize self makeUUID.! ! !UUID methodsFor: 'as yet unclassified' stamp: 'topa 10/19/2015 22:46:23'! makeUUID UUIDGenerator default generateBytes: self forVersion: 4.! ! !UUID methodsFor: 'system primitives' stamp: 'ul 10/24/2015 21:02' prior: 26311862! primMakeUUID ^nil! ! !UUID methodsFor: 'accessing' stamp: 'ul 10/24/2015 20:59'! variant ^(self at: 9) bitShift: -6! ! !UUID methodsFor: 'accessing' stamp: 'ul 10/24/2015 20:58'! version ^(self at: 7) bitShift: -4! ! UUIDGenerator removeSelector: #setupRandom! UUIDGenerator removeSelector: #semaphoreForGenerator:! UUIDGenerator removeSelector: #semaphoreForGenerator! UUIDGenerator removeSelector: #randomGenerator:! UUIDGenerator removeSelector: #randomGenerator! UUIDGenerator removeSelector: #randomCounter:! UUIDGenerator removeSelector: #randomCounter! UUIDGenerator removeSelector: #placeFields:! UUIDGenerator removeSelector: #makeUnixSeed! UUIDGenerator removeSelector: #makeSeedFromSound! UUIDGenerator removeSelector: #makeSeed! UUIDGenerator removeSelector: #initialize! UUIDGenerator removeSelector: #generateRandomBitsOfLength:! UUIDGenerator removeSelector: #generateOneOrZero! UUIDGenerator removeSelector: #generateFieldsVersion4! UUIDGenerator class removeSelector: #generateDefault! "Network"! !ByteArrayTest methodsFor: 'testing - platform independent access' stamp: 'ul 9/27/2015 22:40' prior: 34108378! testPlatformIndepentendIntegerAccessorsAtBitBorders #( shortAt:put:bigEndian: shortAt:bigEndian: false 16 longAt:put:bigEndian: longAt:bigEndian: false 32 long64At:put:bigEndian: long64At:bigEndian: false 64 unsignedShortAt:put:bigEndian: unsignedShortAt:bigEndian: true 16 unsignedLongAt:put:bigEndian: unsignedLongAt:bigEndian: true 32 unsignedLong64At:put:bigEndian: unsignedLong64At:bigEndian: true 64 ) groupsDo: [ :setter :getter :unsigned :storageBits | self verifyPlatformIndepentendIntegerAccessorsAtBitBordersSetter: setter getter: getter unsigned: unsigned storageBits: storageBits ]! ! !ByteArrayTest methodsFor: 'testing - platform independent access' stamp: 'ul 9/27/2015 22:40' prior: 34109047! testPlatformIndepentendIntegerAccessorsWithRandomValues | random | random := Random seed: 36rSqueak. #( shortAt:put:bigEndian: shortAt:bigEndian: false 16 longAt:put:bigEndian: longAt:bigEndian: false 32 long64At:put:bigEndian: long64At:bigEndian: false 64 unsignedShortAt:put:bigEndian: unsignedShortAt:bigEndian: true 16 unsignedLongAt:put:bigEndian: unsignedLongAt:bigEndian: true 32 unsignedLong64At:put:bigEndian: unsignedLong64At:bigEndian: true 64 ) groupsDo: [ :setter :getter :unsigned :storageBits | self verifyPlatformIndepentendIntegerAccessorsWithRandomValuesSetter: setter getter: getter unsigned: unsigned storageBits: storageBits random: random ]! ! !IntegerArrayTest methodsFor: 'tests' stamp: 'nice 10/31/2015 18:33' prior: 26410007! testStoreSmallInteger "Any SmallInteger may be stored in an IntegerArray in a 32bits VM. Not so true for a 64bits spur VM though..." | ia val | ia := IntegerArray new: 1. val := Smalltalk wordSize = 8 ifTrue: [1 << 31 - 1] ifFalse: [SmallInteger maxVal]. ia at: 1 put: val. self assert: ((ia at: 1) = val). val := Smalltalk wordSize = 8 ifTrue: [(1 << 31) negated] ifFalse: [SmallInteger minVal]. ia at: 1 put: val. self assert: ((ia at: 1) = val) ! ! !WideStringTest methodsFor: 'tests - converting' stamp: 'ul 9/28/2015 16:46' prior: 59295524! testAsInteger #( '' nil nil nil '1796exportFixes-tkMX' 1796 1796 1796 'donald' nil nil nil 'abc234def567' 234 234 234 '-94' -94 -94 94 'foo-bar-92' -92 -92 92 ) groupsDo: [ :inputString :asIntegerExpectedValue :asSignedIntegerExpectedValue :asUnsignedIntegerExpectedValue | | wideString | wideString := inputString asWideString. self assert: asIntegerExpectedValue equals: wideString asInteger; assert: asSignedIntegerExpectedValue equals: wideString asSignedInteger; assert: asUnsignedIntegerExpectedValue equals: wideString asUnsignedInteger ]! ! !WideStringTest methodsFor: 'tests - converting' stamp: 'ul 10/10/2015 15:19'! testAsIntegerSigned #( '' nil nil '1796exportFixes-tkMX' 1796 1796 'donald' nil nil 'abc234def567' 234 234 '-94' -94 94 'foo-bar-92' -92 92 '1234567890' 1234567890 1234567890 '--1234567890--' -1234567890 1234567890 '--1234567890123456789012345678901234567890--' -1234567890123456789012345678901234567890 1234567890123456789012345678901234567890 ) groupsDo: [ :inputString :expectedSignedValue :expectedUnsignedValue | self assert: expectedSignedValue equals: (inputString asIntegerSigned: true); assert: expectedUnsignedValue equals: (inputString asIntegerSigned: false) ]! ! !WideStringTest methodsFor: 'tests - converting' stamp: 'ul 10/10/2015 15:35'! testAsIntegerSignedUsingRandomNumbers | random digitCharactersByValue | random := Random seed: 36rSqueak. digitCharactersByValue := (((0 to: 65535) collect: #asCharacter as: String) select: #isDigit) groupBy: #digitValue. 1 to: 100 do: [ :digitLength | 50 timesRepeat: [ | number inputString | number := ((2 atRandom: random) = 1 ifTrue: [ LargePositiveInteger ] ifFalse: [ LargeNegativeInteger ]) new: digitLength. 1 to: digitLength do: [ :index | number at: index put: (256 atRandom: random) - 1 ]. number := number normalize. inputString := number asString asWideString. inputString replace: [ :each | each == $- ifTrue: [ each ] ifFalse: [ (digitCharactersByValue at: each digitValue) atRandom: random ] ]. self assert: number equals: (inputString asIntegerSigned: true); assert: number abs equals: (inputString asIntegerSigned: false) ] ]! ! !SetWithNilTest methodsFor: 'tests' stamp: 'ul 11/2/2015 04:50' prior: 84837624! runSetWithNilTestOf: newSet "Run the common tests for the given set class" | class collectClass | class := newSet value class. collectClass := class == WeakSet ifTrue: [ WeakSet ] ifFalse: [ Set ]. self assert: (newSet value add: nil; yourself) size = 1. self assert: (newSet value addAll: #(nil nil nil); yourself) size = 1. self assert: ((newSet value add: nil; yourself) includes: nil). self assert: ((newSet value addAll: #(nil nil nil); yourself) includes: nil). self assert: (newSet value add: nil; yourself) anyOne = nil. self assert: ((newSet value add: nil; yourself) remove: nil) == nil. self assert: ((newSet value add: nil; yourself) remove: nil; yourself) isEmpty. self assert: (newSet value addAll: #(1 nil foo); yourself) size = 3. self assert: ((newSet value addAll: #(1 nil foo); yourself) remove: nil; yourself) size = 2. self assert: ((newSet value add: nil; yourself) collect:[:x| x]) = (collectClass with: nil). self assert: ((newSet value add: nil; yourself) collect:[:x| x] as: Array) = #(nil). self deny: ((newSet value) includes: nil). self deny: ((newSet value add: 3; yourself) includes: nil). self deny: ((newSet value add: 3; remove: 3; yourself) includes: nil). ! ! !TextTest methodsFor: 'tests' stamp: 'mt 11/12/2015 09:59'! test01ColorAt | text | text := Text fromString: 'Hello'. self assert: Color black equals: (text colorAt: 1). self should: [text colorAt: 1 ifNone: [Error signal]] raise: Error. text := Text string: 'Hello' attribute: (TextColor color: Color gray). self assert: Color gray equals: (text colorAt: 1). ! ! !StringTest methodsFor: 'tests - converting' stamp: 'ul 9/28/2015 16:51' prior: 59876331! testAsInteger #( '' nil nil nil '1796exportFixes-tkMX' 1796 1796 1796 'donald' nil nil nil 'abc234def567' 234 234 234 '-94' -94 -94 94 'foo-bar-92' -92 -92 92 ) groupsDo: [ :inputString :asIntegerExpectedValue :asSignedIntegerExpectedValue :asUnsignedIntegerExpectedValue | self assert: asIntegerExpectedValue equals: inputString asInteger; assert: asSignedIntegerExpectedValue equals: inputString asSignedInteger; assert: asUnsignedIntegerExpectedValue equals: inputString asUnsignedInteger ]! ! !StringTest methodsFor: 'tests - converting' stamp: 'ul 10/10/2015 15:19'! testAsIntegerSigned #( '' nil nil '1796exportFixes-tkMX' 1796 1796 'donald' nil nil 'abc234def567' 234 234 '-94' -94 94 'foo-bar-92' -92 92 '1234567890' 1234567890 1234567890 '--1234567890--' -1234567890 1234567890 '--1234567890123456789012345678901234567890--' -1234567890123456789012345678901234567890 1234567890123456789012345678901234567890 ) groupsDo: [ :inputString :expectedSignedValue :expectedUnsignedValue | self assert: expectedSignedValue equals: (inputString asIntegerSigned: true); assert: expectedUnsignedValue equals: (inputString asIntegerSigned: false) ]! ! !StringTest methodsFor: 'tests - converting' stamp: 'ul 10/10/2015 15:34'! testAsIntegerSignedUsingRandomNumbers | random | random := Random seed: 36rSqueak. 1 to: 100 do: [ :digitLength | 50 timesRepeat: [ | number inputString | number := ((2 atRandom: random) = 1 ifTrue: [ LargePositiveInteger ] ifFalse: [ LargeNegativeInteger ]) new: digitLength. 1 to: digitLength do: [ :index | number at: index put: (256 atRandom: random) - 1 ]. number := number normalize. inputString := number asString. self assert: number equals: (inputString asIntegerSigned: true); assert: number abs equals: (inputString asIntegerSigned: false) ] ]! ! !StringTest methodsFor: 'tests - finding' stamp: 'nice 11/11/2015 02:08' prior: 59897294! testFindSubstringInStartingAtMatchTable | str tbl cm | str := 'hello '. tbl := String classPool at: #CaseSensitiveOrder. self assert: (str findSubstring: ' ' in: str startingAt: 1 matchTable: tbl) = 6. self assert: (str findSubstring: 'q' in: str startingAt: 1 matchTable: tbl) = 0. self assert: (str findSubstring: 'q' in: str startingAt: -1 matchTable: tbl) = 0. self assert: (str findSubstring: ' ' in: str startingAt: -1 matchTable: tbl) = 6. "The next test ensures that the fallback code works just as well" cm := (ByteString >> #findSubstring:in:startingAt:matchTable:) withoutPrimitive. self assert: (cm valueWithReceiver: str arguments: {' '. str. 1. tbl}) = 6. self assert: (cm valueWithReceiver: str arguments: {'q'. str. 1. tbl}) = 0. self assert: (cm valueWithReceiver: str arguments: {'q'. str. -1. tbl}) = 0. self assert: (cm valueWithReceiver: str arguments: {' '. str. -1. tbl}) = 6. ! ! ReadStreamTest removeSelector: #testOldBackOnPosition1! ReadStreamTest removeSelector: #testOldBack! "CollectionsTests"! !EncoderForV3 class methodsFor: 'compiled method support' stamp: 'nice 10/31/2015 17:59' prior: 19064489! markerOrNilFor: aMethod "If aMethod is a marker method, answer the symbol used to mark it. Otherwise answer nil. What is a marker method? It is method with body like 'self subclassResponsibility' or '^ self subclassResponsibility' used to indicate ('mark') a special property. Marker methods compile to two bytecode forms, this: self send: pop returnSelf or this: self send: returnTop" | expectedHeaderPlusLliteralSize e | expectedHeaderPlusLliteralSize := Smalltalk wordSize * 4. ^(((e := aMethod endPC - expectedHeaderPlusLliteralSize) = 3 or: [e = 4]) and: [aMethod numLiterals = 3 and: [(aMethod at: expectedHeaderPlusLliteralSize + 1) = 16r70 "push self" and: [(aMethod at: expectedHeaderPlusLliteralSize + 2) = 16rD0]]]) "send " ifTrue: [aMethod literalAt: 1]! ! "Compiler"! !Environment methodsFor: 'emulating' stamp: 'eem 4/14/2015 17:21'! collect: aBlock ^ declarations collect: aBlock! ! "Environments"! !Random methodsFor: 'accessing' stamp: 'ul 10/20/2015 07:33'! nextBytes: anInteger into: aBytesObject startingAt: startIndex "Fill aBytesObject, an object with indexable byte fields, with anInteger number of random bytes starting from startIndex. Assume that MTw is at least 8." | randomValue remainingBits index endIndex | randomValue := remainingBits := 0. index := startIndex. endIndex := startIndex + anInteger - 1. [ index <= endIndex ] whileTrue: [ remainingBits >= 8 ifTrue: [ aBytesObject basicAt: index put: (randomValue bitAnd: 16rFF). randomValue := randomValue bitShift: -8. remainingBits := remainingBits - 8. index := index + 1 ] ifFalse: [ remainingBits = 0 ifTrue: [ randomValue := self nextValue ] ifFalse: [ | newRandomValue | newRandomValue := self nextValue. aBytesObject basicAt: index put: (randomValue bitShift: 8 - remainingBits) + (newRandomValue bitAnd: (1 bitShift: 8 - remainingBits) - 1). randomValue := newRandomValue bitShift: 0 - remainingBits. index := index + 1 ]. remainingBits := MTw - remainingBits ] ]! ! !Random methodsFor: 'accessing' stamp: 'ul 10/20/2015 07:25' prior: 63565423! nextLargeInt: anInteger "Answer a random integer value from the interval [1, anInteger]. This method works for arbitrarily large integers." | byteCount bigRandom result firstDigit | byteCount := anInteger digitLength + 4. "Extend the space with at least 32 bits for a fairer distribution." bigRandom := LargePositiveInteger new: byteCount. self nextBytes: byteCount into: bigRandom startingAt: 1. result := anInteger * bigRandom bitShift: -8 * byteCount. "Avoid using LargeInteger arithmetic for +1 in most cases." result isLarge ifFalse: [ ^result + 1 ]. (firstDigit := result digitAt: 1) = 255 ifTrue: [ ^result + 1 ]. result digitAt: 1 put: firstDigit + 1. ^result ! ! !Duration class methodsFor: 'squeak protocol' stamp: 'ul 10/10/2015 16:03' prior: 84198386! days: days hours: hours minutes: minutes seconds: seconds nanoSeconds: nanos ^self seconds: seconds + (minutes * SecondsInMinute) + (hours * SecondsInHour) + (days * SecondsInDay) nanoSeconds: nanos ! ! !Duration methodsFor: 'squeak protocol' stamp: 'ul 10/10/2015 00:35' prior: 84191526! asMilliSeconds nanos = 0 ifTrue: [ ^seconds * 1000 ]. ^nanos // 1000000 + (seconds * 1000)! ! !Duration methodsFor: 'squeak protocol' stamp: 'ul 10/10/2015 00:35' prior: 84191829! asNanoSeconds ^seconds * NanosInSecond + nanos! ! !Behavior methodsFor: 'system startup' stamp: 'nice 11/13/2015 00:22' prior: 29548559! startUpFrom: endiannessHasToBeFixed "Override this when a per-instance startUp message needs to be sent. For example, to correct the order of 16-bit non-pointer data when it came from a different endian machine." ^ nil! ! !Process methodsFor: 'changing suspended state' stamp: 'eem 11/4/2015 12:02:50' prior: 20164264! restartTopWith: method "Rollback top context and replace with new method. Assumes self is suspended" method isQuick ifTrue: [self popTo: suspendedContext sender] ifFalse: [suspendedContext method frameSize >= method frameSize ifTrue: [suspendedContext privRefreshWith: method] ifFalse: [self assert: suspendedContext isExecutingBlock not. suspendedContext := MethodContext sender: suspendedContext sender receiver: suspendedContext receiver method: method arguments: ((1 to: method numArgs) collect: [:i| suspendedContext tempAt: i])]]. ! ! !LargePositiveInteger methodsFor: 'objects from disk' stamp: 'nice 10/31/2015 19:19'! readDataFrom: aDataStream size: varsOnDisk ^(super readDataFrom: aDataStream size: varsOnDisk) normalize ! ! !Float methodsFor: 'converting' stamp: 'ul 10/10/2015 00:39' prior: 25001635! adaptToFraction: rcvr andCompare: selector "If I am involved in comparison with a Fraction, convert myself to a Fraction. This way, no bit is lost and comparison is exact." self isFinite ifFalse: [ selector == #= ifTrue: [ ^false ]. selector == #~= ifTrue: [ ^true ]. (selector == #< or: [ selector == #'<=' ]) ifTrue: [ ^self >= 0.0]. (selector == #> or: [ selector == #'>=' ]) ifTrue: [ ^0.0 >= self ]. ^self error: 'unknow comparison selector' ]. "Try to avoid asTrueFraction because it can cost" rcvr isAnExactFloat ifTrue: [^rcvr asExactFloat perform: selector with: self]. selector == #= ifTrue: [^false]. selector == #~= ifTrue: [^true]. ^ rcvr perform: selector with: self asTrueFraction! ! !Float methodsFor: 'converting' stamp: 'ul 10/10/2015 00:49' prior: 25003529! adaptToInteger: rcvr andCompare: selector "If I am involved in comparison with an Integer, convert myself to a Fraction. This way, no bit is lost and comparison is exact." self isFinite ifFalse: [ selector == #= ifTrue: [ ^false ]. selector == #~= ifTrue: [ ^true ]. (selector == #< or: [ selector == #'<=' ]) ifTrue: [ ^self >= 0.0 ]. (selector == #> or: [ selector == #'>=' ]) ifTrue: [ ^0.0 >= self ]. ^self error: 'unknow comparison selector']. "Try to avoid asTrueFraction because it can cost" selector == #= ifTrue: [ self fractionPart = 0.0 ifFalse: [^false]]. selector == #~= ifTrue: [ self fractionPart = 0.0 ifFalse: [^true]]. rcvr isAnExactFloat ifTrue: [^rcvr asExactFloat perform: selector with: self]. selector == #= ifTrue: [^false]. selector == #~= ifTrue: [^true]. ^ rcvr perform: selector with: self asTrueFraction! ! !Float methodsFor: 'converting' stamp: 'ul 10/10/2015 00:50' prior: 25005380! adaptToScaledDecimal: rcvr andCompare: selector "If I am involved in comparison with a scaled Decimal, convert myself to a Fraction. This way, no bit is lost and comparison is exact." self isFinite ifFalse: [ selector == #= ifTrue: [^false]. selector == #~= ifTrue: [^true]. (selector == #< or: [ selector == #'<=' ]) ifTrue: [ ^self >= 0.0 ]. (selector == #> or: [ selector == #'>=' ]) ifTrue: [ ^0.0 >= self ]. ^self error: 'unknow comparison selector' ]. "Try to avoid asTrueFraction because it can cost" rcvr isAnExactFloat ifTrue: [^rcvr asExactFloat perform: selector with: self]. selector == #= ifTrue: [^false]. selector == #~= ifTrue: [^true]. ^ rcvr perform: selector with: self asTrueFraction! ! !Object methodsFor: 'error handling' stamp: 'topa 10/8/2015 20:44'! deprecated "Warn that the sending method has been deprecated." Deprecation maybeSignalDeprecationFor: thisContext sender message: '' explanation: ''! ! !Object methodsFor: 'drag and drop' stamp: 'mt 11/4/2015 14:09'! dragStartedFor: anItemMorph transferMorph: aTransferMorph "Give the model a chance to respond to a started drag operation. Could be used to give a notification or play an animation. Do nothing by default."! ! !Object methodsFor: 'tracing' stamp: 'ul 10/10/2015 22:09' prior: 66751793! inboundPointersExcluding: objectsToExclude "Answer a list of all objects in the system that hold a reference to me, excluding those in the collection of objectsToExclude." | pointers object objectsToAlwaysExclude | Smalltalk garbageCollect. pointers := OrderedCollection new. self systemNavigation allObjectsOrNil ifNotNil: [ :allObjects | objectsToAlwaysExclude := { allObjects. thisContext. thisContext sender. thisContext sender sender. objectsToExclude. }. 1 to: allObjects size do: [ :index | object := allObjects at: index. (object pointsTo: self) ifTrue: [ ((objectsToAlwaysExclude identityIncludes: object) or: [ objectsToExclude identityIncludes: object ]) ifFalse: [ pointers add: object ] ] ]. ^pointers ]. "SystemNavigation >> #allObjectsDo: is inlined here with a slight modification: the marker object is pointers. This gives better results, because the value of pointers, it's inner objects and transient method contexts will not be iterated over." object := self someObject. [ object == pointers ] whileFalse: [ (object isInMemory and: [ object pointsTo: self ]) ifTrue: [ pointers add: object ]. object := object nextObject ]. objectsToAlwaysExclude := { thisContext. thisContext sender. thisContext sender sender. objectsToExclude. }. ^pointers removeAllSuchThat: [ :ea | (objectsToAlwaysExclude identityIncludes: ea) or: [ objectsToExclude identityIncludes: ea ] ]! ! !SmallInteger methodsFor: 'objects from disk' stamp: 'nice 11/12/2015 17:02'! objectForDataStream: refStrm "In a 64-bit Spur VM, we may have to fake 32-bit SmallIntegers for compatibility." | large | self > 16r3FFFFFFF ifTrue: [ large := LargePositiveInteger new: self digitLength neg: false. 1 to: self digitLength do: [:i | large digitAt: i put: (self digitAt: i)]. ^large]. self < -16r40000000 ifTrue: [ large := LargeNegativeInteger new: self digitLength neg: true. 1 to: self digitLength do: [:i | large digitAt: i put: (self digitAt: i)]. ^large]. ^ self! ! !InstructionPrinter methodsFor: 'instruction decoding' stamp: 'eem 4/10/2015 11:06' prior: 66932203! callPrimitive: index "Print the callPrimitive bytecode." self print: 'callPrimitive: ' , index printString! ! !BlockClosure methodsFor: 'comparing' stamp: 'nice 11/9/2015 20:43'! = aClosure self == aClosure ifTrue: [^true]. aClosure class = self class ifFalse: [^false]. (self method == aClosure method and: [startpc = aClosure startpc and: [self isClean]]) ifTrue: [^true]. ^outerContext = aClosure outerContext and: [startpc = aClosure startpc]! ! !BlockClosure methodsFor: 'comparing' stamp: 'nice 11/9/2015 20:41'! hash ^(self method hash + startpc hash) hashMultiply! ! !CompiledMethod methodsFor: 'converting' stamp: 'nice 11/11/2015 02:07'! withoutPrimitive "Answers a copy of self without primitive call. That may serve for example for testing fallback code." | copy skipPrimitiveCall | self primitive = 0 ifTrue: [^self]. skipPrimitiveCall := 3. copy := CompiledMethod newMethod: self basicSize - self initialPC + 1 - skipPrimitiveCall header: (self header bitClear: 16r10000). 1 to: self numLiterals do: [:index| copy literalAt: index put: (self literalAt: index)]. self initialPC + skipPrimitiveCall to: self size do: [:index | copy at: index - skipPrimitiveCall put: (self at: index)]. copy postCopy. ^copy! ! !Deprecation class methodsFor: 'utilities' stamp: 'topa 10/8/2015 20:43' prior: 34116376! maybeSignalDeprecationFor: context message: messageString explanation: explanationString self showDeprecationWarnings ifTrue: [ | message | message := context method reference, ' has been deprecated', messageString, '.'. explanationString ifNotEmpty: [message := message, ' ', explanationString]. self signal: message].! ! Object removeSelector: #dragTransferType! "Kernel"! Object subclass: #MCMcmUpdater instanceVariableNames: 'repository updateMapName lastUpdateMap' classVariableNames: 'DefaultUpdateMap DefaultUpdateURL Registry SkipPackages UpdateFromServerAtStartup UpdateMissingPackages Updaters' poolDictionaries: '' category: 'MonticelloConfigurations'! !MCMcmUpdater commentStamp: 'dtl 10/12/2015 19:45' prior: 34120389! MCMcmUpdater provides utility methods for updating Monticello packages from Monticello configurations. When Monticello configurations are stored in a repository (or repositories), MCMcmUpdater acts as an update stream. It first ensures that each configuration map has been loaded in sequence, then updates the last configuration map to the most recent version for each specified package, and finally loads these versions to produce a fully updated configuration. Currently if a set of packages are unloaded from the image, using this class to reload them may cause problems, depending on what dependencies those classes have. Success is not assured. Removing packages via SmalltalkImage>>unloadAllKnownPackages will be successful, it flags the packages removed so that they are not loaded by this utility. If you wish to not have MCMcmUpdater update packages, there are two ways to handle this: 1) To have MCMcmUpdater not update any packages not currently in the image set the UpdateMissingPackages preference to false: MCMcmUpdater updateMissingPackages: false Note that any new packages added to the repositories will not be picked up when this is turned off. 2) To have MCMcmUpdater not update a specific package, evaluate MCMcmUpdater disableUpdatesOfPackage: Class Variables definitions: DefaultUpdateURL - String: the URL that will be checked by default for updates. This would be set for a common standard location to check. Repository - A registry of known MCMcmUpdater instances identified by repository URL and update map name. SkipPackages - Set of Strings: names of packages to not update in MCMcmUpdater (empty by default). UpdateMissingPackages - Boolean: if true (default), new packages in the update config map will be loaded unless they are in SkipPackages. If false, packages not currently loaded in the image will not be loaded by MCMcmUpdater. (This can be dangerous if packages are split - use at your own risk). Instance Variables: updateMapName - Base name of the files used for this updater, typically a name such as 'update' or 'update.spur'. repository - URL of the repository in which the update maps are located. lastUpdateMap - Dictionary of Integer: version number of the last loaded update map per repository. Keeps track of the last configuration map, so that the utility will not have to run through the full history in the repositories each time you ask to update. ! !MCMcmUpdater class methodsFor: 'class initialization' stamp: 'dtl 10/12/2015 18:47'! clearRegistry "Save the current default updater, clear the registry, and re-register the current updater. This is intended for cleaning up an image prior to public release. Assumes that the current updater is the one intended for ongoing use in this image." "MCMcmUpdater clearRegistry" | current | current := self default. Registry := nil. current register. ^Registry! ! !MCMcmUpdater class methodsFor: 'instance creation' stamp: 'dtl 10/11/2015 19:45' prior: 34122822! default "The default instance for system updates. Uses a default repository and update map name that may be set as preferences." ^self updateMapNamed: self updateMapName repository: self defaultUpdateURL ! ! !MCMcmUpdater class methodsFor: 'registry' stamp: 'dtl 10/11/2015 19:04'! forRepository: repository updateMap: basename "Answer the requested updater from the repository, or nil of not found" "MCMcmUpdater forRepository: 'http://source.squeak.org/trunk' updateMap: 'update'" "MCMcmUpdater forRepository: 'foo' updateMap: 'bar'" ^ ((Registry ifNil: [Registry := Dictionary new]) at: repository ifAbsent: [^nil]) at: basename ifAbsent: [^nil]! ! !MCMcmUpdater class methodsFor: 'class initialization' stamp: 'dtl 10/12/2015 19:34' prior: 34123200! initialize "MCMcmUpdater initialize" self flag: #TODO. "remove Updaters class var after transition to Registry" DefaultUpdateURL ifNil:[ DefaultUpdateURL := MCHttpRepository trunkUrlString. DefaultUpdateMap := self defaultBaseName. ]. Registry ifNil: [ "Migrate from Updaters class var to Registry" "Set new repository ivar in all existing instances" Updaters keysAndValuesDo: [ :k :v | v repository: k]. "Populate the new registry" Updaters do: [:e | e register]. "Set the default update map name to its prior value" self updateMapName: ((Updaters at: MCMcmUpdater defaultUpdateURL) updateMapName) ]. ! ! !MCMcmUpdater class methodsFor: 'registry' stamp: 'dtl 10/13/2015 19:36'! registry "Private - unit test support" ^Registry! ! !MCMcmUpdater class methodsFor: 'registry' stamp: 'dtl 10/13/2015 19:36'! registry: registry "Private - unit test support" Registry := registry! ! !MCMcmUpdater class methodsFor: 'instance creation' stamp: 'dtl 10/11/2015 18:17'! repository: url updateMap: baseName "Answer a new instance with empty last update map, not yet registered" ^ self repository: url updateMap: baseName lastUpdateMap: Dictionary new! ! !MCMcmUpdater class methodsFor: 'instance creation' stamp: 'dtl 10/11/2015 18:17'! repository: url updateMap: baseName lastUpdateMap: dictionary "Answer a new instance, not yet registered" ^ self new repository: url; updateMapName: baseName; lastUpdateMap: dictionary! ! !MCMcmUpdater class methodsFor: 'updating' stamp: 'dtl 10/12/2015 19:23' prior: 34123982! updateFromRepository: updaterUrlKey baseName: baseName "Update using an MCMcmUpdater identified by updaterUrlKey, and using update map baseName" ^ (self updateMapNamed: baseName repository: updaterUrlKey) doUpdate! ! !MCMcmUpdater class methodsFor: 'updating' stamp: 'dtl 10/12/2015 19:23' prior: 60611547! updateFromServer "Update the image by loading all pending updates from the server." ^self default doUpdate ! ! !MCMcmUpdater class methodsFor: 'preferences' stamp: 'dtl 10/11/2015 19:09' prior: 34124314! updateMapName "The default update map name" ^DefaultUpdateMap ifNil:['']! ! !MCMcmUpdater class methodsFor: 'preferences' stamp: 'dtl 10/11/2015 19:10' prior: 34124586! updateMapName: mapName "The default update map name for the default updater." DefaultUpdateMap := mapName! ! !MCMcmUpdater class methodsFor: 'instance creation' stamp: 'dtl 10/12/2015 19:06' prior: 34125451! updateMapNamed: baseName repository: url "Answer an instance for the given repository URL with a base update name baseName, Register a new instance if not present in the registry." " | updater1 updater2 | updater1 := self updateMapNamed: 'BAR' repository: 'FOO'. updater2 := self updateMapNamed: 'BAZ' repository: 'FOO'. updater1 unregister. updater2 unregister. Registry" ^(self forRepository: url updateMap: baseName) ifNil: [ "register a new updater" (self repository: url updateMap: baseName) register]. ! ! !MCMcmUpdater methodsFor: 'updating' stamp: 'dtl 10/24/2015 11:47'! doUpdate "Update the image by loading all pending updates from the server. If this is the default updater for the system, update the system version when complete. Flush all caches. If a previous download failed this is often helpful" ^self doUpdate: true ! ! !MCMcmUpdater methodsFor: 'updating' stamp: 'dtl 10/25/2015 17:31'! doUpdate: interactive "Update the image by loading all pending updates from the server. If this is the default updater for the system, update the system version when complete. If interteractive use a modal notifier, otherwise only update the transcript. Flush all caches. If a previous download failed this is often helpful" | config | MCFileBasedRepository flushAllCaches. config := self updateFromRepositories: { self repository }. config ifNil: [ interactive ifTrue: [ ^self inform: 'Unable to retrieve updates from remote repository.' translated ]. Transcript cr; show: '========== Unable to retrieve updates from remote repository. ==========' translated; cr. ^ self ]. MCMcmUpdater default == self ifTrue: [ config setSystemVersion. interactive ifTrue: [ self inform: ('Update completed. Current update number: ' translated, SystemVersion current highestUpdate) ]. Transcript cr; show: '========== Update completed. Current update number ' translated; show: SystemVersion current highestUpdate; show: ' =========='; cr ] ifFalse: [ interactive ifTrue: [ self inform: 'Update completed.' ]. Transcript cr; show: '========== Update completed. ==========' translated; cr ] ! ! !MCMcmUpdater methodsFor: 'registry' stamp: 'dtl 10/11/2015 18:26'! isRegistered "True if this instance is registered. False if another instance with the same repository and updateNameName is registered." ^self == ((Registry at: repository ifAbsent: [^false]) at: updateMapName ifAbsent: [^false]). ! ! !MCMcmUpdater methodsFor: 'printing' stamp: 'dtl 10/11/2015 22:57'! printOn: aStream super printOn: aStream. aStream nextPutAll: ' on '''; nextPutAll: updateMapName asString; nextPutAll: ''' at '; nextPutAll: repository asString! ! !MCMcmUpdater methodsFor: 'registry' stamp: 'dtl 10/11/2015 19:18'! register "Register this instance, keyed by repository and update map name. Each update maintains its own lastUpdateMap. The registry permits multilple updaters to be maintained, with each updater keeping track of its own last update map." repository ifNil: [self error: 'repository is ', repository asString]. updateMapName ifNil: [self error: 'updateMapName is ', updateMapName asString]. updateMapName isEmpty ifTrue: [self error: 'updateMapName must be specified']. ((Registry ifNil: [Registry := Dictionary new]) at: repository ifAbsentPut: [Dictionary new]) at: updateMapName put: self ! ! !MCMcmUpdater methodsFor: 'accessing' stamp: 'dtl 10/11/2015 16:24'! repository "URL string of the repository for the update maps" ^ repository! ! !MCMcmUpdater methodsFor: 'accessing' stamp: 'dtl 10/11/2015 16:23'! repository: repositoryURLString repository := repositoryURLString! ! !MCMcmUpdater methodsFor: 'registry' stamp: 'dtl 10/12/2015 19:00'! unregister "If this instance is registered, remove it frorm the registry." self isRegistered ifTrue: [(Registry at: repository) removeKey: updateMapName. (Registry at: repository) isEmpty ifTrue: [Registry removeKey: repository]] ! ! MCMcmUpdater removeSelector: #updateFromDefaultRepository! MCMcmUpdater removeSelector: #updateFrom:! MCMcmUpdater class removeSelector: #updaters! MCMcmUpdater class removeSelector: #updateMapNamed:! MCMcmUpdater class removeSelector: #updateFromRepositories:using:baseName:! MCMcmUpdater class removeSelector: #updateFromDefaultRepository! MCMcmUpdater class removeSelector: #resetUpdaters! "MonticelloConfigurations"! Object subclass: #SecureHashAlgorithm instanceVariableNames: 'totalA totalB totalC totalD totalE totals' classVariableNames: 'K1 K2 K3 K4 TA TB TC TD TE TI' poolDictionaries: '' category: 'System-Digital Signatures'! !SecureHashAlgorithm commentStamp: '' prior: 31067417! This class implements the Secure Hash Algorithm (SHA) described in the U.S. government's Secure Hash Standard (SHS). This standard is described in FIPS PUB 180-1, "SECURE HASH STANDARD", April 17, 1995. The Secure Hash Algorithm is also described on p. 442 of 'Applied Cryptography: Protocols, Algorithms, and Source Code in C' by Bruce Scheier, Wiley, 1996. See the comment in class DigitalSignatureAlgorithm for details on its use. Implementation notes: The secure hash standard was created with 32-bit hardware in mind. All arithmetic in the hash computation must be done modulo 2^32. This implementation uses ThirtyTwoBitRegister objects to simulate hardware registers; this implementation is about six times faster than using LargePositiveIntegers (measured on a Macintosh G3 Powerbook). Implementing a primitive to process each 64-byte buffer would probably speed up the computation by a factor of 20 or more. ! !SecureHashAlgorithm class methodsFor: 'class initialization' stamp: 'ul 10/26/2015 02:11' prior: 31100711! initialize "SecureHashAlgorithm initialize" "For the curious, here's where these constants come from: #(2 3 5 10) collect: [:x | ((x sqrt / 4.0) * (2.0 raisedTo: 32)) truncated hex]" K1 := ThirtyTwoBitRegister fromInteger: 16r5A827999. K2 := ThirtyTwoBitRegister fromInteger: 16r6ED9EBA1. K3 := ThirtyTwoBitRegister fromInteger: 16r8F1BBCDC. K4 := ThirtyTwoBitRegister fromInteger: 16rCA62C1D6. TA := ThirtyTwoBitRegister fromInteger: 16r67452301. TB := ThirtyTwoBitRegister fromInteger: 16rEFCDAB89. TC := ThirtyTwoBitRegister fromInteger: 16r98BADCFE. TD := ThirtyTwoBitRegister fromInteger: 16r10325476. TE := ThirtyTwoBitRegister fromInteger: 16rC3D2E1F0. (TI := Bitmap new: 5) at: 1 put: 16r67452301; at: 2 put: 16rEFCDAB89; at: 3 put: 16r98BADCFE; at: 4 put: 16r10325476; at: 5 put: 16rC3D2E1F0! ! !SecureHashAlgorithm methodsFor: 'private' stamp: 'ul 10/27/2015 01:35' prior: 31082677! expandedBlock: aByteArray "Convert the given 64 byte buffer into 80 32-bit registers and answer the result." | out src | out := Array new: 80. src := 1. 1 to: 16 do: [:i | out at: i put: (ThirtyTwoBitRegister fromByteArray: aByteArray at: src). src := src + 4]. 17 to: 80 do: [:i | out at: i put: ( (out at: i - 3) copy bitXor: (out at: i - 8); bitXor: (out at: i - 14); bitXor: (out at: i - 16); leftRotateBy: 1) ]. ^ out ! ! !SecureHashAlgorithm methodsFor: 'private' stamp: 'ul 10/26/2015 02:20' prior: 31084645! finalHash "Concatenate the final totals to build the 160-bit integer result." "Details: If the primitives are supported, the results are in the totals array. Otherwise, they are in the instance variables totalA through totalE." | result | result := ByteArray new: 20. totals ifNil: [ "compute final hash when not using primitives" result unsignedShortAt: 1 put: totalE low bigEndian: false; unsignedShortAt: 3 put: totalE hi bigEndian: false; unsignedShortAt: 5 put: totalD low bigEndian: false; unsignedShortAt: 7 put: totalD hi bigEndian: false; unsignedShortAt: 9 put: totalC low bigEndian: false; unsignedShortAt: 11 put: totalC hi bigEndian: false; unsignedShortAt: 13 put: totalB low bigEndian: false; unsignedShortAt: 15 put: totalB hi bigEndian: false; unsignedShortAt: 17 put: totalA low bigEndian: false; unsignedShortAt: 19 put: totalA hi bigEndian: false ] ifNotNil: [ "compute final hash when using primitives" result unsignedLongAt: 1 put: (totals at: 5) bigEndian: false; unsignedLongAt: 5 put: (totals at: 4) bigEndian: false; unsignedLongAt: 9 put: (totals at: 3) bigEndian: false; unsignedLongAt: 13 put: (totals at: 2) bigEndian: false; unsignedLongAt: 17 put: (totals at: 1) bigEndian: false ]. ^(LargePositiveInteger new: result size) replaceFrom: 1 to: result size with: result startingAt: 1; normalize! ! !SecureHashAlgorithm methodsFor: 'private' stamp: 'ul 10/27/2015 01:30'! hashFunction: i of: x with: y with: z using: t1 and: t2 "Compute the hash function for the i-th step of the block hash loop. We number our steps 1-80, versus the 0-79 of the standard." "Details: There are four functions, one for each 20 iterations. The second and fourth are the same." t1 loadFrom: x. i <= 20 ifTrue: [ t2 loadFrom: x; bitInvert; bitAnd: z. ^t1 bitAnd: y; bitOr: t2 ]. i <= 40 ifTrue: [ ^t1 bitXor: y; bitXor: z ]. i <= 60 ifTrue: [ t2 loadFrom: x; bitOr: y; bitAnd: z. ^t1 bitAnd: y; bitOr: t2 ]. ^t1 bitXor: y; bitXor: z ! ! !SecureHashAlgorithm methodsFor: 'public' stamp: 'ul 10/26/2015 02:10' prior: 31075595! hashInteger: aPositiveInteger seed: seedInteger "Hash the given positive integer. The integer to be hashed should have 512 or fewer bits. This entry point is used in the production of random numbers" | buffer dstIndex | "Initialize totalA through totalE to their seed values." totals ifNil: [ totalA := ThirtyTwoBitRegister fromInteger: ((seedInteger bitShift: -128) bitAnd: 16rFFFFFFFF). totalB := ThirtyTwoBitRegister fromInteger: ((seedInteger bitShift: -96) bitAnd: 16rFFFFFFFF). totalC := ThirtyTwoBitRegister fromInteger: ((seedInteger bitShift: -64) bitAnd: 16rFFFFFFFF). totalD := ThirtyTwoBitRegister fromInteger: ((seedInteger bitShift: -32) bitAnd: 16rFFFFFFFF). totalE := ThirtyTwoBitRegister fromInteger: (seedInteger bitAnd: 16rFFFFFFFF) ] ifNotNil: [ totals at: 1 put: ((seedInteger bitShift: -128) bitAnd: 16rFFFFFFFF); at: 2 put: ((seedInteger bitShift: -96) bitAnd: 16rFFFFFFFF); at: 3 put: ((seedInteger bitShift: -64) bitAnd: 16rFFFFFFFF); at: 4 put: ((seedInteger bitShift: -32) bitAnd: 16rFFFFFFFF); at: 5 put: (seedInteger bitAnd: 16rFFFFFFFF) ]. "pad integer with zeros" buffer := ByteArray new: 64. dstIndex := 0. aPositiveInteger digitLength to: 1 by: -1 do: [:i | buffer at: (dstIndex := dstIndex + 1) put: (aPositiveInteger digitAt: i)]. "process that one block" self processBuffer: buffer. ^ self finalHash ! ! !SecureHashAlgorithm methodsFor: 'public' stamp: 'ul 10/26/2015 03:54' prior: 31079309! hashStream: aPositionableStream "Hash the contents of the given stream from the current position to the end using the Secure Hash Algorithm. The SHA algorithm is defined in FIPS PUB 180-1. It is also described on p. 442 of 'Applied Cryptography: Protocols, Algorithms, and Source Code in C' by Bruce Scheier, Wiley, 1996." "SecureHashAlgorithm new hashStream: (ReadStream on: 'foo')" | startPosition buf bitLength | self initializeTotals. "(SecureHashAlgorithm new hashMessage: '') radix: 16 => 'DA39A3EE5E6B4B0D3255BFEF95601890AFD80709'" aPositionableStream atEnd ifTrue: [self processFinalBuffer: #[] bitLength: 0]. startPosition := aPositionableStream position. buf := ByteArray new: 64. [aPositionableStream atEnd] whileFalse: [ buf := aPositionableStream next: 64 into: buf startingAt: 1. (aPositionableStream atEnd not and: [buf size = 64]) ifTrue: [self processBuffer: buf] ifFalse: [ bitLength := (aPositionableStream position - startPosition) * 8. self processFinalBuffer: buf bitLength: bitLength]]. ^ self finalHash ! ! !SecureHashAlgorithm methodsFor: 'initialize-release' stamp: 'ul 10/27/2015 01:17'! initialize self primHasSecureHashPrimitive ifTrue: [ totals := Bitmap new: 5 ] ifFalse: [ totalA := ThirtyTwoBitRegister new. totalB := ThirtyTwoBitRegister new. totalC := ThirtyTwoBitRegister new. totalD := ThirtyTwoBitRegister new. totalE := ThirtyTwoBitRegister new ]! ! !SecureHashAlgorithm methodsFor: 'private' stamp: 'ul 10/26/2015 02:05' prior: 31088155! initializeTotals "Initialize totalA through totalE to their seed values." totals ifNil: [ "total registers for use when primitives are absent" totalA loadFrom: TA. totalB loadFrom: TB. totalC loadFrom: TC. totalD loadFrom: TD. totalE loadFrom: TE ] ifNotNil: [ totals replaceFrom: 1 to: totals size with: TI startingAt: 1 ]! ! !SecureHashAlgorithm methodsFor: 'private' stamp: 'ul 10/27/2015 01:31' prior: 31092660! processBuffer: aByteArray "Process given 64-byte buffer, accumulating the results in totalA through totalE." | a b c d e t tmp w tmp2 tmp3 | totals ifNotNil: [ ^self processBufferUsingPrimitives: aByteArray ]. "initialize registers a through e from the current totals" a := totalA copy. b := totalB copy. c := totalC copy. d := totalD copy. e := totalE copy. "expand and process the buffer" w := self expandedBlock: aByteArray. tmp := ThirtyTwoBitRegister new. tmp2 := ThirtyTwoBitRegister new. tmp3 := ThirtyTwoBitRegister new. 1 to: 80 do: [:i | tmp loadFrom: a; leftRotateBy: 5; += (self hashFunction: i of: b with: c with: d using: tmp2 and: tmp3); += e; += (w at: i); += (self constantForStep: i). t := e. e := d. d := c. c := b leftRotateBy: 30. b := a. a := tmp. tmp := t ]. "add a through e into total accumulators" totalA += a. totalB += b. totalC += c. totalD += d. totalE += e. ! ! !ImageSegment methodsFor: 'fileIn/Out' stamp: 'nice 11/13/2015 00:14' prior: 33801810! comeFullyUpOnReload: smartRefStream "fix up the objects in the segment that changed size. An object in the segment is the wrong size for the modern version of the class. Construct a fake class that is the old size. Replace the modern class with the old one in outPointers. Load the segment. Traverse the instances, making new instances by copying fields, and running conversion messages. Keep the new instances. Bulk forward become the old to the new. Let go of the fake objects and classes. After the install (below), arrayOfRoots is filled in. Globalize new classes. Caller may want to do some special install on certain objects in arrayOfRoots. May want to write the segment out to disk in its new form." | mapFakeClassesToReal receiverClasses rootsToUnhiberhate myProject forgetDoItsClasses endianness | forgetDoItsClasses := Set new. RecentlyRenamedClasses := nil. "in case old data hanging around" mapFakeClassesToReal := smartRefStream reshapedClassesIn: outPointers. "Dictionary of just the ones that change shape. Substitute them in outPointers." self fixCapitalizationOfSymbols. endianness := self endianness. arrayOfRoots := self loadSegmentFrom: segment outPointers: outPointers. self checkAndReportLoadError. "Can't use install. Not ready for rehashSets" mapFakeClassesToReal isEmpty ifFalse: [ self reshapeClasses: mapFakeClassesToReal refStream: smartRefStream ]. "When a Project is stored, arrayOfRoots has all objects in the project, except those in outPointers" arrayOfRoots do: [:importedObject | | existing | ((importedObject isMemberOf: WideString) or: [importedObject isMemberOf: WideSymbol]) ifTrue: [ importedObject mutateJISX0208StringToUnicode. importedObject class = WideSymbol ifTrue: [ "self halt." Symbol hasInterned: importedObject asString ifTrue: [:multiSymbol | multiSymbol == importedObject ifFalse: [ importedObject becomeForward: multiSymbol. ]. ]. ]. ]. (importedObject isKindOf: TTCFontSet) ifTrue: [ existing := TTCFontSet familyName: importedObject familyName pointSize: importedObject pointSize. "supplies default" existing == importedObject ifFalse: [importedObject becomeForward: existing]. ]. ]. "Smalltalk garbageCollect. MultiSymbol rehash. These take time and are not urgent, so don't to them. In the normal case, no bad MultiSymbols will be found." receiverClasses := self restoreEndianness: (endianness ~~ Smalltalk endianness). "rehash sets" smartRefStream checkFatalReshape: receiverClasses. "Classes in this segment." arrayOfRoots do: [:importedObject | importedObject class class == Metaclass ifTrue: [ forgetDoItsClasses add: importedObject. self declare: importedObject]]. arrayOfRoots do: [:importedObject | importedObject isCompiledMethod ifTrue: [ importedObject sourcePointer > 0 ifTrue: [importedObject zapSourcePointer]]. (importedObject isKindOf: Project) ifTrue: [ myProject := importedObject. importedObject ensureChangeSetNameUnique. Project addingProject: importedObject. importedObject restoreReferences. self dependentsRestore: importedObject]]. rootsToUnhiberhate := arrayOfRoots select: [:importedObject | importedObject respondsTo: #unhibernate "ScriptEditors and ViewerFlapTabs" ]. myProject ifNotNil: [ myProject world setProperty: #thingsToUnhibernate toValue: rootsToUnhiberhate asArray. ]. mapFakeClassesToReal isEmpty ifFalse: [ mapFakeClassesToReal keysAndValuesDo: [:aFake :aReal | aFake removeFromSystemUnlogged. "do not assign the fake's hash to the real class" aFake becomeForward: aReal copyHash: false]. SystemOrganization removeEmptyCategories]. forgetDoItsClasses do: [:c | c forgetDoIts]. "^ self" ! ! !ImageSegment methodsFor: 'fileIn/Out' stamp: 'eem 11/12/2015 17:10' prior: 25740099! endianness "Return which endian kind the incoming segment came from" segment class isBits ifFalse: ["Hope that primitive 98 did the right thing - anyway, we lost information about endianness, so pretend we share the image's endianness." ^Smalltalk endianness]. ^(segment first bitShift: -24) asCharacter == $d ifTrue: [#big] ifFalse: [#little]! ! !ImageSegment methodsFor: 'fileIn/Out' stamp: 'nice 11/13/2015 00:35' prior: 33811819! restoreEndianness ^self restoreEndianness: self endianness ~~ Smalltalk endianness! ! !ImageSegment methodsFor: 'fileIn/Out' stamp: 'nice 11/13/2015 00:22'! restoreEndianness: endiannessHasToBeFixed "If endiannessHasToBeFixed, then fix endianness (byte order) of any objects not already fixed. Do this by discovering classes that need a startUp message sent to each instance, and sending it.. I have just been brought in and converted to live objects. Find all Sets and Dictionaries in the newly created objects and rehash them. Segment is near then end of memory, since is was newly brought in (and a new object created for it). Also, collect all classes of receivers of blocks which refer to instance variables. Return them. Caller will check if they have been reshaped." | hashedCollections receiverClasses noStartUpNeeded startUps | hashedCollections := OrderedCollection new. receiverClasses := IdentitySet new. noStartUpNeeded := IdentitySet new. "classes that don't have a per-instance startUp message" startUps := IdentityDictionary new. "class -> MessageSend of a startUp message" self allObjectsDo: [:object| | cls msg | object isInMemory ifTrue: [(object isCollection and: [object isKindOf: HashedCollection]) ifTrue: [hashedCollections add: object]. (object isContext and: [object hasInstVarRef]) ifTrue: [receiverClasses add: object receiver class]]. (noStartUpNeeded includes: object class) ifFalse: [cls := object class. (msg := startUps at: cls ifAbsent: nil) ifNil: [msg := cls startUpFrom: endiannessHasToBeFixed. "a Message, if we need to swap bytes this time" msg ifNil: [noStartUpNeeded add: cls] ifNotNil: [startUps at: cls put: msg]]. msg ifNotNil: [msg sentTo: object]]]. hashedCollections do: [ :each | each compact ]. "our purpose" ^ receiverClasses "our secondary job"! ! !SystemNavigation methodsFor: 'query' stamp: 'eem 10/7/2015 15:33'! allUnboundMethods "Answer all CompiledMehtods that are not in the class hierarchy" "self systemNavigation allUnboundMethods" ^CompiledMethod allSubInstances select: [:m| m methodClass ifNil: [true] ifNotNil: [:mc| (mc compiledMethodAt: m selector ifAbsent: []) ~~ m]]! ! !SystemNavigation methodsFor: 'browse' stamp: 'cmm 10/16/2015 13:55' prior: 57968226! browseMessageList: messageListOrBlock name: labelString autoSelect: autoSelectString "Create and schedule a MessageSet browser on the message list. If messageListOrBlock is a block, then evaluate it to get the message list." | messageList title | messageList := messageListOrBlock isBlock ifTrue: [ Cursor wait showWhile: messageListOrBlock ] ifFalse: [ messageListOrBlock ]. messageList size = 0 ifTrue: [ ^self inform: 'There are no', String cr, labelString ]. title := messageList size > 1 ifFalse: [ labelString ] ifTrue: [ labelString, ' [', messageList size printString, ']' ]. ^ ToolSet browseMessageSet: messageList name: title autoSelect: autoSelectString! ! !SystemNavigation methodsFor: 'browse' stamp: 'cmm 10/16/2015 14:13' prior: 57987807! methodHierarchyBrowserForClass: aClass selector: selectorSymbol "Create and schedule a message set browser on all implementors of the currently selected message selector. Do nothing if no message is selected." "SystemNavigation default methodHierarchyBrowserForClass: ParagraphEditor selector: #isControlActive" | list aClassNonMeta isMeta tab | aClass ifNil: [^ self]. aClass isTrait ifTrue: [^ self]. selectorSymbol ifNil: [^ self]. aClassNonMeta := aClass theNonMetaClass. isMeta := aClassNonMeta ~~ aClass. list := OrderedCollection new. tab := ''. aClass allSuperclasses reverseDo: [:cl | (cl includesSelector: selectorSymbol) ifTrue: [list addLast: tab , cl name, ' ', selectorSymbol]. tab := tab , ' ']. aClassNonMeta allSubclassesWithLevelDo: [:cl :level | | theClassOrMeta stab | theClassOrMeta := isMeta ifTrue: [cl class] ifFalse: [cl]. (theClassOrMeta includesSelector: selectorSymbol) ifTrue: [stab := ''. 1 to: level do: [:i | stab := stab , ' ']. list addLast: tab , stab , theClassOrMeta name, ' ', selectorSymbol]] startingLevel: 0. (self browseMessageList: list name: 'Inheritance of ' , selectorSymbol ) model deselectAll ; selectReference: (aClass>>selectorSymbol) methodReference! ! !DataStream methodsFor: 'write and read' stamp: 'nice 10/31/2015 23:24' prior: 57387436! nextPut: anObject "Write anObject to the receiver stream. Answer anObject." | typeID selector objectToStore | typeID := self typeIDFor: anObject. (self tryToPutReference: anObject typeID: typeID) ifTrue: [^ anObject]. objectToStore := (self objectIfBlocked: anObject) objectForDataStream: self. objectToStore == anObject ifFalse: [typeID := self typeIDFor: objectToStore. (self tryToPutReference: objectToStore typeID: typeID) ifTrue: [^ anObject]]. byteStream nextPut: typeID. selector := #(writeNil: writeTrue: writeFalse: writeInteger: writeStringOld: writeSymbol: writeByteArray: writeArray: writeInstance: errorWriteReference: writeBitmap: writeClass: writeUser: writeFloat: writeRectangle: == "<-16 short inst" writeString: writeBitmap: writeBitmap: writeWordLike: writeInstance: "CompiledMethod") at: typeID. self perform: selector with: objectToStore. ^ anObject "NOTE: If anObject is a reference type (one that we write cross-references to) but its externalized form (result of objectForDataStream:) isn't (e.g. CompiledMethod and ViewState), then we should remember its externalized form but not add to 'references'. Putting that object again should just put its external form again. That's more compact and avoids seeks when reading. But we just do the simple thing here, allowing backward-references for non-reference types like nil. So objectAt: has to compensate. Objects that externalize nicely won't contain the likes of ViewStates, so this shouldn't hurt much. writeReference: -> errorWriteReference:."! ! !SmalltalkImage class methodsFor: 'class initialization' stamp: 'topa 10/8/2015 21:13' prior: 28072181! initializeStartUpList "SmalltalkImage initialize" | oldList | oldList := StartUpList. StartUpList := OrderedCollection new. "These get processed from the top down..." self flag: #'revisit in Squeak 5.3'. #( SmallInteger Delay DisplayScreen Cursor InputSensor ProcessorScheduler "Starts low space watcher and bkground." FileDirectory "Enables file stack dump and opens sources." ShortIntegerArray ShortRunArray CrLfFileStream "Remove this in Squeak 5.3" ) do:[:clsName| Smalltalk at: clsName ifPresent:[:cls| Smalltalk addToStartUpList: cls]. ]. oldList ifNotNil: [oldList do: [:className | Smalltalk at: className ifPresent: [:theClass | Smalltalk addToStartUpList: theClass]]]. #( ImageSegment PasteUpMorph ControlManager ) do:[:clsName| Smalltalk at: clsName ifPresent:[:cls| Smalltalk addToStartUpList: cls]. ]. ! ! !SmalltalkImage methodsFor: 'system attributes' stamp: 'eem 7/18/2014 10:39' prior: 27941195! isRunningCog "Answers if we're running on a Cog VM (JIT or StackInterpreter)" ^(self vmParameterAt: 42) ifNil: [false] ifNotNil: [:numStackPages| numStackPages > 0]! ! !SmalltalkImage methodsFor: 'system attributes' stamp: 'eem 9/30/2015 10:58'! supportsQueueingFinalization "Answer whether the VM queues individual weak arrays for finalization, instead of signalling the finalization semaphore once for all arrays and having the WeakRegistry mechanism finalize all weak arrays, whether they need to or not." "SmalltalkImage current supportsQueueingFinalization" ^(self vmParameterAt: 48) anyMask: 16! ! !SmalltalkImage methodsFor: 'system attributes' stamp: 'eem 9/30/2015 11:03'! supportsQueueingFinalization: aBoolean "Determine whether the VM queues individual weak arrays for finalization, instead of signalling the finalization semaphore once for all arrays and having the WeakRegistry mechanism finalize all weak arrays, whether they need to or not. This flag persists across snapshots, stored in the image header." "SmalltalkImage current supportsQueueingFinalization: true" self vmParameterAt: 48 put: ((self vmParameterAt: 48) bitClear: 16) + (aBoolean ifTrue: [16] ifFalse: [0])! ! !NaturalLanguageTranslator class methodsFor: 'accessing' stamp: 'topa 10/29/2015 01:03' prior: 54763867! availableForLocaleID: localeID "Answer available locale ID. If translator is not found for correct locale ID, then isoLanguage is attempted for the key." ^ self translators at: localeID ifAbsentPut: [localeID hasParent ifTrue: [self translators at: localeID parent ifAbsent: [self default]] ifFalse: [self default]]! ! SecureHashAlgorithm removeSelector: #initializeTotalsArray! SecureHashAlgorithm removeSelector: #hashFunction:of:with:with:! Preferences class removeSelector: #multipleTextUndo! BreakpointManager class removeSelector: #breakpointMethodSourceFor:in:! "System"! !ByteArray methodsFor: 'platform independent access' stamp: 'ul 9/27/2015 23:01'! long64At: index bigEndian: bigEndian "Return a 64-bit signed integer quantity starting from the given byte index." | value | value := self unsignedLong64At: index bigEndian: bigEndian. value digitLength < 8 ifTrue: [ ^value ]. (value digitAt: 8) < 16r80 ifTrue: [ ^value ]. ^value - 16r10000000000000000! ! !ByteArray methodsFor: 'platform independent access' stamp: 'ul 9/27/2015 22:57'! long64At: index put: value bigEndian: bigEndian "Store a 64-bit signed integer quantity starting from the given byte index." ^self unsignedLong64At: index put: (value negative ifFalse: [ value ] ifTrue: [ value + 16r10000000000000000 ]) bigEndian: bigEndian! ! !ByteArray methodsFor: 'printing' stamp: 'eem 10/31/2015 16:42:41'! printAsLiteralByteArrayOn: aStream aStream nextPutAll: '#['. self do: [ :each | each printOn: aStream ] separatedBy: [ aStream nextPut: $ ]. aStream nextPut: $]! ! !ByteArray methodsFor: 'printing' stamp: 'eem 10/31/2015 16:45:10' prior: 56723868! printOn: aStream self shouldBePrintedAsLiteral ifFalse: [super printOn: aStream. aStream space]. self printAsLiteralByteArrayOn: aStream! ! !ByteArray methodsFor: 'platform independent access' stamp: 'ul 9/27/2015 22:49'! signedByteAt: index "Return an 8-bit signed integer quantity from the given byte index." | byte | (byte := self at: index) <= 16r7F ifTrue: [ ^byte ]. ^byte - 16r100! ! !ByteArray methodsFor: 'platform independent access' stamp: 'ul 9/27/2015 22:55'! signedByteAt: index put: anInteger "Store an 8-bit signed integer quantity at the given byte index." anInteger >= 0 ifTrue: [ ^self at: index put: anInteger ]. self at: index put: anInteger + 16r100. ^anInteger! ! !ByteArray methodsFor: 'printing' stamp: 'eem 10/31/2015 16:42:54'! storeAsLiteralByteArrayOn: aStream aStream nextPutAll: '#['. self do: [ :each | each storeOn: aStream ] separatedBy: [ aStream nextPut: $ ]. aStream nextPut: $]! ! !ByteArray methodsFor: 'printing' stamp: 'eem 10/31/2015 16:45:51' prior: 56724099! storeOn: aStream self shouldBePrintedAsLiteral ifTrue: [self storeAsLiteralByteArrayOn: aStream] ifFalse: [super storeOn: aStream]! ! !Set methodsFor: 'comparing' stamp: 'ul 10/13/2015 23:29' prior: 27057879! = anObject "Two sets are equal if (a) they are the same 'kind' of thing. (b) they have the same set of keys. (c) for each (common) key, they have the same value" self == anObject ifTrue: [ ^true ]. self species == anObject species ifFalse: [ ^false ]. self size = anObject size ifFalse: [ ^false ]. ^self allSatisfy: [ :each | anObject includes: each ]! ! !String methodsFor: 'converting' stamp: 'ul 9/28/2015 20:32' prior: 22217425! asInteger ^self asIntegerSigned: true ! ! !String methodsFor: 'converting' stamp: 'ul 10/10/2015 03:13'! asIntegerSigned: signed "Return the first decimal integer I can find or nil." | index character size result negative | index := 0. size := self size. "Find the first character between $0 and $9." [ (index := index + 1) > size or: [ (self at: index) isDigit ] ] whileFalse. index > size ifTrue: [ ^nil ]. negative := signed and: [ index > 1 and: [ (self at: index - 1) == $- ] ]. "Parse the number." size - index > 15 ifTrue: [ negative ifTrue: [ index := index - 1 ]. ^Integer readFrom: ( ReadStream on: self from: index to: size) ]. result := (self at: index) digitValue. [ (index := index + 1) <= size and: [ (character := self at: index) isDigit ] ] whileTrue: [ result := result * 10 + character digitValue ]. negative ifTrue: [ ^result negated ]. ^result! ! !String methodsFor: 'converting' stamp: 'ul 10/9/2015 22:45' prior: 33574256! asSignedInteger "Return the first signed integer I can find or nil." ^self asIntegerSigned: true! ! !String methodsFor: 'converting' stamp: 'ul 10/9/2015 22:45' prior: 22226096! asUnsignedInteger "Returns the first unsigned integer I can find or nil." ^self asIntegerSigned: false! ! !Text methodsFor: 'emphasis' stamp: 'mt 11/12/2015 09:58'! colorAt: characterIndex ^ self colorAt: characterIndex ifNone: [Color black]! ! !Text methodsFor: 'emphasis' stamp: 'mt 11/12/2015 10:13'! colorAt: characterIndex ifNone: block self size = 0 ifTrue: [^ block value]. "null text tolerates access." ^ (runs at: characterIndex) detect: [:attr | attr class == TextColor] ifFound: [:attr | attr color] ifNone: block! ! !PluggableSet methodsFor: 'as yet unclassified' stamp: 'ul 10/13/2015 23:29'! = anObject "Two sets are equal if (a) they are the same 'kind' of thing. (b) they have the same set of keys. (c) for each (common) key, they have the same value" self == anObject ifTrue: [ ^true ]. self species == anObject species ifFalse: [ ^false ]. hashBlock = anObject hashBlock ifFalse: [ ^false ]. equalBlock = anObject equalBlock ifFalse: [ ^false ]. self size = anObject size ifFalse: [ ^false ]. ^self allSatisfy: [ :each | anObject includes: each ]! ! !WeakValueDictionary methodsFor: 'accessing' stamp: 'ul 9/27/2015 23:13'! associationClass ^WeakValueAssociation! ! !PositionableStream methodsFor: 'accessing' stamp: 'topa 10/8/2015 20:31' prior: 26666711! peekBack "Return the element at the previous position, without changing position. Use indirect messages in case self is a StandardFileStream." | element | self position = 0 ifTrue: [self errorCantGoBack]. self position = 1 ifTrue: [self position: 0. ^ nil]. self skip: -2. element := self next. self skip: 1. ^ element! ! !WeakKeyDictionary methodsFor: 'accessing' stamp: 'ul 9/27/2015 23:13'! associationClass ^WeakKeyAssociation! ! !WeakKeyDictionary methodsFor: 'accessing' stamp: 'ul 9/27/2015 23:14' prior: 56698251! at: key put: anObject "Set the value at key to be anObject. If key is not found, create a new entry for key and set is value to anObject. Answer anObject." key ifNil: [ ^anObject ]. ^super at: key put: anObject! ! !Dictionary methodsFor: 'comparing' stamp: 'ul 10/13/2015 23:23' prior: 30416319! = anObject "Two dictionaries are equal if (a) they are the same 'kind' of thing. (b) they have the same set of keys. (c) for each (common) key, they have the same value" self == anObject ifTrue: [ ^true ]. self species == anObject species ifFalse: [ ^false ]. self size = anObject size ifFalse: [ ^false ]. self associationsDo: [ :association | (anObject at: association key ifAbsent: [ ^false ]) = association value ifFalse: [ ^false ] ]. ^true! ! !Dictionary methodsFor: 'accessing' stamp: 'ul 9/27/2015 23:13'! associationClass ^Association! ! !Dictionary methodsFor: 'accessing' stamp: 'ul 9/27/2015 23:15' prior: 34190869! at: key ifPresent: oneArgBlock ifAbsentPut: absentBlock "Lookup the given key in the receiver. If it is present, answer the value of evaluating oneArgBlock with the value associated with the key. Otherwise add the value of absentBlock under the key, and answer that value." | index value | index := self scanFor: key. (array at: index) ifNotNil: [:element| ^oneArgBlock value: element value]. value := absentBlock value. self atNewIndex: index put: (self associationClass key: key value: value). ^value! ! !Dictionary methodsFor: 'accessing' stamp: 'ul 9/27/2015 23:13' prior: 30408869! at: key put: anObject "Set the value at key to be anObject. If key is not found, create a new entry for key and set is value to anObject. Answer anObject." | index | index := self scanFor: key. (array at: index) ifNil: [ self atNewIndex: index put: (self associationClass key: key value: anObject) ] ifNotNil: [ :association | association value: anObject ]. ^anObject! ! !Dictionary methodsFor: 'private' stamp: 'ul 9/27/2015 23:15' prior: 30433450! valueAtNewKey: aKey put: anObject atIndex: index declareFrom: aDictionary "Support for coordinating class variable and global declarations with variables that have been put in Undeclared so as to redirect all references to the undeclared variable." (aDictionary includesKey: aKey) ifTrue: [self atNewIndex: index put: ((aDictionary associationAt: aKey) value: anObject). aDictionary removeKey: aKey] ifFalse: [self atNewIndex: index put: (self associationClass key: aKey value: anObject)]! ! !ByteString methodsFor: 'converting' stamp: 'ul 10/10/2015 03:25'! asIntegerSigned: signed "Return the first decimal integer I can find or nil." | index integerValue result size negative | (size := self size) <= 16 ifFalse: [ ^super asIntegerSigned: signed ]. "Find the first character between $0 and $9." index := 0. [ (index := index + 1) <= size and: [ (integerValue := (self at: index) asInteger) <= 47 "$0 asInteger - 1" or: [ 58 "$9 asInteger + 1" <= integerValue ] ] ] whileTrue. index <= size ifFalse: [ ^nil ]. negative := signed and: [ 2 <= index and: [ (self at: index - 1) == $- ] ]. "Parse the number." result := integerValue - 48 "$0 asInteger". [ (index := index + 1) <= size and: [ (integerValue := (self at: index) asInteger) <= 57 "$9 asInteger" and: [ 48 "$0 asInteger" <= integerValue ] ] ] whileTrue: [ result := result * 10 + integerValue - 48 ]. negative ifTrue: [ ^result negated ]. ^result! ! !PluggableDictionary methodsFor: 'comparing' stamp: 'ul 10/13/2015 23:24'! = anObject "Two dictionaries are equal if (a) they are the same 'kind' of thing. (b) they have the same set of keys. (c) for each (common) key, they have the same value" self == anObject ifTrue: [ ^true ]. self species == anObject species ifFalse: [ ^false ]. hashBlock = anObject hashBlock ifFalse: [ ^false ]. equalBlock = anObject equalBlock ifFalse: [ ^false ]. self size = anObject size ifFalse: [ ^false ]. self associationsDo: [ :association | (anObject at: association key ifAbsent: [ ^false ]) = association value ifFalse: [ ^false ] ]. ^true! ! WeakValueDictionary removeSelector: #at:put:! "Collections"! MCCodeTool subclass: #MCOperationsBrowser instanceVariableNames: 'selection reverts' classVariableNames: '' poolDictionaries: '' category: 'Monticello-UI'! !MCCodeTool methodsFor: 'menus' stamp: 'cmm 10/19/2015 16:10:13' prior: 56992670! methodListKey: aKeystroke from: aListMorph aKeystroke caseOf: { [$b] -> [self browseMethodFull]. [$h] -> [self classHierarchy]. [$p] -> [self browseFullProtocol]. [$o] -> [self fileOutMessage]. [$c] -> [self copySelector]. [$C] -> [self copyReference]. [$n] -> [self browseSendersOfMessages]. [$m] -> [self browseMessages]. [$i] -> [self methodHierarchy]. [$v] -> [self browseVersions]} otherwise: []! ! !MCCodeTool methodsFor: 'menus' stamp: 'cmm 10/16/2015 14:16' prior: 56997774! methodListMenu: aMenu "Build the menu for the selected method, if any." self selectedMessageName ifNil: [items notEmpty ifTrue: [aMenu addList:#(('fileOut (o)' fileOutMessage))]] ifNotNil: [ aMenu addList:#( ('browse full (b)' browseMethodFull) ('browse hierarchy (h)' classHierarchy) ('browse protocol (p)' browseFullProtocol) - ('fileOut (o)' fileOutMessage) ('printOut' printOutMessage) ('copy selector (c)' copySelector) ('copy reference (C)' copyReference)). aMenu addList: #( - ('browse senders (n)' browseSendersOfMessages) ('browse implementors (m)' browseMessages) ('inheritance (i)' methodHierarchy) ('versions (v)' browseVersions) ('change sets with this method' findMethodInChangeSets) " ('x revert to previous version' revertToPreviousVersion)" ('remove from current change set' removeFromCurrentChanges) " ('x revert & remove from changes' revertAndForget)" ('add to current change set' adoptMessageInCurrentChangeset) " ('x copy up or copy down...' copyUpOrCopyDown)" " ('x remove method (x)' removeMessage)" "-" ). ]. " aMenu addList: #( ('x inst var refs...' browseInstVarRefs) ('x inst var defs...' browseInstVarDefs) ('x class var refs...' browseClassVarRefs) ('x class variables' browseClassVariables) ('x class refs (N)' browseClassRefs) ). " ^ aMenu ! ! !MCOperationsBrowser methodsFor: 'selecting' stamp: 'pre 11/11/2015 15:26'! advanceSelection self selection < items size ifTrue: [self selection: self selection + 1]! ! !MCOperationsBrowser methodsFor: 'actions' stamp: 'pre 11/11/2015 15:26' prior: 50990596! installSelection | loader | selection ifNotNil: [loader := MCPackageLoader new. selection applyTo: loader. loader loadWithName: self changeSetNameForInstall. self reverts remove: selection ifAbsent: []. self changed: #list ]! ! !MCOperationsBrowser methodsFor: 'accessing' stamp: 'mt 11/12/2015 10:16' prior: 50987908! list ^ self items collect: [:each | (self reverts includes: each) ifFalse: [each summary] ifTrue: [Text string: '( ', each summary, ' )' attribute: TextEmphasis struckOut ]]! ! !MCOperationsBrowser methodsFor: 'menus' stamp: 'pre 11/11/2015 15:09'! methodListKey: aKeystroke from: aListMorph aKeystroke caseOf: { [$x] -> [self revertSelection] } otherwise: [super methodListKey: aKeystroke from: aListMorph ]! ! !MCOperationsBrowser methodsFor: 'menus' stamp: 'pre 11/11/2015 15:09' prior: 50992838! methodListMenu: aMenu selection ifNotNil: [aMenu addList: #( ('install' installSelection) ('revert (x)' revertSelection) ('browse origin' browseSelectionOrigin) -)]. self unchangedMethods ifNotEmpty: [aMenu addList: #( ('revert unchanged methods...' revertUnchangedMethods) -)]. super methodListMenu: aMenu. ^ aMenu! ! !MCOperationsBrowser methodsFor: 'actions' stamp: 'pre 11/11/2015 15:28' prior: 50990839! revertSelection | loader | selection ifNotNil: [loader := MCPackageLoader new. selection inverse applyTo: loader. loader loadWithName: self changeSetNameForInstall. self reverts add: selection. self advanceSelection; changed: #list ]! ! !MCOperationsBrowser methodsFor: 'accessing' stamp: 'pre 11/11/2015 15:57'! reverts ^ reverts ifNil: [reverts := Set new]! ! !MCSnapshotBrowser methodsFor: 'accessing' stamp: 'cmm 10/22/2015 11:37:18' prior: 52055138! methodsForSelectedClass ^ items select: [ : ea | ea className = classSelection and: [ ea isMethodDefinition ] ]! ! !MCSnapshotBrowser methodsFor: 'accessing' stamp: 'cmm 10/22/2015 11:36:43'! methodsForSelectedClassAndMetaSelection ^ self methodsForSelectedClass select: [ : each | each classIsMeta = self switchIsClass ]! ! !MCSnapshotBrowser methodsFor: 'accessing' stamp: 'cmm 10/22/2015 11:45:10' prior: 52055741! methodsForSelectedClassCategory ^ items select: [ : ea | (self visibleClasses includes: ea className) and: [ ea isMethodDefinition ] ]! ! !MCSnapshotBrowser methodsFor: 'accessing' stamp: 'cmm 10/22/2015 11:36:59' prior: 52056454! methodsForSelectedProtocol | methods | protocolSelection ifNil: [^ Array new]. methods := self methodsForSelectedClassAndMetaSelection asOrderedCollection. (protocolSelection = '-- all --') ifFalse: [methods removeAllSuchThat: [:ea | ea category ~= protocolSelection]]. ^ methods ! ! !MCSnapshotBrowser methodsFor: 'listing' stamp: 'cmm 10/22/2015 11:44:21' prior: 52061052! visibleProtocols | methods protocols | self switchIsComment ifTrue: [^ Array new]. methods := self methodsForSelectedClassAndMetaSelection. protocols := (methods collect: [:ea | ea category]) asSet asSortedCollection. (protocols size > 1) ifTrue: [protocols add: '-- all --']. ^ protocols ! ! !MCSaveVersionDialog methodsFor: 'ui' stamp: 'cmm 10/19/2015 16:46:29' prior: 25616452! defaultLabel ^ 'Edit Version Name and Message: ', self name! ! !MCSaveVersionDialog methodsFor: 'actions' stamp: 'pre 11/11/2015 15:26' prior: 25623613! ignoreSelection selection ifNil: [ignore size = items size ifFalse: [ignore addAll: items] ifTrue: [ignore removeAll]] ifNotNil: [ ignore remove: selection ifAbsent: [ ignore add: selection]. self advanceSelection]. self changed: #list ! ! !MCSaveVersionDialog methodsFor: 'accessing' stamp: 'mt 11/12/2015 10:16' prior: 25613647! list ^ self items collect: [:each | (self reverts includes: each) ifFalse: [(self ignore includes: each) ifFalse: [each summary] ifTrue: [Text string: '( ', each summary, ' )' attribute: (TextColor color: Color gray)]] ifTrue: [Text string: '( ', each summary, ' )' attribute: TextEmphasis struckOut ]]! ! !MCSaveVersionDialog methodsFor: 'menus' stamp: 'cmm 10/19/2015 16:09:06' prior: 25620384! methodListKey: aKeystroke from: aListMorph aKeystroke caseOf: { [$I] -> [self ignoreSelection]. [$e] -> [self refresh]. } otherwise: [super methodListKey: aKeystroke from: aListMorph ]! ! !MCSaveVersionDialog methodsFor: 'menus' stamp: 'cmm 10/19/2015 16:08:52' prior: 25621146! methodListMenu: aMenu super methodListMenu: aMenu. aMenu addList:#(- ('ignore (I)' ignoreSelection 'Toggle inclusion of this change when saving.') ('refresh (e)' refresh 'Refresh the list of changes to this package.')). ^aMenu! ! !MCSaveVersionDialog methodsFor: 'accessing' stamp: 'cmm 10/19/2015 15:20:19'! name ^ name! ! MCSaveVersionDialog removeSelector: #revertSelection! CrLfFileStream removeSelector: #lineEndingConvention:! MCCodeTool removeSelector: #openSingleMessageBrowser! "Monticello"! !FileStream class methodsFor: 'file reader services' stamp: 'topa 10/23/2015 10:09' prior: 34191560! fileReaderServicesForFile: fullName suffix: suffix "Answer services for the given file" "Check whether the given path points to a directory or file." (FileDirectory default directoryExists: fullName) ifTrue: [^ #()]. ^ self servicesWithSuffixes select: [:spec | spec key anySatisfy: [:pattern | suffix = '*' or: [pattern match: suffix]]] thenCollect: [:spec | spec value]! ! !FileStream class methodsFor: 'dnd requests' stamp: 'mt 10/22/2015 09:47:19'! primDropRequestFileName: dropIndex "Primitive. Return the file name for some file that was just dropped onto Squeak. Fail if dropIndex is out of range or the primitive is not supported." ^nil! ! !StandardFileStream class methodsFor: 'file creation' stamp: 'topa 10/23/2015 13:16' prior: 54506598! isAFileNamed: fileName "Answer true if a file of the given name exists." ^ FileDirectory default fileExists: fileName! ! !StandardFileStream methodsFor: 'dnd requests' stamp: 'mt 10/22/2015 09:47:36' prior: 54460213! requestDropStream: dropIndex "Return a read-only stream for some file the user has just dropped onto Squeak." | rawName | rawName := self class primDropRequestFileName: dropIndex. name := (FilePath pathName: rawName isEncoded: true) asSqueakPathName. fileID := self primDropRequestFileHandle: dropIndex. fileID == nil ifTrue:[^nil]. self register. rwmode := false. buffer1 := String new: 1. self enableReadBuffering ! ! !FileDirectory class methodsFor: 'file reader services' stamp: 'mt 10/22/2015 10:08:08'! fileReaderServicesForFile: fullName suffix: suffix ^ (self on: fullName) exists ifTrue: [self services] ifFalse: [#()].! ! !FileDirectory class methodsFor: 'class initialization' stamp: 'mt 10/22/2015 10:27:23'! initialize FileServices registerFileReader: self.! ! !FileDirectory class methodsFor: 'dnd requests' stamp: 'topa 10/23/2015 10:06'! requestDropDirectory: dropIndex | potentialDirectory | potentialDirectory := self on: (FileStream primDropRequestFileName: dropIndex). ^ potentialDirectory exists ifTrue: [potentialDirectory] ! ! !FileDirectory class methodsFor: 'file reader services' stamp: 'mt 10/22/2015 10:08:52'! services ^ (self class selectors copyWithout: #services) select: [:symbol | symbol beginsWith: #service] thenCollect: [:selector | self perform: selector]! ! !FileDirectory methodsFor: 'path access' stamp: 'mt 10/22/2015 10:24:31'! mimeTypes ^ #('text/directory')! ! !FileDirectory methodsFor: 'path access' stamp: 'mt 10/22/2015 09:58:56'! name "Compatibility with StandardFileStream >> #name to be used, for example, for drop event handling." ^ self fullName! ! StandardFileStream removeSelector: #primDropRequestFileName:! !SmallIntegerTest methodsFor: 'testing - Class Methods' stamp: 'nice 10/31/2015 18:47' prior: 20996071! testMaxVal self assert: (SmallInteger maxVal = 16r3FFFFFFF or: [SmallInteger maxVal = 16rFFFFFFFFFFFFFFF]).! ! !SmallIntegerTest methodsFor: 'testing - Class Methods' stamp: 'nice 10/31/2015 18:47' prior: 20996222! testMinVal self assert: (SmallInteger minVal = -16r40000000 or: [SmallInteger minVal = -16r1000000000000000]).! ! !SmallIntegerTest methodsFor: 'testing - printing' stamp: 'ul 11/2/2015 03:29' prior: 20997853! testPrintString self assert: 1 printString = '1'. self assert: -1 printString = '-1'. self assert: SmallInteger minVal printString = (Smalltalk wordSize = 8 ifTrue: [ '-1152921504606846976'] ifFalse: ['-1073741824']). self assert: SmallInteger maxVal printString = (Smalltalk wordSize = 8 ifTrue: [ '1152921504606846975'] ifFalse: ['1073741823']). self assert: 12345 printString = '12345'. self assert: -54321 printString = '-54321'. self assert: 0 decimalDigitLength = 1. self assert: 4 decimalDigitLength = 1. self assert: 12 decimalDigitLength = 2. self assert: 123 decimalDigitLength = 3. self assert: 1234 decimalDigitLength = 4. self assert: 56789 decimalDigitLength = 5. self assert: 657483 decimalDigitLength = 6. self assert: 6571483 decimalDigitLength = 7. self assert: 65174383 decimalDigitLength = 8. self assert: 625744831 decimalDigitLength = 9. self assert: 1000001111 decimalDigitLength = 10. self assert: SmallInteger maxVal decimalDigitLength = (Smalltalk wordSize = 8 ifTrue: [19] ifFalse: [10]).! ! "KernelTests"! PluggableWidgetSpec subclass: #PluggableListSpec instanceVariableNames: 'list getIndex setIndex getSelected setSelected menu keyPress autoDeselect dragItem dropItem dropAccept doubleClick listSize listItem keystrokePreview icon vScrollBarPolicy hScrollBarPolicy dragStarted' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! !PluggableListSpec commentStamp: 'ar 7/15/2005 11:54' prior: 17927676! A single selection list element. Instance variables: list The selector to retrieve the list elements. getIndex The selector to retrieve the list selection index. setIndex The selector to set the list selection index. getSelected The selector to retrieve the list selection. setSelected The selector to set the list selection. menu The selector to offer (to retrieve?) the context menu. keyPress The selector to invoke for handling keyboard shortcuts. autoDeselect Whether the list should allow automatic deselection or not. dragItem Selector to initiate a drag action on an item dropItem Selector to initiate a drop action of an item dropAccept Selector to determine whether a drop would be accepted! PluggableWidgetSpec subclass: #PluggableTreeSpec instanceVariableNames: 'roots getSelectedPath setSelected getSelected setSelectedParent getChildren hasChildren label icon unusedVar menu keyPress dropItem dropAccept autoDeselect dragItem nodeClass columns vScrollBarPolicy hScrollBarPolicy dragStarted' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! !PluggableTreeSpec commentStamp: 'mvdg 3/21/2008 20:59' prior: 58128289! A pluggable tree widget. PluggableTrees are slightly different from lists in such that they ALWAYS store the actual objects and use the label selector to query for the label of the item. PluggableTrees also behave somewhat differently in such that they do not have a "getSelected" message but only a getSelectedPath message. The difference is that getSelectedPath is used to indicate by the model that the tree should select the appropriate path. This allows disambiguation of items. Because of this, implementations of PluggableTrees must always set their internal selection directly, e.g., rather than sending the model a setSelected message and wait for an update of the #getSelected the implementation must set the selection before sending the #setSelected message. If a client doesn't want this, it can always just signal a change of getSelectedPath to revert to whatever is needed. Instance variables: roots The message to retrieve the roots of the tree. getSelectedPath The message to retrieve the selected path in the tree. setSelected The message to set the selected item in the tree. getChildren The message to retrieve the children of an item hasChildren The message to query for children of an item label The message to query for the label of an item. icon The message to query for the icon of an item. help The message to query for the help of an item. menu The message to query for the tree's menu keyPress The message to process a keystroke. wantsDrop The message to query whether a drop might be accepted. dropItem The message to drop an item. enableDrag Enable dragging from this tree. autoDeselect Whether the tree should allow automatic deselection or not. unusedVar (unused) This variable is a placeholder to fix problems with loading packages in 3.10.! !UIManager methodsFor: 'system introspecting' stamp: 'topa 10/20/2015 08:53:36' prior: 17890288! classOrTraitFrom: environment pattern: pattern label: label "If there is a class or trait whose name exactly given by pattern, return it. If there is only one class or trait in the given environment whose name matches pattern, return it. Otherwise, put up a menu offering the names of all classes that match pattern, and return the class chosen, else nil if nothing chosen. This method ignores separator characters in the pattern" | toMatch potentialNames names exactMatch lines reducedIdentifiers selectedIndex | toMatch := pattern copyWithoutAll: Character separators. toMatch ifEmpty: [ ^nil ]. "If there's a class or trait named as pattern, then return it." Symbol hasInterned: pattern ifTrue: [ :symbol | environment at: symbol ifPresent: [ :maybeClassOrTrait | ((maybeClassOrTrait isKindOf: Class) or: [ maybeClassOrTrait isTrait ]) ifTrue: [ ^maybeClassOrTrait ] ] ]. "No exact match, look for potential matches." toMatch := pattern asLowercase copyWithout: $.. potentialNames := (environment classAndTraitNames) asOrderedCollection. names := pattern last = $. "This is some old hack, using String>>#match: may be better." ifTrue: [ potentialNames select: [ :each | each asLowercase = toMatch ] ] ifFalse: [ potentialNames select: [ :each | each includesSubstring: toMatch caseSensitive: false ] ]. exactMatch := names detect: [ :each | each asLowercase = toMatch ] ifNone: [ nil ]. lines := OrderedCollection new. exactMatch ifNotNil: [ lines add: 1 ]. "Also try some fuzzy matching." reducedIdentifiers := pattern suggestedTypeNames select: [ :each | potentialNames includes: each ]. reducedIdentifiers ifNotEmpty: [ names addAll: reducedIdentifiers. lines add: 1 + names size + reducedIdentifiers size ]. "Let the user select if there's more than one possible match. This may give surprising results." names size = 0 ifTrue: [^ nil "nothing matches"]. selectedIndex := names size = 1 ifTrue: [ 1 ] ifFalse: [ exactMatch ifNotNil: [ names addFirst: exactMatch ]. self chooseFrom: names lines: lines title: label ]. selectedIndex = 0 ifTrue: [ ^nil ]. ^environment at: (names at: selectedIndex) asSymbol! ! !PluggableListSpec methodsFor: 'accessing - selection' stamp: 'ar 2/12/2005 16:42' prior: 17928564! autoDeselect "Answer whether this tree can be automatically deselected" ^autoDeselect ifNil:[true]! ! !PluggableListSpec methodsFor: 'accessing - selection' stamp: 'ar 2/12/2005 16:41' prior: 17928741! autoDeselect: aBool "Indicate whether this tree can be automatically deselected" autoDeselect := aBool! ! !PluggableListSpec methodsFor: 'accessing - drag and drop' stamp: 'ar 7/15/2005 11:07' prior: 17929269! dragItem "Answer the selector for dragging an item" ^dragItem! ! !PluggableListSpec methodsFor: 'accessing - drag and drop' stamp: 'ar 7/15/2005 11:07' prior: 17929409! dragItem: aSymbol "Set the selector for dragging an item" dragItem := aSymbol! ! !PluggableListSpec methodsFor: 'accessing - drag and drop' stamp: 'mt 11/4/2015 14:38'! dragStarted ^ dragStarted! ! !PluggableListSpec methodsFor: 'accessing - drag and drop' stamp: 'mt 11/4/2015 14:38'! dragStarted: symbol dragStarted := symbol.! ! !PluggableListSpec methodsFor: 'accessing - drag and drop' stamp: 'ar 7/15/2005 11:54' prior: 17929565! dropAccept "Answer the selector to determine whether a drop would be accepted" ^dropAccept! ! !PluggableListSpec methodsFor: 'accessing - drag and drop' stamp: 'ar 7/15/2005 11:55' prior: 17929734! dropAccept: aSymbol "Answer the selector to determine whether a drop would be accepted" dropAccept := aSymbol.! ! !PluggableListSpec methodsFor: 'accessing - drag and drop' stamp: 'ar 7/15/2005 11:07' prior: 17929923! dropItem "Answer the selector for dropping an item" ^dropItem! ! !PluggableListSpec methodsFor: 'accessing - drag and drop' stamp: 'ar 7/15/2005 11:07' prior: 17930063! dropItem: aSymbol "Set the selector for dropping an item" dropItem := aSymbol! ! !PluggableListSpec methodsFor: 'accessing - selection' stamp: 'ar 2/9/2005 18:21' prior: 17930218! getIndex "Answer the selector for retrieving the list's selection index" ^getIndex! ! !PluggableListSpec methodsFor: 'accessing - selection' stamp: 'ar 2/9/2005 18:21' prior: 17930378! getIndex: aSymbol "Indicate the selector for retrieving the list's selection index" getIndex := aSymbol! ! !PluggableListSpec methodsFor: 'accessing - selection' stamp: 'ar 2/10/2005 22:33' prior: 17930560! getSelected "Answer the selector for retrieving the list selection" ^getSelected! ! !PluggableListSpec methodsFor: 'accessing - selection' stamp: 'ar 2/10/2005 22:33' prior: 17930719! getSelected: aSymbol "Indicate the selector for retrieving the list selection" getSelected := aSymbol! ! !PluggableListSpec methodsFor: 'accessing - list' stamp: 'ar 2/9/2005 18:20' prior: 17932132! list "Answer the selector for retrieving the list contents" ^list! ! !PluggableListSpec methodsFor: 'accessing - list' stamp: 'ar 2/9/2005 19:24' prior: 17932275! list: aSymbol "Indicate the selector for retrieving the list contents" list := aSymbol.! ! !PluggableListSpec methodsFor: 'accessing - list' stamp: 'mtf 9/27/2007 11:13' prior: 17932442! listItem "Answer the selector for retrieving the list element" ^listItem! ! !PluggableListSpec methodsFor: 'accessing - list' stamp: 'mtf 9/27/2007 11:13' prior: 17932594! listItem: aSymbol "Indicate the selector for retrieving the list element" listItem := aSymbol.! ! !PluggableListSpec methodsFor: 'accessing - list' stamp: 'mtf 9/27/2007 11:11' prior: 17932768! listSize "Answer the selector for retrieving the list size" ^listSize! ! !PluggableListSpec methodsFor: 'accessing - list' stamp: 'mtf 9/27/2007 11:12' prior: 17932917! listSize: aSymbol "Indicate the selector for retrieving the list size" listSize := aSymbol.! ! !PluggableListSpec methodsFor: 'accessing - selection' stamp: 'ar 2/9/2005 18:21' prior: 17933389! setIndex "Answer the selector for setting the list's selection index" ^setIndex! ! !PluggableListSpec methodsFor: 'accessing - selection' stamp: 'ar 2/9/2005 18:21' prior: 17933546! setIndex: aSymbol "Answer the selector for setting the list's selection index" setIndex := aSymbol! ! !PluggableListSpec methodsFor: 'accessing - selection' stamp: 'ar 2/10/2005 22:34' prior: 17933723! setSelected "Answer the selector for setting the list selection" ^setSelected! ! !PluggableListSpec methodsFor: 'accessing - selection' stamp: 'ar 2/10/2005 22:33' prior: 17933879! setSelected: aSymbol "Indicate the selector for setting the list selection" setSelected := aSymbol! ! !PluggableTreeSpec methodsFor: 'accessing - selection' stamp: 'ar 2/12/2005 17:38' prior: 58130285! autoDeselect "Answer whether this tree can be automatically deselected" ^autoDeselect ifNil:[true]! ! !PluggableTreeSpec methodsFor: 'accessing - selection' stamp: 'mvdg 3/21/2008 18:09' prior: 58130661! autoDeselect: aBool "Indicate whether this tree can be automatically deselected" autoDeselect := aBool.! ! !PluggableTreeSpec methodsFor: 'accessing - drag and drop' stamp: 'mvdg 2/11/2007 13:47' prior: 58131060! dragItem ^ dragItem.! ! !PluggableTreeSpec methodsFor: 'accessing - drag and drop' stamp: 'mvdg 2/11/2007 13:47' prior: 58131160! dragItem: aSymbol "Set the selector for dragging an item" dragItem := aSymbol! ! !PluggableTreeSpec methodsFor: 'accessing - drag and drop' stamp: 'mt 11/4/2015 14:21'! dragStarted ^ dragStarted! ! !PluggableTreeSpec methodsFor: 'accessing - drag and drop' stamp: 'mt 11/4/2015 14:21'! dragStarted: symbol dragStarted := symbol.! ! !PluggableTreeSpec methodsFor: 'accessing - drag and drop' stamp: 'ar 7/15/2005 12:09' prior: 58131316! dropAccept "Answer the selector for querying the receiver about accepting drops" ^dropAccept! ! !PluggableTreeSpec methodsFor: 'accessing - drag and drop' stamp: 'ar 7/15/2005 12:09' prior: 58131487! dropAccept: aSymbol "Set the selector for querying the receiver about accepting drops" dropAccept := aSymbol! ! !PluggableTreeSpec methodsFor: 'accessing - drag and drop' stamp: 'ar 2/12/2005 00:35' prior: 58131674! dropItem "Answer the selector for invoking the tree's dragDrop handler" ^dropItem! ! !PluggableTreeSpec methodsFor: 'accessing - drag and drop' stamp: 'ar 2/12/2005 00:35' prior: 58131834! dropItem: aSymbol "Indicate the selector for invoking the tree's dragDrop handler" dropItem := aSymbol! ! !PluggableTreeSpec methodsFor: 'accessing - hierarchy' stamp: 'ar 2/12/2005 00:31' prior: 58132015! getChildren "Answer the message to get the children of this tree" ^getChildren! ! !PluggableTreeSpec methodsFor: 'accessing - hierarchy' stamp: 'ar 2/12/2005 00:31' prior: 58132172! getChildren: aSymbol "Indicate the message to retrieve the children of this tree" getChildren := aSymbol! ! !PluggableTreeSpec methodsFor: 'accessing - selection' stamp: 'mt 3/7/2015 08:54' prior: 58132354! getSelected ^ getSelected! ! !PluggableTreeSpec methodsFor: 'accessing - selection' stamp: 'mt 3/7/2015 08:55' prior: 58132456! getSelected: aSymbol "Indicate a single node in the tree. Only works if that node is visible, too. Use #getSelectedPath otherwise." getSelected := aSymbol.! ! !PluggableTreeSpec methodsFor: 'accessing - selection' stamp: 'ar 2/12/2005 03:28' prior: 58132692! getSelectedPath "Answer the message to retrieve the selection of this tree" ^getSelectedPath! ! !PluggableTreeSpec methodsFor: 'accessing - selection' stamp: 'ar 2/12/2005 03:28' prior: 58132863! getSelectedPath: aSymbol "Indicate the message to retrieve the selection of this tree" getSelectedPath := aSymbol! ! !PluggableTreeSpec methodsFor: 'accessing' stamp: 'mt 11/4/2015 10:23'! hScrollBarPolicy ^ hScrollBarPolicy! ! !PluggableTreeSpec methodsFor: 'accessing' stamp: 'mt 11/4/2015 10:23'! hScrollBarPolicy: aSymbol "#always, #never, #whenNeeded" hScrollBarPolicy := aSymbol.! ! !PluggableTreeSpec methodsFor: 'accessing - hierarchy' stamp: 'ar 2/12/2005 00:31' prior: 58133055! hasChildren "Answer the message to get the existence of children in this tree" ^hasChildren! ! !PluggableTreeSpec methodsFor: 'accessing - hierarchy' stamp: 'ar 2/12/2005 00:31' prior: 58133225! hasChildren: aSymbol "Indicate the message to retrieve the existence children in this tree" hasChildren := aSymbol! ! !PluggableTreeSpec methodsFor: 'accessing - hierarchy' stamp: 'ar 2/12/2005 00:29' prior: 58134917! roots "Answer the message to retrieve the roots of this tree" ^roots! ! !PluggableTreeSpec methodsFor: 'accessing - hierarchy' stamp: 'ar 2/12/2005 00:30' prior: 58135064! roots: aSymbol "Indicate the message to retrieve the roots of this tree" roots := aSymbol! ! !PluggableTreeSpec methodsFor: 'accessing - selection' stamp: 'ar 2/12/2005 00:30' prior: 58135232! setSelected "Answer the message to set the selection of this tree" ^setSelected! ! !PluggableTreeSpec methodsFor: 'accessing - selection' stamp: 'ar 2/12/2005 00:30' prior: 58135390! setSelected: aSymbol "Indicate the message to set the selection of this tree" setSelected := aSymbol! ! !PluggableTreeSpec methodsFor: 'accessing - selection' stamp: 'mt 3/7/2015 09:31' prior: 58135568! setSelectedParent ^ setSelectedParent! ! !PluggableTreeSpec methodsFor: 'accessing - selection' stamp: 'mt 3/7/2015 09:31' prior: 58135682! setSelectedParent: aSymbol setSelectedParent := aSymbol! ! !PluggableTreeSpec methodsFor: 'accessing' stamp: 'mt 11/4/2015 10:23'! vScrollBarPolicy ^ vScrollBarPolicy! ! !PluggableTreeSpec methodsFor: 'accessing' stamp: 'mt 11/4/2015 10:23'! vScrollBarPolicy: aSymbol "#always, #never, #whenNeeded" vScrollBarPolicy := aSymbol.! ! PluggableTreeSpec removeSelector: #wantsDrop:! PluggableTreeSpec removeSelector: #wantsDrop! "ToolBuilder-Kernel"! Object subclass: #TextEditorCommand instanceVariableNames: 'interval message paragraph selection contentsBefore contentsAfter intervalBefore intervalAfter valid messageToUndo messageToRedo intervalBetween type isCompositeUndo isCompositeRedo' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Text Support'! Object subclass: #TextEditorCommandHistory instanceVariableNames: 'commands currentIndex' classVariableNames: 'MaximumTextHistoryDepth' poolDictionaries: '' category: 'Morphic-Text Support'! Editor subclass: #TextEditor instanceVariableNames: 'model paragraph markBlock pointBlock beginTypeInIndex emphasisHere lastParenLocation otherInterval oldInterval typeAhead history' classVariableNames: 'AutoEnclose AutoIndent ChangeText FindText' poolDictionaries: '' category: 'Morphic-Text Support'! !TextEditor commentStamp: '' prior: 61688290! See comment in Editor. My instances edit Text, this is, they support multiple lines and TextAttributes. They have no specific facilities for editing Smalltalk code. Those are found in SmalltalkEditor.! Morph subclass: #SimpleHaloMorph instanceVariableNames: 'target positionOffset' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Widgets'! !SimpleHaloMorph commentStamp: 'mt 11/6/2015 09:59' prior: 0! This is a simple base class for halos in the system. It represents the minimal interface used to implement custom halo morphs. It provides: - event handling code to invoke and transfer a halo when clicking the meta-button (blue) - move the halo's target (morph) when click-hold-drag the meta-button - one close button as a minimal handle (see #addHandles) In general, the halo concept consists of one dedicated user interaction (meta-button click) to invoke an additional, interactive view (the halo) for any morph. This interactive view is itself a morph that can have submorphs (e.g. buttons or text fields) to enrich the target morph. Besides button-based interactions (e.g. resize, move, duplicate, etc.), this could also be used to show other, even domain-specific, information. Use the halo concept to provide means to explore and modify interactive, graphical elements in Squeak and your application. You can benefit from this concept without wasting additional screen space. In non-Squeak applications, the meta-key (typically the mouse-wheel button) is often without real functionality for the user. There, it makes scrolling more convenient---at best. In Squeak, you can easily take advantage of this button click. Notice that direct user input is very limited. Many keyboard shortcuts (such as [ctrl]+[c]) are already pre-defined and should not be remapped for your domain-specific applications to avoid user confusion. Key chords (such as [ctrl]+[alt]+[v], [a] from Visual Studio) have to be learned with great effort. The left mouse click (red) selects something. The right mouse click (yellow) invokes a context menu. Only the middle click, the meta-key, the blue button, is unused in many environments. This is where the halo concept comes in. [For two- or single-button mice, the meta-key can be simulated.]! SimpleHaloMorph subclass: #HaloMorph instanceVariableNames: 'innerTarget angleOffset minExtent growingOrRotating directionArrowAnchor haloBox simpleMode originalExtent' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Widgets'! !HaloMorph commentStamp: '' prior: 64866147! This morph provides a halo of handles for its target morph. Dragging, duplicating, rotating, and resizing to be done by mousing down on the appropriate handle. There are also handles for help and for a menu of infrequently used operations.! BorderedMorph subclass: #PasteUpMorph instanceVariableNames: 'presenter model cursor padding backgroundMorph turtleTrailsForm turtlePen lastTurtlePositions isPartsBin indicateCursor wantsMouseOverHalos worldState griddingOn' classVariableNames: 'DisableDeferredUpdates GlobalCommandKeysEnabled MinCycleLapse StillAlive WindowEventHandler' poolDictionaries: '' category: 'Morphic-Worlds'! !PasteUpMorph commentStamp: '' prior: 61352310! A morph whose submorphs comprise a paste-up of rectangular subparts which "show through". Anything called a 'Playfield' is a PasteUpMorph. Facilities commonly needed on pages of graphical presentations and on simulation playfields, such as the painting of new objects, turtle trails, gradient fills, background paintings, parts-bin behavior, collision-detection, etc., are (or will be) provided. A World, the entire Smalltalk screen, is a PasteUpMorph. A World responds true to isWorld. Morph subclasses that have specialized menus (BookMorph) build them in the message addBookMenuItemsTo:hand:. A PasteUpMorph that is a world, builds its menu in HandMorph buildWorldMenu. presenter A Presenter in charge of stopButton stepButton and goButton, mouseOverHalosEnabled soundsEnabled fenceEnabled coloredTilesEnabled. model cursor ?? padding ?? backgroundMorph A Form that covers the background. turtleTrailsForm Moving submorphs may leave trails on this form. turtlePen Draws the trails. lastTurtlePositions A Dictionary of (aPlayer -> aPoint) so turtle trails can be drawn only once each step cycle. The point is the start of the current stroke. isPartsBin If true, every object dragged out is copied. autoLineLayout ?? indicateCursor ?? resizeToFit ?? wantsMouseOverHalos If true, simply moving the cursor over a submorph brings up its halo. worldState If I am also a World, keeps the hands, damageRecorder, stepList etc. griddingOn If true, submorphs are on a grid ! ScrollPane subclass: #PluggableListMorph instanceVariableNames: 'list getListSelector getListSizeSelector getListElementSelector getIndexSelector setIndexSelector keystrokeActionSelector autoDeselect lastKeystrokeTime lastKeystrokes lastClickTime doubleClickSelector handlesBasicKeys potentialDropRow hoverRow listMorph hScrollRangeCache keystrokePreviewSelector priorSelection getIconSelector getHelpSelector' classVariableNames: 'ClearFilterAutomatically FilterableLists HighlightHoveredRow MenuRequestUpdatesSelection' poolDictionaries: '' category: 'Morphic-Pluggable Widgets'! !PluggableListMorph commentStamp: 'cmm 8/21/2011 23:37' prior: 66954717! When a PluggableListMorph is in focus, type in a letter (or several letters quickly) to go to the next item that begins with that letter (if FilterableLists is false). Special keys (up, down, home, etc.) are also supported.! ScrollPane subclass: #SimpleHierarchicalListMorph instanceVariableNames: 'selectedMorph hoveredMorph getListSelector keystrokeActionSelector autoDeselect columns sortingSelector getSelectionSelector setSelectionSelector potentialDropMorph lineColor' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Explorer'! !SimpleHierarchicalListMorph commentStamp: 'ls 3/1/2004 12:15' prior: 56172224! Display a hierarchical list of items. Each item should be wrapped with a ListItemWrapper. For a simple example, look at submorphsExample. For beefier examples, look at ObjectExplorer or FileList2.! RectangleMorph subclass: #GradientDisplayMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Widgets'! RectangleMorph subclass: #GradientEditor instanceVariableNames: 'gradientDisplay rampMorphs selectedSketch row text target selector morph' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Widgets'! !SolidFillStyle methodsFor: '*Morphic-Balloon' stamp: 'topa 10/20/2015 00:49:34'! addFillStyleMenuItems: aMenu hand: aHand from: aMorph ^ self asColor addFillStyleMenuItems: aMenu hand: aHand from: aMorph! ! !TextEditorCommand methodsFor: 'accessing' stamp: 'mt 11/7/2015 14:03'! contentsAfter ^ contentsAfter! ! !TextEditorCommand methodsFor: 'accessing' stamp: 'mt 11/7/2015 14:03'! contentsAfter: anObject contentsAfter := anObject! ! !TextEditorCommand methodsFor: 'accessing' stamp: 'mt 11/7/2015 14:03'! contentsBefore ^ contentsBefore! ! !TextEditorCommand methodsFor: 'accessing' stamp: 'mt 11/7/2015 14:03'! contentsBefore: anObject contentsBefore := anObject! ! !TextEditorCommand methodsFor: 'testing' stamp: 'mt 11/10/2015 09:58'! hasReplacedSomething ^ self contentsBefore size > 0! ! !TextEditorCommand methodsFor: 'accessing' stamp: 'mt 11/7/2015 14:08'! intervalAfter ^ intervalAfter! ! !TextEditorCommand methodsFor: 'accessing' stamp: 'mt 11/7/2015 14:08'! intervalAfter: anObject intervalAfter := anObject! ! !TextEditorCommand methodsFor: 'accessing' stamp: 'mt 11/7/2015 14:08'! intervalBefore ^ intervalBefore! ! !TextEditorCommand methodsFor: 'accessing' stamp: 'mt 11/7/2015 14:08'! intervalBefore: anObject intervalBefore := anObject! ! !TextEditorCommand methodsFor: 'accessing' stamp: 'mt 11/7/2015 14:51'! intervalBetween ^ intervalBetween! ! !TextEditorCommand methodsFor: 'accessing' stamp: 'mt 11/7/2015 14:51'! intervalBetween: anObject intervalBetween := anObject! ! !TextEditorCommand methodsFor: 'accessing' stamp: 'mt 11/10/2015 10:28'! isCompositeRedo ^ isCompositeRedo! ! !TextEditorCommand methodsFor: 'accessing' stamp: 'mt 11/10/2015 10:29'! isCompositeRedo: boolean isCompositeRedo := boolean.! ! !TextEditorCommand methodsFor: 'accessing' stamp: 'mt 11/10/2015 10:28'! isCompositeUndo ^ isCompositeUndo! ! !TextEditorCommand methodsFor: 'accessing' stamp: 'mt 11/10/2015 10:29'! isCompositeUndo: boolean isCompositeUndo := boolean.! ! !TextEditorCommand methodsFor: 'accessing' stamp: 'mt 11/7/2015 14:45'! messageToRedo ^ messageToRedo! ! !TextEditorCommand methodsFor: 'accessing' stamp: 'mt 11/7/2015 14:45'! messageToRedo: msg messageToRedo := msg.! ! !TextEditorCommand methodsFor: 'accessing' stamp: 'mt 11/7/2015 14:45'! messageToUndo ^ messageToUndo! ! !TextEditorCommand methodsFor: 'accessing' stamp: 'mt 11/7/2015 15:26'! messageToUndo: msg messageToUndo := msg.! ! !TextEditorCommand methodsFor: 'copying' stamp: 'mt 11/8/2015 13:15'! postCopy super postCopy. contentsAfter := contentsAfter copy. contentsBefore := contentsBefore copy. intervalAfter := intervalAfter copy. intervalBefore := intervalBefore copy. intervalBetween := intervalBetween copy. messageToUndo := messageToUndo copy. messageToRedo := messageToRedo copy.! ! !TextEditorCommand methodsFor: 'undo/redo' stamp: 'mt 11/7/2015 17:04'! redoIn: editor self messageToRedo sendTo: editor.! ! !TextEditorCommand methodsFor: 'accessing' stamp: 'mt 11/7/2015 21:41'! type ^ type! ! !TextEditorCommand methodsFor: 'accessing' stamp: 'mt 11/7/2015 21:41'! type: symbol type := symbol.! ! !TextEditorCommand methodsFor: 'undo/redo' stamp: 'mt 11/7/2015 17:26'! undoIn: editor self messageToUndo sendTo: editor.! ! !TextEditorCommandHistory class methodsFor: 'preferences' stamp: 'mt 11/13/2015 09:51'! maximumTextHistoryDepth ^ MaximumTextHistoryDepth ifNil: [500]! ! !TextEditorCommandHistory class methodsFor: 'preferences' stamp: 'mt 11/8/2015 09:39'! maximumTextHistoryDepth: number MaximumTextHistoryDepth := number.! ! !TextEditorCommandHistory methodsFor: 'undo/redo' stamp: 'mt 11/8/2015 10:18'! beginRemember: command commands := commands copyFrom: (1 max: (currentIndex + 2 - self class maximumTextHistoryDepth)) to: (currentIndex min: commands size). commands := commands, {command}. currentIndex := commands size - 1. "Select the new command."! ! !TextEditorCommandHistory methodsFor: 'accessing' stamp: 'mt 11/8/2015 10:03'! current ^ self next! ! !TextEditorCommandHistory methodsFor: 'enumeration' stamp: 'mt 11/8/2015 15:04'! detect: block self do: [:command | (block value: command) ifTrue: [^ command]]. ^ nil! ! !TextEditorCommandHistory methodsFor: 'enumeration' stamp: 'mt 11/8/2015 15:06'! do: block ((currentIndex min: commands size) to: 1 by: -1) do: [:i | block value: (commands at: i)].! ! !TextEditorCommandHistory methodsFor: 'undo/redo' stamp: 'mt 11/8/2015 10:01'! finishRemember currentIndex := commands size.! ! !TextEditorCommandHistory methodsFor: 'accessing' stamp: 'mt 11/7/2015 23:47'! hasNext ^ currentIndex < commands size! ! !TextEditorCommandHistory methodsFor: 'accessing' stamp: 'mt 11/8/2015 09:56'! hasPrevious ^ currentIndex > 0! ! !TextEditorCommandHistory methodsFor: 'initialization' stamp: 'mt 11/7/2015 23:41'! initialize super initialize. self reset.! ! !TextEditorCommandHistory methodsFor: 'accessing' stamp: 'mt 11/8/2015 09:57'! next ^ self hasNext ifTrue: [commands at: currentIndex+1] ifFalse: [nil]! ! !TextEditorCommandHistory methodsFor: 'accessing' stamp: 'mt 11/8/2015 09:58'! previous ^ self hasPrevious ifTrue: [commands at: currentIndex] ifFalse: [nil]! ! !TextEditorCommandHistory methodsFor: 'undo/redo' stamp: 'mt 11/10/2015 10:44'! redoIn: editor self hasNext ifFalse: [^ self]. [self current redoIn: editor] ensure: [currentIndex := currentIndex + 1]. self previous isCompositeRedo == true ifTrue: [self redoIn: editor].! ! !TextEditorCommandHistory methodsFor: 'initialization' stamp: 'mt 11/7/2015 23:40'! reset commands := #(). currentIndex := 0.! ! !TextEditorCommandHistory methodsFor: 'undo/redo' stamp: 'mt 11/10/2015 10:40'! undoIn: editor self hasPrevious ifFalse: [^ self]. currentIndex := currentIndex - 1. self current undoIn: editor. self current isCompositeUndo == true ifTrue: [self undoIn: editor].! ! !DockingBarMorph methodsFor: 'initialize-release' stamp: 'cmm 10/19/2015 10:33' prior: 28182717! initialize "initialize the receiver" super initialize. selectedItem := nil. activeSubMenu := nil. fillsOwner := true. avoidVisibleBordersAtEdge := true. autoGradient := MenuMorph gradientMenu. self setDefaultParameters ; beFloating ; beSticky ; layoutInset: 0 ; dropEnabled: true! ! !DockingBarMorph methodsFor: 'initialize-release' stamp: 'cmm 10/18/2015 22:45'! setupGlobalHotKeyEventListeners PasteUpMorph globalCommandKeysEnabled ifTrue: [ ActiveHand addKeyboardListener: self ] ifFalse: [ ActiveHand removeKeyboardListener: self ]! ! !LazyListMorph methodsFor: 'drawing' stamp: 'mt 11/12/2015 10:03' prior: 53562131! display: item atRow: row on: canvas "display the given item at row row" | drawBounds emphasized rowColor itemAsText | itemAsText := item asStringOrText. "If it is a text, we will only use the first character's emphasis." emphasized := itemAsText isText ifTrue: [font emphasized: (itemAsText emphasisAt: 1)] ifFalse: [font]. rowColor := itemAsText isText ifTrue: [itemAsText colorAt: 1 ifNone: [self colorForRow: row]] ifFalse: [self colorForRow: row]. drawBounds := (self drawBoundsForRow: row) translateBy: (self hMargin @ 0). drawBounds := drawBounds intersect: self bounds. "Draw icon if existing. Adjust draw bounds in that case." (self icon: row) ifNotNil: [ :icon || top | top := drawBounds top + ((drawBounds height - icon height) // 2). canvas translucentImage: icon at: drawBounds left @ top. drawBounds := drawBounds left: drawBounds left + icon width + 2 ]. "Draw filter matches if any." (self filterOffsets: row) do: [:offset | canvas frameAndFillRoundRect: ((drawBounds left + offset first) @ drawBounds top corner: (drawBounds left + offset last) @ drawBounds bottom) radius: 3 fillStyle: self class listFilterHighlightColor borderWidth: 1 borderColor: self class listFilterHighlightColor twiceDarker]. "We will only draw strings here." canvas drawString: itemAsText asString in: drawBounds font: emphasized color: rowColor.! ! !Editor methodsFor: 'typing/selecting keys' stamp: 'mt 11/7/2015 17:54' prior: 23174511! backspace: aKeyboardEvent "Backspace over the last character." | startIndex | aKeyboardEvent shiftPressed ifTrue: [^ self backWord: aKeyboardEvent]. startIndex := self markIndex + (self hasCaret ifTrue: [0] ifFalse: [1]). startIndex := 1 max: startIndex - 1. ^ self backTo: startIndex! ! !Editor methodsFor: 'private' stamp: 'mt 11/7/2015 16:02' prior: 23191497! firstWordBoundaryAfter: position "If the character at position is whitespace, answer the position of the first character after position which is not whitespace. If the character at position is not whitespace, answer the position of the first character after position which is whitespace." | string index atWhitespace | string := self string. index := position. (atWhitespace := (string at: index) isSeparator) ifTrue: [ "find next non-separator" [ (index <= string size) and: [ (string at: index) isSeparator ] ] whileTrue: [ index := index + 1 ] ] ifFalse: [ "find next separator" [ (index <= string size) and: [ (string at: index) isSeparator not ] ] whileTrue: [ index := index + 1 ] ]. ^ index! ! !TextEditor class methodsFor: 'class initialization' stamp: 'mt 11/11/2015 12:54'! cleanUp TextEditor allSubInstancesDo: [:editor | editor history ifNotNil: [:h | h current ifNotNil: [editor closeTypeIn]. h reset]].! ! !TextEditor class methodsFor: 'class initialization' stamp: 'mt 11/7/2015 18:57' prior: 61901501! initialize "Initialize the keyboard shortcut maps and the shared buffers for copying text across views and managing again and undo." "TextEditor initialize" FindText := ChangeText := Text new. self initializeCmdKeyShortcuts. self initializeShiftCmdKeyShortcuts. self initializeYellowButtonMenu. self initializeShiftedYellowButtonMenu! ! !TextEditor class methodsFor: 'keyboard shortcut tables' stamp: 'mt 11/13/2015 09:44' prior: 61906784! initializeCmdKeyShortcuts "Initialize the (unshifted) command-key (or alt-key) shortcut table." "NOTE: if you don't know what your keyboard generates, use Sensor kbdTest" "TextEditor initialize" | cmdMap cmds | cmdMap := Array new: 256 withAll: #noop:. "use temp in case of a crash" cmdMap at: 1 + 1 put: #cursorHome:. "home key" cmdMap at: 4 + 1 put: #cursorEnd:. "end key" cmdMap at: 8 + 1 put: #backspace:. "ctrl-H or delete key" cmdMap at: 11 + 1 put: #cursorPageUp:. "page up key" cmdMap at: 12 + 1 put: #cursorPageDown:. "page down key" cmdMap at: 13 + 1 put: #crWithIndent:. "cmd-Return" cmdMap at: 27 + 1 put: #offerMenuFromEsc:. "escape key" cmdMap at: 28 + 1 put: #cursorLeft:. "left arrow key" cmdMap at: 29 + 1 put: #cursorRight:. "right arrow key" cmdMap at: 30 + 1 put: #cursorUp:. "up arrow key" cmdMap at: 31 + 1 put: #cursorDown:. "down arrow key" cmdMap at: 32 + 1 put: #selectWord:. "space bar key" cmdMap at: 127 + 1 put: #forwardDelete:. "del key" '0123456789-=' do: [:char | cmdMap at: char asciiValue + 1 put: #changeEmphasis:]. '([<{|"''' do: [:char | cmdMap at: char asciiValue + 1 put: #enclose:]. cmds := #($a #selectAll: $c #copySelection: $e #exchange: $f #find: $g #findAgain: $h #setSearchString: $j #doAgain: $k #offerFontMenu: $u #align: $v #paste: $w #backWord: $x #cut: $y #swapChars: $z #undo:). 1 to: cmds size by: 2 do: [:i | cmdMap at: (cmds at: i) asciiValue + 1 put: (cmds at: i + 1)]. cmdActions := cmdMap! ! !TextEditor class methodsFor: 'keyboard shortcut tables' stamp: 'mt 11/13/2015 10:00' prior: 61911175! initializeShiftCmdKeyShortcuts "Initialize the shift-command-key (or control-key) shortcut table." "NOTE: if you don't know what your keyboard generates, use Sensor kbdTest" "wod 11/3/1998: Fix setting of cmdMap for shifted keys to actually use the capitalized versions of the letters. TPR 2/18/99: add the plain ascii values back in for those VMs that don't return the shifted values." "TextEditor initialize" | cmdMap cmds | "shift-command and control shortcuts" cmdMap := Array new: 256 withAll: #noop:. "use temp in case of a crash" cmdMap at: ( 1 + 1) put: #cursorHome:. "home key" cmdMap at: ( 4 + 1) put: #cursorEnd:. "end key" cmdMap at: ( 8 + 1) put: #forwardDelete:. "ctrl-H or delete key" cmdMap at: (11 + 1) put: #cursorPageUp:. "page up key" cmdMap at: (12 + 1) put: #cursorPageDown:. "page down key" cmdMap at: (13 + 1) put: #crWithIndent:. "ctrl-Return" cmdMap at: (27 + 1) put: #offerMenuFromEsc:. "escape key" cmdMap at: (28 + 1) put: #cursorLeft:. "left arrow key" cmdMap at: (29 + 1) put: #cursorRight:. "right arrow key" cmdMap at: (30 + 1) put: #cursorUp:. "up arrow key" cmdMap at: (31 + 1) put: #cursorDown:. "down arrow key" cmdMap at: (32 + 1) put: #selectWord:. "space bar key" cmdMap at: (45 + 1) put: #changeEmphasis:. "cmd-sh-minus" cmdMap at: (61 + 1) put: #changeEmphasis:. "cmd-sh-plus" cmdMap at: (127 + 1) put: #forwardDelete:. "del key" "On some keyboards, these characters require a shift" '([<{|"''9' do: [:char | cmdMap at: char asciiValue + 1 put: #enclose:]. "NB: sw 12/9/2001 commented out the idiosyncratic line just below, which was grabbing shift-esc in the text editor and hence which argued with the wish to have shift-esc be a universal gesture for escaping the local context and calling up the desktop menu." "cmdMap at: (27 + 1) put: #shiftEnclose:." "ctrl-[" "'""''(' do: [ :char | cmdMap at: (char asciiValue + 1) put: #enclose:]." cmds := #( $c compareToClipboard: $h cursorTopHome: $j doAgainUpToEnd: $k changeStyle: $m selectCurrentTypeIn: $s findAgain: $u changeLfToCr: $x makeLowercase: $y makeUppercase: $z redo: "makeCapitalized:" ). 1 to: cmds size by: 2 do: [ :i | cmdMap at: ((cmds at: i) asciiValue + 1) put: (cmds at: i + 1). "plain keys" cmdMap at: ((cmds at: i) asciiValue - 32 + 1) put: (cmds at: i + 1). "shifted keys" cmdMap at: ((cmds at: i) asciiValue - 96 + 1) put: (cmds at: i + 1). "ctrl keys" ]. shiftCmdActions := cmdMap! ! !TextEditor class methodsFor: 'keyboard shortcut tables' stamp: 'mt 11/13/2015 09:33' prior: 61914323! initializeYellowButtonMenu "Initialize the yellow button pop-up menu and corresponding messages." "TextEditor initialize" yellowButtonMenu := MenuMorph fromArray: { {'find...(f)' translated. #find}. {'find again (g)' translated. #findAgain}. {'find and replace ...' translated. #findReplace}. {'do/replace again (j)' translated. #again}. #-. {'undo (z)' translated. #undo}. {'redo (Z)' translated. #redo}. #-. {'copy (c)' translated. #copySelection}. {'cut (x)' translated. #cut}. {'paste (v)' translated. #paste}. {'paste...' translated. #pasteRecent}. #-. {'set font... (k)' translated. #offerFontMenu}. {'set style... (K)' translated. #changeStyle}. {'set alignment...' translated. #chooseAlignment}. " #-. {'more...' translated. #shiftedTextPaneMenuRequest}. " }! ! !TextEditor class methodsFor: 'class initialization' stamp: 'mt 11/11/2015 11:44'! resetAllHistory TextEditor allSubInstances do: [:editor | editor history reset]. ! ! !TextEditor methodsFor: 'typing support' stamp: 'mt 11/7/2015 23:46' prior: 61796906! addString: aString morph readOnly ifTrue: [^ self]. "If we modifying the text like backward or forward delete, we have to finish that operation." (self isTypingIn and: [self history current type notNil]) ifTrue: [self closeTypeIn]. self typeAhead nextPutAll: aString.! ! !TextEditor methodsFor: 'menu messages' stamp: 'mt 11/10/2015 10:56' prior: 61688822! again "Do the same replace command again. Unlike #findReplaceAgain, this looks up the editor's own command history and uses the previous command." self history hasPrevious ifFalse: [morph flash. ^ self]. self history previous hasReplacedSomething ifFalse: [morph flash. ^ self] ifTrue: [ "Reset shared find/replace state." FindText := self history previous contentsBefore. ChangeText := self history previous contentsAfter. self selectAt: self stopIndex. self findReplaceAgain].! ! !TextEditor methodsFor: 'menu messages' stamp: 'mt 11/10/2015 10:57'! againUpToEnd "Find and replace until the end." | interval pivot isFirst last | self history hasPrevious ifFalse: [morph flash. ^ self]. pivot := self history previous. pivot hasReplacedSomething ifFalse: [morph flash. ^ self]. "Reset shared find/replace state." FindText := pivot contentsBefore. ChangeText := pivot contentsAfter. isFirst := true. last := pivot. [self selectionInterval ~= interval] whileTrue: [ last ~= pivot ifTrue: [ last isCompositeUndo: isFirst not; isCompositeRedo: true. isFirst := false]. last := self history previous. interval := self selectionInterval. self selectAt: self stopIndex. "No selection to make find work." self findReplaceAgain]. last isCompositeRedo: false.! ! !TextEditor methodsFor: 'typing support' stamp: 'mt 11/10/2015 16:08' prior: 61798071! autoEncloseFor: typedChar "Answer whether typeChar was handled by auto-enclosure. Caller should call normalCharacter if not." | openers closers | openers := '([{'. closers := ')]}'. (closers includes: typedChar) ifTrue: [ | pos | self blinkPrevParen: typedChar. ((pos := self indexOfNextNonwhitespaceCharacter) notNil and: [ (paragraph string at: pos) = typedChar ]) ifTrue: [ self moveCursor: [ : position | position + pos - pointBlock stringIndex + 1 ] forward: true select: false. ^ true ] ifFalse: [ ^ false ] ]. (openers includes: typedChar) ifTrue: [ self openTypeIn; addString: typedChar asString; addString: (closers at: (openers indexOf: typedChar)) asString ; insertAndCloseTypeIn ; moveCursor: [ : position | position - 1 ] forward: false select: false. ^ true ]. ^ false! ! !TextEditor methodsFor: 'typing support' stamp: 'mt 11/8/2015 16:28' prior: 61803331! backTo: startIndex "During typing, backspace to startIndex. If there already is a selection, just delete that selection. Otherwise, check if we did something else than backward-deletion and start a new command if so." morph readOnly ifTrue: [^ self]. self hasSelection ifTrue: [ "Add checkpoint in undo history." self replaceSelectionWith: self nullText. ^ true]. startIndex > self text size ifTrue: [^ false]. self selectInvisiblyFrom: startIndex to: self stopIndex-1. self isTypingIn ifTrue: [ self history current type = #backward ifFalse: [self closeTypeIn] ifTrue: [ "Accumulate all deleted characters in current undo command." self history current contentsBefore replaceFrom: 1 to: 0 with: self selection. self history current intervalBefore in: [:i | self history current intervalBefore: (startIndex to: i last)]]]. self openTypeInFor: #backward. self zapSelectionWith: self nullText. ^ false! ! !TextEditor methodsFor: 'initialize-release' stamp: 'mt 11/7/2015 15:18' prior: 61832820! changeParagraph: aParagraph "Install aParagraph as the one to be edited by the receiver." paragraph := aParagraph. self resetState! ! !TextEditor methodsFor: 'attributes' stamp: 'mt 11/10/2015 10:50' prior: 61829776! changeSelectionFontTo: aFont | attr | aFont ifNil: [ ^ self ]. attr := TextFontReference toFont: aFont. self openTypeIn. paragraph text addAttribute: attr from: self startIndex to: (self hasSelection ifTrue: [ self stopIndex - 1 min: paragraph text size ] ifFalse: [ paragraph text size ]). self closeTypeIn. paragraph composeAll. self recomputeSelection. morph changed! ! !TextEditor methodsFor: 'typing support' stamp: 'mt 11/8/2015 16:52' prior: 61805633! closeTypeIn "See comment in openTypeIn. It is important to call closeTypeIn before executing any non-typing key, making a new selection, etc. It is called automatically for menu commands." | begin stop | beginTypeInIndex ifNotNil: [ begin := beginTypeInIndex. stop := self stopIndex. self history current contentsAfter: (stop <= begin ifTrue: [self nullText] ifFalse: [paragraph text copyFrom: begin to: stop-1]); intervalAfter: (stop to: stop-1); intervalBetween: (stop < begin ifTrue: [stop to: stop-1] ifFalse: [begin to: stop-1]); messageToUndo: (Message selector: #undoAndReselect); messageToRedo: (Message selector: #redoAndReselect). self history finishRemember. beginTypeInIndex := nil]! ! !TextEditor methodsFor: 'menu messages' stamp: 'mt 11/7/2015 18:24' prior: 61698424! copySelection "Copy the current selection and store it in the paste buffer, unless a caret." self lineSelectAndEmptyCheck: [^ self]. self clipboardTextPut: self selection.! ! !TextEditor methodsFor: 'menu messages' stamp: 'mt 11/8/2015 13:05' prior: 61698904! cut "Cut out the current selection and redisplay the paragraph if necessary. Undoer & Redoer: undoCutCopy:" self lineSelectAndEmptyCheck: [^ self]. self clipboardTextPut: self selection. self replaceSelectionWith: self nullText.! ! !TextEditor methodsFor: 'editing keys' stamp: 'topa 10/19/2015 19:48'! debugIt: aKeyboardEvent self debugIt. ^ true! ! !TextEditor methodsFor: 'typing support' stamp: 'mt 11/10/2015 12:13' prior: 61815459! dispatchOnKeyboardEvent: aKeyboardEvent "Carry out the action associated with this character, if any. Type-ahead is passed so some routines can flush or use it." | honorCommandKeys typedChar | typedChar := aKeyboardEvent keyCharacter. "Create a new command for separating characters." (Character separators includes: typedChar) ifTrue: [self closeTypeIn]. "Handle one-line input fields." (typedChar == Character cr and: [morph acceptOnCR]) ifTrue: [^ true]. "Clear highlight for last opened parenthesis." self clearParens. "Handle line breaks and auto indent." typedChar == Character cr ifTrue: [ aKeyboardEvent controlKeyPressed ifTrue: [^ self normalCharacter: aKeyboardEvent]. aKeyboardEvent shiftPressed ifTrue: [^ self lf: aKeyboardEvent]. aKeyboardEvent commandKeyPressed ifTrue: [^ self crlf: aKeyboardEvent]. ^ self crWithIndent: aKeyboardEvent]. "Handle indent/outdent with selected text block." (typedChar == Character tab and: [self hasSelection]) ifTrue: [ aKeyboardEvent shiftPressed ifTrue: [self outdent: aKeyboardEvent] ifFalse: [self indent: aKeyboardEvent]. ^ true]. honorCommandKeys := Preferences cmdKeysInText. (honorCommandKeys and: [typedChar == Character enter]) ifTrue: [^ self dispatchOnEnterWith: aKeyboardEvent]. "Special keys overwrite crtl+key combinations - at least on Windows. To resolve this conflict, assume that keys other than cursor keys aren't used together with Crtl." ((self class specialShiftCmdKeys includes: aKeyboardEvent keyValue) and: [aKeyboardEvent keyValue < 27]) ifTrue: [^ aKeyboardEvent controlKeyPressed ifTrue: [self perform: (self class shiftCmdActions at: aKeyboardEvent keyValue + 1) with: aKeyboardEvent] ifFalse: [self perform: (self class cmdActions at: aKeyboardEvent keyValue + 1) with: aKeyboardEvent]]. "backspace, and escape keys (ascii 8 and 27) are command keys" ((honorCommandKeys and: [aKeyboardEvent commandKeyPressed]) or: [self class specialShiftCmdKeys includes: aKeyboardEvent keyValue]) ifTrue: [ ^ aKeyboardEvent shiftPressed ifTrue: [self perform: (self class shiftCmdActions at: aKeyboardEvent keyValue + 1) with: aKeyboardEvent] ifFalse: [self perform: (self class cmdActions at: aKeyboardEvent keyValue + 1) with: aKeyboardEvent]]. "the control key can be used to invoke shift-cmd shortcuts" (honorCommandKeys and: [ aKeyboardEvent controlKeyPressed ]) ifTrue: [^ self perform: (self class shiftCmdActions at: aKeyboardEvent keyValue + 1) with: aKeyboardEvent]. "Automatically enclose paired characters such as brackets." self class autoEnclose ifTrue: [((self hasSelection and: [self enclose: aKeyboardEvent]) or: [self autoEncloseFor: typedChar]) ifTrue: [^ true]]. self normalCharacter: aKeyboardEvent. ^ false! ! !TextEditor methodsFor: 'typing/selecting keys' stamp: 'mt 11/8/2015 13:33'! doAgain: aKeyboardEvent "Do the previous thing again once. 1/26/96 sw" self insertAndCloseTypeIn. self again. ^ true! ! !TextEditor methodsFor: 'typing/selecting keys' stamp: 'mt 11/10/2015 09:56'! doAgainUpToEnd: aKeyboardEvent "Do the previous thing again once. 1/26/96 sw" self insertAndCloseTypeIn. self againUpToEnd. ^ true! ! !TextEditor methodsFor: 'editing keys' stamp: 'mt 11/8/2015 17:01' prior: 61755110! enclose: aKeyboardEvent "Insert or remove bracket characters around the current selection." | character left right startIndex stopIndex oldSelection which t | character := aKeyboardEvent shiftPressed ifTrue: ['{}|"<>' at: ('[]\'',.' indexOf: aKeyboardEvent keyCharacter) ifAbsent: [aKeyboardEvent keyCharacter]] ifFalse: [aKeyboardEvent keyCharacter]. self closeTypeIn. startIndex := self startIndex. stopIndex := self stopIndex. oldSelection := self selection. which := '([<{|"''9' indexOf: character ifAbsent: [ ^false ]. "Allow Control key in lieu of Alt+Shift for (, {, and double-quote." left := ((Preferences cmdKeysInText and: [ aKeyboardEvent controlKeyPressed ]) ifTrue: [ '({<{|""(' ] ifFalse: ['([<{|"''(']) at: which. right := ((Preferences cmdKeysInText and: [ aKeyboardEvent controlKeyPressed ]) ifTrue: [ ')}>}|"")' ] ifFalse: [')]>}|"'')']) at: which. t := self text. ((startIndex > 1 and: [stopIndex <= t size]) and: [ (t at: startIndex-1) = left and: [(t at: stopIndex) = right]]) ifTrue: [ "already enclosed; strip off brackets" self selectFrom: startIndex-1 to: stopIndex. self replaceSelectionWith: oldSelection] ifFalse: [ "not enclosed; enclose by matching brackets" self replaceSelectionWith: (Text string: (String with: left), oldSelection string, (String with: right) attributes: emphasisHere). self selectFrom: startIndex+1 to: stopIndex]. ^true! ! !TextEditor methodsFor: 'menu messages' stamp: 'mt 11/8/2015 17:42' prior: 61699267! exchange "See comment in exchangeWith:" self exchangeWith: otherInterval.! ! !TextEditor methodsFor: 'private' stamp: 'mt 11/10/2015 11:07' prior: 61734067! exchangeWith: prior "If the prior selection is non-overlapping and legal, exchange the text of it with the current selection and leave the currently selected text selected in the location of the prior selection (or leave a caret after a non-caret if it was exchanged with a caret). If both selections are carets, flash & do nothing. Don't affect the paste buffer." | start stop before selection priorSelection delta altInterval | start := self startIndex. stop := self stopIndex - 1. (((prior first <= prior last) and: [start <= stop]) and: [self isDisjointFrom: prior]) ifFalse: [morph flash. ^ self]. before := prior last < start. selection := self selection. priorSelection := paragraph text copyFrom: prior first to: prior last. delta := before ifTrue: [0] ifFalse: [priorSelection size - selection size]. "Create first undo command." self replaceSelectionWith: priorSelection. self history previous isCompositeRedo: true. self selectInvisiblyFrom: prior first + delta to: prior last + delta. delta := before ifTrue: [stop - prior last] ifFalse: [start - prior first]. "Create second undo command." self replaceSelectionWith: selection. self history previous isCompositeUndo: true. altInterval := prior first + delta to: prior last + delta. "If one was a caret, make it otherInterval & leave the caret after the other" prior first > prior last ifTrue: [self selectAt: prior last + 1]. otherInterval := start > stop ifTrue: [self selectAt: altInterval last + 1. prior] ifFalse: [altInterval]! ! !TextEditor methodsFor: 'menu messages' stamp: 'mt 11/12/2015 17:24' prior: 61705628! find "Prompt the user for a string to search for, and search the receiver from the current selection onward for it. 1/26/96 sw" (UIManager default request: 'Find what to select? ' initialAnswer: (self selection ifEmpty: [FindText])) ifEmpty: [^ self] ifNotEmpty: [:reply | self setSearch: reply. self findAgain].! ! !TextEditor methodsFor: 'menu messages' stamp: 'mt 11/13/2015 09:03' prior: 61706109! findAgain | where | where := self text findString: FindText startingAt: self stopIndex caseSensitive: Preferences caseSensitiveFinds. where = 0 ifTrue: [^ false]. self selectFrom: where to: where + FindText size - 1. ^ true! ! !TextEditor methodsFor: 'typing/selecting keys' stamp: 'mt 11/8/2015 12:39' prior: 61788965! findAgain: aKeyboardEvent "Find the desired text again. 1/24/96 sw" self insertAndCloseTypeIn. self findAgain. ^ true! ! !TextEditor methodsFor: 'menu messages' stamp: 'mt 11/12/2015 17:23'! findReplace (UIManager default request: 'Find what to replace?' initialAnswer: (self selection ifEmpty: [FindText])) ifEmpty: [^ self] ifNotEmpty: [:find | (UIManager default request: ('Replace ''{1}'' with?' format: {find}) initialAnswer: (ChangeText ifEmpty: [find])) ifEmpty: [^ self] ifNotEmpty: [:replace | FindText := find. ChangeText := replace. self findReplaceAgain]]! ! !TextEditor methodsFor: 'typing/selecting keys' stamp: 'mt 11/8/2015 12:45'! findReplace: aKeyboardEvent self insertAndCloseTypeIn. self findReplace. ^ true! ! !TextEditor methodsFor: 'menu messages' stamp: 'mt 11/8/2015 13:03'! findReplaceAgain | where | self hasSelection ifTrue: [ "Search from the beginning of the current selection. Supports a nice combination with regular find feature." self selectInvisiblyFrom: self startIndex to: self startIndex - 1]. where := self text findString: FindText startingAt: self stopIndex caseSensitive: Preferences caseSensitiveFinds. where = 0 ifTrue: [^ false]. self selectInvisiblyFrom: where to: where + FindText size - 1. self replaceSelectionWith: ChangeText. ^ true! ! !TextEditor methodsFor: 'typing/selecting keys' stamp: 'mt 11/8/2015 12:45'! findReplaceAgain: aKeyboardEvent self insertAndCloseTypeIn. self findReplaceAgain. ^ true! ! !TextEditor methodsFor: 'typing/selecting keys' stamp: 'mt 11/8/2015 13:04' prior: 61792411! forwardDelete: aKeyboardEvent "Delete forward over the next character. Make Undo work on the whole type-in, not just the one char. wod 11/3/1998: If there was a selection use #zapSelectionWith: rather than #backspace: which was 'one off' in deleting the selection. Handling of things like undo or typeIn area were not fully considered." | startIndex stopIndex | morph readOnly ifTrue: [^ self]. self hasSelection ifTrue: [ "Create checkpoint in history." self replaceSelectionWith: self nullText. ^ true]. startIndex := self markIndex. startIndex > self text size ifTrue: [^ false]. stopIndex := startIndex. "Forward delete next word" self flag: #consistency. "mt: We might want to implemented it like #backspace: and #backWord:." aKeyboardEvent shiftPressed ifTrue: [stopIndex := (self firstWordBoundaryAfter: stopIndex) - 1]. self selectInvisiblyFrom: startIndex to: stopIndex. self isTypingIn ifTrue: [ self history current type = #forwardDelete ifFalse: [self closeTypeIn] ifTrue: [ "Append next characters that will be removed." self history current contentsBefore append: self selection. self history current intervalBefore in: [:i | self history current intervalBefore: (i first to: i last + (stopIndex - startIndex + 1))]]]. self openTypeInFor: #forwardDelete. self zapSelectionWith: self nullText. ^ false! ! !TextEditor methodsFor: 'accessing' stamp: 'mt 11/7/2015 23:26'! history ^ history! ! !TextEditor methodsFor: 'accessing' stamp: 'mt 11/7/2015 23:26'! history: commandHistory history := commandHistory.! ! !TextEditor methodsFor: 'new selection' stamp: 'mt 11/7/2015 22:38' prior: 61720274! insertAndSelect: aString at: anInteger self closeTypeIn. self selectInvisiblyFrom: anInteger to: anInteger - 1. self openTypeIn. self replace: self selectionInterval with: (Text string: (' ', aString) attributes: emphasisHere) and: [self]. self closeTypeIn.! ! !TextEditor methodsFor: 'typing support' stamp: 'mt 11/7/2015 22:15'! isTypingIn ^ beginTypeInIndex notNil! ! !TextEditor methodsFor: 'events' stamp: 'mt 11/7/2015 22:45' prior: 61885533! keyStroke: anEvent self resetTypeAhead; deselect. (self dispatchOnKeyboardEvent: anEvent) ifTrue: [ self closeTypeIn. self storeSelectionInParagraph. ^self]. self openTypeIn. self zapSelectionWith: self typeAhead contents; resetTypeAhead; unselect; storeSelectionInParagraph.! ! !TextEditor methodsFor: 'editing keys' stamp: 'mt 11/13/2015 10:09' prior: 61772042! makeCapitalized: aKeyboardEvent "Force the current selection to uppercase." | prev | prev := $-. "not a letter" self replaceSelectionWith: (self selection string collect: [:c | prev := prev isLetter ifTrue: [c asLowercase] ifFalse: [c asUppercase]]). ^ true! ! !TextEditor methodsFor: 'typing support' stamp: 'mt 11/7/2015 22:24' prior: 61818982! openTypeIn self openTypeInFor: nil.! ! !TextEditor methodsFor: 'typing support' stamp: 'mt 11/8/2015 16:33'! openTypeInFor: editType "Set up UndoSelection to null text (to be added to by readKeyboard and backTo:), beginTypeInBlock to keep track of the leftmost backspace, and UndoParameter to tally how many deleted characters were backspaced over rather than 'cut'. You can't undo typing until after closeTypeIn." beginTypeInIndex ifNil: [ beginTypeInIndex := self startIndex. self history beginRemember: (TextEditorCommand new type: editType; contentsBefore: (self hasSelection ifTrue: [self selection] ifFalse: [self nullText]); intervalBefore: (beginTypeInIndex to: self stopIndex-1) yourself)].! ! !TextEditor methodsFor: 'menu messages' stamp: 'mt 11/7/2015 18:30'! paste "Update command history." self openTypeIn. super paste. self closeTypeIn.! ! !TextEditor methodsFor: 'typing/selecting keys' stamp: 'mt 11/10/2015 11:14' prior: 61794737! querySymbol: aKeyboardEvent "Invoked by Ctrl-q to query the Symbol table and display alternate symbols." | hintText lastOffering offering | self isTypingIn ifFalse: [ self selectPrecedingIdentifier. hintText := self selection string] ifTrue: [ self history current type = #query ifFalse: [ self closeTypeIn. self selectPrecedingIdentifier. hintText := self selection string] ifTrue: [ self history hasPrevious ifFalse: [morph flash. self closeTypeIn. ^ true]. hintText := self history previous contentsAfter string. hintText := hintText copyFrom: (hintText lastIndexOfAnyOf: Character separators, #($#) startingAt: hintText size ifAbsent: [0])+1 to: hintText size. self selectPrecedingIdentifier. lastOffering := self selection string]]. offering := '-'. [offering allSatisfy: [:ea | ea tokenish]] whileFalse: [ offering := (Symbol thatStarts: hintText skipping: lastOffering) ifNil: [hintText]. lastOffering := offering]. self openTypeInFor: #query. self typeAhead nextPutAll: offering. ^ false! ! !TextEditor methodsFor: 'menu messages' stamp: 'mt 11/7/2015 23:37'! redo self closeTypeIn. self history redoIn: self.! ! !TextEditor methodsFor: 'editing keys' stamp: 'mt 11/7/2015 18:53'! redo: aKeyboardEvent "Redo the last edit." self insertAndCloseTypeIn. self redo. ^true! ! !TextEditor methodsFor: 'undoers' stamp: 'mt 11/7/2015 23:38'! redoAndReselect self replace: self history current intervalBefore with: self history current contentsAfter and: [self selectInterval: self history current intervalAfter].! ! !TextEditor methodsFor: 'accessing' stamp: 'mt 11/7/2015 22:39'! replace: interval with: newText self replace: interval with: newText and: ["Do nothing."].! ! !TextEditor methodsFor: 'accessing' stamp: 'mt 11/7/2015 17:04' prior: 61891123! replace: xoldInterval with: newText and: selectingBlock "Replace the text in oldInterval with newText and execute selectingBlock to establish the new selection. Create an undoAndReselect:redoAndReselect: undoer to allow perfect undoing." | undoInterval | undoInterval := self selectionInterval. undoInterval = xoldInterval ifFalse: [self selectInterval: xoldInterval]. self zapSelectionWith: newText. selectingBlock value. otherInterval := self selectionInterval.! ! !TextEditor methodsFor: 'accessing' stamp: 'mt 11/7/2015 18:50' prior: 61892802! replaceSelectionWith: aText "Remember the selection text in UndoSelection. Deselect, and replace the selection text by aText. Remember the resulting selectionInterval in UndoInterval and PriorInterval. Set up undo to use UndoReplace." self openTypeIn. self zapSelectionWith: aText. self closeTypeIn.! ! !TextEditor methodsFor: 'initialize-release' stamp: 'mt 11/7/2015 23:41' prior: 61833604! resetState "Establish the initial conditions for editing the paragraph: place caret before first character, set the emphasis to that of the first character, and save the paragraph for purposes of canceling." pointBlock := markBlock := paragraph defaultCharacterBlock. beginTypeInIndex := nil. otherInterval := 1 to: 0. self setEmphasisHere. selectionShowing := false! ! !TextEditor methodsFor: 'nonediting/nontyping keys' stamp: 'mt 11/8/2015 16:22' prior: 61851556! selectCurrentTypeIn: aKeyboardEvent "Select what would be replaced by an undo (e.g., the last typeIn)." | prior | self flag: #buggy. self insertAndCloseTypeIn. prior := otherInterval. self insertAndCloseTypeIn. otherInterval := prior. ^ true! ! !TextEditor methodsFor: 'accessing' stamp: 'mt 11/8/2015 13:27' prior: 61893627! setSearch: aStringOrText FindText := aStringOrText. ChangeText := self nullText.! ! !TextEditor methodsFor: 'initialize-release' stamp: 'mt 11/8/2015 11:47' prior: 61834077! stateArray ^ {ChangeText. FindText. history ifNil: [TextEditorCommandHistory new]. "Convert old instances" self selectionInterval. self startOfTyping. emphasisHere}! ! !TextEditor methodsFor: 'initialize-release' stamp: 'mt 11/7/2015 23:24' prior: 61834840! stateArrayPut: stateArray | sel | ChangeText := stateArray at: 1. FindText := stateArray at: 2. history := stateArray at: 3. sel := stateArray at: 4. self selectFrom: sel first to: sel last. beginTypeInIndex := stateArray at: 5. emphasisHere := stateArray at: 6! ! !TextEditor methodsFor: 'menu messages' stamp: 'mt 11/10/2015 14:01' prior: 61716804! undo self closeTypeIn. self history undoIn: self. self history hasPrevious ifFalse: [morph hasUnacceptedEdits: false].! ! !TextEditor methodsFor: 'undoers' stamp: 'mt 11/7/2015 23:38'! undoAndReselect self replace: self history current intervalBetween with: self history current contentsBefore and: [self selectInterval: self history current intervalBefore].! ! !TextEditor methodsFor: 'mvc compatibility' stamp: 'mt 11/7/2015 16:38' prior: 61896920! zapSelectionWith: replacement | start stop rep | morph readOnly ifTrue: [^ self]. self deselect. start := self startIndex. stop := self stopIndex. (replacement isEmpty and: [stop > start]) ifTrue: [ "If deleting, then set emphasisHere from 1st character of the deletion" emphasisHere := (self text attributesAt: start) select: [:att | att mayBeExtended]]. (start = stop and: [ replacement isEmpty ]) ifFalse: [ replacement isText ifTrue: [ rep := replacement] ifFalse: [ rep := Text string: replacement attributes: emphasisHere ]. self text replaceFrom: start to: stop - 1 with: rep. paragraph recomposeFrom: start to: start + rep size - 1 delta: rep size - (stop-start). self markIndex: start pointIndex: start + rep size. otherInterval := self selectionInterval]. self userHasEdited " -- note text now dirty"! ! !TransferMorph class methodsFor: 'instance creation' stamp: 'mt 11/4/2015 18:08' prior: 30638415! withPassenger: anObject ^ self withPassenger: anObject from: nil! ! !TransferMorph class methodsFor: 'instance creation' stamp: 'mt 11/4/2015 18:08' prior: 30638841! withPassenger: anObject from: source ^ self new passenger: anObject; source: source; yourself! ! !TransferMorph methodsFor: 'dropping/grabbing' stamp: 'mt 11/4/2015 18:31' prior: 30630846! aboutToBeGrabbedBy: aHand "The receiver is being grabbed by a hand. Perform necessary adjustments (if any) and return the actual morph that should be added to the hand." "Since this morph has been initialized automatically with bounds origin 0@0, we have to move it to aHand position." super aboutToBeGrabbedBy: aHand. self align: self fullBounds bottomLeft with: aHand position. aHand newKeyboardFocus: self.! ! !TransferMorph methodsFor: 'event handling' stamp: 'mt 11/4/2015 18:17'! doCopy copy := true. self updateCopyIcon.! ! !TransferMorph methodsFor: 'event handling' stamp: 'mt 11/4/2015 18:17'! doMove copy := false. self updateCopyIcon.! ! !TransferMorph methodsFor: 'accessing' stamp: 'panda 4/28/2000 16:11' prior: 30630733! dragTransferType ^transferType! ! !TransferMorph methodsFor: 'initialization' stamp: 'mt 11/4/2015 18:33' prior: 30633496! initialize super initialize. self changeTableLayout; listDirection: #leftToRight; hResizing: #shrinkWrap; vResizing: #shrinkWrap; layoutInset: 3; cellInset: 3; wrapCentering: #center; cellPositioning: #leftCenter; setProperty: #indicateKeyboardFocus toValue: #never. self doMove. self on: #keyStroke send: #keyStroke: to: self. self on: #keyUp send: #updateFromUserInputEvent: to: self. self on: #keyDown send: #updateFromUserInputEvent: to: self.! ! !TransferMorph methodsFor: 'event handling' stamp: 'mt 11/4/2015 18:26' prior: 30632686! keyStroke: evt "Abort the drag on an escape" evt keyCharacter = Character escape ifTrue: [self delete].! ! !TransferMorph methodsFor: 'accessing' stamp: 'mt 11/4/2015 18:13' prior: 30630087! passenger: anObject passenger := anObject. self removeAllMorphs; addMorph: passenger asDraggableMorph; updateCopyIcon.! ! !TransferMorph methodsFor: 'accessing' stamp: 'mt 11/4/2015 15:28'! shouldMove ^ self shouldCopy not! ! !TransferMorph methodsFor: 'private' stamp: 'mt 11/4/2015 18:16' prior: 30636759! updateCopyIcon (self submorphNamed: #tmCopyIcon) ifNil: [self shouldCopy ifTrue: [ self addMorphFront: (ImageMorph new image: CopyPlusIcon; name: #tmCopyIcon; yourself)]] ifNotNil: [:copyIcon | self shouldCopy ifFalse: [ copyIcon delete]]! ! !TransferMorph methodsFor: 'event handling' stamp: 'mt 11/4/2015 18:18'! updateFromUserInputEvent: evt evt shiftPressed ifTrue: [self doCopy] ifFalse: [self doMove].! ! !MenuIcons class methodsFor: 'menu decoration' stamp: 'mt 11/10/2015 15:31' prior: 61125207! itemsIcons "answer a collection of associations wordings -> icon to decorate the menus all over the image" | icons | icons := OrderedCollection new. "icons add: #('Test Runner' ) -> self smallTrafficIcon." " world menu" "icons add: #('previous project' 'go to previous project') -> self smallProjectBackIcon." icons add: #('go to next project') -> self smallProjectNextIcon. icons add: #('select' ) -> self smallSelectIcon. icons add: #('jump to project...' ) -> self smallProjectJumpIcon. icons add: #('open...' ) -> self smallOpenIcon. icons add: #('appearance...' ) -> self smallConfigurationIcon. icons add: #('help...' ) -> self smallHelpIcon. "icons add: #('windows...' ) -> self smallWindowIcon." icons add: #('changes...' ) -> self smallDocumentClockIcon. icons add: #('print PS to file...' ) -> self smallPrintIcon. icons add: #('debug...' ) -> self smallDebugIcon. icons add: #('export...' ) -> self smallExportIcon. icons add: #('save' ) -> self smallSaveIcon. "icons add: #('save project on file...' ) -> self smallProjectSaveIcon." "icons add: #('save as...') -> self smallSaveAsIcon. icons add: #('save as new version') -> self smallSaveNewIcon. icons add: #('save and quit' ) -> self smallQuitIcon." icons add: #('quit') -> self smallQuitNoSaveIcon. "icons add: #('load project from file...' ) -> self smallProjectLoadIcon." "" icons add: #('do it (d)' ) -> self smallDoItIcon. icons add: #('inspect it (i)' 'inspect world' 'explore world' 'inspect model' 'inspect morph' 'explore morph' 'inspect owner chain' 'explore' 'inspect' 'explore (I)' 'inspect (i)' 'basic inspect' ) -> self smallInspectItIcon. icons add: #('print it (p)' ) -> self smallPrintIcon. icons add: #('debug it (D)' ) -> self smallDebugIcon. icons add: #('tally it' ) -> self smallTimerIcon. "" icons add: #('copy (c)' 'copy to paste buffer' 'copy text' ) -> self smallCopyIcon. icons add: #('paste (v)') -> self smallPasteIcon. icons add: #('cut (x)' ) -> self smallCutIcon. "" icons add: #('accept (s)' 'yes' 'Yes' ) -> self smallOkIcon. icons add: #('cancel (l)' 'no' 'No' ) -> self smallCancelIcon. "" icons add: #('redo (Z)' ) -> self smallRedoIcon. icons add: #('undo (z)' ) -> self smallUndoIcon. "" icons add: #( 'find class... (f)' 'find method...' ) -> self smallSearchIcon. icons add: #('find...(f)') -> self smallFindIcon. "" icons add: #('remove' 'remove class (x)' 'delete method from changeset (d)' 'remove method from system (x)' 'delete class from change set (d)' 'remove class from system (x)' 'destroy change set (X)' ) -> self smallDeleteIcon. icons add: #('add item...' 'new category...' 'new change set... (n)' ) -> self smallNewIcon. "" icons add: #('objects (o)' ) -> self smallObjectCatalogIcon. icons add: #('authoring tools...') -> self smallAuthoringToolsIcon. icons add: #('projects...') -> self smallProjectIcon. "" icons add: #('make screenshot') -> self smallScreenshotIcon. "" icons add: #('leftFlush' ) -> self smallLeftFlushIcon. icons add: #('rightFlush' ) -> self smallRightFlushIcon. icons add: #('centered' 'set alignment... (u)' ) -> self smallCenteredIcon. icons add: #('justified' ) -> self smallJustifiedIcon. "" icons add: #('set font... (k)' 'list font...' 'set subtitles font' 'change font' 'system fonts...' 'change font...' 'default text font...' 'flaps font...' 'eToys font...' 'eToys title font...' 'halo label font...' 'menu font...' 'window-title font...' 'balloon-help font...' 'code font...' 'button font...') -> self smallFontsIcon. icons add: #('full screen on') -> self smallFullscreenOnIcon. icons add: #('full screen off' ) -> self smallFullscreenOffIcon. "" ^ icons! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'mt 11/8/2015 12:51'! findReplace self handleEdit: [textMorph editor findReplace]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'mt 11/8/2015 11:52'! redo self handleEdit: [textMorph editor redo]! ! !PluggableTextMorph methodsFor: 'updating' stamp: 'mt 11/8/2015 13:28' prior: 18427388! update: aSymbol aSymbol ifNil: [^self]. aSymbol == #flash ifTrue: [^self flash]. aSymbol == getTextSelector ifTrue: [ self setText: self getText. getSelectionSelector ifNotNil: [self setSelection: self getSelection]. ^ self]. aSymbol == getSelectionSelector ifTrue: [^self setSelection: self getSelection]. aSymbol == #acceptChanges ifTrue: [^ self accept]. aSymbol == #revertChanges ifTrue: [^ self cancel]. (aSymbol == #autoSelect and: [getSelectionSelector notNil]) ifTrue: [self handleEdit: [(textMorph editor) abandonChangeText; "no replacement!!" setSearch: model autoSelectString; findAgain]]. aSymbol == #clearUserEdits ifTrue: [^self hasUnacceptedEdits: false]. aSymbol == #wantToChange ifTrue: [self canDiscardEdits ifFalse: [^self promptForCancel]. ^self]. aSymbol == #appendEntry ifTrue: [self handleEdit: [self appendEntry]. ^self refreshWorld]. aSymbol == #appendEntryLater ifTrue: [self handleEdit: [self appendEntry]]. aSymbol == #clearText ifTrue: [self handleEdit: [self changeText: Text new]. ^self refreshWorld]. aSymbol == #bs ifTrue: [self handleEdit: [self bsText]. ^self refreshWorld]. aSymbol == #codeChangedElsewhere ifTrue: [self hasEditingConflicts: true. ^self changed]. aSymbol == #saveContents ifTrue: [^self saveContentsInFile]. ! ! !HandMorph methodsFor: 'private events' stamp: 'cmm 10/15/2015 15:20' prior: 19330323! sendListenEvent: anEvent to: listenerGroup "Send the event to the given group of listeners" listenerGroup ifNil:[^self]. listenerGroup do:[:listener| listener ifNotNil:[listener handleListenEvent: anEvent]].! ! !Morph methodsFor: 'halos and balloon help' stamp: 'mt 11/4/2015 20:10' prior: 32081600! addHalo "Invoke a halo programatically (e.g., not from a meta gesture)" ^ self createHalo popUpFor: self; yourself! ! !Morph methodsFor: 'halos and balloon help' stamp: 'mt 11/4/2015 20:10' prior: 32082091! addHalo: evt ^ self createHalo popUpFor: self event: evt; yourself! ! !Morph methodsFor: 'halos and balloon help' stamp: 'mt 11/4/2015 20:18' prior: 32084596! addMagicHaloFor: aHand aHand halo ifNotNil: [:halo | halo target == self ifTrue:[^self]. halo isMagicHalo ifFalse:[^self]]. self createHalo popUpMagicallyFor: self hand: aHand! ! !Morph methodsFor: 'meta-actions' stamp: 'mt 11/4/2015 21:00' prior: 32244216! blueButtonDown: anEvent "Special gestures (cmd-mouse on the Macintosh; Alt-mouse on Windows and Unix) allow a mouse-sensitive morph to be moved or bring up a halo for the morph." | h tfm doNotDrag | h := anEvent hand halo. "Prevent wrap around halo transfers originating from throwing the event back in" doNotDrag := false. h ifNotNil:[ (h innerTarget == self) ifTrue:[doNotDrag := true]. (h innerTarget hasOwner: self) ifTrue:[doNotDrag := true]. (self hasOwner: h target) ifTrue:[doNotDrag := true]]. tfm := (self transformedFrom: nil) inverseTransformation. "cmd-drag on flexed morphs works better this way" h := self addHalo: (anEvent transformedBy: tfm). h ifNil: [^ self]. doNotDrag ifTrue:[^self]. "Initiate drag transition if requested" anEvent hand waitForClicksOrDrag: h event: (anEvent transformedBy: tfm) selectors: { nil. nil. nil. #startDragTarget:. } threshold: HandMorph dragThreshold. "Pass focus explicitly here" anEvent hand newMouseFocus: h.! ! !Morph methodsFor: 'halos and balloon help' stamp: 'mt 11/4/2015 20:09'! createHalo ^ (Smalltalk at: self haloClass ifAbsent: [HaloMorph]) new bounds: self worldBoundsForHalo yourself! ! !HaloMorph methodsFor: 'events' stamp: 'mt 11/5/2015 10:03' prior: 64899697! blueButtonDown: event self isMagicHalo ifFalse: [super blueButtonDown: event] ifTrue: [ self isMagicHalo: false. self magicAlpha: 1.0].! ! !HaloMorph methodsFor: 'events' stamp: 'ar 9/15/2000 16:54' prior: 64880126! containsPoint: aPoint event: anEvent "Blue buttons are handled by the halo" (anEvent isMouse and:[anEvent isMouseDown and:[anEvent blueButtonPressed]]) ifFalse:[^super containsPoint: aPoint event: anEvent]. ^bounds containsPoint: anEvent position! ! !HaloMorph methodsFor: 'submorphs-add/remove' stamp: 'mt 11/5/2015 10:07' prior: 64904236! delete "Delete the halo. Tell the target that it no longer has the halo; accept any pending edits to the name; and then either actually delete myself or start to fade out" self acceptNameEdit. self isMagicHalo: false. Preferences haloTransitions ifFalse: [super delete] ifTrue: [ self stopStepping; startStepping; startSteppingSelector: #fadeOutFinally]. ! ! !HaloMorph methodsFor: 'dragging or resizing' stamp: 'mt 11/5/2015 10:10'! doResizeTarget: evt | oldExtent newExtent newPosition | newExtent := originalExtent + (evt position - positionOffset * 2). (newExtent x > 1 and: [newExtent y > 1]) ifTrue: [ oldExtent := target extent. target setExtentFromHalo: (newExtent min: owner extent). newPosition := target position - (target extent - oldExtent // 2). newPosition := (newPosition x min: owner extent x - newExtent x max: 0) @ (newPosition y min: owner extent y - newExtent y max: 0). target setConstrainedPosition: newPosition hangOut: true]. self bounds: self target worldBoundsForHalo.! ! !HaloMorph methodsFor: 'events' stamp: 'nk 6/26/2002 07:19' prior: 64880454! handleListenEvent: anEvent "We listen for possible drop events here to add back those handles after a dup/grab operation" (anEvent isMouse and:[anEvent isMove not]) ifFalse:[^ self]. "not interested" anEvent hand removeMouseListener: self. "done listening" (self world ifNil: [target world]) ifNil: [^ self]. self addHandles "and get those handles back"! ! !HaloMorph methodsFor: 'events' stamp: 'mt 11/5/2015 10:10' prior: 64875320! mouseMove: evt growingOrRotating ifTrue: [self doResizeTarget: evt] ifFalse: [self doDragTarget: evt].! ! !HaloMorph methodsFor: 'pop up' stamp: 'mt 11/5/2015 10:20'! popUpFor: morph at: position hand: hand super popUpFor: morph at: position hand: hand. self startStepping. (Preferences haloTransitions or: [self isMagicHalo]) ifTrue: [ self magicAlpha: 0.0. self startSteppingSelector: #fadeInInitially].! ! !HaloMorph methodsFor: 'pop up' stamp: 'mt 11/5/2015 10:25' prior: 64879181! popUpMagicallyFor: aMorph hand: aHand "Programatically pop up a halo for a given hand." super popUpMagicallyFor: aMorph hand: aHand. Preferences magicHalos ifTrue: [self isMagicHalo: true]. (Preferences haloTransitions not and: [self isMagicHalo]) ifTrue: [self magicAlpha: 0.2]. ! ! !HaloMorph methodsFor: 'private' stamp: 'sw 10/2/2001 22:09' prior: 64873600! startDrag: evt with: dragHandle "Drag my target without removing it from its owner." | itsOwner | self obtainHaloForEvent: evt andRemoveAllHandlesBut: dragHandle. positionOffset := dragHandle center - (target point: target position in: owner). ((itsOwner := target topRendererOrSelf owner) notNil and: [itsOwner automaticViewing]) ifTrue: [target openViewerForArgument]! ! !HaloMorph methodsFor: 'dragging or resizing' stamp: 'mt 11/5/2015 10:12'! startDragTarget: event event controlKeyPressed ifTrue: [self startResizeTarget: event] ifFalse: [ growingOrRotating := false. super startDragTarget: event].! ! !HaloMorph methodsFor: 'dragging or resizing' stamp: 'mt 11/5/2015 10:12'! startResizeTarget: event "Begin resizing the target" growingOrRotating := true. positionOffset := event position. originalExtent := target extent. self removeAllHandlesBut: nil. event hand newMouseFocus: self. event hand addMouseListener: self. "add handles back on mouse-up"! ! !HaloMorph methodsFor: 'stepping' stamp: 'jm 7/16/97 06:54' prior: 64904723! stepTime ^ 0 "every cycle" ! ! !HaloMorph methodsFor: 'events' stamp: 'sw 5/21/1998 15:41' prior: 64876178! wantsKeyboardFocusFor: aSubmorph "to allow the name to be edited in the halo in the old tty way; when we morphic-text-ize the name editing, presumably this method should be removed" ^ true! ! !SimpleHaloMorph methodsFor: 'construction' stamp: 'mt 11/5/2015 09:50'! addHandles "This is an example for handles." self addMorphFront: (IconicButton new color: Color red muchLighter; borderColor: Color red; labelGraphic: MenuIcons smallCancelIcon; target: self target; actionSelector: #delete; bottomRight: self topLeft; yourself).! ! !SimpleHaloMorph methodsFor: 'events' stamp: 'mt 11/4/2015 20:58'! blueButtonDown: event "Transfer the halo to the next likely recipient" self target ifNil: [^self delete]. event hand obtainHalo: self. self positionOffset: (event position - (self target point: self target position in: self owner)). "wait for drags or transfer" event hand waitForClicksOrDrag: self event: event selectors: { #transferHalo:. nil. nil. #startDragTarget:. } threshold: HandMorph dragThreshold.! ! !SimpleHaloMorph methodsFor: 'submorphs-add/remove' stamp: 'mt 11/4/2015 20:52'! delete self target hasHalo: false. super delete.! ! !SimpleHaloMorph methodsFor: 'dragging' stamp: 'mt 11/4/2015 20:58'! doDragTarget: event self target setConstrainedPosition: (self target point: (event position - self positionOffset) from: self owner) hangOut: true. self bounds: self target worldBoundsForHalo.! ! !SimpleHaloMorph methodsFor: 'drawing' stamp: 'mt 11/4/2015 20:42'! drawOn: aCanvas "Draw this morph only if it has no target." (Preferences showBoundsInHalo and: [self target isWorldMorph not]) ifTrue: [ | boundsColor | boundsColor := MenuMorph menuSelectionColor ifNil: [Color blue]. aCanvas frameAndFillRectangle: self bounds fillColor: Color transparent borderWidth: 2 borderColor: (boundsColor isTranslucent ifTrue: [boundsColor] ifFalse: [boundsColor alpha: 0.8])]! ! !SimpleHaloMorph methodsFor: 'events' stamp: 'mt 11/4/2015 20:17'! handlerForBlueButtonDown: anEvent "Blue button was clicked within the receiver" ^self! ! !SimpleHaloMorph methodsFor: 'accessing' stamp: 'mt 11/5/2015 09:58'! innerTarget "If the target is merely a decorator for another morph, the inner target can be distiguished. Scroll panes, for example, could have their scrolled content as an inner target." ^ self target! ! !SimpleHaloMorph methodsFor: 'testing' stamp: 'mt 11/4/2015 20:13'! isMagicHalo ^ false! ! !SimpleHaloMorph methodsFor: 'events' stamp: 'mt 11/4/2015 20:59'! mouseMove: event self doDragTarget: event.! ! !SimpleHaloMorph methodsFor: 'pop up' stamp: 'mt 11/4/2015 20:05'! popUpFor: morph self popUpFor: morph hand: (morph world activeHand ifNil: [morph world primaryHand]).! ! !SimpleHaloMorph methodsFor: 'pop up' stamp: 'mt 11/5/2015 10:20'! popUpFor: morph at: position hand: hand self target: morph. hand halo: self. hand world addMorphFront: self. self positionOffset: position - (morph point: morph position in: self owner).! ! !SimpleHaloMorph methodsFor: 'pop up' stamp: 'mt 11/4/2015 20:22'! popUpFor: morph event: event self popUpFor: morph at: event position hand: event hand.! ! !SimpleHaloMorph methodsFor: 'pop up' stamp: 'mt 11/4/2015 20:23'! popUpFor: morph hand: hand self popUpFor: morph at: (hand lastEvent transformedBy: (morph transformedFrom: nil)) hand: hand! ! !SimpleHaloMorph methodsFor: 'pop up' stamp: 'mt 11/4/2015 20:23'! popUpMagicallyFor: morph hand: hand self popUpFor: morph hand: hand.! ! !SimpleHaloMorph methodsFor: 'accessing' stamp: 'mt 11/4/2015 20:20'! positionOffset ^ positionOffset! ! !SimpleHaloMorph methodsFor: 'accessing' stamp: 'mt 11/4/2015 20:20'! positionOffset: aPoint positionOffset := aPoint.! ! !SimpleHaloMorph methodsFor: 'events' stamp: 'mt 11/4/2015 20:45'! rejectsEvent: anEvent "Return true to reject the given event. Rejecting an event means neither the receiver nor any of it's submorphs will be given any chance to handle it." (super rejectsEvent: anEvent) ifTrue:[^true]. anEvent isDropEvent ifTrue:[^true]. "never attempt to drop on halos" ^false! ! !SimpleHaloMorph methodsFor: 'dragging' stamp: 'mt 11/4/2015 20:58'! startDragTarget: event self positionOffset: (event position - (self target point: self target position in: self owner)). event hand newMouseFocus: self.! ! !SimpleHaloMorph methodsFor: 'testing' stamp: 'mt 11/4/2015 20:41'! staysUpWhenMouseIsDownIn: aMorph ^ ((aMorph == self target) or: [aMorph hasOwner: self])! ! !SimpleHaloMorph methodsFor: 'accessing' stamp: 'mt 11/5/2015 10:14'! target ^ target ifNil: [target := Morph new]! ! !SimpleHaloMorph methodsFor: 'accessing' stamp: 'mt 11/4/2015 20:29'! target: morph target := morph. morph hasHalo: true. self addHandles.! ! !SimpleHaloMorph methodsFor: 'pop up' stamp: 'mt 11/5/2015 10:26'! transferHalo: event "Transfer the halo to the next likely recipient" self target transferHalo: (event transformedBy: (self target transformedFrom: self)) from: self target.! ! !TextMorph class methodsFor: 'class initialization' stamp: 'mt 11/11/2015 12:55'! cleanUp TextMorph allSubInstancesDo: [:m | m releaseEditor].! ! !TextMorph methodsFor: 'private' stamp: 'mt 11/7/2015 23:29' prior: 65854208! installEditorToReplace: priorEditor "Install an editor for my paragraph. This constitutes 'hasFocus'. If priorEditor is not nil, then initialize the new editor from its state. We may want to rework this so it actually uses the prior editor." | stateArray | priorEditor ifNotNil: [stateArray := priorEditor stateArray]. editor := self editorClass new morph: self. editor changeParagraph: self paragraph. priorEditor ifNil: [editor history: TextEditorCommandHistory new] ifNotNil: [editor stateArrayPut: stateArray]. self selectionChanged. ^ editor! ! !SmalltalkEditor class methodsFor: 'keyboard shortcut tables' stamp: 'mt 11/10/2015 09:53' prior: 62179607! initializeCmdKeyShortcuts "Initialize the (unshifted) command-key (or alt-key) shortcut table." "NOTE: if you don't know what your keyboard generates, use Sensor kbdTest" "SmalltalkEditor initialize" | cmds | super initializeCmdKeyShortcuts. cmds := #($b #browseIt: $d #doIt: $i #inspectIt: $l #cancel: $m #implementorsOfIt: $n #sendersOfIt: $o #spawnIt: $p #printIt: $q #querySymbol: $s #save: ). 1 to: cmds size by: 2 do: [ : i | cmdActions at: (cmds at: i) asciiValue + 1 put: (cmds at: i + 1)]. "Set up type-method argument hot keys, 1-4.." '1234' do: [ : eachKeyboardChar | cmdActions at: eachKeyboardChar asciiValue + 1 put: #typeMethodArgument: ]! ! !SmalltalkEditor class methodsFor: 'keyboard shortcut tables' stamp: 'topa 10/19/2015 19:52' prior: 62180397! initializeShiftCmdKeyShortcuts "Initialize the shift-command-key (or control-key) shortcut table." "NOTE: if you don't know what your keyboard generates, use Sensor kbdTest" "wod 11/3/1998: Fix setting of cmdMap for shifted keys to actually use the capitalized versions of the letters. TPR 2/18/99: add the plain ascii values back in for those VMs that don't return the shifted values." "SmalltalkEditor initialize" | cmds | super initializeShiftCmdKeyShortcuts. cmds := #( $a argAdvance: $b browseItHere: $d debugIt: $e methodStringsContainingIt: $f displayIfFalse: $g fileItIn: $i exploreIt: $n referencesToIt: $s invokePrettyPrint: $t displayIfTrue: $v pasteInitials: $w methodNamesContainingIt: ). 1 to: cmds size by: 2 do: [ :i | shiftCmdActions at: ((cmds at: i) asciiValue + 1) put: (cmds at: i + 1). "plain keys" shiftCmdActions at: ((cmds at: i) asciiValue - 32 + 1) put: (cmds at: i + 1). "shifted keys" shiftCmdActions at: ((cmds at: i) asciiValue - 96 + 1) put: (cmds at: i + 1). "ctrl keys" ].! ! !PasteUpMorph class methodsFor: 'preferences' stamp: 'cmm 10/17/2015 18:54'! globalCommandKeysEnabled ^ GlobalCommandKeysEnabled ifNil: [ true ]! ! !PasteUpMorph class methodsFor: 'preferences' stamp: 'cmm 10/18/2015 23:04'! globalCommandKeysEnabled: aBoolean GlobalCommandKeysEnabled := aBoolean. aBoolean ifTrue: [ ActiveHand addKeyboardListener: SystemWindow topWindow ; addKeyboardListener: ActiveWorld. ActiveWorld dockingBars do: [ : each | ActiveHand addKeyboardListener: each ] ] ifFalse: [ ActiveHand removeKeyboardListener: SystemWindow topWindow ; removeKeyboardListener: ActiveWorld. ActiveWorld dockingBars do: [ : each | ActiveHand removeKeyboardListener: each ] ]. TheWorldMainDockingBar updateInstances! ! !PasteUpMorph methodsFor: 'initialization' stamp: 'cmm 10/17/2015 18:55' prior: 61402256! becomeActiveDuring: aBlock "Make the receiver the ActiveWorld during the evaluation of aBlock. Note that this method does deliberately *not* use #ensure: to prevent re-installation of the world on project switches." | priorWorld priorHand priorEvent | priorWorld := ActiveWorld. priorHand := ActiveHand. priorEvent := ActiveEvent. priorHand removeKeyboardListener: priorWorld. ActiveWorld := self. ActiveHand := self hands first. "default" ActiveEvent := nil. "not in event cycle" self class globalCommandKeysEnabled ifTrue: [ ActiveHand addKeyboardListener: self ]. aBlock on: Error do: [:ex | ActiveWorld := priorWorld. ActiveEvent := priorEvent. ActiveHand := priorHand. ex pass]! ! !PasteUpMorph methodsFor: 'event handling' stamp: 'topa 11/2/2015 10:04' prior: 61375409! dropFiles: anEvent "Handle a number of dropped files from the OS. TODO: - use a more general mechanism for figuring out what to do with the file (perhaps even offering a choice from a menu) - remember the resource location or (when in browser) even the actual file handle " | numFiles | numFiles := anEvent contents. 1 to: numFiles do: [ :i | (FileDirectory requestDropDirectory: i) ifNotNil: [:directory | self handleDroppedItem: directory event: anEvent] ifNil: [(FileStream requestDropStream: i) ifNotNil: [:stream | [self handleDroppedItem: stream event: anEvent] ensure: [stream close]]]]. ! ! !PasteUpMorph methodsFor: 'event handling' stamp: 'topa 11/2/2015 10:02'! handleDroppedItem: anItem event: anEvent (ExternalDropHandler lookupExternalDropHandler: anItem) ifNotNil: [:handler | handler handle: anItem in: self dropEvent: anEvent].! ! !PasteUpMorph methodsFor: 'events-processing' stamp: 'mt 11/10/2015 13:30'! handleListenEvent: aUserInputEvent "Handlers for *global* keys, regardless of which widget has keyboard focus." aUserInputEvent type = #keystroke ifTrue: [ aUserInputEvent commandKeyPressed ifTrue: [ aUserInputEvent keyValue = $R asciiValue ifTrue: [ Utilities browseRecentSubmissions ]. aUserInputEvent keyValue = $L asciiValue ifTrue: [ World findAFileList: aUserInputEvent ]. aUserInputEvent keyValue = $O asciiValue ifTrue: [ World findAMonticelloBrowser ]. aUserInputEvent keyValue = $P asciiValue ifTrue: [ World findAPreferencesPanel: aUserInputEvent ]. "aUserInputEvent keyValue = $Z asciiValue ifTrue: [ ChangeList browseRecentLog ]." aUserInputEvent keyValue = $] asciiValue ifTrue: [ Smalltalk snapshot: true andQuit: false ] ] ]! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'cmm 10/19/2015 16:23:45' prior: 61506579! keystrokeInWorld: evt "A keystroke was hit when no keyboard focus was set, so it is sent here to the world instead." | aChar isCmd ascii | aChar := evt keyCharacter. (ascii := aChar asciiValue) = Character escape asciiValue ifTrue: [evt commandKeyPressed ifFalse: [^ self putUpWorldMenuFromEscapeKey]]. (evt controlKeyPressed not and: [(#(1 4 8 28 29 30 31 32) includes: ascii) "home, end, backspace, arrow keys, space" and: [self keyboardNavigationHandler notNil]]) ifTrue: [self keyboardNavigationHandler navigateFromKeystroke: aChar]. isCmd := evt commandKeyPressed and: [Preferences cmdKeysInText]. (evt commandKeyPressed and: [Preferences eToyFriendly]) ifTrue: [(aChar == $W) ifTrue: [^ self putUpWorldMenu: evt]]. (isCmd and: [Preferences honorDesktopCmdKeys]) ifTrue: [^ self dispatchCommandKeyInWorld: aChar event: evt]. "It was unhandled. Remember the keystroke." self lastKeystroke: evt keyString. self triggerEvent: #keyStroke! ! !SearchBar class methodsFor: 'preferences' stamp: 'mt 11/2/2015 10:11' prior: 18508507! useScratchPad ^ UseScratchPad ifNil: [ false ]! ! !CornerGripMorph methodsFor: 'as yet unclassified' stamp: 'cmm 10/19/2015 22:14:50'! mouseDown: aMouseButtonEvent target isSystemWindow ifTrue: [ target == SystemWindow topWindow ifFalse: [ target activate ] ]. super mouseDown: aMouseButtonEvent! ! !HelpBrowser methodsFor: '*morphic' stamp: 'cmm 10/15/2015 23:34'! representsSameBrowseeAs: anotherModel ^ self hasUnacceptedEdits not and: [ (toplevelTopics collect: [ : e | e title ]) = (anotherModel toplevelTopics collect: [ : e | e title ]) ]! ! !ListItemWrapper methodsFor: 'accessing' stamp: 'mt 11/5/2015 09:34' prior: 60077176! highlightingColor ^ LazyListMorph listSelectionColor makeForegroundColor! ! !ListItemWrapper methodsFor: 'initialization' stamp: 'mt 11/10/2015 15:09' prior: 60078344! setItem: anObject item := anObject.! ! !TheWorldMainDockingBar class methodsFor: 'events' stamp: 'topa 10/20/2015 08:46:31' prior: 53276468! updateInstances "The class has changed, time to update the instances" self setTimeStamp. Project current in: [:project | project isMorphic ifTrue: [ project assureMainDockingBarPresenceMatchesPreference]].! ! !GradientFillStyle methodsFor: '*Morphic-Balloon' stamp: 'kfr 10/27/2015 17:12' prior: 51772230! addFillStyleMenuItems: aMenu hand: aHand from: aMorph "Add the items for changing the current fill style of the receiver" self isRadialFill ifTrue:[ aMenu add: 'linear gradient' translated target: self selector: #beLinearGradientIn: argument: aMorph. ] ifFalse:[ aMenu add: 'radial gradient' translated target: self selector: #beRadialGradientIn: argument: aMorph. ]. aMenu addLine. aMenu add: 'change color ramp' translated target: self selector: #changeColorRampIn:event: argument: aMorph. aMenu addLine. super addFillStyleMenuItems: aMenu hand: aHand from: aMorph.! ! !GradientFillStyle methodsFor: '*Morphic-Balloon' stamp: 'kfr 10/21/2015 00:15'! changeColorRampIn: aMorph event: evt ^self changeColorSelector: #colorRamp:forMorph: hand: evt hand morph: aMorph originalColor:aMorph fillStyle colorRamp! ! !GradientFillStyle methodsFor: '*Morphic-Balloon' stamp: 'kfr 10/21/2015 00:14' prior: 51774041! changeColorSelector: aSymbol hand: aHand morph: aMorph originalColor: originalColor "Change either the firstColor or the lastColor (depending on aSymbol). Put up a color picker to hande it. We always use a modal picker so that the user can adjust both colors concurrently." ^(GradientEditor on: self selector: aSymbol forMorph: aMorph colorRamp: originalColor) openNear: aMorph fullBoundsInWorld. "NewColorPickerMorph useIt ifTrue: [ (NewColorPickerMorph on: self originalColor: originalColor setColorSelector: aSymbol) openNear: aMorph fullBoundsInWorld ] ifFalse: [ ColorPickerMorph new initializeModal: false ; sourceHand: aHand ; target: self ; selector: aSymbol ; argument: aMorph ; originalColor: originalColor ; putUpFor: aMorph near: aMorph fullBoundsInWorld ]"! ! !GradientFillStyle methodsFor: '*Morphic-Balloon' stamp: 'kfr 10/26/2015 15:37'! colorRamp: aColorRamp forMorph: aMorph colorRamp :=aColorRamp. isTranslucent := nil. pixelRamp := nil. aMorph changed.! ! !SystemWindow methodsFor: 'top window' stamp: 'cmm 10/17/2015 19:07' prior: 34214425! activate "Bring the receiver to the top. If I am modal, bring along my owning window as well." | modalOwner | self modalChild ifNotNil: [ : modalChild | modalChild owner ifNotNil: [ modalChild activate. ^ modalChild modalChild ifNil: [ modalChild flash ] ] ]. (isCollapsed not and: [ self paneMorphs size > 1 and: [ self splitters isEmpty ] ]) ifTrue: [ self addPaneSplitters ]. self activateWindow. PasteUpMorph globalCommandKeysEnabled ifTrue: [ActiveHand addKeyboardListener: self]. modalOwner := self modalOwner. (modalOwner notNil and: [ modalOwner isSystemWindow ]) ifTrue: [ modalOwner bringBehind: self ]! ! !SystemWindow methodsFor: 'events' stamp: 'cmm 10/15/2015 23:13' prior: 34218435! handleListenEvent: aUserInputEvent aUserInputEvent type = #keystroke ifTrue: [ aUserInputEvent commandKeyPressed ifTrue: [ aUserInputEvent keyValue = $\ asciiValue ifTrue: [ self class sendTopWindowToBack ]. "Command+Escape" aUserInputEvent keyValue = 27 ifTrue: [ aUserInputEvent wasHandled: true. ActiveHand removeKeyboardListener: self. self delete ] ]. aUserInputEvent controlKeyPressed ifTrue: [ aUserInputEvent keyValue = 27 ifTrue: [ World findWindow: aUserInputEvent ] ] ]. aUserInputEvent isMouse ifFalse: [ ^ self ]. "Still dragging?" aUserInputEvent hand hasSubmorphs ifTrue: [ ^ self ]. "Make sure we lock our contents after drag-and-drop has finished." (self isActive and: [ self class allWindowsAcceptInput not ]) ifFalse: [ self configureFocus ]. aUserInputEvent hand removeMouseListener: self! ! !SystemWindow methodsFor: 'top window' stamp: 'cmm 10/15/2015 15:01' prior: 34220649! passivate "Lose my drop shadlow and reconfigure my focus according to preferences." self hasDropShadow: false ; configureFocus ; lookUnfocused. ActiveHand removeKeyboardListener: self. model modelSleep! ! !PluggableListMorph methodsFor: 'accessing' stamp: 'mt 11/6/2015 11:27'! balloonText "Overridden to send selector to model and not self. Do not use #perform:orSendTo: because super does more than just the send.." self getHelpSelector ifNotNil: [:selector | ((self model respondsTo: selector) and: [self hoverRow > 0]) ifTrue: [ ^ self model perform: selector with: (self modelIndexFor: self hoverRow)]]. ^ super balloonText! ! !PluggableListMorph methodsFor: 'accessing' stamp: 'mt 11/6/2015 11:29'! getHelpSelector ^ getHelpSelector! ! !PluggableListMorph methodsFor: 'accessing' stamp: 'mt 11/6/2015 11:29'! getHelpSelector: aSelector "Get help for list entries." getHelpSelector := aSelector.! ! !PluggableListMorph methodsFor: 'accessing' stamp: 'mt 11/6/2015 11:26' prior: 66955770! hoverRow: anInteger hoverRow = anInteger ifTrue: [^ self]. hoverRow ifNotNil: [self listMorph rowChanged: hoverRow]. hoverRow := anInteger. hoverRow ifNotNil: [self listMorph rowChanged: hoverRow]. self wantsBalloon ifTrue: [ self activeHand removePendingBalloonFor: self; triggerBalloonFor: self after: self balloonHelpDelayTime].! ! !PluggableListMorph methodsFor: 'drag and drop' stamp: 'mt 11/5/2015 08:58' prior: 66962195! startDrag: evt | item itemMorph | evt hand hasSubmorphs ifTrue: [^ self]. self model okToChange ifFalse: [^ self]. "Ensure selection to save additional click." (self modelIndexFor: (self rowAtLocation: evt position)) in: [:evtIndex | self selectionIndex = evtIndex ifFalse: [self changeModelSelection: evtIndex]]. item := self selection ifNil: [^ self]. itemMorph := StringMorph contents: item asStringOrText. [ "Initiate drag." (self model dragPassengerFor: itemMorph inMorph: self) ifNotNil: [:passenger | | ddm | ddm := (self valueOfProperty: #dragTransferClass ifAbsent: [TransferMorph]) withPassenger: passenger from: self. ddm dragTransferType: (self model dragTransferTypeForMorph: self). ddm updateFromUserInputEvent: evt. self model dragStartedFor: itemMorph transferMorph: ddm. evt hand grabMorph: ddm] ] ensure: [ Cursor normal show. evt hand releaseMouseFocus: self].! ! !PluggableListMorph methodsFor: 'drag and drop' stamp: 'panda 4/25/2000 18:26' prior: 66963322! wantsDroppedMorph: aMorph event: anEvent ^ self model wantsDroppedMorph: aMorph event: anEvent inMorph: self! ! !SimpleHierarchicalListMorph methodsFor: 'drag and drop' stamp: 'nk 6/15/2003 11:49' prior: 56179577! acceptDroppingMorph: aMorph event: evt self model acceptDroppingMorph: aMorph event: evt inMorph: self. self resetPotentialDropMorph. evt hand releaseMouseFocus: self. Cursor normal show. ! ! !SimpleHierarchicalListMorph methodsFor: 'drawing' stamp: 'mt 11/5/2015 09:46'! drawHoverOn: aCanvas self hoveredMorph ifNil: [^ self]. PluggableListMorph highlightHoveredRow ifFalse: [^ self]. aCanvas fillRectangle: (((scroller transformFrom: self) invertBoundsRect: self hoveredMorph bounds) intersect: scroller bounds) color: (LazyListMorph listSelectionColor darker alpha: 0.3).! ! !SimpleHierarchicalListMorph methodsFor: 'drawing' stamp: 'mt 11/5/2015 09:39' prior: 56178639! drawOn: aCanvas super drawOn: aCanvas. self drawHoverOn: aCanvas. self drawSelectionOn: aCanvas. self drawLinesOn: aCanvas.! ! !SimpleHierarchicalListMorph methodsFor: 'drawing' stamp: 'mt 11/5/2015 09:32'! drawSelectionOn: aCanvas self selectedMorph ifNil: [^ self]. aCanvas fillRectangle: (((scroller transformFrom: self) invertBoundsRect: selectedMorph bounds) intersect: scroller bounds) color: LazyListMorph listSelectionColor.! ! !SimpleHierarchicalListMorph methodsFor: 'events-processing' stamp: 'mt 11/5/2015 09:44' prior: 56199039! handleMouseMove: anEvent "Reimplemented because we really want #mouseMove when a morph is dragged around" anEvent wasHandled ifTrue:[^self]. "not interested" self hoveredMorph: (self itemFromPoint: anEvent position). (anEvent anyButtonPressed and:[anEvent hand mouseFocus == self]) ifFalse:[^self]. anEvent wasHandled: true. self mouseMove: anEvent. (self handlesMouseStillDown: anEvent) ifTrue:[ "Step at the new location" self startStepping: #handleMouseStillDown: at: Time millisecondClockValue arguments: {anEvent copy resetHandlerFields} stepTime: 1]. ! ! !SimpleHierarchicalListMorph methodsFor: 'accessing' stamp: 'mt 11/5/2015 09:27'! hoveredMorph ^ hoveredMorph! ! !SimpleHierarchicalListMorph methodsFor: 'accessing' stamp: 'mt 11/5/2015 09:42'! hoveredMorph: aMorph hoveredMorph == aMorph ifTrue: [^ self]. hoveredMorph ifNotNil: [:m | m changed]. hoveredMorph := aMorph. hoveredMorph ifNotNil: [:m | m changed]. ! ! !SimpleHierarchicalListMorph methodsFor: 'event handling' stamp: 'mt 11/8/2015 09:27' prior: 34211454! mouseLeave: aMouseEvent super mouseLeave: aMouseEvent. self hoveredMorph: nil. (SystemWindow allWindowsAcceptInput or: [ Preferences mouseOverForKeyboardFocus ]) ifTrue: [ aMouseEvent hand releaseKeyboardFocus: self ]! ! !SimpleHierarchicalListMorph methodsFor: 'event handling' stamp: 'mt 11/8/2015 09:27' prior: 56191648! mouseLeaveDragging: anEvent self hoveredMorph: nil. (self dropEnabled and:[anEvent hand hasSubmorphs]) ifFalse: ["no d&d" ^ super mouseLeaveDragging: anEvent]. self resetPotentialDropMorph. anEvent hand releaseMouseFocus: self. "above is ugly but necessary for now" ! ! !SimpleHierarchicalListMorph methodsFor: 'drag and drop' stamp: 'panda 4/25/2000 17:39' prior: 56179874! potentialDropMorph ^potentialDropMorph! ! !SimpleHierarchicalListMorph methodsFor: 'drag and drop' stamp: 'mir 5/8/2000 15:37' prior: 56180200! potentialDropMorph: aMorph potentialDropMorph := aMorph. aMorph highlightForDrop! ! !SimpleHierarchicalListMorph methodsFor: 'drag and drop' stamp: 'mir 5/8/2000 15:38' prior: 56180616! resetPotentialDropMorph potentialDropMorph ifNotNil: [ potentialDropMorph resetHighlightForDrop. potentialDropMorph := nil] ! ! !SimpleHierarchicalListMorph methodsFor: 'selection' stamp: 'mt 11/4/2015 13:58' prior: 56217892! setSelectedMorph: aMorph "Avoid unnecessary model callbacks." self selectedMorph == aMorph ifTrue: [^ self]. model perform: (setSelectionSelector ifNil: [^self]) with: aMorph complexContents "leave last wrapper in place" ! ! !SimpleHierarchicalListMorph methodsFor: 'drag and drop' stamp: 'mt 11/4/2015 18:41' prior: 56194475! startDrag: evt | itemMorph | evt hand hasSubmorphs ifTrue: [^ self]. self model okToChange ifFalse: [^ self]. itemMorph := scroller submorphs detect: [:any | any highlightedForMouseDown] ifNone: [^ self]. "Prepare visuals." itemMorph highlightForMouseDown: false. self setSelectedMorph: itemMorph. [ "Initiate drag." (self model dragPassengerFor: itemMorph inMorph: self) ifNotNil: [:passenger | | ddm | ddm := (self valueOfProperty: #dragTransferClass ifAbsent: [TransferMorph]) withPassenger: passenger from: self. ddm dragTransferType: (self model dragTransferTypeForMorph: self). ddm updateFromUserInputEvent: evt. self model dragStartedFor: itemMorph transferMorph: ddm. evt hand grabMorph: ddm]. ] ensure: [ Cursor normal show. evt hand releaseMouseFocus: self].! ! !SimpleHierarchicalListMorph methodsFor: 'drag and drop' stamp: 'panda 4/25/2000 17:38' prior: 56180843! wantsDroppedMorph: aMorph event: anEvent ^ self model wantsDroppedMorph: aMorph event: anEvent inMorph: self! ! !GradientDisplayMorph methodsFor: 'as yet unclassified' stamp: 'kfr 3/20/2015 11:29'! colorRamp ^self fillStyle colorRamp! ! !GradientDisplayMorph methodsFor: 'as yet unclassified' stamp: 'kfr 3/18/2015 18:50'! colorRamp: aColorRamp self fillStyle colorRamp: aColorRamp! ! !GradientDisplayMorph methodsFor: 'as yet unclassified' stamp: 'kfr 10/27/2015 16:59'! drawOn: aCanvas "Draw a hatch pattern first." aCanvas fillRectangle: self innerBounds fillStyle: (InfiniteForm with: ColorPresenterMorph hatchForm). super drawOn: aCanvas! ! !GradientDisplayMorph methodsFor: 'as yet unclassified' stamp: 'kfr 3/20/2015 16:00'! initialize | fill colorRamp | super initialize. "self hResizing: #spaceFill. " colorRamp := {0.0 -> Color green. 0.3 -> Color red. 0.7 -> Color black. 1.0 -> Color blue}. fill := GradientFillStyle ramp: colorRamp. fill origin: 0@0. fill direction: self bounds extent x @ 0. fill radial: false. self fillStyle: fill! ! !GradientEditor class methodsFor: 'as yet unclassified' stamp: 'kfr 10/21/2015 00:20'! on: aTarget selector: aSelector forMorph: aMorph colorRamp: aColorRamp ^self new setTarget: aTarget selector: aSelector forMorph: aMorph colorRamp: aColorRamp. ! ! !GradientEditor methodsFor: 'initialization' stamp: 'kfr 10/29/2015 12:48'! addButtonRow | button button2 buttonRow button3 | buttonRow := RectangleMorph new borderWidth: 0; color: Color transparent; layoutPolicy: TableLayout new; hResizing: #spaceFil; vResizing: #spaceFill; cellPositioning: #center; listCentering: #topLeft; listDirection: #LeftToRight; reverseTableCells: true; cellInset: 4. button := PluggableButtonMorph on: self getState: nil action: #addHandle label: #addColorButtonLabel. button hResizing: #spaceFill; vResizing: #spaceFill. buttonRow addMorph: button. button2 := PluggableButtonMorph on: self getState: nil action: #deleteHandle label: #removeColorButtonLabel. button2 hResizing: #spaceFill; vResizing: #spaceFill. buttonRow addMorph: button2. button3 := PluggableButtonMorph on: self getState: nil action: #delete label: #closeButtonLabel. button3 hResizing: #spaceFill; vResizing: #spaceFill. buttonRow addMorph: button3. self addMorph: buttonRow! ! !GradientEditor methodsFor: 'initialization' stamp: 'kfr 10/28/2015 13:36'! addColorButtonLabel ^ 'Add color' translated! ! !GradientEditor methodsFor: 'change reporting' stamp: 'kfr 10/27/2015 22:46'! addHandle self addHandleForColor: Color random position: 0.5. self updateColorRamp! ! !GradientEditor methodsFor: 'change reporting' stamp: 'kfr 10/27/2015 22:49'! addHandleForColor: aColor position: aPosition | handleInstance colorIcon delta | handleInstance := self handle. colorIcon := SketchMorph withForm: ((aColor iconOrThumbnailOfSize: 20) borderWidth: 1 color: Color black).. self eventHandler: colorIcon target: colorIcon. self eventHandler: handleInstance target: self. row addMorph: handleInstance. delta := gradientDisplay left - 10 + (gradientDisplay width * aPosition). handleInstance position: delta @ (gradientDisplay top - 18). colorIcon position: delta @ (gradientDisplay bottom + 5). handleInstance addMorph: colorIcon. rampMorphs addLast: handleInstance. ! ! !GradientEditor methodsFor: 'change reporting' stamp: 'kfr 11/1/2015 21:06'! addHandles | handle colorRamp | rampMorphs := OrderedCollection new. colorRamp := gradientDisplay colorRamp asOrderedCollection. handle := self handle. colorRamp do: [:i | self addHandleForColor: i value position: i key ]. self changed.! ! !GradientEditor methodsFor: 'change reporting' stamp: 'kfr 3/23/2015 12:22'! changeColor: aSketchMorph event: evt target: aMorph | newColor | newColor := aSketchMorph rotatedForm colorAt: aSketchMorph rotatedForm center. selectedSketch := aSketchMorph. self changeColorTarget: self selector: #updateColor: originalColor: newColor value hand: evt hand. ! ! !GradientEditor methodsFor: 'initialization' stamp: 'kfr 10/28/2015 13:35'! closeButtonLabel ^ 'Close' translated! ! !GradientEditor methodsFor: 'accessing' stamp: 'kfr 11/1/2015 21:05'! colorRamp ^gradientDisplay fillStyle colorRamp asArray printString. ! ! !GradientEditor methodsFor: 'accessing' stamp: 'kfr 10/31/2015 17:52'! colorRamp: aColorRamp gradientDisplay colorRamp: aColorRamp. self changed: #colorRamp. self changed ! ! !GradientEditor methodsFor: 'accessing' stamp: 'kfr 11/1/2015 21:10'! colorRampExpression: aString "Set my color by evaluating aString, a Smalltalk expression which results in a Color instance." | col | {aString.} detect: [ : each | ([ col := Compiler evaluate: each ] on: Error do: [ : err | nil ]) notNil ] ifNone: [ nil ]. col ifNotNil: [ self colorRamp: col. rampMorphs do:[ :each| each delete]. self addHandles; updateColorRamp. ]! ! !GradientEditor methodsFor: 'initialization' stamp: 'kfr 11/1/2015 21:16'! colorRampExpressionMorph | inputField builder | builder := ToolBuilder default. inputField := (builder build: (builder pluggableInputFieldSpec new model: self; getText: #colorRamp; setText: #colorRampExpression:; softLineWrap: true)). inputField hResizing: #spaceFill ; vResizing: #spaceFill ; height: (Preferences standardDefaultTextFont height * 3/2). ^ inputField! ! !GradientEditor methodsFor: 'change reporting' stamp: 'kfr 10/28/2015 12:14'! deleteHandle rampMorphs do:[ :i | (i color == Color black) ifTrue:[ rampMorphs remove: i. row removeMorph: i]]. self updateColorRamp ! ! !GradientEditor methodsFor: 'event handling' stamp: 'kfr 11/1/2015 21:07'! eventHandler: anInstance target: aTarget (anInstance isKindOf: SketchMorph) ifTrue: [anInstance on: #mouseUp send: #changeColor:event:target: to: self withValue: aTarget] ifFalse: [anInstance on: #mouseDown send: #limitHandleMove:event:from: to: self withValue: aTarget. anInstance on: #mouseMove send: #limitHandleMove:event:from: to: self withValue: aTarget]! ! !GradientEditor methodsFor: 'initialization' stamp: 'kfr 11/1/2015 21:07'! handle | handle | handle := PolygonMorph vertices: (Array with: 0 @ 0 with: 16 @ 0 with: 8 @ 16) color: Color white darker borderWidth: 1 borderColor: Color black. ^ handle addMorph: ((RectangleMorph newBounds: (8 @ 18 extent: 1 @ (gradientDisplay height - 2)) color: Color orange) borderWidth: 0)! ! !GradientEditor methodsFor: 'initialization' stamp: 'kfr 11/1/2015 21:07'! initialize super initialize. self myLayout. self extent: 500 @ 200. row := RectangleMorph new extent: self width @ 100; color: Color transparent; borderColor: #inset. row addMorph: (gradientDisplay := GradientDisplayMorph new position: 20 @ 20; extent: self width - 40 @ 40). gradientDisplay fillStyle direction: gradientDisplay width @ 0. self addMorph: row. self addButtonRow. self addMorph: self colorRampExpressionMorph! ! !GradientEditor methodsFor: 'change reporting' stamp: 'kfr 10/28/2015 12:24'! limitHandleMove: association event: evt from: handle | p newBounds | rampMorphs do:[ : i | i color: (Color white darker)]. newBounds := gradientDisplay bounds. newBounds := (newBounds left: (newBounds left - 10)). newBounds := (newBounds right: (newBounds right - 10)). p := (evt cursorPoint - (10@0)) adhereTo: newBounds. handle position: (p x )@ (handle position y). handle color: Color black. self updateColorRamp! ! !GradientEditor methodsFor: 'accessing' stamp: 'kfr 10/21/2015 00:18'! morph: aMorph ^morph := aMorph! ! !GradientEditor methodsFor: 'initialization' stamp: 'kfr 10/29/2015 12:48'! myLayout self color: (Color white darker) ; cornerStyle: #rounded ; borderWidth: 0; layoutPolicy: TableLayout new; hResizing: #shrinkWrap; vResizing: #shrinkWrap; cellPositioning: #center; listCentering: #topLeft; layoutInset: 4; listDirection: #topToBottom; reverseTableCells: true; wrapCentering: #topLeft; cellInset: 4! ! !GradientEditor methodsFor: 'initialization' stamp: 'kfr 10/28/2015 13:36'! removeColorButtonLabel ^ 'Remove color' translated! ! !GradientEditor methodsFor: 'accessing' stamp: 'kfr 10/19/2015 21:44'! selector: aSelector ^selector := aSelector! ! !GradientEditor methodsFor: 'initialization' stamp: 'kfr 10/31/2015 17:48'! setTarget: aTarget selector: aSelector forMorph:aMorph colorRamp: aColorRamp self target: aTarget; selector: aSelector; morph: aMorph; colorRamp: aColorRamp; addHandles ! ! !GradientEditor methodsFor: 'accessing' stamp: 'kfr 10/19/2015 21:44'! target: aTarget ^target := aTarget! ! !GradientEditor methodsFor: 'change reporting' stamp: 'kfr 3/23/2015 12:17'! updateColor: aColor selectedSketch rotatedForm floodFill: aColor at: selectedSketch rotatedForm center. self updateColorRamp ! ! !GradientEditor methodsFor: 'change reporting' stamp: 'kfr 10/31/2015 11:40'! updateColorRamp | newAssociation newKey newColor sketch colorRamp | self updateRampMorphs. colorRamp := OrderedCollection new. rampMorphs do: [:i | newKey := ((i position x - gradientDisplay left / gradientDisplay width) asFloat roundUpTo: 0.01) min: 1.0 max: 0.0. sketch := i findA: SketchMorph. newColor := sketch rotatedForm colorAt: sketch rotatedForm center. newAssociation := newKey -> newColor. colorRamp addLast: newAssociation]. colorRamp := colorRamp sorted. gradientDisplay colorRamp: colorRamp. gradientDisplay fillStyle direction: gradientDisplay extent x @ 0. self changed. target ifNotNil:[ target perform: selector with: colorRamp with: morph]. self changed: #colorRamp! ! !GradientEditor methodsFor: 'change reporting' stamp: 'kfr 3/27/2015 14:21'! updateRampMorphs rampMorphs do:[ :i | i isInWorld ifFalse:[ rampMorphs remove: i]]! ! !ProportionalSplitterMorph methodsFor: 'events' stamp: 'cmm 10/19/2015 22:17:26' prior: 24839832! mouseDown: anEvent "If the user manually drags me, don't override him with auto positioning." self owningWindow ifNotNil: [ : systemWindow | systemWindow == SystemWindow topWindow ifFalse: [ systemWindow activate ]]. anEvent redButtonChanged ifTrue: [ self withSiblingSplittersDo: [ : each | each stopStepping ] ] ifFalse: [ anEvent shiftPressed ifTrue: [ self startStepping ] ifFalse: [ self startStepping. self withSiblingSplittersDo: [ : each | each startStepping ] ] ]. (self class showSplitterHandles not and: [ self bounds containsPoint: anEvent cursorPoint ]) ifTrue: [ oldColor := self color. self color: Color black ]. ^ super mouseDown: anEvent! ! !ProportionalSplitterMorph methodsFor: 'events' stamp: 'cmm 10/9/2015 14:04' prior: 24850666! updateFromEvent: anEvent | delta | lastMouse ifNil: [ lastMouse := anEvent position ]. delta := splitsTopAndBottom ifTrue: [ 0 @ ((self normalizedY: anEvent cursorPoint y) - lastMouse y) ] ifFalse: [ (self normalizedX: anEvent cursorPoint x) - lastMouse x @ 0 ]. lastMouse := splitsTopAndBottom ifTrue: [ lastMouse x @ (self normalizedY: anEvent cursorPoint y) ] ifFalse: [ (self normalizedX: anEvent cursorPoint x) @ lastMouse y ]. self repositionBy: delta! ! !MorphicProject methodsFor: 'docking bars support' stamp: 'cmm 10/19/2015 14:38' prior: 29247894! createOrUpdateMainDockingBar "Private - create a new main docking bar or update the current one" | w mainDockingBars | w := self world. mainDockingBars := w mainDockingBars. mainDockingBars isEmpty ifTrue: [ "no docking bar, just create a new one" self dockingBar createDockingBar openInWorld: w ; setupGlobalHotKeyEventListeners. ^ self ]. "update if needed" mainDockingBars do: [ : each | self dockingBar updateIfNeeded: each. each setupGlobalHotKeyEventListeners ]! ! TextEditor removeSelector: #undoer:with:with:with:! TextEditor removeSelector: #undoer:with:with:! TextEditor removeSelector: #undoer:with:! TextEditor removeSelector: #undoer:! TextEditor removeSelector: #undoReplace! TextEditor removeSelector: #undoQuery:lastOffering:! TextEditor removeSelector: #undoMessage:forRedo:! TextEditor removeSelector: #undoCutCopy:! TextEditor removeSelector: #undoAndReselect:redoAndReselect:! TextEditor removeSelector: #undoAgain:andReselect:typedKey:! TextEditor removeSelector: #search:! TextEditor removeSelector: #noUndoer! TextEditor removeSelector: #isUndoing! TextEditor removeSelector: #isRedoing! TextEditor removeSelector: #isDoing! TextEditor removeSelector: #duplicate:! TextEditor removeSelector: #doneTyping! TextEditor removeSelector: #doAgainOnce:! TextEditor removeSelector: #doAgainMany:! TextEditor removeSelector: #completeSymbol:lastOffering:! TextEditor removeSelector: #againOrSame:many:! TextEditor removeSelector: #againOrSame:! TextEditor removeSelector: #againOnce:! TransferMorph removeSelector: #stepTime! TransferMorph removeSelector: #step! TransferMorph removeSelector: #shouldCopy:! TransferMorph removeSelector: #privateFullMoveBy:! TransferMorph removeSelector: #move! TransferMorph removeSelector: #initDraggedMorph! TransferMorph removeSelector: #draggedMorph:! TransferMorph removeSelector: #draggedMorph! TransferMorph removeSelector: #delete! HaloMorph removeSelector: #transferHalo:! HaloMorph removeSelector: #target! HaloMorph removeSelector: #staysUpWhenMouseIsDownIn:! HaloMorph removeSelector: #rejectsEvent:! HaloMorph removeSelector: #popUpFor:event:! HaloMorph removeSelector: #handlerForBlueButtonDown:! HaloMorph removeSelector: #growTarget:! HaloMorph removeSelector: #drawOn:! HaloMorph removeSelector: #dragTarget:! !FlapTabTests methodsFor: 'tests' stamp: 'nice 10/31/2015 16:41' prior: 22377491! testFlapTabRecusion | a b tab | "This float is 466.7005813953488" a := (16r1D2B3594D65359 asFloat timesTwoPower: -44). b := 105. self deny: a + b - a = b. tab := Flaps newFlapTitled: 'Test' onEdge: #top. tab left: a. self should: [tab extent: b asPoint] notTakeMoreThanMilliseconds: 10 ! ! "MorphicExtrasTests"! CodeHolder subclass: #Debugger instanceVariableNames: 'interruptedProcess interruptedController contextStack contextStackIndex contextStackList receiverInspector contextVariablesInspector externalInterrupt proceedValue selectingPC savedCursor isolationHead failedProject errorWasInUIProcess labelString message untilExpression' classVariableNames: 'ContextStackKeystrokes ErrorRecursion InterruptUIProcessIfBlockedOnErrorInBackgroundProcess WantsAnnotationPane' poolDictionaries: '' category: 'Tools-Debugger'! !Debugger commentStamp: '' prior: 54792119! I represent the machine state at the time of an interrupted process. I also represent a query path into the state of the process. The debugger is typically viewed through a window that views the stack of suspended contexts, the code for, and execution point in, the currently selected message, and inspectors on both the receiver of the currently selected message, and the variables in the current context. Special note on recursive errors: Some errors affect Squeak's ability to present a debugger. This is normally an unrecoverable situation. However, if such an error occurs in an isolation layer, Squeak will attempt to exit from the isolation layer and then present a debugger. Here is the chain of events in such a recovery. * A recursive error is detected. * The current project is queried for an isolationHead * Changes in the isolationHead are revoked * The parent project of isolated project is returned to * The debugger is opened there and execution resumes. If the user closes that debugger, execution continues in the outer project and layer. If, after repairing some damage, the user proceeds from the debugger, then the isolationHead is re-invoked, the failed project is re-entered, and execution resumes in that world. ! !FileList class methodsFor: 'instance creation' stamp: 'mt 10/22/2015 10:44:49' prior: 57239228! newOn: aDirectory ^super new directory: aDirectory! ! !FileList class methodsFor: 'instance creation' stamp: 'mt 10/22/2015 10:44:44'! openOn: directory ^ToolBuilder open: (self newOn: directory)! ! !FileList methodsFor: 'file list menu' stamp: 'mt 11/13/2015 09:41' prior: 57124009! mainFileContentsMenu: aMenu "Construct aMenu to have items appropriate for the file browser's code pane, for the unshifted state" ^ aMenu addTranslatedList: #( ('find... (f)' find) ('find again (g)' findAgain) ('find and replace... ' findReplace) ('do/replace again (j)' again) - ('undo (z)' undo) ('redo (Z)' redo) - ('copy (c)' copySelection) ('cut (x)' cut) ('paste (v)' paste) ('paste...' pasteRecent) - ('do it (d)' doIt) ('print it (p)' printIt) ('inspect it (i)' inspectIt) ('fileIn selection (G)' fileItIn) - ('accept (s)' accept) ('cancel (l)' cancel) - ('more...' shiftedYellowButtonActivity)); yourself ! ! !CodeHolder methodsFor: 'message list menu' stamp: 'cmm 10/19/2015 15:58:51' prior: 23088040! messageListKey: aChar from: view "Respond to a Command key. I am a model with a code pane, and I also have a listView that has a list of methods. The view knows how to get the list and selection." | sel class | aChar == $D ifTrue: [^ self toggleDiffing]. sel := self selectedMessageName. aChar == $m ifTrue: "These next two put up a type in if no message selected" [^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllImplementorsOf: to: self ]. aChar == $n ifTrue: [^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllCallsOn: to: self ]. aChar == $d ifTrue: [^ self removeMessageFromBrowser]. "The following require a class selection" (class := self selectedClassOrMetaClass) ifNil: [^ self arrowKey: aChar from: view]. aChar == $b ifTrue: [^ Browser fullOnClass: class selector: sel]. aChar == $N ifTrue: [^ self browseClassRefs]. aChar == $i ifTrue: [^ self methodHierarchy]. aChar == $h ifTrue: [^ self classHierarchy]. aChar == $p ifTrue: [^ self browseFullProtocol]. aChar == $r ifTrue: [^ self browseVariableReferences]. aChar == $a ifTrue: [^ self browseVariableAssignments]. "The following require a method selection" sel ifNotNil: [aChar == $o ifTrue: [^ self fileOutMessage]. aChar == $c ifTrue: [^ self copySelector]. aChar == $v ifTrue: [^ self browseVersions]. aChar == $x ifTrue: [^ self removeMessage]. aChar == $C ifTrue: [ self copyReference ]. (aChar == $Y and: [self canShowMultipleMessageCategories]) ifTrue: [^ self showHomeCategory]]. ^ self arrowKey: aChar from: view! ! !Debugger class methodsFor: 'preferences' stamp: 'cmm 11/10/2015 19:39'! wantsAnnotationPane ^ WantsAnnotationPane ifNil: [false]! ! !Debugger class methodsFor: 'preferences' stamp: 'mt 11/10/2015 13:35'! wantsAnnotationPane: boolean WantsAnnotationPane := boolean.! ! !Debugger methodsFor: 'toolbuilder' stamp: 'mt 11/11/2015 11:19'! buildCodePaneWith: builder | textSpec top controlButtons browseButtons annoSpec | top := builder pluggablePanelSpec new. top children: OrderedCollection new. controlButtons := self buildControlButtonsWith: builder. controlButtons frame: self controlButtonsFrame. top children add: controlButtons. self wantsOptionalButtons ifTrue: [ browseButtons := self buildOptionalButtonsWith: builder. browseButtons frame: self optionalButtonsFrame. top children add: browseButtons]. textSpec := builder pluggableCodePaneSpec new. textSpec model: self; getText: #contents; setText: #contents:notifying:; selection: #contentsSelection; menu: #codePaneMenu:shifted:; frame: self textFrame. top children add: textSpec. self wantsAnnotationPane ifTrue: [ annoSpec := self buildAnnotationPaneWith: builder. annoSpec frame: self annotationFrame. top children add: annoSpec]. . ^ top! ! !Debugger methodsFor: 'toolbuilder' stamp: 'mt 11/11/2015 11:09'! buildControlButtonsWith: builder | panelSpec | panelSpec := builder pluggablePanelSpec new. panelSpec children: OrderedCollection new. self customButtonSpecs do:[:spec| | buttonSpec | buttonSpec := builder pluggableActionButtonSpec new. buttonSpec model: self. buttonSpec label: spec first. buttonSpec action: spec second. spec second == #methodHierarchy ifTrue:[ buttonSpec color: #inheritanceButtonColor. ]. spec size > 2 ifTrue:[buttonSpec help: spec third]. panelSpec children add: buttonSpec. ]. panelSpec layout: #horizontal. "buttons" ^panelSpec! ! !Debugger methodsFor: 'toolbuilder' stamp: 'mt 11/6/2015 11:57' prior: 54879757! buildFullWith: builder | windowSpec listSpec textSpec | windowSpec := builder pluggableWindowSpec new model: self; label: 'Debugger'; children: OrderedCollection new. listSpec := builder pluggableListSpec new. listSpec model: self; list: #contextStackList; getIndex: #contextStackIndex; setIndex: #toggleContextStackIndex:; menu: #contextStackMenu:shifted:; icon: #messageIconAt:; help: #messageHelpAt:; keyPress: #contextStackKey:from:; frame: (0@0 corner: 1@0.22). windowSpec children add: listSpec. textSpec := self buildCodePaneWith: builder. textSpec frame: (0@0.22corner: 1@0.8). windowSpec children add: textSpec. listSpec := builder pluggableListSpec new. listSpec model: self receiverInspector; list: #fieldList; getIndex: #selectionIndex; setIndex: #toggleIndex:; menu: #fieldListMenu:; keyPress: #inspectorKey:from:; frame: (0@0.8 corner: 0.2@1). windowSpec children add: listSpec. textSpec := builder pluggableTextSpec new. textSpec model: self receiverInspector; getText: #contents; setText: #accept:; help: '<- Select receiver''s field' translated; selection: #contentsSelection; menu: #codePaneMenu:shifted:; frame: (0.2@0.8 corner: 0.5@1). windowSpec children add: textSpec. listSpec := builder pluggableListSpec new. listSpec model: self contextVariablesInspector; list: #fieldList; getIndex: #selectionIndex; setIndex: #toggleIndex:; menu: #fieldListMenu:; keyPress: #inspectorKey:from:; frame: (0.5@0.8 corner: 0.7@1). windowSpec children add: listSpec. textSpec := builder pluggableTextSpec new. textSpec model: self contextVariablesInspector; getText: #contents; setText: #accept:; help: '<- Select context''s field' translated; selection: #contentsSelection; menu: #codePaneMenu:shifted:; frame: (0.7@0.8 corner: 1@1). windowSpec children add: textSpec. ^builder build: windowSpec! ! !Debugger methodsFor: 'toolbuilder' stamp: 'mt 11/6/2015 11:57' prior: 54893313! buildNotifierWith: builder label: label message: messageString | windowSpec listSpec textSpec panelSpec quads | windowSpec := builder pluggableWindowSpec new model: self; extent: self initialExtentForNotifier; label: label; children: OrderedCollection new. panelSpec := builder pluggablePanelSpec new. panelSpec children: OrderedCollection new. quads := self preDebugButtonQuads. (self interruptedContext selector == #doesNotUnderstand:) ifTrue: [ quads := quads copyWith: { 'Create'. #createMethod. #magenta. 'create the missing method' } ]. (#(#notYetImplemented #shouldBeImplemented #requirement) includes: self interruptedContext selector) ifTrue: [ quads := quads copyWith: { 'Create'. #createImplementingMethod. #magenta. 'implement the marked method' } ]. (self interruptedContext selector == #subclassResponsibility) ifTrue: [ quads := quads copyWith: { 'Create'. #createOverridingMethod. #magenta. 'create the missing overriding method' } ]. quads do:[:spec| | buttonSpec | buttonSpec := builder pluggableButtonSpec new. buttonSpec model: self. buttonSpec label: spec first. buttonSpec action: spec second. buttonSpec help: spec fourth. panelSpec children add: buttonSpec. ]. panelSpec layout: #horizontal. "buttons" panelSpec frame: self preDebugButtonQuadFrame. windowSpec children add: panelSpec. Preferences eToyFriendly | messageString notNil ifFalse:[ listSpec := builder pluggableListSpec new. listSpec model: self; list: #contextStackList; getIndex: #contextStackIndex; setIndex: #debugAt:; icon: #messageIconAt:; help: #messageHelpAt:; frame: self contextStackFrame. windowSpec children add: listSpec. ] ifTrue:[ message := messageString. textSpec := builder pluggableTextSpec new. textSpec model: self; getText: #preDebugMessageString; setText: nil; selection: nil; menu: #debugProceedMenu:; frame: self contextStackFrame. windowSpec children add: textSpec. ]. ^windowSpec! ! !Debugger methodsFor: 'toolbuilder' stamp: 'mt 11/11/2015 11:32' prior: 54896267! contextStackFrame ^LayoutFrame new leftFraction: 0 offset: 0; topFraction: 0 offset: self buttonHeight; rightFraction: 1 offset: 0; bottomFraction: 1 offset: 0! ! !Debugger methodsFor: 'toolbuilder' stamp: 'mt 11/11/2015 11:18'! controlButtonsFrame ^LayoutFrame new leftFraction: 0 offset: 0; topFraction: 0 offset: 0; rightFraction: 1 offset: 0; bottomFraction: 0 offset: self buttonHeight! ! !Debugger methodsFor: 'context stack (message list)' stamp: 'mt 11/6/2015 12:01'! messageHelpAt: anIndex "Show the first n lines of the sources code of the selected message." | method source formatted lineCount | Preferences balloonHelpInMessageLists ifFalse: [^ nil]. contextStack size < anIndex ifTrue: [^ nil]. method := (contextStack at: anIndex) method. source := method getSource. formatted := SHTextStylerST80 new classOrMetaClass: method methodClass; styledTextFor: source asText. lineCount := 0. source doWithIndex: [:char :index | char = Character cr ifTrue: [lineCount := lineCount + 1]. lineCount > 10 ifTrue: [ formatted := formatted copyFrom: 1 to: index-1. formatted append: ' [...]'. ^ formatted]]. ^ formatted! ! !Debugger methodsFor: 'context stack (message list)' stamp: 'mt 11/6/2015 12:01'! messageIconAt: anIndex Browser showMessageIcons ifFalse: [^ nil]. ^ ToolIcons iconNamed: (ToolIcons iconForClass: (contextStack at: anIndex) method methodClass selector: (contextStack at: anIndex) method selector)! ! !Debugger methodsFor: 'toolbuilder' stamp: 'mt 11/11/2015 11:20'! optionalButtonsFrame ^LayoutFrame new leftFraction: 0 offset: 0; topFraction: 0 offset: self buttonHeight; rightFraction: 1 offset: 0; bottomFraction: 0 offset: self buttonHeight*2! ! !Debugger methodsFor: 'context stack menu' stamp: 'cmm 10/16/2015 14:15' prior: 54850463! shiftedContextStackMenu: aMenu "Set up the menu appropriately for the context-stack-list, shifted" ^ aMenu addList: #( ('browse class hierarchy' classHierarchy) ('browse class' browseClass) ('implementors of sent messages' browseAllMessages) ('change sets with this method' findMethodInChangeSets) - ('inspect instances' inspectInstances) ('inspect subinstances' inspectSubInstances) - ('revert to previous version' revertToPreviousVersion) ('remove from current change set' removeFromCurrentChanges) ('revert & remove from changes' revertAndForget)); yourself ! ! !Debugger methodsFor: 'toolbuilder' stamp: 'mt 11/11/2015 11:24'! textFrame ^ super textFrame topOffset: (self wantsOptionalButtons ifTrue: [self buttonHeight * 2] ifFalse: [self buttonHeight]); yourself! ! !Debugger methodsFor: 'toolbuilder' stamp: 'mt 11/10/2015 13:35' prior: 54897341! wantsAnnotationPane ^ self class wantsAnnotationPane! ! !Debugger methodsFor: 'toolbuilder' stamp: 'mt 11/11/2015 11:09' prior: 54871708! wantsOptionalButtons "The debugger benefits so majorly from the optional buttons that we put them up regardless of the global setting. Some traditionalists will want to change this method manually!!" ^ Preferences extraDebuggerButtons! ! !ChangeSorter methodsFor: 'message list' stamp: 'cmm 10/16/2015 14:14' prior: 25515653! unshiftedMessageMenu: aMenu "Fill aMenu with items appropriate for the message list; could be for a single or double changeSorter" aMenu title: 'message list'. aMenu addStayUpItemSpecial. parent ifNotNil: [aMenu addList: #( ('copy method to other side' copyMethodToOther) ('move method to other side' moveMethodToOther))]. aMenu addList: #( ('delete method from changeSet (d)' forget) - ('remove method from system (x)' removeMessage) - ('browse full (b)' browseMethodFull) ('browse hierarchy (h)' spawnHierarchy) ('browse protocol (p)' browseFullProtocol) - ('fileOut' fileOutMessage) ('printOut' printOutMessage) - ('senders of... (n)' browseSendersOfMessages) ('implementors of... (m)' browseMessages) ('inheritance (i)' methodHierarchy) ('versions (v)' browseVersions)). ^ aMenu ! ! !PasteUpMorph methodsFor: '*Tools' stamp: 'cmm 10/19/2015 15:24:47' prior: 61553487! defaultDesktopCommandKeyTriplets "Answer a list of triplets of the form [+ optional fourth element, a for use in desktop-command-key-help] that will provide the default desktop command key handlers. If the selector takes an argument, that argument will be the command-key event" | noviceKeys expertKeys | noviceKeys := { { $o. ActiveWorld. #activateObjectsTool. 'Activate the "Objects Tool"'}. { $r. ActiveWorld. #restoreMorphicDisplay. 'Redraw the screen'}. { $z. self. #undoOrRedoCommand. 'Undo or redo the last undoable command'}. { $F. Project current. #toggleFlapsSuppressed. 'Toggle the display of flaps'}. { $N. self. #toggleClassicNavigatorIfAppropriate. 'Show/Hide the classic Navigator, if appropriate'}. { $M. self. #toggleShowWorldMainDockingBar. 'Show/Hide the Main Docking Bar'}. { $]. Smalltalk. #saveSession. 'Save the image.'}. }. Preferences noviceMode ifTrue:[^ noviceKeys]. expertKeys := { { $b. SystemBrowser. #defaultOpenBrowser. 'Open a new System Browser'}. { $k. StringHolder. #open. 'Open a new, blank Workspace'}. { $m. self. #putUpNewMorphMenu. 'Put up the "New Morph" menu'}. { $O. self. #findAMonticelloBrowser. 'Bring a Monticello window into focus.'}. { $t. self. #findATranscript:. 'Make a System Transcript visible'}. { $w. SystemWindow. #closeTopWindow. 'Close the topmost window'}. { Character escape. SystemWindow. #closeTopWindow. 'Close the topmost window'}. { $C. self. #findAChangeSorter:. 'Make a Change Sorter visible'}. { $L. self. #findAFileList:. 'Make a File List visible'}. { $P. self. #findAPreferencesPanel:. 'Activate the Preferences tool'}. { $R. Utilities. #browseRecentSubmissions. 'Make a Recent Submissions browser visible'}. { $W. self. #findAMessageNamesWindow:. 'Make a MessageNames tool visible'}. { $Z. ChangeList. #browseRecentLog. 'Browse recently-logged changes'}. { $\. SystemWindow. #sendTopWindowToBack. 'Send the top window to the back'}. { $_. Smalltalk. #quitPrimitive. 'Quit the image immediately.'}. }. ^ noviceKeys, expertKeys ! ! !InspectorBrowser methodsFor: 'as yet unclassified' stamp: 'mt 11/13/2015 09:40' prior: 65151848! msgPaneMenu: aMenu shifted: shifted ^ aMenu labels: 'find... (f) find again (g) find and replace... do/replace again (j) undo (z) redo (Z) copy (c) cut (x) paste (v) do it (d) print it (p) inspect it (i) accept (s) cancel (l)' lines: #(0 4 6 9 12) selections: #(find findAgain findReplace again undo redo copySelection cut paste doIt printIt inspectIt accept cancel)! ! !VersionsBrowser methodsFor: 'menu' stamp: 'cmm 10/16/2015 14:29' prior: 33176519! mainVersionsMenu: aMenu "Fill aMenu with menu items appropriate to the receiver" aMenu addTranslatedList: #( ('remove from changes' removeMethodFromChanges 'remove this method from the current change set, if present') ('find original change set' findOriginalChangeSet 'locate the changeset which originally contained this version') - ('toggle diffing (D)' toggleDiffing 'toggle whether or not diffs should be shown here') ('update list' reformulateList 'reformulate the list of versions, in case it somehow got out of synch with reality') - ('senders (n)' browseSenders 'browse all senders of this selector') ('implementors (m)' browseImplementors 'browse all implementors of this selector') ('inheritance (i)' methodHierarchy 'browse method inheritance') - ('help...' offerVersionsHelp 'provide an explanation of the use of this tool')). ^aMenu! ! !FileDirectory class methodsFor: '*Tools-FileList' stamp: 'mt 10/22/2015 10:45:06'! serviceBrowseDirectory ^ (SimpleServiceEntry provider: FileList label: 'browse directory' selector: #openOn: description: 'browse directory' buttonLabel: 'browse') argumentGetter: [:directory | directory]; yourself! ! !StringHolder class methodsFor: '*Tools-yellow button menu' stamp: 'mt 11/13/2015 09:41' prior: 21122995! yellowButtonMenuItems "Returns the standard yellow button menu items" ^{ #-. {'set font... (k)' translated. #offerFontMenu}. {'set style... (K)' translated. #changeStyle}. {'set alignment... (u)' translated. #chooseAlignment}. #-. {'make project link (P)' translated. #makeProjectLink}. #-. {'find...(f)' translated. #find}. {'find again (g)' translated. #findAgain}. {'find and replace ...' translated. #findReplace}. {'do/replace again (j)' translated. #again}. #-. {'undo (z)' translated. #undo}. {'redo (Z)' translated. #redo}. #-. {'copy (c)' translated. #copySelection}. {'cut (x)' translated. #cut}. {'paste (v)' translated. #paste}. {'paste...' translated. #pasteRecent}. #-. {'do it (d)' translated. #doIt}. {'debug it (D)' translated. #debugIt}. {'print it (p)' translated. #printIt}. {'inspect it (i)' translated. #inspectIt}. {'explore it (I)' translated. #exploreIt}. {'button for it' translated. #buttonForIt}. {'tally it' translated. #tallyIt}. {'spy on it' translated. #spyOnIt}. #-. {'accept (s)' translated. #accept}. {'cancel (l)' translated. #cancel}. #-. {'show bytecodes' translated. #showBytecodes}. #-. {'copy html' translated. #copyHtml}. #-. {'more...' translated. #shiftedTextPaneMenuRequest}. }! ! !StringHolder methodsFor: '*Tools' stamp: 'cmm 10/19/2015 16:10:48' prior: 21076152! messageListKey: aChar from: view "Respond to a Command key. I am a model with a code pane, and I also have a listView that has a list of methods. The view knows how to get the list and selection." | sel class | aChar == $D ifTrue: [^ self toggleDiffing]. sel := self selectedMessageName. aChar == $m ifTrue: "These next two put up a type in if no message selected" [^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllImplementorsOf: to: self systemNavigation]. aChar == $n ifTrue: [^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllCallsOn: to: self systemNavigation]. "The following require a class selection" (class := self selectedClassOrMetaClass) ifNil: [^ self arrowKey: aChar from: view]. aChar == $b ifTrue: [^ Browser fullOnClass: class selector: sel]. aChar == $N ifTrue: [^ self browseClassRefs]. aChar == $i ifTrue: [^ self methodHierarchy]. aChar == $h ifTrue: [^ self classHierarchy]. aChar == $p ifTrue: [^ self browseFullProtocol]. "The following require a method selection" sel ifNotNil: [aChar == $o ifTrue: [^ self fileOutMessage]. aChar == $c ifTrue: [^ self copySelector]. aChar == $C ifTrue: [^ self copyReference]. aChar == $v ifTrue: [^ self browseVersions]. aChar == $x ifTrue: [^ self removeMessage]]. ^ self arrowKey: aChar from: view! ! !MessageTrace methodsFor: 'private initializing' stamp: 'mt 11/6/2015 11:38' prior: 26534042! buildMessageListWith: builder | listSpec | listSpec := builder pluggableAlternateMultiSelectionListSpec new. listSpec model: self ; list: #messageList ; getIndex: #messageListIndex ; setIndex: #toggleSelectionAt:shifted:controlled: ; icon: #messageIconAt:; help: #messageHelpAt:; menu: #messageListMenu:shifted: ; getSelectionList: #isMessageSelectedAt: ; setSelectionList: #messageAt:beSelected: ; keyPress: #messageListKey:from:. SystemBrowser browseWithDragNDrop ifTrue: [ listSpec dragItem: #dragFromMessageList: ]. ^ listSpec! ! !MessageTrace methodsFor: 'actions' stamp: 'cmm 10/16/2015 14:12' prior: 26527704! deselectAll super deselectAll. 1 to: messageSelections size do: [ :index | messageSelections at: index put: false ] ! ! !MessageSet methodsFor: 'toolbuilder' stamp: 'mt 11/6/2015 11:35' prior: 29116152! buildMessageListWith: builder | listSpec | listSpec := builder pluggableListSpec new. listSpec model: self; list: #messageList; getIndex: #messageListIndex; setIndex: #messageListIndex:; icon: #messageIconAt:; help: #messageHelpAt:; menu: #messageListMenu:shifted:; keyPress: #messageListKey:from:. SystemBrowser browseWithDragNDrop ifTrue:[listSpec dragItem: #dragFromMessageList:]. ^listSpec ! ! !MessageSet methodsFor: 'private' stamp: 'cmm 10/16/2015 14:30'! deselectAll self messageListIndex: 0! ! !MessageSet methodsFor: 'message functions' stamp: 'cmm 10/16/2015 14:16' prior: 29094149! mainMessageListMenu: aMenu "Answer the message-list menu" aMenu addList: #( ('what to show...' offerWhatToShowMenu) ('toggle break on entry' toggleBreakOnEntry) - ('browse full (b)' browseMethodFull) ('browse hierarchy (h)' classHierarchy) ('browse protocol (p)' browseFullProtocol) - ('fileOut' fileOutMessage) ('printOut' printOutMessage) ('copy selector (c)' copySelector) ('copy reference (C)' copyReference) - ('senders of... (n)' browseSendersOfMessages) ('implementors of... (m)' browseMessages) ('inheritance (i)' methodHierarchy) ('versions (v)' browseVersions) - ('references... (r)' browseVariableReferences) ('assignments... (a)' browseVariableAssignments) ('class refs (N)' browseClassRefs) - ('remove method (x)' removeMessage) ('explore method' exploreMethod) ('inspect method' inspectMethod)). ^ aMenu! ! !MessageSet methodsFor: 'message list' stamp: 'mt 11/6/2015 11:49'! messageHelpAt: anIndex "Show the first n lines of the sources code of the selected message." | reference source formatted lineCount | Preferences balloonHelpInMessageLists ifFalse: [^ nil]. self messageList size < anIndex ifTrue: [^ nil]. reference := self messageList at: anIndex. reference isValid ifFalse: [^ nil]. source := reference compiledMethod getSource. formatted := SHTextStylerST80 new classOrMetaClass: reference actualClass; styledTextFor: source asText. lineCount := 0. source doWithIndex: [:char :index | char = Character cr ifTrue: [lineCount := lineCount + 1]. lineCount > 10 ifTrue: [ formatted := formatted copyFrom: 1 to: index-1. formatted append: ' [...]'. ^ formatted]]. ^ formatted! ! !MessageSet methodsFor: 'message list' stamp: 'mt 11/6/2015 11:47'! messageIconAt: anIndex Browser showMessageIcons ifFalse: [^ nil]. ^ ToolIcons iconNamed: (ToolIcons iconForClass: (self messageList at: anIndex) actualClass selector: (self messageList at: anIndex) selector)! ! !ObjectExplorer methodsFor: 'accessing - other' stamp: 'topa 10/8/2015 20:56' prior: 24140988! selector self isThisEverCalled. self flag: #deprecated. "mt: Who uses this? And why?" self parentObject ifNil: [^ nil]. (self parentObject class allInstVarNames includes: self currentSelection key) ifTrue: [^ self currentSelection key asSymbol]. ^ nil! ! !ChangeList methodsFor: 'viewing access' stamp: 'mt 10/21/2015 09:10:18' prior: 23604642! diffedVersionContents "Answer diffed version contents, maybe pretty maybe not" | change class earlier later | (listIndex = 0 or: [changeList size < listIndex]) ifTrue: [^ '']. change := changeList at: listIndex. later := change text. class := change methodClass. (listIndex == changeList size or: [class == nil]) ifTrue: [^ (self showingPrettyDiffs and: [class notNil]) ifTrue: [class prettyPrinterClass format: later in: class notifying: nil] ifFalse: [later]]. earlier := (changeList at: listIndex + 1) text. ^ TextDiffBuilder buildDisplayPatchFrom: earlier to: later inClass: class prettyDiffs: self showingPrettyDiffs! ! !Browser methodsFor: 'toolbuilder' stamp: 'mt 11/6/2015 10:14' prior: 62879545! buildMessageListWith: builder | listSpec | listSpec := builder pluggableListSpec new. listSpec model: self; list: #messageList; getIndex: #messageListIndex; setIndex: #messageListIndex:; icon: #messageIconAt:; help: #messageHelpAt:; menu: #messageListMenu:shifted:; keyPress: #messageListKey:from:. SystemBrowser browseWithDragNDrop ifTrue:[listSpec dragItem: #dragFromMessageList:]. ^listSpec ! ! !Browser methodsFor: 'message functions' stamp: 'cmm 11/11/2015 15:46' prior: 62812563! defineMessageFrom: aString notifying: aController "Compile the expressions in aString. Notify aController if a syntax error occurs. Install the compiled method in the selected class classified under the currently selected message category name. Answer the selector obtained if compilation succeeds, nil otherwise." | selectedMessageName selector category oldMessageList selectedClassOrMetaClass | selectedMessageName := self selectedMessageName. oldMessageList := self messageList. selectedClassOrMetaClass := self selectedClassOrMetaClass. contents := nil. selector := (selectedClassOrMetaClass newParser parseSelector: aString). (self metaClassIndicated and: [(selectedClassOrMetaClass includesSelector: selector) not and: [Metaclass isScarySelector: selector]]) ifTrue: ["A frist-time definition overlaps the protocol of Metaclasses" (self confirm: ((selector , ' is used in the existing class system. Overriding it could cause serious problems. Is this really what you want to do?') asText makeBoldFrom: 1 to: selector size)) ifFalse: [^nil]]. selector := selectedClassOrMetaClass compile: aString classified: (selectedMessageName ifNotNil: [category := (selectedClassOrMetaClass >> selectedMessageName) methodReference ifNotNil: [ : ref | ref category ]]) notifying: aController. selector == nil ifTrue: [^ nil]. contents := aString copy. selector ~~ selectedMessageName ifTrue: [category = ClassOrganizer nullCategory ifTrue: [self changed: #classSelectionChanged. self changed: #classList. self messageCategoryListIndex: 1]. self setClassOrganizer. "In case organization not cached" (oldMessageList includes: selector) ifFalse: [self changed: #messageList]. self messageListIndex: (self messageList indexOf: selector)]. ^ selector! ! !Browser methodsFor: 'message functions' stamp: 'cmm 10/16/2015 14:14' prior: 62815594! mainMessageListMenu: aMenu ^ aMenu addList: #( ('what to show...' offerWhatToShowMenu) ('toggle break on entry' toggleBreakOnEntry) - ('browse full (b)' browseMethodFull) ('browse hierarchy (h)' classHierarchy) ('browse protocol (p)' browseFullProtocol) - ('fileOut' fileOutMessage) ('printOut' printOutMessage) ('copy selector (c)' copySelector) ('copy reference (C)' copyReference) - ('senders of... (n)' browseSendersOfMessages) ('implementors of... (m)' browseMessages) ('inheritance (i)' methodHierarchy) ('versions (v)' browseVersions) - ('references... (r)' browseVariableReferences) ('assignments... (a)' browseVariableAssignments) ('class refs (N)' browseClassRefs) - ('remove method (x)' removeMessage) ('explore method' exploreMethod) ('inspect method' inspectMethod)); yourself ! ! !Browser methodsFor: 'message list' stamp: 'mt 11/6/2015 11:25'! messageHelpAt: anIndex "Show the first n lines of the sources code of the selected message." | source formatted lineCount | Preferences balloonHelpInMessageLists ifFalse: [^ nil]. self messageList size < anIndex ifTrue: [^ nil]. source := (self selectedClassOrMetaClass >> (self messageList at: anIndex)) getSource. formatted := SHTextStylerST80 new classOrMetaClass: self selectedClassOrMetaClass; styledTextFor: source asText. lineCount := 0. source doWithIndex: [:char :index | char = Character cr ifTrue: [lineCount := lineCount + 1]. lineCount > 10 ifTrue: [ formatted := formatted copyFrom: 1 to: index-1. formatted append: ' [...]'. ^ formatted]]. ^ formatted! ! StringHolder removeSelector: #openSingleMessageBrowser! ClassCommentVersionsBrowser removeSelector: #openSingleMessageBrowser! Debugger removeSelector: #optionalButtonPairs! "Tools"! !PreferenceBrowserMorph methodsFor: 'submorphs - preference list' stamp: 'kfr 11/6/2015 16:45' prior: 50915533! turnOnSelectedPreference highlightedPreferenceButton = self selectedPreferenceButton ifTrue: [ highlightedPreferenceButton highlightOff. ^self turnOffSelectedPreference]. highlightedPreferenceButton ifNotNil: [:m | m highlightOff]. highlightedPreferenceButton := self selectedPreferenceButton highlightOn; yourself. self preferenceList scrollToShow: highlightedPreferenceButton bounds.! ! !PreferenceBrowserMorph methodsFor: 'updating' stamp: 'kfr 11/6/2015 16:45' prior: 50921037! updateSelectedPreference | index | index := self selectedPreferenceIndex. index = 0 ifTrue: [^self]. self turnOnSelectedPreference.! ! "PreferenceBrowser"! !Lexicon methodsFor: 'menu commands' stamp: 'cmm 10/16/2015 14:16' prior: 54633602! offerMenu "Offer a menu to the user, in response to the hitting of the menu button on the tool pane" | aMenu | aMenu := MenuMorph new defaultTarget: self. aMenu addTitle: 'Lexicon'. aMenu addStayUpItem. aMenu addList: #( ('vocabulary...' chooseVocabulary) ('what to show...' offerWhatToShowMenu) - ('inst var refs (here)' setLocalInstVarRefs) ('inst var assignments (here)' setLocalInstVarDefs) ('class var refs (here)' setLocalClassVarRefs) - ('navigate to a sender...' navigateToASender) ('recent...' navigateToRecentMethod) ('show methods in current change set' showMethodsInCurrentChangeSet) ('show methods with initials...' showMethodsWithInitials) - "('toggle search pane' toggleSearch)" - ('browse full (b)' browseMethodFull) ('browse hierarchy (h)' classHierarchy) ('browse protocol (p)' browseFullProtocol) - ('fileOut' fileOutMessage) ('printOut' printOutMessage) - ('senders of... (n)' browseSendersOfMessages) ('implementors of... (m)' browseMessages) ('versions (v)' browseVersions) ('inheritance (i)' methodHierarchy) - ('references... (r)' browseVariableReferences) ('assignments... (a)' browseVariableAssignments) - ('more...' shiftedYellowButtonActivity)). aMenu popUpInWorld: ActiveWorld! ! !Lexicon methodsFor: 'category list' stamp: 'topa 10/19/2015 23:02:15' prior: 54605158! selectWithinCurrentCategoryIfPossible: aSelector "If the receiver's message list contains aSelector, navigate right to it without changing categories" | detectedItem messageIndex | aSelector ifNil: [^ self]. detectedItem := messageList detect: [:anItem | (anItem asString copyUpTo: $ ) asSymbol == aSelector] ifNone: [^ self]. messageIndex := messageList indexOf: detectedItem. self messageListIndex: messageIndex ! ! !InstanceBrowser methodsFor: 'menu commands' stamp: 'cmm 10/16/2015 14:15' prior: 23911041! offerMenu "Offer a menu to the user, in response to the hitting of the menu button on the tool pane" | aMenu | aMenu := MenuMorph new defaultTarget: self. aMenu title: 'Messages of ', objectViewed nameForViewer. aMenu addStayUpItem. aMenu addList: #( ('vocabulary...' chooseVocabulary) ('what to show...' offerWhatToShowMenu) - ('inst var refs (here)' setLocalInstVarRefs) ('inst var defs (here)' setLocalInstVarDefs) ('class var refs (here)' setLocalClassVarRefs) - ('navigate to a sender...' navigateToASender) ('recent...' navigateToRecentMethod) ('show methods in current change set' showMethodsInCurrentChangeSet) ('show methods with initials...' showMethodsWithInitials) - "('toggle search pane' toggleSearch)" - - ('browse full (b)' browseMethodFull) ('browse hierarchy (h)' classHierarchy) ('browse protocol (p)' browseFullProtocol) - ('fileOut' fileOutMessage) ('printOut' printOutMessage) - ('senders of... (n)' browseSendersOfMessages) ('implementors of... (m)' browseMessages) ('versions (v)' browseVersions) ('inheritance (i)' methodHierarchy) - ('references... (r)' browseVariableReferences) ('assignments... (a)' browseVariableAssignments) - ('viewer on me' viewViewee) ('inspector on me' inspectViewee) - ('more...' shiftedYellowButtonActivity)). aMenu popUpInWorld: ActiveWorld! ! "Protocols"! !SMLoaderPlus methodsFor: 'interface' stamp: 'mt 11/4/2015 10:38' prior: 27263676! buildCategoriesListWith: aBuilder "Create the hierarchical list holding the category tree." ^ aBuilder pluggableTreeSpec new model: self; roots: #categoryList; getSelectedPath: #selectedCategoryPath; getChildren: #categoryChildren:; hasChildren: #categoryHasChildren:; setSelected: #selectedCategory:; getSelected: #selectedCategory; menu: #categoriesMenu:; label: #categoryLabel:; autoDeselect: true; name: #categoriesList; yourself! ! !SMLoaderPlus methodsFor: 'interface' stamp: 'mt 11/4/2015 10:38' prior: 27265353! buildPackagesListWith: aBuilder "Create the hierarchical list holding the packages and releases." ^ aBuilder pluggableTreeSpec new model: self; roots: #packageList; getSelectedPath: #selectedItemPath; getSelected: #selectedItem; setSelected: #selectedItem:; menu: #packagesMenu:; label: #itemLabel:; getChildren: #itemChildren:; hasChildren: #itemHasChildren:; autoDeselect: true; name: #packagesList; yourself! ! !SMLoaderCategoricalPlus methodsFor: 'DEPRECATED' stamp: 'mt 11/4/2015 10:38' prior: 20035966! buildInstalledPackagesListWith: aBuilder ^ aBuilder pluggableTreeSpec new model: self; roots: #installedPackageList; getSelectedPath: #selectedItemPath; getSelected: #selectedItem; setSelected: #selectedItem:; menu: #packagesMenu:; label: #itemLabel:; getChildren: #itemChildren:; hasChildren: #itemHasChildren:; autoDeselect: true; yourself! ! !SMLoaderCategoricalPlus methodsFor: 'DEPRECATED' stamp: 'mt 11/4/2015 10:38' prior: 20036909! buildNotInstalledPackagesListWith: aBuilder ^ aBuilder pluggableTreeSpec new model: self; roots: #notInstalledPackageList; getSelectedPath: #selectedItemPath; getSelected: #selectedItem; setSelected: #selectedItem:; menu: #packagesMenu:; label: #itemLabel:; getChildren: #itemChildren:; hasChildren: #itemHasChildren:; autoDeselect: true; yourself! ! "SMLoader"! !Debugger methodsFor: '*ST80-opening' stamp: 'topa 10/20/2015 08:36:19' prior: 54917529! mvcResumeProcess: aTopView aTopView erase. savedCursor ifNotNil: [Cursor currentCursor: savedCursor]. interruptedProcess isTerminated ifFalse: [ ScheduledControllers activeControllerNoTerminate: interruptedController andProcess: interruptedProcess]. "if old process was terminated, just terminate current one" interruptedProcess := nil. "Before delete, so release doesn't terminate it" aTopView controller closeAndUnscheduleNoErase. Smalltalk installLowSpaceWatcher. "restart low space handler" Processor terminateActive ! ! !Controller methodsFor: 'as yet unclassified' stamp: 'topa 10/20/2015 09:50:47'! closeAndUnscheduleNoTerminate ! ! !View methodsFor: 'initialize-release' stamp: 'topa 10/20/2015 08:32:51' prior: 23319549! setDefaultBackgroundColor "Obtain the background color from the receiver's model. The preferences make sure whether this is a colorful or uniform look." self backgroundColor: model defaultBackgroundColor! ! !PluggableButtonView methodsFor: 'private' stamp: 'topa 10/20/2015 09:55:07' prior: 30364148! getModelState "Answer the result of sending the receiver's model the getStateSelector message." (model isNil or: [getStateSelector isNil]) ifTrue: [^ false] ifFalse: [^ model perform: getStateSelector]. ! ! !ParagraphEditor class methodsFor: 'keyboard shortcut tables' stamp: 'cmm 10/19/2015 15:05:07' prior: 60508099! initializeShiftCmdKeyShortcuts "Initialize the shift-command-key (or control-key) shortcut table." "NOTE: if you don't know what your keyboard generates, use Sensor kbdTest" "wod 11/3/1998: Fix setting of cmdMap for shifted keys to actually use the capitalized versions of the letters. TPR 2/18/99: add the plain ascii values back in for those VMs that don't return the shifted values." | cmdMap | "shift-command and control shortcuts" cmdMap := Array new: 256 withAll: #noop:. "use temp in case of a crash" cmdMap at: ( 1 + 1) put: #cursorHome:. "home key" cmdMap at: ( 4 + 1) put: #cursorEnd:. "end key" cmdMap at: ( 8 + 1) put: #forwardDelete:. "ctrl-H or delete key" cmdMap at: (11 + 1) put: #cursorPageUp:. "page up key" cmdMap at: (12 + 1) put: #cursorPageDown:. "page down key" cmdMap at: (13 + 1) put: #crWithIndent:. "ctrl-Return" cmdMap at: (27 + 1) put: #offerMenuFromEsc:. "escape key" cmdMap at: (28 + 1) put: #cursorLeft:. "left arrow key" cmdMap at: (29 + 1) put: #cursorRight:. "right arrow key" cmdMap at: (30 + 1) put: #cursorUp:. "up arrow key" cmdMap at: (31 + 1) put: #cursorDown:. "down arrow key" cmdMap at: (32 + 1) put: #selectWord:. "space bar key" cmdMap at: (45 + 1) put: #changeEmphasis:. "cmd-sh-minus" cmdMap at: (61 + 1) put: #changeEmphasis:. "cmd-sh-plus" cmdMap at: (127 + 1) put: #forwardDelete:. "del key" "On some keyboards, these characters require a shift" '([<{|"''' do: [:char | cmdMap at: char asciiValue + 1 put: #enclose:]. "NB: sw 12/9/2001 commented out the idiosyncratic line just below, which was grabbing shift-esc in the text editor and hence which argued with the wish to have shift-esc be a universal gesture for escaping the local context and calling up the desktop menu." "cmdMap at: (27 + 1) put: #shiftEnclose:." "ctrl-[" "'""''(' do: [ :char | cmdMap at: (char asciiValue + 1) put: #enclose:]." "triplet = {character. comment selector. novice appropiated}" #( ($a argAdvance: false) ($b browseItHere: false) ($c compareToClipboard: false) ($e methodStringsContainingIt: false) ($f displayIfFalse: false) ($g fileItIn: false) ($h cursorTopHome: true) ($i exploreIt: false) ($j doAgainMany: true) ($k changeStyle: true) ($m selectCurrentTypeIn: true) ($n referencesToIt: false) ($p makeProjectLink: true) ($s search: true) ($t displayIfTrue: false) ($u changeLfToCr: false) ($v pasteInitials: false) ($w methodNamesContainingIt: false) ($x makeLowercase: true) ($y makeUppercase: true) ($z makeCapitalized: true) ) select:[:triplet | Preferences noviceMode not or:[triplet third]] thenDo:[:triplet | cmdMap at: (triplet first asciiValue + 1) put: triplet second. "plain keys" cmdMap at: (triplet first asciiValue - 32 + 1) put: triplet second. "shifted keys" cmdMap at: (triplet first asciiValue - 96 + 1) put: triplet second. "ctrl keys" ]. ShiftCmdActions := cmdMap! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'topa 10/20/2015 08:49:42' prior: 60302212! browseClassFromIt "Launch a browser for the class indicated by the current selection. If multiple classes matching the selection exist, let the user choose among them." | aClass | self lineSelectAndEmptyCheck: [^ self]. aClass := UIManager default classFromPattern: self selection string withCaption: 'choose a class to browse...'. aClass ifNil: [^ view flash]. self terminateAndInitializeAround: [| aBrow | aBrow := SystemBrowser default new. aBrow setClass: aClass selector: nil. aBrow class openBrowserView: (aBrow openEditString: nil) label: 'System Browser'].! ! !ParagraphEditor methodsFor: 'editing keys' stamp: 'topa 10/19/2015 19:50'! debugIt: characterStream sensor keyboard. self terminateAndInitializeAround: [self debugIt]. ^ true! ! !ParagraphEditor methodsFor: 'parenblinking' stamp: 'cmm 10/19/2015 14:37' prior: 60393539! dispatchOnCharacter: char with: typeAheadStream "Carry out the action associated with this character, if any. Type-ahead is passed so some routines can flush or use it." | honorCommandKeys result | self clearParens. "mikki 1/3/2005 21:31 Preference for auto-indent on return added." char asciiValue = 13 ifTrue: [ ^Preferences autoIndent ifTrue: [ sensor controlKeyPressed ifTrue: [self normalCharacter: typeAheadStream] ifFalse: [self crWithIndent: typeAheadStream]] ifFalse: [ sensor controlKeyPressed ifTrue: [self crWithIndent: typeAheadStream] ifFalse: [self normalCharacter: typeAheadStream]]]. ((honorCommandKeys := Preferences cmdKeysInText) and: [char = Character enter]) ifTrue: [^ self dispatchOnEnterWith: typeAheadStream]. (char = Character tab and: [ self selection notEmpty ]) ifTrue: [ self tabOrIndent: typeAheadStream ]. "Special keys overwrite crtl+key combinations - at least on Windows. To resolve this conflict, assume that keys other than cursor keys aren't used together with Crtl." ((self class specialShiftCmdKeys includes: char asciiValue) and: [char asciiValue < 27]) ifTrue: [^ sensor controlKeyPressed ifTrue: [self perform: (ShiftCmdActions at: char asciiValue + 1) with: typeAheadStream] ifFalse: [self perform: (CmdActions at: char asciiValue + 1) with: typeAheadStream]]. "backspace, and escape keys (ascii 8 and 27) are command keys" ((honorCommandKeys and: [sensor commandKeyPressed]) or: [self class specialShiftCmdKeys includes: char asciiValue]) ifTrue: [^ sensor leftShiftDown ifTrue: [self perform: (ShiftCmdActions at: char asciiValue + 1 ifAbsent: [#noop:]) with: typeAheadStream] ifFalse: [self perform: (CmdActions at: char asciiValue + 1 ifAbsent: [#noop:]) with: typeAheadStream]]. "the control key can be used to invoke shift-cmd shortcuts" (honorCommandKeys and: [sensor controlKeyPressed]) ifTrue: [^ self perform: (ShiftCmdActions at: char asciiValue + 1 ifAbsent: [#noop:]) with: typeAheadStream]. result := self normalCharacter: typeAheadStream. (')]}' includes: char) ifTrue: [self blinkPrevParen: char ]. ^result! ! !ParagraphEditor methodsFor: 'typing/selecting keys' stamp: 'cmm 10/19/2015 14:25'! tabOrIndent: characterStream self selection ifEmpty: [ self normalCharacter: characterStream ] ifNotEmpty: [ Sensor shiftPressed ifTrue: [ self outdent: characterStream ] ifFalse: [ self indent: characterStream ] ]. ^ false! ! !ScreenController methodsFor: 'menu messages' stamp: 'topa 10/20/2015 08:59:32' prior: 50925903! configureFonts | aMenu result | aMenu := CustomMenu fromArray: #( ('default text font...' chooseSystemFont) ('list font' chooseListFont) ('flaps font' chooseFlapsFont) ('menu font' chooseMenuFont) ('window-title font' chooseWindowTitleFont) ('code font' chooseCodeFont) - ('restore default font choices' restoreDefaultFonts)). aMenu title: 'Standard System Fonts'. (result := aMenu startUp) ifNotNil: [Preferences perform: result].! ! ParagraphEditor removeSelector: #duplicate:! "ST80"! TestCase subclass: #MCMcmUpdaterTest instanceVariableNames: '' classVariableNames: 'SaveRegistry' poolDictionaries: '' category: 'Tests-Monticello'! !MCMcmUpdaterTest commentStamp: 'dtl 10/13/2015 20:45' prior: 0! MCMcmUpdaterTest verifies registry of Monticello based updaters used for update streams, including the Squeak trunk update stream. The default update stream for the image is specified by preferences, and new updaters are created as needed. Existing updaters remain in a registry such that their individual update status is preserved. ! !MCMcmUpdaterTest methodsFor: 'running' stamp: 'dtl 10/13/2015 19:49'! setUp "Registry will be modified by tests. Safe it here and restore it in tearDown" SaveRegistry := MCMcmUpdater registry. MCMcmUpdater registry: nil! ! !MCMcmUpdaterTest methodsFor: 'running' stamp: 'dtl 10/13/2015 19:37'! tearDown MCMcmUpdater registry: SaveRegistry ! ! !MCMcmUpdaterTest methodsFor: 'testing' stamp: 'dtl 10/13/2015 19:48'! testDefault | defaultMapFromPreference defaultURLFromPreference defaultUpdater | defaultMapFromPreference := MCMcmUpdater updateMapName. defaultURLFromPreference := MCMcmUpdater defaultUpdateURL. defaultUpdater := MCMcmUpdater default. "create and register" self assert: defaultMapFromPreference equals: defaultUpdater updateMapName. self assert: defaultURLFromPreference equals: defaultUpdater repository. self assert: MCMcmUpdater registry size = 1. self assert: (MCMcmUpdater registry at: defaultURLFromPreference) size = 1 ! ! !MCMcmUpdaterTest methodsFor: 'testing' stamp: 'dtl 10/13/2015 19:40'! testRegistryIsBeingSaved "setUp and tearDown save and restore the current state" self assert: MCMcmUpdater registry isNil! ! !MCMcmUpdaterTest methodsFor: 'testing' stamp: 'dtl 10/13/2015 19:59'! testTwoUpdatersForOneRepository | reg updater1 updater2 | reg := MCMcmUpdater registry. updater1 := MCMcmUpdater updateMapNamed: 'BAR' repository: 'FOO'. self assert: MCMcmUpdater registry size = 1. self assert: (MCMcmUpdater registry at: 'FOO') size = 1. updater2 := MCMcmUpdater updateMapNamed: 'BAZ' repository: 'FOO'. self assert: MCMcmUpdater registry size = 1. self assert: (MCMcmUpdater registry at: 'FOO') size = 2. updater1 unregister. self assert: MCMcmUpdater registry size = 1. self assert: (MCMcmUpdater registry at: 'FOO') size = 1. updater2 unregister. self assert: MCMcmUpdater registry isEmpty. self should: [MCMcmUpdater registry at: 'FOO'] raise: Error. ! ! !MCMcmUpdaterTest methodsFor: 'testing' stamp: 'dtl 10/13/2015 20:01'! testTwoUpdatersInDifferentRepositories | reg updater1 updater2 | reg := MCMcmUpdater registry. updater1 := MCMcmUpdater updateMapNamed: 'BAR' repository: 'FOO'. self assert: MCMcmUpdater registry size = 1. self assert: (MCMcmUpdater registry at: 'FOO') size = 1. updater2 := MCMcmUpdater updateMapNamed: 'BAZ' repository: 'FOO2'. self assert: MCMcmUpdater registry size = 2. self assert: (MCMcmUpdater registry at: 'FOO') size = 1. self assert: (MCMcmUpdater registry at: 'FOO2') size = 1. updater1 unregister. self assert: MCMcmUpdater registry size = 1. self assert: (MCMcmUpdater registry at: 'FOO2') size = 1. updater2 unregister. self assert: MCMcmUpdater registry isEmpty. self should: [MCMcmUpdater registry at: 'FOO'] raise: Error. self should: [MCMcmUpdater registry at: 'FOO2'] raise: Error. ! ! !MCMcmUpdaterTest methodsFor: 'testing' stamp: 'dtl 10/13/2015 20:40'! testUpdatePreferences | defaultMapFromPreference defaultURLFromPreference defaultUpdater | defaultMapFromPreference := MCMcmUpdater updateMapName. defaultURLFromPreference := MCMcmUpdater defaultUpdateURL. defaultUpdater := MCMcmUpdater default. "create and register" self assert: defaultMapFromPreference equals: defaultUpdater updateMapName. self assert: defaultURLFromPreference equals: defaultUpdater repository. self assert: MCMcmUpdater registry size = 1. self assert: (MCMcmUpdater registry at: defaultURLFromPreference) size = 1. [ | newDefault | MCMcmUpdater updateMapName: 'NEWMAP'. "new instance not yet registered" self assert: MCMcmUpdater registry size = 1. self assert: (MCMcmUpdater registry at: defaultURLFromPreference) size = 1. self shouldnt: [MCMcmUpdater registry at: defaultURLFromPreference] raise: Error. self should: [(MCMcmUpdater registry at: defaultURLFromPreference) at: 'NEWMAP'] raise: Error. newDefault := MCMcmUpdater default. "create and register new default updater" self shouldnt: [(MCMcmUpdater registry at: defaultURLFromPreference) at: 'NEWMAP'] raise: Error. self assert: 'NEWMAP' equals: newDefault updateMapName. MCMcmUpdater defaultUpdateURL: 'NEWURL'. self assert: MCMcmUpdater registry size = 1. newDefault := MCMcmUpdater default. "create and register new default updater" self assert: MCMcmUpdater registry size = 2. self shouldnt: [(MCMcmUpdater registry at: 'NEWURL') at: 'NEWMAP'] raise: Error. self assert: 'NEWURL' equals: newDefault repository. self assert: 'NEWMAP' equals: newDefault updateMapName. ] ensure: [ "restore preferences" MCMcmUpdater updateMapName: defaultMapFromPreference. MCMcmUpdater defaultUpdateURL: defaultURLFromPreference ] ! ! !SystemNavigationTest methodsFor: 'as yet unclassified' stamp: 'ul 11/2/2015 04:53' prior: 63168378! testAllImplementedMessagesWithout self assert: #(bar baz classFoo) asIdentitySet equals: (sysNav allImplementedMessagesWithout: {{env at: #Griffle}. {#foo}}).! ! !SystemNavigationTest methodsFor: 'as yet unclassified' stamp: 'ul 11/2/2015 04:51' prior: 63169229! testAllSentMessagesWithout self assert: (#(foo bar) asIdentitySet addAll: Smalltalk presumedSentMessages; addAll: Smalltalk specialSelectors; yourself) equals: (sysNav allSentMessagesWithout: {{env at: #Griffle}. {#+}}).! ! "Tests"! PluggableListMorph subclass: #PluggableListMorphPlus instanceVariableNames: 'dragItemSelector dropItemSelector wantsDropSelector dragTypeSelector dragStartedSelector' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Morphic'! !PluggableListMorphPlus commentStamp: 'ar 7/15/2005 11:10' prior: 33946568! Extensions for PluggableListMorph needed by ToolBuilder! SimpleHierarchicalListMorph subclass: #PluggableTreeMorph instanceVariableNames: 'rootWrappers selectedWrapper getRootsSelector getChildrenSelector hasChildrenSelector getLabelSelector getIconSelector getSelectedPathSelector setSelectedParentSelector getHelpSelector dropItemSelector wantsDropSelector dragItemSelector dragTypeSelector nodeClass lastKeystrokeTime lastKeystrokes dragStartedSelector' classVariableNames: 'FilterByLabelsOnly MaximumSearchDepth' poolDictionaries: '' category: 'ToolBuilder-Morphic'! !PluggableTreeMorph commentStamp: 'ar 2/12/2005 04:38' prior: 33947196! A pluggable tree morph.! !MorphicToolBuilder methodsFor: 'widgets optional' stamp: 'mt 11/6/2015 11:46' prior: 30028299! buildPluggableAlternateMultiSelectionList: aSpec | listMorph listClass | aSpec getSelected ifNotNil: [ ^ self error: 'There is no PluggableAlternateListMorphOfManyByItem' ]. listClass := self alternateMultiSelectListClass. listMorph := listClass on: aSpec model list: aSpec list primarySelection: aSpec getIndex changePrimarySelection: aSpec setIndex listSelection: aSpec getSelectionList changeListSelection: aSpec setSelectionList menu: aSpec menu. listMorph setProperty: #highlightSelector toValue: #highlightMessageList:with: ; setProperty: #itemConversionMethod toValue: #asStringOrText ; setProperty: #balloonTextSelectorForSubMorphs toValue: #balloonTextForClassAndMethodString ; enableDragNDrop: SystemBrowser browseWithDragNDrop ; menuTitleSelector: #messageListSelectorTitle. self register: listMorph id: aSpec name. listMorph keystrokeActionSelector: aSpec keyPress ; getListElementSelector: aSpec listItem ; getListSizeSelector: aSpec listSize; getIconSelector: aSpec icon; getHelpSelector: aSpec help. self setFrame: aSpec frame in: listMorph. self setLayoutHintsFor: listMorph spec: aSpec. parent ifNotNil: [ self add: listMorph to: parent ]. panes ifNotNil: [ aSpec list ifNotNil:[panes add: aSpec list ] ]. ^ listMorph! ! !MorphicToolBuilder methodsFor: 'widgets required' stamp: 'mt 11/4/2015 14:41' prior: 30072412! buildPluggableList: aSpec | widget listClass getIndex setIndex | aSpec getSelected ifNil:[ listClass := self listClass. getIndex := aSpec getIndex. setIndex := aSpec setIndex. ] ifNotNil:[ listClass := self listByItemClass. getIndex := aSpec getSelected. setIndex := aSpec setSelected. ]. widget := listClass on: aSpec model list: aSpec list selected: getIndex changeSelected: setIndex menu: aSpec menu keystroke: aSpec keyPress. self register: widget id: aSpec name. "Override default scroll bar policies if needed. Widget will use preference values otherwise." aSpec hScrollBarPolicy ifNotNil: [:policy | policy caseOf: { [#always] -> [widget alwaysShowHScrollBar]. [#never] -> [widget hideHScrollBarIndefinitely]. [#whenNeeded] -> [widget showHScrollBarOnlyWhenNeeded]. } ]. aSpec vScrollBarPolicy ifNotNil: [:policy | policy caseOf: { [#always] -> [widget alwaysShowVScrollBar]. [#never] -> [widget hideVScrollBarIndefinitely]. [#whenNeeded] -> [widget showVScrollBarOnlyWhenNeeded]. } ]. widget getListElementSelector: aSpec listItem. widget getListSizeSelector: aSpec listSize. widget getIconSelector: aSpec icon. widget getHelpSelector: aSpec help. widget doubleClickSelector: aSpec doubleClick. widget dragItemSelector: aSpec dragItem. widget dropItemSelector: aSpec dropItem. widget wantsDropSelector: aSpec dropAccept. widget dragStartedSelector: aSpec dragStarted. widget autoDeselect: aSpec autoDeselect. widget keystrokePreviewSelector: aSpec keystrokePreview. widget borderWidth: 1; borderColor: Color lightGray; color: (aSpec color ifNil: [Color white] ifNotNil: [aSpec color]). self setFrame: aSpec frame in: widget. self setLayoutHintsFor: widget spec: aSpec. parent ifNotNil:[self add: widget to: parent]. panes ifNotNil:[ aSpec list ifNotNil:[panes add: aSpec list]. ]. ^widget! ! !MorphicToolBuilder methodsFor: 'widgets required' stamp: 'mt 11/4/2015 14:22' prior: 30103128! buildPluggableTree: aSpec | widget | widget := self treeClass new. self register: widget id: aSpec name. widget model: aSpec model. widget getSelectedPathSelector: aSpec getSelectedPath. widget setSelectedSelector: aSpec setSelected. widget getSelectedSelector: aSpec getSelected. widget setSelectedParentSelector: aSpec setSelectedParent. widget getChildrenSelector: aSpec getChildren. widget hasChildrenSelector: aSpec hasChildren. widget getLabelSelector: aSpec label. widget getIconSelector: aSpec icon. widget getHelpSelector: aSpec help. widget getMenuSelector: aSpec menu. widget keystrokeActionSelector: aSpec keyPress. widget nodeClass: aSpec nodeClass. widget getRootsSelector: aSpec roots. widget autoDeselect: aSpec autoDeselect. widget dropItemSelector: aSpec dropItem. widget wantsDropSelector: aSpec dropAccept. widget dragItemSelector: aSpec dragItem. widget dragStartedSelector: aSpec dragStarted. widget columns: aSpec columns. "Override default scroll bar policies if needed. Widget will use preference values otherwise." aSpec hScrollBarPolicy ifNotNil: [:policy | policy caseOf: { [#always] -> [widget alwaysShowHScrollBar]. [#never] -> [widget hideHScrollBarIndefinitely]. [#whenNeeded] -> [widget showHScrollBarOnlyWhenNeeded]. } ]. aSpec vScrollBarPolicy ifNotNil: [:policy | policy caseOf: { [#always] -> [widget alwaysShowVScrollBar]. [#never] -> [widget hideVScrollBarIndefinitely]. [#whenNeeded] -> [widget showVScrollBarOnlyWhenNeeded]. } ]. self setFrame: aSpec frame in: widget. self setLayoutHintsFor: widget spec: aSpec. parent ifNotNil:[self add: widget to: parent]. " panes ifNotNil:[ aSpec roots ifNotNil:[panes add: aSpec roots]. ]. " ^widget! ! !PluggableListMorphPlus methodsFor: 'drag and drop' stamp: 'mt 11/4/2015 12:28' prior: 24627176! acceptDroppingMorph: aTransferMorph event: evt dropItemSelector ifNil: [^ self]. potentialDropRow ifNil: [^ self]. model perform: dropItemSelector withEnoughArguments: { aTransferMorph passenger. potentialDropRow. aTransferMorph shouldCopy. aTransferMorph}. self resetPotentialDropRow. evt hand releaseMouseFocus: self. Cursor normal show. ! ! !PluggableListMorphPlus methodsFor: 'accessing' stamp: 'mt 11/4/2015 14:42'! dragStartedSelector ^ dragStartedSelector! ! !PluggableListMorphPlus methodsFor: 'accessing' stamp: 'mt 11/4/2015 14:43'! dragStartedSelector: symbol dragStartedSelector := symbol.! ! !PluggableListMorphPlus methodsFor: 'drag and drop' stamp: 'mt 11/5/2015 08:59' prior: 33947570! startDrag: evt | item itemMorph modelIndex | dragItemSelector ifNil:[^self]. evt hand hasSubmorphs ifTrue: [^ self]. self model okToChange ifFalse: [^ self]. "Ensure selection to save additional click." (self modelIndexFor: (self rowAtLocation: evt position)) in: [:evtIndex | self selectionIndex = evtIndex ifFalse: [self changeModelSelection: evtIndex]]. item := self selection ifNil: [^ self]. itemMorph := StringMorph contents: item asStringOrText. modelIndex := self modelIndexFor: self selectionIndex. [ "Initiate drag." (self model perform: dragItemSelector with: modelIndex) ifNotNil: [:passenger | | ddm | ddm := (self valueOfProperty: #dragTransferClass ifAbsent: [TransferMorph]) withPassenger: passenger from: self. ddm dragTransferType: (self dragTypeSelector ifNotNil: [:s | self model perform: s with: modelIndex]). ddm updateFromUserInputEvent: evt. self dragStartedSelector ifNotNil: [:s | self model perform: s with: itemMorph with: ddm]. evt hand grabMorph: ddm]. ] ensure: [ Cursor normal show. evt hand releaseMouseFocus: self]! ! !PluggableListMorphPlus methodsFor: 'drag and drop' stamp: 'mt 11/4/2015 14:11' prior: 24631584! wantsDroppedMorph: aTransferMorph event: anEvent dropItemSelector ifNil: [^ false]. wantsDropSelector ifNil: [^ true]. (aTransferMorph isKindOf: TransferMorph) ifFalse: [^ false]. ^ model perform: wantsDropSelector withEnoughArguments: { aTransferMorph passenger. aTransferMorph dragTransferType. aTransferMorph source. aTransferMorph}! ! !PluggableTreeMorph methodsFor: 'drag and drop' stamp: 'mt 11/4/2015 12:30' prior: 53763842! acceptDroppingMorph: aTransferMorph event: evt dropItemSelector ifNil: [^ self]. potentialDropMorph ifNil: [^ self]. model perform: dropItemSelector withEnoughArguments: { aTransferMorph passenger. potentialDropMorph withoutListWrapper. aTransferMorph shouldCopy. aTransferMorph}. self resetPotentialDropMorph. evt hand releaseMouseFocus: self. Cursor normal show! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'mt 11/4/2015 14:20'! dragStartedSelector ^ dragStartedSelector! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'mt 11/4/2015 14:20'! dragStartedSelector: aSymbol dragStartedSelector := aSymbol.! ! !PluggableTreeMorph methodsFor: 'selection' stamp: 'mt 11/4/2015 13:58' prior: 53759197! setSelectedMorph: aMorph "Avoid unnecessary model callbacks." self selectedMorph == aMorph ifTrue: [^ self]. selectedWrapper := aMorph complexContents. "Let the model now about the selected object, not wrapper." setSelectionSelector ifNotNil: [:symbol | model perform: symbol with: (selectedWrapper ifNotNil: [:w | w item])]. "The model may not have access to the parent object in terms of this tree structure." setSelectedParentSelector ifNotNil: [:symbol | model perform: symbol with: (selectedWrapper ifNotNil: [:w | w parent ifNotNil: [:pw | pw item]])].! ! !PluggableTreeMorph methodsFor: 'drag and drop' stamp: 'mt 11/4/2015 18:40' prior: 33948597! startDrag: evt | itemMorph | self dragItemSelector ifNil: [^ self]. evt hand hasSubmorphs ifTrue: [^ self]. self model okToChange ifFalse: [^ self]. itemMorph := scroller submorphs detect: [:any | any highlightedForMouseDown] ifNone: [^ self]. "Prepare visuals." itemMorph highlightForMouseDown: false. self setSelectedMorph: itemMorph. [ "Initiate drag." (self model perform: self dragItemSelector with: itemMorph withoutListWrapper) ifNotNil: [:passenger | | ddm | ddm := (self valueOfProperty: #dragTransferClass ifAbsent: [TransferMorph]) withPassenger: passenger from: self. ddm dragTransferType: (self dragTypeSelector ifNotNil: [:s | self model perform: s with: itemMorph withoutListWrapper]). ddm updateFromUserInputEvent: evt. self dragStartedSelector ifNotNil: [:s | self model perform: s with: itemMorph with: ddm]. evt hand grabMorph: ddm]. ] ensure: [ Cursor normal show. evt hand releaseMouseFocus: self].! ! !PluggableTreeMorph methodsFor: 'drag and drop' stamp: 'mt 11/4/2015 14:11' prior: 53767507! wantsDroppedMorph: aTransferMorph event: anEvent dropItemSelector ifNil: [^ false]. wantsDropSelector ifNil: [^ true]. (aTransferMorph isKindOf: TransferMorph) ifFalse: [^ false]. ^ model perform: wantsDropSelector withEnoughArguments: { aTransferMorph passenger. aTransferMorph dragTransferType. aTransferMorph source. aTransferMorph}! ! PluggableListMorphPlus removeSelector: #hoverRow:! PluggableListMorphPlus removeSelector: #getHelpSelector:! PluggableListMorphPlus removeSelector: #getHelpSelector! PluggableListMorphPlus removeSelector: #balloonText! "ToolBuilder-Morphic"! !HelpBrowser class methodsFor: 'instance creation' stamp: 'tbn 9/20/2010 09:36' prior: 55096982! openOn: aHelpTopic "Open the receiver on the given help topic or any other object that can be transformed into a help topic by sending #asHelpTopic." ^(self defaultHelpBrowser new) rootTopic: aHelpTopic; open; yourself! ! !HelpTopicListItemWrapper methodsFor: 'initialization' stamp: 'mt 11/10/2015 15:09'! setItem: anObject item ifNotNil: [:obj | obj removeDependent: self]. super setItem: anObject. item ifNotNil: [:obj | obj addDependent: self].! ! "HelpSystem-Core"! !SqueakTutorialsCommandKey class methodsFor: 'as yet unclassified' stamp: 'cmm 10/19/2015 16:44:26' prior: 23662211! commandKeyMappings "This method was automatically generated. Edit it using:" "SqueakTutorialsCommandKey edit: #commandKeyMappings" ^HelpTopic title: 'Command Key Mappings' contents: 'Lower-case command keys (use with Cmd key on Mac and Alt key on other platforms) a Select all b Browse it (selection is a class name or cursor is over a class-list or message-list) c Copy selection d Do it (selection is a valid expression) e Exchange selection with prior selection f Find g Find again h Set selection as search string for find again i Inspect it (selection is a valid expression, or selection is over an inspect-ilst) j Again once (do the last text-related operation again) k Set font l Cancel m Implementors of it (selection is a message selector or cursor is over a class-list or message-list) n Senders of it (selection is a message selector or cursor is over a class-list or message-list) o Spawn current method p Print it (selection is a valid expression) q Query symbol (toggle all possible completion for a given prefix) r Recognizer s Save (i.e. accept) t Finds a Transcript (when cursor is over the desktop) u Toggle alignment v Paste w Delete preceding word (over text); Close-window (over morphic desktop) x Cut selection y Swap characters z Undo Note: for Do it, Senders of it, etc., a null selection will be expanded to a word or to the current line in an attempt to do what you want. Also note that Senders/Implementors of it will find the outermost keyword selector in a large selection, as when you have selected a bracketed expression or an entire line. Finally note that the same cmd-m and cmd-n (and cmd-v for versions) work in the message pane of most browsers. Upper-case command keys (use with Shift-Cmd, or Ctrl on Mac or Shift-Alt on other platforms; sometimes Ctrl works too) A Advance argument B Browse it in this same browser (in System browsers only) C Compare the selected text to the clipboard contents D Debug-It E Method strings containing it F Insert ''ifFalse:'' G fileIn from it (a file name) H cursor TopHome: I Inspect via Object Explorer J Again many (apply the previous text command repeatedly until the end of the text) K Set style L Outdent (move selection one tab-stop left) M Select current type-in N References to it (selection is a class name, or cursor is over a class-list or message-list) O Open single-message browser (in message lists) P Make project link R Indent (move selection one tab-stap right) S Search T Insert ''ifTrue:'' U Convert linefeeds to carriage returns in selection V Paste author''s initials W Selectors containing it (in text); show-world-menu (when issued with cursor over desktop) X Force selection to lowercase Y Force selection to uppercase Z Capitalize all words in selection Other special keys Backspace Backward delete character Shift-Bksp Backward select or delete word Del Forward delete character Shift-Del Forward delete word Esc Pop up the context menu Shift+Esc Pop up the World Menu Cmd+Esc Close the active window Ctrl+Esc Present a list of open windows \ Send the active window to the back Cursor keys left, right, up, down Move cursor left, right, up or down Ctrl-left Move cursor left one word Ctrl-right Move cursor right one word Home Move cursor to begin of line or begin of text End Move cursor to end of line or end of text PgUp, Ctrl-up Move cursor up one page PgDown, Ctrl-Dn Move cursor down one page Note all these keys can be used together with Shift to define or enlarge the selection. You cannot however shrink that selection again, as in some other systems. Other Cmd-key combinations (not available on all platforms) Return Insert return followed by as many tabs as the previous line (with a further adjustment for additional brackets in that line) Space Select the current word as with double clicking Enclose the selection in a kind of bracket. Each is a toggle. (not available on all platforms) Ctrl-( Toggle enclosure within parentheses Ctrl-[ Toggle enclosure within brackets Crtl-{ Toggle enclosre within curly braces Ctrl-< Toggle enclosre within less-than / greater-than (HTML) Ctrl-'' Toggle enclosure within double-quotes Ctrl-'' Toggle encllosure within single-quotes Note also that you can double-click just inside any of the above delimiters, or at the beginning or end of a line, to select the text enclosed. Text Emphasis (not available on all platforms) Cmd-1 type the first method argument Cmd-2 type the second method argument Cmd-3 type the third method argument Cmd-4 type the fourth method argument Cmd-5 for future use Cmd-6 color, action-on-click, link to class comment, link to method, url Brings up a menu. To remove these properties, select more than the active part and then use command-0. Cmd-7 bold Cmd-8 italic Cmd-9 narrow (same as negative kern) Cmd-0 plain text (resets all emphasis) Cmd-- underlined (toggles it) Cmd-= struck out (toggles it) Shift-Cmd-- (aka :=) negative kern (letters 1 pixel closer) Shift-Cmd-+ positive kern (letters 1 pixel larger spread) Docking Bar Ctrl- opens the n-th (where n is between 0 and 7) menu if such exists, otherwise it moves the keyboard focus to the Search Bar. Currently this means: Ctrl-0 Activates Search Bar Ctrl-1 Squeak menu Ctrl-2 Projects menu Ctrl-3 Tools menu Ctrl-4 Apps menu Ctrl-5 Extras menu Ctrl-6 Windows menu Ctrl-7 Help menu !!' readStream nextChunkText! ! "Help-Squeak-Project"! "Files"! "Morphic"! SystemOrganization classify: #ProgressMorph under: #'MorphicExtras-Widgets'! SystemOrganization classify: #ProgressBarMorph under: #'MorphicExtras-Widgets'! !ProgressMorph class methodsFor: 'example' stamp: 'sma 3/3/2000 19:07' prior: 17541877! example "ProgressMorph example" | progress | progress := ProgressMorph label: 'Test progress'. progress subLabel: 'this is the subheading'. progress openInWorld. [10 timesRepeat: [(Delay forMilliseconds: 200) wait. progress incrDone: 0.1]. progress delete] fork! ! !ProgressMorph class methodsFor: 'instance creation' stamp: 'mir 1/19/2000 13:07' prior: 17542239! label: aString ^self new label: aString! ! !ProgressMorph methodsFor: 'accessing' stamp: 'mir 2/14/2000 17:55' prior: 17538250! done ^self progress value contents! ! !ProgressMorph methodsFor: 'accessing' stamp: '' prior: 17538330! done: amountDone self progress value contents: ((amountDone min: 1.0) max: 0.0). self currentWorld displayWorld! ! !ProgressMorph methodsFor: 'private' stamp: 'nk 7/12/2003 08:59' prior: 17540933! fontOfPointSize: size ^ (TextConstants at: Preferences standardEToysFont familyName ifAbsent: [TextStyle default]) fontOfPointSize: size! ! !ProgressMorph methodsFor: 'accessing' stamp: 'sma 3/3/2000 19:05' prior: 17538516! incrDone: incrDone self done: self done + incrDone! ! !ProgressMorph methodsFor: 'initialization' stamp: 'sma 3/3/2000 19:13' prior: 17539431! initLabelMorph ^ labelMorph := StringMorph contents: '' font: (self fontOfPointSize: 14)! ! !ProgressMorph methodsFor: 'initialization' stamp: 'dvf 9/17/2003 05:14' prior: 17539599! initProgressMorph progress := ProgressBarMorph new. progress borderWidth: 1. progress color: Color white. progress progressColor: Color gray. progress extent: 200 @ 15. ! ! !ProgressMorph methodsFor: 'initialization' stamp: 'sma 3/3/2000 19:13' prior: 17540039! initSubLabelMorph ^ subLabelMorph := StringMorph contents: '' font: (self fontOfPointSize: 12)! ! !ProgressMorph methodsFor: 'initialization' stamp: 'mir 1/19/2000 13:28' prior: 17540213! initialize super initialize. self setupMorphs! ! !ProgressMorph methodsFor: 'accessing' stamp: 'mir 1/19/2000 13:28' prior: 17538641! label ^self labelMorph contents! ! !ProgressMorph methodsFor: 'accessing' stamp: '' prior: 17538718! label: aString self labelMorph contents: aString. self currentWorld displayWorld! ! !ProgressMorph methodsFor: 'private' stamp: 'mir 1/19/2000 13:25' prior: 17541142! labelMorph ^labelMorph ifNil: [self initLabelMorph]! ! !ProgressMorph methodsFor: 'accessing' stamp: 'mir 1/19/2000 13:25' prior: 17538874! progress ^progress ifNil: [self initProgressMorph]! ! !ProgressMorph methodsFor: 'initialization' stamp: 'nk 4/21/2002 20:06' prior: 17540338! setupMorphs | | self initProgressMorph. self layoutPolicy: TableLayout new; listDirection: #topToBottom; cellPositioning: #topCenter; listCentering: #center; hResizing: #shrinkWrap; vResizing: #shrinkWrap; color: Color transparent. self addMorphBack: self labelMorph. self addMorphBack: self subLabelMorph. self addMorphBack: self progress. self borderWidth: 2. self borderColor: Color black. self color: Color veryLightGray. self align: self fullBounds center with: Display boundingBox center ! ! !ProgressMorph methodsFor: 'accessing' stamp: 'mir 1/19/2000 13:27' prior: 17538999! subLabel ^self subLabelMorph contents! ! !ProgressMorph methodsFor: 'accessing' stamp: '' prior: 17539082! subLabel: aString self subLabelMorph contents: aString. self currentWorld displayWorld! ! !ProgressMorph methodsFor: 'private' stamp: 'mir 1/19/2000 13:25' prior: 17541266! subLabelMorph ^subLabelMorph ifNil: [self initSubLabelMorph]! ! !ProgressBarMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:43' prior: 67093585! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu addList: { {'progress color...' translated. #changeProgressColor:}. {'progress value...' translated. #changeProgressValue:}. }! ! !ProgressBarMorph methodsFor: 'menu' stamp: 'ar 10/5/2000 18:51' prior: 67094193! changeProgressColor: evt | aHand | aHand := evt ifNotNil: [evt hand] ifNil: [self primaryHand]. self changeColorTarget: self selector: #progressColor: originalColor: self progressColor hand: aHand.! ! !ProgressBarMorph methodsFor: 'menu' stamp: 'ar 8/6/2009 20:43' prior: 67094774! changeProgressValue: evt | answer | answer := UIManager default request: 'Enter new value (0 - 1.0)' initialAnswer: self value contents asString. answer isEmptyOrNil ifTrue: [^ self]. self value contents: answer asNumber! ! !ProgressBarMorph methodsFor: 'drawing' stamp: 'sma 3/3/2000 18:54' prior: 67092849! drawOn: aCanvas | width inner | super drawOn: aCanvas. inner := self innerBounds. width := (inner width * lastValue) truncated min: inner width. aCanvas fillRectangle: (inner origin extent: width @ inner height) color: progressColor.! ! !ProgressBarMorph methodsFor: 'initialization' stamp: 'sma 3/3/2000 18:55' prior: 67093388! initialize super initialize. progressColor := Color green. self value: (ValueHolder new contents: 0.0). lastValue := 0.0! ! !ProgressBarMorph methodsFor: 'accessing' stamp: 'ar 11/18/1998 22:14' prior: 67091545! progressColor ^progressColor! ! !ProgressBarMorph methodsFor: 'accessing' stamp: 'sma 3/3/2000 18:52' prior: 67091843! progressColor: aColor progressColor = aColor ifFalse: [progressColor := aColor. self changed]! ! !ProgressBarMorph methodsFor: 'updating' stamp: 'sma 3/3/2000 18:51' prior: 67095267! update: aSymbol aSymbol == #contents ifTrue: [lastValue := value contents. self changed]! ! !ProgressBarMorph methodsFor: 'accessing' stamp: 'ar 11/18/1998 22:09' prior: 67092022! value ^value! ! !ProgressBarMorph methodsFor: 'accessing' stamp: 'sma 3/3/2000 18:53' prior: 67092325! value: aModel value ifNotNil: [value removeDependent: self]. value := aModel. value ifNotNil: [value addDependent: self]! ! SystemOrganization classify: #TextMorphCommandHistory under: #'51Deprecated-Morphic-Text Support'! SystemOrganization classify: #TextMorphEditor under: #'51Deprecated-Morphic-Text Support'! !TextMorphEditor commentStamp: 'dtl 1/21/2012 18:02' prior: 53726276! This is a stub class to replace the original implementation of a ParagraphEditor for TextMorphs, which has since been replaced by TextEditor. This implementation is retained for the benefit of external packages such as Connectors and FreeType that may have dependencies on TextMorphEditor. The comment below is from the class comment of the original TextMorphEditor. ----- In the past, BookMorphs had the ability to have each page be on the server as a .sp SqueakPage file. The index of the book was a .bo file. In text, Cmd-6 had a LinkTo option that linked to a page by its name, or created a new page of that name. It assumed the book was on a server with a file per page. Ted removed that code, and kept a copy on his disk in 'TME-ChngEmphasis.st for .bo .sp'! !TextMorphCommandHistory methodsFor: 'command exec' stamp: 'sps 7/23/2003 18:57' prior: 64960474! redo ^super redoNextCommand ! ! !TextMorphCommandHistory methodsFor: 'command exec' stamp: 'sps 7/23/2003 18:58' prior: 64961163! rememberCommand: aCommand "Make the supplied command be the 'LastCommand', and mark it 'done'" "Before adding the new command, remove any commands after the last #done command, and make that last #done command be lastCommand." self removeUndoneCommands. aCommand phase: #done. "If we are building a compound command, just add the new command to that" history addLast: aCommand. lastCommand := aCommand. "Debug dShow: ('Remember: ', commandToUse asString)." ! ! !TextMorphCommandHistory methodsFor: 'command exec' stamp: 'sps 7/24/2003 16:42' prior: 64962199! removeUndoneCommands "Remove all of the commands at the end of history until the first one that is not marked #undone" history reversed do: [ :command | (command phase == #done) ifTrue:[ lastCommand := command. ^self ]ifFalse:[ history remove: command. ]. ]. "If there were no #done commands on the stack, then get rid of lastCommand" lastCommand := nil. ! ! !TextMorphCommandHistory methodsFor: 'command exec' stamp: 'sps 7/23/2003 18:57' prior: 64962663! undo ^super undoLastCommand ! ! "51Deprecated"! !HTTPSocket class methodsFor: '*webclient-http' stamp: 'cmm 11/20/2015 15:48' prior: 56348192! httpGet: url args: args user: user passwd: passwd "Upload the contents of the stream to a file on the server. WARNING: This method will send a basic auth header proactively. This is necessary to avoid breaking MC and SqueakSource since SS does not return a 401 when accessing a private (global no access) repository." | urlString xhdrs client resp progress | "Normalize the url and append args" urlString := (Url absoluteFromText: url) asString. args ifNotNil: [ urlString := urlString, (self argString: args) ]. "Some raw extra headers which historically have been added" xhdrs := HTTPProxyCredentials, HTTPBlabEmail. "may be empty" client := WebClient new. client username: user; password: passwd. ^[resp := client httpGet: urlString do:[:req| "HACK: Proactively send a basic auth header. See comment above." req headerAt: 'Authorization' put: 'Basic ', (user, ':', passwd) base64Encoded. "Accept anything" req addHeader: 'Accept' value: '*/*'. "Add the additional headers" (WebUtils readHeadersFrom: xhdrs readStream) do:[:assoc| req addHeader: assoc key value: assoc value]]. progress := [:total :amount| (HTTPProgress new) total: total; amount: amount; signal: 'Downloading...' ]. "Simulate old HTTPSocket return behavior" (resp code between: 200 and: 299) ifTrue:[^(RWBinaryOrTextStream with: (resp contentWithProgress: progress)) reset] ifFalse:[resp asString, resp content]. ] ensure:[client destroy]. ! ! "WebClient-HTTP"! !Form class methodsFor: 'mode constants' stamp: 'tpr 11/13/2015 15:35'! compareMatchColor "The primCompare test id values are compareMatchColors -> 0 compareNotColorANotColorB -> 1 compareNotColorAMatchColorB -> 2" ^0! ! !Form class methodsFor: 'mode constants' stamp: 'tpr 11/13/2015 15:35'! compareNotColorAMatchColorB "The primCompare test id values are compareMatchColors -> 0 compareNotColorANotColorB -> 1 compareNotColorAMatchColorB -> 2" ^2! ! !Form class methodsFor: 'mode constants' stamp: 'tpr 11/13/2015 15:35'! compareNotColorANotColorB "The primCompare test id values are compareMatchColors -> 0 compareNotColorANotColorB -> 1 compareNotColorAMatchColorB -> 2" ^1! ! !Form class methodsFor: 'mode constants' stamp: 'tpr 11/13/2015 15:36'! compareTallyFlag "The primCompare test id values are ORR'd with 8 to indicate tallying rather than simply reporting the first hit" ^8! ! !Form class methodsFor: 'examples' stamp: 'tpr 11/13/2015 15:36'! exampleColorSees "Form exampleColorSees" "First column as above shows the sneaky red/yellow pirate sneaking up on the blue/peach galleon. Second column shows the 1bpp made from the red/yellow/transparent - white -> ignore this, black -> test this Third shows the hit area - where red touches blue - superimposed on the original scene. Fourth column is the tally of hits via the old algorithm Last column shows the tally of hits via the new prim" |formA formB maskA offset tally map intersection left top dCanvas sensitiveColor soughtColor index| formA := formB := maskA := offset := tally := map := intersection := nil. "just to shut up the compiler when testing" ActiveWorld restoreMorphicDisplay; doOneCycle. sensitiveColor := Color red. soughtColor := Color blue. top := 50. dCanvas := FormCanvas on: Display. -50 to: 80 by: 10 do:[:p| offset:= p@0. "vary this to check different states" left := 10. formA := (Form extent: 100@50 depth: 32) asFormOfDepth: 16 "so we can try original forms of other depths". formB := Form extent: 100@50 depth: 32. "make a red square in the middle of the form" (FormCanvas on: formA) fillRectangle: (25@25 extent: 50@5) fillStyle: sensitiveColor. (FormCanvas on: formA) fillRectangle: (25@30 extent: 50@5) fillStyle: Color transparent. (FormCanvas on: formA) fillRectangle: (25@35 extent: 50@50) fillStyle: Color yellow. "formA displayOn: Display at: left@top rule: Form paint. dCanvas frameRectangle: (left@top extent: formA extent) width:2 color: Color green. left := left + 150." "make a blue block on the right half of the form" (FormCanvas on: formB) fillRectangle: (50@0 extent: 50@100) fillStyle: soughtColor. (FormCanvas on: formB) fillRectangle: (60@0 extent: 10@100) fillStyle: Color palePeach. "formB displayOn: Display at: left@top rule: Form paint. dCanvas frameRectangle: (left@top extent: formA extent) width:2 color: Color green. left := left + 150." intersection := (formA boundingBox translateBy: offset) intersect: (formB boundingBox). formB displayOn: Display at: left@top rule: Form paint. formA displayOn: Display at: (left@top) + offset rule: Form paint. dCanvas frameRectangle: (intersection translateBy: left@top) width:2 color: Color green. left := left + 150. maskA := Form extent: intersection extent depth: 1. map := Bitmap new: (1 bitShift: (formA depth min: 15)). map at: (index := sensitiveColor indexInMap: map) put: 1. maskA copyBits: (intersection translateBy: offset negated) from: formA at: 0@0 colorMap: map. formB displayOn: Display at: left@top rule: Form paint. formA displayOn: Display at: (left@top) + offset rule: Form paint. maskA displayOn: Display at: (left@top) + intersection origin rule: Form paint. dCanvas frameRectangle: (intersection translateBy: left@top) width:2 color: Color green. left := left + 150. "intersect world pixels of the color we're looking for with sensitive pixels mask" map at: index put: 0. "clear map and reuse it" map at: (soughtColor indexInMap: map) put: 1. maskA copyBits: intersection from: formB at: 0@0 clippingBox: formB boundingBox rule: Form and fillColor: nil map: map. formB displayOn: Display at: left@top rule: Form paint. formA displayOn: Display at: (left@top) + offset rule: Form paint. maskA displayOn: Display at: (left@top) + intersection origin rule: Form paint. dCanvas frameRectangle: (intersection translateBy: left@top) width:2 color: Color green. left := left + 170. (maskA tallyPixelValues at: 2) asString asDisplayText displayOn: Display at: left@(top +20). left := left + 70. "now try using the new primitive" tally := (BitBlt destForm: formB sourceForm: formA fillColor: nil combinationRule: 3 "really ought to work with nil but prim code checks" destOrigin: intersection origin sourceOrigin: (offset negated max: 0@0) extent: intersection extent clipRect: intersection) primCompareColor: ((sensitiveColor pixelValueForDepth: formA depth) ) to: ((soughtColor pixelValueForDepth: formB depth) ) test: (Form compareMatchColor bitOr: Form compareTallyFlag). tally asString asDisplayText displayOn: Display at: left@(top +20). top:= top + 60] ! ! !Form class methodsFor: 'examples' stamp: 'tpr 11/13/2015 15:36'! exampleTouchTest "Form exampleTouchTest" "Demonstrate the algorithm used in Scratch code to determine if a sprite's non-transparent pixels touch a non-transparent pixel of the background upon which it is displayed. First column shows a form with a red block in the midst of transparent area sneaking up on a form with a transparent LHS and blue RHS. The green frame shows the intersection area. Second column shows in grey the part of the red that is within the intersection. Third column shows in black the blue that is within the intersection. Fourth column shows just the A touching B area. Fifth column is the tally of hits via the old algorithm Last column shows the tally of hits via the new prim" |formA formB maskA maskB offset tally map intersection left top dCanvas| formA := formB := maskA := maskB := offset := tally := map := intersection := nil. "just to shut up the compiler when testing" ActiveWorld restoreMorphicDisplay; doOneCycle. top := 50. dCanvas := FormCanvas on: Display. -50 to: 80 by: 10 do:[:p| offset:= p@0. "vary this to check different states" left := 10. formA := Form extent: 100@50 depth: 32. formB := Form extent: 100@50 depth: 16. "make a red square in the middle of the form" (FormCanvas on: formA) fillRectangle: (25@25 extent: 50@5) fillStyle: Color yellow. (FormCanvas on: formA) fillRectangle: (25@30 extent: 50@5) fillStyle: Color transparent. (FormCanvas on: formA) fillRectangle: (25@35 extent: 50@50) fillStyle: Color red. "formA displayOn: Display at: left@top rule: Form paint. dCanvas frameRectangle: (left@top extent: formA extent) width:2 color: Color green. left := left + 150." "make a blue block on the right half of the form" (FormCanvas on: formB) fillRectangle: (50@0 extent: 50@100) fillStyle: Color blue. (FormCanvas on: formB) fillRectangle: (60@0 extent: 10@100) fillStyle: Color palePeach. "formB displayOn: Display at: left@top rule: Form paint. dCanvas frameRectangle: (left@top extent: formA extent) width:2 color: Color green. left := left + 150." intersection := (formA boundingBox translateBy: offset) intersect: (formB boundingBox). formB displayOn: Display at: left@top rule: Form paint. formA displayOn: Display at: (left@top) + offset rule: Form paint. dCanvas frameRectangle: (intersection translateBy: left@top) width:2 color: Color green. left := left + 150. maskA := Form extent: intersection extent depth: 2. formA displayOn: maskA at: offset - intersection origin rule: Form paint. formB displayOn: Display at: left@top rule: Form paint. formA displayOn: Display at: (left@top) + offset rule: Form paint. maskA displayOn: Display at: (left@top) + intersection origin rule: Form paint. dCanvas frameRectangle: (intersection translateBy: left@top) width:2 color: Color green. left := left + 150. maskB := Form extent: intersection extent depth: 2. formB displayOn: maskB at: intersection origin negated rule: Form paint. formB displayOn: Display at: left@top rule: Form paint. formA displayOn: Display at: (left@top) + offset rule: Form paint. maskB displayOn: Display at: (left@top) + intersection origin rule: Form paint. dCanvas frameRectangle: (intersection translateBy: left@top) width:2 color: Color green. left := left + 150. map := Bitmap new: 4 withAll: 1. map at: 1 put: 0. "transparent" maskA copyBits: maskA boundingBox from: maskA at: 0@0 colorMap: map. "maskA displayOn: Display at: (left@top) + intersection origin rule: Form paint. dCanvas frameRectangle: (intersection translateBy: left@top) width:2 color: Color green. left := left + 150." maskB copyBits: maskB boundingBox from: maskB at: 0@0 colorMap: map. "maskB displayOn: Display at: (left@top) + intersection origin rule: Form paint. dCanvas frameRectangle: (intersection translateBy: left@top) width:2 color: Color green. left := left + 150." maskB displayOn: maskA at: 0@0 rule: Form and. maskA displayOn: Display at: (left@top) + intersection origin rule: Form paint. dCanvas frameRectangle: (intersection translateBy: left@top) width:2 color: Color green. left := left + 170. (maskA boundingBox area -( maskA tallyPixelValues at: 1)) asString asDisplayText displayOn: Display at: left@(top +20). left := left + 70. "now try using the new primitive" tally := (BitBlt destForm: formB sourceForm: formA fillColor: nil combinationRule: 3 "really ought to work with nil but prim code checks" destOrigin: intersection origin sourceOrigin: (offset negated max: 0@0) extent: intersection extent clipRect: intersection) primCompareColor: ((Color transparent pixelValueForDepth: formA depth) bitAnd: 16rFFFFFF) to: ((Color transparent pixelValueForDepth: formB depth) bitAnd: 16rFFFFFF) test: (Form compareNotColorANotColorB bitOr: Form compareTallyFlag). tally asString asDisplayText displayOn: Display at: left@(top +20). top:= top + 60] ! ! !Form class methodsFor: 'examples' stamp: 'tpr 11/13/2015 15:37'! exampleTouchingColor "Form exampleTouchingColor" "Demonstrate the algorithm used in Scratch code to determine if a sprite's non-transparent pixels touch a particular color pixel of the background upon which it is displayed. First column as above shows the sneaky red/yellow pirate sneaking up on the blue/peach galleon. Second column shows the 1bpp made from the red/yellow/transparent - white -> ignore this, black -> test this Third shows the hit area (black) superimposed on the original scene Fourth column is the tally of hits via the old algorithm Last column shows the tally of hits via the new prim" |formA formB maskA offset tally map intersection left top dCanvas ignoreColor soughtColor| formA := formB := maskA := offset := tally := map := intersection := nil. "just to shut up the compiler when testing" ActiveWorld restoreMorphicDisplay; doOneCycle. ignoreColor := Color transparent. soughtColor := Color blue. top := 50. dCanvas := FormCanvas on: Display. -50 to: 80 by: 10 do:[:p| offset:= p@0. "vary this to check different states" left := 10. formA := (Form extent: 100@50 depth: 32) asFormOfDepth: 16 "so we can try original forms of other depths". formB := Form extent: 100@50 depth: 32. "make a red square in the middle of the form" (FormCanvas on: formA) fillRectangle: (25@25 extent: 50@5) fillStyle: Color red. (FormCanvas on: formA) fillRectangle: (25@30 extent: 50@5) fillStyle: Color transparent. (FormCanvas on: formA) fillRectangle: (25@35 extent: 50@50) fillStyle: Color yellow. "formA displayOn: Display at: left@top rule: Form paint. dCanvas frameRectangle: (left@top extent: formA extent) width:2 color: Color green. left := left + 150." "make a blue block on the right half of the form" (FormCanvas on: formB) fillRectangle: (50@0 extent: 50@100) fillStyle: soughtColor. (FormCanvas on: formB) fillRectangle: (60@0 extent: 10@100) fillStyle: Color palePeach. "formB displayOn: Display at: left@top rule: Form paint. dCanvas frameRectangle: (left@top extent: formA extent) width:2 color: Color green. left := left + 150." intersection := (formA boundingBox translateBy: offset) intersect: (formB boundingBox). formB displayOn: Display at: left@top rule: Form paint. formA displayOn: Display at: (left@top) + offset rule: Form paint. dCanvas frameRectangle: (intersection translateBy: left@top) width:2 color: Color green. left := left + 150. maskA := Form extent: intersection extent depth: 1. map := Bitmap new: (1 bitShift: (formA depth min: 15)). map atAllPut: 1. map at: ( ignoreColor indexInMap: map) put: 0. maskA copyBits: (intersection translateBy: offset negated) from: formA at: 0@0 colorMap: map. formB displayOn: Display at: left@top rule: Form paint. formA displayOn: Display at: (left@top) + offset rule: Form paint. maskA displayOn: Display at: (left@top) + intersection origin rule: Form paint. dCanvas frameRectangle: (intersection translateBy: left@top) width:2 color: Color green. left := left + 150. "intersect world pixels of the color we're looking for with sensitive pixels mask" map atAllPut: 0. "clear map and reuse it" map at: (soughtColor indexInMap: map) put: 1. maskA copyBits: intersection from: formB at: 0@0 clippingBox: formB boundingBox rule: Form and fillColor: nil map: map. formB displayOn: Display at: left@top rule: Form paint. formA displayOn: Display at: (left@top) + offset rule: Form paint. maskA displayOn: Display at: (left@top) + intersection origin rule: Form paint. dCanvas frameRectangle: (intersection translateBy: left@top) width:2 color: Color green. left := left + 170. (maskA tallyPixelValues at: 2) asString asDisplayText displayOn: Display at: left@(top +20). left := left + 70. "now try using the new primitive" tally := (BitBlt destForm: formB sourceForm: formA fillColor: nil combinationRule: 3 "really ought to work with nil but prim code checks" destOrigin: intersection origin sourceOrigin: (offset negated max: 0@0) extent: intersection extent clipRect: intersection) primCompareColor: ((ignoreColor pixelValueForDepth: formA depth) bitAnd: 16rFFFFFF) to: ((soughtColor pixelValueForDepth: formB depth) bitAnd: 16rFFFFFF) test: (Form compareNotColorAMatchColorB bitOr: Form compareTallyFlag). tally asString asDisplayText displayOn: Display at: left@(top +20). top:= top + 60] ! ! !Form methodsFor: 'converting' stamp: 'tpr 11/13/2015 15:38' prior: 65264413! asFormOfDepth: d "Create a copy of me with depth 'd'. Includes a correction for some bitmaps that when imported have poorly set up transparency" | newForm | d = self depth ifTrue:[^self]. newForm := Form extent: self extent depth: d. (BitBlt toForm: newForm) colorMap: (self colormapIfNeededFor: newForm); copy: (self boundingBox) from: 0@0 in: self fillColor: nil rule: Form over. "Special case: For a 16 -> 32 bit conversion fill the alpha channel because it gets lost in translation." d = 32 ifTrue:[newForm fixAlpha]. ^newForm! ! !BitBlt methodsFor: 'private' stamp: 'tpr 11/13/2015 15:35'! primCompareColor: colorValueA to: colorValueB test: testID "Call the prim that compares pixel color values and can tell if two Forms that overlap in some manner when composited are touching colors as defined by the testID. " "to signal failure without an error we'll return -1" ^-1! ! !StrikeFont class methodsFor: 'examples' stamp: 'tpr 11/13/2015 15:38' prior: 19480475! readStrikeFont2Family: familyName "StrikeFont readStrikeFont2Family: 'Lucida'" ^self readStrikeFont2Family: familyName fromDirectory: FileDirectory default! ! !StrikeFont class methodsFor: 'examples' stamp: 'tpr 11/13/2015 15:39' prior: 19482652! readStrikeFont2Family: familyName fromDirectory: aDirectory "StrikeFont readStrikeFont2Family: 'Lucida' fromDirectory: FileDirectory default" "This utility reads all available .sf2 StrikeFont files for a given family from the current directory. It returns an Array, sorted by size, suitable for handing to TextStyle newFontArray: ." "For this utility to work as is, the .sf2 files must be named 'familyNN.sf2'." | fileNames strikeFonts | fileNames := aDirectory fileNamesMatching: familyName , '##.sf2'. strikeFonts := fileNames collect: [:fname | StrikeFont new readFromStrike2: (aDirectory fullNameFor: fname)]. strikeFonts do: [ :font | font reset ]. ^strikeFonts asArray sort: [:a :b | a height < b height]. "TextConstants at: #Lucida put: (TextStyle fontArray: (StrikeFont readStrikeFont2Family: 'Lucida' fromDirectory: FileDirectory default))."! ! !StrikeFont methodsFor: 'file in/out' stamp: 'tpr 6/11/2014 17:58' prior: 19436411! readFromStrike2: fileName "StrikeFont new readFromStrike2: 'Palatino14.sf2'" "Build an instance from the strike font stored in strike2 format. fileName is of the form: .sf2" | file | ('*.sf2' match: fileName) ifFalse: [self halt. "likely incompatible"]. name := FileDirectory baseNameFor: ( FileDirectory localNameFor: fileName). "Drop filename extension" file := FileStream readOnlyFileNamed: fileName. file binary. [self readFromStrike2Stream: file] ensure: [file close]! ! "Graphics"! !MessageNode methodsFor: 'macro transformations' stamp: 'eem 11/21/2015 15:18' prior: 50469776! transformToDo: encoder " var := rcvr. L1: [var <= arg1] Bfp(L2) [block body. var := var + inc] Jmp(L1) L2: " | limit increment block initStmt test incStmt limitInit blockVar myRange blockRange | block := arguments last. "First check for valid arguments" (block notNil and: [block isBlockNode and: [block numberOfArguments = 1 and: [block firstArgument isVariableReference "As with debugger remote vars"]]]) ifFalse: [^false]. arguments size = 3 ifTrue: [increment := arguments at: 2. (increment isConstantNumber and: [increment literalValue ~= 0]) ifFalse: [^false]] ifFalse: [increment := encoder encodeLiteral: 1]. (limit := arguments at: 1) isVariableReference ifTrue: [| shouldScanForAssignment | shouldScanForAssignment := limit isArg not or: [limit isBlockArg and: [Scanner allowBlockArgumentAssignment]]. shouldScanForAssignment ifTrue: [block nodesDo: [:node| (node isAssignmentNode and: [node variable = limit]) ifTrue: [^false]]]]. arguments size < 3 ifTrue: "transform to full form" [selector := SelectorNode new key: #to:by:do: code: #macro]. "Now generate auxiliary structures" myRange := encoder rawSourceRanges at: self ifAbsent: [1 to: 0]. blockRange := encoder rawSourceRanges at: block ifAbsent: [1 to: 0]. blockVar := block firstArgument. initStmt := AssignmentNode new variable: blockVar value: receiver. (limit isVariableReference or: [limit isConstantNumber]) ifTrue: [limitInit := nil] ifFalse: "Need to store limit in a var" [limit := encoder bindBlockArg: blockVar key, 'LimiT' within: block. limit scope: -2. "Already done parsing block; flag so it won't print" block addArgument: limit. limitInit := AssignmentNode new variable: limit value: arguments first]. test := MessageNode new receiver: blockVar selector: (increment key > 0 ifTrue: [#<=] ifFalse: [#>=]) arguments: {limit} precedence: precedence from: encoder sourceRange: (myRange first to: blockRange first). incStmt := AssignmentNode new variable: blockVar value: (MessageNode new receiver: blockVar selector: #+ arguments: {increment} precedence: precedence from: encoder sourceRange: (myRange last to: (myRange last max: blockRange last))) from: encoder sourceRange: (myRange last to: (myRange last max: blockRange last)). arguments := {limit. increment. block. initStmt. test. incStmt. limitInit}. block noteOptimizedIn: self. ^true! ! "Compiler"! SystemOrganization addCategory: #'Environments-Help'! Object subclass: #EnvironmentsAPIDocumentation instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Environments-Help'! !EnvironmentsAPIDocumentation class methodsFor: 'as yet unclassified' stamp: 'kfr 12/3/2015 13:53'! asHelpTopic ^ (HelpTopic named: self bookName) subtopics: (self packages collect: [:pkgName | PackageAPIHelpTopic new packageName: pkgName]); yourself! ! !EnvironmentsAPIDocumentation class methodsFor: 'as yet unclassified' stamp: 'kfr 12/3/2015 13:54'! bookName ^'API Documentation'! ! !EnvironmentsAPIDocumentation class methodsFor: 'as yet unclassified' stamp: 'kfr 12/3/2015 13:55'! packages ^#('Environments-Core' 'Environments-Loading' 'Environments-Policies')! ! !Binding methodsFor: 'as yet unclassified' stamp: 'cwp 11/27/2015 17:09' prior: 84957659! objectForDataStream: refStrm "I am about to be written on an object file. I am a global, so write a proxy that will hook up with the same resource in the destination system." | dp | dp := DiskProxy global: #Smalltalk selector: #associationOrUndeclaredAt: args: (Array with: key). refStrm replace: self with: dp. ^ dp! ! "Environments"! !DiskProxy methodsFor: 'i/o' stamp: 'cwp 11/27/2015 20:54' prior: 84990986! comeFullyUpOnReload: smartRefStream "Internalize myself into a fully alive object after raw loading from a DataStream. (See my class comment.) DataStream will substitute the object from this eval for the DiskProxy." | globalObj symbol pr nn arrayIndex env | symbol := globalObjectName. "See if class is mapped to another name" (smartRefStream respondsTo: #renamed) ifTrue: [ "If in outPointers in an ImageSegment, remember original class name. See mapClass:installIn:. Would be lost otherwise." ((thisContext sender sender sender sender sender sender sender sender receiver class == ImageSegment) and: [ thisContext sender sender sender sender method == (DataStream compiledMethodAt: #readArray)]) ifTrue: [ arrayIndex := (thisContext sender sender sender sender) tempAt: 4. "index var in readArray. Later safer to find i on stack of context." smartRefStream renamedConv at: arrayIndex put: symbol]. "save original name" symbol := smartRefStream renamed at: symbol ifAbsent: [symbol]]. "map" env := Environment current. globalObj := env valueOf: symbol ifAbsent: [ preSelector == nil & (constructorSelector = #yourself) ifTrue: [ Transcript cr; show: symbol, ' is undeclared.'. env undeclare: symbol. ^ nil]. ^ self error: 'Global "', symbol, '" not found']. ((symbol == #World) and: [Smalltalk isMorphic not]) ifTrue: [ self inform: 'These objects will work better if opened in a Morphic World. Dismiss and reopen all menus.']. preSelector ifNotNil: [ Symbol hasInterned: preSelector ifTrue: [:selector | [globalObj := globalObj perform: selector] on: Error do: [:ex | ex messageText = 'key not found' ifTrue: [^ nil]. ^ ex signal]] ]. symbol == #Project ifTrue: [ (constructorSelector = #fromUrl:) ifTrue: [ nn := (constructorArgs first findTokens: '/') last. nn := (nn findTokens: '.|') first. pr := Project named: nn. ^ pr ifNil: [self] ifNotNil: [pr]]. pr := globalObj perform: constructorSelector withArguments: constructorArgs. ^ pr ifNil: [self] ifNotNil: [pr]]. "keep the Proxy if Project does not exist" constructorSelector ifNil: [^ globalObj]. Symbol hasInterned: constructorSelector ifTrue: [:selector | [^ globalObj perform: selector withArguments: constructorArgs] on: Error do: [:ex | ex messageText = 'key not found' ifTrue: [^ nil]. ^ ex signal] ]. "args not checked against Renamed" ^ nil "was not in proper form"! ! Association removeSelector: #objectForDataStream:! "System"! Installer removeSelector: #fuel! "Installer-Core"! !Envelope methodsFor: 'applying' stamp: 'tpr 11/13/2015 15:48'! computeSustainValueAtMSecs: mSecs "Return the value of this envelope at the given number of milliseconds from its onset. Return zero for times outside the time range of this envelope." "Note: Unlike the private method incrementalComputeValueAtMSecs:, this method does is not increment. Thus it is slower, but it doesn't depend on being called sequentially at fixed time intervals. Note: this is the same as computeValueAtMSecs: apart from removing the first section that requires loopEndMSecs t obe nil; this appears to cause a problem when a sound in playing and is stopped whilst the #computeSlopeAtMSecs: method is run inside the SoundPlayer loop" | t i | mSecs < 0 ifTrue: [^ 0.0]. mSecs < loopStartMSecs ifTrue: [ "attack phase" i := self indexOfPointAfterMSecs: mSecs startingAt: 1. i = 1 ifTrue: [^ (points at: 1) y * scale]. ^ self interpolate: mSecs between: (points at: i - 1) and: (points at: i)]. "sustain phase" loopMSecs = 0 ifTrue: [^ (points at: loopEndIndex) y * scale]. "looping on a single point" t := loopStartMSecs + ((mSecs - loopStartMSecs) \\ loopMSecs). i := self indexOfPointAfterMSecs: t startingAt: loopStartIndex. ^ self interpolate: t between: (points at: i - 1) and: (points at: i) ! ! !Envelope methodsFor: 'applying' stamp: 'tpr 11/13/2015 15:48' prior: 21386823! sustainEnd: mSecs "Set the ending time of the sustain phase of this envelope; the decay phase will start this point. Typically derived from a note's duration. Details: to avoid a sharp transient, the decay phase is scaled so that the beginning of the decay matches the envelope's instantaneous value when the decay phase starts." | vIfSustaining firstVOfDecay | loopEndMSecs := mSecs. "no longer set to nil in order to pretend to be sustaining" decayScale := 1.0. nextRecomputeTime := 0. vIfSustaining := self computeSustainValueAtMSecs: mSecs. "get value at end of sustain phase" "loopEndMSecs := mSecs. not required any more" firstVOfDecay := (points at: loopEndIndex) y * scale. firstVOfDecay = 0.0 ifTrue: [decayScale := 1.0] ifFalse: [decayScale := vIfSustaining / firstVOfDecay]. ! ! !SimpleMIDIPort methodsFor: 'output' stamp: 'tpr 11/13/2015 15:49' prior: 52140511! midiCmd: cmd channel: channel byte: dataByte "Immediately output the given MIDI command with the given channel and argument byte to this MIDI port. Assume that the port is open." accessSema critical: [ self primMIDIWriteNoErrorPort: portNumber from: (ByteArray with: (cmd bitOr: channel) with: dataByte) at: 0]. ! ! !SimpleMIDIPort methodsFor: 'output' stamp: 'tpr 11/13/2015 15:49' prior: 52140908! midiCmd: cmd channel: channel byte: dataByte1 byte: dataByte2 "Immediately output the given MIDI command with the given channel and argument bytes to this MIDI port. Assume that the port is open." accessSema critical: [ self primMIDIWriteNoErrorPort: portNumber from: (ByteArray with: (cmd bitOr: channel) with: dataByte1 with: dataByte2) at: 0]. ! ! !SoundBuffer class methodsFor: 'objects from disk' stamp: 'nice 11/13/2015 00:22' prior: 26516330! startUpFrom: endiannessHasToBeFixed "In this case, do we need to swap word halves when reading this segment?" ^endiannessHasToBeFixed ifTrue: [Message selector: #swapHalves "will be run on each instance"] ifFalse: [nil]! ! Envelope removeSelector: #computeValueAtMSecs:! "Sound"! !DockingBarMorph class methodsFor: 'samples' stamp: 'tpr 4/9/2014 15:09' prior: 28189116! squeakMenu | menu | menu := DockingBarMenuMorph new defaultTarget: self. menu add: 'Hello' target: self selector: #inform: argument: 'Hello World!!'. menu add: 'Long Hello' target: self selector: #inform: argument: 'Helloooo World!!'. menu add: 'A very long Hello' target: self selector: #inform: argument: 'Hellooooooooooooooo World!!'. menu add: 'An incredible long Hello' target: self selector: #inform: argument: 'Hellooooooooooooooooooooooo World!!'. ^ menu! ! !DockingBarItemMorph methodsFor: 'events' stamp: 'tpr 4/9/2014 15:08' prior: 60132587! mouseDown: evt "Handle a mouse down event. Menu items get activated when the mouse is over them." (evt shiftPressed and:[self wantsKeyboardFocusOnShiftClick]) ifTrue: [ ^super mouseDown: evt ]. "enable label editing" isSelected ifTrue: [ evt hand newMouseFocus: nil. owner selectItem: nil event: evt. ] ifFalse: [ (self containsPoint: evt position) ifFalse: [ self halt ]. owner activate: evt. "Redirect to menu for valid transitions" owner selectItem: self event: evt. ] ! ! !DockingBarItemMorph methodsFor: 'events' stamp: 'tpr 11/14/2015 11:27'! wantsKeyboardFocusOnShiftClick "set this preference to false to prevent user editing of docking bar menu items" ^Preferences valueOfPreference: #allowMenubarItemEditing ifAbsent: [true]! ! !Morph methodsFor: 'user interface' stamp: 'mt 11/13/2015 10:35' prior: 32375010! defaultLabelForInspector "Answer the default label to be used for an Inspector window on the receiver." ^ self printStringLimitedTo: 40! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'tpr 4/9/2014 15:29'! handledOwnDraggingBy: aHandMorph on: aCanvas "this is my chance to do something differrent to the normal dragging work. return true if I did what I wanted, false if not" ^false! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'cmm 10/22/2015 14:30:56' prior: 31988805! justDroppedInto: aMorph event: anEvent "This message is sent to a dropped morph after it has been dropped on -- and been accepted by -- a drop-sensitive morph" | partsBinCase cmd | (self formerOwner notNil and: [self formerOwner ~~ aMorph]) ifTrue: [self removeHalo]. self formerOwner: nil. self formerPosition: nil. cmd := self valueOfProperty: #undoGrabCommand. cmd ifNotNil:[aMorph rememberCommand: cmd. self removeProperty: #undoGrabCommand]. (partsBinCase := aMorph isPartsBin) ifFalse: [self isPartsDonor: false]. (self isInWorld and: [partsBinCase not]) ifTrue: [self world startSteppingSubmorphsOf: self]. "Note an unhappy inefficiency here: the startStepping... call will often have already been called in the sequence leading up to entry to this method, but unfortunately the isPartsDonor: call often will not have already happened, with the result that the startStepping... call will not have resulted in the startage of the steppage." "An object launched by certain parts-launcher mechanisms should end up fully visible..." (self hasProperty: #beFullyVisibleAfterDrop) ifTrue: [aMorph == ActiveWorld ifTrue: [self goHome]. self removeProperty: #beFullyVisibleAfterDrop]. ! ! !SmalltalkEditor methodsFor: 'private' stamp: 'cmm 11/3/2015 23:32'! nextWord: position | string index boundaryCharacters | string := self string. index := position - 1. [ (index between: 1 and: string size) and: [ (string at: index) isSeparator ] ] whileTrue: [ index := index + 1 ]. boundaryCharacters := ')]}''"|^. '. ((index between: 1 and: string size) and: [ boundaryCharacters includes: (string at: index) ]) ifTrue: [ index := index + 1 ] ifFalse: [ [ (index between: 1 and: string size) and: [ (boundaryCharacters includes: (string at: index)) not ] ] whileTrue: [ index := index + 1 ] ]. ^ index! ! !SmalltalkEditor methodsFor: 'private' stamp: 'cmm 11/3/2015 23:31'! previousWord: position | string index boundaryCharacters | string := self string. index := position. "First, get out of whitespace." [ (index between: 2 and: string size) and: [ (string at: index) isSeparator ] ] whileTrue: [ index := index - 1 ]. boundaryCharacters := '([{''"|^. '. "Are we at a boundary character?" ((index between: 2 and: string size) and: [ boundaryCharacters includes: (string at: index) ]) ifTrue: [ "yes, select it and any following whitespace of this line." index := index - 1 ] ifFalse: [ "no, select to the next boundary character" [ (index between: 1 and: string size) and: [ (boundaryCharacters includes: (string at: index)) not ] ] whileTrue: [ index := index - 1 ] ]. ^ index + 1! ! !TextEditor class methodsFor: 'keyboard shortcut tables' stamp: 'cmm 11/14/2015 19:20' prior: 34408242! initializeCmdKeyShortcuts "Initialize the (unshifted) command-key (or alt-key) shortcut table." "NOTE: if you don't know what your keyboard generates, use Sensor kbdTest" "TextEditor initialize" | cmdMap cmds | cmdMap := Array new: 256 withAll: #noop:. "use temp in case of a crash" cmdMap at: 1 + 1 put: #cursorHome:. "home key" cmdMap at: 4 + 1 put: #cursorEnd:. "end key" cmdMap at: 8 + 1 put: #backspace:. "ctrl-H or delete key" cmdMap at: 11 + 1 put: #cursorPageUp:. "page up key" cmdMap at: 12 + 1 put: #cursorPageDown:. "page down key" cmdMap at: 13 + 1 put: #crWithIndent:. "cmd-Return" cmdMap at: 27 + 1 put: #offerMenuFromEsc:. "escape key" cmdMap at: 28 + 1 put: #cursorLeft:. "left arrow key" cmdMap at: 29 + 1 put: #cursorRight:. "right arrow key" cmdMap at: 30 + 1 put: #cursorUp:. "up arrow key" cmdMap at: 31 + 1 put: #cursorDown:. "down arrow key" cmdMap at: 32 + 1 put: #selectWord:. "space bar key" cmdMap at: 127 + 1 put: #forwardDelete:. "del key" '0123456789-=' do: [:char | cmdMap at: char asciiValue + 1 put: #changeEmphasis:]. '([<{|"''' do: [:char | cmdMap at: char asciiValue + 1 put: #enclose:]. cmds := #($a #selectAll: $c #copySelection: $e #exchange: $f #find: $g #findAgain: $j #doAgain: $k #offerFontMenu: $u #align: $v #paste: $w #backWord: $x #cut: $y #swapChars: $z #undo:). 1 to: cmds size by: 2 do: [:i | cmdMap at: (cmds at: i) asciiValue + 1 put: (cmds at: i + 1)]. cmdActions := cmdMap! ! !TextEditor methodsFor: 'menu messages' stamp: 'mt 11/18/2015 22:38' prior: 34413958! again "Do the same replace command again. Unlike #findReplaceAgain, this looks up the editor's own command history and uses the previous command." (self history hasPrevious and: [self history previous hasReplacedSomething]) ifFalse: [morph flash. ^ false]. self setSearchFromSelectionOrHistory; setReplacementFromHistory. "If we have no selection, give the user one to avoid annoying surprises." ^ self hasSelection ifTrue: [self findReplaceAgainNow] ifFalse: [self findAgainNow. false "see #againUpToEnd"]! ! !TextEditor methodsFor: 'menu messages' stamp: 'mt 11/18/2015 22:37' prior: 34414540! againUpToEnd "Find and replace until the end." | first | self again ifFalse: [^ self]. first := self history previous. [self hasSelection] whileTrue: [ self history previous isCompositeUndo: true; isCompositeRedo: true. self findReplaceAgainNow]. first isCompositeUndo: false. self history previous isCompositeUndo: first ~~ self history previous. self history previous isCompositeRedo: false.! ! !TextEditor methodsFor: 'typing support' stamp: 'mt 11/22/2015 14:44' prior: 34415375! autoEncloseFor: typedChar "Answer whether typeChar was handled by auto-enclosure. Caller should call normalCharacter if not." | openers closers | openers := '([{'. closers := ')]}'. (closers includes: typedChar) ifTrue: [ | pos | self blinkPrevParen: typedChar. ((pos := self indexOfNextNonwhitespaceCharacter) notNil and: [ (paragraph string at: pos) = typedChar ]) ifTrue: [ self moveCursor: [ : position | position + pos - pointBlock stringIndex + 1 ] forward: true select: false. ^ true ] ifFalse: [ ^ false ] ]. (openers includes: typedChar) ifTrue: [ self openTypeIn; addString: typedChar asString; addString: (closers at: (openers indexOf: typedChar)) asString; insertAndCloseTypeIn; moveCursor: [ : position | position - 1 ] forward: false select: false. ^ true ]. ^ false! ! !TextEditor methodsFor: 'private' stamp: 'eem 11/18/2015 11:27' prior: 61731409! beginningOfLine: position "Redefined in subclasses using Paragraph support" ^ (paragraph lines at:(paragraph lineIndexOfCharacterIndex: position)) first! ! !TextEditor methodsFor: 'typing support' stamp: 'mt 11/24/2015 09:25' prior: 34419636! dispatchOnKeyboardEvent: aKeyboardEvent "Carry out the action associated with this character, if any. Type-ahead is passed so some routines can flush or use it." | honorCommandKeys typedChar | typedChar := aKeyboardEvent keyCharacter. "Handle one-line input fields." (typedChar == Character cr and: [morph acceptOnCR]) ifTrue: [^ true]. "Clear highlight for last opened parenthesis." self clearParens. "Handle line breaks and auto indent." typedChar == Character cr ifTrue: [ aKeyboardEvent controlKeyPressed ifTrue: [^ self normalCharacter: aKeyboardEvent]. aKeyboardEvent shiftPressed ifTrue: [^ self lf: aKeyboardEvent]. aKeyboardEvent commandKeyPressed ifTrue: [^ self crlf: aKeyboardEvent]. ^ self crWithIndent: aKeyboardEvent]. "Handle indent/outdent with selected text block." typedChar == Character tab ifTrue: [ aKeyboardEvent shiftPressed ifTrue: [self outdent: aKeyboardEvent. ^ true] ifFalse: [self hasMultipleLinesSelected ifTrue: [self indent: aKeyboardEvent. ^ true]]]. honorCommandKeys := Preferences cmdKeysInText. (honorCommandKeys and: [typedChar == Character enter]) ifTrue: [^ self dispatchOnEnterWith: aKeyboardEvent]. "Special keys overwrite crtl+key combinations - at least on Windows. To resolve this conflict, assume that keys other than cursor keys aren't used together with Crtl." ((self class specialShiftCmdKeys includes: aKeyboardEvent keyValue) and: [aKeyboardEvent keyValue < 27]) ifTrue: [^ aKeyboardEvent controlKeyPressed ifTrue: [self perform: (self class shiftCmdActions at: aKeyboardEvent keyValue + 1) with: aKeyboardEvent] ifFalse: [self perform: (self class cmdActions at: aKeyboardEvent keyValue + 1) with: aKeyboardEvent]]. "backspace, and escape keys (ascii 8 and 27) are command keys" ((honorCommandKeys and: [aKeyboardEvent commandKeyPressed]) or: [self class specialShiftCmdKeys includes: aKeyboardEvent keyValue]) ifTrue: [ ^ aKeyboardEvent shiftPressed ifTrue: [self perform: (self class shiftCmdActions at: aKeyboardEvent keyValue + 1) with: aKeyboardEvent] ifFalse: [self perform: (self class cmdActions at: aKeyboardEvent keyValue + 1) with: aKeyboardEvent]]. "the control key can be used to invoke shift-cmd shortcuts" (honorCommandKeys and: [ aKeyboardEvent controlKeyPressed ]) ifTrue: [^ self perform: (self class shiftCmdActions at: aKeyboardEvent keyValue + 1) with: aKeyboardEvent]. "Automatically enclose paired characters such as brackets." (self class autoEnclose and: [self autoEncloseFor: typedChar]) ifTrue: [^ true]. self normalCharacter: aKeyboardEvent. ^ false! ! !TextEditor methodsFor: 'menu messages' stamp: 'mt 11/18/2015 22:15' prior: 34426353! find "Prompt the user for a string to search for, and search the receiver from the current selection onward for it. 1/26/96 sw" self setSearchFromSelectionOrHistory. (UIManager default request: 'Find what to select? ' initialAnswer: FindText) ifEmpty: [^ self] ifNotEmpty: [:reply | FindText := reply. self findAgainNow].! ! !TextEditor methodsFor: 'typing/selecting keys' stamp: 'mt 11/18/2015 22:15' prior: 61788437! find: aKeyboardEvent "Prompt the user for what to find, then find it, searching from the current selection onward." self insertAndCloseTypeIn; find. ^ true! ! !TextEditor methodsFor: 'menu messages' stamp: 'mt 11/18/2015 22:25' prior: 34426769! findAgain self setSearchFromSelectionOrHistory. ^ self findAgainNow! ! !TextEditor methodsFor: 'typing/selecting keys' stamp: 'mt 11/18/2015 22:14' prior: 34427112! findAgain: aKeyboardEvent "Find the desired text again." self insertAndCloseTypeIn; findAgain. ^ true! ! !TextEditor methodsFor: 'typing support' stamp: 'mt 11/18/2015 22:10'! findAgainNow | where | where := self text findString: FindText startingAt: self stopIndex caseSensitive: Preferences caseSensitiveFinds. where = 0 ifTrue: [self selectFrom: self stopIndex to: self stopIndex - 1] ifFalse: [self selectFrom: where to: where + FindText size - 1]. ^ true! ! !TextEditor methodsFor: 'menu messages' stamp: 'mt 11/18/2015 22:15' prior: 34427310! findReplace self setSearchFromSelectionOrHistory; setReplacementFromHistory. (UIManager default request: 'Find what to replace?' initialAnswer: FindText) ifEmpty: [^ self] ifNotEmpty: [:find | (UIManager default request: ('Replace ''{1}'' with?' format: {find}) initialAnswer: (ChangeText ifEmpty: [find])) ifEmpty: [^ self] ifNotEmpty: [:replace | FindText := find. ChangeText := replace. self findReplaceAgainNow]]! ! !TextEditor methodsFor: 'typing/selecting keys' stamp: 'mt 11/18/2015 22:15' prior: 34427799! findReplace: aKeyboardEvent self insertAndCloseTypeIn; findReplace. ^ true! ! !TextEditor methodsFor: 'menu messages' stamp: 'mt 11/18/2015 22:12' prior: 34427955! findReplaceAgain self setSearchFromSelectionOrHistory; setReplacementFromHistory. ^ self findReplaceAgainNow! ! !TextEditor methodsFor: 'typing/selecting keys' stamp: 'mt 11/18/2015 22:12' prior: 34428549! findReplaceAgain: aKeyboardEvent self insertAndCloseTypeIn; findReplaceAgain. ^ true! ! !TextEditor methodsFor: 'typing support' stamp: 'mt 11/18/2015 22:13'! findReplaceAgainNow self hasSelection ifTrue: [ "Search from the beginning of the current selection. Supports a nice combination with regular find feature." self selectInvisiblyFrom: self startIndex to: self startIndex - 1]. self findAgainNow. self hasSelection ifFalse: [^ false]. self replaceSelectionWith: ChangeText. self findAgainNow. "Select possible next thing to replace." ^ true! ! !TextEditor methodsFor: 'typing support' stamp: 'mt 11/20/2015 14:10'! hasMultipleLinesSelected ^ self hasSelection and: [self startBlock top < self stopBlock top]! ! !TextEditor methodsFor: 'undo' stamp: 'mt 11/7/2015 23:38' prior: 34434078! redoAndReselect self replace: self history current intervalBefore with: self history current contentsAfter and: [self selectInterval: self history current intervalAfter].! ! !TextEditor methodsFor: 'undo' stamp: 'mt 11/7/2015 22:39' prior: 34434325! replace: interval with: newText self replace: interval with: newText and: ["Do nothing."].! ! !TextEditor methodsFor: 'undo' stamp: 'mt 11/7/2015 17:04' prior: 34434508! replace: xoldInterval with: newText and: selectingBlock "Replace the text in oldInterval with newText and execute selectingBlock to establish the new selection. Create an undoAndReselect:redoAndReselect: undoer to allow perfect undoing." | undoInterval | undoInterval := self selectionInterval. undoInterval = xoldInterval ifFalse: [self selectInterval: xoldInterval]. self zapSelectionWith: newText. selectingBlock value. otherInterval := self selectionInterval.! ! !TextEditor methodsFor: 'undo' stamp: 'mt 11/7/2015 18:50' prior: 34435070! replaceSelectionWith: aText "Remember the selection text in UndoSelection. Deselect, and replace the selection text by aText. Remember the resulting selectionInterval in UndoInterval and PriorInterval. Set up undo to use UndoReplace." self openTypeIn. self zapSelectionWith: aText. self closeTypeIn.! ! !TextEditor methodsFor: 'accessing' stamp: 'mt 11/18/2015 21:44'! setReplacementFromHistory "Use history to get the previous replacement." (self history hasPrevious and: [self history previous hasReplacedSomething]) ifTrue: [ChangeText := self history previous contentsAfter].! ! !TextEditor methodsFor: 'accessing' stamp: 'mt 11/18/2015 21:36' prior: 34436289! setSearch: aStringOrText FindText := aStringOrText.! ! !TextEditor methodsFor: 'accessing' stamp: 'mt 11/18/2015 21:37'! setSearchFromSelectionOrHistory "Updates the current string to find with the current selection or the last change if it replaced something and thus had a prior selection." self hasSelection ifTrue: [FindText := self selection] ifFalse: [(self history hasPrevious and: [self history previous hasReplacedSomething]) ifTrue: [FindText := self history previous contentsBefore]].! ! !TextEditor methodsFor: 'undo' stamp: 'mt 11/7/2015 23:38' prior: 34437283! undoAndReselect self replace: self history current intervalBetween with: self history current contentsBefore and: [self selectInterval: self history current intervalBefore].! ! !Form methodsFor: '*Morphic' stamp: 'mt 12/10/2015 09:43' prior: 33944356! scaledIntoFormOfSize: aNumberOrPoint smoothing: factor "Scale and center the receiver into a form of a given size" | extent scaledForm result | extent := aNumberOrPoint asPoint. extent = self extent ifTrue: [^ self copy]. scaledForm := self scaledToSize: extent smoothing: factor. result := self species extent: extent depth: self depth. result getCanvas translucentImage: scaledForm at: extent - scaledForm extent // 2. ^ result ! ! !HandMorph methodsFor: 'drawing' stamp: 'tpr 6/22/2015 15:56' prior: 19265305! fullDrawOn: aCanvas "A HandMorph has unusual drawing requirements: 1. the hand itself (i.e., the cursor) appears in front of its submorphs 2. morphs being held by the hand cast a shadow on the world/morphs below The illusion is that the hand plucks up morphs and carries them above the world." "Note: This version caches an image of the morphs being held by the hand for better performance. This cache is invalidated if one of those morphs changes." | disableCaching subBnds | self visible ifFalse: [^self]. (aCanvas isVisible: self fullBounds) ifFalse: [^self]. (self hasProperty: #errorOnDraw) ifTrue:[^self drawErrorOn: aCanvas]. disableCaching := false. disableCaching ifTrue: [self nonCachingFullDrawOn: aCanvas. ^self]. submorphs isEmpty ifTrue: [cacheCanvas := nil. ^self drawOn: aCanvas]. "just draw the hand itself" "special handling of a single submorph that wants to do its own thing when being dragged" (submorphs size = 1 and: [submorphs first handledOwnDraggingBy: self on: aCanvas]) ifTrue: [^ self drawOn: aCanvas]. subBnds := Rectangle merging: (submorphs collect: [:m | m fullBounds]). self updateCacheCanvas: aCanvas. (cacheCanvas isNil or: [cachedCanvasHasHoles and: [cacheCanvas depth = 1]]) ifTrue: ["could not use caching due to translucency; do full draw" self nonCachingFullDrawOn: aCanvas. ^self]. "draw the shadow" aCanvas asShadowDrawingCanvas translateBy: self shadowOffset during: [:shadowCanvas | cachedCanvasHasHoles ifTrue: ["Have to draw the real shadow of the form" shadowCanvas paintImage: cacheCanvas form at: subBnds origin] ifFalse: ["Much faster if only have to shade the edge of a solid rectangle" (subBnds areasOutside: (subBnds translateBy: self shadowOffset negated)) do: [:r | shadowCanvas fillRectangle: r color: Color black]]]. "draw morphs in front of the shadow using the cached Form" cachedCanvasHasHoles ifTrue: [aCanvas paintImage: cacheCanvas form at: subBnds origin] ifFalse: [aCanvas drawImage: cacheCanvas form at: subBnds origin sourceRect: cacheCanvas form boundingBox]. self drawOn: aCanvas "draw the hand itself in front of morphs"! ! !HandMorph methodsFor: 'gridded cursor' stamp: 'tpr 12/3/2015 18:26'! gridPointRaw "return my latest position gridded" ^self griddedPoint: self currentEvent position! ! !HandMorph methodsFor: 'gridded cursor' stamp: 'tpr 12/3/2015 18:27'! gridTo: grid origin: offset "set a couple of properties to specify gridding for the temporaryCursor; instvars would be nicer" self setProperty: #gridStep toValue: grid; setProperty: #gridOffset toValue: offset! ! !HandMorph methodsFor: 'gridded cursor' stamp: 'tpr 12/3/2015 17:19'! griddedPoint: aPoint "return the equivalent point snapped to the grid, if indeed any gridding is set" self valueOfProperty: #gridStep ifPresentDo: [:grid| |offset| offset := self valueOfProperty: #gridOffset ifAbsent: [0@0]. ^ offset + (aPoint + (grid //2) - offset truncateTo: grid)]. ^aPoint! ! !HandMorph methodsFor: 'geometry' stamp: 'tpr 12/3/2015 17:26' prior: 19294240! position: aPoint "Overridden to align submorph origins to the grid if gridding is on." | adjustedPosition delta box | adjustedPosition := aPoint. temporaryCursor ifNotNil: [adjustedPosition := (self griddedPoint: adjustedPosition) + temporaryCursorOffset]. "Copied from Morph to avoid owner layoutChanged" "Change the position of this morph and and all of its submorphs." delta := adjustedPosition - bounds topLeft. delta isZero ifTrue: [^ self]. "Null change" box := self fullBounds. (delta dotProduct: delta) > 100 ifTrue:[ "e.g., more than 10 pixels moved" self invalidRect: box. self invalidRect: (box translateBy: delta). ] ifFalse:[ self invalidRect: (box merge: (box translateBy: delta)). ]. self privateFullMoveBy: delta. ! ! !HandMorph methodsFor: 'gridded cursor' stamp: 'tpr 12/3/2015 18:27'! turnOffGridding "remove the gridding properties to stop gridding" self removeProperty: #gridStep; removeProperty: #gridOffset! ! !TextMorph methodsFor: 'geometry' stamp: 'mt 11/20/2015 11:35' prior: 65820860! container "Return the container for composing this text. There are four cases: 1. container is specified as, eg, an arbitrary shape, 2. container is specified as the bound rectangle, because this morph is linked to others, 3. container is nil, and wrap is true -- grow downward as necessary, 4. container is nil, and wrap is false -- grow in 2D as necessary." container ifNil: [successor ifNotNil: [^ self compositionRectangle]. wrapFlag ifTrue: [^ self compositionRectangle withHeight: self maximumContainerExtent y]. ^ self compositionRectangle topLeft extent: self maximumContainerExtent]. ^ container! ! !TextMorph methodsFor: 'multi level undo' stamp: 'mt 11/15/2015 13:38' prior: 65841017! editHistory ^ self editor history! ! !TextMorph methodsFor: 'geometry' stamp: 'mt 11/20/2015 11:34'! maximumContainerExtent "For text composition. Returns the maximum area for text to be composed." ^ 9999999@9999999! ! !TextMorph methodsFor: 'copying' stamp: 'mt 11/15/2015 13:38' prior: 65799943! veryDeepInner: deepCopier "Copy all of my instance variables. Some need to be not copied at all, but shared. Warning!!!! Every instance variable defined in this class must be handled. We must also implement veryDeepFixupWith:. See DeepCopier class comment." super veryDeepInner: deepCopier. textStyle := textStyle veryDeepCopyWith: deepCopier. text := text veryDeepCopyWith: deepCopier. wrapFlag := wrapFlag veryDeepCopyWith: deepCopier. paragraph := paragraph veryDeepCopyWith: deepCopier. editor := editor veryDeepCopyWith: deepCopier. container := container veryDeepCopyWith: deepCopier. predecessor := predecessor. successor := successor. backgroundColor := backgroundColor veryDeepCopyWith: deepCopier. margins := margins veryDeepCopyWith: deepCopier.! ! !PluggableTextMorph methodsFor: 'editor access' stamp: 'mt 11/20/2015 12:00' prior: 18379447! scrollSelectionIntoView: event "Scroll my text into view. Due to line composition mechanism, we must never use the right of a character block because the lines last character block right value always comes from a global container and is *not* line specific." selectionInterval := textMorph editor selectionInterval. textMorph editor hasSelection ifFalse: [self scrollToShow: (textMorph editor startBlock withWidth: 1)] ifTrue: [ self scrollToShow: (textMorph editor startBlock topLeft corner: textMorph editor stopBlock bottomLeft). self scrollToShow: (textMorph editor pointBlock withWidth: 1). "Ensure text cursor visibility."]. ^ true! ! !PluggableTextMorph methodsFor: 'model access' stamp: 'mt 11/20/2015 11:47' prior: 18416212! setSelection: sel selectionInterval := sel. textMorph editor selectFrom: sel first to: sel last. self scrollSelectionIntoView.! ! !MenuMorph methodsFor: 'control' stamp: 'tpr 6/22/2015 15:57' prior: 24470307! popUpAdjacentTo: rightOrLeftPoint forHand: hand from: sourceItem "Present this menu at the given point under control of the given hand." | tryToPlace selectedOffset rightPoint leftPoint | hand world startSteppingSubmorphsOf: self. popUpOwner := sourceItem. self fullBounds. self updateColor. "ensure layout is current" selectedOffset := (selectedItem ifNil: [self items first]) position - self position. tryToPlace := [:where :mustFit | | delta | self position: where - selectedOffset. delta := self boundsInWorld amountToTranslateWithin: sourceItem worldBounds. (delta x = 0 or: [mustFit]) ifTrue: [delta = (0 @ 0) ifFalse: [self position: self position + delta]. sourceItem world addMorphFront: self. ^ self]]. rightPoint := rightOrLeftPoint first + ((self layoutInset + self borderWidth) @ 0). leftPoint := rightOrLeftPoint last - ((self layoutInset + self borderWidth + self width) @ 0). tryToPlace value: rightPoint value: false; value: leftPoint value: false; value: rightPoint value: true.! ! !PasteUpMorph methodsFor: 'objects from disk' stamp: 'cwp 12/7/2015 21:26'! referencePool ^ self valueOfProperty: #References ifAbsentPut: [OrderedCollection new] ! ! !SimpleHaloMorph methodsFor: 'pop up' stamp: 'jmg 11/27/2015 23:23' prior: 34456680! popUpFor: morph hand: hand self popUpFor: morph at: (hand lastEvent transformedBy: (morph transformedFrom: nil)) position hand: hand! ! !TheWorldMainDockingBar methodsFor: 'submenu - help' stamp: 'mt 11/17/2015 17:40' prior: 53130919! helpMenuOn: aDockingBar aDockingBar addItem: [ :it | it contents: 'Help' translated; addSubMenu: [ :menu | 'Todo'. menu addItem:[:item| item contents: 'Online Resources' translated; help: 'Online resources for Squeak' translated; target: self; icon: MenuIcons smallHelpIcon; selector: #showWelcomeText:label:in:; arguments: { #squeakOnlineResources. 'Squeak Online Resources'. (140@140 extent: 560@360) }]. menu addItem:[:item| item contents: 'Keyboard Shortcuts' translated; help: 'Keyboard bindings used in Squeak' translated; target: Utilities; selector: #openCommandKeyHelp ]. menu addItem:[:item| item contents: 'Font Size Summary' translated; help: 'Font size summary from the old Squeak 3.10.2 help menu.' translated; target: TextStyle; selector: #fontSizeSummary ]. menu addItem:[:item| item contents: 'Useful Expressions' translated; help: 'Useful expressions from the old Squeak 3.10.2 help menu.' translated; target: Utilities; selector: #openStandardWorkspace ]. (Smalltalk classNamed: #SystemReporter) ifNotNil: [:classSystemReporter | menu addItem: [:item | item contents: 'About this System' translated; help: 'SystemReporter status of the image and runtime environment' translated; target: classSystemReporter; selector: #open]]. menu addLine. menu addItem:[:item| item contents: 'Extending the system' translated; help: 'Includes code snippets to evaluate for extending the system' translated; target: self; icon: MenuIcons smallHelpIcon; selector: #showWelcomeText:label:in:; arguments: { #extendingTheSystem. 'How to extend the system'. (140@140 extent: 560@360) }]. menu addLine. menu addItem:[:item| item contents: 'Welcome Workspaces' translated; help: 'The Welcome Workspaces' translated; addSubMenu:[:submenu| self welcomeWorkspacesOn: submenu]]. (Smalltalk classNamed: #HelpBrowser) ifNotNil: [:classHelpBrowser | (Smalltalk classNamed: #TerseGuideHelp) ifNotNil: [:classTerseGuideHelp | menu addLine. menu addItem: [:item | item contents: 'Terse Guide to Squeak' translated; help: 'Concise information about language and environment' translated; target: classHelpBrowser; selector: #openForCodeOn:; arguments: { classTerseGuideHelp }]]. menu addLine. menu addItem: [:item | item contents: 'Help Browser' translated; help: 'Integrated Help System' translated; target: classHelpBrowser; selector: #open]]]]! ! !Editor methodsFor: 'new selection' stamp: 'cmm 11/16/2015 19:19' prior: 23200791! selectWord "Select a word or expression, the result of pressing Command+[Space Bar] or by double-clicking." ^self selectWordLeftDelimiters: ' "''|([{<' "<--- punctuation symbols should precede the bracket symbols" rightDelimiters: ' "''|)]}>'! ! !Editor methodsFor: 'new selection' stamp: 'cmm 11/16/2015 15:49' prior: 23201016! selectWordLeftDelimiters: leftDelimiters rightDelimiters: rightDelimiters "Select delimited text or word--the result of double-clicking." | openDelimiter closeDelimiter direction match level string here hereChar start stop | string := self string. string size < 2 ifTrue: [^self]. here := self pointIndex. "Select the whole text when clicking before first or after last character" (here > string size or: [here < 2]) ifTrue: [^self selectFrom: 1 to: string size]. openDelimiter := string at: here - 1. closeDelimiter := string at: here. (match := leftDelimiters indexOf: openDelimiter) > (rightDelimiters indexOf: closeDelimiter) ifTrue: [ "a more-distinct delimiter is on the left -- match to the right" start := here. direction := 1. here := here - 1. closeDelimiter := rightDelimiters at: match] ifFalse: [ openDelimiter := string at: here. match := rightDelimiters indexOf: openDelimiter. match > 0 ifTrue: [ "delimiter is on right -- match to the left" stop := here - 1. direction := -1. closeDelimiter := leftDelimiters at: match] ifFalse: [ "no delimiters -- select a token" direction := -1]]. level := 1. [level > 0 and: [direction > 0 ifTrue: [here < string size] ifFalse: [here > 1]]] whileTrue: [ hereChar := string at: (here := here + direction). match = 0 ifTrue: ["token scan goes left, then right" hereChar tokenish ifTrue: [here = 1 ifTrue: [ start := 1. "go right if hit string start" direction := 1]] ifFalse: [ direction < 0 ifTrue: [ start := here + 1. "go right if hit non-token" direction := 1] ifFalse: [level := 0]]] ifFalse: ["bracket match just counts nesting level" hereChar = closeDelimiter ifTrue: [level := level - 1"leaving nest"] ifFalse: [hereChar = openDelimiter ifTrue: [level := level + 1"entering deeper nest"]]]]. level > 0 ifTrue: ["in case ran off string end" here := here + direction]. ^direction > 0 ifTrue: [self selectFrom: start to: here - 1] ifFalse: [self selectFrom: here + 1 to: stop]! ! TextEditor removeSelector: #setSearchString:! TextMorph removeSelector: #editHistory:! Object subclass: #ToolIconHelp instanceVariableNames: '' classVariableNames: 'HelpTexts' poolDictionaries: '' category: 'Tools-Base'! !TimeProfileBrowser methodsFor: 'message list' stamp: 'ul 11/18/2015 13:08'! messageIconAt: index ^nil! ! !CompiledMethod methodsFor: '*Tools-Debugger' stamp: 'eem 3/6/2015 16:20'! canonicalArgumentName ^ 'CompiledMethod'! ! !Browser methodsFor: 'message functions' stamp: 'kfr 11/23/2015 23:32'! browseAllCommentsForClass "Opens a HelpBrowser on the class" | myClass | ((myClass := self selectedClassOrMetaClass) isNil or: [myClass isTrait]) ifFalse: [HelpBrowser openOn: myClass theNonMetaClass] ! ! !Browser methodsFor: 'class functions' stamp: 'kfr 11/23/2015 23:26' prior: 62665533! classListMenu: aMenu "Conveniently fit for backward compatibility with old browers stored in image segments" aMenu addList: #( - ('browse full (b)' browseMethodFull) ('browse hierarchy (h)' spawnHierarchy) ('browse protocol (p)' browseFullProtocol) - ('printOut' printOutClass) ('fileOut' fileOutClass) - ('show hierarchy' hierarchy) ('show definition' editClass) ('show comment' editComment) ('show all comments' browseAllCommentsForClass) - ('references... (r)' browseVariableReferences) ('assignments... (a)' browseVariableAssignments) ('class refs (N)' browseClassRefs) - ('rename class ...' renameClass) ('copy class' copyClass) ('remove class (x)' removeClass) - ('find method...' findMethod)). ^ aMenu ! ! !Browser methodsFor: 'message functions' stamp: 'cmm 11/12/2015 14:00' prior: 34520761! defineMessageFrom: aString notifying: aController "Compile the expressions in aString. Notify aController if a syntax error occurs. Install the compiled method in the selected class classified under the currently selected message category name. Answer the selector obtained if compilation succeeds, nil otherwise." | selectedMessageName selector category oldMessageList selectedClassOrMetaClass | selectedMessageName := self selectedMessageName. oldMessageList := self messageList. selectedClassOrMetaClass := self selectedClassOrMetaClass. contents := nil. selector := (selectedClassOrMetaClass newParser parseSelector: aString). (self metaClassIndicated and: [(selectedClassOrMetaClass includesSelector: selector) not and: [Metaclass isScarySelector: selector]]) ifTrue: ["A frist-time definition overlaps the protocol of Metaclasses" (self confirm: ((selector , ' is used in the existing class system. Overriding it could cause serious problems. Is this really what you want to do?') asText makeBoldFrom: 1 to: selector size)) ifFalse: [^nil]]. category := selectedMessageName ifNil: [ self selectedMessageCategoryName ] ifNotNil: [ (selectedClassOrMetaClass >> selectedMessageName) methodReference ifNotNil: [ : ref | ref category ]]. selector := selectedClassOrMetaClass compile: aString classified: category notifying: aController. selector == nil ifTrue: [^ nil]. contents := aString copy. selector ~~ selectedMessageName ifTrue: [category = ClassOrganizer nullCategory ifTrue: [self changed: #classSelectionChanged. self changed: #classList. self messageCategoryListIndex: 1]. self setClassOrganizer. "In case organization not cached" (oldMessageList includes: selector) ifFalse: [self changed: #messageList]. self messageListIndex: (self messageList indexOf: selector)]. ^ selector! ! !Browser methodsFor: 'class list' stamp: 'mt 11/19/2015 09:12' prior: 62715653! flattenHierarchyTree: classHierarchy on: col indent: indent ^ self flattenHierarchyTree: classHierarchy on: col indent: indent by: ' '.! ! !Browser methodsFor: 'message list' stamp: 'pre 12/8/2015 17:36' prior: 34523674! messageHelpAt: anIndex "Show the first n lines of the sources code of the selected message." | source formatted | Preferences balloonHelpInMessageLists ifFalse: [^ nil]. self messageList size < anIndex ifTrue: [^ nil]. source := (self selectedClassOrMetaClass >> (self messageList at: anIndex)) getSource. source lineCount > 5 ifTrue: [ | sourceLines | sourceLines := (source asString lines copyFrom: 1 to: 5) asOrderedCollection. sourceLines add: ' [...]'. source := sourceLines joinSeparatedBy: Character cr]. formatted := SHTextStylerST80 new classOrMetaClass: self selectedClassOrMetaClass; styledTextFor: source asText. ^ (Text newFrom: ((self messageIconHelpAt: anIndex) ifNotEmpty: [:t | t , Character cr, Character cr])) append: formatted; yourself! ! !Browser methodsFor: 'message list' stamp: 'pre 12/8/2015 19:07'! messageIconHelpAt: anIndex self class showMessageIcons ifFalse: [^ nil]. ^ ToolIconHelp iconHelpNamed: (ToolIcons iconForClass: self selectedClassOrMetaClass selector: (self messageList at: anIndex))! ! !Browser methodsFor: 'class functions' stamp: 'eem 12/2/2015 15:37' prior: 62704707! shiftedClassListMenu: aMenu "Set up the menu to apply to the receiver's class list when the shift key is down" ^ aMenu addList: #( - ('local senders...' browseLocalSenders 'browse senders local to this class') ('unsent methods' browseUnusedMethods 'browse all methods defined by this class that have no senders') ('unreferenced inst vars' showUnreferencedInstVars 'show a list of all instance variables that are not referenced in methods') ('unreferenced class vars' showUnreferencedClassVars 'show a list of all class variables that are not referenced in methods') ('subclass template' makeNewSubclass 'put a template into the code pane for defining of a subclass of this class') - ('sample instance' makeSampleInstance 'give me a sample instance of this class, if possible') ('inspect instances' inspectInstances 'open an inspector on all the extant instances of this class') ('inspect subinstances' inspectSubInstances 'open an inspector on all the extant instances of this class and of all of its subclasses') - ('add all meths to current chgs' addAllMethodsToCurrentChangeSet 'place all the methods defined by this class into the current change set') ('create inst var accessors' createInstVarAccessors 'compile instance-variable access methods for any instance variables that do not yet have them')); yourself! ! !ToolIconHelp class methodsFor: 'as yet unclassified' stamp: 'pre 12/8/2015 19:05'! abstract ^ 'This method is abstract.' ! ! !ToolIconHelp class methodsFor: 'as yet unclassified' stamp: 'pre 12/8/2015 19:06'! arrowDown ^ 'This method is overriden by another method.'! ! !ToolIconHelp class methodsFor: 'as yet unclassified' stamp: 'pre 12/8/2015 19:05'! arrowUp ^ 'This method overrides a super method.'! ! !ToolIconHelp class methodsFor: 'as yet unclassified' stamp: 'pre 12/8/2015 19:05'! arrowUpAndDown ^ 'This method overrides and is overridden by other methods.'! ! !ToolIconHelp class methodsFor: 'as yet unclassified' stamp: 'pre 12/8/2015 19:09'! blank ^ ''! ! !ToolIconHelp class methodsFor: 'as yet unclassified' stamp: 'pre 12/8/2015 17:48'! breakpoint ^ 'This method contains a breakpoint.'! ! !ToolIconHelp class methodsFor: 'as yet unclassified' stamp: 'pre 12/8/2015 19:04'! flag ^ 'This method needs attention of some kind.' ! ! !ToolIconHelp class methodsFor: 'as yet unclassified' stamp: 'pre 12/8/2015 19:08'! helpTexts ^ HelpTexts ifNil: [HelpTexts := IdentityDictionary new]! ! !ToolIconHelp class methodsFor: 'as yet unclassified' stamp: 'pre 12/8/2015 19:10'! iconHelpNamed: aSymbol (self respondsTo: aSymbol) ifTrue: [^self helpTexts at: aSymbol ifAbsentPut: [self perform: aSymbol]] ifFalse: [^ ''] ! ! !ToolIconHelp class methodsFor: 'as yet unclassified' stamp: 'pre 12/8/2015 19:05'! no ^ 'This method should not be implemented.' ! ! !ToolIconHelp class methodsFor: 'as yet unclassified' stamp: 'pre 12/8/2015 19:05'! notOverridden ^ 'This method is abstract and has not been overridden.' ! ! !ToolIconHelp class methodsFor: 'as yet unclassified' stamp: 'pre 12/8/2015 19:05'! primitive ^ 'This method implements a primitive.'! ! !MessageNames methodsFor: 'selector list' stamp: 'eem 12/6/2015 12:19' prior: 57343405! selectorListIndex: anInteger "Set the selectorListIndex as specified, and propagate consequences" | methodClass index | methodClass := currentCompiledMethod ifNotNil: [currentCompiledMethod methodClass]. selectorListIndex := anInteger. self changed: #selectorListIndex. messageList := self computeMessageList. self changed: #messageList. messageList size > 1 ifTrue: [methodClass ifNotNil: [index := messageList findFirst: [:methodRef| methodRef actualClass = methodClass]]]. "If a method of the same class exists, select that, otherwise select the first message if any." self messageListIndex: (index ifNil: [1 min: messageList size])! ! !StringHolder methodsFor: '*Tools' stamp: 'eem 8/9/2014 10:05'! browseLocalSenders self selectedClass ifNotNil: [:cls| | token | token := UIManager default request: 'browse for selector or literal'. token isEmpty ifTrue: [^self]. Scanner new typedScan: token do: [:scannedToken :tokenType| token := tokenType = #word ifTrue: [(Symbol findInterned: token) ifNil: [^UIManager default inform: 'no such selector: ', token] ifNotNil: [:symbol| symbol]] ifFalse: [scannedToken]. self systemNavigation browseAllCallsOn: token localTo: cls]]! ! !ObjectExplorer methodsFor: 'accessing' stamp: 'mt 11/13/2015 10:35' prior: 24118325! label ^ self rootObject printStringLimitedTo: 40! ! "Tools"! !Lexicon methodsFor: 'message list' stamp: 'mt 11/18/2015 13:41'! messageHelpAt: anIndex "Not working due to text representation of message list." ^ nil! ! !Lexicon methodsFor: 'message list' stamp: 'mt 11/18/2015 13:41'! messageIconAt: anIndex "Not working due to text representation of message list." ^ nil! ! "Protocols"! !SMPackage methodsFor: 'services' stamp: 'cmm 10/17/2015 16:49:51' prior: 28954626! releaseWithId: anIdString | anId | anId := UUID fromString: anIdString. ^ releases detect: [ : each | each id = anId ] ifNone: [ nil ]! ! "SMBase"! !HelpBrowser class methodsFor: 'instance creation' stamp: 'mt 11/17/2015 17:39' prior: 55095798! open | window | window := self openOn: CustomHelp. window model showFirstTopic. ^ window! ! !HelpBrowser class methodsFor: 'instance creation' stamp: 'mt 11/17/2015 17:38'! openForCodeOn: aHelpTopic | browser window | browser := (self defaultHelpBrowser new) rootTopic: aHelpTopic; yourself. window := ToolBuilder open: (browser buildForCodeWith: ToolBuilder default). ^ window! ! !HelpBrowser class methodsFor: 'instance creation' stamp: 'mt 11/17/2015 17:39' prior: 34557236! openOn: aHelpTopic "Open the receiver on the given help topic or any other object that can be transformed into a help topic by sending #asHelpTopic." ^(self defaultHelpBrowser new) rootTopic: aHelpTopic; open! ! !HelpBrowser methodsFor: 'actions' stamp: 'mt 11/24/2015 09:43' prior: 55083509! accept: text "Accept edited text. Compile it into a HelpTopic" | code parent topicClass topicMethod | (self currentParentTopic isNil or: [self currentParentTopic isEditable not]) ifTrue: [^ self inform: 'This help topic cannot be edited.']. self changed: #clearUserEdits. parent := self currentParentTopic. topicClass := parent helpClass. topicMethod := self currentTopic key. code := String streamContents:[:s| s nextPutAll: topicMethod. s crtab; nextPutAll: '"This method was automatically generated. Edit it using:"'. s crtab; nextPutAll: '"', self name,' edit: ', topicMethod storeString,'"'. s crtab; nextPutAll: '^HelpTopic'. s crtab: 2; nextPutAll: 'title: ', currentTopic title storeString. s crtab: 2; nextPutAll: 'contents: '. s cr; nextPutAll: (String streamContents:[:c| c nextChunkPutWithStyle: text]) storeString. s nextPutAll:' readStream nextChunkText'. ]. topicClass class compile: code classified: ((topicClass class organization categoryOfElement: topicMethod) ifNil:['pages']). parent refresh. parent == self rootTopic ifTrue: [self rootTopic: parent]. self currentTopic: (parent subtopics detect: [:t | t key = topicMethod]).! ! !HelpBrowser methodsFor: 'toolbuilder' stamp: 'mt 11/17/2015 17:33'! buildCodeContentsWith: builder ^ builder pluggableCodePaneSpec new model: self; getText: #topicContents; setText: #accept:; menu: #codePaneMenu:shifted:; softLineWrap: false; frame: (LayoutFrame fractions: (0.3@0.0 corner: 1@1) offsets: (0@ (Preferences standardDefaultTextFont height * 2) corner: 0@0)); yourself! ! !HelpBrowser methodsFor: 'toolbuilder' stamp: 'mt 11/17/2015 17:29'! buildContentsWith: builder ^ builder pluggableTextSpec new model: self; getText: #topicContents; setText: #accept:; menu: #codePaneMenu:shifted:; frame: (LayoutFrame fractions: (0.3@0.0 corner: 1@1) offsets: (0@ (Preferences standardDefaultTextFont height * 2) corner: 0@0)); yourself! ! !HelpBrowser methodsFor: 'toolbuilder' stamp: 'mt 11/17/2015 17:33'! buildForCodeWith: builder | windowSpec | windowSpec := self buildWindowWith: builder. windowSpec children add: (self buildSearchWith: builder); add: (self buildTreeWith: builder); add: (self buildCodeContentsWith: builder). ^ builder build: windowSpec! ! !HelpBrowser methodsFor: 'toolbuilder' stamp: 'mt 11/17/2015 17:29'! buildSearchWith: builder ^ builder pluggableInputFieldSpec new model: self; getText: #searchTerm; setText: #searchTerm:; help: 'Search...'; frame: (LayoutFrame fractions: (0@0 corner: 1@0) offsets: (0@0 corner: 0@ (Preferences standardDefaultTextFont height * 2))); yourself! ! !HelpBrowser methodsFor: 'toolbuilder' stamp: 'mt 11/17/2015 17:30'! buildTreeWith: builder ^ builder pluggableTreeSpec new model: self; nodeClass: HelpTopicListItemWrapper; roots: #toplevelTopics; getSelected: #currentTopic; setSelected: #currentTopic:; getSelectedPath: #currentTopicPath; setSelectedParent: #currentParentTopic:; autoDeselect: false; frame: (LayoutFrame fractions: (0@0 corner: 0.3@1) offsets: (0@ (Preferences standardDefaultTextFont height * 2) corner: 0@0)); yourself! ! !HelpBrowser methodsFor: 'toolbuilder' stamp: 'mt 11/17/2015 17:30'! buildWindowWith: builder ^ builder pluggableWindowSpec new model: self; children: OrderedCollection new; label: #label; yourself! ! !HelpBrowser methodsFor: 'toolbuilder' stamp: 'mt 11/17/2015 17:31' prior: 55092022! buildWith: builder | windowSpec | windowSpec := self buildWindowWith: builder. windowSpec children add: (self buildSearchWith: builder); add: (self buildTreeWith: builder); add: (self buildContentsWith: builder). ^ builder build: windowSpec! ! !HelpBrowser methodsFor: 'accessing' stamp: 'mt 11/17/2015 16:41' prior: 55087834! currentParentTopic ^ currentParentTopic ifNil: [self rootTopic]! ! !HelpBrowser methodsFor: 'accessing' stamp: 'mt 11/24/2015 09:36' prior: 55088183! currentTopic: aHelpTopic self okToChange ifFalse: [^ self]. self currentTopic == aHelpTopic ifTrue: [^ self]. currentTopic := aHelpTopic. topicPath := nil. self changed: #currentTopic. self changed: #topicContents.! ! !HelpBrowser methodsFor: 'enumeration' stamp: 'mt 11/17/2015 17:25'! detect: block ifFound: foundBlock self do: [:topic :path | (block value: topic) ifTrue: [foundBlock cull: topic cull: path. ^ topic]].! ! !HelpBrowser methodsFor: 'enumeration' stamp: 'mt 11/17/2015 17:19'! do: block self do: block in: self toplevelTopics path: #().! ! !HelpBrowser methodsFor: 'enumeration' stamp: 'mt 11/17/2015 17:20'! do: block in: topics path: path topics do: [:topic | block cull: topic cull: path. topic hasSubtopics ifTrue: [ self do: block in: topic subtopics path: path, {topic}]].! ! !HelpBrowser methodsFor: 'updating' stamp: 'mt 11/24/2015 09:37'! okToChange self canDiscardEdits ifTrue: [^ true]. self changed: #wantToChange. "Solicit cancel from view" ^ self canDiscardEdits! ! !HelpBrowser methodsFor: 'ui' stamp: 'mt 11/17/2015 17:39' prior: 55078079! open ^ ToolBuilder open: self! ! !HelpBrowser methodsFor: 'searching' stamp: 'mt 11/24/2015 09:42' prior: 55094077! searchTerm: aString "Spawn a new search topic." | topic | self okToChange ifFalse: [^ self]. topic := self searchTopic subtopics detect: [:t | t term = aString] ifNone: [ | newTopic | newTopic := SearchTopic new term: aString; yourself. self searchTopic addSubtopic: newTopic. newTopic addDependent: self. "Tell me about your updates." newTopic]. "self changed: #searchTerm." "Select results and expand searches node if necessary." self currentTopicPath: {self searchTopic. topic}. self assert: self currentTopic == topic. topic topicsToSearch: self toplevelTopics allButLast; startSearch.! ! !HelpBrowser methodsFor: 'actions' stamp: 'mt 11/17/2015 17:21'! showFirstTopic "Shows the first topic that has contents." self showTopicThat: [:topic | topic contents notEmpty].! ! !HelpBrowser methodsFor: 'actions' stamp: 'mt 11/17/2015 17:21'! showTopicThat: block self detect: [:topic | block value: topic] ifFound: [:topic :path | self currentTopicPath: path, {topic}].! ! HelpBrowser removeSelector: #inTopic:replaceSubtopic:with:! HelpBrowser removeSelector: #inTopic:replaceCurrentTopicWith:! HelpBrowser removeSelector: #inSubtopic:find:! HelpBrowser removeSelector: #findStringInHelpTopic:! HelpBrowser removeSelector: #findAgain! HelpBrowser removeSelector: #find:! HelpBrowser removeSelector: #find! "HelpSystem-Core"! !AdvancedHelpBrowserDummy methodsFor: 'testing' stamp: 'kfr 11/22/2015 19:24'! model ^self! ! !AdvancedHelpBrowserDummy methodsFor: 'testing' stamp: 'kfr 11/22/2015 19:26'! showFirstTopic ^rootTopic! ! "HelpSystem-Tests"! !SqueakTutorialsCommandKey class methodsFor: 'as yet unclassified' stamp: 'cmm 11/22/2015 22:35' prior: 34557911! commandKeyMappings "This method was automatically generated. Edit it using:" "SqueakTutorialsCommandKey edit: #commandKeyMappings" ^HelpTopic title: 'Command Key Mappings' contents: 'Lower-case command keys (use with Cmd key on Mac and Alt key on other platforms) a Select all b Browse it (selection is a class name or cursor is over a class-list or message-list) c Copy selection d Do it (selection is a valid expression) e Exchange selection with prior selection f Find text with a dialog g Find the current selection again j Repeat the last selection replacement i Inspect it k Set font l Cancel text edit m Implementors of it n Senders of it o Spawn current method p Print it (selection is a valid expression) q Query symbol (toggle all possible completion for a given prefix) s Save (i.e. accept) t Finds a Transcript (when cursor is over the desktop) u Toggle alignment v Paste w Select/Delete preceding word (over text); Close-window (over morphic desktop) x Cut selection y Swap characters z Undo Note: for Do it, Senders of it, etc., a null selection will be expanded to a word or to the current line in an attempt to do what you want. Also note that Senders/Implementors of it will find the outermost keyword selector in a large selection, as when you have selected a bracketed expression or an entire line. Finally note that the same cmd-m and cmd-n (and cmd-v for versions) work in the message pane of most browsers. Upper-case command keys (use with Shift-Cmd, or Ctrl on Mac or Shift-Alt on other platforms; sometimes Ctrl works too) A Advance argument B Browse it in this same browser (in System browsers only) C Compare the selected text to the clipboard contents D Debug-It E Method strings containing it F Insert ''ifFalse:'' G fileIn from it (a file name) H cursor TopHome: I Inspect via Object Explorer J Again many (apply the previous text command repeatedly until the end of the text) K Set style L Outdent (move selection one tab-stop left) M Select current type-in N References to it (selection is a class name, or cursor is over a class-list or message-list) O Open single-message browser (in message lists) P Make project link R Indent (move selection one tab-stap right) S Search T Insert ''ifTrue:'' U Convert linefeeds to carriage returns in selection V Paste author''s initials W Selectors containing it (in text); show-world-menu (when issued with cursor over desktop) X Force selection to lowercase Y Force selection to uppercase Z Redo Other special keys Backspace Backward delete character Shift-Bksp Backward select or delete word Del Forward delete character Shift-Del Forward delete word Esc Pop up the context menu Shift+Esc Pop up the World Menu Cmd+Esc Close the active window Ctrl+Esc Present a list of open windows \ Send the active window to the back Cursor keys left, right, up, down Move cursor left, right, up or down Ctrl-left Move cursor left one word Ctrl-right Move cursor right one word Home Move cursor to begin of line or begin of text End Move cursor to end of line or end of text PgUp, Ctrl-up Move cursor up one page PgDown, Ctrl-Dn Move cursor down one page Note all these keys can be used together with Shift to define or enlarge the selection. You cannot however shrink that selection again, as in some other systems. Other Cmd-key combinations (not available on all platforms) Return Insert return followed by as many tabs as the previous line (with a further adjustment for additional brackets in that line) Space Select the current word as with double clicking Enclose the selection in a kind of bracket. Each is a toggle. (not available on all platforms) Ctrl-( Toggle enclosure within parentheses Cmd-[ Toggle enclosure within brackets Crtl-{ Toggle enclosure within curly braces Ctrl-'' Toggle enclosure within double-quotes Cmd-'' Toggle enclosure within single-quotes Note also that you can double-click just inside any of the above delimiters, or at the beginning or end of a line, to select the text enclosed. Text Emphasis (not available on all platforms) Cmd-1 type the first method argument Cmd-2 type the second method argument Cmd-3 type the third method argument Cmd-4 type the fourth method argument Cmd-5 for future use Cmd-6 color, action-on-click, link to class comment, link to method, url Brings up a menu. To remove these properties, select more than the active part and then use command-0. Cmd-7 bold Cmd-8 italic Cmd-9 narrow (same as negative kern) Cmd-0 plain text (resets all emphasis) Cmd-- underlined (toggles it) Cmd-= struck out (toggles it) Shift-Cmd-- (aka :=) negative kern (letters 1 pixel closer) Shift-Cmd-+ positive kern (letters 1 pixel larger spread) Docking Bar Ctrl- opens the n-th (where n is between 0 and 7) menu if such exists, otherwise it moves the keyboard focus to the Search Bar. Currently this means: Ctrl-0 Activates Search Bar or Scratch Pad Ctrl-1 Squeak menu Ctrl-2 Projects menu Ctrl-3 Tools menu Ctrl-4 Apps menu Ctrl-5 Extras menu Ctrl-6 Windows menu Ctrl-7 Help menu !!' readStream nextChunkText! ! !Utilities class methodsFor: '*Help-Squeak-Project-support windows' stamp: 'mt 11/17/2015 17:44' prior: 58753766! openCommandKeyHelp "Open a window giving command key help." "Utilities openCommandKeyHelp" (HelpBrowser openOn: SqueakTutorialsCommandKey) model showFirstTopic! ! "Help-Squeak-Project"! !WebServerReference class methodsFor: 'accessing' stamp: 'kfr 12/3/2015 14:11'! asHelpTopic ^ (HelpTopic named: self bookName) subtopics: (self packages collect: [:pkgName | PackageAPIHelpTopic new packageName: pkgName]); yourself! ! !WebClientReference class methodsFor: 'accessing' stamp: 'kfr 12/3/2015 14:09'! asHelpTopic ^ (HelpTopic named: self bookName) subtopics: (self packages collect: [:pkgName | PackageAPIHelpTopic new packageName: pkgName]); yourself! ! "WebClient-Help"! "MorphicExtras"! "Morphic"! ----QUIT----{10 December 2015 . 4:28:21 pm} trunk50.image priorSource: 9231! ----STARTUP----{11 December 2015 . 5:34:21 pm} as /Users/eliot/oscogvm/image/trunk50.image! [MCMcmUpdater defaultUpdateURL: 'http://source.squeak.org/trunk'; updateFromServer] valueSupplyingAnswer: true. Smalltalk snapshot: true andQuit: true ! ----End fileIn of a ReadStream----! ----QUIT----{11 December 2015 . 5:34:25 pm} trunk50.image priorSource: 1102523! ----STARTUP----{5 January 2016 . 4:32:14 pm} as /Users/eliot/oscogvm/image/trunk50.image! [MCMcmUpdater defaultUpdateURL: 'http://source.squeak.org/trunk'; updateFromServer] valueSupplyingAnswer: true. Smalltalk snapshot: true andQuit: true ! ----End fileIn of a ReadStream----! !MailComposition methodsFor: 'interface' stamp: 'cmm 11/16/2015 10:10' prior: 59136447! menuGet: aMenu shifted: shifted aMenu addList: { {'find...(f)' translated. #find}. {'find selection again (g)' translated. #findAgain}. #-. {'accept (s)' translated. #accept}. {'send message' translated. #submit}}. ^aMenu.! ! "Network"! SharedPool subclass: #ChronologyConstants instanceVariableNames: 'seconds offset jdn nanos' classVariableNames: 'DayNames DaysInMonth MicrosecondsInDay MonthNames NanosInMillisecond NanosInSecond OneDay SecondsInDay SecondsInHour SecondsInMinute SqueakEpoch Zero' poolDictionaries: '' category: 'Kernel-Chronology'! !ChronologyConstants commentStamp: 'brp 3/12/2004 14:34' prior: 63186027! ChronologyConstants is a SharedPool for the constants used by the Kernel-Chronology classes.! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'eem 1/3/2016 09:20' prior: 60054439! nowWithOffset: aDuration | usecs | usecs := Time utcMicrosecondClock. ^self basicNew setJdn: DaysSinceEpoch seconds: usecs // 1000000 \\ SecondsInDay nano: usecs \\ 1000000 * 1000 offset: aDuration! ! !Delay class methodsFor: 'primitives' stamp: 'eem 1/3/2016 10:42'! primSignal: aSemaphore atUTCMicroseconds: anInteger "Signal the semaphore when the UTC microsecond clock reaches the value of the second argument. Fail if the first argument is neither a Semaphore nor nil, or if the second argument is not an integer. Essential. See Object documentation whatIsAPrimitive." ^self primitiveFailed! ! !Delay class methodsFor: 'timer process' stamp: 'eem 1/5/2016 11:32'! scheduleDelay: aDelay from: nowUsecs "Private. Schedule this Delay." aDelay resumptionTime: nowUsecs + aDelay microsecondDelayDuration; beingWaitedOn: true. ActiveDelay ifNil: [ActiveDelay := aDelay] ifNotNil: [aDelay resumptionTime < ActiveDelay resumptionTime ifTrue: [SuspendedDelays add: ActiveDelay. ActiveDelay := aDelay] ifFalse: [SuspendedDelays add: aDelay]]! ! !Delay methodsFor: 'public' stamp: 'eem 1/5/2016 11:28' prior: 50639234! delayDuration "Answer the receiver's duration in milliseconds." ^delayDuration! ! !Delay methodsFor: 'public' stamp: 'eem 1/5/2016 11:30' prior: 50639325! delayDuration: milliseconds "Set teh receiver's duration in milliseconds, iff it is not active." milliseconds < 0 ifTrue: [self error: 'Delay times cannot be negative!!']. beingWaitedOn == true ifTrue: [self error: 'This delay is scheduled!!']. delayDuration := milliseconds asInteger! ! !Delay methodsFor: 'public' stamp: 'eem 1/5/2016 11:27'! microsecondDelayDuration "Answer the receiver's duration in microseconds." ^delayDuration * 1000! ! !ChronologyConstants class methodsFor: 'class initialization' stamp: 'eem 1/3/2016 08:49' prior: 63186939! initialize "ChronologyConstants initialize" SqueakEpoch := 2415386. "Julian day number of 1 Jan 1901" SecondsInDay := 86400. SecondsInHour := 3600. SecondsInMinute := 60. MicrosecondsInDay := 24 * 60 * 60 * 1000000. NanosInSecond := 10 raisedTo: 9. NanosInMillisecond := 10 raisedTo: 6. DayNames := #(Sunday Monday Tuesday Wednesday Thursday Friday Saturday). MonthNames := #( January February March April May June July August September October November December). DaysInMonth := #(31 28 31 30 31 30 31 31 30 31 30 31)! ! !Time class methodsFor: 'clock' stamp: 'eem 9/28/2009 08:19'! localMicrosecondClock "Answer the number of microseconds since the start of the 20th century in local time." ^0! ! !Time class methodsFor: 'ansi protocol' stamp: 'eem 7/19/2012 13:17' prior: 63604626! now "Answer a Time representing the time right now - this is a 24 hour clock." | localUsecs localUsecsToday | localUsecs := self localMicrosecondClock. localUsecsToday := localUsecs \\ MicrosecondsInDay. ^ self seconds: localUsecsToday // 1000000 nanoSeconds: localUsecsToday \\ 1000000 * 1000! ! !Time class methodsFor: 'clock' stamp: 'eem 9/28/2009 08:18'! utcMicrosecondClock "Answer the number of microseconds since the start of the 20th century in UTC." ^0! ! Delay removeSelector: #scheduleEvent! "Kernel"! !SequenceableCollection methodsFor: 'copying' stamp: 'cmm 1/3/2016 15:32' prior: 51161149! grownBy: length "Answer a copy of receiver collection with size grown by length" ^ (self class ofSize: self size + length) replaceFrom: 1 to: self size with: self startingAt: 1 ; yourself! ! "Collections"! !SoundRecorder methodsFor: 'primitives' stamp: 'tpr 11/22/2015 12:10' prior: 24021550! primStartRecordingDesiredSampleRate: samplesPerSec stereo: stereoFlag semaIndex: anInteger "Start sound recording with the given stereo setting. Use a sampling rate as close to the desired rate as the underlying platform will support. If the given semaphore index is > 0, it is taken to be the index of a Semaphore in the external objects array to be signalled every time a recording buffer is filled. We do *not* raise a primitiveFailed error here since this prim is called insdied a critical blcok and that often makes things painful. The only really likely case where this prim fails is a linux machine with no sound input hardware (a Raspberry Pi for example). See the startRecording method for how the failure is handled" "self primitiveFailed" ! ! !SoundRecorder methodsFor: 'recording controls' stamp: 'tpr 11/22/2015 12:28' prior: 24028429! startRecording "Turn on the sound input driver and start the recording process. Initially, recording is paused. If the primStartRecordingDesiredSampleRate:... fails it almost certainly means we have no usable sound input device. Rather than having the prim raise a failure error we let it quietly do nothing (since I hate trying to debug errors inside a critical block) and check the actual sampling rate later. If the sampling rate is 0 we know the startup failed and raise an application level Signal to let any user code know about the problem. You might think we should also use the stopRecording message to close things down cleanly but that simply results in astorm of attempts to start recording so it is simpler to let it be deluded. An attempts to start recording will repeat the test and thereby handle any plug-in hardware etc." recordLevel ifNil: [recordLevel := 0.5]. "lazy initialization" CanRecordWhilePlaying ifFalse: [SoundPlayer shutDown]. recordProcess ifNotNil: [self stopRecording]. paused := true. meteringBuffer := SoundBuffer newMonoSampleCount: 1024. meterLevel := 0. self allocateBuffer. Smalltalk newExternalSemaphoreDo: [ :semaphore :index | bufferAvailableSema := semaphore. self primStartRecordingDesiredSampleRate: samplingRate asInteger stereo: stereo semaIndex: index ]. RecorderActive := true. samplingRate := self primGetActualRecordingSampleRate. samplingRate = 0 ifTrue: [ Warning signal: 'SoundRecorder: unable to connect to sound input device']. self primSetRecordLevel: (1000.0 * recordLevel) asInteger. recordProcess := [self recordLoop] newProcess. recordProcess priority: Processor userInterruptPriority. recordProcess resume! ! "Sound"! !TextEditorCommandHistory methodsFor: 'testing' stamp: 'mt 12/21/2015 13:55'! hasInsertedSomething ^ self hasPrevious and: [self previous hasInsertedSomething]! ! !TextEditorCommandHistory methodsFor: 'testing' stamp: 'mt 11/26/2015 16:46'! hasReplacedSomething ^ self hasPrevious and: [self previous hasReplacedSomething]! ! !MenuMorph methodsFor: 'control' stamp: 'tpr 12/18/2015 16:10' prior: 34625798! popUpAdjacentTo: rightOrLeftPoint forHand: hand from: sourceItem "Present this menu at the given point under control of the given hand." | tryToPlace selectedOffset rightPoint leftPoint | hand world startSteppingSubmorphsOf: self. popUpOwner := sourceItem. self fullBounds. self updateColor. "ensure layout is current" selectedOffset := (selectedItem ifNil: [self items first]) position - self position. tryToPlace := [:where :mustFit | | delta | self position: where - selectedOffset. delta := self boundsInWorld amountToTranslateWithin: sourceItem worldBounds. (delta x = 0 or: [mustFit]) ifTrue: [delta = (0 @ 0) ifFalse: [self position: self position + delta]. sourceItem world addMorphFront: self. ^ self]]. rightPoint := rightOrLeftPoint first + ((self layoutInset + self borderWidth) @ 0). leftPoint := rightOrLeftPoint last + ((self layoutInset + self borderWidth - self width) @ 0). tryToPlace value: rightPoint value: false; value: leftPoint value: false; value: rightPoint value: true.! ! !TextEditorCommand methodsFor: 'testing' stamp: 'mt 12/21/2015 13:56'! hasInsertedSomething ^ self contentsBefore isEmpty! ! !TextEditor methodsFor: 'menu messages' stamp: 'mt 12/21/2015 14:16' prior: 34607378! again "Do the same find/replace command again. Looks up the editor's own command history and uses the previous command to determine find string and replace string." self history hasReplacedSomething ifFalse: [morph flash. ^ false]. self setSearchFromSelectionOrHistory; setReplacementFromHistory. "If we have no selection, give the user one to avoid annoying surprises." ^ self hasSelection ifTrue: [self findReplaceAgainNow] ifFalse: [self findAgainNow. false "see #againUpToEnd"]! ! !TextEditor methodsFor: 'menu messages' stamp: 'mt 12/21/2015 14:16' prior: 34614655! findReplaceAgain ^ self again! ! !TextEditor methodsFor: 'typing support' stamp: 'mt 12/21/2015 15:17'! removePreviousInsertion "If the previous command was an insertion, remove it by not undoing it but replacing it with nothing." self history hasInsertedSomething ifFalse: [morph flash. ^ false]. self selectInvisiblyFrom: self history previous intervalBefore first to: self history previous intervalAfter last. self replaceSelectionWith: self nullText. ^ true ! ! !TextEditor methodsFor: 'accessing' stamp: 'mt 11/26/2015 16:47' prior: 34617063! setReplacementFromHistory "Use history to get the previous replacement." self history hasReplacedSomething ifTrue: [ChangeText := self history previous contentsAfter].! ! !TextEditor methodsFor: 'accessing' stamp: 'mt 12/21/2015 15:02' prior: 34617488! setSearchFromSelectionOrHistory "Updates the current string to find with the current selection or the last change if it replaced something and thus had a prior selection." self hasSelection ifTrue: [FindText := self selection] ifFalse: [self history hasReplacedSomething ifTrue: [FindText := self history previous contentsBefore] ifFalse: [self history hasInsertedSomething ifTrue: [ FindText := self history previous contentsAfter. self removePreviousInsertion. "Undoable."]]]! ! "Morphic"! !PBNumericPreferenceView methodsFor: 'user interface' stamp: 'kfr 1/4/2016 09:10' prior: 56979074! representativeButtonWithColor: aColor inPanel: aPreferenceBrowser ^self horizontalPanel layoutInset: 2; color: aColor; cellInset: 20; cellPositioning: #center; addMorphBack: (StringMorph contents: self preference name); addMorphBack: self horizontalFiller; addMorphBack: self textField; yourself.! ! !PBColorPreferenceView methodsFor: 'user interface' stamp: 'kfr 1/3/2016 18:04' prior: 34152535! changeColor: aButton NewColorPickerMorph useIt ifTrue: [ (NewColorPickerMorph on: self originalColor: aButton color setColorSelector: #setButtonColor:) openNear: aButton fullBoundsInWorld ] ifFalse: [ ColorPickerMorph new choseModalityFromPreference ; sourceHand: aButton activeHand ; target: self ; selector: #setButtonColor: ; originalColor: aButton color ; putUpFor: aButton near: aButton fullBoundsInWorld ] ! ! !PBColorPreferenceView methodsFor: 'user interface' stamp: 'kfr 1/3/2016 18:08'! setButtonColor: aColor button color: aColor. self preference preferenceValue: aColor. button label: self preference preferenceValue asString. self adjustLabelColor ! ! "PreferenceBrowser"! !PluggableSystemWindow methodsFor: 'initialization' stamp: 'cmm 11/19/2015 16:23' prior: 33511416! delete (model notNil and: [ closeWindowSelector notNil ]) ifTrue: [ model perform: closeWindowSelector ]. super delete! ! "ToolBuilder-Morphic"! !Utilities class methodsFor: 'identification' stamp: 'eem 1/5/2016 12:21' prior: 58582575! dateTimeSuffix "Answer a string which indicates the date and time, intended for use in building fileout filenames, etc." "Utilities dateTimeSuffix" ^Preferences twentyFourHourFileStamps ifFalse: [self monthDayTimeStringFrom: Time totalSeconds] ifTrue: [self monthDayTime24StringFrom: Time totalSeconds]! ! "System"! !Array methodsFor: 'converting' stamp: 'eem 1/5/2016 12:36' prior: 51278198! elementsForwardIdentityTo: otherArray "This primitive performs a bulk mutation, causing all pointers to the elements of the receiver to be replaced by pointers to the corresponding elements of otherArray. The identityHashes remain with the pointers rather than with the objects so that the objects in this array should still be properly indexed in any existing hashed structures after the mutation." ec == #'bad receiver' ifTrue: [^self error: 'receiver must be of class Array']. ec == #'bad argument' ifTrue: [^self error: (otherArray class == Array ifTrue: ['arg must be of class Array'] ifFalse: ['receiver and argument must have the same size'])]. ec == #'inappropriate operation' ifTrue: [^self error: 'can''t become immediates such as SmallIntegers or Characters']. ec == #'no modification' ifTrue: [^self error: 'can''t become immutable objects']. ec == #'object is pinned' ifTrue: [^self error: 'can''t become pinned objects']. ec == #'insufficient object memory' ifTrue: [Smalltalk garbageCollect < 1048576 ifTrue: [Smalltalk growMemoryByAtLeast: 1048576]. ^self elementsForwardIdentityTo: otherArray]. self primitiveFailed! ! "Collections"! !SystemProgressMorph methodsFor: 'private' stamp: 'eem 1/5/2016 12:08' prior: 27224043! position: aPoint label: shortDescription min: minValue max: maxValue | slot range barSize lastRefresh | requestedPosition := aPoint. ((range := maxValue - minValue) < 0 or: [(slot := self nextSlotFor: shortDescription) = 0]) ifTrue: [^[:barVal| 0 ]]. range <= 0 ifTrue: [self removeMorph: (bars at: slot)]. self reposition. self openInWorld. barSize := -1. "Enforces a inital draw of the morph" lastRefresh := 0. ^[:barVal | | newBarSize | barVal isString ifTrue: [ self setLabel: barVal at: slot. self currentWorld displayWorld]. (barVal isNumber and: [range >= 1 and: [barVal between: minValue and: maxValue]]) ifTrue: [ newBarSize := (barVal - minValue / range * BarWidth) truncated. newBarSize = barSize ifFalse: [ barSize := newBarSize. (bars at: slot) barSize: barSize. Time utcMicrosecondClock - lastRefresh > 25000 ifTrue: [ self currentWorld displayWorld. lastRefresh := Time utcMicrosecondClock]]]. slot]! ! SystemProgressMorph removeSelector: #label:min:max:! "Morphic"! !Time class methodsFor: '*51Deprecated-primitives' stamp: 'ul 4/27/2013 22:00' prior: 63632457! primLocalMicrosecondClock "Answer the local microseconds since the Smalltalk epoch. The value is derived from the Posix epoch with a constant offset corresponding to elapsed microseconds between the two epochs according to RFC 868, and with an offset duration corresponding to the current offset of local time from UTC." ^0! ! !Time class methodsFor: '*51Deprecated-primitives' stamp: 'dtl 8/14/2010 15:25' prior: 63632868! primMicrosecondClock "Answer the number of microseconds since the microsecond clock was last reset or rolled over. Answer zero if the primitive fails." ^ 0! ! !Time class methodsFor: '*51Deprecated-primitives' stamp: 'brp 8/23/2003 22:01' prior: 63624400! primMillisecondClock "Primitive. Answer the number of milliseconds since the millisecond clock was last reset or rolled over. Answer zero if the primitive fails. Optional. See Object documentation whatIsAPrimitive." ^ 0! ! !Time class methodsFor: '*51Deprecated-primitives' stamp: 'dtl 4/13/2011 08:02' prior: 63633136! primMillisecondClockMask "Answer the mask value used for millisecond clock rollover in the virtual machine, or nil if the VM cannot support the request." ^nil! ! !Time class methodsFor: '*51Deprecated-primitives' stamp: 'brp 8/23/2003 22:01' prior: 63624718! primSecondsClock "Answer the number of seconds since 00:00 on the morning of January 1, 1901 (a 32-bit unsigned number). Essential. See Object documentation whatIsAPrimitive. " self primitiveFailed! ! !Time class methodsFor: '*51Deprecated-primitives' stamp: 'ul 4/27/2013 22:05' prior: 63633689! primUTCMicrosecondClock "Answer the UTC microseconds since the Smalltalk epoch. The value is derived from the Posix epoch with a constant offset corresponding to elapsed microseconds between the two epochs according to RFC 868." ^0! ! !Time class methodsFor: '*51Deprecated-primitives' stamp: 'kph 12/14/2006 01:43' prior: 63634349! secondsWhenClockTicks "waits for the moment when a new second begins" | lastSecond delay | delay := Delay forMilliseconds: 1. lastSecond := self primSecondsClock. [ lastSecond = self primSecondsClock ] whileTrue: [ delay wait ]. ^ lastSecond + 1! ! "51Deprecated"! !NetNameResolver class methodsFor: 'lookups' stamp: 'eem 1/5/2016 13:07' prior: 34287095! addressForName: hostName timeout: secs "Look up the given host name and return its address. Return nil if the address is not found in the given number of seconds." "NetNameResolver addressForName: 'create.ucsb.edu' timeout: 30" "NetNameResolver addressForName: '100000jobs.de' timeout: 30" "NetNameResolver addressForName: '1.7.6.4' timeout: 30" "NetNameResolver addressForName: '' timeout: 30 (This seems to return nil?)" | deadline | self initializeNetwork. self useOldNetwork ifFalse: [^self addressForName: hostName]. "check if this is a valid numeric host address (e.g. 1.2.3.4)" (self addressFromString: hostName) ifNotNil: [ :numericHostAddress | ^numericHostAddress ]. "Look up a host name, including ones that start with a digit (e.g. 100000jobs.de or squeak.org)" deadline := Time utcMicrosecondClock + (secs * 1000000). "Protect the execution of this block, as the ResolverSemaphore is used for both parts of the transaction." ^(self resolverMutex critical: [ (self waitForResolverReadyUntil: deadline) ifTrue: [ self primStartLookupOfName: hostName. (self waitForCompletionUntil: deadline) ifTrue: [ self primNameLookupResult. ] ] ]) ifNil: [ (NameLookupFailure hostName: hostName) signal: 'Could not resolve the server named: ', hostName ] ! ! !NetNameResolver class methodsFor: 'lookups' stamp: 'eem 1/5/2016 13:07' prior: 34288635! nameForAddress: hostAddress timeout: secs "Look up the given host address and return its name. Return nil if the lookup fails or is not completed in the given number of seconds. Depends on the given host address being known to the gateway, which may not be the case for dynamically allocated addresses." "NetNameResolver nameForAddress: (NetNameResolver addressFromString: '128.111.92.2') timeout: 30" | deadline | self initializeNetwork. deadline := Time utcMicrosecondClock + (secs * 1000000). "Protect the execution of this block, as the ResolverSemaphore is used for both parts of the transaction." ^self resolverMutex critical: [ (self waitForResolverReadyUntil: deadline) ifTrue: [ self primStartLookupOfAddress: hostAddress. (self waitForCompletionUntil: deadline) ifTrue: [ self primAddressLookupResult ] ] ]! ! !NetNameResolver class methodsFor: 'private' stamp: 'eem 1/5/2016 13:09' prior: 34289573! waitForCompletionUntil: deadline "Wait until deadline for the resolver to be ready to accept a new request. Return true if the resolver is ready, false if the network is not initialized or the resolver has not become free within the given time period." | status millisecondsLeft | status := self resolverStatus. [ status = ResolverBusy and: [millisecondsLeft := (deadline - Time utcMicrosecondClock) // 1000. millisecondsLeft > 0 ] ] whileTrue: "wait for resolver to be available" [ ResolverSemaphore waitTimeoutMSecs: millisecondsLeft. status := self resolverStatus ]. status = ResolverReady ifTrue: [ ^true ]. status = ResolverBusy ifTrue: [ self primAbortLookup ]. ^false! ! !NetNameResolver class methodsFor: 'private' stamp: 'eem 1/5/2016 13:10' prior: 34290457! waitForResolverReadyUntil: deadline "Wait until deadline for the resolver to be ready to accept a new request. Return true if the resolver is not busy, false if the network is not initialized or the resolver has not become free within the given time period." | status millisecondsLeft | (status := self resolverStatus) = ResolverUninitialized ifTrue: [ ^false ]. [ status = ResolverBusy and: [millisecondsLeft := (deadline - Time utcMicrosecondClock) // 1000. millisecondsLeft > 0 ] ] whileTrue: "wait for resolver to be available" [ ResolverSemaphore waitTimeoutMSecs: millisecondsLeft. status := self resolverStatus ]. ^status ~= ResolverBusy! ! "Network"! Object subclass: #Delay instanceVariableNames: 'delayDuration resumptionTime delaySemaphore beingWaitedOn' classVariableNames: 'AccessProtect ActiveDelay DelaySuspended FinishedDelay RunTimerEventLoop ScheduledDelay SuspendedDelays TimerEventLoop TimingSemaphore' poolDictionaries: '' category: 'Kernel-Processes'! !Delay commentStamp: 'eem 1/5/2016 11:58' prior: 50637066! I am the main way that a process may pause for some amount of time. The simplest usage is like this: (Delay forSeconds: 5) wait. An instance of Delay responds to the message 'wait' by suspending the caller's process for a certain amount of time. The duration of the pause is specified when the Delay is created with the message forMilliseconds: or forSeconds:. A Delay can be used again when the current wait has finished. For example, a clock process might repeatedly wait on a one-second Delay. A delay in progress when an image snapshot is saved is resumed when the snapshot is re-started. For a more complex example, see #testDelayOf:for:rect: . A word of advice: This is THE highest priority code which is run in Squeak, in other words it is time-critical. The speed of this code is critical for accurate responses, it is critical for network services, it affects every last part of the system. In short: Don't fix it if it ain't broken!! This code isn't supposed to be beautiful, it's supposed to be fast!! The reason for duplicating code is to make it fast. The reason for not using ifNil:[]ifNotNil:[] is that the compiler may not inline those. Since the effect of changes are VERY hard to predict it is best to leave things as they are for now unless there is an actual need to change anything Instance Variables beingWaitedOn: delayDuration: delaySemaphore: resumptionTime: beingWaitedOn - this is set when the delay is being waited on or is unscheduled. delayDuration - the duration of the delay in milliseconds delaySemaphore - the semaphore used to suspend process(es) waiting on this delay resumptionTime - the value of the UTC miscrosecond clock at which the delay should resume processes waiting on it'! Magnitude subclass: #DateAndTime instanceVariableNames: 'seconds offset jdn nanos' classVariableNames: 'ClockProvider DaysSinceEpoch LocalTimeZone' poolDictionaries: 'ChronologyConstants' category: 'Kernel-Chronology'! !DateAndTime commentStamp: 'brp 5/13/2003 08:07' prior: 60010146! I represent a point in UTC time as defined by ISO 8601. I have zero duration. My implementation uses three SmallIntegers and a Duration: jdn - julian day number. seconds - number of seconds since midnight. nanos - the number of nanoseconds since the second. offset - duration from UTC. The nanosecond attribute is almost always zero but it defined for full ISO compliance and is suitable for timestamping. ! Magnitude subclass: #Time instanceVariableNames: 'seconds nanos' classVariableNames: '' poolDictionaries: 'ChronologyConstants' category: 'Kernel-Chronology'! !Time commentStamp: 'dew 10/23/2004 17:58' prior: 63589000! This represents a particular point in time during any given day. For example, '5:19:45 pm'. If you need a point in time on a particular day, use DateAndTime. If you need a duration of time, use Duration. ! !Random methodsFor: 'initialization' stamp: 'eem 1/5/2016 13:14' prior: 63573846! seed: anIntegerOrNil "Use the given integer as the seed, or generate one if it's nil." | newSeed | newSeed := anIntegerOrNil ifNil: [(Time utcMicrosecondClock bitShift: 28) bitXor: self hash hashMultiply]. (newSeed between: 0 and: 16rFFFFFFFF) ifFalse: [newSeed := self hashSeed: newSeed]. self initializeStatesWith: newSeed; generateStates! ! !Delay class methodsFor: 'timer process' stamp: 'eem 1/5/2016 11:37' prior: 50656309! handleTimerEvent "Handle a timer event; which can be either: - a schedule request (ScheduledDelay notNil) - an unschedule request (FinishedDelay notNil) - a timer signal (not explicitly specified) We check for timer expiry every time we get a signal." | nowTick nextTick | "Wait until there is work to do." TimingSemaphore wait. nowTick := Time utcMicrosecondClock. "Process any schedule requests" ScheduledDelay ifNotNil: [self scheduleDelay: ScheduledDelay from: nowTick. ScheduledDelay := nil]. "Process any unschedule requests" FinishedDelay ifNotNil: [self unscheduleDelay: FinishedDelay. FinishedDelay := nil]. "Signal any expired delays" [ActiveDelay notNil and: [nowTick >= ActiveDelay resumptionTime]] whileTrue: [ActiveDelay signalWaitingProcess. ActiveDelay := SuspendedDelays isEmpty ifFalse: [SuspendedDelays removeFirst]]. "And signal when the next request is due. We sleep at most 1sec here as a soft busy-loop so that we don't accidentally miss signals." nextTick := nowTick + 1000000. ActiveDelay ifNotNil: [nextTick := nextTick min: ActiveDelay resumptionTime]. "Since we have processed all outstanding requests, reset the timing semaphore so that only new work will wake us up again. Do this RIGHT BEFORE setting the next wakeup call from the VM because it is only signaled once so we mustn't miss it." TimingSemaphore initSignals. Delay primSignal: TimingSemaphore atUTCMicroseconds: nextTick! ! !Delay class methodsFor: 'timer process' stamp: 'eem 1/5/2016 11:37' prior: 50652407! restoreResumptionTimes "Private!! Restore the resumption times of all scheduled Delays after a snapshot. This method should be called only while the AccessProtect semaphore is held." | newBaseTime | newBaseTime := Time utcMicrosecondClock. SuspendedDelays do: [:d | d adjustResumptionTimeOldBase: 0 newBase: newBaseTime]. ActiveDelay ifNotNil: [ActiveDelay adjustResumptionTimeOldBase: 0 newBase: newBaseTime]! ! !Delay class methodsFor: 'timer process' stamp: 'eem 1/5/2016 11:37' prior: 50653691! saveResumptionTimes "Private!! Record the resumption times of all Delays relative to a base time of zero. This is done prior to snapshotting. This method should be called only while the AccessProtect semaphore is held." | oldBaseTime | oldBaseTime := Time utcMicrosecondClock. ActiveDelay ifNotNil: [ActiveDelay adjustResumptionTimeOldBase: oldBaseTime newBase: 0]. SuspendedDelays do: [:d | d adjustResumptionTimeOldBase: oldBaseTime newBase: 0]! ! !Delay class methodsFor: 'timer process' stamp: 'eem 1/5/2016 11:51' prior: 50660937! startTimerEventLoop "Start the timer event loop" "Delay startTimerEventLoop" self stopTimerEventLoop. AccessProtect := Semaphore forMutualExclusion. SuspendedDelays := Heap withAll: (SuspendedDelays ifNil:[#()]) sortBlock: [:d1 :d2 | d1 resumptionTime <= d2 resumptionTime]. TimingSemaphore := Semaphore new. RunTimerEventLoop := true. TimerEventLoop := [self runTimerEventLoop] newProcess. TimerEventLoop priority: Processor timingPriority. TimerEventLoop resume. TimingSemaphore signal "get going"! ! !DateAndTime class methodsFor: 'initialize-release' stamp: 'eem 1/5/2016 12:45' prior: 60069227! initialize super initialize. ClockProvider := Time. Smalltalk addToStartUpList: self. self startUp: true! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'eem 1/5/2016 12:15' prior: 60052039! milliSecondsSinceMidnight ^Time milliSecondsSinceMidnight! ! !DateAndTime class methodsFor: 'initialize-release' stamp: 'eem 1/5/2016 12:44' prior: 60071856! startUp: resuming | durationSinceEpoch | resuming ifFalse: [^self]. durationSinceEpoch := Duration days: SqueakEpoch hours: 0 minutes: 0 seconds: self clock totalSeconds. DaysSinceEpoch := durationSinceEpoch days! ! !Time class methodsFor: 'clock' stamp: 'eem 1/5/2016 13:24' prior: 34661128! localMicrosecondClock "Answer the local microseconds since the Smalltalk epoch (January 1st 1901, the start of the 20th century). The value is derived from the Posix epoch with a constant offset corresponding to elapsed microseconds between the two epochs according to RFC 868, and with an offset duration corresponding to the current offset of local time from UTC." ^0! ! !Time class methodsFor: 'ansi protocol' stamp: 'eem 1/5/2016 12:14' prior: 63604484! milliSecondsSinceMidnight ^self localMicrosecondClock // 1000 \\ 86400000 "24 * 60 * 60 * 1000"! ! !Time class methodsFor: 'general inquiries' stamp: 'eem 1/5/2016 12:48' prior: 63618988! millisecondClockValue "Answer the value of the millisecond clock." ^self localMicrosecondClock // 1000! ! !Time class methodsFor: 'squeak protocol' stamp: 'eem 1/5/2016 12:03' prior: 63630408! milliseconds: currentTime since: lastTime "Answer the elapsed time since last recorded in milliseconds (i.e. of millisecondClockValue). Since the time basis is now a 61-bit or greater UTC microsecond clock, rollover is no longer an issue." ^currentTime - lastTime! ! !Time class methodsFor: 'general inquiries' stamp: 'eem 1/5/2016 12:04' prior: 63619584! millisecondsToRun: timedBlock "Answer the number of milliseconds timedBlock takes to return its value." | startUsecs | startUsecs := self utcMicrosecondClock. timedBlock value. ^self utcMicrosecondClock - startUsecs + 500 // 1000! ! !Time class methodsFor: 'smalltalk-80' stamp: 'eem 1/5/2016 12:40' prior: 63628297! totalSeconds "Answer the total seconds since the Squeak epoch: 1 January 1901, in local time." ^self localMicrosecondClock // 1000000! ! !Time class methodsFor: 'clock' stamp: 'eem 1/5/2016 13:24' prior: 34661717! utcMicrosecondClock "Answer the UTC microseconds since the Smalltalk epoch (January 1st 1901, the start of the 20th century). The value is derived from the Posix epoch with a constant offset corresponding to elapsed microseconds between the two epochs according to RFC 868." ^0! ! Time class removeSelector: #millisecondClockMask! Time class removeSelector: #initializeMillisecondClockMask! DateAndTime class removeSelector: #waitForOffsets! DateAndTime class removeSelector: #initializeOffsets! "Kernel"! ----QUIT----{5 January 2016 . 4:32:48 pm} trunk50.image priorSource: 1102889! ----STARTUP----{5 January 2016 . 5:13:49 pm} as /Users/eliot/oscogvm/image/trunk50.image! [MCMcmUpdater defaultUpdateURL: 'http://source.squeak.org/trunk'; updateFromServer] valueSupplyingAnswer: true. Smalltalk snapshot: true andQuit: true ! ----End fileIn of a ReadStream----! ----STARTUP----{5 January 2016 . 5:46:52 pm} as /Users/eliot/oscogvm/image/trunk50.image! [MCMcmUpdater defaultUpdateURL: 'http://source.squeak.org/trunk'; updateFromServer] valueSupplyingAnswer: true. Smalltalk snapshot: true andQuit: true ! ----End fileIn of a ReadStream----! !Integer methodsFor: 'truncation and round off' stamp: 'eem 1/5/2016 17:26'! fractionPart "Added for ANSI compatibility" ^0! ! !Integer methodsFor: 'truncation and round off' stamp: 'eem 1/5/2016 17:26'! integerPart "Added for ANSI compatibility" ^self! ! !Delay methodsFor: 'printing' stamp: 'eem 1/5/2016 17:19' prior: 50644620! printOn: aStream super printOn: aStream. aStream nextPut: $(; print: delayDuration; nextPutAll: ' msecs'. beingWaitedOn ifTrue: [aStream nextPutAll: '; '; print: resumptionTime - Time utcMicrosecondClock + 500 // 1000; nextPutAll: ' msecs remaining']. aStream nextPut: $)! ! Delay class removeSelector: #scheduleDelay:! "Kernel"! Object subclass: #MenuIcons instanceVariableNames: '' classVariableNames: 'Icons TranslatedIcons TranslationLocale' poolDictionaries: '' category: 'Morphic-Menus'! !MenuIcons commentStamp: 'sd 11/9/2003 14:09' prior: 61080421! I represent a registry for icons. You can see the icons I contain using the following script: | dict methods | dict := Dictionary new. methods := MenuIcons class selectors select: [:each | '*Icon' match: each asString]. methods do: [:each | dict at: each put: (MenuIcons perform: each)]. GraphicalDictionaryMenu openOn: dict withLabel: 'MenuIcons'! !MenuIcons class methodsFor: 'class initialization' stamp: 'eem 1/5/2016 17:32' prior: 61105427! initializeTranslations "Initialize the dictionary of ->" TranslationLocale := LocaleID current. TranslatedIcons := Dictionary new. self itemsIcons do: [:assoc| assoc key do: [:str| TranslatedIcons at: str translated asLowercase put: assoc value]]! ! !MenuIcons class methodsFor: 'class initialization' stamp: 'eem 1/5/2016 17:33' prior: 61105764! startUp: resuming resuming ifFalse: [^self]. TranslationLocale = LocaleID current ifTrue: [^self]. self initializeTranslations! ! "Morphic"! ----QUIT----{5 January 2016 . 5:47:11 pm} trunk50.image priorSource: 1134908! ----STARTUP----{16 January 2016 . 9:48:16 am} as /Users/eliot/oscogvm/image/trunk50.image! [MCMcmUpdater defaultUpdateURL: 'http://source.squeak.org/trunk'; updateFromServer] valueSupplyingAnswer: true. Smalltalk snapshot: true andQuit: true ! ----End fileIn of a ReadStream----! LinkedList subclass: #Monitor instanceVariableNames: 'ownerProcess defaultQueue queueDict queuesMutex mutex nestingLevel' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Processes'! !Monitor commentStamp: 'md 3/3/2006 09:19' prior: 54421489! A monitor provides process synchronization that is more high level than the one provided by a Semaphore. Similar to the classical definition of a Monitor it has the following properties: 1) At any time, only one process can execute code inside a critical section of a monitor. 2) A monitor is reentrant, which means that the active process in a monitor never gets blocked when it enters a (nested) critical section of the same monitor. 3) Inside a critical section, a process can wait for an event that may be coupled to a certain condition. If the condition is not fulfilled, the process leaves the monitor temporarily (in order to let other processes enter) and waits until another process signals the event. Then, the original process checks the condition again (this is often necessary because the state of the monitor could have changed in the meantime) and continues if it is fulfilled. 4) The monitor is fair, which means that the process that is waiting on a signaled condition the longest gets activated first. 5) The monitor allows you to define timeouts after which a process gets activated automatically. Basic usage: Monitor>>critical: aBlock Critical section. Executes aBlock as a critical section. At any time, only one process can execute code in a critical section. NOTE: All the following synchronization operations are only valid inside the critical section of the monitor!! Monitor>>wait Unconditional waiting for the default event. The current process gets blocked and leaves the monitor, which means that the monitor allows another process to execute critical code. When the default event is signaled, the original process is resumed. Monitor>>waitWhile: aBlock Conditional waiting for the default event. The current process gets blocked and leaves the monitor only if the argument block evaluates to true. This means that another process can enter the monitor. When the default event is signaled, the original process is resumed, which means that the condition (argument block) is checked again. Only if it evaluates to false, does execution proceed. Otherwise, the process gets blocked and leaves the monitor again... Monitor>>waitUntil: aBlock Conditional waiting for the default event. See Monitor>>waitWhile: aBlock. Monitor>>signal One process waiting for the default event is woken up. Monitor>>signalAll All processes waiting for the default event are woken up. Using non-default (specific) events: Monitor>>waitFor: aSymbol Unconditional waiting for the non-default event represented by the argument symbol. Same as Monitor>>wait, but the process gets only reactivated by the specific event and not the default event. Monitor>>waitWhile: aBlock for: aSymbol Confitional waiting for the non-default event represented by the argument symbol. Same as Monitor>>waitWhile:for:, but the process gets only reactivated by the specific event and not the default event. Monitor>>waitUntil: aBlock for: aSymbol Confitional waiting for the non-default event represented by the argument symbol. See Monitor>>waitWhile:for: aBlock. Monitor>>signal: aSymbol One process waiting for the given event is woken up. If there is no process waiting for this specific event, a process waiting for the default event gets resumed. Monitor>>signalAll: aSymbol All process waiting for the given event or the default event are woken up. Monitor>>signalReallyAll All processes waiting for any events (default or specific) are woken up. Using timeouts Monitor>>waitMaxMilliseconds: anInteger Monitor>>waitFor: aSymbol maxMilliseconds: anInteger Same as Monitor>>wait (resp. Monitor>>waitFor:), but the process gets automatically woken up when the specified time has passed. Monitor>>waitWhile: aBlock maxMilliseconds: anInteger Monitor>>waitWhile: aBlock for: aSymbol maxMilliseconds: anInteger Same as Monitor>>waitWhile: (resp. Monitor>>waitWhile:for:), but the process gets automatically woken up when the specified time has passed. Monitor>>waitUntil: aBlock maxMilliseconds: anInteger Monitor>>waitUntil: aBlock for: aSymbol maxMilliseconds: anInteger Same as Monitor>>waitUntil: (resp. Monitor>>waitUntil:for:), but the process gets automatically woken up when the specified time has passed.! LinkedList subclass: #Mutex instanceVariableNames: 'owner semaphore' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Processes'! !Mutex commentStamp: '' prior: 28398132! A Mutex is a light-weight MUTual EXclusion object being used when two or more processes need to access a shared resource concurrently. A Mutex grants ownership to a single process and will suspend any other process trying to aquire the mutex while in use. Waiting processes are granted access to the mutex in the order the access was requested. Instance variables: semaphore The (primitive) semaphore used for synchronization. owner The process owning the mutex.! !Monitor methodsFor: 'private-primitives' stamp: 'eem 1/5/2016 09:00'! primitiveEnterCriticalSection "Primitive. The receiver must be unowned or owned by the current process to proceed. Answer if the process is owned by the current process. Copyright (c) 2016 - 3D Immersive Collaboration Consulting, LLC." self primitiveFailed "In the spirit of the following" "[owner ifNil: [owner := Processor activeProcess. ^false]. owner = Processor activeProcess ifTrue: [^true]. self addLast: Processor activeProcess. Processor activeProcess suspend] valueUnpreemptively"! ! !Monitor methodsFor: 'private-primitives' stamp: 'eem 1/5/2016 09:00'! primitiveExitCriticalSection "Primitive. Set the receiver to unowned and if any processes are waiting on the receiver then proceed the first one, indicating that the receiver is unowned. Copyright (c) 2016 - 3D Immersive Collaboration Consulting, LLC." self primitiveFailed "In the spirit of the following" "[owner := nil. self isEmpty ifFalse: [process := self removeFirst. process resume]] valueUnpreemptively"! ! !Monitor methodsFor: 'private-primitives' stamp: 'eem 1/5/2016 09:00'! primitiveTestAndSetOwnershipOfCriticalSection "Primitive. Attempt to set the ownership of the receiver. If the receiver is unowned set its owningProcess to the activeProcess and answer false. If the receiver is owned by the activeProcess answer true. If the receiver is owned by some other process answer nil. Copyright (c) 2016 - 3D Immersive Collaboration Consulting, LLC." self primitiveFail "In the spirit of the following" "[owner ifNil: [owningProcess := Processor activeProcess. ^false]. owner = Processor activeProcess ifTrue: [^true]. ^nil] valueUnpreemptively"! ! !Mutex methodsFor: 'private-primitives' stamp: 'eem 1/5/2016 09:00'! primitiveEnterCriticalSection "Primitive. The receiver must be unowned or owned by the current process to proceed. Answer if the process is owned by the current process. Copyright (c) 2016 - 3D Immersive Collaboration Consulting, LLC." self primitiveFailed "In the spirit of the following" "[owner ifNil: [owner := Processor activeProcess. ^false]. owner = Processor activeProcess ifTrue: [^true]. self addLast: Processor activeProcess. Processor activeProcess suspend] valueUnpreemptively"! ! !Mutex methodsFor: 'private-primitives' stamp: 'eem 1/5/2016 09:00'! primitiveExitCriticalSection "Primitive. Set the receiver to unowned and if any processes are waiting on the receiver then proceed the first one, indicating that the receiver is unowned. Copyright (c) 2016 - 3D Immersive Collaboration Consulting, LLC." self primitiveFailed "In the spirit of the following" "[owner := nil. self isEmpty ifFalse: [process := self removeFirst. process resume]] valueUnpreemptively"! ! !Mutex methodsFor: 'private-primitives' stamp: 'eem 1/5/2016 09:00'! primitiveTestAndSetOwnershipOfCriticalSection "Primitive. Attempt to set the ownership of the receiver. If the receiver is unowned set its owningProcess to the activeProcess and answer false. If the receiver is owned by the activeProcess answer true. If the receiver is owned by some other process answer nil. Copyright (c) 2016 - 3D Immersive Collaboration Consulting, LLC." self primitiveFail "In the spirit of the following" "[owner ifNil: [owningProcess := Processor activeProcess. ^false]. owner = Processor activeProcess ifTrue: [^true]. ^nil] valueUnpreemptively"! ! "Kernel"! !BalloonMorph class methodsFor: '*51Deprecated' stamp: 'mt 1/13/2016 08:20' prior: 21518002! setBalloonColorTo: aColor self deprecated: 'Use #balloonColor: instead.'. self balloonColor: aColor.! ! "51Deprecated"! !Socket methodsFor: 'other' stamp: 'ul 12/8/2015 20:03' prior: 22525957! setOption: aName value: aValue | value | "setup options on this socket, see Unix man pages for values for sockets, IP, TCP, UDP. IE SO_KEEPALIVE returns an array, element one is the error number element two is the resulting of the negotiated value. See #getOption: for list of keys" self isValid ifFalse: [ InvalidSocketStatusException signal: 'Socket status must valid before setting an option' ]. value := aValue caseOf: { [ true ] -> [ '1' ]. [ false ] -> [ '0' ] } otherwise: [ aValue asString ]. ^ self primSocket: socketHandle setOption: aName value: value! ! "Network"! !Bitmap methodsFor: 'converting' stamp: 'fbs 7/25/2013 07:07' prior: 28696995! asByteArray "Faster way to make a byte array from me. copyFromByteArray: makes equal Bitmap." | f bytes hack | f := Form extent: 4@self size depth: 8 bits: self. bytes := ByteArray new: self size * 4. hack := Form new hackBits: bytes. Smalltalk isLittleEndian ifTrue:[hack swapEndianness]. hack copyBits: f boundingBox from: f at: (0@0) clippingBox: hack boundingBox rule: Form over fillColor: nil map: nil. "f displayOn: hack." ^ bytes. ! ! !Bitmap methodsFor: 'copying' stamp: 'RAA 7/28/2000 21:51' prior: 28697533! copy ^self clone! ! !Color methodsFor: 'conversions' stamp: 'eem 1/16/2016 09:40' prior: 58326774! pixelValueForDepth: d "Answers an integer representing the bits that appear in a single pixel of this color in a Form of the given depth. The depth must be one of 1, 2, 4, 8, 16, or 32. Contrast with pixelWordForDepth: and bitPatternForDepth:, which answer either a 32-bit word packed with the given pixel value or a multiple-word Bitmap containing a pattern. The inverse is the class message colorFromPixelValue:depth:" "Details: For depths of 8 or less, the result is a colorMap index. For depths of 16 and 32, it is a direct color value with 5 or 8 bits per color component." "Transparency: The pixel value zero is reserved for transparent. For depths greater than 8, black maps to the darkest possible blue." | val | d > 8 ifTrue: "most common case" [d = 32 ifTrue: "eight bits per component; top 8 bits set to all ones (opaque alpha)" ["this subexpression is a SmallInteger in both 32- and 64-bits." val := ((rgb bitShift: -6) bitAnd: 16rFF0000) bitOr: (((rgb bitShift: -4) bitAnd: 16rFF00) bitOr: ((rgb bitShift: -2) bitAnd: 16rFF)). "16rFF000000 & 16rFF000001 are LargeIntegers in 32-bits, SmallIntegers in 64-bits." ^val = 0 ifTrue: [16rFF000001] ifFalse: [16rFF000000 + val]]. d = 16 ifTrue: "five bits per component; top bits ignored" [val := (((rgb bitShift: -15) bitAnd: 16r7C00) bitOr: ((rgb bitShift: -10) bitAnd: 16r03E0)) bitOr: ((rgb bitShift: -5) bitAnd: 16r001F). ^val = 0 ifTrue: [1] ifFalse: [val]]. d = 12 ifTrue: "for indexing a color map with 4 bits per color component" [val := (((rgb bitShift: -18) bitAnd: 16r0F00) bitOr: ((rgb bitShift: -12) bitAnd: 16r00F0)) bitOr: ((rgb bitShift: -6) bitAnd: 16r000F). ^val = 0 ifTrue: [1] ifFalse: [val]]. d = 9 ifTrue: "for indexing a color map with 3 bits per color component" [val := (((rgb bitShift: -21) bitAnd: 16r01C0) bitOr: ((rgb bitShift: -14) bitAnd: 16r0038)) bitOr: ((rgb bitShift: -7) bitAnd: 16r0007). ^val = 0 ifTrue: [1] ifFalse: [val]]]. d = 8 ifTrue: [^ self closestPixelValue8]. d = 4 ifTrue: [^ self closestPixelValue4]. d = 2 ifTrue: [^ self closestPixelValue2].. d = 1 ifTrue: [^ self closestPixelValue1]. self error: 'unknown pixel depth: ', d printString ! ! "Graphics"! Magnitude subclass: #DateAndTime instanceVariableNames: 'seconds offset jdn nanos' classVariableNames: 'ClockProvider LastClockValue LocalTimeZone NanoOffset' poolDictionaries: 'ChronologyConstants' category: 'Kernel-Chronology'! !DateAndTime commentStamp: 'brp 5/13/2003 08:07' prior: 34681721! I represent a point in UTC time as defined by ISO 8601. I have zero duration. My implementation uses three SmallIntegers and a Duration: jdn - julian day number. seconds - number of seconds since midnight. nanos - the number of nanoseconds since the second. offset - duration from UTC. The nanosecond attribute is almost always zero but it defined for full ISO compliance and is suitable for timestamping. ! LinkedList subclass: #Monitor instanceVariableNames: 'ownerProcess defaultQueue queueDict queuesMutex mutex nestingLevel' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Processes'! !Monitor commentStamp: 'eem 1/7/2016 11:38' prior: 34692525! A monitor provides process synchronization that is more high level than the one provided by a Semaphore. Similar to the classical definition of a Monitor it has the following properties: 1) At any time, only one process can execute code inside a critical section of a monitor. 2) A monitor is reentrant, which means that the active process in a monitor never gets blocked when it enters a (nested) critical section of the same monitor. For example a monitor will not block when trying the following: | m | m := Monitor new. m critical: [m critical: [#yes]] whereas a Semaphore will deadlock: | s | s := Semaphore forMutualExclusion. s critical: [s critical: [#no]] 3) Inside a critical section, a process can wait for an event that may be coupled to a certain condition. If the condition is not fulfilled, the process leaves the monitor temporarily (in order to let other processes enter) and waits until another process signals the event. Then, the original process checks the condition again (this is often necessary because the state of the monitor could have changed in the meantime) and continues if it is fulfilled. 4) The monitor is fair, which means that the process that is waiting on a signaled condition the longest gets activated first. 5) The monitor allows you to define timeouts after which a process gets activated automatically. Basic usage: Monitor>>critical: aBlock Critical section. Executes aBlock as a critical section. At any time, only one process can execute code in a critical section. NOTE: All the following synchronization operations are only valid inside the critical section of the monitor!! Monitor>>wait Unconditional waiting for the default event. The current process gets blocked and leaves the monitor, which means that the monitor allows another process to execute critical code. When the default event is signaled, the original process is resumed. Monitor>>waitWhile: aBlock Conditional waiting for the default event. The current process gets blocked and leaves the monitor only if the argument block evaluates to true. This means that another process can enter the monitor. When the default event is signaled, the original process is resumed, which means that the condition (argument block) is checked again. Only if it evaluates to false, does execution proceed. Otherwise, the process gets blocked and leaves the monitor again... Monitor>>waitUntil: aBlock Conditional waiting for the default event. See Monitor>>waitWhile: aBlock. Monitor>>signal One process waiting for the default event is woken up. Monitor>>signalAll All processes waiting for the default event are woken up. Using non-default (specific) events: Monitor>>waitFor: aSymbol Unconditional waiting for the non-default event represented by the argument symbol. Same as Monitor>>wait, but the process gets only reactivated by the specific event and not the default event. Monitor>>waitWhile: aBlock for: aSymbol Confitional waiting for the non-default event represented by the argument symbol. Same as Monitor>>waitWhile:for:, but the process gets only reactivated by the specific event and not the default event. Monitor>>waitUntil: aBlock for: aSymbol Confitional waiting for the non-default event represented by the argument symbol. See Monitor>>waitWhile:for: aBlock. Monitor>>signal: aSymbol One process waiting for the given event is woken up. If there is no process waiting for this specific event, a process waiting for the default event gets resumed. Monitor>>signalAll: aSymbol All process waiting for the given event or the default event are woken up. Monitor>>signalReallyAll All processes waiting for any events (default or specific) are woken up. Using timeouts Monitor>>waitMaxMilliseconds: anInteger Monitor>>waitFor: aSymbol maxMilliseconds: anInteger Same as Monitor>>wait (resp. Monitor>>waitFor:), but the process gets automatically woken up when the specified time has passed. Monitor>>waitWhile: aBlock maxMilliseconds: anInteger Monitor>>waitWhile: aBlock for: aSymbol maxMilliseconds: anInteger Same as Monitor>>waitWhile: (resp. Monitor>>waitWhile:for:), but the process gets automatically woken up when the specified time has passed. Monitor>>waitUntil: aBlock maxMilliseconds: anInteger Monitor>>waitUntil: aBlock for: aSymbol maxMilliseconds: anInteger Same as Monitor>>waitUntil: (resp. Monitor>>waitUntil:for:), but the process gets automatically woken up when the specified time has passed.! LinkedList subclass: #Mutex instanceVariableNames: 'owner' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Processes'! !Mutex commentStamp: 'eem 1/7/2016 11:36' prior: 34696948! A Mutex is a light-weight MUTual EXclusion object being used when two or more processes need to access a shared resource concurrently. A Mutex grants ownership to a single process and will suspend any other process trying to aquire the mutex while in use. Waiting processes are granted access to the mutex in the order the access was requested. A Mutex allows the owning process to reenter as many times as desired. For example a Mutex will not block when trying the following: | m | m := Mutex new. m critical: [m critical: [#yes]] whereas a Semaphore will deadlock: | s | s := Semaphore forMutualExclusion. s critical: [s critical: [#no]] Instance variables: owner The process owning the mutex! !MethodContext methodsFor: 'closure support' stamp: 'eem 1/7/2016 11:48' prior: 62145040! isClosureContext ^closureOrNil ~~ nil! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'ul 1/10/2016 18:17' prior: 60050351! julianDayNumber: anInteger offset: aDuration ^self basicNew setJdn: anInteger seconds: 0 nano: 0 offset: aDuration! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'ul 1/10/2016 18:10' prior: 34658617! nowWithOffset: aDuration | clockValue nanos | clockValue := Time utcMicrosecondClock. "Ensure that consecutive sends of this method return increasing values, by adding small values to the nanosecond part of the created object. The next few lines are assumed to be executed atomically - having no suspension points." ((LastClockValue ifNil: [ 0 ]) digitCompare: clockValue) = 0 ifTrue: [ NanoOffset := NanoOffset + 1 ] ifFalse: [ NanoOffset := 0 ]. LastClockValue := clockValue. nanos := clockValue \\ 1000000 * 1000 + NanoOffset. clockValue := clockValue // 1000000. ^self basicNew setJdn: clockValue // SecondsInDay + SqueakEpoch seconds: clockValue \\ SecondsInDay nano: nanos offset: aDuration! ! !EventSensor methodsFor: 'mouse' stamp: 'tpr 1/11/2016 15:35' prior: 84368845! createMouseEvent "create and return a new mouse event from the current mouse position; this is useful for restarting normal event queue processing after manual polling" | buttons modifiers pos mapped eventBuffer | eventBuffer := Array new: 8. buttons := self primMouseButtons. pos := self primMousePt. modifiers := buttons bitShift: -3. buttons := buttons bitAnd: 7. mapped := self mapButtons: buttons modifiers: modifiers. eventBuffer at: 1 put: EventTypeMouse; at: 2 put: Time eventMillisecondClock; at: 3 put: pos x; at: 4 put: pos y; at: 5 put: mapped; at: 6 put: modifiers. ^ eventBuffer! ! !EventSensor methodsFor: 'private' stamp: 'tpr 1/11/2016 15:36' prior: 84374240! nextEventSynthesized "Return a synthesized event. This method is called if an event driven client wants to receive events but the primary user interface is not event-driven (e.g., the receiver does not have an event queue but only updates its state). This can, for instance, happen if a Morphic World is run in an MVC window. To simplify the clients work this method will always return all available keyboard events first, and then (repeatedly) the mouse events. Since mouse events come last, the client can assume that after one mouse event has been received there are no more to come. Note that it is impossible for EventSensor to determine if a mouse event has been issued before so the client must be aware of the possible problem of getting repeatedly the same mouse events. See HandMorph>>processEvents for an example on how to deal with this." | kbd array buttons pos modifiers mapped | "First check for keyboard" array := Array new: 8. kbd := self primKbdNext. kbd ifNotNil: ["simulate keyboard event" array at: 1 put: EventTypeKeyboard. "evt type" array at: 2 put: Time eventMillisecondClock. "time stamp" array at: 3 put: (kbd bitAnd: 255). "char code" array at: 4 put: EventKeyChar. "key press/release" array at: 5 put: (kbd bitShift: -8). "modifier keys" ^ array]. "Then check for mouse" pos := self primMousePt. buttons := mouseButtons. modifiers := buttons bitShift: -3. buttons := buttons bitAnd: 7. mapped := self mapButtons: buttons modifiers: modifiers. array at: 1 put: EventTypeMouse; at: 2 put: Time eventMillisecondClock; at: 3 put: pos x; at: 4 put: pos y; at: 5 put: mapped; at: 6 put: modifiers. ^ array ! ! !EventSensor methodsFor: 'private-I/O' stamp: 'tpr 1/11/2016 15:36' prior: 84386051! primGetNextEvent: array "Store the next OS event available into the provided array. Essential. If the VM is not event driven the ST code will fall back to the old-style mechanism and use the state based primitives instead." | kbd buttons modifiers pos mapped | "Simulate the events" array at: 1 put: EventTypeNone. "assume no more events" "First check for keyboard" kbd := super primKbdNext. kbd = nil ifFalse:[ "simulate keyboard event" array at: 1 put: EventTypeKeyboard. "evt type" array at: 2 put: Time eventMillisecondClock. "time stamp" array at: 3 put: (kbd bitAnd: 255). "char code" array at: 4 put: EventKeyChar. "key press/release" array at: 5 put: (kbd bitShift: -8). "modifier keys" ^self]. "Then check for mouse" buttons := super primMouseButtons. pos := super primMousePt. modifiers := buttons bitShift: -3. buttons := buttons bitAnd: 7. mapped := self mapButtons: buttons modifiers: modifiers. (pos = mousePosition and:[(mapped bitOr: (modifiers bitShift: 3)) = mouseButtons]) ifTrue:[^self]. array at: 1 put: EventTypeMouse; at: 2 put: Time eventMillisecondClock; at: 3 put: pos x; at: 4 put: pos y; at: 5 put: mapped; at: 6 put: modifiers. ! ! !Semaphore methodsFor: 'mutual exclusion' stamp: 'eem 1/7/2016 11:43' prior: 26548609! critical: mutuallyExcludedBlock "Evaluate mutuallyExcludedBlock only if the receiver is not currently in the process of running the critical: message. If the receiver is, evaluate mutuallyExcludedBlock after the other critical: message is finished." | caught | "We need to catch eventual interruptions very carefully. The naive approach of just doing, e.g.,: self wait. aBlock ensure:[self signal]. will fail if the active process gets terminated while in the wait. However, the equally naive: [self wait. aBlock value] ensure:[self signal]. will fail too, since the active process may get interrupted while entering the ensured block and leave the semaphore signaled twice. To avoid both problems we make use of the fact that interrupts only occur on sends (or backward jumps) and use an assignment (bytecode) right before we go into the wait primitive (which cannot be preempted)." caught := false. ^[ caught := true. self wait. mutuallyExcludedBlock value ] ensure: [ caught ifTrue: [self signal] ] ! ! !Monitor methodsFor: 'private' stamp: 'eem 1/5/2016 09:50' prior: 54435295! checkOwnerProcess "If the receiver is not already the owner of the section raise an error." (self primitiveTestAndSetOwnershipOfCriticalSection ifNil: [false] ifNotNil: [:alreadyOwner| alreadyOwner or: [self primitiveExitCriticalSection. false]]) ifFalse: [self error: 'Monitor access violation']! ! !Monitor methodsFor: 'mutual exclusion' stamp: 'eem 1/7/2016 11:40' prior: 54428960! critical: aBlock "Evaluate aBlock protected by the receiver." ^self primitiveEnterCriticalSection ifTrue: [aBlock value] ifFalse: [aBlock ensure: [self primitiveExitCriticalSection]]! ! !Monitor methodsFor: 'mutual exclusion' stamp: 'eem 1/7/2016 12:10'! critical: aBlock ifLocked: lockedBlock "Answer the evaluation of aBlock protected by the receiver. If it is already in a critical section on behalf of some other process answer the evaluation of lockedBlock." ^self primitiveTestAndSetOwnershipOfCriticalSection ifNil: [lockedBlock value] ifNotNil: [:alreadyOwner| alreadyOwner ifTrue: [aBlock value] ifFalse: [aBlock ensure: [self primitiveExitCriticalSection]]]! ! !Monitor methodsFor: 'private' stamp: 'eem 1/5/2016 09:42' prior: 54437568! exitAndWaitInQueue: anOrderedCollection maxMilliseconds: anIntegerOrNil [ | lock | lock := queuesMutex critical: [ anOrderedCollection addLast: Semaphore new ]. self primitiveExitCriticalSection. anIntegerOrNil ifNil: [ lock wait ] ifNotNil: [ | delay | delay := MonitorDelay signalLock: lock afterMSecs: anIntegerOrNil inMonitor: self queue: anOrderedCollection. [ lock wait ] ensure: [ delay unschedule ] ] ] ensure: [ self primitiveEnterCriticalSection ]! ! !Monitor methodsFor: 'initialize-release' stamp: 'eem 1/5/2016 09:53' prior: 54426127! initialize queuesMutex := Semaphore forMutualExclusion! ! !Mutex methodsFor: 'mutual exclusion' stamp: 'eem 1/7/2016 11:41' prior: 28398816! critical: aBlock "Evaluate aBlock protected by the receiver." ^self primitiveEnterCriticalSection ifTrue: [aBlock value] ifFalse: [aBlock ensure: [self primitiveExitCriticalSection]]! ! !Mutex methodsFor: 'mutual exclusion' stamp: 'eem 1/7/2016 12:10'! critical: aBlock ifLocked: lockedBlock "Answer the evaluation of aBlock protected by the receiver. If it is already in a critical section on behalf of some other process answer the evaluation of lockedBlock." ^self primitiveTestAndSetOwnershipOfCriticalSection ifNil: [lockedBlock value] ifNotNil: [:alreadyOwner| alreadyOwner ifTrue: [aBlock value] ifFalse: [aBlock ensure: [self primitiveExitCriticalSection]]]! ! !Process methodsFor: 'changing process state' stamp: 'eem 1/7/2016 12:08' prior: 20152703! terminate "Stop the process that the receiver represents forever. Unwind to execute pending ensure:/ifCurtailed: blocks before terminating." | ctxt unwindBlock oldList | self isActiveProcess ifTrue: [ ctxt := thisContext. [ ctxt := ctxt findNextUnwindContextUpTo: nil. ctxt isNil ] whileFalse: [ (ctxt tempAt: 2) ifNil:[ ctxt tempAt: 2 put: nil. unwindBlock := ctxt tempAt: 1. thisContext terminateTo: ctxt. unwindBlock value]. ]. thisContext terminateTo: nil. self suspend. ] ifFalse:[ "Always suspend the process first so it doesn't accidentally get woken up" oldList := self suspend. suspendedContext ifNotNil:[ "Figure out if we are terminating a process that is in the ensure: block of a critical section. In this case, if the block has made progress, pop the suspendedContext so that we leave the ensure: block inside the critical: without signaling the semaphore/exiting the primitive section, since presumably this has already happened." (suspendedContext isClosureContext and: [(suspendedContext method pragmaAt: #criticalSection) notNil and: [suspendedContext startpc > suspendedContext closure startpc]]) ifTrue: [suspendedContext := suspendedContext home]. "If we are terminating a process halfways through an unwind, try to complete that unwind block first." (suspendedContext findNextUnwindContextUpTo: nil) ifNotNil: [:outer| (suspendedContext findContextSuchThat:[:c| c closure == (outer tempAt: 1)]) ifNotNil: [:inner| "This is an unwind block currently under evaluation" suspendedContext runUntilErrorOrReturnFrom: inner]]. ctxt := self popTo: suspendedContext bottomContext. ctxt == suspendedContext bottomContext ifFalse: [self debug: ctxt title: 'Unwind error during termination']]]! ! !Time class methodsFor: 'clock' stamp: 'tpr 1/11/2016 14:18'! eventMillisecondClock "In order to make certain event handling code work (cf MouseEvent>asMouseMove) we need access to the tick kept by ioMSecs() " "Time eventMillisecondClock" ^0! ! DateAndTime class removeSelector: #startUp:! Monitor removeSelector: #isOwnerProcess! Monitor removeSelector: #exit! Monitor removeSelector: #enter! Mutex removeSelector: #initialize! "Kernel"! !ColorTheme methodsFor: 'applying' stamp: 'mt 1/13/2016 08:18' prior: 54224850! apply "apply the receiver as the current theme" BalloonMorph balloonColor: self balloonColor. Preferences setParameter: #defaultWorldColor to: self defaultWorldColor. Preferences insertionPointColor: self insertionPointColor. Preferences keyboardFocusColor: self keyboardFocusColor. Preferences textHighlightColor: self textHighlightColor. Preferences setParameter: #menuTitleColor to: self menuTitleColor. Preferences setParameter: #menuTitleBorderColor to: self menuTitleBorderColor. Preferences setParameter: #menuTitleBorderWidth to: self menuTitleBorderWidth. Preferences setParameter: #menuColor to: self menuColor. Preferences setParameter: #menuBorderColor to: self menuBorderColor. Preferences setParameter: #menuLineColor to: self menuLineColor. Preferences setParameter: #menuBorderWidth to: self menuBorderWidth. Preferences setParameter: #menuSelectionColor to: self menuSelectionColor. SystemProgressMorph reset. self class current: self. ! ! !PseudoClass methodsFor: 'accessing' stamp: 'ul 1/9/2016 22:11' prior: 28505465! allInstVarNames self realClass ifNotNil: [ :realClass | ^realClass allInstVarNames ]. ^#()! ! !PseudoClass methodsFor: 'accessing' stamp: 'ul 1/9/2016 22:11' prior: 28506012! compilerClass ^self realClass ifNil: [ Compiler ] ifNotNil: [ :realClass | realClass compilerClass ]! ! !PseudoClass methodsFor: 'accessing' stamp: 'ul 1/9/2016 22:10' prior: 28506403! instVarNames self realClass ifNotNil: [ :realClass | ^realClass instVarNames ]. ^#()! ! !PseudoClass methodsFor: 'private' stamp: 'ul 1/9/2016 22:14' prior: 28541897! parserClass ^self compilerClass parserClass! ! !PseudoClass methodsFor: 'accessing' stamp: 'ul 1/9/2016 22:23' prior: 28508954! realClass ^Smalltalk globals classNamed: self name! ! !PseudoClass methodsFor: 'enumerating' stamp: 'ul 1/9/2016 22:06'! withAllSubAndSuperclassesDo: aBlock self realClass ifNotNil: [ :realClass | ^realClass withAllSubAndSuperclassesDo: aBlock ]. ^aBlock value: self! ! !PseudoClass methodsFor: 'enumerating' stamp: 'ul 1/9/2016 22:06'! withAllSuperclassesDo: aBlock self realClass ifNotNil: [ :realClass | ^realClass withAllSuperclassesDo: aBlock ]. ^aBlock value: self! ! "System"! !WeakSet class methodsFor: 'as yet unclassified' stamp: 'ul 1/4/2016 14:54'! arrayType ^WeakArray! ! !WeakSet methodsFor: 'private' stamp: 'ul 1/4/2016 14:56' prior: 21936187! growTo: anInteger "Grow the elements array and reinsert the old elements" | oldElements | oldElements := array. array := self class arrayType new: anInteger withAll: flag. self noCheckNoGrowFillFrom: oldElements! ! !WeakSet methodsFor: 'private' stamp: 'ul 1/4/2016 14:57' prior: 21936459! initialize: n "Initialize array to an array size of n" super initialize: n. flag := Object new. array atAllPut: flag! ! "Collections"! !MCCodeTool methodsFor: 'menus' stamp: 'eem 1/7/2016 11:20' prior: 56985331! browseVersions "Create and schedule a message set browser on all versions of the currently selected message selector." (ToolSet browseVersionsOf: self selectedClassOrMetaClass selector: self selectedMessageName) ifNil: [self changed: #flash]! ! "Monticello"! !MonitorTest methodsFor: 'examples' stamp: 'eem 1/7/2016 14:19'! testCheckOwnerProcess self should: [Monitor new checkOwnerProcess] raise: Error. self shouldnt: [| m | m := Monitor new. m critical: [m checkOwnerProcess]] raise: Error. self should: [| s m | m := Monitor new. [m critical: [s := #in. Semaphore new wait]] fork. Processor yield. self assert: #in equals: s. m checkOwnerProcess] raise: Error! ! !MonitorTest methodsFor: 'examples' stamp: 'eem 1/7/2016 14:22'! testCriticalIfLocked | m s | m := Monitor new. self assert: #unlocked == (m critical: [#unlocked] ifLocked: [#locked]). [m critical: [s := #in. Semaphore new wait]] fork. Processor yield. self assert: #in equals: s. self assert: #locked equals: (m critical: [#unlocked] ifLocked: [#locked])! ! MonitorTest removeSelector: #testMonitorNotGainingUnwantedSignalsDuringUnwinding! "KernelTests"! Morph subclass: #NewBalloonMorph instanceVariableNames: 'balloonOwner textMorph maximumWidth orientation hasTail' classVariableNames: 'DefaultBalloonTextColor UseNewBalloonMorph' poolDictionaries: '' category: 'Morphic-Widgets'! !NewBalloonMorph commentStamp: 'mt 3/31/2015 10:15' prior: 56728007! A balloon is a bubble with an optional tail. It contains rich text, which describes something about its balloon-owner.! !HandMorph methodsFor: 'private events' stamp: 'tpr 1/11/2016 15:33' prior: 19318120! generateDropFilesEvent: evtBuf "Generate the appropriate mouse event for the given raw event buffer" "Note: This is still in an experimental phase and will need more work" | position buttons modifiers stamp numFiles dragType | stamp := evtBuf second. stamp = 0 ifTrue: [stamp := Time eventMillisecondClock]. dragType := evtBuf third. position := evtBuf fourth @ evtBuf fifth. buttons := 0. modifiers := evtBuf sixth. buttons := buttons bitOr: (modifiers bitShift: 3). numFiles := evtBuf seventh. dragType = 4 ifTrue: ["e.g., drop" owner borderWidth: 0. ^DropFilesEvent new setPosition: position contents: numFiles hand: self]. "the others are currently not handled by morphs themselves" dragType = 1 ifTrue: ["experimental drag enter" owner borderWidth: 4; borderColor: owner color asColor negated]. dragType = 2 ifTrue: ["experimental drag move" ]. dragType = 3 ifTrue: ["experimental drag leave" owner borderWidth: 0]. ^nil! ! !HandMorph methodsFor: 'private events' stamp: 'tpr 1/11/2016 15:33' prior: 19321614! generateKeyboardEvent: evtBuf "Generate the appropriate mouse event for the given raw event buffer" | buttons modifiers type pressType stamp keyValue | stamp := evtBuf second. stamp = 0 ifTrue: [stamp := Time eventMillisecondClock]. pressType := evtBuf fourth. pressType = EventKeyDown ifTrue: [type := #keyDown]. pressType = EventKeyUp ifTrue: [type := #keyUp]. pressType = EventKeyChar ifTrue: [type := #keystroke]. modifiers := evtBuf fifth. buttons := (modifiers bitShift: 3) bitOr: (lastMouseEvent buttons bitAnd: 7). type = #keystroke ifTrue: [keyValue := (self keyboardInterpreter nextCharFrom: Sensor firstEvt: evtBuf) asInteger] ifFalse: [keyValue := evtBuf third]. ^ KeyboardEvent new setType: type buttons: buttons position: self position keyValue: keyValue hand: self stamp: stamp. ! ! !HandMorph methodsFor: 'private events' stamp: 'tpr 1/11/2016 15:34' prior: 19324002! generateMouseEvent: evtBuf "Generate the appropriate mouse event for the given raw event buffer" | position buttons modifiers type trail stamp oldButtons evtChanged | evtBuf first = lastEventBuffer first ifTrue: ["Workaround for Mac VM bug, *always* generating 3 events on clicks" evtChanged := false. 3 to: evtBuf size do: [:i | (lastEventBuffer at: i) = (evtBuf at: i) ifFalse: [evtChanged := true]]. evtChanged ifFalse: [^nil]]. stamp := evtBuf second. stamp = 0 ifTrue: [stamp := Time eventMillisecondClock]. position := evtBuf third @ evtBuf fourth. buttons := evtBuf fifth. modifiers := evtBuf sixth. type := buttons = 0 ifTrue:[ lastEventBuffer fifth = 0 ifTrue: [#mouseMove] "this time no button and previously no button .. just mouse move" ifFalse: [#mouseUp] "this time no button but previously some button ... therefore button was released" ] ifFalse:[ buttons = lastEventBuffer fifth ifTrue: [#mouseMove] "button states are the same .. now and past .. therfore a mouse movement" ifFalse: [ "button states are different .. button was pressed or released" buttons > lastEventBuffer fifth ifTrue: [#mouseDown] ifFalse:[#mouseUp]. ]. ]. buttons := buttons bitOr: (modifiers bitShift: 3). oldButtons := lastEventBuffer fifth bitOr: (lastEventBuffer sixth bitShift: 3). lastEventBuffer := evtBuf. type == #mouseMove ifTrue: [trail := self mouseTrailFrom: evtBuf. ^MouseMoveEvent new setType: type startPoint: (self position) endPoint: trail last trail: trail buttons: buttons hand: self stamp: stamp]. ^MouseButtonEvent new setType: type position: position which: (oldButtons bitXor: buttons) buttons: buttons hand: self stamp: stamp! ! !HandMorph methodsFor: 'private events' stamp: 'tpr 1/11/2016 15:30' prior: 19325889! generateWindowEvent: evtBuf "Generate the appropriate window event for the given raw event buffer" | evt | evt := WindowEvent new. evt setTimeStamp: evtBuf second. evt timeStamp = 0 ifTrue: [evt setTimeStamp: Time eventMillisecondClock]. evt action: evtBuf third. evt rectangle: (Rectangle origin: evtBuf fourth @ evtBuf fifth corner: evtBuf sixth @ evtBuf seventh ). ^evt! ! !NewBalloonMorph class methodsFor: 'preferences' stamp: 'mt 1/13/2016 08:26'! defaultBalloonTextColor ^ DefaultBalloonTextColor ifNil: [Color black]! ! !NewBalloonMorph class methodsFor: 'preferences' stamp: 'mt 1/13/2016 08:12'! defaultBalloonTextColor: color DefaultBalloonTextColor := color.! ! !NewBalloonMorph methodsFor: 'initialization' stamp: 'mt 1/13/2016 08:25' prior: 56730592! defaultBorderWidth ^ MenuMorph menuBorderWidth! ! !NewBalloonMorph methodsFor: 'initialization' stamp: 'mt 1/13/2016 08:10' prior: 56730818! initialize super initialize. self borderWidth: self defaultBorderWidth; borderColor: self defaultBorderColor; color: (Preferences menuAppearance3d ifTrue: [self defaultColor alpha: 1.0] ifFalse: [self defaultColor]); hasDropShadow: Preferences menuAppearance3d; shadowOffset: 1@1; shadowColor: (self color muchDarker muchDarker alpha: 0.333); orientation: #bottomLeft. MenuMorph roundedMenuCorners ifTrue: [self cornerStyle: #rounded]. textMorph := TextMorph new wrapFlag: false; lock; yourself. self addMorph: textMorph.! ! !NewBalloonMorph methodsFor: 'initialization' stamp: 'mt 1/13/2016 08:37' prior: 56732359! setText: stringOrText | text | text := stringOrText asText. text unembellished ifTrue: [ text addAttribute: (TextColor color: self class defaultBalloonTextColor)]. text addAttribute: (TextFontReference toFont: (self balloonOwner ifNil: [BalloonMorph]) balloonFont). self textMorph wrapFlag: false. self textMorph newContents: text. self textMorph fullBounds. (self maximumWidth > 0 and: [self textMorph width > self maximumWidth]) ifTrue: [ self textMorph wrapFlag: true; width: self maximumWidth]. self updateLayout.! ! !BalloonMorph class methodsFor: 'preferences' stamp: 'mt 1/13/2016 08:17' prior: 21517031! balloonColor ^ BalloonColor ifNil: [(TranslucentColor r: 0.92 g: 0.92 b: 0.706 alpha: 0.749)]! ! !BalloonMorph class methodsFor: 'preferences' stamp: 'mt 1/13/2016 08:17'! balloonColor: aColor BalloonColor := aColor.! ! !FormCanvas methodsFor: 'drawing-rectangles' stamp: 'mt 1/13/2016 09:02' prior: 52004675! fillRoundRect: aRectangle radius: radius fillStyle: fillStyle fillStyle isTransparent ifTrue:[^self]. radius asPoint <= (0@0) ifTrue:[^self fillRectangle: aRectangle fillStyle: fillStyle]. fillStyle isSolidFill ifFalse:[^self balloonFillRoundRect: aRectangle radius: radius fillStyle: fillStyle]. self setFillColor: (shadowColor ifNil:[fillStyle asColor]). ^port fillRoundRect: (aRectangle translateBy: origin) truncated radius: radius. ! ! !FormCanvas methodsFor: 'drawing-rectangles' stamp: 'mt 1/13/2016 09:02' prior: 52008376! frameAndFillRoundRect: aRectangle radius: cornerRadius fillStyle: fillStyle borderWidth: bw borderColor: bc "Draw a rounded rectangle" self shadowColor ifNotNil:[ ^self fillRoundRect: aRectangle radius: cornerRadius fillStyle: shadowColor. ]. "see if the round rect is degenerate" cornerRadius asPoint <= (0@0) ifTrue:[^self frameAndFillRectangle: aRectangle fillColor: fillStyle asColor borderWidth: bw borderColor: bc]. "Okay it's a rounded rectangle" fillStyle isTransparent ifFalse:["fill interior" | innerRect radius | innerRect := aRectangle. radius := cornerRadius. bw isZero ifFalse:[ innerRect := innerRect insetBy: bw. radius := radius - bw. ]. self fillRoundRect: innerRect radius: radius fillStyle: fillStyle. ]. self frameRoundRect: aRectangle radius: cornerRadius width: bw color: bc ! ! !MorphicEvent methodsFor: 'accessing' stamp: 'tpr 1/11/2016 15:30' prior: 56542352! timeStamp "Return the millisecond clock value at which the event was generated" ^timeStamp ifNil:[timeStamp := Time eventMillisecondClock]! ! !MouseEvent methodsFor: 'converting' stamp: 'tpr 1/11/2016 14:22' prior: 26101270! asMouseMove "Convert the receiver into a mouse move" ^MouseMoveEvent new setType: #mouseMove startPoint: position endPoint: position trail: {position. position} buttons: buttons hand: source stamp: Time eventMillisecondClock! ! !ScrollBar methodsFor: 'initialize' stamp: 'mt 1/13/2016 09:10' prior: 22968294! initializeSlider self initializeMenuButton; initializeUpButton; initializeDownButton; initializePagingArea. super initializeSlider. self expandSlider. self class roundedScrollBarLook ifTrue: [ slider cornerStyle: #rounded. sliderShadow cornerStyle: #rounded. Preferences menuAppearance3d ifTrue: [ slider borderStyle: (BorderStyle complexRaised width: 1)]]. self sliderColor: self sliderColor.! ! "Morphic"! !Debugger methodsFor: 'context stack menu' stamp: 'eem 1/7/2016 11:19' prior: 54829281! browseVersions "Create and schedule a message set browser on all versions of the currently selected message selector." (ToolSet browseVersionsOf: self selectedClassOrMetaClass selector: self selectedMessageName) ifNil: [self changed: #flash]! ! !Browser methodsFor: 'drag and drop' stamp: 'ul 1/10/2016 22:35' prior: 62742473! dropOnMessageCategories: method at: index | sourceClass destinationClass category copy | copy := Sensor shiftPressed. (method isKindOf: CompiledMethod) ifFalse:[^self inform: 'Can only drop methods']. sourceClass := method methodClass. destinationClass := self selectedClassOrMetaClass. sourceClass == destinationClass ifTrue:[ category := self messageCategoryList at: index. category = ClassOrganizer allCategory ifTrue: [^false]. destinationClass organization classify: method selector under: category suppressIfDefault: false logged: true. ^true ]. (copy or: [ (destinationClass inheritsFrom: sourceClass) or: [ (sourceClass inheritsFrom: destinationClass) or: [ sourceClass theNonMetaClass == destinationClass theNonMetaClass ] ] ]) ifFalse: [ (self confirm: ( 'Classes "{1}" and "{2}" are unrelated.{3}Are you sure you want to move this method?' format: { sourceClass. destinationClass. Character cr })) ifFalse: [ ^false ] ]. destinationClass compile: method getSource classified: (self messageCategoryList at: index) withStamp: method timeStamp notifying: nil. copy ifFalse: [ sourceClass removeSelector: method selector ]. ^true! ! !StandardToolSet class methodsFor: 'browsing' stamp: 'eem 1/7/2016 11:28' prior: 31562830! browseVersionsOf: class selector: selector "Open and answer a browser on versions of the method. If the method doesn't exist try and find version from the current change set. If not found there, answer nil." | methodOrNil methodCategory | methodOrNil := class compiledMethodAt: selector ifAbsent: []. methodOrNil ifNil: [(ChangeSet current methodInfoFromRemoval: {class name. selector}) ifNil: [^nil] ifNotNil: [:pair| methodOrNil := CompiledMethod toReturnSelfTrailerBytes: (CompiledMethodTrailer new sourcePointer: pair first). methodCategory := pair last]]. ^VersionsBrowser browseVersionsOf: methodOrNil class: class theNonMetaClass meta: class isMeta category: (methodCategory ifNil: [class organization categoryOfElement: selector]) selector: selector! ! !FileContentsBrowser methodsFor: 'other' stamp: 'eem 1/7/2016 11:19' prior: 26442824! browseVersions "Create and schedule a message set browser on all versions of the currently selected message selector." (ToolSet browseVersionsOf: self selectedClassOrMetaClass selector: self selectedMessageName) ifNil: [self changed: #flash]! ! !VersionsBrowser methodsFor: 'contents' stamp: 'ul 1/9/2016 22:03'! aboutToStyle: aStyler "Style in source view, or when there's nothing to diff with." (self isModeStyleable or: [ listIndex = list size ]) ifFalse: [ ^false ]. aStyler classOrMetaClass: classOfMethod; parseAMethod: true. ^true ! ! !ClassCommentVersionsBrowser methodsFor: 'contents' stamp: 'ul 1/9/2016 21:51'! aboutToStyle: aStyler ^false! ! !StringHolder methodsFor: '*Tools' stamp: 'eem 1/7/2016 11:16' prior: 21067447! browseVersions "Create and schedule a Versions Browser, showing all versions of the currently selected message. Answer the browser or nil." | selector | self classCommentIndicated ifTrue: [ClassCommentVersionsBrowser browseCommentOf: self selectedClass. ^nil]. ^(selector := self selectedMessageName) ifNil: [self inform: 'Sorry, only actual methods have retrievable versions.'. nil] ifNotNil: [ToolSet browseVersionsOf: self selectedClassOrMetaClass selector: selector]! ! "Tools"! !PluggableTextMorphPlus methodsFor: 'testing' stamp: 'kfr 1/6/2016 23:35' prior: 52104290! okToStyle ^ styler ifNil:[false] ifNotNil: [:s | s class syntaxHighlightingAsYouType ifTrue:[model aboutToStyle: s] ifFalse:[false]]! ! "ToolBuilder-Morphic"! !BrowserTest methodsFor: 'as yet unclassified' stamp: 'ul 1/10/2016 22:47' prior: 57761811! testFlattenHierarchyTreeOnIndent | flatten | flatten := [:coll | (browser flattenHierarchyTree: (browser createHierarchyTreeOf: coll) on: OrderedCollection new indent: '') asArray ]. "Empty collection." self assert: (flatten value: #()) isEmpty. "Single class." self assert: #('Browser') equals: (flatten value: {Browser}). "Single class + subclass." self assert: #('Browser' ' HierarchyBrowser') equals: (flatten value: {Browser. HierarchyBrowser}). "Single class + 2 subclasses" self assert: #('Browser' ' HierarchyBrowser' ' FileContentsBrowser') equals: (flatten value: { Browser. HierarchyBrowser. FileContentsBrowser. }). "Superclass, class, subclass" self assert: #('CodeHolder' ' Browser' ' HierarchyBrowser') equals: (flatten value: { CodeHolder. Browser. HierarchyBrowser. }). "Two 'unrelated' classes" self assert: #('Browser' 'SmallInteger') equals: (flatten value: { Browser. SmallInteger }). "Two 'unrelated' classes and a common ancestor" self assert: #('Browser' 'SmallInteger' 'ProtoObject') equals: (flatten value: { Browser. SmallInteger. ProtoObject }).! ! !BrowserTest methodsFor: 'as yet unclassified' stamp: 'ul 1/10/2016 22:49' prior: 57763128! testFlattenHierarchyTreeOnIndentBy | flatten | flatten := [:coll | (browser flattenHierarchyTree: (browser createHierarchyTreeOf: coll) on: OrderedCollection new indent: '' by: 'x') asArray ]. "Empty collection." self assert: (flatten value: #()) isEmpty. "Single class." self assert: #('Browser') equals: (flatten value: {Browser}). "Single class + subclass." self assert: #('Browser' 'xHierarchyBrowser') equals: (flatten value: {Browser. HierarchyBrowser}). "Single class + 2 subclasses" self assert: #('Browser' 'xHierarchyBrowser' 'xFileContentsBrowser') equals: (flatten value: { Browser. HierarchyBrowser. FileContentsBrowser. }). "Superclass, class, subclass" self assert: #('CodeHolder' 'xBrowser' 'xxHierarchyBrowser') equals: (flatten value: { CodeHolder. Browser. HierarchyBrowser. }). "Two 'unrelated' classes" self assert: #('Browser' 'SmallInteger') equals: (flatten value: { Browser. SmallInteger }). "Two 'unrelated' classes and a common ancestor" self assert: #('Browser' 'SmallInteger' 'ProtoObject') equals: (flatten value: { Browser. SmallInteger. ProtoObject }).! ! "ToolsTests"! !ReleaseBuilder class methodsFor: 'preferences' stamp: 'mt 1/13/2016 08:18' prior: 33560137! setPreferences "Preferences class defaultValueTableForCurrentRelease" self setProjectBackground: Color darkGray. "General User interaction" Preferences enable: #generalizedYellowButtonMenu ; disable: #mouseOverForKeyboardFocus ; enable: #swapMouseButtons. Morph indicateKeyboardFocus: true. SearchBar useScratchPad: false. "Text input." TextEditor autoEnclose: true ; autoIndent: true ; destructiveBackWord: false ; blinkingCursor: true ; dumbbellCursor: false. Preferences insertionPointColor: Color red. PluggableTextMorph simpleFrameAdornments: false. "Windows" Preferences installUniformWindowColors. SystemWindow reuseWindows: false. Model windowActiveOnFirstClick: false. "Not good for 800x600" Preferences disable: #showSplitterHandles; enable: #fastDragWindowForMorphic. CornerGripMorph drawCornerResizeHandles: false. ProportionalSplitterMorph smartHorizontalSplitters: false ; smartVerticalSplitters: false. "Scroll bars." Preferences enable: #scrollBarsNarrow; enable: #scrollBarsOnRight; disable: #alwaysHideHScrollbar; disable: #alwaysShowHScrollbar; disable: #alwaysShowVScrollbar. ScrollBar scrollBarsWithoutArrowButtons: true; scrollBarsWithoutMenuButton: true. ScrollPane useRetractableScrollBars: false. "Rounded corners." Morph preferredCornerRadius: 6. Preferences disable: #roundedWindowCorners. PluggableButtonMorph roundedButtonCorners: false. FillInTheBlankMorph roundedDialogCorners: false. MenuMorph roundedMenuCorners: false. ScrollBar roundedScrollBarLook: false. "Gradients." Preferences disable: #gradientScrollBars. SystemWindow gradientWindow: false. MenuMorph gradientMenu: false. PluggableButtonMorph gradientButton: false. "Shadows" Preferences enable: #menuAppearance3d. MenuMorph menuBorderWidth: 1; menuBorderColor: Color lightGray; menuLineColor: Color lightGray. Morph useSoftDropShadow: true.. "Lists and Trees" PluggableListMorph filterableLists: true; clearFilterAutomatically: false; highlightHoveredRow: true; menuRequestUpdatesSelection: true. PluggableTreeMorph filterByLabelsOnly: false; maximumSearchDepth: 1. LazyListMorph listSelectionTextColor: Color black; listSelectionColor: (Color r: 0.72 g: 0.72 b: 0.9). "Standard Tools" BalloonMorph balloonColor: (TranslucentColor r: 0.92 g: 0.92 b: 0.706 alpha: 0.75). Workspace shouldStyle: false. Browser listClassesHierarchically: true; showClassIcons: true; showMessageIcons: true; sortMessageCategoriesAlphabetically: true. Preferences enable: #annotationPanes; enable: #optionalButtons; enable: #diffsWithPrettyPrint; enable: #traceMessages; enable: #alternativeBrowseIt; enable: #menuWithIcons; enable: #visualExplorer. SystemNavigation thoroughSenders: true. "Halo" Preferences enable: #showBoundsInHalo ; disable: #alternateHandlesLook. "System" NetNameResolver enableIPv6: false. Scanner allowUnderscoreAsAssignment: true; prefAllowUnderscoreSelectors: true. "that's all, folks"! ! "ReleaseBuilder"! ----QUIT----{16 January 2016 . 9:48:44 am} trunk50.image priorSource: 1137465! ----STARTUP----{16 January 2016 . 9:49 am} as /Users/eliot/oscogvm/image/trunk50.image! [MCMcmUpdater defaultUpdateURL: 'http://source.squeak.org/trunk'; updateFromServer] valueSupplyingAnswer: true. Smalltalk snapshot: true andQuit: true ! ----End fileIn of a ReadStream----! ----QUIT----{16 January 2016 . 9:49:03 am} trunk50.image priorSource: 1191906! ----STARTUP----{15 February 2016 . 10:58:58 am} as /Users/eliot/oscogvm/image/trunk50.image! [MCMcmUpdater defaultUpdateURL: 'http://source.squeak.org/trunk'; updateFromServer] valueSupplyingAnswer: true. Smalltalk snapshot: true andQuit: true ! ----End fileIn of a ReadStream----! !EventSensor methodsFor: '*45Deprecated' stamp: 'fbs 7/8/2013 22:53'! currentCursor "The current cursor is maintained in class Cursor." self deprecated: 'Use Cursor >> #currentCursor'. ^ Cursor currentCursor! ! !EventSensor methodsFor: '*45Deprecated' stamp: 'fbs 7/8/2013 22:53'! currentCursor: newCursor "The current cursor is maintained in class Cursor." self deprecated: 'Use Cursor >> #currentCursor:'. Cursor currentCursor: newCursor.! ! InputSensor removeSelector: #currentCursor:! InputSensor removeSelector: #currentCursor! "45Deprecated"! !EventSensor methodsFor: '*Graphics-KernelExtensions' stamp: 'BG 3/16/2005 08:23'! testJoystick: index "Sensor testJoystick: 3" | f pt buttons status | f := Form extent: 110@50. [Sensor anyButtonPressed] whileFalse: [ pt := Sensor joystickXY: index. buttons := Sensor joystickButtons: index. status := 'xy: ', pt printString, ' buttons: ', buttons printStringHex. f fillWhite. status displayOn: f at: 10@10. f displayOn: Display at: 10@10. ]. ! ! InputSensor removeSelector: #testJoystick:! "Graphics"! !Object methodsFor: 'copying' stamp: 'eem 1/18/2016 19:21' prior: 66605115! shallowCopy "Answer a copy of the receiver which shares the receiver's instance variables." | class newObject index | ec == #'insufficient object memory' ifFalse: [^self primitiveFailed]. class := self class. class isVariable ifTrue: [index := self basicSize. newObject := class basicNew: index. [index > 0] whileTrue: [newObject basicAt: index put: (self basicAt: index). index := index - 1]] ifFalse: [newObject := class basicNew]. index := class instSize. [index > 0] whileTrue: [newObject instVarAt: index put: (self instVarAt: index). index := index - 1]. ^newObject! ! !EventSensor class methodsFor: 'preference change notification' stamp: 'dew 12/14/2004 23:54'! duplicateAllControlAndAltKeysChanged "The Preference for duplicateAllControlAndAltKeys has changed; reset the other two." "At some point the various exclusive CtrlAlt-key prefs should become a radio button set, then these methods wouldn't be needed." (Preferences valueOfFlag: #swapControlAndAltKeys ifAbsent: [false]) ifTrue: [ self inform: 'Resetting swapControlAndAltKeys preference'. (Preferences preferenceAt: #swapControlAndAltKeys) rawValue: false. ]. (Preferences valueOfFlag: #duplicateControlAndAltKeys ifAbsent: [false]) ifTrue: [ self inform: 'Resetting duplicateControlAndAltKeys preference'. (Preferences preferenceAt: #duplicateControlAndAltKeys) rawValue: false. ]. self installKeyDecodeTable. ! ! !EventSensor class methodsFor: 'preference change notification' stamp: 'dew 12/13/2004 18:58'! duplicateControlAndAltKeysChanged "The Preference for duplicateControlAndAltKeys has changed; reset the other two." (Preferences valueOfFlag: #swapControlAndAltKeys ifAbsent: [false]) ifTrue: [ self inform: 'Resetting swapControlAndAltKeys preference'. (Preferences preferenceAt: #swapControlAndAltKeys) rawValue: false. ]. (Preferences valueOfFlag: #duplicateAllControlAndAltKeys ifAbsent: [false]) ifTrue: [ self inform: 'Resetting duplicateAllControlAndAltKeys preference'. (Preferences preferenceAt: #duplicateAllControlAndAltKeys) rawValue: false. ]. self installKeyDecodeTable. ! ! !EventSensor class methodsFor: 'class initialization' stamp: 'dtl 1/30/2016 12:55'! initialize self flag: #REMOVE. "temporary initialization method to support InputSensor removal" "Update the preferences" { #swapMouseButtons . #swapControlAndAltKeys . #duplicateControlAndAltKeys . #duplicateAllControlAndAltKeys } do: [ :key | | pref changeSelector | pref := Preferences preferenceAt: key. changeSelector := (key , #Changed) asSymbol. pref ifNotNil: [ pref changeInformee: EventSensor changeSelector: changeSelector ] ]. ! ! !EventSensor class methodsFor: 'preference change notification' stamp: 'dew 12/13/2004 18:58'! swapControlAndAltKeysChanged "The Preference for swapControlAndAltKeys has changed; reset the other two." (Preferences valueOfFlag: #duplicateControlAndAltKeys ifAbsent: [false]) ifTrue: [ self inform: 'Resetting duplicateControlAndAltKeys preference'. (Preferences preferenceAt: #duplicateControlAndAltKeys) rawValue: false. ]. (Preferences valueOfFlag: #duplicateAllControlAndAltKeys ifAbsent: [false]) ifTrue: [ self inform: 'Resetting duplicateAllControlAndAltKeys preference'. (Preferences preferenceAt: #duplicateAllControlAndAltKeys) rawValue: false. ]. self installKeyDecodeTable. ! ! !EventSensor methodsFor: 'mouse' stamp: 'nk 3/17/2004 07:24'! anyButtonPressed "Answer whether at least one mouse button is currently being pressed." ^ self primMouseButtons anyMask: 7 ! ! !EventSensor methodsFor: 'modifier keys' stamp: 'di 9/28/1999 08:29'! anyModifierKeyPressed "ignore, however, the shift keys 'cause that's not REALLY a command key" ^ self primMouseButtons anyMask: 16r70 "cmd | opt | ctrl"! ! !EventSensor methodsFor: 'mouse' stamp: 'nk 3/17/2004 07:24'! blueButtonPressed "Answer whether only the blue mouse button is being pressed. This is the third mouse button or cmd+click on the Mac." ^ (self primMouseButtons bitAnd: 7) = 1 ! ! !EventSensor methodsFor: 'keyboard'! characterForKeycode: keycode "Map the given keycode to a Smalltalk character object. Encoding: A keycode is 12 bits: <4 modifer bits><8 bit ISO character> Modifier bits are: