[squeak-dev] The Trunk: System-dtl.183.mcz

commits at source.squeak.org commits at source.squeak.org
Sun Nov 29 23:31:20 UTC 2009


David T. Lewis uploaded a new version of System to project The Trunk:
http://source.squeak.org/trunk/System-dtl.183.mcz

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

Name: System-dtl.183
Author: dtl
Time: 29 November 2009, 7:27:35 am
UUID: aec8c06f-e83f-46ec-80cc-4e91f2000b4a
Ancestors: System-nice.182

Remove all remaining explicit MVC and Morphic dependencies (hopefully) from class Project.

=============== Diff against System-nice.182 ===============

Item was changed:
  ----- Method: Project>>loadFromServer: (in category 'file in/out') -----
  loadFromServer: newerAutomatically
  	"If a newer version of me is on the server, load it."
- 	| pair resp server |
- 	self assureIntegerVersion.
  
+ 	self subclassResponsibility!
- 	self isCurrentProject ifTrue: ["exit, then do the command"
- 		^ self armsLengthCommand: #loadFromServer withDescription: 'Loading' translated
- 	].
- 	server := self tryToFindAServerWithMe ifNil: [^ nil].
- 	pair := self class mostRecent: self name onServer: server.
- 	pair first ifNil: [^ self inform: ('can''t find file on server for {1}' translated format: {self name})].
- 	self currentVersionNumber > pair second ifTrue: [
- 		^ self inform: ('That server has an older version of the project.' translated)].
- 	version = (Project parseProjectFileName: pair first) second ifTrue: [
- 		resp := (UIManager default chooseFrom: 
- 				(Array with: 'Reload anyway' translated 
- 						with: 'Cancel' translated withCRs) 
- 				title:  'The only changes are the ones you made here.' translated).
- 		resp ~= 1 ifTrue: [^ nil]
- 	] ifFalse: [
- 		newerAutomatically ifFalse: [
- 			resp := (UIManager default 
- 						chooseFrom: #('Load it' 'Cancel') 
- 						title:  'A newer version exists on the server.').
- 			resp ~= 1 ifTrue: [^ nil]
- 		].
- 	].
- 
- 	"let's avoid renaming the loaded change set since it will be replacing ours"
- 	self projectParameters at: #loadingNewerVersion put: true.
- 
- 	ComplexProgressIndicator new 
- 		targetMorph: nil;
- 		historyCategory: 'project loading';
- 		withProgressDo: [
- 			ProjectLoading
- 				installRemoteNamed: pair first
- 				from: server
- 				named: self name
- 				in: parentProject
- 		]
- !

Item was changed:
  ----- Method: Project>>makeThumbnail (in category 'menu messages') -----
  makeThumbnail
  	"Make a thumbnail image of this project from the Display."
  	viewSize ifNil: [viewSize := Display extent // 8].
  	thumbnail := Form extent: viewSize depth: Display depth.
  	(WarpBlt current toForm: thumbnail)
  			sourceForm: Display;
  			cellSize: 2;  "installs a colormap"
  			combinationRule: Form over;
  			copyQuad: (Display boundingBox) innerCorners
  			toRect: (0 at 0 extent: viewSize).
+ 	(Smalltalk at: #InternalThreadNavigationMorph) ifNotNilDo: [:tnMorph |
+ 			tnMorph  cacheThumbnailFor: self].
- 	InternalThreadNavigationMorph cacheThumbnailFor: self.
  	^thumbnail
  !

Item was changed:
  ----- Method: Project>>chooseNaturalLanguage (in category 'language') -----
  chooseNaturalLanguage
  	"Put up a menu allowing the user to choose the natural language for the project"
  
+ 	"Project current chooseNaturalLanguage"
- 	| aMenu availableLanguages |
- 	aMenu := MenuMorph new defaultTarget: self.
- 	aMenu addTitle: 'choose language' translated.
- 	aMenu lastItem setBalloonText: 'This controls the human language in which tiles should be viewed.  It is potentially extensible to be a true localization mechanism, but initially it only works in the classic tile scripting system.  Each project has its own private language choice' translated.
- 	Preferences noviceMode
- 		ifFalse:[aMenu addStayUpItem].
- 
- 	availableLanguages := NaturalLanguageTranslator availableLanguageLocaleIDs
- 										asSortedCollection:[:x :y | x displayName < y displayName].
- 
- 	availableLanguages do:
- 		[:localeID |
- 			aMenu addUpdating: #stringForLanguageNameIs: target: Locale selector:  #switchAndInstallFontToID: argumentList: {localeID}].
- 	aMenu popUpInWorld
  
+ 	self subclassResponsibility
+ !
- "Project current chooseNaturalLanguage"!

Item was changed:
  ----- Method: Project>>storeOnServerWithProgressInfoOn: (in category 'file in/out') -----
  storeOnServerWithProgressInfoOn: aMorphOrNil
  
  	"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."
  
+ 	self subclassResponsibility
- 	ComplexProgressIndicator new 
- 		targetMorph: aMorphOrNil;
- 		historyCategory: 'project storing';
- 		withProgressDo: [self storeOnServerInnards]
  	!

Item was added:

Item was changed:
  ----- Method: Project>>storeSegment (in category 'file in/out') -----
  storeSegment
  	"Store my project out on the disk as an ImageSegment.  Keep the outPointers in memory.  Name it <project name>.seg.  *** Caller must be holding (Project alInstances) to keep subprojects from going out. ***"
  
+ 	self subclassResponsibility
- | is sizeHint |
- (World == world) ifTrue: [^ false]. 
- 	"self inform: 'Can''t send the current world out'."
- world isInMemory ifFalse: [^ false].  "already done"
- world isMorph ifFalse: [
- 	self projectParameters at: #isMVC put: true.
- 	^ false].	"Only Morphic projects for now"
- world ifNil: [^ false].  world presenter ifNil: [^ false].
- 
- Utilities emptyScrapsBook.
- World checkCurrentHandForObjectToPaste.
- world releaseSqueakPages.
- sizeHint := self projectParameters at: #segmentSize ifAbsent: [0].
- 
- is := ImageSegment new copyFromRootsLocalFileFor: 
- 			(Array with: world presenter with: world)	"world, and all Players"
- 		 sizeHint: sizeHint.
- 
- is state = #tooBig ifTrue: [^ false].
- is segment size < 2000 ifTrue: ["debugging" 
- 	Transcript show: self name, ' only ', is segment size printString, 
- 		'bytes in Segment.'; cr].
- self projectParameters at: #segmentSize put: is segment size.
- is extract; writeToFile: self name.
- ^ true
  !

Item was changed:
  ----- Method: Project>>exportSegmentWithChangeSet:fileName:directory: (in category 'file in/out') -----
  exportSegmentWithChangeSet: aChangeSetOrNil fileName: aFileName
  directory: aDirectory
  	"Store my project out on the disk as an *exported*
  ImageSegment.  All outPointers will be in a form that can be resolved
  in the target image.  Name it <project name>.extSeg.  Whatdo we do
  about subProjects, especially if they are out as local image
  segments?  Force them to come in?
  	Player classes are included automatically."
  
+ 	self subclassResponsibility!
- 	| is str ans revertSeg roots holder collector fd mgr stacks |
- 
- 	"Files out a changeSet first, so that a project can contain
- its own classes"
- world isMorph ifFalse: [
- 	self projectParameters at: #isMVC put: true.
- 	^ false].	"Only Morphic projects for now"
- world ifNil: [^ false].  world presenter ifNil: [^ false].
- 
- Utilities emptyScrapsBook.
- world currentHand pasteBuffer: nil.	  "don't write the paste buffer."
- world currentHand mouseOverHandler initialize.	  "forget about any
- references here"
- 	"Display checkCurrentHandForObjectToPaste."
- Command initialize.
- world clearCommandHistory.
- world fullReleaseCachedState; releaseViewers.
- world cleanseStepList.
- world localFlapTabs size = world flapTabs size ifFalse: [
- 	self error: 'Still holding onto Global flaps'].
- world releaseSqueakPages.
- ScriptEditorMorph writingUniversalTiles: (self projectParameterAt:
- #universalTiles ifAbsent: [false]).
- holder := Project allProjects.	"force them in to outPointers, where
- DiskProxys are made"
- 
- "Just export me, not my previous version"
- revertSeg := self projectParameters at: #revertToMe ifAbsent: [nil].
- self projectParameters removeKey: #revertToMe ifAbsent: [].
- 
- roots := OrderedCollection new.
- roots add: self; add: world; add: transcript; add: changeSet; add: thumbnail.
- roots add: world activeHand.
- 
- 	"; addAll: classList; addAll: (classList collect: [:cls | cls class])"
- 
- roots := roots reject: [ :x | x isNil].	"early saves may not have
- active hand or thumbnail"
- 
- 	fd := aDirectory directoryNamed: self resourceDirectoryName.
- 	fd assureExistence.
- 	"Clean up resource references before writing out"
- 	mgr := self resourceManager.
- 	self resourceManager: nil.
- 	ResourceCollector current: ResourceCollector new.
- 	ResourceCollector current localDirectory: fd.
- 	ResourceCollector current baseUrl: self resourceUrl.
- 	ResourceCollector current initializeFrom: mgr.
- 	ProgressNotification signal: '2:findingResources' extra:
- '(collecting resources...)' translated.
- 	"Must activate old world because this is run at #armsLength.
- 	Otherwise references to ActiveWorld, ActiveHand, or ActiveEvent
- 	will not be captured correctly if referenced from blocks or user code."
- 	world becomeActiveDuring:[
- 		is := ImageSegment new copySmartRootsExport: roots asArray.
- 		"old way was (is := ImageSegment new
- copyFromRootsForExport: roots asArray)"
- 	].
- 	self resourceManager: mgr.
- 	collector := ResourceCollector current.
- 	ResourceCollector current: nil.
- 	ProgressNotification signal: '2:foundResources' extra: ''.
- 	is state = #tooBig ifTrue: [
- 		collector replaceAll.
- 		^ false].
- 
- str := ''.
- "considered legal to save a project that has never been entered"
- (is outPointers includes: world) ifTrue: [
- 	str := str, '\Project''s own world is not in the segment.' translated withCRs].
- str isEmpty ifFalse: [
- 	ans := UIManager default chooseFrom: {
- 		'Do not write file' translated.
- 		'Write file anyway' translated.
- 		'Debug' translated.
- 	} title: str.
- 	ans = 1 ifTrue: [
- 		revertSeg ifNotNil: [projectParameters at:
- #revertToMe put: revertSeg].
- 		collector replaceAll.
- 		^ false].
- 	ans = 3 ifTrue: [
- 		collector replaceAll.
- 		self halt: 'Segment not written' translated]].
- 	stacks := is findStacks.
- 
- 	is
- 		writeForExportWithSources: aFileName
- 		inDirectory: fd
- 		changeSet: aChangeSetOrNil.
- 	SecurityManager default signFile: aFileName directory: fd.
- 	"Compress all files and update check sums"
- 	collector forgetObsolete.
- 	self storeResourceList: collector in: fd.
- 	self storeHtmlPageIn: fd.
- 	self storeManifestFileIn: fd.
- 	self writeStackText: stacks in: fd registerIn: collector.
- 	"local proj.005.myStack.t"
- 	self compressFilesIn: fd to: aFileName in: aDirectory
- resources: collector.
- 			"also deletes the resource directory"
- 	"Now update everything that we know about"
- 	mgr updateResourcesFrom: collector.
- 
- revertSeg ifNotNil: [projectParameters at: #revertToMe put: revertSeg].
- holder.
- 
- collector replaceAll.
- 
- world flapTabs do: [:ft |
- 		(ft respondsTo: #unhibernate) ifTrue: [ft unhibernate]].
- is arrayOfRoots do: [:obj |
- 	obj class == ScriptEditorMorph ifTrue: [obj unhibernate]].
- ^ true
- !

Item was changed:
  ----- Method: Project>>storeOnServerWithProgressInfo (in category 'file in/out') -----
  storeOnServerWithProgressInfo
  
  	"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."
  
+ 	self subclassResponsibility
+ !
- 	ComplexProgressIndicator new 
- 		targetMorph: nil;
- 		historyCategory: 'project storing';
- 		withProgressDo: [self storeOnServerInnards]
- 	!

Item was changed:
  ----- Method: Project>>initializeProjectPreferences (in category 'project parameters') -----
  initializeProjectPreferences
  	"Initialize the project's preferences from currently-prevailing preferences that are currently being held in projects in this system"
  	
  	projectPreferenceFlagDictionary := Project current projectPreferenceFlagDictionary deepCopy.    "Project overrides in the new project start out being the same set of overrides in the calling project"
  
  	Preferences allPreferenceObjects do:  "in case we missed some"
  		[:aPreference |
  			aPreference localToProject ifTrue:
  				[(projectPreferenceFlagDictionary includesKey: aPreference name) ifFalse:
  			[projectPreferenceFlagDictionary at: aPreference name put: aPreference preferenceValue]]].
  
- 	self isMorphic ifFalse: [self flapsSuppressed: true].
  	(Project current projectParameterAt: #disabledGlobalFlapIDs  ifAbsent: [nil]) ifNotNilDo:
  		[:idList | self projectParameterAt: #disabledGlobalFlapIDs put: idList copy]
  !

Item was changed:
  ----- Method: Project>>storeSegmentNoFile (in category 'file in/out') -----
  storeSegmentNoFile
  	"For testing.  Make an ImageSegment.  Keep the outPointers in memory.  Also useful if you want to enumerate the objects in the segment afterwards (allObjectsDo:)"
  
+ 	self subclassResponsibility
- | is str |
- (World == world) ifTrue: [^ self].		" inform: 'Can''t send the current world out'."
- world isInMemory ifFalse: [^ self].  "already done"
- world isMorph ifFalse: [
- 	self projectParameters at: #isMVC put: true.
- 	^ self].	"Only Morphic projects for now"
- world ifNil: [^ self].  world presenter ifNil: [^ self].
- 
- "Do this on project enter"
- World flapTabs do: [:ft | ft referent adaptToWorld: World].
- 	"Hack to keep the Menu flap from pointing at my project"
- "Preferences setPreference: #useGlobalFlaps toValue: false."
- "Utilities globalFlapTabsIfAny do:
- 	[:aFlapTab | Utilities removeFlapTab: aFlapTab keepInList: false].
- Utilities clobberFlapTabList.	"
- "project world deleteAllFlapArtifacts."
- "self currentWorld deleteAllFlapArtifacts.	"
- Utilities emptyScrapsBook.
- World checkCurrentHandForObjectToPaste2.
- 
- is := ImageSegment new copyFromRootsLocalFileFor: 
- 		(Array with: world presenter with: world)	"world, and all Players"
- 	sizeHint: 0.
- 
- is segment size < 800 ifTrue: ["debugging" 
- 	Transcript show: self name, ' did not get enough objects'; cr.  ^ Beeper beep].
- false ifTrue: [
- 	str := String streamContents: [:strm |
- 		strm nextPutAll: 'Only a tiny part of the project got into the segment'.
- 		strm nextPutAll: '\These are pointed to from the outside:' withCRs.
- 		is outPointers do: [:out |
- 			(out class == Presenter) | (out class == ScriptEditorMorph) ifTrue: [
- 				strm cr. out printOn: strm.
- 				self systemNavigation
- 					browseAllObjectReferencesTo: out
- 					except: (Array with: is outPointers)
- 					ifNone: [:obj | ]].
- 			(is arrayOfRoots includes: out class) ifTrue: [strm cr. out printOn: strm.
- 				self systemNavigation
- 					browseAllObjectReferencesTo: out
- 					except: (Array with: is outPointers)
- 					ifNone: [:obj | ]]]].
- 	self inform: str.
- 	^ is inspect].
- 
- is extract.
- "is instVarAt: 2 put: is segment clone."		"different memory"
  !

Item was changed:
  ----- Method: Project>>exportSegmentWithCatagories:classes:fileName:directory: (in category 'file in/out') -----
  exportSegmentWithCatagories: catList classes: classList fileName: aFileName directory: aDirectory
  	"Store my project out on the disk as an *exported* ImageSegment.  All outPointers will be in a form that can be resolved in the target image.  Name it <project name>.extSeg.  What do we do about subProjects, especially if they are out as local image segments?  Force them to come in?
  	Player classes are included automatically."
  
+ 	self flag: #toRemove.
+ 	self subclassResponsibility
- 	| is str ans revertSeg roots holder |
- self halt.  "unused"
- 	"world == World ifTrue: [^ false]."
- 		"self inform: 'Can''t send the current world out'."
- 	world isMorph ifFalse: [
- 		self projectParameters at: #isMVC put: true.
- 		^ false].	"Only Morphic projects for now"
- 	world ifNil: [^ false].  world presenter ifNil: [^ false].
- 
- 	Utilities emptyScrapsBook.
- 	world currentHand pasteBuffer: nil.	  "don't write the paste buffer."
- 	world currentHand mouseOverHandler initialize.	  "forget about any references here"
- 		"Display checkCurrentHandForObjectToPaste."
- 	Command initialize.
- 	world clearCommandHistory.
- 	world fullReleaseCachedState; releaseViewers. 
- 	world cleanseStepList.
- 	world localFlapTabs size = world flapTabs size ifFalse: [
- 		self error: 'Still holding onto Global flaps'].
- 	world releaseSqueakPages.
- 	ScriptEditorMorph writingUniversalTiles: (self projectParameterAt: #universalTiles ifAbsent: [false]).
- 	holder := Project allProjects.	"force them in to outPointers, where DiskProxys are made"
- 
- 	"Just export me, not my previous version"
- 	revertSeg := self projectParameters at: #revertToMe ifAbsent: [nil].
- 	self projectParameters removeKey: #revertToMe ifAbsent: [].
- 
- 	roots := OrderedCollection new.
- 	roots add: self; add: world; add: transcript; add: changeSet; add: thumbnail.
- 	roots add: world activeHand; addAll: classList; addAll: (classList collect: [:cls | cls class]).
- 
- 	roots := roots reject: [ :x | x isNil].	"early saves may not have active hand or thumbnail"
- 
- 	catList do: [:sysCat | 
- 		(SystemOrganization listAtCategoryNamed: sysCat asSymbol) do: [:symb |
- 			roots add: (Smalltalk at: symb); add: (Smalltalk at: symb) class]].
- 
- 	is := ImageSegment new copySmartRootsExport: roots asArray.
- 		"old way was (is := ImageSegment new copyFromRootsForExport: roots asArray)"
- 
- 	is state = #tooBig ifTrue: [^ false].
- 
- 	str := ''.
- 	"considered legal to save a project that has never been entered"
- 	(is outPointers includes: world) ifTrue: [
- 		str := str, '\Project''s own world is not in the segment.' withCRs].
- 	str isEmpty ifFalse: [
- 		ans := (UIManager default
- 				 chooseFrom: #('Do not write file' 'Write file anyway' 'Debug')
- 				 title: str).
- 		ans = 1 ifTrue: [
- 			revertSeg ifNotNil: [projectParameters at: #revertToMe put: revertSeg].
- 			^ false].
- 		ans = 3 ifTrue: [self halt: 'Segment not written']].
- 
- 	is writeForExportWithSources: aFileName inDirectory: aDirectory.
- 	revertSeg ifNotNil: [projectParameters at: #revertToMe put: revertSeg].
- 	holder.
- 	world flapTabs do: [:ft | 
- 			(ft respondsTo: #unhibernate) ifTrue: [ft unhibernate]].
- 	is arrayOfRoots do: [:obj |
- 		obj class == ScriptEditorMorph ifTrue: [obj unhibernate]].
- 	^ true
  !

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].
+ 	(Smalltalk at: #EToyProjectDetailsMorph) ifNotNilDo: [:etpdm |
+ 		etpdm
+ 			getFullInfoFor: self 
+ 			ifValid: [
+ 				World displayWorldSafely.
+ 				aBlock value.
+ 			] fixTemps
+ 			expandedFormat: false]
- 	EToyProjectDetailsMorph
- 		getFullInfoFor: self 
- 		ifValid: [
- 			World displayWorldSafely.
- 			aBlock value.
- 		] fixTemps
- 		expandedFormat: false
  !

Item was removed:
- ----- Method: Project>>currentStack (in category 'project parameters') -----
- currentStack
- 	"Answer the current stack of the current project.  Called basically as a bail-out when we can't find the stack in the owner chain of a morph, probably because it is on a background that is not currently installed.  This method will always return a stack that is in the world, or nil if no stack is found in the world.  Of course it would be nice to have multiple stacks concurrently open in the same world, but at the moment that is problematical."
- 
- 	| aStack curStack |
- 
- 	curStack := self projectParameterAt: #CurrentStack.
- 	curStack ifNotNil: [curStack isInWorld ifTrue: [^ curStack]].
- 
- 	(aStack := world findA: StackMorph) ifNotNil:
- 		[self currentStack: aStack].
- 	^ aStack!

Item was removed:
- ----- Method: Project>>setPaletteFor: (in category 'language') -----
- setPaletteFor: aLanguageSymbol 
- 	| prototype formKey form |
- 	prototype := PaintBoxMorph prototype.
- 	formKey := ('offPalette' , aLanguageSymbol) asSymbol.
- 	form := Imports default imports
- 				at: formKey
- 				ifAbsent: [Imports default imports
- 						at: #offPaletteEnglish
- 						ifAbsent: []].
- 	form isNil ifFalse: [prototype loadOffForm: form].
- 	formKey := ('pressedPalette' , aLanguageSymbol) asSymbol.
- 	form := Imports default imports
- 				at: formKey
- 				ifAbsent: [Imports default imports
- 						at: #pressedPaletteEnglish
- 						ifAbsent: []].
- 	form isNil ifFalse: [prototype loadPressedForm: form].
- !




More information about the Squeak-dev mailing list