File: Splash.tcl

package info (click to toggle)
coccinella 0.96.20-9
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, buster, sid
  • size: 13,184 kB
  • sloc: tcl: 124,744; xml: 206; makefile: 66; sh: 62
file content (156 lines) | stat: -rw-r--r-- 5,073 bytes parent folder | download | duplicates (4)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
#  Dialogs.tcl ---
#  
#       Handles the splash screen.
#      
#  Copyright (c) 1999-2005  Mats Bengtsson
#  
#   This program is free software: you can redistribute it and/or modify
#   it under the terms of the GNU General Public License as published by
#   the Free Software Foundation, either version 3 of the License, or
#   (at your option) any later version.
#   
#   This program is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#   GNU General Public License for more details.
#   
#   You should have received a copy of the GNU General Public License
#   along with this program.  If not, see <http://www.gnu.org/licenses/>.
#  
# $Id: Splash.tcl,v 1.20 2008-04-17 15:00:32 matben Exp $
   
package provide Splash 1.0

namespace eval ::Splash:: {
    
    set text1 "Written by Mats Bengtsson (C) 1999-2008"
    set text2 "Distributed under the Gnu General Public License"
	
    # Use option database for customization.
    option add *Splash.image               splash-default   widgetDefault
    option add *Splash.showMinor           1                widgetDefault
    option add *Splash.showCopyright       0                widgetDefault
    option add *Splash.minorX              362              widgetDefault
    option add *Splash.minorY              219              widgetDefault
    option add *Splash.minorColor          "#ef2910"        widgetDefault
    option add *Splash.copyrightX          ""               widgetDefault
    option add *Splash.copyrightY          ""               widgetDefault
    option add *Splash.copyrightText1      $text1           widgetDefault
    option add *Splash.copyrightText2      $text2           widgetDefault

    # Name of variable for message displat.
    variable startMsg ""
    variable topwin ""
    variable splashCount 0
}

array set wDlgs {
    splash          .splash
}


# Splash::SplashScreen --
#
#       Shows the splash screen.
#       
# Arguments:
#       w      the toplevel window.
#       
# Results:
#       none

proc ::Splash::SplashScreen {} {
    global  this prefs wDlgs this
    variable topwin
    variable canwin
    variable startMsg
    
    
    set w $wDlgs(splash)
    set topwin $w
    if {[winfo exists $w]} {
	return
    }
    toplevel $w -class Splash
    if {[tk windowingsystem] eq "aqua"} {
	::tk::unsupported::MacWindowStyle style $w floating {closeBox}
    } else {
	if {([tk windowingsystem] eq "win32") && ([info tclversion] >= 8.5)} {
	    wm attributes $w -toolwindow 1
	}
	wm transient $w
    }
    wm title $w [mc "About %s" $prefs(theAppName)]
    wm resizable $w 0 0
    set screenW [winfo vrootwidth .]
    set screenH [winfo vrootheight .]

    wm geometry $w +[expr {($screenW - 450)/2}]+[expr {($screenH - 300)/2}]
    set showMinor     [option get $w showMinor {}]
    set showCopyright [option get $w showCopyright {}]
    set copyrightX    [option get $w copyrightX {}]
    set copyrightY    [option get $w copyrightY {}]
    
    # If image not already there, get it.
    set tail [option get $w image {}]
    set imsplash [::Theme::FindIcon splash/$tail]
    set imHeight [image height $imsplash]
    set imWidth [image width $imsplash]
    if {$copyrightX eq ""} {
	set copyrightX 50
    }
    if {$copyrightY eq ""} {
	set copyrightY [expr {$imHeight - 70}]
    }
    foreach {r g b} [$imsplash get 50 [expr {$imHeight - 20}]] break
    if {[expr {$r + $g + $b}] > [expr {2*255}]} {
	set textcol black
    } else {
	set textcol white
    }
    set canwin $w.can
    canvas $w.can -width $imWidth -height $imHeight -bd 0 -highlightthickness 0
    $w.can create image 0 0 -anchor nw -image $imsplash
    $w.can create text 50 [expr {$imHeight - 20}] -anchor nw -tags tsplash  \
      -font CociTinyFont -text $startMsg -fill $textcol
    
    # Print patch level for dev versions.
    if {$this(vers,minorRelease) && $showMinor} {
	set x [option get $w minorX {}]
	set y [option get $w minorY {}]
	set c [option get $w minorColor {}]
	$w.can create text $x $y -anchor sw  \
	  -font {Helvetica -18} -text ".$this(vers,minorRelease)" -fill $c
    }
    if {$showCopyright} {
	set text1 [option get $w copyrightText1 {}]
	set text2 [option get $w copyrightText2 {}]
	$w.can create text $copyrightX $copyrightY -anchor nw \
	  -font CociSmallFont -text $text1 -fill $textcol
	$w.can create text $copyrightX [expr {$copyrightY - 15}] -anchor nw \
	  -font CociSmallFont -text $text2 -fill $textcol
    }
    
    pack $w.can
    bind $w <Return> [list destroy $w]
    bind $w <Button-1> [list destroy $w]
}

proc ::Splash::SetMsg {msg} {
    global this
    variable topwin
    variable canwin
    variable startMsg
    variable splashCount
    
    set startMsg $msg
    incr splashCount
    
    # Update needed to force display (bad?).
    if {[winfo exists $topwin]} {
	$canwin itemconfigure tsplash -text $startMsg
	update
    }
}

#-------------------------------------------------------------------------------