The Trunk: System-tfel.911.mcz

Tim Felgentreff uploaded a new version of System to project The Trunk:
http://source.squeak.org/trunk/System-tfel.911.mcz

==================== Summary ====================

Name: System-tfel.911
Author: tfel
Time: 29 August 2016, 4:20:07.411946 pm
UUID: 0242c0ab-04df-994a-adb2-a8c26da259fa
Ancestors: System-tfel.902, System-ul.910

merge fixes from Etoys Squeakland
- Project loading was refactored, and hooks added to support Sexp projects
- translations added
- use new sequential progress mechanism when loading projects
- translatedNoop added to Object, helps GetTextExporter find terms

=============== Diff against System-ul.910 ===============

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 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: DiskProxy>>enter:revert:saveForRevert: (in category 'exceptions') -----
  enter: returningFlag revert: revertFlag saveForRevert: saveForRevert
  "Look for our project on the server, then try to enter it!!  DiskProxy is acting as a stub for the real thing.  Called from a ProjectViewMorph in the current project.  If have url, use it.  Else look in current Project's server and folder."
 
+ constructorSelector == #namedExample: ifTrue: ["Project namedUrl: xxx"
+ ^ ((Smalltalk at: globalObjectName) perform: #fromExampleEtoys:
+ withArguments: constructorArgs) ].
  constructorSelector == #namedUrl: ifTrue: ["Project namedUrl: xxx"
  ^ ((Smalltalk at: globalObjectName) perform: #fromUrl:
  withArguments: constructorArgs) ].
  constructorSelector == #named: ifTrue: [
  Project current fromMyServerLoad: constructorArgs first]. "name"
  !

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 := [
  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 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.
  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: [
- 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 == ours) | (ww == nil) ifFalse: [
  refs removeKey: obj.  known := known-1.
+ blockers at: obj put: (StringMorph contents:
+ obj printString, ' from another world')]]].
- 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: 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 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 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}.
  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.
 
+ rawList isString ifTrue: [self inform: 'server is unavailable' translated. ^nothingFound].
- 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: [
- (aName beginsWith: stem) ifTrue: [
  num := (Project parseProjectFileName: aName) second.
+ num > max ifTrue: [max := num.  goodName := (rawList at: ind)]]]].
- 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: '_'.
  list withIndexDo: [:aName :ind |
  (aName beginsWith: stem1) ifTrue: [
  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"
  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"
  max = -1 ifFalse: [^ Array with: goodName with: max].
 
  ^nothingFound "no matches"
  !

Item was added:
+ ----- Method: Project class>>publishInSexp (in category 'preferences') -----
+ publishInSexp
+
+ ^ (Smalltalk classNamed: 'SISSDictionaryForScanning')
+ ifNil: [false]
+ ifNotNil: [:siss | siss publishInSexp]!

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'.
 
  "Collect each name, and decide on versions"
  list := aServerDirectory fileNames.
+ list isString ifTrue: [^ self inform: 'server is unavailable' translated].
- 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 removed:
- ----- Method: Project>>compressFilesIn:to:in:resources: (in category 'file in/out') -----
- compressFilesIn: tempDir to: localName in: localDirectory resources: collector
- "Compress all the files in tempDir making up a zip file in localDirectory named localName"
- | archive urlMap |
- urlMap := Dictionary new.
- collector locatorsDo:[:loc|
- "map local file names to urls"
- urlMap at: (tempDir localNameFor: loc localFileName) put: loc urlString.
- ResourceManager cacheResource: loc urlString inArchive: localName].
- archive := ZipArchive new.
- tempDir fileNames do:[:fn| | archiveName entry |
- archiveName := urlMap at: fn ifAbsent:[fn].
- entry := archive addFile: (tempDir fullNameFor: fn) as: archiveName.
- entry desiredCompressionMethod: ZipArchive compressionStored.
- ].
- archive writeToFileNamed: (localDirectory fullNameFor: localName).
- archive close.
- tempDir fileNames do:[:fn|
- tempDir deleteFileNamed: fn ifAbsent:[]].
- localDirectory deleteDirectory: tempDir localName.!

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 topProject project |
  depth := 0.
- topProject := Project topProject.
  project := self.
 
+ [project class == DiskProxy ifTrue: [^ depth].
+ project isTopProject]
+ whileFalse:
- [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].
- (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>>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 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 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 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>>openOn: (in category 'loading') -----
+ openOn: aStream
+ 'Loading a Project...' displaySequentialProgress: [self
+ openName: nil
+ stream: aStream
+ fromDirectory: nil
+ withProjectView: nil]!

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'.]!