Color and HTTP Proxy preferencesHernan Tylim htylim at yahoo.com.arTue Jan 4 11:37:17 UTC 2005
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
-------------- next part --------------
'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.
!
-------------- next part --------------
'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 ! !
-------------- next part --------------
'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 |