Color and HTTP Proxy preferencesstéphane ducasse ducasse at iam.unibe.chTue Jan 4 16:56:11 UTC 2005
thanks hernan as soon as 3.8 is out, I will add that to 3.9. Please remind me if I forget. My life is getting a bit crazy right now. Stef On 4 janv. 05, at 12:37, Hernan Tylim wrote: > Hi, > I just wanted to advertise that I added to PreferenceBrowser > support for Windows Colors and HTTP Proxy settings. The required > refactoring for them are waiting on Mantis. If you are interested, > please review them and ask for their inclusion on 3.9a. > > There are 3 .cs > > The Window Color refactorings: > http://bugs.impara.de/view.php?id=634 > ( WindowColorPrefs-hpt.2.cs ) > > A 2 methods .cs that adds numeric preferences support to the base > image to the already present text, color, and boolean preferences : > http://bugs.impara.de/view.php?id=646 > ( NumericPrefs-hpt.1.cs ) > > HTTPSocket refactoring to use Preferences instead of a class variables > to store the HTTP Proxy Settings: > http://bugs.impara.de/view.php?id=648 > ( HTTPProxyPrefs-hpt.1.cs ) > > Regards, > Hernán > 'From Squeak3.9alpha of ''2 November 2004'' [latest update: #6485] on > 10 December 2004 at 11:21:58 pm'! > "Change Set: HTTPProxyPrefs-hpt > Date: 10 December 2004 > Author: Hernan Tylim > > This changeset is part of the Preferences Refactorings. The idea is to > start moving all the user preferences and settings that are currently > dispersed on the image to the Preferences class to be Preference > instances. For more info look into the PrefViews-hpt preamble. > > The changes present on this .cs are simple refactorings on HTTPSocket > to make it use getter and setter to access to the http proxy info, > which will be stored on Preferences instead of class variables."! > > OldSimpleClientSocket subclass: #HTTPSocket > instanceVariableNames: 'headerTokens headers responseCode ' > classVariableNames: 'HTTPBlabEmail HTTPPort HTTPProxyCredentials > HTTPProxyExceptions HTTPProxyPort HTTPProxyServer LogToTranscript > ParamDelimiters ' > poolDictionaries: '' > category: 'Network-Protocols'! > > !HTTPSocket class methodsFor: 'class initialization' stamp: 'hpt > 12/9/2004 22:55'! > initialize > "HTTPSocket initialize" > > ParamDelimiters := ' ', CrLf. > HTTPPort := 80. > self httpProxyServer: nil. > HTTPBlabEmail := ''. " 'From: somebody at no.where', CrLf " > HTTPProxyCredentials := ''. > > ExternalSettings registerClient: self! ! > > !HTTPSocket class methodsFor: 'get the page' stamp: 'hpt 12/9/2004 > 22:53'! > httpPostMultipart: url args: argsDict accept: mimeType request: > requestString > " do multipart/form-data encoding rather than x-www-urlencoded " > " by Bolot Kerimbaev, 1998 " > " this version is a memory hog: puts the whole file in memory " > "bolot 12/14/2000 18:28 -- minor fixes to make it comply with RFC > 1867" > > | serverName serverAddr s header length bare page list firstData > aStream port argsStream specifiedServer type newUrl mimeBorder > fieldValue | > 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 := self httpProxyServer. > port := self httpProxyPort]. > > mimeBorder := '----squeak-georgia-tech-', Time millisecondClockValue > printString, '-csl-cool-stuff-----'. > "encode the arguments dictionary" > argsStream := WriteStream on: String new. > argsDict associationsDo: [:assoc | > assoc value do: [ :value | > "print the boundary" > argsStream nextPutAll: '--', mimeBorder, CrLf. > " check if it's a non-text field " > argsStream nextPutAll: 'Content-disposition: multipart/form-data; > name="', assoc key, '"'. > (value isKindOf: MIMEDocument) > ifFalse: [fieldValue := value] > ifTrue: [argsStream nextPutAll: ' filename="', value url > pathForFile, '"', CrLf, 'Content-Type: ', value contentType. > fieldValue := (value content > ifNil: [(FileStream fileNamed: value url pathForFile) > contentsOfEntireFile] > ifNotNil: [value content]) asString]. > " Transcript show: 'field=', key, '; value=', fieldValue; cr. " > argsStream nextPutAll: CrLf, CrLf, fieldValue, CrLf. > ]]. > argsStream nextPutAll: '--', mimeBorder, '--'. > > "make the request" > serverAddr := NetNameResolver addressForName: serverName timeout: 20. > serverAddr ifNil: [ > ^ 'Could not resolve the server named: ', serverName]. > > > s := HTTPSocket new. > s connectTo: serverAddr port: port. > s waitForConnectionUntil: self standardDeadline. > Transcript cr; show: serverName, ':', port asString; cr. > s sendCommand: 'POST ', page, ' HTTP/1.1', CrLf, > (mimeType ifNotNil: ['ACCEPT: ', mimeType, CrLf] ifNil: ['']), > 'ACCEPT: text/html', CrLf, "Always accept plain text" > HTTPProxyCredentials, > HTTPBlabEmail, "may be empty" > requestString, "extra user request. Authorization" > self userAgentString, CrLf, > 'Content-type: multipart/form-data; boundary=', mimeBorder, CrLf, > 'Content-length: ', argsStream contents size printString, CrLf, > 'Host: ', specifiedServer, CrLf. "blank line automatically added" > > s sendCommand: argsStream contents. > > "get the header of the reply" > list := s getResponseUpTo: CrLf, CrLf. "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. > length := s getHeader: 'content-length'. > length ifNotNil: [ length := length asNumber ]. > type := s getHeader: 'content-type'. > s responseCode first = $3 ifTrue: [ > "redirected - don't re-post automatically" > "for now, just do a GET, without discriminating between 301/302 > codes" > newUrl := s getHeader: 'location'. > newUrl ifNotNil: [ > (newUrl beginsWith: 'http://') > ifFalse: [ > (newUrl beginsWith: '/') > ifTrue: [newUrl := (bare copyUpTo: $/), newUrl] > ifFalse: [newUrl := url, newUrl. self flag: #todo > "should do a relative URL"] > ]. > Transcript show: 'redirecting to: ', newUrl; cr. > s destroy. > ^self httpGetDocument: newUrl > "for some codes, may do: > ^self httpPostMultipart: newUrl args: argsDict accept: mimeType > request: requestString"] ]. > > aStream := s getRestOfBuffer: firstData totalLength: length. > s responseCode = '401' ifTrue: [^ header, aStream contents]. > s destroy. "Always OK to destroy!!" > > ^ MIMEDocument contentType: type content: aStream contents url: url! > ! > > !HTTPSocket class methodsFor: 'get the page' stamp: 'hpt 12/9/2004 > 22:53'! > httpPostToSuperSwiki: url args: argsDict accept: mimeType request: > requestString > > | serverName serverAddr s header length bare page list firstData > aStream port specifiedServer type mimeBorder contentsData | > > 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: $/ ifAbsent: [^'error']) to: > bare size. > page size = 0 ifTrue: [page := '/']. > (self shouldUseProxy: serverName) ifTrue: [ > page := 'http://', serverName, ':', port printString, page. "put > back together" > serverName := self httpProxyServer. > port := self httpProxyPort]. > > mimeBorder := '---------SuperSwiki',Time millisecondClockValue > printString,'-----'. > contentsData := String streamContents: [ :strm | > strm nextPutAll: mimeBorder, CrLf. > argsDict associationsDo: [:assoc | > assoc value do: [ :value | > strm > nextPutAll: 'Content-disposition: form-data; name="', assoc key, > '"'; > nextPutAll: CrLf; > nextPutAll: CrLf; > nextPutAll: value; > nextPutAll: CrLf; > nextPutAll: CrLf; > nextPutAll: mimeBorder; > nextPutAll: CrLf. > ] > ]. > ]. > > "make the request" > serverAddr := NetNameResolver addressForName: serverName timeout: 20. > serverAddr ifNil: [ > ^ 'Could not resolve the server named: ', serverName]. > > s := HTTPSocket new. > s connectTo: serverAddr port: port. > s waitForConnectionUntil: self standardDeadline. > s sendCommand: 'POST ', page, ' HTTP/1.1', CrLf, > (mimeType ifNotNil: ['ACCEPT: ', mimeType, CrLf] ifNil: ['']), > 'ACCEPT: text/html', CrLf, "Always accept plain text" > HTTPProxyCredentials, > HTTPBlabEmail, "may be empty" > requestString, "extra user request. Authorization" > self userAgentString, CrLf, > 'Content-type: multipart/form-data; boundary=', mimeBorder, CrLf, > 'Content-length: ', contentsData size printString, CrLf, > 'Host: ', specifiedServer, CrLf. "blank line automatically added" > > s sendCommand: contentsData. > > list := s getResponseUpTo: CrLf, CrLf. "list = header, CrLf, CrLf, > beginningOfData" > header := list at: 1. > firstData := list at: 3. > > header isEmpty ifTrue: [ > s destroy. > ^'no response' > ]. > s header: header. > length := s getHeader: 'content-length'. > length ifNotNil: [ length := length asNumber ]. > type := s getHeader: 'content-type'. > aStream := s getRestOfBuffer: firstData totalLength: length. > s responseCode = '401' ifTrue: [^ header, aStream contents]. > s destroy. "Always OK to destroy!!" > > ^ MIMEDocument contentType: type content: aStream contents url: url! > ! > > !HTTPSocket class methodsFor: 'get the page' stamp: 'hpt 12/9/2004 > 22:54'! > 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 | > 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 := self httpProxyServer. > port := self httpProxyPort]. > > "make the request" > serverAddr := NetNameResolver addressForName: serverName timeout: 20. > serverAddr ifNil: [ > ^ 'Could not resolve the server named: ', serverName]. > > authorization := (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: Basic ' , 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. > 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! ! > > !HTTPSocket class methodsFor: 'proxy settings' stamp: 'hpt 12/10/2004 > 23:18'! > addHTTPProxyPreferences > " This method will add to Squeak the HTTP Proxy preferences. " > Preferences addTextPreference: #httpProxyServer category: #'http > proxy' default: '' balloonHelp: 'HTTP Proxy Server. Leave blank if > you don''t want to use a Proxy'. > Preferences addNumericPreference: #httpProxyPort category: #'http > proxy' default: 80 balloonHelp: 'HTTP Proxy Port'.! ! > > !HTTPSocket class methodsFor: 'proxy settings' stamp: 'hpt 12/10/2004 > 22:40'! > checkHTTPProxyPreferences > Preferences preferenceAt: #httpProxyPort ifAbsent: [self > addHTTPProxyPreferences]. > Preferences preferenceAt: #httpProxyServer ifAbsent: [self > addHTTPProxyPreferences].! ! > > !HTTPSocket class methodsFor: 'proxy settings' stamp: 'hpt 12/9/2004 > 22:51'! > fetchExternalSettingsIn: aDirectory > "Scan for server configuration files" > "HTTPSocket fetchExternalSettingsIn: (FileDirectory default > directoryNamed: 'prefs')" > > | stream entries | > (aDirectory fileExists: self proxySettingsFileName) > ifFalse: [^self]. > stream := aDirectory readOnlyFileNamed: self proxySettingsFileName. > stream > ifNotNil: [ > [entries := ExternalSettings parseServerEntryArgsFrom: stream] > ensure: [stream close]]. > > entries ifNil: [^self]. > > self httpProxyServer: (entries at: 'host' ifAbsent: [nil]). > self httpProxyPort: ((entries at: 'port' ifAbsent: ['80']) asInteger > ifNil: [self defaultPort]). > HTTPSocket addProxyException: (entries at: 'exception' ifAbsent: > [nil])! ! > > !HTTPSocket class methodsFor: 'proxy settings' stamp: 'hpt 12/10/2004 > 22:39'! > httpProxyPort > "answer the httpProxyPort" > self checkHTTPProxyPreferences. > ^Preferences valueOfPreference: #httpProxyPort.! ! > > !HTTPSocket class methodsFor: 'proxy settings' stamp: 'hpt 12/10/2004 > 23:20'! > httpProxyPort: aPortNumber > self checkHTTPProxyPreferences. > Preferences setPreference: #httpProxyPort toValue: aPortNumber.! ! > > !HTTPSocket class methodsFor: 'proxy settings' stamp: 'hpt 12/10/2004 > 23:19'! > httpProxyServer > "answer the httpProxyServer. Take into account that as a Preference > the Server might appear as an empty string but HTTPSocket expect it to > be nil" > self checkHTTPProxyPreferences. > ^Preferences valueOfPreference: #httpProxyServer. > ! ! > > !HTTPSocket class methodsFor: 'proxy settings' stamp: 'hpt 12/10/2004 > 23:17'! > httpProxyServer: aStringOrNil > | serverName | > self checkHTTPProxyPreferences. > serverName _ aStringOrNil > ifNil: [''] > ifNotNil: [aStringOrNil withBlanksTrimmed ]. > Preferences setPreference: #httpProxyServer toValue: serverName! ! > > !HTTPSocket class methodsFor: 'proxy settings' stamp: 'hpt 12/9/2004 > 22:55'! > stopUsingProxyServer > "Stop directing HTTP request through a proxy server." > > self httpProxyServer: nil. > self httpProxyPort: 80. > HTTPProxyCredentials := '' > ! ! > > !HTTPSocket class methodsFor: 'proxy settings' stamp: 'hpt 12/9/2004 > 22:57'! > useProxyServerNamed: proxyServerName port: portNum > "Direct all HTTP requests to the HTTP proxy server with the given > name and port number." > > proxyServerName ifNil: [ "clear proxy settings" > self httpProxyServer: nil. > self httpProxyPort: 80. > ^ self]. > > proxyServerName class == String > ifFalse: [self error: 'Server name must be a String or nil']. > self httpProxyServer: proxyServerName. > > self httpProxyPort: portNum. > self httpProxyPort class == String ifTrue: [HTTPPort := portNum > asNumber]. > self httpProxyPort ifNil: [self httpProxyPort: self defaultPort].! ! > > !HTTPSocket class methodsFor: 'utilities' stamp: 'hpt 12/9/2004 22:54'! > initHTTPSocket: httpUrl wait: timeout ifError: aBlock > "Retrieve the server and port information from the URL, match it to > the proxy settings and open a http socket for the request." > > | serverName port serverAddr s | > Socket initializeNetwork. > > serverName := httpUrl authority. > port := httpUrl port ifNil: [self defaultPort]. > > (self shouldUseProxy: serverName) ifTrue: [ > serverName := self httpProxyServer. > port := self httpProxyPort]. > > "make the request" > serverAddr := NetNameResolver addressForName: serverName timeout: 20. > serverAddr ifNil: [ > aBlock value: 'Error: Could not resolve the server named: ', > serverName]. > > s := HTTPSocket new. > s connectTo: serverAddr port: port. > (s waitForConnectionUntil: timeout) ifFalse: [ > Socket deadServer: httpUrl authority. > s destroy. > ^aBlock value: 'Error: Server ',httpUrl authority,' is not > responding']. > ^s > ! ! > > !HTTPSocket class methodsFor: 'utilities' stamp: 'hpt 12/10/2004 > 23:21'! > shouldUseProxy: serverName > "Retrieve the server and port information from the URL, match it to > the proxy settings and open a http socket for the request." > > self httpProxyServer ifNotEmpty: [ > self httpProxyExceptions > detect: [:domainName | domainName match: serverName] > ifNone: [^true]]. > ^false > ! ! > > !HTTPSocket class methodsFor: '*monticello-override' stamp: 'hpt > 12/9/2004 22:52'! > 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 := self httpProxyServer. > connectToPort := self 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!!'! ! > > HTTPSocket initialize! > OldSimpleClientSocket subclass: #HTTPSocket > instanceVariableNames: 'headerTokens headers responseCode' > classVariableNames: 'HTTPBlabEmail HTTPPort HTTPProxyCredentials > HTTPProxyExceptions LogToTranscript ParamDelimiters' > poolDictionaries: '' > category: 'Network-Protocols'! > "Postscript: > This method will add to Preferences the HTTPProxy preferences." > HTTPSocket addHTTPProxyPreferences. > ! > > 'From Squeak3.9alpha of ''2 November 2004'' [latest update: #6485] on > 10 December 2004 at 11:50:47 pm'! > "Change Set: NumericPrefs-hpt > Date: 10 December 2004 > Author: Hernan Tylim > > For some reason when I introduced the new 'types' of preferences and I > created methods for adding text, boolean, font and color preferences, > it didn't occur to me to add also methods for adding numeric > preferences. This cs does just that. Take note that it does not > produce any big change. Just add three very convenient methods."! > > > !PreferenceViewRegistry class methodsFor: 'instance creation' stamp: > 'hpt 12/9/2004 22:16'! > ofNumericPreferences > ^(self registryOf: #numericPreferences) > viewOrder: 3; > yourself.! ! > > > !Preferences class methodsFor: 'add preferences' stamp: 'hpt 12/9/2004 > 22:15'! > addNumericPreference: prefSymbol categories: categoryList default: > defaultValue balloonHelp: helpString > "Add an item repreesenting the given preference symbol to the system. > " > > self addPreference: prefSymbol categories: categoryList default: > defaultValue balloonHelp: helpString projectLocal: false > changeInformee: nil changeSelector: nil viewRegistry: > PreferenceViewRegistry ofNumericPreferences ! ! > > !Preferences class methodsFor: 'add preferences' stamp: 'hpt 12/9/2004 > 22:15'! > addNumericPreference: prefSymbol category: categorySymbol default: > defaultValue balloonHelp: helpString > "Add an item repreesenting the given preference symbol to the system." > > self addPreference: prefSymbol categories: {categorySymbol} default: > defaultValue balloonHelp: helpString projectLocal: false > changeInformee: nil changeSelector: nil viewRegistry: > PreferenceViewRegistry ofNumericPreferences ! ! > > 'From Squeak3.9alpha of ''2 November 2004'' [latest update: #6485] on > 9 December 2004 at 9:27:58 pm'! > "Change Set: WindowColorPrefs-hpt > Date: 8 December 2004 > Author: Hernan Tylim > > This changeset is part of the big Preferences refactoring that started > on 3.8 with PrefViews-hpt, and PrefViewsRegistry-hpt. > On these previous changesets we prepared Squeak to use Preference > instances to store any type of preferences, not only boolean. This > changeset will move where squeak stores its window colors preference > to regular Preference instances, so they will be editable from the new > PreferenceBrowser."! > > > !Preferences class methodsFor: 'add preferences' stamp: 'hpt 12/8/2004 > 23:22'! > addPreference: aName categories: categoryList default: aValue > balloonHelp: helpString projectLocal: localBoolean changeInformee: > informeeSymbol changeSelector: aChangeSelector viewRegistry: > aViewRegistry > "Add or replace a preference as indicated. Reuses the preexisting > Preference object for this symbol, if there is one, so that UI > artifacts that interact with it will remain valid." > > | aPreference aPrefSymbol | > aPrefSymbol _ aName asSymbol. > aPreference := DictionaryOfPreferences at: aPrefSymbol ifAbsent: > [Preference new]. > aPreference name: aPrefSymbol defaultValue: aValue helpString: > helpString localToProject: localBoolean categoryList: categoryList > changeInformee: informeeSymbol changeSelector: aChangeSelector > viewRegistry: aViewRegistry. > DictionaryOfPreferences at: aPrefSymbol put: aPreference. > self compileAccessMethodForPreference: aPreference! ! > > !Preferences class methodsFor: 'window colors' stamp: 'hpt 12/6/2004 > 22:49'! > checkForWindowColors > (self allPreferenceObjects noneSatisfy: [:aPref | aPref name > endsWith: 'WindowColor']) > ifTrue: [self installBrightWindowColors].! ! > > !Preferences class methodsFor: 'window colors' stamp: 'hpt 12/8/2004 > 19:34'! > darkenStandardWindowPreferences > "Make all window-color preferences one shade darker" > > (self allPreferenceObjects > select: [:aPref | (aPref name endsWith: 'WindowColor') > and: [aPref preferenceValue isColor]]) > do: [:aPref | aPref preferenceValue: aPref preferenceValue darker]. > > "Preferences darkenStandardWindowPreferences" > ! ! > > !Preferences class methodsFor: 'window colors' stamp: 'hpt 12/8/2004 > 23:17'! > installMissingWindowColors > "Install the factory-provided bright window colors -- a one-time > bootstrap" > "Preferences installMissingWindowColors" > | color | > self windowColorTable do: > [:aColorSpec | > color := (Color colorFrom: aColorSpec brightColor). > self setWindowColorFor: aColorSpec classSymbol to: color]! ! > > !Preferences class methodsFor: 'window colors' stamp: 'hpt 12/8/2004 > 20:10'! > installWindowColorsVia: colorSpecBlock > "Install windows colors using colorSpecBlock to deliver the color > source for each element; the block is handed a WindowColorSpec object" > "Preferences installBrightWindowColors" > | color | > self windowColorTable do: > [:aColorSpec | > color := (Color colorFrom: (colorSpecBlock value: aColorSpec)). > self setWindowColorFor: aColorSpec classSymbol to: color] > ! ! > > !Preferences class methodsFor: 'window colors' stamp: 'hpt 12/8/2004 > 19:35'! > lightenStandardWindowPreferences > "Make all window-color preferences one shade darker" > > (self allPreferenceObjects > select: [:aPref | (aPref name endsWith: 'WindowColor') > and: [aPref preferenceValue isColor]]) > do: [:aPref | aPref preferenceValue: aPref preferenceValue lighter]. > > "Preferences lightenStandardWindowPreferences" > ! ! > > !Preferences class methodsFor: 'window colors' stamp: 'hpt 12/8/2004 > 23:29'! > setWindowColorFor: modelSymbol to: incomingColor > | aColor aPrefSymbol aColorSpec | > aColorSpec := self windowColorTable > detect: [:ea | ea classSymbol = modelSymbol] ifNone: [^self]. > aColor := incomingColor asNontranslucentColor. > (aColor = ColorPickerMorph perniciousBorderColor or: [aColor = Color > black]) > ifTrue: [^ self]. > aPrefSymbol _ self windowColorPreferenceForClassNamed: aColorSpec > classSymbol. > self > addPreference: aPrefSymbol > categories: { #'window colors' } > default: aColor > balloonHelp: aColorSpec helpMessage translated > projectLocal: false > changeInformee: nil > changeSelector: nil > viewRegistry: (PreferenceViewRegistry registryOf: > #windowColorPreferences)! ! > > !Preferences class methodsFor: 'window colors' stamp: 'hpt 12/8/2004 > 23:28'! > windowColorFor: aModelClassName > | classToCheck prefSymbol | > self checkForWindowColors. > classToCheck := Smalltalk at: aModelClassName. > prefSymbol := self windowColorPreferenceForClassNamed: classToCheck > name. > [(classToCheck ~~ Object) and: [(self preferenceAt: prefSymbol) > isNil]] > whileTrue: > [classToCheck := classToCheck superclass. > prefSymbol := self windowColorPreferenceForClassNamed: > classToCheck name]. > ^self valueOfPreference: prefSymbol ifAbsent: [Color white].! ! > > !Preferences class methodsFor: 'window colors' stamp: 'hpt 12/9/2004 > 21:25'! > windowColorPreferenceForClassNamed: aClassName > | aColorSpec wording | > aColorSpec := self windowColorTable detect: [:ea | ea classSymbol = > aClassName] ifNone: []. > wording := aColorSpec ifNil: [aClassName] ifNotNil: [aColorSpec > wording]. > ^(wording, 'WindowColor') asLegalSelector asSymbol.! ! > > "Postscript: > This call to #installMissingWindowColors will store the Bright Window > Colors as Preferences. After doing this they will be editable not only > from the legacy WindowColor panel, but from the new PreferenceBrowser" > Preferences installMissingWindowColors.! > >
More information about the Squeak-dev mailing list |