"
 COPYRIGHT (c) 1993 by Claus Gittinger
	      All Rights Reserved

 This software is furnished under a license and may be used
 only in accordance with the terms of that license and with the
 inclusion of the above copyright notice.   This software may not
 be provided or otherwise made available to, or used by, any
 other person.  No title to or ownership of the software is
 hereby transferred.
"

"{ Package: 'stx:libview' }"

ResourcePack subclass:#ViewStyle
	instanceVariableNames:'name is3D viewGrey'
	classVariableNames:''
	poolDictionaries:''
	category:'Views-Support'
!

!ViewStyle class methodsFor:'documentation'!

copyright
"
 COPYRIGHT (c) 1993 by Claus Gittinger
	      All Rights Reserved

 This software is furnished under a license and may be used
 only in accordance with the terms of that license and with the
 inclusion of the above copyright notice.   This software may not
 be provided or otherwise made available to, or used by, any
 other person.  No title to or ownership of the software is
 hereby transferred.
"
!

documentation
"
    instances of this class keep all view-style specific information.
    The current viewStyle is kept in Views-classvariable called 'StyleSheet'
    and is instantiated with 'View defaultStyle:aStyleSymbol', which reads
    a stylesheet from a file '<aStyleSymbol>.style' (usually in the 'resources'
    directory.

    [see also:]
	View
	( Configuration & Customization :html: custom/TOP.html#VIEWSTYLE )

    [author:]
	Claus Gittinger
"
! !

!ViewStyle class methodsFor:'instance creation'!

fromFile:aFileNameArg
    "get the preferences definitions from a file"

    |aFileName prefs failed nm dir d path|

    aFileName := aFileNameArg asFilename.
    (aFileName hasSuffix:'style') ifTrue:[
        nm := aFileName withoutSuffix
    ] ifFalse:[
        nm := aFileName
    ].
    prefs := self new.
    prefs at:#name put:nm baseName. 

    "/ generic search first (allows for user to overwrite it)
    path := Smalltalk getResourceFileName:aFileName forPackage:'stx:libview'.
    path notNil ifTrue:[
        dir := path asFilename directory name
    ] ifFalse:[
        "/ then search in the classes package directory ...
        dir := Smalltalk projectDirectoryForPackage:'stx:libview'.
        dir notNil ifTrue:[
            dir := dir asFilename.
            d := dir construct:'resources'.
            (d exists and:[(d construct:aFileName) exists]) ifFalse:[
                d := dir construct:'styles'.
            ].
            (d exists and:[(d construct:aFileName) exists]) ifTrue:[
                dir := d
            ].
            dir := dir pathName.
        ].
    ].
    failed := (prefs readFromFile:aFileName directory:dir) isNil.
    prefs at:#fileReadFailed put:failed. 
    ^ prefs

    "
     ViewStyle fromFile:'motif.style'  
     ViewStyle fromFile:'normal.style' 
     ViewStyle fromFile:'iris.style'
     ViewStyle fromFile:'iris.style' asFilename
    "

    "Modified: / 10.12.1999 / 16:05:30 / cg"
! !

!ViewStyle methodsFor:'accessing'!

at:aKey
    |sCls val|

    sCls := thisContext sender receiver.
    sCls isBehavior ifFalse:[sCls := sCls class].
    (sCls isSubclassOf:SimpleView) ifTrue:[
	val := self at:(sCls name , '.' , aKey) default:nil.
	val notNil ifTrue:[^ val].
    ].
    ^ self at:aKey default:nil

    "Modified: 10.9.1995 / 10:59:38 / claus"
!

at:aKey default:default
    "translate a string; if not present, return default.
     Here, two keys are tried, iff the key is of the form 'foo.bar',
     'fooBar' is also tried.
     This has been added for a smooth migration towards names with a form of
     'classname.itemKey' in the stylesheets."

    |v i k2|

    (self includesKey:aKey) ifTrue:[
	^ (super at:aKey ifAbsent:default) value
    ].
    (i := aKey indexOf:$.) ~~ 0 ifTrue:[
	k2 := (aKey copyTo:i-1) , (aKey copyFrom:i+1) asUppercaseFirst.
	(self includesKey:k2) ifTrue:[^ super at:k2 ifAbsent:default].
    ].
    ^ default value

    "Created: / 14.10.1997 / 00:21:15 / cg"
    "Modified: / 15.9.1998 / 21:47:13 / cg"
!

colorAt:aKey
    "retrieve a color resource - also aquire a device color
     to avoid repeated color allocations later"

    ^ self deviceResourceAt:aKey default:nil 
!

colorAt:aKey default:default
    "retrieve a color resource - also aquire a device color
     to avoid repeated color allocations later"

    ^ self deviceResourceAt:aKey default:default
!

deviceResourceAt:aKey default:default
    "retrieve a resource - also aquire a device version
     for the default display, to avoid repeated allocations later"

    |aResource deviceResource device|

    device := Display.

    aResource := self at:aKey default:default.
    (aResource notNil and:[device notNil]) ifTrue:[
        deviceResource := aResource onDevice:device.
        deviceResource notNil ifTrue:[^ deviceResource].
    ].
    ^ aResource

    "Modified: / 5.9.1998 / 20:25:19 / cg"
!

doesNotUnderstand:aMessage
    ^ self at:(aMessage selector) default:nil
!

fontAt:aKey
    "retrieve a font resource - also aquire a device font
     to avoid repeated font allocations later"

    ^ self deviceResourceAt:aKey default:nil 
!

fontAt:aKey default:default
    "retrieve a font resource - also aquire a device font
     to avoid repeated font allocations later"

    ^ self deviceResourceAt:aKey default:default
!

is3D
    is3D isNil ifTrue:[
	is3D := self at:#is3D default:false.
    ].
    ^ is3D
!

name
    name isNil ifTrue:[
	name := self at:#name default:'noname'.
    ].
    ^ name
!

viewGrey
    viewGrey isNil ifTrue:[
        viewGrey := self at:#viewGrey default:nil.
    ].
    ^ viewGrey
! !

!ViewStyle methodsFor:'error handling'!

nonexistingFileRead
    "here, a non-existing stylesheet is treated as an error"

    fileReadFailed := true.
    ^ self

    "Created: 6.9.1997 / 11:40:16 / cg"
! !

!ViewStyle methodsFor:'queries'!

isWindowsStyle
    "answer true if this is a MS-Windows style.
     XXX Currently we simply check the name"

    name isNil ifTrue:[
        "read name into instance variable name (for speed)"
        self name
    ].

    ^ name == #win95 or:[name == #win98]
! !

!ViewStyle methodsFor:'special'!

newDerivedStyle
    "create and return a new style, which inherits from
     the receiver, but possibly overrides individual entries.
     This may be useful to give a single button some different
     look (in the future - read the comment in SimpleView>>viewStyle:)"

    ^ self class new
        superPack:self; 
        at:#is3D put:(self is3D);
        at:viewGrey put:(self viewGrey);
        yourself

    "
     |panel b1 b2 newStyle|

     panel := HorizontalPanelView new.
     panel add:(b1 := Button label:'oldStyle').
     panel add:(b2 := Button label:'newStyle').
     newStyle := b1 styleSheet newDerivedStyle.
     newStyle at:'button.activeBackgroundColor' put:Color blue.
     b2 styleSheet:newStyle.        

     panel open
    "
! !

!ViewStyle class methodsFor:'documentation'!

version
    ^ '$Header: /cvs/stx/stx/libview/ViewStyle.st,v 1.29 2004-09-27 08:30:08 stefan Exp $'
! !