[squeak-dev] The Trunk: System-tfel.880.mczcommits at source.squeak.org commits at source.squeak.orgWed Aug 31 09:21:25 UTC 2016
Tim Felgentreff uploaded a new version of System to project The Trunk: http://source.squeak.org/trunk/System-tfel.880.mcz ==================== Summary ==================== Name: System-tfel.880 Author: tfel Time: 10 August 2016, 3:25:06.212665 pm UUID: 8363ffbe-86d8-a54f-811e-07a91aeb6a61 Ancestors: System-tfel.879 Import Etoys and SISS independent bits for storing and loading images also from sexps from the Squeakland release. Mostly this just refactors the Project loading code into multiple different methods, but it also puts the junctions in there to save and load SISS SExpressions rather than image segments, if SISS and Etoys are loaded =============== Diff against System-cmm.876 =============== Item was changed: ----- Method: CodeLoader>>installProject (in category 'installing') ----- installProject "Assume that we're loading a single file and it's a project" | aStream | + aStream _ sourceFiles first contentStream. - aStream := sourceFiles first contentStream. aStream ifNil:[^self error:'Project was not loaded']. + ProjectLoading openOn: aStream! - ProjectLoading - openName: nil "<--do we want to cache this locally? Need a name if so" - stream: aStream - fromDirectory: nil - withProjectView: nil. - ! Item was changed: ----- Method: ExternalDropHandler class>>defaultProjectHandler (in category 'private') ----- defaultProjectHandler + ^ ExternalDropHandler - ^ExternalDropHandler type: nil extension: 'pr' + action: [:stream | ProjectLoading openOn: stream]! - action: [:stream | - ProjectLoading - openName: nil - stream: stream - fromDirectory: nil - withProjectView: nil] - ! Item was changed: ----- Method: ExternalSettings class>>assuredPreferenceDirectory (in category 'accessing') ----- assuredPreferenceDirectory "Answer the preference directory, creating it if necessary" + | prefDir topDir | - | prefDir | prefDir := self preferenceDirectory. prefDir ifNil: + [topDir := Preferences startInUntrustedDirectory + ifTrue: [FileDirectory on: SecurityManager default secureUserDirectory] + ifFalse: [FileDirectory default]. + prefDir := topDir directoryNamed: self preferenceDirectoryName. - [prefDir := FileDirectory default directoryNamed: self preferenceDirectoryName. prefDir assureExistence]. ^ prefDir! Item was added: + ----- Method: GetTextTranslator>>moFiles (in category 'private') ----- + moFiles + + ^ moFiles! Item was changed: ----- Method: ImageSegment>>declareAndPossiblyRename: (in category 'fileIn/Out') ----- declareAndPossiblyRename: classThatIsARoot | existing catInstaller | "The class just arrived in this segment. How fit it into the Smalltalk dictionary? If it had an association, that was installed with associationDeclareAt:." + catInstaller _ [ - catInstaller := [ classThatIsARoot superclass name == #Player ifTrue: [classThatIsARoot category: Object categoryForUniclasses] ifFalse: [(classThatIsARoot superclass name beginsWith: 'WonderLandActor') ifTrue: [classThatIsARoot category: 'Balloon3D-UserObjects'] + ifFalse: [classThatIsARoot category: Object categoryForUniclasses]]. - ifFalse: [classThatIsARoot category: 'Morphic-Imported']]. ]. classThatIsARoot superclass addSubclass: classThatIsARoot. (Smalltalk includesKey: classThatIsARoot name) ifFalse: [ "Class entry in Smalltalk not referred to in Segment, install anyway." catInstaller value. ^ Smalltalk at: classThatIsARoot name put: classThatIsARoot]. + existing _ Smalltalk at: classThatIsARoot name. - existing := Smalltalk at: classThatIsARoot name. existing xxxClass == ImageSegmentRootStub ifTrue: [ "We are that segment!! Must ask it carefully!!" catInstaller value. ^ Smalltalk at: classThatIsARoot name put: classThatIsARoot]. existing == false | (existing == nil) ifTrue: [ "association is in outPointers, just installed" catInstaller value. ^ Smalltalk at: classThatIsARoot name put: classThatIsARoot]. "Conflict with existing global or copy of the class" (existing isKindOf: Class) ifTrue: [ classThatIsARoot isSystemDefined not ifTrue: [ "UniClass. give it a new name" classThatIsARoot setName: classThatIsARoot baseUniclass chooseUniqueClassName. catInstaller value. "must be after new name" ^ Smalltalk at: classThatIsARoot name put: classThatIsARoot]. "Take the incoming one" self inform: 'Using newly arrived version of ', classThatIsARoot name. classThatIsARoot superclass removeSubclass: classThatIsARoot. "just in case" (Smalltalk at: classThatIsARoot name) becomeForward: classThatIsARoot. catInstaller value. ^ classThatIsARoot superclass addSubclass: classThatIsARoot]. self error: 'Name already in use by a non-class: ', classThatIsARoot name. ! Item was changed: ----- Method: ImageSegment>>smartFillRoots: (in category 'read/write segment') ----- smartFillRoots: dummy + | refs known ours ww blockers | - | refs ours blockers known | "Put all traced objects into my arrayOfRoots. Remove some that want to be in outPointers. Return blockers, an IdentityDictionary of objects to replace in outPointers." + blockers _ dummy blockers. + known _ (refs _ dummy references) size. - blockers := dummy blockers. - known := (refs := dummy references) size. refs keys do: [:obj | "copy keys to be OK with removing items" + (obj isSymbol) ifTrue: [refs removeKey: obj. known _ known-1]. - (obj isSymbol) ifTrue: [refs removeKey: obj. - known := known-1]. (obj class == PasteUpMorph) ifTrue: [ obj isWorldMorph & (obj owner == nil) ifTrue: [ + (dummy project ~~ nil and: [obj == dummy project world]) ifFalse: [ + refs removeKey: obj. known _ known-1. - obj == dummy project world ifFalse: [ - refs removeKey: obj. known := known-1. blockers at: obj put: + (StringMorph contents: 'The worldMorph of a different world')]]]. - (StringMorph - contents: 'The worldMorph of a different world')]]]. "Make a ProjectViewMorph here" "obj class == Project ifTrue: [Transcript show: obj; cr]." (blockers includesKey: obj) ifTrue: [ + refs removeKey: obj ifAbsent: [known _ known+1]. known _ known-1]. - refs removeKey: obj ifAbsent: [known := - known+1]. known := known-1]. ]. + ours _ dummy project ifNotNil: [dummy project world] ifNil: [ActiveWorld]. + refs keysDo: [:obj | - ours := dummy project world. - refs keysDo: [:obj | | ww | obj isMorph ifTrue: [ + ww _ obj world. - ww := obj world. (ww == ours) | (ww == nil) ifFalse: [ + refs removeKey: obj. known _ known-1. + blockers at: obj put: (StringMorph contents: + obj printString, ' from another world')]]]. - refs removeKey: obj. known := known-1. - blockers at: obj put: - (StringMorph contents: - obj - printString, ' from another world')]]]. "keep original roots on the front of the list" (dummy rootObject) do: [:rr | refs removeKey: rr ifAbsent: []]. + self classOrganizersBeRoots: dummy. + ^ dummy rootObject, refs fasterKeys asArray.! - ^ dummy rootObject, refs keys asArray. - - ! Item was changed: ----- Method: Locale class>>localeChangedGently (in category 'notification') ----- localeChangedGently + SystemNavigation default allBehaviorsDo: [:b | b == self ifFalse: [b localeChangedGently]].! - self class environment allBehaviorsDo: [:b | b localeChangedGently].! Item was changed: ----- Method: MOFile>>searchByDictionary: (in category 'public') ----- searchByDictionary: aString | index | + index := translations at: aString ifAbsentPut: [nil]. + index ifNil: [^ nil]. + ^self translatedString: index! - index := translations at: aString ifAbsent: [^nil]. - ^self translatedString: index - - ! Item was added: + ----- Method: MOFile>>translations (in category 'private') ----- + translations + + ^ translations! Item was changed: ----- Method: MczInstaller class>>serviceLoadVersion (in category 'services') ----- serviceLoadVersion ^ SimpleServiceEntry provider: self + label: 'load' translatedNoop - label: 'load' selector: #loadVersionFile: + description: 'load a package version' translatedNoop! - description: 'load a package version'! Item was changed: ----- Method: NaturalLanguageTranslator class>>translateWithoutLoading:toLocaleID:inDomain: (in category 'translation') ----- translateWithoutLoading: aString toLocaleID: localeID inDomain: aDomainName "try to translate with small footprint: if GetTextTranslator hasn't loaded MO, try to use InternalTranslator. if InternalTranslator isn't available, then actually load MO and use it" | translator | translator := self availableForLocaleID: localeID. + translator class = NaturalLanguageTranslator ifTrue: [^ aString]. (translator isDomainLoaded: aDomainName) ifFalse: [ (InternalTranslator availableLanguageLocaleIDs includes: localeID) ifTrue: [translator := InternalTranslator localeID: localeID]. ]. ^translator translate: aString inDomain: aDomainName! Item was added: + ----- Method: Object>>translatedNoop (in category '*System-Localization-locales') ----- + translatedNoop + "This is correspondence gettext_noop() in gettext." + ^ self + ! Item was changed: ----- Method: Preference>>helpString (in category 'menu') ----- helpString "Answer the help string provided for the receiver" + ^ helpString ifNil: ['no help available' translatedNoop]! - ^ helpString ifNil: ['no help available']! Item was removed: - ----- Method: Preferences class>>alwaysShowConnectionVocabulary (in category 'standard queries') ----- - alwaysShowConnectionVocabulary - ^ self - valueOfFlag: #alwaysShowConnectionVocabulary - ifAbsent: [false]! Item was changed: + ----- Method: Preferences class>>chooseEToysTitleFont (in category 'fonts') ----- - ----- Method: Preferences class>>chooseEToysTitleFont (in category 'prefs - fonts') ----- chooseEToysTitleFont + "Present a menu with the possible fonts for etoy titles" + - "present a menu with the possible fonts for the eToys" self + chooseFontWithPrompt: 'Choose the etoy title font' translated - chooseFontWithPrompt: 'eToys Title font...' translated andSendTo: self withSelector: #setEToysTitleFontTo: + highlight: self standardEToysTitleFont! - highlightSelector: #standardEToysTitleFont! Item was removed: - ----- Method: Preferences class>>haloTheme (in category 'prefs - halos') ----- - haloTheme - ^ self - valueOfFlag: #haloTheme - ifAbsent: [ #iconicHaloSpecifications ]! Item was changed: + ----- Method: Preferences class>>iconicHaloSpecifications (in category 'halos') ----- - ----- Method: Preferences class>>iconicHaloSpecifications (in category 'prefs - halos') ----- 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 (white) 'Halo-Menu') - (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') ) ! Item was changed: + ----- Method: Preferences class>>menuColorString (in category 'misc') ----- - ----- Method: Preferences class>>menuColorString (in category 'support - misc') ----- menuColorString ^ ((self valueOfFlag: #menuColorFromWorld) + ifTrue: ['stop menu-color-from-world' translated] + ifFalse: ['start menu-color-from-world' translated]) ! - ifTrue: ['stop menu-color-from-world'] - ifFalse: ['start menu-color-from-world']) translated! Item was changed: + ----- Method: Preferences class>>restorePersonalPreferences (in category 'personalization') ----- - ----- Method: Preferences class>>restorePersonalPreferences (in category 'initialization - save/load') ----- 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' translated]. - 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]) ifNotNilDo: - [:assoc | (self preferenceAt: assoc key ifAbsent: [nil]) ifNotNil: [:pref | pref preferenceValue: assoc value preferenceValue]]! Item was changed: + ----- Method: Preferences class>>restorePreferencesFromDisk (in category 'personalization') ----- - ----- Method: Preferences class>>restorePreferencesFromDisk (in category 'initialization - save/load') ----- restorePreferencesFromDisk + | result | + result := (FileList2 modalFileSelectorForSuffixes: #('prefs')) . + result ifNil: [^ self]. + self restorePreferencesFromDisk: result fullName + - (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!!' ]. ! Item was removed: - ----- Method: Preferences class>>showAdvancedNavigatorButtons (in category 'standard queries') ----- - showAdvancedNavigatorButtons - ^ self - valueOfFlag: #showAdvancedNavigatorButtons - ifAbsent: [ true ]! Item was changed: + ----- Method: Preferences class>>storePreferencesToDisk (in category 'personalization') ----- - ----- Method: Preferences class>>storePreferencesToDisk (in category 'initialization - save/load') ----- storePreferencesToDisk + | newName | + newName := UIManager default request: 'Please confirm name for save...' initialAnswer: 'myPreferences'. + newName isEmpty + ifTrue: [^ self]. + Cursor wait + showWhile: [[self storePreferencesIn: newName , '.prefs'] + on: Error + do: [:ex | self inform: 'there was an error storing your preferences to disk. you probably already have stored your preferences' translated]]! - Cursor wait showWhile: [ - [ self storePreferencesIn: 'my.prefs' ] on: Error do: [ :ex | self inform: 'there was an error storing your preferences to disk' ]]! Item was removed: - ----- Method: Preferences class>>useSmartLabels (in category 'standard queries') ----- - useSmartLabels - ^ self - valueOfFlag: #useSmartLabels - ifAbsent: [false]! Item was changed: ----- Method: Project class>>mostRecent:onServer: (in category 'squeaklet on server') ----- mostRecent: projName onServer: aServerDirectory | stem list max goodName triple num stem1 stem2 rawList nothingFound unEscName | "Find the exact fileName of the most recent version of project with the stem name of projName. Names are of the form 'projName|mm.pr' where mm is a mime-encoded integer version number. File names may or may not be HTTP escaped, %20 on the server." self flag: #bob. "do we want to handle unversioned projects as well?" + "I think we do now - Yoshiki." + nothingFound _ {nil. -1}. - nothingFound := {nil. -1}. aServerDirectory ifNil: [^nothingFound]. "23 sept 2000 - some old projects have periods in name so be more careful" + unEscName _ projName unescapePercents. + triple _ Project parseProjectFileName: unEscName. + stem _ triple first. + rawList _ aServerDirectory fileNames. - unEscName := projName unescapePercents. - triple := Project parseProjectFileName: unEscName. - stem := triple first. - rawList := aServerDirectory fileNames. + rawList isString ifTrue: [self inform: 'server is unavailable' translated. ^nothingFound]. + list _ rawList collect: [:nnn | nnn unescapePercents]. + max _ -1. goodName _ nil. - rawList isString ifTrue: [self inform: 'server is unavailable'. ^nothingFound]. - list := rawList collect: [:nnn | nnn unescapePercents]. - max := -1. goodName := nil. list withIndexDo: [:aName :ind | + ((aName beginsWith: stem)) ifTrue: [ + ((aName endsWith: triple last) or: [triple last = '' and: [aName endsWith: '.pr']]) ifTrue: [ + num _ (Project parseProjectFileName: aName) second. + num > max ifTrue: [max _ num. goodName _ (rawList at: ind)]]]]. - (aName beginsWith: stem) ifTrue: [ - num := (Project parseProjectFileName: aName) second. - num > max ifTrue: [max := num. goodName := (rawList at: ind)]]]. max = -1 ifFalse: [^ Array with: goodName with: max]. "try with underbar for spaces on server" (stem includes: $ ) ifTrue: [ + stem1 _ stem copyReplaceAll: ' ' with: '_'. - stem1 := stem copyReplaceAll: ' ' with: '_'. list withIndexDo: [:aName :ind | (aName beginsWith: stem1) ifTrue: [ + num _ (Project parseProjectFileName: aName) second. + num > max ifTrue: [max _ num. goodName _ (rawList at: ind)]]]]. - num := (Project parseProjectFileName: aName) second. - num > max ifTrue: [max := num. goodName := (rawList at: ind)]]]]. max = -1 ifFalse: [^ Array with: goodName with: max]. "try without the marker | " + stem1 _ stem allButLast, '.pr'. + stem2 _ stem1 copyReplaceAll: ' ' with: '_'. "and with spaces replaced" - stem1 := stem allButLast, '.pr'. - stem2 := stem1 copyReplaceAll: ' ' with: '_'. "and with spaces replaced" list withIndexDo: [:aName :ind | (aName beginsWith: stem1) | (aName beginsWith: stem2) ifTrue: [ + (triple _ aName findTokens: '.') size >= 2 ifTrue: [ + max _ 0. goodName _ (rawList at: ind)]]]. "no other versions" - (triple := aName findTokens: '.') size >= 2 ifTrue: [ - max := 0. goodName := (rawList at: ind)]]]. "no other versions" max = -1 ifFalse: [^ Array with: goodName with: max]. ^nothingFound "no matches" ! Item was added: + ----- Method: Project class>>publishInSexp (in category 'preferences') ----- + publishInSexp + + Smalltalk at: #SISSDictionaryForScanning ifPresent: [:siss | ^ siss publishInSexp]. + ^ false + ! Item was changed: ----- Method: Project class>>squeakletDirectory (in category 'squeaklet on server') ----- squeakletDirectory | squeakletDirectoryName | + squeakletDirectoryName := (Smalltalk at: #SugarLauncher ifPresent: [:c | + c current parameterAt: 'SQUEAKLETS' ifAbsent: []]) ifNil: ['Squeaklets']. - squeakletDirectoryName := 'Squeaklets'. (FileDirectory default directoryExists: squeakletDirectoryName) ifFalse: [ FileDirectory default createDirectory: squeakletDirectoryName ]. ^FileDirectory default directoryNamed: squeakletDirectoryName! Item was changed: ----- Method: Project class>>sweep: (in category 'squeaklet on server') ----- sweep: aServerDirectory | repository list parts ind entry projectName versions | "On the server, move all but the three most recent versions of each Squeaklet to a folder called 'older'" "Project sweep: ((ServerDirectory serverNamed: 'DaniOnJumbo') clone directory: '/vol0/people/dani/Squeaklets/2.7')" "Ensure the 'older' directory" (aServerDirectory includesKey: 'older') ifFalse: [aServerDirectory createDirectory: 'older']. + repository _ aServerDirectory clone directory: aServerDirectory directory, '/older'. - repository := aServerDirectory clone directory: aServerDirectory directory, '/older'. "Collect each name, and decide on versions" + list _ aServerDirectory fileNames. + list isString ifTrue: [^ self inform: 'server is unavailable' translated]. + list _ list asSortedCollection asOrderedCollection. + parts _ list collect: [:en | Project parseProjectFileName: en]. + parts _ parts select: [:en | en third = 'pr']. + ind _ 1. + [entry _ list at: ind. + projectName _ entry first asLowercase. + versions _ OrderedCollection new. versions add: entry. + [(ind _ ind + 1) > list size - list := aServerDirectory fileNames. - list isString ifTrue: [^ self inform: 'server is unavailable']. - list := list asSortedCollection asOrderedCollection. - parts := list collect: [:en | Project parseProjectFileName: en]. - parts := parts select: [:en | en third = 'pr']. - ind := 1. - [entry := list at: ind. - projectName := entry first asLowercase. - versions := OrderedCollection new. versions add: entry. - [(ind := ind + 1) > list size ifFalse: [(parts at: ind) first asLowercase = projectName ifTrue: [versions add: (parts at: ind). true] ifFalse: [false]] ifTrue: [false]] whileTrue. aServerDirectory moveYoungest: 3 in: versions to: repository. ind > list size] whileFalse. ! Item was added: + ----- Method: Project>>acceptProjectDetails: (in category 'file in/out') ----- + acceptProjectDetails: details + "Store project details back into a property of the world, and if a name is provided, make sure the name is properly installed in the project." + + world setProperty: #ProjectDetails toValue: details. + details at: 'projectname' ifPresent: [ :newName | + self renameTo: newName]! Item was added: + ----- Method: Project>>compressFilesIn:to:in: (in category 'file in/out') ----- + compressFilesIn: tempDir to: localName in: localDirectory + "Compress all the files in tempDir making up a zip file in localDirectory named localName" + + | archive archiveName entry fileNames | + archive := ZipArchive new. + fileNames := tempDir fileNames. + (fileNames includes: 'manifest') + ifTrue: [fileNames := #('manifest'), (fileNames copyWithout: 'manifest')]. + fileNames do:[:fn| + archiveName := fn. + entry := archive addFile: (tempDir fullNameFor: fn) as: archiveName. + entry desiredCompressionMethod: ( + fn = 'manifest' + ifTrue: [ZipArchive compressionLevelNone] + ifFalse: [ZipArchive compressionDeflated]). + ]. + archive writeToFileNamed: (localDirectory fullNameFor: localName). + archive close. + tempDir fileNames do:[:fn| + tempDir deleteFileNamed: fn ifAbsent:[]]. + localDirectory deleteDirectory: tempDir localName.! Item was added: + ----- Method: Project>>createViewIfAppropriate (in category 'utilities') ----- + createViewIfAppropriate + "overridden in subclasses" + ^ self! Item was changed: ----- Method: Project>>depth (in category 'active process') ----- depth "Return the depth of this project from the top. topProject = 0, next = 1, etc." "Project current depth." + | depth project | + depth _ 0. + project _ self. - | depth topProject project | - depth := 0. - topProject := Project topProject. - project := self. + [project class == DiskProxy ifTrue: [^ depth]. + project isTopProject] + whileFalse: + [project _ project parent. + depth _ depth + 1]. - [project ~= topProject and:[project notNil]] - whileTrue: - [project := project parent. - depth := depth + 1]. ^ depth! Item was changed: ----- Method: Project>>doWeWantToRename (in category 'menu messages') ----- doWeWantToRename | want | self hasBadNameForStoring ifTrue: [^true]. + (self name beginsWith: 'Unnamed' translated) ifTrue: [^true]. + want _ world valueOfProperty: #SuperSwikiRename ifAbsent: [false]. - (self name beginsWith: 'Unnamed') ifTrue: [^true]. - want := world valueOfProperty: #SuperSwikiRename ifAbsent: [false]. world removeProperty: #SuperSwikiRename. ^want ! Item was changed: ----- Method: Project>>exportSegmentFileName:directory: (in category 'file in/out') ----- exportSegmentFileName: aFileName directory: aDirectory + ^ self exportSegmentFileName: aFileName directory: aDirectory withoutInteraction: false! - | exportChangeSet | - - "An experimental version to fileout a changeSet first so that a project can contain its own classes" - - "Store my project out on the disk as an *exported* ImageSegment. Put all outPointers in a form that can be resolved in the target image. Name it <project name>.extSeg. - Player classes are included automatically." - - exportChangeSet := nil. - (changeSet notNil and: [changeSet isEmpty not]) ifTrue: [ - (self confirm: - 'Would you like to include all the changes in the change set - as part of this publishing operation?' translated) ifTrue: [ - exportChangeSet := changeSet - ]. - ]. - ^ self - exportSegmentWithChangeSet: exportChangeSet - fileName: aFileName - directory: aDirectory - ! Item was added: + ----- Method: Project>>exportSegmentFileName:directory:withoutInteraction: (in category 'file in/out') ----- + exportSegmentFileName: aFileName directory: aDirectory withoutInteraction: noInteraction + + | exportChangeSet | + + "An experimental version to fileout a changeSet first so that a project can contain its own classes" + + "Store my project out on the disk as an *exported* ImageSegment. Put all outPointers in a form that can be resolved in the target image. Name it <project name>.extSeg. + Player classes are included automatically." + exportChangeSet := nil. + (changeSet notNil and: [changeSet isEmpty not]) ifTrue: [ + (noInteraction or: [self confirm: + 'Would you like to include all the changes in the change set + as part of this publishing operation?' translated]) ifTrue: [ + exportChangeSet := changeSet + ]. + ]. + + Project publishInSexp ifTrue: [ + ^ self exportSegmentInSexpWithChangeSet: exportChangeSet fileName: aFileName directory: aDirectory withoutInteraction: noInteraction + ]. + ^ self + exportSegmentWithChangeSet: exportChangeSet + fileName: aFileName + directory: aDirectory + withoutInteraction: noInteraction + ! Item was added: + ----- Method: Project>>exportSegmentInSexpWithChangeSet:fileName:directory:withoutInteraction: (in category 'file in/out') ----- + exportSegmentInSexpWithChangeSet: aChangeSetOrNil fileName: aFileName directory: aDirectory withoutInteraction: noInteraction + + self subclassResponsibility! Item was changed: ----- Method: Project>>htmlPagePrototype (in category 'file in/out') ----- htmlPagePrototype "Return the HTML page prototype" ^'<html> <head> <title>Squeak Project</title> <meta http-equiv="Content-Type" content="text/html; charset=utf-8"> </head> <body bgcolor="#FFFFFF"> <EMBED type="application/x-squeak-source" ALIGN="CENTER" WIDTH="$$WIDTH$$" HEIGHT="$$HEIGHT$$" src="$$PROJECT$$" + pluginspage="http://www.squeakland.org/download/"> - pluginspage="http://www.squeakland.org/plugin/detect/detectinstaller.html"> </EMBED> </body> </html> '! Item was changed: ----- Method: Project>>revert (in category 'file in/out') ----- revert | | "Exit this project and do not save it. Warn user unless in dangerous projectRevertNoAsk mode. Exit to the parent project. Do a revert on a clone of the segment, to allow later reverts." + projectParameters ifNil: [^ self inform: 'nothing to revert to' translated]. - projectParameters ifNil: [^ self inform: 'nothing to revert to']. parentProject enter: false revert: true saveForRevert: false. "does not return!!" ! Item was changed: ----- Method: Project>>storeOnServer (in category 'file in/out') ----- storeOnServer "Save to disk as an Export Segment. Then put that file on the server I came from, as a new version. Version is literal piece of file name. Mime encoded and http encoded." world setProperty: #optimumExtentFromAuthor toValue: world extent. + self validateProjectNameIfOK: [:details | + self acceptProjectDetails: details. - self validateProjectNameIfOK: [ self isCurrentProject ifTrue: ["exit, then do the command" ^ self armsLengthCommand: #storeOnServerAssumingNameValid withDescription: 'Publishing' translated ]. self storeOnServerWithProgressInfo. ].! Item was changed: ----- Method: Project>>storeOnServerAssumingNameValid (in category 'file in/out') ----- storeOnServerAssumingNameValid "Save to disk as an Export Segment. Then put that file on the server I came from, as a new version. Version is literal piece of file name. Mime encoded and http encoded." - world setProperty: #optimumExtentFromAuthor toValue: world extent. self isCurrentProject ifTrue: ["exit, then do the command" + Flaps globalFlapTabsIfAny do: [:each | Flaps removeFlapTab: each keepInList: true]. ^ self armsLengthCommand: #storeOnServerAssumingNameValid withDescription: 'Publishing' translated ]. self storeOnServerWithProgressInfo. ! Item was changed: ----- Method: Project>>storeOnServerShowProgressOn:forgetURL: (in category 'file in/out') ----- storeOnServerShowProgressOn: aMorphOrNil forgetURL: forget "Save to disk as an Export Segment. Then put that file on the server I came from, as a new version. Version is literal piece of file name. Mime encoded and http encoded." world setProperty: #optimumExtentFromAuthor toValue: world extent. + self validateProjectNameIfOK: [:details | + self acceptProjectDetails: details. - self validateProjectNameIfOK: [ self isCurrentProject ifTrue: ["exit, then do the command" forget ifTrue: [self forgetExistingURL] ifFalse: [urlList isEmptyOrNil ifTrue: [urlList := parentProject urlList copy]]. ^self armsLengthCommand: #storeOnServerAssumingNameValid withDescription: 'Publishing' translated ]. self storeOnServerWithProgressInfoOn: aMorphOrNil. ]. ! Item was changed: ----- Method: Project>>validateProjectNameIfOK: (in category 'menu messages') ----- validateProjectNameIfOK: aBlock | details | details := world valueOfProperty: #ProjectDetails. details ifNotNil: ["ensure project info matches real project name" details at: 'projectname' put: self name. ]. + self doWeWantToRename ifFalse: [^ aBlock value: details]. - self doWeWantToRename ifFalse: [^aBlock value]. (Smalltalk at: #EToyProjectDetailsMorph) ifNotNil: [:etpdm | etpdm getFullInfoFor: self + ifValid: [:d | - ifValid: [ World displayWorldSafely. + aBlock value: d - aBlock value. ] expandedFormat: false] ! Item was changed: ----- Method: ProjectLauncher>>loginAs: (in category 'eToy login') ----- loginAs: userName "Assuming that we have a valid user url; read its contents and see if the user is really there." | actualName userList | eToyAuthentificationServer ifNil:[ self proceedWithLogin. ^true]. + userList _ eToyAuthentificationServer eToyUserList. - userList := eToyAuthentificationServer eToyUserList. userList ifNil:[ self inform: 'Sorry, I cannot find the user list. (this may be due to a network problem) + Please hit Cancel if you wish to use Squeak.' translated. - Please hit Cancel if you wish to use Squeak.'. ^false]. "case insensitive search" + actualName _ userList detect:[:any| any sameAs: userName] ifNone:[nil]. - actualName := userList detect:[:any| any sameAs: userName] ifNone:[nil]. actualName isNil ifTrue:[ + self inform: 'Unknown user: ' translated ,userName. - self inform: 'Unknown user: ',userName. ^false]. Utilities authorName: actualName. eToyAuthentificationServer eToyUserName: actualName. self proceedWithLogin. ^true! Item was added: + ----- Method: ProjectLoading class>>checkSecurity:preStream:projStream: (in category 'utilities') ----- + checkSecurity: aFileName preStream: preStream projStream: projStream + "Answer true if passed" + | trusted enterRestricted | + trusted := SecurityManager default positionToSecureContentsOf: + projStream. + trusted ifFalse: + [enterRestricted := (preStream isTypeHTTP or: + [aFileName isNil]) + ifTrue: [Preferences securityChecksEnabled] + ifFalse: [Preferences standaloneSecurityChecksEnabled]. + enterRestricted + ifTrue: [SecurityManager default enterRestrictedMode + ifFalse: + [preStream close. + ^ false]]]. + ^ true + ! Item was added: + ----- Method: ProjectLoading class>>checkStream: (in category 'utilities') ----- + checkStream: aStream + (aStream isNil + or: [aStream size = 0]) + ifFalse: [^ false]. + ProgressNotification signal: '9999 about to enter + project'. + "the hard part is over" + self inform: 'It looks like a problem occurred while + getting this project. It may be temporary, + so you may want to try again,' translated. + ^ true! Item was added: + ----- Method: ProjectLoading class>>fileInName:archive:morphOrList: (in category 'utilities') ----- + fileInName: aFileName archive: archive morphOrList: morphOrList + | baseChangeSet substituteFont numberOfFontSubstitutes exceptions anObject mgr | + ResourceCollector current: ResourceCollector new. + baseChangeSet := ChangeSet current. + self useTempChangeSet. "named zzTemp" + "The actual reading happens here" + substituteFont := Preferences standardDefaultTextFont copy. + numberOfFontSubstitutes := 0. + exceptions := Set new. + [[anObject := morphOrList fileInObjectAndCodeForProject] + on: MissingFont do: [ :ex | + exceptions add: ex. + numberOfFontSubstitutes := numberOfFontSubstitutes + 1. + ex resume: substituteFont ]] + ensure: [ ChangeSet newChanges: baseChangeSet]. + mgr := ResourceManager new initializeFrom: ResourceCollector current. + mgr fixJISX0208Resource. + mgr registerUnloadedResources. + archive ifNotNil:[mgr preLoadFromArchive: archive cacheName: aFileName]. + ResourceCollector current: nil. + ^ {anObject. numberOfFontSubstitutes. substituteFont. mgr}! Item was added: + ----- Method: ProjectLoading class>>loadImageSegment:fromDirectory:withProjectView:numberOfFontSubstitutes:substituteFont:mgr: (in category 'loading') ----- + loadImageSegment: morphOrList fromDirectory: aDirectoryOrNil withProjectView: existingView numberOfFontSubstitutes: numberOfFontSubstitutes substituteFont: substituteFont mgr: mgr + + | proj projectsToBeDeleted ef | + Smalltalk at: #Flaps ifPresent: [:flaps | + (flaps globalFlapTabWithID: 'Navigator' translated)ifNotNil: [:f | f hideFlap]]. + proj := morphOrList arrayOfRoots + detect: [:mm | mm isKindOf: Project] + ifNone: [^ nil]. + numberOfFontSubstitutes > 0 ifTrue: [ + proj projectParameterAt: #substitutedFont put: substituteFont]. + ef := proj projectParameterAt: #eToysFont. + (ef isNil or: [ef ~= substituteFont familySizeFace]) ifTrue: [ + proj projectParameterAt: #substitutedFont put: substituteFont. + ]. + proj projectParameters at: #MultiSymbolInWrongPlace put: false. + "Yoshiki did not put MultiSymbols into outPointers in older images!!" + morphOrList arrayOfRoots do: [:obj | + obj fixUponLoad: proj seg: morphOrList "imageSegment"]. + (proj projectParameters at: #MultiSymbolInWrongPlace) ifTrue: [ + morphOrList arrayOfRoots do: [:obj | (obj isKindOf: Set) ifTrue: [obj rehash]]]. + + proj resourceManager: mgr. + "proj versionFrom: preStream." + proj lastDirectory: aDirectoryOrNil. + proj setParent: Project current. + projectsToBeDeleted := OrderedCollection new. + existingView == #none ifFalse: [ + self makeExistingView: existingView project: proj projectsToBeDeleted: projectsToBeDeleted]. + ChangeSorter allChangeSets add: proj changeSet. + Project current projectParameters + at: #deleteWhenEnteringNewProject + ifPresent: [ :ignored | + projectsToBeDeleted add: Project current. + Project current removeParameter: #deleteWhenEnteringNewProject. + ]. + projectsToBeDeleted isEmpty ifFalse: [ + proj projectParameters + at: #projectsToBeDeleted + put: projectsToBeDeleted. + ]. + proj removeParameter: #eToysFont. + ^ proj! Item was added: + ----- Method: ProjectLoading class>>makeExistingView:project:projectsToBeDeleted: (in category 'utilities') ----- + makeExistingView: existingView project: proj projectsToBeDeleted: projectsToBeDeleted + existingView ifNil: [ + proj createViewIfAppropriate. + ChangeSorter allChangeSets add: proj changeSet. + Project current openProject: proj. + ] ifNotNil: [ + (existingView project isKindOf: DiskProxy) ifFalse: [ + existingView project changeSet name: + ChangeSet defaultName. + projectsToBeDeleted add: existingView project. + ]. + (existingView owner isSystemWindow) ifTrue: [ + existingView owner model: proj + ]. + existingView project: proj. + ]. + ! Item was added: + ----- Method: ProjectLoading class>>morphOrList:stream:fromDirectory:archive: (in category 'utilities') ----- + morphOrList: aFileName stream: preStream fromDirectory: aDirectoryOrNil archive: archive + "Answer morphOrList or nil if problem happened" + | projStream localDir morphOrList | + projStream := archive + ifNil: [preStream] + ifNotNil: [self projectStreamFromArchive: archive]. + (self checkSecurity: aFileName preStream: preStream projStream: projStream) + ifFalse: [^nil]. + localDir := Project squeakletDirectory. + aFileName ifNotNil: [ + (aDirectoryOrNil isNil or: [aDirectoryOrNil pathName + ~= localDir pathName]) ifTrue: [ + localDir deleteFileNamed: aFileName. + (localDir fileNamed: aFileName) binary + nextPutAll: preStream remainingContents; + close. + ]. + ]. + morphOrList := projStream asUnZippedStream. + preStream sleep. "if ftp, let the connection close" + ^ morphOrList + ! Item was changed: ----- Method: ProjectLoading class>>openName:stream:fromDirectory:withProjectView: (in category 'loading') ----- openName: aFileName stream: preStream fromDirectory: aDirectoryOrNil withProjectView: existingView - "Reconstitute a Morph from the selected file, presumed to be - represent a Morph saved via the SmartRefStream mechanism, and open it - in an appropriate Morphic world." + ^ self openName: aFileName stream: preStream fromDirectory: aDirectoryOrNil + withProjectView: existingView clearOriginFlag: false. - | morphOrList proj trusted localDir projStream archive mgr - projectsToBeDeleted baseChangeSet enterRestricted substituteFont - numberOfFontSubstitutes exceptions | - (preStream isNil or: [preStream size = 0]) ifTrue: [ - ProgressNotification signal: '9999 about to enter - project'. "the hard part is over" - ^self inform: - 'It looks like a problem occurred while - getting this project. It may be temporary, - so you may want to try again,' translated - ]. - ProgressNotification signal: '2:fileSizeDetermined - ',preStream size printString. - preStream isZipArchive - ifTrue:[ archive := ZipArchive new readFrom: preStream. - projStream := self - projectStreamFromArchive: archive] - ifFalse:[projStream := preStream]. - trusted := SecurityManager default positionToSecureContentsOf: - projStream. - trusted ifFalse: - [enterRestricted := (preStream isTypeHTTP or: - [aFileName isNil]) - ifTrue: [Preferences securityChecksEnabled] - ifFalse: [Preferences standaloneSecurityChecksEnabled]. - enterRestricted - ifTrue: [SecurityManager default enterRestrictedMode - ifFalse: - [preStream close. - ^ self]]]. - localDir := Project squeakletDirectory. - aFileName ifNotNil: [ - (aDirectoryOrNil isNil or: [aDirectoryOrNil pathName - ~= localDir pathName]) ifTrue: [ - localDir deleteFileNamed: aFileName. - (localDir fileNamed: aFileName) binary - nextPutAll: preStream contents; - close. - ]. - ]. - morphOrList := projStream asUnZippedStream. - preStream sleep. "if ftp, let the connection close" - ProgressNotification signal: '3:unzipped'. - ResourceCollector current: ResourceCollector new. - baseChangeSet := ChangeSet current. - self useTempChangeSet. "named zzTemp" - "The actual reading happens here" - substituteFont := Preferences standardEToysFont copy. - numberOfFontSubstitutes := 0. - exceptions := Set new. - [[morphOrList := morphOrList fileInObjectAndCodeForProject] - on: MissingFont do: [ :ex | - exceptions add: ex. - numberOfFontSubstitutes := - numberOfFontSubstitutes + 1. - ex resume: substituteFont ]] - ensure: [ ChangeSet newChanges: baseChangeSet]. - mgr := ResourceManager new initializeFrom: ResourceCollector current. - mgr fixJISX0208Resource. - mgr registerUnloadedResources. - archive ifNotNil:[mgr preLoadFromArchive: archive cacheName: - aFileName]. - (preStream respondsTo: #close) ifTrue:[preStream close]. - ResourceCollector current: nil. - ProgressNotification signal: '4:filedIn'. - ProgressNotification signal: '9999 about to enter project'. - "the hard part is over" - (morphOrList isKindOf: ImageSegment) ifTrue: [ - proj := morphOrList arrayOfRoots - detect: [:mm | mm isKindOf: Project] - ifNone: [^self inform: 'No project found in - this file']. - proj projectParameters at: #substitutedFont put: ( - numberOfFontSubstitutes > 0 - ifTrue: [substituteFont] - ifFalse: [#none]). - proj projectParameters at: #MultiSymbolInWrongPlace put: false. - "Yoshiki did not put MultiSymbols into - outPointers in older images!!" - morphOrList arrayOfRoots do: [:obj | - obj fixUponLoad: proj seg: morphOrList "imageSegment"]. - (proj projectParameters at: #MultiSymbolInWrongPlace) ifTrue: [ - morphOrList arrayOfRoots do: [:obj | (obj - isKindOf: HashedCollection) ifTrue: [obj rehash]]]. - - proj resourceManager: mgr. - "proj versionFrom: preStream." - proj lastDirectory: aDirectoryOrNil. - proj setParent: Project current. - projectsToBeDeleted := OrderedCollection new. - existingView ifNil: [ - ChangeSet allChangeSets add: proj changeSet. - Project current openProject: proj. - "Note: in MVC we get no further than the above" - ] ifNotNil: [ - (existingView project isKindOf: DiskProxy) ifFalse: [ - existingView project changeSet name: - ChangeSet defaultName. - projectsToBeDeleted add: existingView project. - ]. - (existingView owner isSystemWindow) ifTrue: [ - existingView owner model: proj - ]. - existingView project: proj. - ]. - ChangeSet allChangeSets add: proj changeSet. - Project current projectParameters - at: #deleteWhenEnteringNewProject - ifPresent: [ :ignored | - projectsToBeDeleted add: Project current. - Project current removeParameter: - #deleteWhenEnteringNewProject. - ]. - projectsToBeDeleted isEmpty ifFalse: [ - proj projectParameters - at: #projectsToBeDeleted - put: projectsToBeDeleted. - ]. - ^ ProjectEntryNotification signal: proj - ]. - Project current openViewAndEnter: morphOrList ! Item was added: + ----- Method: ProjectLoading class>>openName:stream:fromDirectory:withProjectView:clearOriginFlag: (in category 'loading') ----- + openName: aFileName stream: preStream fromDirectory: aDirectoryOrNil + withProjectView: existingView clearOriginFlag: clearOriginFlag + "Reconstitute a Morph from the selected file, presumed to + represent a Morph saved via the SmartRefStream mechanism, and open it + in an appropriate Morphic world." + + | morphOrList archive mgr substituteFont numberOfFontSubstitutes resultArray anObject project manifests dict | + (self checkStream: preStream) ifTrue: [^ self]. + ProgressNotification signal: '0.2'. + archive _ preStream isZipArchive + ifTrue:[ZipArchive new readFrom: preStream] + ifFalse:[nil]. + archive ifNotNil:[ + manifests _ (archive membersMatching: '*manifest'). + (manifests size = 1 and: [((dict _ self parseManifest: manifests first contents) at: 'Project-Format' ifAbsent: []) = 'S-Expression']) + ifTrue: [ + ^ (self respondsTo: #openSexpProjectDict:stream:fromDirectory:withProjectView:) + ifTrue: [self openSexpProjectDict: dict stream: preStream fromDirectory: aDirectoryOrNil withProjectView: existingView] + ifFalse: [self inform: 'Cannot load S-Expression format projects without Etoys' translated]]]. + + morphOrList _ self morphOrList: aFileName stream: preStream fromDirectory: aDirectoryOrNil archive: archive. + morphOrList ifNil: [^ self]. + ProgressNotification signal: '0.4'. + resultArray _ self fileInName: aFileName archive: archive morphOrList: morphOrList. + anObject _ resultArray first. + numberOfFontSubstitutes _ resultArray second. + substituteFont _ resultArray third. + mgr _ resultArray fourth. + preStream close. + ProgressNotification signal: '0.7'. + "the hard part is over" + (anObject isKindOf: ImageSegment) ifTrue: [ + project _ self loadImageSegment: anObject + fromDirectory: aDirectoryOrNil + withProjectView: existingView + numberOfFontSubstitutes: numberOfFontSubstitutes + substituteFont: substituteFont + mgr: mgr. + project noteManifestDetailsIn: dict. + project removeParameter: #sugarProperties. + Smalltalk at: #SugarPropertiesNotification ifPresent: [:sp | + sp signal ifNotNilDo: [:props | + project keepSugarProperties: props monitor: true]]. + clearOriginFlag ifTrue: [project forgetExistingURL]. + ProgressNotification signal: '0.8'. + ^ project + ifNil: [self inform: 'No project found in this file' translated] + ifNotNil: [ProjectEntryNotification signal: project]]. + Project current openViewAndEnter: anObject! Item was added: + ----- Method: ProjectLoading class>>parseManifest: (in category 'utilities') ----- + parseManifest: aString + + | dict line index key value aStream | + aStream := aString readStream. + dict := Dictionary new. + [(line := aStream nextLine) notNil] whileTrue: [ + index := line indexOf: $:. + index > 0 ifTrue: [ + key := line copyFrom: 1 to: index - 1. + value := (line copyFrom: index + 1 to: line size) withBlanksTrimmed. + dict at: key put: value. + ]. + ]. + ^ dict.! Item was changed: ----- Method: ProjectLoading class>>projectStreamFromArchive: (in category 'accessing') ----- projectStreamFromArchive: archive | ext prFiles entry unzipped | ext := FileDirectory dot, Project projectExtension. prFiles := archive members select:[:any| any fileName endsWith: ext]. + prFiles isEmpty ifTrue: + [ext := FileDirectory dot, 'sexp'. + prFiles := archive members select:[:any| any fileName endsWith: ext]]. + prFiles isEmpty ifTrue: ['']. - prFiles isEmpty ifTrue:[^'']. entry := prFiles first. + unzipped := MultiByteBinaryOrTextStream on: (ByteArray new: entry uncompressedSize). - unzipped := RWBinaryOrTextStream on: (ByteArray new: entry uncompressedSize). entry extractTo: unzipped. ^unzipped reset! Item was changed: ----- Method: SARInstaller class>>serviceFileInSAR (in category 'class initialization') ----- serviceFileInSAR "Answer a service for opening a changelist browser on a file" ^ SimpleServiceEntry provider: self + label: 'install SAR' translatedNoop - label: 'install SAR' selector: #installSAR: + description: 'install this Squeak ARchive into the image.' translatedNoop + buttonLabel: 'install' translatedNoop! - description: 'install this Squeak ARchive into the image.' - buttonLabel: 'install'! Item was changed: ----- Method: SystemVersion>>majorMinorVersion (in category 'accessing') ----- majorMinorVersion "Return the major/minor version number of the form X.Y, without any 'alpha' or 'beta' or other suffix." - "(SystemVersion new version: 'Squeak3.7alpha') majorMinorVersion" " --> 'Squeak3.7' " - "SystemVersion current majorMinorVersion" | char stream | + ^ (version includes: $.) + ifTrue: + [stream := ReadStream on: version, 'x'. + stream upTo: $.. + char := stream next. + [char isDigit] + whileTrue: [char := stream next]. + version copyFrom: 1 to: stream position - 1] + ifFalse: + [version] + + " + (SystemVersion new version: 'Squeak3.7alpha') majorMinorVersion + (SystemVersion new version: 'Testing') majorMinorVersion + SystemVersion current majorMinorVersion + " + - stream := ReadStream on: version, 'x'. - stream upTo: $.. - char := stream next. - char ifNil: [^ version]. "eg: 'Jasmine-rc1' has no $. in it." - [char isDigit] - whileTrue: [char := stream next]. - ^ version copyFrom: 1 to: stream position - 1 ! Item was changed: ----- Method: TextStyle>>addNewFontSize: (in category '*System-Fonts') ----- addNewFontSize: pointSize "Add a font in specified size to the array of fonts." | f d newArray t isSet | fontArray first emphasis ~= 0 ifTrue: [ t := TextConstants at: self fontArray first familyName asSymbol. t fonts first emphasis = 0 ifTrue: [ ^ t addNewFontSize: pointSize. ]. ]. pointSize <= 0 ifTrue: [^ nil]. fontArray do: [:s | s pointSize = pointSize ifTrue: [^ s]. ]. (isSet := fontArray first isKindOf: TTCFontSet) ifTrue:[ | fonts | fonts := fontArray first fontArray collect: [ :font | | newFont | (font isNil) ifTrue: [newFont := nil] ifFalse: [ newFont := (font ttcDescription size > 256) ifTrue: [MultiTTCFont new initialize] ifFalse: [TTCFont new initialize]. newFont ttcDescription: font ttcDescription. newFont pixelSize: pointSize * 96 // 72. font derivativeFonts notEmpty ifTrue: [font derivativeFonts do: [ :proto | proto ifNotNil: [ d := proto class new initialize. d ttcDescription: proto ttcDescription. d pixelSize: newFont pixelSize. newFont derivativeFont: d]]]. ]. newFont]. f := TTCFontSet newFontArray: fonts] ifFalse: [ f := fontArray first class new initialize: fontArray first. f pointSize: pointSize. fontArray first derivativeFonts do: [:proto | proto ifNotNil: [ + d := TTCFont new initialize: proto. - d := proto class new initialize: proto. d pointSize: f pointSize. + f derivativeFont: d. - f derivativeFont: d mainFont: proto. ]. ]. ]. newArray := (fontArray copyWith: f) asArray sort: [:a :b | a pointSize <= b pointSize]. self newFontArray: newArray. isSet ifTrue: [ TTCFontSet register: newArray at: newArray first familyName asSymbol. ]. ^ self fontOfPointSize: pointSize ! Item was changed: ----- Method: Utilities class>>floatPrecisionForDecimalPlaces: (in category 'miscellaneous') ----- floatPrecisionForDecimalPlaces: places "Answer the floatPrecision that corresponds to the given number of decimal places" ^ places caseOf: {[0]->[1] . + [1]-> [0.1] . + [2]-> [0.01] . + [3]-> [0.001] . + [4]-> [0.0001] . + [5]-> [0.00001] . + [6]-> [0.000001] . + [7]-> [0.0000001] . + [8]-> [0.00000001] . + [9]-> [0.000000001]. + [10]->[0.0000000001]} - [1]->[0.1] . - [2]->[0.01] . - [3]->[0.001] . - [4]->[0.0001] . - [5]->[0.00001] . - [6]->[0.000001] . - [7]->[0.0000001] . - [8]->[0.00000001] . - [9]->[0.000000001]} otherwise: [(10.0 raisedTo: places negated) asFloat] " (0 to: 6) collect: [:i | Utilities floatPrecisionForDecimalPlaces: i] (-10 to: 20) collect: [:i | Utilities floatPrecisionForDecimalPlaces: i] "! Item was changed: ----- Method: Utilities class>>registerInFlapsRegistry (in category 'class initialization') ----- registerInFlapsRegistry "Register the receiver in the system's flaps registry" self environment at: #Flaps + ifPresent: [:cl | cl registerQuad: {#Utilities. #recentSubmissionsWindow. 'Recent' translatedNoop. 'A message browser that tracks the most recently-submitted methods' translatedNoop} - ifPresent: [:cl | cl registerQuad: #(Utilities recentSubmissionsWindow 'Recent' 'A message browser that tracks the most recently-submitted methods') forFlapNamed: 'Tools'.]!
More information about the Squeak-dev mailing list |