[squeak-dev] The Trunk: System-tfel.911.mcz

commits at source.squeak.org commits at source.squeak.org
Mon Aug 29 14:20:36 UTC 2016


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



More information about the Squeak-dev mailing list