[Pkg] Monticello Public: Monticello.impl-kph.635.mcz

[squeak-dev-noreply at lists.squeakfoundation.org]

A new version of Monticello.impl was added to project Monticello Public:
http://www.squeaksource.com/mc/Monticello.impl-kph.635.mcz

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

Name: Monticello.impl-kph.635
Author: kph
Time: 17 February 2009, 12:34:59 pm
UUID: 6b2cd301-8d04-482e-ad20-5630cf8930a4
Ancestors: Monticello.impl-kph.625

+ stopped inclusion of effectively empty scripts
+ MCUnloadPostscript was removing the script before evaluating it
+ Some scripts were not being evaluated.
+ removed HTTP overrides in favour of M7291
+ fixed file service handlers for mcm's

=============== Diff against Monticello.impl-kph.625 ===============

Item was changed:
  ----- Method: MCWorkingCopyBrowser>>editScript: (in category 'morphic ui') -----
  editScript: scriptSymbol
  
+ 	| script |
+ 	
+ 	workingCopy packageInfo in: [ :pi |
+ 		 script := (pi propertyAt: scriptSymbol) ifNil: [ pi propertyDefaultAt: scriptSymbol ].
+ 	].
+ 	script openLabel: scriptSymbol asString, ' of the Package ', workingCopy package name.!
- | script |
- script := workingCopy packageInfo propertyOrDefaultAt: scriptSymbol.
- script openLabel: scriptSymbol asString, ' of the Package ', workingCopy package name.!

Item was changed:
  ----- Method: MCSnapshotBrowser>>visibleClasses (in category 'listing') -----
  visibleClasses
  
  	categorySelection = self filesCategory ifTrue: [ 
+ 		^ self fileDefinitions collect: [:f | f path]
- 		^ self fileDefinitions collect: #path
  	].
  
  	^ categorySelection = self extensionsCategory
  		ifTrue: [self extensionClassNames]
  		ifFalse: [self packageClasses
  					select: [:ea | ea category = categorySelection]
  					thenCollect: [:ea | ea className]].!

Item was changed:
+ ----- Method: PackageInfo>>manager: (in category '*monticello-base') -----
- ----- Method: PackageInfo>>manager: (in category '*monticello') -----
  manager: mcPackageManager
  
  	^ self propertyAt: #mc put: mcPackageManager!

Item was changed:
  ----- Method: MCFileDefinition>>install (in category 'as yet unclassified') -----
  install
  
+ 	| file |
+ 	file := self pathToOriginalFull.
+ 	(FileDirectory on: file) containingDirectory assureExistence.
+ 	FileDirectory default copyFileNamed: self pathToSnapshotFull toFileNamed: file.!
- 	FileDirectory default copyFileNamed: self pathToSnapshotFull toFileNamed: self pathToOriginalFull!

Item was changed:
+ ----- Method: MCWorkingCopy>>trimAncestry (in category 'accessing') -----
- ----- Method: MCWorkingCopy>>trimAncestry (in category 'private') -----
  trimAncestry
+ 	 
+ 	self ancestry ancestors do: [ :ea | ea trimAfterVersionInfo: ea ]!
- 
- 	self ancestry trimAfterVersionInfo: versionInfo!

Item was added:
+ ----- Method: MCOrganizationDefinition>>unload (in category 'as yet unclassified') -----
+ unload
+ 	Smalltalk organization removeEmptyCategories!

Item was changed:
  ----- Method: MCScriptDefinition>>installScript: (in category 'as yet unclassified') -----
  installScript: aString
  	
+ 	self packageInfo propertyAt: self scriptSelector put: (StringHolder new contents: aString).
- 	self packageInfo propertyAt: self scriptSelector put: aString.
  	!

Item was changed:
  ----- Method: MCRemovalPreambleDefinition>>unload (in category 'as yet unclassified') -----
  unload
+ 	self evaluate
  	super unload.
+ !
- 	self evaluate!

Item was added:
+ ----- Method: MCPreambleDefinition>>preloadOver: (in category 'as yet unclassified') -----
+ preloadOver: obs
+ 	super preloadOver: obs.
+ 	self evaluate !

Item was changed:
  ----- Method: MCWorkingCopy>>myMenu:inBrowser: (in category 'menu') -----
  myMenu: aMenu inBrowser: browser
   
+ 	"note these actions are sent to the browser"
+ 	
  	browser fillMenu: aMenu fromSpecs:
  		#(
  			('add required package' #addRequiredPackage)
  			('clear required packages' #clearRequiredPackages)
  			('add repository...' #addPackageRepository)
  			"('browse package' #browseWorkingCopy)
  			('view changes' #viewChanges)
  			('view history' #viewHistory)"
  			('recompile package' #recompilePackage)
  			('recompile all packages' #recompileAllPackages)		
  			('memory use for all packages' #viewMemoryUseAll)		
  			('memory use' #viewMemoryUse)		
  			('revert package...' #revertPackage)
  			('unload package code' #unloadPackage)
  			('trim ancestry' #trimAncestry)
  			('ancestry go back one' #ancestryGoBackOne)
  			('remove package name from list' #deleteWorkingCopy)
  			('explore working copy' #exploreWorkingCopy)
  		).
  
  	self class selectors select: [ :sel | (sel beginsWith: #myMenu) and: [ sel ~= #myMenu:inBrowser: ]]
  		thenDo: [ :ea | self perform: ea with: aMenu ].
  
  	^ aMenu
  !

Item was changed:
  ----- Method: MCScriptDefinition class>>from:addTo: (in category 'as yet unclassified') -----
  from: aPackageInfo addTo: definitions
  	
+ 	| script default |
+ 
  	(aPackageInfo respondsTo: #propertyAt:) ifFalse: [ ^ self ].
  	
+ 	script := (aPackageInfo propertyAt: self scriptSelector) ifNil: [ ^ self ].
+ 	default := aPackageInfo propertyDefaultAt: self scriptSelector.
+ 	
+ 	script contents ~= default contents 
+ 		ifTrue: [ definitions add: (self script: script contents asString packageName: aPackageInfo name) ]!
- 	(aPackageInfo propertyAt: self scriptSelector)
- 		ifNotNilDo: [ :v | definitions add: (self from: v) ]!

Item was changed:
  ----- Method: MCWorkingCopyBrowser>>workingCopyListMenu: (in category 'morphic ui') -----
  workingCopyListMenu: aMenu
+  
+ 	workingCopy ifNil: [ ^ self workingCopyAllMenu: aMenu ] ifNotNilDo: [ :wc | wc myMenu: aMenu inBrowser: self  ].
+ 	
+ 	^ aMenu!
- 	workingCopy ifNil: [^ aMenu].
- 	self fillMenu: aMenu fromSpecs:
- 		#(('add required package' #addRequiredPackage)
- 			('add required all dirty packages' #addRequiredDirtyPackage)
- 			('clear required packages' #clearRequiredPackages)
- 			('browse package' #browseWorkingCopy)
- 			('view changes' #viewChanges)
- 			('view history' #viewHistory)
- 			('recompile package' #recompilePackage)
- 			('recompile all packages' #recompileAllPackages)		
- 			('memory use for all packages' #viewMemoryUseAll)		
- 			('memory use' #viewMemoryUse)	
- 			('revert package...' #revertPackage)
- 			('unload package' #unloadPackage)
- 			('delete working copy' #deleteWorkingCopy)).
- 	(Smalltalk includesKey: #SARMCPackageDumper) ifTrue: [
- 		aMenu add: 'make SAR' target: self selector: #fileOutAsSAR
- 	].
- 	^aMenu!

Item was changed:
+ ----- Method: PackageInfo>>manager (in category '*monticello-base') -----
- ----- Method: PackageInfo>>manager (in category '*monticello') -----
  manager
  
  	^ self propertyAt: #mc!

Item was changed:
  ----- Method: MCDefinition>>postloadOver: (in category 'installing') -----
  postloadOver: aDefinition
+ 	!
- 	"this method is now obsolete, it runs when old versions of Monticello are used to load this one.
- 	It is also the only place in the transition where you can put 'initialization' code if you have to"
-  !

Item was added:
+ ----- Method: MCWorkingCopyBrowser>>workingCopyAllMenu: (in category 'morphic ui') -----
+ workingCopyAllMenu: aMenu
+  
+ 	aMenu add: 'trim ALL ancestry' target: self selector: #trimAncestryAll.
+ 
+ 	^aMenu!

Item was changed:
  ----- Method: MCPostscriptDefinition>>postloadOver: (in category 'as yet unclassified') -----
  postloadOver: obs
+ 	super postloadOver: obs.
  	self evaluate!

Item was changed:
  ----- Method: MCWorkingCopyBrowser>>workingCopyTreeMenu: (in category 'morphic ui') -----
  workingCopyTreeMenu: aMenu
+  
+ 	workingCopy ifNil: [ ^ self workingCopyAllMenu: aMenu ] ifNotNilDo: [ :wc | wc myMenu: aMenu inBrowser: self  ].
- 
- 	workingCopy ifNotNilDo: [ :wc | wc myMenu: aMenu inBrowser: self  ].
  	
  	^ aMenu!

Item was added:
+ ----- Method: MCWorkingCopyBrowser>>trimAncestryAll (in category 'actions') -----
+ trimAncestryAll
+ 
+ 	self workingCopies do: [ :ea | ea  trimAncestry ]
+ 		
+ 	 !

Item was removed:
- ----- Method: HTTPSocket class>>httpPost:args:user:passwd: (in category '*monticello-override') -----
- httpPost: url args: args user: user passwd: passwd
- 	| authorization result |
- 	authorization := (Base64MimeConverter mimeEncode: (user , ':' , passwd) readStream) contents.
- 	result := self 
- 		httpPostDocument: url args: args accept: '*/*' 
- 		request: 'Authorization: Basic ' , authorization , CrLf.
- 	result isString ifFalse: [^result].
- 
- 	authorization := self digestFor: result method: 'POST' url: url user: user password: passwd.
- 	authorization ifNil: [^result].
- 	^self 
- 		httpPostDocument: url args: args accept: '*/*' 
- 		request: 'Authorization: Digest ' , authorization , CrLf.
- !

Item was removed:
- ----- Method: HTTPSocket class>>httpGetDocument:args:accept:request: (in category '*monticello-override') -----
- httpGetDocument: url args: args accept: mimeType request: requestString
- 	"Return the exact contents of a web object. Asks for the given MIME 
- type. If mimeType is nil, use 'text/html'. An extra requestString may be 
- submitted and must end with crlf.  The parsed header is saved. Use a 
- proxy server if one has been registered.  tk 7/23/97 17:12"
- 	"Note: To fetch raw data, you can use the MIME type 
- 'application/octet-stream'."
- 
- 	| serverName serverAddr port sock header length bare page list firstData 
- aStream index connectToHost connectToPort type newUrl |
- 	Socket initializeNetwork.
- 	bare := (url asLowercase beginsWith: 'http://') 
- 		ifTrue: [url copyFrom: 8 to: url size]
- 		ifFalse: [url].
- 	bare := bare copyUpTo: $#.  "remove fragment, if specified"
- 	serverName := bare copyUpTo: $/.
- 	page := bare copyFrom: serverName size + 1 to: bare size.
- 	(serverName includes: $:) 
- 		ifTrue: [ index := serverName indexOf: $:.
- 			port := (serverName copyFrom: index+1 to: serverName size) asNumber.
- 			serverName := serverName copyFrom: 1 to: index-1. ]
- 		ifFalse: [ port := self defaultPort ].
- 	page size = 0 ifTrue: [page := '/'].
- 	"add arguments"
- 	args ifNotNil: [page := page, (self argString: args) ].
- 
- 
- 	(self shouldUseProxy: serverName)
- 		ifFalse: [ 
- 			connectToHost := serverName.
- 			connectToPort := port ]
- 		ifTrue:  [
- 			page := 'http://', serverName, ':', port printString, page.		"put back 
- together"
- 			connectToHost := HTTPProxyServer.
- 			connectToPort := HTTPProxyPort].
- 	
- 
- 	serverAddr := NetNameResolver addressForName: connectToHost timeout: 20.
- 	serverAddr ifNil: [
- 		^ 'Could not resolve the server named: ', connectToHost].
- 
- 3 timesRepeat: [
- 	sock := HTTPSocket new.
- 	sock connectTo: serverAddr port: connectToPort.
- 	(sock waitForConnectionUntil: (self deadlineSecs: 30)) ifFalse: [
- 		Socket deadServer: connectToHost.  sock destroy.
- 		^ 'Server ',connectToHost,' is not responding'].
- 	"Transcript cr;show: url; cr.
- 	Transcript show: page; cr."
- 	sock sendCommand: 'GET ', page, ' HTTP/1.0', CrLf, 
- 		(mimeType ifNotNil: ['ACCEPT: ', mimeType, CrLf] ifNil: ['']),
- 		'ACCEPT: text/html', CrLf,	"Always accept plain text"
- 		HTTPBlabEmail,	"may be empty"
- 		requestString,	"extra user request. Authorization"
- 		self userAgentString, CrLf,
- 		'Host: ', serverName, ':', port printString, CrLf.	"blank line 
- automatically added"
- 
- 	list := sock getResponseUpTo: CrLf, CrLf ignoring: (String with: CR).	"list = header, CrLf, CrLf, 
- beginningOfData"
- 	header := list at: 1.
- 	"Transcript show: page; cr; show: header; cr."
- 	firstData := list at: 3.
- 	header isEmpty 
- 		ifTrue: [aStream := 'server aborted early']
- 		ifFalse: [
- 			"dig out some headers"
- 			sock header: header.
- 			length := sock getHeader: 'content-length'.
- 			length ifNotNil: [ length := length asNumber ].
- 			type := sock getHeader: 'content-type'.
- 			sock responseCode first = $3 ifTrue: [
- 				newUrl := sock getHeader: 'location'.
- 				newUrl ifNotNil: [ 
- 					Transcript show: 'redirecting to ', newUrl; cr.
- 					sock destroy.
- 					newUrl := self expandUrl: newUrl ip: serverAddr port: connectToPort.
- 					^self httpGetDocument: newUrl args: args  accept: mimeType request: requestString] ].
- 			aStream := sock getRestOfBuffer: firstData totalLength: length.
- 			"a 400-series error"
- 			sock responseCode first = $4 ifTrue: [^ header, aStream contents].
- 			].
- 	sock destroy.	"Always OK to destroy!!"
- 	aStream class ~~ String ifTrue: [
-  		^ MIMEDocument contentType: type content: aStream contents url: url].
- 	aStream = 'server aborted early' ifTrue: [ ^aStream ].
- 	].
- 
- {'HTTPSocket class>>httpGetDocument:args:accept:request:'. aStream. url} inspect.
- 
- 	^'some other bad thing happened!!'!

Item was removed:
- ----- Method: HTTPSocket class>>digestFor:method:url:user:password: (in category '*monticello-override') -----
- digestFor: serverText method: method url: url user: user password: password
- 	"RFC2069"
- 	| sock |
- 	sock := HTTPSocket new. "header decoder is on instance side"
- 	sock header: (serverText readStream upToAll: CrLf, CrLf).
- 	^self digestFrom: sock method: method url: url user: user password: password!

Item was removed:
- ----- Method: HTTPSocket class>>httpGet:args:user:passwd: (in category '*monticello-override') -----
- httpGet: url args: args user: user passwd: passwd
- 	| authorization result |
- 	authorization := (Base64MimeConverter mimeEncode: (user , ':' , passwd) readStream) contents.
- 	result := self 
- 		httpGet: url args: args accept: '*/*' 
- 		request: 'Authorization: Basic ' , authorization , CrLf.
- 	result isString ifFalse: [^result].
- 
- 	authorization := self digestFor: result method: 'GET' url: url user: user password: passwd.
- 	authorization ifNil: [^result].
- 	^self 
- 		httpGet: url args: args accept: '*/*' 
- 		request: 'Authorization: Digest ' , authorization , CrLf.
- !

Item was removed:
- ----- Method: HTTPSocket class>>md5Hash: (in category '*monticello-override') -----
- md5Hash: aString
- 	"Answer hash of aString as lowercase 32 digit hex String.
- 	There are several providers of MD5 hash ..."
- 	"(self md5Hash: 'user:realm:passwd') =  '007e68e539ed680c24f6d9a370f3bcb1'"
- 	| hash |
- 	hash := Smalltalk at: #CMD5Hasher ifPresent: [:cls |
- 		cls hashMessage: aString].
- 	hash ifNil: [
- 		hash := Smalltalk at: #TCryptoRandom ifPresent: [:cls |
- 			(cls basicNew md5HashMessage: aString) asInteger]].
- 	hash ifNotNil: [
- 		hash := hash hex asLowercase.
- 		(hash beginsWith: '16r') ifTrue: [hash := hash allButFirst: 3].
- 		hash := hash padded: #left to: 32 with: $0].
- 	^hash!

Item was removed:
- ----- Method: HTTPSocket class>>httpPut:to:user:passwd: (in category '*monticello-override') -----
- httpPut: contents to: url user: user passwd: passwd
- 	"Upload the contents of the stream to a file on the server"
- 
- 	| bare serverName specifiedServer port page serverAddr authorization s list header firstData length aStream command digest |
- 	Socket initializeNetwork.
-  
- 	"parse url"
- 	bare := (url asLowercase beginsWith: 'http://') 
- 		ifTrue: [url copyFrom: 8 to: url size]
- 		ifFalse: [url].
- 	serverName := bare copyUpTo: $/.
- 	specifiedServer := serverName.
- 	(serverName includes: $:) ifFalse: [ port := self defaultPort ] ifTrue: [
- 		port := (serverName copyFrom: (serverName indexOf: $:) + 1 
- 				to: serverName size) asNumber.
- 		serverName := serverName copyUpTo: $:.
- 	].
- 
- 	page := bare copyFrom: (bare indexOf: $/) to: bare size.
- 	page size = 0 ifTrue: [page := '/'].
- 	(self shouldUseProxy: serverName) ifTrue: [ 
- 		page := 'http://', serverName, ':', port printString, page.		"put back together"
- 		serverName := HTTPProxyServer.
- 		port := HTTPProxyPort].
- 
-   	"make the request"	
- 	serverAddr := NetNameResolver addressForName: serverName timeout: 20.
- 	serverAddr ifNil: [
- 		^ 'Could not resolve the server named: ', serverName].
- 
- 	authorization := ' Basic ', (Base64MimeConverter mimeEncode: (user , ':' , passwd) readStream) contents.
- [
- 	s := HTTPSocket new.
- 	s connectTo: serverAddr port: port.
- 	s waitForConnectionUntil: self standardDeadline.
- 	Transcript cr; show: url; cr.
- 	command := 
- 		'PUT ', page, ' HTTP/1.0', CrLf, 
- 		self userAgentString, CrLf,
- 		'Host: ', specifiedServer, CrLf, 
- 		'ACCEPT: */*', CrLf,
- 		HTTPProxyCredentials,
- 		'Authorization: ' , authorization , CrLf , 
- 		'Content-length: ', contents size printString, CrLf , CrLf , 
- 		contents.
- 	s sendCommand: command.
- 	"get the header of the reply"
- 	list := s getResponseUpTo: CrLf, CrLf ignoring: (String with: CR).	"list = header, CrLf, CrLf, beginningOfData"
- 	header := list at: 1.
- 	"Transcript show: page; cr; show: argsStream contents; cr; show: header; cr."
- 	firstData := list at: 3.
- 
- 	"dig out some headers"
- 	s header: header.
- 
- (authorization beginsWith: 'Digest ') not
- and: [(digest := self digestFrom: s method: 'PUT' url: url user: user password: passwd) notNil]]
- 	whileTrue: [authorization :=  'Digest ', digest].
- 
- 	length := s getHeader: 'content-length'.
- 	length ifNotNil: [ length := length asNumber ].
- 
- 	aStream := s getRestOfBuffer: firstData totalLength: length.
- 	s destroy.	"Always OK to destroy!!"
- 	^ header, aStream contents!

Item was removed:
- ----- Method: MCScriptDefinition class>>from: (in category 'as yet unclassified') -----
- from: aPackageInfo
- 	^ self script: (aPackageInfo propertyAt: self scriptSelector) contents asString packageName: aPackageInfo name!

Item was removed:
- ----- Method: HTTPSocket class>>digestFrom:method:url:user:password: (in category '*monticello-override') -----
- digestFrom: sock method: method url: url user: user password: password
- 	"RFC2069"
- 	| auth fields realm nonce uri a1 a2 response |
- 	sock responseCode = '401' ifFalse: [^nil].
- 	auth := sock getHeader: 'www-authenticate'.
- 	(auth asLowercase beginsWith: 'digest') ifFalse: [^nil].
- 
- 	fields := (((auth allButFirst: 6) findTokens: ', 	') collect: [:ea |
- 		(ea copyUpTo: $=) asLowercase -> (ea copyAfter: $=) withoutQuoting]) as: Dictionary.
- 
- 	realm := fields at: 'realm'.
- 	nonce := fields at: 'nonce'.
- 	uri := url readStream upToAll: '://'; skipTo: $/; skip: -1; upTo: $#.
- 	a1 := self md5Hash: user, ':', realm, ':', password.
- 	a2 := self md5Hash: method, ':', uri.
- 	a1 ifNil: [^nil "no MD5 support"].
- 	response := self md5Hash: a1, ':', nonce, ':', a2.
- 
- 	^String streamContents: [:digest |
- 		digest
- 			nextPutAll: 'username="', user, '"';
- 			nextPutAll: ', realm="', realm, '"';
- 			nextPutAll: ', nonce="', nonce, '"';
- 			nextPutAll: ', uri="', uri, '"';
- 			nextPutAll: ', response="', response, '"'.
- 		fields at: 'opaque' ifPresent: [:opaque |
- 			digest nextPutAll: ', opaque="', opaque, '"'].
- 	]
- !