line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Tk::GtkSettings; |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
=head1 NAME |
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
Tk::GtkSettings - Give Tk applications the looks of Gtk applications |
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
=cut |
8
|
|
|
|
|
|
|
|
9
|
1
|
|
|
1
|
|
72632
|
use strict; |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
28
|
|
10
|
1
|
|
|
1
|
|
5
|
use warnings; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
22
|
|
11
|
1
|
|
|
1
|
|
5
|
use File::Basename; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
135
|
|
12
|
|
|
|
|
|
|
our $VERSION = '0.04'; |
13
|
|
|
|
|
|
|
|
14
|
1
|
|
|
1
|
|
10
|
use Exporter; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
3760
|
|
15
|
|
|
|
|
|
|
our @ISA = qw(Exporter); |
16
|
|
|
|
|
|
|
our %EXPORT_TAGS = ( 'all' => [ qw( |
17
|
|
|
|
|
|
|
$delete_output |
18
|
|
|
|
|
|
|
$gtkpath |
19
|
|
|
|
|
|
|
$verbose |
20
|
|
|
|
|
|
|
$out_file |
21
|
|
|
|
|
|
|
alterColor |
22
|
|
|
|
|
|
|
appName |
23
|
|
|
|
|
|
|
convertColorCode |
24
|
|
|
|
|
|
|
export2file |
25
|
|
|
|
|
|
|
export2Xdefaults |
26
|
|
|
|
|
|
|
export2xrdb |
27
|
|
|
|
|
|
|
export2Xresources |
28
|
|
|
|
|
|
|
groupAdd |
29
|
|
|
|
|
|
|
groupAll |
30
|
|
|
|
|
|
|
groupDelete |
31
|
|
|
|
|
|
|
groupExists |
32
|
|
|
|
|
|
|
groupMembers |
33
|
|
|
|
|
|
|
groupMembersAdd |
34
|
|
|
|
|
|
|
groupMembersReplace |
35
|
|
|
|
|
|
|
groupOption |
36
|
|
|
|
|
|
|
groupOptionAll |
37
|
|
|
|
|
|
|
groupOptionDelete |
38
|
|
|
|
|
|
|
gtkKey |
39
|
|
|
|
|
|
|
gtkKeyAll |
40
|
|
|
|
|
|
|
gtkKeyDelete |
41
|
|
|
|
|
|
|
hex2rgb |
42
|
|
|
|
|
|
|
hexstring |
43
|
|
|
|
|
|
|
initDefaults |
44
|
|
|
|
|
|
|
loadGtkInfo |
45
|
|
|
|
|
|
|
platformPermitted |
46
|
|
|
|
|
|
|
removefromFile |
47
|
|
|
|
|
|
|
removeFromXdefaults |
48
|
|
|
|
|
|
|
removeFromXresources |
49
|
|
|
|
|
|
|
removeFromxrdb |
50
|
|
|
|
|
|
|
resetAll |
51
|
|
|
|
|
|
|
rgb2hex |
52
|
|
|
|
|
|
|
) ] ); |
53
|
|
|
|
|
|
|
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} }); |
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
our @EXPORT = qw( |
56
|
|
|
|
|
|
|
applyGtkSettings |
57
|
|
|
|
|
|
|
); |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
sub appName; |
60
|
|
|
|
|
|
|
sub export2xrdb; |
61
|
|
|
|
|
|
|
sub generateOutput; |
62
|
|
|
|
|
|
|
sub initDefaults; |
63
|
|
|
|
|
|
|
sub loadGtkInfo; |
64
|
|
|
|
|
|
|
sub platformPermitted; |
65
|
|
|
|
|
|
|
sub resetAll; |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
our $delete_output = 1; |
68
|
|
|
|
|
|
|
our $gtkpath; |
69
|
|
|
|
|
|
|
our $verbose = 0; |
70
|
|
|
|
|
|
|
our $out_file; |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
if (platformPermitted) { |
73
|
|
|
|
|
|
|
$gtkpath = $ENV{HOME} . "/.config/gtk-3.0/"; |
74
|
|
|
|
|
|
|
$out_file = $ENV{HOME} . "/.tkgtksettings"; |
75
|
|
|
|
|
|
|
} |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
my $no_gtk = 0; |
78
|
|
|
|
|
|
|
my %gtksettings = (); |
79
|
|
|
|
|
|
|
my %groups = (main => [[''], {}]); |
80
|
|
|
|
|
|
|
my $app_name = basename($0); |
81
|
|
|
|
|
|
|
my $marker; |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
my @basegtkeys = qw( |
84
|
|
|
|
|
|
|
theme_fg_color |
85
|
|
|
|
|
|
|
theme_bg_color |
86
|
|
|
|
|
|
|
theme_text_color |
87
|
|
|
|
|
|
|
theme_base_color |
88
|
|
|
|
|
|
|
theme_view_hover_decoration_color |
89
|
|
|
|
|
|
|
theme_hovering_selected_bg_color |
90
|
|
|
|
|
|
|
theme_selected_bg_color |
91
|
|
|
|
|
|
|
theme_selected_fg_color |
92
|
|
|
|
|
|
|
theme_view_active_decoration_color |
93
|
|
|
|
|
|
|
theme_button_background_normal |
94
|
|
|
|
|
|
|
theme_button_decoration_hover |
95
|
|
|
|
|
|
|
theme_button_decoration_focus |
96
|
|
|
|
|
|
|
theme_button_foreground_normal |
97
|
|
|
|
|
|
|
theme_button_foreground_active |
98
|
|
|
|
|
|
|
borders |
99
|
|
|
|
|
|
|
warning_color |
100
|
|
|
|
|
|
|
success_color |
101
|
|
|
|
|
|
|
error_color |
102
|
|
|
|
|
|
|
theme_unfocused_fg_color |
103
|
|
|
|
|
|
|
theme_unfocused_text_color |
104
|
|
|
|
|
|
|
theme_unfocused_bg_color |
105
|
|
|
|
|
|
|
theme_unfocused_base_color |
106
|
|
|
|
|
|
|
theme_unfocused_selected_bg_color_alt |
107
|
|
|
|
|
|
|
theme_unfocused_selected_bg_color |
108
|
|
|
|
|
|
|
theme_unfocused_selected_fg_color |
109
|
|
|
|
|
|
|
theme_button_background_backdrop |
110
|
|
|
|
|
|
|
theme_button_decoration_hover_backdrop |
111
|
|
|
|
|
|
|
theme_button_decoration_focus_backdrop |
112
|
|
|
|
|
|
|
theme_button_foreground_backdrop |
113
|
|
|
|
|
|
|
theme_button_foreground_active_backdrop |
114
|
|
|
|
|
|
|
unfocused_borders |
115
|
|
|
|
|
|
|
warning_color_backdrop |
116
|
|
|
|
|
|
|
success_color_backdrop |
117
|
|
|
|
|
|
|
error_color_backdrop |
118
|
|
|
|
|
|
|
insensitive_fg_color |
119
|
|
|
|
|
|
|
insensitive_base_fg_color |
120
|
|
|
|
|
|
|
insensitive_bg_color |
121
|
|
|
|
|
|
|
insensitive_base_color |
122
|
|
|
|
|
|
|
insensitive_selected_bg_color |
123
|
|
|
|
|
|
|
insensitive_selected_fg_color |
124
|
|
|
|
|
|
|
theme_button_background_insensitive |
125
|
|
|
|
|
|
|
theme_button_decoration_hover_insensitive |
126
|
|
|
|
|
|
|
theme_button_decoration_focus_insensitive |
127
|
|
|
|
|
|
|
theme_button_foreground_insensitive |
128
|
|
|
|
|
|
|
theme_button_foreground_active_insensitive |
129
|
|
|
|
|
|
|
insensitive_borders |
130
|
|
|
|
|
|
|
warning_color_insensitive |
131
|
|
|
|
|
|
|
success_color_insensitive |
132
|
|
|
|
|
|
|
error_color_insensitive |
133
|
|
|
|
|
|
|
insensitive_unfocused_fg_color |
134
|
|
|
|
|
|
|
theme_unfocused_view_text_color |
135
|
|
|
|
|
|
|
insensitive_unfocused_bg_color |
136
|
|
|
|
|
|
|
theme_unfocused_view_bg_color |
137
|
|
|
|
|
|
|
insensitive_unfocused_selected_bg_color |
138
|
|
|
|
|
|
|
insensitive_unfocused_selected_fg_color |
139
|
|
|
|
|
|
|
theme_button_background_backdrop_insensitive |
140
|
|
|
|
|
|
|
theme_button_decoration_hover_backdrop_insensitive |
141
|
|
|
|
|
|
|
theme_button_decoration_focus_backdrop_insensitive |
142
|
|
|
|
|
|
|
theme_button_foreground_backdrop_insensitive |
143
|
|
|
|
|
|
|
theme_button_foreground_active_backdrop_insensitive |
144
|
|
|
|
|
|
|
unfocused_insensitive_borders |
145
|
|
|
|
|
|
|
warning_color_insensitive_backdrop |
146
|
|
|
|
|
|
|
success_color_insensitive_backdrop |
147
|
|
|
|
|
|
|
error_color_insensitive_backdrop |
148
|
|
|
|
|
|
|
link_color |
149
|
|
|
|
|
|
|
link_visited_color |
150
|
|
|
|
|
|
|
tooltip_text |
151
|
|
|
|
|
|
|
tooltip_background |
152
|
|
|
|
|
|
|
tooltip_border |
153
|
|
|
|
|
|
|
content_view_bg |
154
|
|
|
|
|
|
|
); |
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
my @contentwidgets = qw( |
157
|
|
|
|
|
|
|
CodeText |
158
|
|
|
|
|
|
|
Entry |
159
|
|
|
|
|
|
|
FloatEntry |
160
|
|
|
|
|
|
|
PodText |
161
|
|
|
|
|
|
|
Spinbox |
162
|
|
|
|
|
|
|
Text |
163
|
|
|
|
|
|
|
TextUndo |
164
|
|
|
|
|
|
|
TextEditor |
165
|
|
|
|
|
|
|
ROText |
166
|
|
|
|
|
|
|
); |
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
my @listwidgets = qw( |
169
|
|
|
|
|
|
|
Dirlist |
170
|
|
|
|
|
|
|
DirTree |
171
|
|
|
|
|
|
|
HList |
172
|
|
|
|
|
|
|
IconList |
173
|
|
|
|
|
|
|
Listbox |
174
|
|
|
|
|
|
|
Tlist |
175
|
|
|
|
|
|
|
Tree |
176
|
|
|
|
|
|
|
); |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
my %mainoptions = qw( |
179
|
|
|
|
|
|
|
background theme_bg_color |
180
|
|
|
|
|
|
|
foreground theme_fg_color |
181
|
|
|
|
|
|
|
font gtk-font-name |
182
|
|
|
|
|
|
|
activeBackground tk-active-background |
183
|
|
|
|
|
|
|
activeForeground theme_fg_color |
184
|
|
|
|
|
|
|
backPageColor tk-through-color |
185
|
|
|
|
|
|
|
highlightBackground theme_bg_color |
186
|
|
|
|
|
|
|
highlightColor theme_hovering_selected_bg_color |
187
|
|
|
|
|
|
|
inactiveBackground tk-through-color |
188
|
|
|
|
|
|
|
insertBackground theme_fg_color |
189
|
|
|
|
|
|
|
selectBackground theme_selected_bg_color |
190
|
|
|
|
|
|
|
selectForeground theme_selected_fg_color |
191
|
|
|
|
|
|
|
troughColor tk-through-color |
192
|
|
|
|
|
|
|
); |
193
|
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
my %contentoptions = qw( |
195
|
|
|
|
|
|
|
background content_view_bg |
196
|
|
|
|
|
|
|
highlightColor theme_bg_color |
197
|
|
|
|
|
|
|
); |
198
|
|
|
|
|
|
|
|
199
|
|
|
|
|
|
|
my %listoptions = qw( |
200
|
|
|
|
|
|
|
background content_view_bg |
201
|
|
|
|
|
|
|
highlightColor theme_bg_color |
202
|
|
|
|
|
|
|
); |
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
appName(basename($0)); |
206
|
|
|
|
|
|
|
|
207
|
|
|
|
|
|
|
=head1 SYNOPSIS |
208
|
|
|
|
|
|
|
|
209
|
|
|
|
|
|
|
=over 4 |
210
|
|
|
|
|
|
|
|
211
|
|
|
|
|
|
|
use Tk::GtkSettings; |
212
|
|
|
|
|
|
|
applyGtkSettings; |
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
#or |
215
|
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
use Tk::GtkSettings qw(initDefaults export2xrdb); |
217
|
|
|
|
|
|
|
initDefaults; |
218
|
|
|
|
|
|
|
#do your adjustments here |
219
|
|
|
|
|
|
|
export2xrdb; |
220
|
|
|
|
|
|
|
|
221
|
|
|
|
|
|
|
#then initialize your perl/Tk app. |
222
|
|
|
|
|
|
|
|
223
|
|
|
|
|
|
|
use Tk; |
224
|
|
|
|
|
|
|
my $w = new MainWindow; |
225
|
|
|
|
|
|
|
|
226
|
|
|
|
|
|
|
#Do your stuff here |
227
|
|
|
|
|
|
|
|
228
|
|
|
|
|
|
|
$w->MainLoop; |
229
|
|
|
|
|
|
|
|
230
|
|
|
|
|
|
|
=back |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
=head1 ABSTRACT |
233
|
|
|
|
|
|
|
|
234
|
|
|
|
|
|
|
Apply Gtk colors and fonts to your perl/Tk application |
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
=head1 DESCRIPTION |
237
|
|
|
|
|
|
|
|
238
|
|
|
|
|
|
|
Tk::GtkSettings attempts to overcome some very old complaints about Tk: |
239
|
|
|
|
|
|
|
|
240
|
|
|
|
|
|
|
- It's ugly! |
241
|
|
|
|
|
|
|
- It's complicated to adjust colors and fonts to your desktop style |
242
|
|
|
|
|
|
|
|
243
|
|
|
|
|
|
|
Tk::GtkSettings loads your Gtk configuration files and applies it's font and color settings to your perl/Tk application. |
244
|
|
|
|
|
|
|
|
245
|
|
|
|
|
|
|
B loads some nice (at least we think so) default settings that copies your Gtk theme pretty well. |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
However, it gives plenty of tools for you to adjust it and mess it up any way you like. |
248
|
|
|
|
|
|
|
|
249
|
|
|
|
|
|
|
It is harmless to install on Windows or Mac. It just will not do anything on these systems. That makes it |
250
|
|
|
|
|
|
|
smooth to add as a dependency to your own package if you want it to be able to run on Windows and Mac as well. |
251
|
|
|
|
|
|
|
|
252
|
|
|
|
|
|
|
In working with colors it assumes 8-bit color depth. |
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
=head1 EXPORTS |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
=over 4 |
257
|
|
|
|
|
|
|
|
258
|
|
|
|
|
|
|
=item B<$delete_output> |
259
|
|
|
|
|
|
|
|
260
|
|
|
|
|
|
|
=over 4 |
261
|
|
|
|
|
|
|
|
262
|
|
|
|
|
|
|
Usefull for testing and debugging. B exports to a file which then is sent to xrdb. |
263
|
|
|
|
|
|
|
It checks if this file should be deleted when done. Default value is 1. |
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
=back |
266
|
|
|
|
|
|
|
|
267
|
|
|
|
|
|
|
=item B<$gtkpath> |
268
|
|
|
|
|
|
|
|
269
|
|
|
|
|
|
|
=over 4 |
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
Usefull for testing. Default value is ~/.config/gtk-3.0/. That is the location where the |
272
|
|
|
|
|
|
|
Gtk configuration files reside. This variable is not defined when on Windows or Mac. |
273
|
|
|
|
|
|
|
|
274
|
|
|
|
|
|
|
=back |
275
|
|
|
|
|
|
|
|
276
|
|
|
|
|
|
|
=item B<$out_file> |
277
|
|
|
|
|
|
|
|
278
|
|
|
|
|
|
|
=over 4 |
279
|
|
|
|
|
|
|
|
280
|
|
|
|
|
|
|
Default value ~/.tkgtksettings. Used by B. This variable is not defined |
281
|
|
|
|
|
|
|
on Windows or Mac. |
282
|
|
|
|
|
|
|
|
283
|
|
|
|
|
|
|
=back |
284
|
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
=item B<$verbose> |
286
|
|
|
|
|
|
|
|
287
|
|
|
|
|
|
|
=over 4 |
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
Usefull for testing and debugging. Default value is 0. If set B will |
290
|
|
|
|
|
|
|
complain about everything not in order. Otherwise it will quietly fail. |
291
|
|
|
|
|
|
|
|
292
|
|
|
|
|
|
|
=back |
293
|
|
|
|
|
|
|
|
294
|
|
|
|
|
|
|
=item B(I<$hexcolor>, I<$offset>) |
295
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
=over 4 |
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
Adjusts $hexcolor by $offset. It takes every color chanel and adds or substracts $offset. |
299
|
|
|
|
|
|
|
If the channel value is greater than 127 it will substract, otherwise it will add. |
300
|
|
|
|
|
|
|
|
301
|
|
|
|
|
|
|
alterColor('#000000', 1) returns #010101 |
302
|
|
|
|
|
|
|
alterColor('#FFFFFF', 1) returns #FEFEFE |
303
|
|
|
|
|
|
|
|
304
|
|
|
|
|
|
|
=back |
305
|
|
|
|
|
|
|
|
306
|
|
|
|
|
|
|
=cut |
307
|
|
|
|
|
|
|
|
308
|
|
|
|
|
|
|
sub alterColor { |
309
|
5
|
|
|
5
|
1
|
479
|
my ($hex, $offset) = @_; |
310
|
5
|
|
|
|
|
11
|
my @rgb = hex2rgb($hex); |
311
|
5
|
|
|
|
|
9
|
my @rgba = (); |
312
|
5
|
|
|
|
|
10
|
for (@rgb) { |
313
|
15
|
100
|
|
|
|
27
|
if ($_ < 128) { |
314
|
3
|
|
|
|
|
5
|
my $c = $_ + $offset; |
315
|
3
|
50
|
|
|
|
7
|
$c = 0 if $c < 0; |
316
|
3
|
|
|
|
|
5
|
push @rgba, $c |
317
|
|
|
|
|
|
|
} else { |
318
|
12
|
|
|
|
|
13
|
my $c = $_ - $offset; |
319
|
12
|
50
|
|
|
|
21
|
$c = 255 if $c > 255; |
320
|
12
|
|
|
|
|
18
|
push @rgba, $c |
321
|
|
|
|
|
|
|
} |
322
|
|
|
|
|
|
|
} |
323
|
5
|
|
|
|
|
10
|
return rgb2hex(@rgba) |
324
|
|
|
|
|
|
|
} |
325
|
|
|
|
|
|
|
|
326
|
|
|
|
|
|
|
=item B |
327
|
|
|
|
|
|
|
|
328
|
|
|
|
|
|
|
=over 4 |
329
|
|
|
|
|
|
|
|
330
|
|
|
|
|
|
|
Just making life easy. Call this one and your done, unless you require adjustments. |
331
|
|
|
|
|
|
|
It calls B and exports the whole bunch to xrdb. |
332
|
|
|
|
|
|
|
Exported by default. |
333
|
|
|
|
|
|
|
|
334
|
|
|
|
|
|
|
=back |
335
|
|
|
|
|
|
|
|
336
|
|
|
|
|
|
|
=cut |
337
|
|
|
|
|
|
|
|
338
|
|
|
|
|
|
|
sub applyGtkSettings { |
339
|
0
|
|
|
0
|
1
|
0
|
initDefaults; |
340
|
0
|
|
|
|
|
0
|
export2xrdb; |
341
|
|
|
|
|
|
|
} |
342
|
|
|
|
|
|
|
|
343
|
|
|
|
|
|
|
=item B(I<$name>) |
344
|
|
|
|
|
|
|
|
345
|
|
|
|
|
|
|
=over 4 |
346
|
|
|
|
|
|
|
|
347
|
|
|
|
|
|
|
Sets and returns your application name. By default it is set to the basename of what is in B<$0>. Your Gtk settings |
348
|
|
|
|
|
|
|
will only be applied to your application in xrdb. You can set it to an empty string. Then it will |
349
|
|
|
|
|
|
|
apply your Gtk settings to all your perl/Tk applications. |
350
|
|
|
|
|
|
|
|
351
|
|
|
|
|
|
|
=back |
352
|
|
|
|
|
|
|
|
353
|
|
|
|
|
|
|
=cut |
354
|
|
|
|
|
|
|
|
355
|
|
|
|
|
|
|
sub appName { |
356
|
1
|
50
|
|
1
|
1
|
4
|
if (@_ ) { |
357
|
1
|
|
|
|
|
11
|
$app_name = shift; |
358
|
1
|
|
|
|
|
4
|
$marker = "!$app_name Tk::GtkSettings section\n"; |
359
|
|
|
|
|
|
|
} |
360
|
1
|
|
|
|
|
2
|
return $app_name |
361
|
|
|
|
|
|
|
} |
362
|
|
|
|
|
|
|
|
363
|
|
|
|
|
|
|
=item B(I<'rgb(255, 0, 0)'>) |
364
|
|
|
|
|
|
|
|
365
|
|
|
|
|
|
|
=over 4 |
366
|
|
|
|
|
|
|
|
367
|
|
|
|
|
|
|
Some color settings in the Gtk configuration files are in the format 'rgb(255, 255, 255)'. |
368
|
|
|
|
|
|
|
B converts these to a hex color string. |
369
|
|
|
|
|
|
|
|
370
|
|
|
|
|
|
|
=back |
371
|
|
|
|
|
|
|
|
372
|
|
|
|
|
|
|
=cut |
373
|
|
|
|
|
|
|
|
374
|
|
|
|
|
|
|
sub convertColorCode { |
375
|
1
|
|
|
1
|
1
|
365
|
my $input = shift; |
376
|
1
|
50
|
|
|
|
11
|
if ($input =~ /rgb\((\d+),(\d+),(\d+)\)/) { |
377
|
1
|
|
|
|
|
7
|
my $r = substr(sprintf("0x%X", $1), 2); |
378
|
1
|
|
|
|
|
5
|
my $g = substr(sprintf("0x%X", $2), 2); |
379
|
1
|
|
|
|
|
4
|
my $b = substr(sprintf("0x%X", $3), 2); |
380
|
1
|
|
|
|
|
4
|
return "#$r$g$b" |
381
|
|
|
|
|
|
|
} |
382
|
|
|
|
|
|
|
} |
383
|
|
|
|
|
|
|
|
384
|
|
|
|
|
|
|
=item B) |
385
|
|
|
|
|
|
|
|
386
|
|
|
|
|
|
|
=over 4 |
387
|
|
|
|
|
|
|
|
388
|
|
|
|
|
|
|
Converts the font string in gtk to something Tk can handle |
389
|
|
|
|
|
|
|
|
390
|
|
|
|
|
|
|
=back |
391
|
|
|
|
|
|
|
|
392
|
|
|
|
|
|
|
=cut |
393
|
|
|
|
|
|
|
|
394
|
|
|
|
|
|
|
# {Khmer OS Battambang} -12 bold italic |
395
|
|
|
|
|
|
|
sub decodeFont { |
396
|
2
|
|
|
2
|
1
|
3
|
my $rawfont = shift; |
397
|
2
|
|
|
|
|
4
|
my $family = ''; |
398
|
2
|
|
|
|
|
3
|
my $style = ''; |
399
|
2
|
|
|
|
|
4
|
my $size = ''; |
400
|
2
|
50
|
|
|
|
12
|
if ($rawfont =~ s/^([^,]+),//) { |
401
|
2
|
|
|
|
|
5
|
$family = $1; |
402
|
|
|
|
|
|
|
} |
403
|
2
|
|
|
|
|
7
|
$rawfont =~ s/^\s*//; #remove leading spaces |
404
|
2
|
50
|
|
|
|
7
|
if ($rawfont =~ s/^([^\d]+)//) { |
405
|
0
|
|
|
|
|
0
|
$style = $1; |
406
|
0
|
|
|
|
|
0
|
$style =~ s/^\s*//; #remove leading spaces |
407
|
0
|
|
|
|
|
0
|
$style =~ s/\s*!//; #remove trailing spaces |
408
|
0
|
|
|
|
|
0
|
$style = lc($style); |
409
|
|
|
|
|
|
|
} |
410
|
2
|
50
|
|
|
|
8
|
if ($rawfont =~ s/^(\d+)//) { |
411
|
2
|
|
|
|
|
4
|
$size = $1; |
412
|
2
|
|
|
|
|
4
|
$size =~ s/\s*!//; #remove trailing spaces |
413
|
|
|
|
|
|
|
} |
414
|
2
|
|
|
|
|
8
|
return "{$family} $size $style" |
415
|
|
|
|
|
|
|
} |
416
|
|
|
|
|
|
|
|
417
|
|
|
|
|
|
|
=item B(I<$file>, ?I<$removeflag>?) |
418
|
|
|
|
|
|
|
|
419
|
|
|
|
|
|
|
=over 4 |
420
|
|
|
|
|
|
|
|
421
|
|
|
|
|
|
|
Exports your Gtk settings to $file in a format recognized by xrdb. It looks for a section |
422
|
|
|
|
|
|
|
in the file marked by appName . "Tk::GtkSettings section\n". If it finds it it will replace this section. |
423
|
|
|
|
|
|
|
Otherwise it will append your Gtk settings to the end of the file. If $file does not yet exist it |
424
|
|
|
|
|
|
|
will create it. if $removeflag is true it will not export but remove the section from $file. |
425
|
|
|
|
|
|
|
|
426
|
|
|
|
|
|
|
=back |
427
|
|
|
|
|
|
|
|
428
|
|
|
|
|
|
|
=cut |
429
|
|
|
|
|
|
|
|
430
|
|
|
|
|
|
|
sub export2file { |
431
|
2
|
|
|
2
|
1
|
1285
|
my ($file, $remove) = @_; |
432
|
2
|
50
|
|
|
|
7
|
return if $no_gtk; |
433
|
2
|
50
|
|
|
|
6
|
return unless platformPermitted; |
434
|
2
|
100
|
|
|
|
6
|
$remove = 0 unless defined $remove; |
435
|
2
|
|
|
|
|
4
|
my $out = ""; |
436
|
2
|
|
|
|
|
2
|
my $found = 0; |
437
|
2
|
50
|
|
|
|
30
|
if (-e $file) { |
438
|
2
|
50
|
|
|
|
59
|
unless (open(XDEF, "<$file")) { |
439
|
0
|
0
|
|
|
|
0
|
warn "cannot open $file" if $verbose; |
440
|
|
|
|
|
|
|
return |
441
|
0
|
|
|
|
|
0
|
} |
442
|
2
|
|
|
|
|
7
|
my $inside = 0; |
443
|
2
|
|
|
|
|
39
|
while (my $l = ) { |
444
|
59
|
100
|
|
|
|
89
|
if ($inside) { |
445
|
46
|
100
|
|
|
|
97
|
if ($l eq $marker) { |
446
|
1
|
|
|
|
|
3
|
$inside = 0; |
447
|
|
|
|
|
|
|
} |
448
|
|
|
|
|
|
|
} else { |
449
|
13
|
100
|
|
|
|
22
|
if ($l eq $marker) { |
450
|
1
|
|
|
|
|
2
|
$inside = 1; |
451
|
1
|
|
|
|
|
2
|
$found = 1; |
452
|
1
|
50
|
|
|
|
8
|
$out = "$out$l" . generateOutput . $l unless $remove; |
453
|
|
|
|
|
|
|
} else { |
454
|
12
|
|
|
|
|
63
|
$out = "$out$l"; |
455
|
|
|
|
|
|
|
} |
456
|
|
|
|
|
|
|
} |
457
|
|
|
|
|
|
|
} |
458
|
2
|
|
|
|
|
22
|
close XDEF; |
459
|
|
|
|
|
|
|
} |
460
|
2
|
100
|
|
|
|
7
|
unless ($found) { |
461
|
1
|
|
|
|
|
5
|
$out = "$out\n$marker" . generateOutput . "$marker\n" |
462
|
|
|
|
|
|
|
} |
463
|
2
|
50
|
|
|
|
124
|
unless (open(XDEFO, ">$file")) { |
464
|
0
|
0
|
|
|
|
0
|
warn "cannot open $file" if $verbose; |
465
|
|
|
|
|
|
|
return |
466
|
0
|
|
|
|
|
0
|
} |
467
|
2
|
|
|
|
|
28
|
print XDEFO $out; |
468
|
2
|
|
|
|
|
175
|
close XDEFO; |
469
|
|
|
|
|
|
|
} |
470
|
|
|
|
|
|
|
|
471
|
|
|
|
|
|
|
=item B(?I<$removeflag>?) |
472
|
|
|
|
|
|
|
|
473
|
|
|
|
|
|
|
=over 4 |
474
|
|
|
|
|
|
|
|
475
|
|
|
|
|
|
|
Same as B, however the file is always '~/.Xdefaults'. |
476
|
|
|
|
|
|
|
|
477
|
|
|
|
|
|
|
=back |
478
|
|
|
|
|
|
|
|
479
|
|
|
|
|
|
|
=cut |
480
|
|
|
|
|
|
|
|
481
|
|
|
|
|
|
|
sub export2Xdefaults { |
482
|
0
|
|
|
0
|
1
|
0
|
export2file('~/.Xdefaults'); |
483
|
|
|
|
|
|
|
} |
484
|
|
|
|
|
|
|
|
485
|
|
|
|
|
|
|
=item B(?I<$removeflag>?) |
486
|
|
|
|
|
|
|
|
487
|
|
|
|
|
|
|
=over 4 |
488
|
|
|
|
|
|
|
|
489
|
|
|
|
|
|
|
Same as B, however the file is always '~/.Xresources'. |
490
|
|
|
|
|
|
|
|
491
|
|
|
|
|
|
|
=back |
492
|
|
|
|
|
|
|
|
493
|
|
|
|
|
|
|
=cut |
494
|
|
|
|
|
|
|
|
495
|
|
|
|
|
|
|
sub export2Xresources { |
496
|
0
|
|
|
0
|
1
|
0
|
export2file('~/.Xresources'); |
497
|
|
|
|
|
|
|
} |
498
|
|
|
|
|
|
|
|
499
|
|
|
|
|
|
|
=item B |
500
|
|
|
|
|
|
|
|
501
|
|
|
|
|
|
|
=over 4 |
502
|
|
|
|
|
|
|
|
503
|
|
|
|
|
|
|
exports your Gtk settings directly to the xrdb database. |
504
|
|
|
|
|
|
|
|
505
|
|
|
|
|
|
|
=back |
506
|
|
|
|
|
|
|
|
507
|
|
|
|
|
|
|
=cut |
508
|
|
|
|
|
|
|
|
509
|
|
|
|
|
|
|
sub export2xrdb { |
510
|
0
|
0
|
|
0
|
1
|
0
|
return unless platformPermitted; |
511
|
0
|
0
|
|
|
|
0
|
return if $no_gtk; |
512
|
0
|
0
|
|
|
|
0
|
if (open(OFILE, ">", $out_file)) { |
513
|
0
|
|
|
|
|
0
|
print OFILE generateOutput; |
514
|
0
|
|
|
|
|
0
|
close OFILE; |
515
|
0
|
|
|
|
|
0
|
system "xrdb $out_file"; |
516
|
0
|
0
|
|
|
|
0
|
unlink $out_file if $delete_output; |
517
|
|
|
|
|
|
|
} |
518
|
|
|
|
|
|
|
} |
519
|
|
|
|
|
|
|
|
520
|
|
|
|
|
|
|
=item B |
521
|
|
|
|
|
|
|
|
522
|
|
|
|
|
|
|
=over 4 |
523
|
|
|
|
|
|
|
|
524
|
|
|
|
|
|
|
Generates the output used by the export functions. Returns a string. |
525
|
|
|
|
|
|
|
|
526
|
|
|
|
|
|
|
=back |
527
|
|
|
|
|
|
|
|
528
|
|
|
|
|
|
|
=cut |
529
|
|
|
|
|
|
|
|
530
|
|
|
|
|
|
|
sub generateOutput { |
531
|
1
|
50
|
|
1
|
1
|
2
|
return if $no_gtk; |
532
|
1
|
50
|
|
|
|
3
|
return unless platformPermitted; |
533
|
1
|
|
|
|
|
2
|
my $output = ''; |
534
|
|
|
|
|
|
|
#group main has to be done first. |
535
|
1
|
|
|
|
|
3
|
my (@g) = ('main'); |
536
|
1
|
|
|
|
|
15
|
for (sort keys %groups) { |
537
|
3
|
100
|
|
|
|
10
|
push @g, $_ unless $_ eq 'main'; |
538
|
|
|
|
|
|
|
} |
539
|
1
|
|
|
|
|
3
|
for (@g) { |
540
|
3
|
|
|
|
|
4
|
my $name = $_; |
541
|
3
|
|
|
|
|
6
|
my $group = $groups{$name}; |
542
|
3
|
|
|
|
|
5
|
my $options = $group->[1]; |
543
|
3
|
|
|
|
|
4
|
my $mem = $group->[0]; |
544
|
3
|
|
|
|
|
6
|
for (@$mem) { |
545
|
17
|
|
|
|
|
22
|
my $member = $_; |
546
|
17
|
|
|
|
|
44
|
for (sort keys %$options) { |
547
|
45
|
|
|
|
|
77
|
my $val = gtkKey($options->{$_}); |
548
|
45
|
50
|
|
|
|
79
|
$val = $options->{$_} unless defined $val; |
549
|
45
|
100
|
|
|
|
65
|
unless ($name eq 'main') { |
550
|
32
|
|
|
|
|
98
|
$output = $output . $app_name . "*$member." . $_ . ": " . $val . "\n"; |
551
|
|
|
|
|
|
|
} else { |
552
|
13
|
|
|
|
|
49
|
$output = $output . $app_name . '*' . $_ . ": " . $val . "\n"; |
553
|
|
|
|
|
|
|
} |
554
|
|
|
|
|
|
|
} |
555
|
|
|
|
|
|
|
} |
556
|
|
|
|
|
|
|
} |
557
|
1
|
|
|
|
|
18
|
return $output |
558
|
|
|
|
|
|
|
} |
559
|
|
|
|
|
|
|
|
560
|
|
|
|
|
|
|
=item B(I<$groupname>, I<\@members>, I<\%options>) |
561
|
|
|
|
|
|
|
|
562
|
|
|
|
|
|
|
=over 4 |
563
|
|
|
|
|
|
|
|
564
|
|
|
|
|
|
|
Adds $groupname to the groups hash. If @members or %options are not specified, |
565
|
|
|
|
|
|
|
it will leave them empty. |
566
|
|
|
|
|
|
|
|
567
|
|
|
|
|
|
|
=back |
568
|
|
|
|
|
|
|
|
569
|
|
|
|
|
|
|
=cut |
570
|
|
|
|
|
|
|
|
571
|
|
|
|
|
|
|
sub groupAdd { |
572
|
5
|
|
|
5
|
1
|
302
|
my ($group, $members, $options) = @_; |
573
|
5
|
50
|
|
|
|
11
|
unless (defined $group) { |
574
|
0
|
0
|
|
|
|
0
|
warn "group is not defined" if $verbose; |
575
|
|
|
|
|
|
|
return |
576
|
0
|
|
|
|
|
0
|
} |
577
|
5
|
50
|
|
|
|
17
|
$members = [] unless defined $members; |
578
|
5
|
50
|
|
|
|
9
|
$options = {} unless defined $options; |
579
|
5
|
50
|
|
|
|
11
|
unless (exists $groups{$group}) { |
580
|
5
|
|
|
|
|
17
|
$groups{$group} = [$members, $options] |
581
|
|
|
|
|
|
|
} else { |
582
|
0
|
0
|
|
|
|
0
|
warn "group $group already exists" if $verbose |
583
|
|
|
|
|
|
|
} |
584
|
|
|
|
|
|
|
} |
585
|
|
|
|
|
|
|
|
586
|
|
|
|
|
|
|
=item B |
587
|
|
|
|
|
|
|
|
588
|
|
|
|
|
|
|
=over 4 |
589
|
|
|
|
|
|
|
|
590
|
|
|
|
|
|
|
Returns a list of all available groups. |
591
|
|
|
|
|
|
|
|
592
|
|
|
|
|
|
|
=back |
593
|
|
|
|
|
|
|
|
594
|
|
|
|
|
|
|
=cut |
595
|
|
|
|
|
|
|
|
596
|
|
|
|
|
|
|
sub groupAll { |
597
|
1
|
|
|
1
|
1
|
7
|
return keys %groups |
598
|
|
|
|
|
|
|
} |
599
|
|
|
|
|
|
|
|
600
|
|
|
|
|
|
|
=item B(I<$groupname>) |
601
|
|
|
|
|
|
|
|
602
|
|
|
|
|
|
|
=over 4 |
603
|
|
|
|
|
|
|
|
604
|
|
|
|
|
|
|
Removes $groupsname from the groups hash. You cannot delete the 'main' group. |
605
|
|
|
|
|
|
|
|
606
|
|
|
|
|
|
|
=back |
607
|
|
|
|
|
|
|
|
608
|
|
|
|
|
|
|
=cut |
609
|
|
|
|
|
|
|
|
610
|
|
|
|
|
|
|
sub groupDelete { |
611
|
2
|
|
|
2
|
1
|
5
|
my $group = shift; |
612
|
2
|
50
|
|
|
|
5
|
if (groupExists($group)) { |
613
|
2
|
100
|
|
|
|
6
|
if ($group eq 'main') { |
614
|
1
|
50
|
|
|
|
4
|
warn "deleting main group is not allowed" if $verbose; |
615
|
1
|
|
|
|
|
3
|
return 0 |
616
|
|
|
|
|
|
|
} |
617
|
1
|
|
|
|
|
3
|
delete $groups{$group}; |
618
|
|
|
|
|
|
|
} |
619
|
1
|
|
|
|
|
2
|
return 1 |
620
|
|
|
|
|
|
|
} |
621
|
|
|
|
|
|
|
|
622
|
|
|
|
|
|
|
=item B(I<$groupname>) |
623
|
|
|
|
|
|
|
|
624
|
|
|
|
|
|
|
=over 4 |
625
|
|
|
|
|
|
|
|
626
|
|
|
|
|
|
|
Returns true if $groupname is available. |
627
|
|
|
|
|
|
|
|
628
|
|
|
|
|
|
|
=back |
629
|
|
|
|
|
|
|
|
630
|
|
|
|
|
|
|
=cut |
631
|
|
|
|
|
|
|
|
632
|
|
|
|
|
|
|
sub groupExists { |
633
|
41
|
|
|
41
|
1
|
56
|
my $group = shift; |
634
|
41
|
50
|
|
|
|
77
|
unless (defined $group) { |
635
|
0
|
0
|
|
|
|
0
|
warn "group not specified or is not defined" if $verbose; |
636
|
0
|
|
|
|
|
0
|
return 0 |
637
|
|
|
|
|
|
|
} |
638
|
41
|
100
|
|
|
|
71
|
unless (exists $groups{$group}) { |
639
|
1
|
50
|
|
|
|
3
|
warn "group $group does not exist" if $verbose; |
640
|
1
|
|
|
|
|
4
|
return 0 |
641
|
|
|
|
|
|
|
} |
642
|
40
|
|
|
|
|
89
|
return 1 |
643
|
|
|
|
|
|
|
} |
644
|
|
|
|
|
|
|
|
645
|
|
|
|
|
|
|
=item B(I<$groupname>) |
646
|
|
|
|
|
|
|
|
647
|
|
|
|
|
|
|
=over 4 |
648
|
|
|
|
|
|
|
|
649
|
|
|
|
|
|
|
Returns the list of existing members of $groupname. It will return an empty list |
650
|
|
|
|
|
|
|
if $groupname equals 'main'. |
651
|
|
|
|
|
|
|
|
652
|
|
|
|
|
|
|
=back |
653
|
|
|
|
|
|
|
|
654
|
|
|
|
|
|
|
=cut |
655
|
|
|
|
|
|
|
|
656
|
|
|
|
|
|
|
sub groupMembers { |
657
|
2
|
|
|
2
|
1
|
5
|
my $group = shift; |
658
|
2
|
50
|
|
|
|
4
|
if (groupExists($group)) { |
659
|
2
|
50
|
|
|
|
5
|
if ($group eq 'main') { |
660
|
0
|
|
|
|
|
0
|
warn "no access to main group members"; |
661
|
|
|
|
|
|
|
return () |
662
|
0
|
|
|
|
|
0
|
} |
663
|
2
|
|
|
|
|
3
|
my $l = $groups{$group}->[0]; |
664
|
2
|
|
|
|
|
7
|
return @$l; |
665
|
|
|
|
|
|
|
} |
666
|
|
|
|
|
|
|
} |
667
|
|
|
|
|
|
|
|
668
|
|
|
|
|
|
|
=item B(I<$groupname>, I<@newmembers>) |
669
|
|
|
|
|
|
|
|
670
|
|
|
|
|
|
|
=over 4 |
671
|
|
|
|
|
|
|
|
672
|
|
|
|
|
|
|
Adds new members to $groupname. You cannot add members to the 'main' group. |
673
|
|
|
|
|
|
|
|
674
|
|
|
|
|
|
|
=back |
675
|
|
|
|
|
|
|
|
676
|
|
|
|
|
|
|
=cut |
677
|
|
|
|
|
|
|
|
678
|
|
|
|
|
|
|
sub groupMembersAdd { |
679
|
1
|
|
|
1
|
1
|
2
|
my $group = shift; |
680
|
1
|
50
|
|
|
|
36
|
if (groupExists($group)) { |
681
|
1
|
50
|
|
|
|
5
|
if ($group eq 'main') { |
682
|
0
|
|
|
|
|
0
|
warn "no access to main group members"; |
683
|
|
|
|
|
|
|
return |
684
|
0
|
|
|
|
|
0
|
} |
685
|
1
|
|
|
|
|
3
|
my $l = $groups{$group}->[0]; |
686
|
1
|
|
|
|
|
4
|
push @$l, @_; |
687
|
|
|
|
|
|
|
} |
688
|
|
|
|
|
|
|
} |
689
|
|
|
|
|
|
|
|
690
|
|
|
|
|
|
|
=item B(I<$groupname>, I<@members>) |
691
|
|
|
|
|
|
|
|
692
|
|
|
|
|
|
|
=over 4 |
693
|
|
|
|
|
|
|
|
694
|
|
|
|
|
|
|
Replaces the list of members in $groupsname by @members. You cannot modify the members list of the 'main' group. |
695
|
|
|
|
|
|
|
|
696
|
|
|
|
|
|
|
=back |
697
|
|
|
|
|
|
|
|
698
|
|
|
|
|
|
|
=cut |
699
|
|
|
|
|
|
|
|
700
|
|
|
|
|
|
|
sub groupMembersReplace { |
701
|
1
|
|
|
1
|
1
|
295
|
my $group = shift; |
702
|
1
|
50
|
|
|
|
3
|
if (groupExists($group)) { |
703
|
1
|
50
|
|
|
|
4
|
if ($group eq 'main') { |
704
|
0
|
|
|
|
|
0
|
warn "No access to main group members"; |
705
|
|
|
|
|
|
|
return |
706
|
0
|
|
|
|
|
0
|
} |
707
|
1
|
|
|
|
|
2
|
my $l = $groups{$group}->[0]; |
708
|
1
|
|
|
|
|
4
|
@$l = @_; |
709
|
|
|
|
|
|
|
} |
710
|
|
|
|
|
|
|
} |
711
|
|
|
|
|
|
|
|
712
|
|
|
|
|
|
|
=item B(I<$groupname>, I<$option>, ?I<$value>?) |
713
|
|
|
|
|
|
|
|
714
|
|
|
|
|
|
|
=over 4 |
715
|
|
|
|
|
|
|
|
716
|
|
|
|
|
|
|
Sets and returns the value of $option in $groupname. $value should be a corresponding key from |
717
|
|
|
|
|
|
|
the Gtk hash. If that key is not found, it assumes a direct value. |
718
|
|
|
|
|
|
|
|
719
|
|
|
|
|
|
|
=back |
720
|
|
|
|
|
|
|
|
721
|
|
|
|
|
|
|
=cut |
722
|
|
|
|
|
|
|
|
723
|
|
|
|
|
|
|
sub groupOption { |
724
|
29
|
|
|
29
|
1
|
327
|
my $group = shift; |
725
|
29
|
50
|
|
|
|
40
|
if (groupExists($group)) { |
726
|
29
|
|
|
|
|
34
|
my $option = shift; |
727
|
29
|
50
|
|
|
|
47
|
unless (defined $option) { |
728
|
0
|
0
|
|
|
|
0
|
warn "option not defined or specified" if $verbose; |
729
|
|
|
|
|
|
|
return |
730
|
0
|
|
|
|
|
0
|
} |
731
|
29
|
100
|
|
|
|
46
|
if (@_) { |
732
|
27
|
|
|
|
|
36
|
my $value = shift; |
733
|
27
|
|
|
|
|
44
|
$groups{$group}->[1]->{$option} = $value; |
734
|
|
|
|
|
|
|
} |
735
|
29
|
|
|
|
|
59
|
return $groups{$group}->[1]->{$option} |
736
|
|
|
|
|
|
|
} |
737
|
|
|
|
|
|
|
} |
738
|
|
|
|
|
|
|
|
739
|
|
|
|
|
|
|
=item B(I<$groupname>) |
740
|
|
|
|
|
|
|
|
741
|
|
|
|
|
|
|
=over 4 |
742
|
|
|
|
|
|
|
|
743
|
|
|
|
|
|
|
Returns a list of all available options in $groupname. |
744
|
|
|
|
|
|
|
|
745
|
|
|
|
|
|
|
=back |
746
|
|
|
|
|
|
|
|
747
|
|
|
|
|
|
|
=cut |
748
|
|
|
|
|
|
|
|
749
|
|
|
|
|
|
|
sub groupOptionAll { |
750
|
2
|
|
|
2
|
1
|
279
|
my $group = shift; |
751
|
2
|
50
|
|
|
|
6
|
if (groupExists($group)) { |
752
|
2
|
|
|
|
|
5
|
my $opt = $groups{$group}->[1]; |
753
|
2
|
|
|
|
|
6
|
return keys %$opt |
754
|
|
|
|
|
|
|
} |
755
|
|
|
|
|
|
|
} |
756
|
|
|
|
|
|
|
|
757
|
|
|
|
|
|
|
=item B(I<$groupname>, I<$option>) |
758
|
|
|
|
|
|
|
|
759
|
|
|
|
|
|
|
=over 4 |
760
|
|
|
|
|
|
|
|
761
|
|
|
|
|
|
|
Removes $option from $groupname |
762
|
|
|
|
|
|
|
|
763
|
|
|
|
|
|
|
=back |
764
|
|
|
|
|
|
|
|
765
|
|
|
|
|
|
|
=cut |
766
|
|
|
|
|
|
|
|
767
|
|
|
|
|
|
|
sub groupOptionDelete { |
768
|
1
|
|
|
1
|
1
|
272
|
my $group = shift; |
769
|
1
|
50
|
|
|
|
3
|
if (groupExists($group)) { |
770
|
1
|
|
|
|
|
2
|
my $option = shift; |
771
|
1
|
50
|
|
|
|
4
|
unless (defined $option) { |
772
|
0
|
0
|
|
|
|
0
|
warn "option not defined or specified" if $verbose; |
773
|
|
|
|
|
|
|
return |
774
|
0
|
|
|
|
|
0
|
} |
775
|
1
|
|
|
|
|
3
|
delete $groups{$group}->[1]->{$option}; |
776
|
|
|
|
|
|
|
} |
777
|
|
|
|
|
|
|
} |
778
|
|
|
|
|
|
|
|
779
|
|
|
|
|
|
|
=item B(I<$key>, ?I<$value>?) |
780
|
|
|
|
|
|
|
|
781
|
|
|
|
|
|
|
=over 4 |
782
|
|
|
|
|
|
|
|
783
|
|
|
|
|
|
|
Sets and returns the value of $key in the Gtk hash |
784
|
|
|
|
|
|
|
|
785
|
|
|
|
|
|
|
=back |
786
|
|
|
|
|
|
|
|
787
|
|
|
|
|
|
|
=cut |
788
|
|
|
|
|
|
|
|
789
|
|
|
|
|
|
|
sub gtkKey { |
790
|
56
|
|
|
56
|
1
|
86
|
my ($key, $val) = @_; |
791
|
56
|
50
|
|
|
|
94
|
return undef if $no_gtk; |
792
|
56
|
100
|
|
|
|
106
|
$gtksettings{$key} = $val if defined $val; |
793
|
56
|
100
|
|
|
|
94
|
if (exists $gtksettings{$key}) { |
794
|
55
|
|
|
|
|
98
|
return $gtksettings{$key} |
795
|
|
|
|
|
|
|
} else { |
796
|
1
|
50
|
|
|
|
3
|
warn "item $key not present in gtk settings" if $verbose; |
797
|
|
|
|
|
|
|
} |
798
|
|
|
|
|
|
|
return undef |
799
|
1
|
|
|
|
|
4
|
} |
800
|
|
|
|
|
|
|
|
801
|
|
|
|
|
|
|
=item B |
802
|
|
|
|
|
|
|
|
803
|
|
|
|
|
|
|
=over 4 |
804
|
|
|
|
|
|
|
|
805
|
|
|
|
|
|
|
Returns a list of all available keys in the Gtk hash. |
806
|
|
|
|
|
|
|
|
807
|
|
|
|
|
|
|
=back |
808
|
|
|
|
|
|
|
|
809
|
|
|
|
|
|
|
=cut |
810
|
|
|
|
|
|
|
|
811
|
|
|
|
|
|
|
sub gtkKeyAll { |
812
|
0
|
0
|
|
0
|
1
|
0
|
return 0 if $no_gtk; |
813
|
0
|
|
|
|
|
0
|
return keys %gtksettings |
814
|
|
|
|
|
|
|
} |
815
|
|
|
|
|
|
|
|
816
|
|
|
|
|
|
|
=item B(I<$key>) |
817
|
|
|
|
|
|
|
|
818
|
|
|
|
|
|
|
=over 4 |
819
|
|
|
|
|
|
|
|
820
|
|
|
|
|
|
|
Delets $key from the Gtk hash. |
821
|
|
|
|
|
|
|
|
822
|
|
|
|
|
|
|
=back |
823
|
|
|
|
|
|
|
|
824
|
|
|
|
|
|
|
=cut |
825
|
|
|
|
|
|
|
|
826
|
|
|
|
|
|
|
sub gtkKeyDelete { |
827
|
1
|
|
|
1
|
1
|
3
|
my $key = shift; |
828
|
1
|
50
|
|
|
|
4
|
return 0 if $no_gtk; |
829
|
1
|
50
|
|
|
|
3
|
if (exists $gtksettings{$key}) { |
830
|
1
|
|
|
|
|
3
|
delete $gtksettings{$key} |
831
|
|
|
|
|
|
|
} else { |
832
|
0
|
0
|
|
|
|
0
|
warn "item $key not present in gtk settings" if $verbose; |
833
|
|
|
|
|
|
|
} |
834
|
|
|
|
|
|
|
} |
835
|
|
|
|
|
|
|
|
836
|
|
|
|
|
|
|
=item B |
837
|
|
|
|
|
|
|
|
838
|
|
|
|
|
|
|
=over 4 |
839
|
|
|
|
|
|
|
|
840
|
|
|
|
|
|
|
Initializes some sensible defaults. Also does a full reset and loads Gtk configuration files. |
841
|
|
|
|
|
|
|
|
842
|
|
|
|
|
|
|
=back |
843
|
|
|
|
|
|
|
|
844
|
|
|
|
|
|
|
=cut |
845
|
|
|
|
|
|
|
|
846
|
|
|
|
|
|
|
sub initDefaults { |
847
|
2
|
|
|
2
|
1
|
451
|
resetAll; |
848
|
2
|
|
|
|
|
6
|
loadGtkInfo; |
849
|
2
|
|
|
|
|
5
|
gtkKey('tk-active-background', alterColor(gtkKey('theme_bg_color'), 20)); |
850
|
2
|
|
|
|
|
5
|
gtkKey('tk-through-color', alterColor(gtkKey('theme_bg_color'), 20)); |
851
|
2
|
|
|
|
|
11
|
for (keys %mainoptions) { |
852
|
26
|
|
|
|
|
42
|
groupOption('main', $_, $mainoptions{$_}) |
853
|
|
|
|
|
|
|
} |
854
|
2
|
|
|
|
|
7
|
my @cw = @contentwidgets; |
855
|
2
|
|
|
|
|
16
|
my %co = %contentoptions; |
856
|
2
|
|
|
|
|
8
|
groupAdd('content', \@cw, \%co); |
857
|
2
|
|
|
|
|
7
|
my @lw = @listwidgets; |
858
|
2
|
|
|
|
|
6
|
my %lo = %listoptions; |
859
|
2
|
|
|
|
|
6
|
groupAdd('list', \@lw, \%lo); |
860
|
|
|
|
|
|
|
} |
861
|
|
|
|
|
|
|
|
862
|
|
|
|
|
|
|
=item B(I<$hex_color>) |
863
|
|
|
|
|
|
|
|
864
|
|
|
|
|
|
|
=over 4 |
865
|
|
|
|
|
|
|
|
866
|
|
|
|
|
|
|
Returns and array with the decimal values of red, green and blue. |
867
|
|
|
|
|
|
|
|
868
|
|
|
|
|
|
|
=back |
869
|
|
|
|
|
|
|
|
870
|
|
|
|
|
|
|
=cut |
871
|
|
|
|
|
|
|
|
872
|
|
|
|
|
|
|
sub hex2rgb { |
873
|
6
|
|
|
6
|
1
|
8
|
my $hex = shift; |
874
|
6
|
|
|
|
|
25
|
$hex =~ s/^(\#|Ox)//; |
875
|
6
|
|
|
|
|
12
|
$_ = $hex; |
876
|
6
|
|
|
|
|
55
|
my ($r, $g, $b) = m/(\w{2})(\w{2})(\w{2})/; |
877
|
6
|
|
|
|
|
12
|
my @rgb = (); |
878
|
6
|
|
|
|
|
14
|
$rgb[0] = CORE::hex($r); |
879
|
6
|
|
|
|
|
10
|
$rgb[1] = CORE::hex($g); |
880
|
6
|
|
|
|
|
8
|
$rgb[2] = CORE::hex($b); |
881
|
|
|
|
|
|
|
return @rgb |
882
|
6
|
|
|
|
|
16
|
} |
883
|
|
|
|
|
|
|
|
884
|
|
|
|
|
|
|
=item B(I<$num>) |
885
|
|
|
|
|
|
|
|
886
|
|
|
|
|
|
|
=over 4 |
887
|
|
|
|
|
|
|
|
888
|
|
|
|
|
|
|
Return the hexadecimal representation of $num in a two character string. |
889
|
|
|
|
|
|
|
|
890
|
|
|
|
|
|
|
=back |
891
|
|
|
|
|
|
|
|
892
|
|
|
|
|
|
|
=cut |
893
|
|
|
|
|
|
|
|
894
|
|
|
|
|
|
|
sub hexstring { |
895
|
19
|
|
|
19
|
1
|
304
|
my $num = shift; |
896
|
19
|
|
|
|
|
45
|
my $hex = substr(sprintf("0x%X", $num), 2); |
897
|
19
|
100
|
|
|
|
40
|
if (length($hex) < 2) { $hex = "0$hex" } |
|
5
|
|
|
|
|
9
|
|
898
|
19
|
|
|
|
|
32
|
return $hex |
899
|
|
|
|
|
|
|
} |
900
|
|
|
|
|
|
|
|
901
|
|
|
|
|
|
|
=item B |
902
|
|
|
|
|
|
|
|
903
|
|
|
|
|
|
|
=over 4 |
904
|
|
|
|
|
|
|
|
905
|
|
|
|
|
|
|
Empties the Gtk hash and (re)loads the Gtk configuration files. |
906
|
|
|
|
|
|
|
|
907
|
|
|
|
|
|
|
=back |
908
|
|
|
|
|
|
|
|
909
|
|
|
|
|
|
|
=cut |
910
|
|
|
|
|
|
|
|
911
|
|
|
|
|
|
|
sub loadGtkInfo { |
912
|
2
|
|
|
2
|
1
|
14
|
%gtksettings = (); |
913
|
2
|
|
|
|
|
5
|
my $cf = $gtkpath . "colors.css"; |
914
|
2
|
50
|
|
|
|
74
|
if (open(OFILE, "<", $cf)) { |
915
|
2
|
|
|
|
|
72
|
while () { |
916
|
140
|
|
|
|
|
230
|
my $line = $_; |
917
|
140
|
50
|
|
|
|
516
|
if ($line =~ s/\@define-color\s//) { |
918
|
140
|
50
|
|
|
|
464
|
if ($line =~ /([^\s]+)\s([^;]+);/) { |
919
|
140
|
|
|
|
|
263
|
my $key = $1; |
920
|
140
|
|
|
|
|
220
|
my $color = $2; |
921
|
140
|
50
|
|
|
|
244
|
$color = convertColorCode($color) if $color =~ /^rgb\(/; |
922
|
140
|
|
|
|
|
210
|
$key = _truncate($key); |
923
|
140
|
|
|
|
|
492
|
$gtksettings{$key} = $color |
924
|
|
|
|
|
|
|
} |
925
|
|
|
|
|
|
|
} |
926
|
|
|
|
|
|
|
} |
927
|
2
|
|
|
|
|
23
|
close OFILE |
928
|
|
|
|
|
|
|
} else { |
929
|
0
|
0
|
|
|
|
0
|
warn "cannot open Gtk colors.css" if $verbose; |
930
|
0
|
|
|
|
|
0
|
$no_gtk = 1; |
931
|
|
|
|
|
|
|
} |
932
|
2
|
|
|
|
|
7
|
my $sf = $gtkpath . "settings.ini"; |
933
|
2
|
50
|
|
|
|
68
|
if (open(OFILE, "<", $sf)) { |
934
|
2
|
|
|
|
|
45
|
while () { |
935
|
24
|
|
|
|
|
40
|
my $line = $_; |
936
|
24
|
100
|
|
|
|
85
|
if ($line =~ /([^=]+)=([^\n]+)/) { |
937
|
22
|
|
|
|
|
98
|
$gtksettings{$1} = $2 |
938
|
|
|
|
|
|
|
} |
939
|
|
|
|
|
|
|
} |
940
|
2
|
|
|
|
|
20
|
close OFILE; |
941
|
2
|
50
|
|
|
|
8
|
if (exists $gtksettings{'gtk-font-name'}) { |
942
|
2
|
|
|
|
|
7
|
my $font = decodeFont($gtksettings{'gtk-font-name'}); |
943
|
2
|
|
|
|
|
6
|
$gtksettings{'gtk-font-name'} = $font; |
944
|
|
|
|
|
|
|
} |
945
|
|
|
|
|
|
|
} else { |
946
|
0
|
0
|
|
|
|
0
|
warn "cannot open Gtk settings.ini" if $verbose; |
947
|
0
|
|
|
|
|
0
|
$no_gtk = 1; |
948
|
|
|
|
|
|
|
} |
949
|
|
|
|
|
|
|
} |
950
|
|
|
|
|
|
|
|
951
|
|
|
|
|
|
|
=item B |
952
|
|
|
|
|
|
|
|
953
|
|
|
|
|
|
|
=over 4 |
954
|
|
|
|
|
|
|
|
955
|
|
|
|
|
|
|
Returns true if you are not on Windows or Mac. |
956
|
|
|
|
|
|
|
|
957
|
|
|
|
|
|
|
=back |
958
|
|
|
|
|
|
|
|
959
|
|
|
|
|
|
|
=cut |
960
|
|
|
|
|
|
|
|
961
|
|
|
|
|
|
|
sub platformPermitted { |
962
|
5
|
|
|
5
|
1
|
20
|
my $platform = $^O; |
963
|
5
|
50
|
33
|
|
|
25
|
return 0 if (($^O eq 'MSWin32') or ($^O eq 'darwin')); |
964
|
5
|
|
|
|
|
14
|
return 1 |
965
|
|
|
|
|
|
|
} |
966
|
|
|
|
|
|
|
|
967
|
|
|
|
|
|
|
=item B(I<$file>) |
968
|
|
|
|
|
|
|
|
969
|
|
|
|
|
|
|
=over 4 |
970
|
|
|
|
|
|
|
|
971
|
|
|
|
|
|
|
Same as export2file($file, 1) |
972
|
|
|
|
|
|
|
|
973
|
|
|
|
|
|
|
=back |
974
|
|
|
|
|
|
|
|
975
|
|
|
|
|
|
|
=cut |
976
|
|
|
|
|
|
|
|
977
|
|
|
|
|
|
|
sub removeFromfile { |
978
|
0
|
|
|
0
|
1
|
0
|
my $f = shift; |
979
|
0
|
|
|
|
|
0
|
export2file($f, 1); |
980
|
|
|
|
|
|
|
} |
981
|
|
|
|
|
|
|
|
982
|
|
|
|
|
|
|
=item B |
983
|
|
|
|
|
|
|
|
984
|
|
|
|
|
|
|
=over 4 |
985
|
|
|
|
|
|
|
|
986
|
|
|
|
|
|
|
Same as export2Xdefaults(1) |
987
|
|
|
|
|
|
|
|
988
|
|
|
|
|
|
|
=back |
989
|
|
|
|
|
|
|
|
990
|
|
|
|
|
|
|
=cut |
991
|
|
|
|
|
|
|
|
992
|
|
|
|
|
|
|
sub removeFromXdefaults { |
993
|
0
|
|
|
0
|
1
|
0
|
export2file('~/.Xdefaults', 1); |
994
|
|
|
|
|
|
|
} |
995
|
|
|
|
|
|
|
|
996
|
|
|
|
|
|
|
=item B |
997
|
|
|
|
|
|
|
|
998
|
|
|
|
|
|
|
=over 4 |
999
|
|
|
|
|
|
|
|
1000
|
|
|
|
|
|
|
Same as export2Xresources(1) |
1001
|
|
|
|
|
|
|
|
1002
|
|
|
|
|
|
|
=back |
1003
|
|
|
|
|
|
|
|
1004
|
|
|
|
|
|
|
=cut |
1005
|
|
|
|
|
|
|
|
1006
|
|
|
|
|
|
|
sub removeFromXresources { |
1007
|
0
|
|
|
0
|
1
|
0
|
export2file('~/.Xresouces', 1); |
1008
|
|
|
|
|
|
|
} |
1009
|
|
|
|
|
|
|
|
1010
|
|
|
|
|
|
|
=item B |
1011
|
|
|
|
|
|
|
|
1012
|
|
|
|
|
|
|
=over 4 |
1013
|
|
|
|
|
|
|
|
1014
|
|
|
|
|
|
|
Removes all the settings previously defined from the xrdb database |
1015
|
|
|
|
|
|
|
|
1016
|
|
|
|
|
|
|
=back |
1017
|
|
|
|
|
|
|
|
1018
|
|
|
|
|
|
|
=cut |
1019
|
|
|
|
|
|
|
|
1020
|
|
|
|
|
|
|
sub removeFromxrdb { |
1021
|
0
|
0
|
|
0
|
1
|
0
|
return unless platformPermitted; |
1022
|
0
|
0
|
|
|
|
0
|
return if $no_gtk; |
1023
|
0
|
0
|
|
|
|
0
|
if (open(OFILE, ">", $out_file)) { |
1024
|
0
|
|
|
|
|
0
|
print OFILE generateOutput; |
1025
|
0
|
|
|
|
|
0
|
close OFILE; |
1026
|
0
|
|
|
|
|
0
|
system "xrdb -remove $out_file"; |
1027
|
0
|
0
|
|
|
|
0
|
unlink $out_file if $delete_output; |
1028
|
|
|
|
|
|
|
} |
1029
|
|
|
|
|
|
|
} |
1030
|
|
|
|
|
|
|
|
1031
|
|
|
|
|
|
|
=item B |
1032
|
|
|
|
|
|
|
|
1033
|
|
|
|
|
|
|
=over 4 |
1034
|
|
|
|
|
|
|
|
1035
|
|
|
|
|
|
|
Removes all groups and options. The group 'main' will remain, but all its options are also deleted. |
1036
|
|
|
|
|
|
|
This does not affect the Gtk hash. |
1037
|
|
|
|
|
|
|
|
1038
|
|
|
|
|
|
|
=back |
1039
|
|
|
|
|
|
|
|
1040
|
|
|
|
|
|
|
=cut |
1041
|
|
|
|
|
|
|
|
1042
|
|
|
|
|
|
|
sub resetAll { |
1043
|
2
|
|
|
2
|
1
|
28
|
%groups = ( |
1044
|
|
|
|
|
|
|
main => [[''], {}] |
1045
|
|
|
|
|
|
|
) |
1046
|
|
|
|
|
|
|
} |
1047
|
|
|
|
|
|
|
|
1048
|
|
|
|
|
|
|
=item B(I<$red>, I<$green>, I<$blue>) |
1049
|
|
|
|
|
|
|
|
1050
|
|
|
|
|
|
|
=over 4 |
1051
|
|
|
|
|
|
|
|
1052
|
|
|
|
|
|
|
Converts the decimval values $red, $green and $blue into a hex color string. |
1053
|
|
|
|
|
|
|
|
1054
|
|
|
|
|
|
|
=back |
1055
|
|
|
|
|
|
|
|
1056
|
|
|
|
|
|
|
=cut |
1057
|
|
|
|
|
|
|
|
1058
|
|
|
|
|
|
|
sub rgb2hex { |
1059
|
6
|
|
|
6
|
1
|
278
|
my ($red, $green, $blue) = @_; |
1060
|
6
|
|
|
|
|
9
|
my $r = hexstring($red); |
1061
|
6
|
|
|
|
|
11
|
my $g = hexstring($green); |
1062
|
6
|
|
|
|
|
10
|
my $b = hexstring($blue); |
1063
|
6
|
|
|
|
|
21
|
return "#$r$g$b" |
1064
|
|
|
|
|
|
|
|
1065
|
|
|
|
|
|
|
} |
1066
|
|
|
|
|
|
|
|
1067
|
|
|
|
|
|
|
sub _truncate { |
1068
|
140
|
|
|
140
|
|
198
|
my $name = shift; |
1069
|
140
|
|
|
|
|
206
|
for (@basegtkeys) { |
1070
|
3734
|
|
|
|
|
4477
|
my $key = $_; |
1071
|
3734
|
100
|
|
|
|
6702
|
if (substr($name, 0, length($key)) eq $key) { |
1072
|
140
|
|
|
|
|
259
|
return $key |
1073
|
|
|
|
|
|
|
} |
1074
|
|
|
|
|
|
|
} |
1075
|
0
|
|
|
|
|
|
return $name |
1076
|
|
|
|
|
|
|
} |
1077
|
|
|
|
|
|
|
|
1078
|
|
|
|
|
|
|
=back |
1079
|
|
|
|
|
|
|
|
1080
|
|
|
|
|
|
|
=head1 COPYRIGHT AND LICENSE |
1081
|
|
|
|
|
|
|
|
1082
|
|
|
|
|
|
|
Copyright 2022 by Hans Jeuken |
1083
|
|
|
|
|
|
|
|
1084
|
|
|
|
|
|
|
GPL v3.0 or same as Perl, in your option. |
1085
|
|
|
|
|
|
|
|
1086
|
|
|
|
|
|
|
=head1 AUTHOR |
1087
|
|
|
|
|
|
|
|
1088
|
|
|
|
|
|
|
Hans Jeuken (jeuken dot hans at gmail dot com) |
1089
|
|
|
|
|
|
|
|
1090
|
|
|
|
|
|
|
=head1 BUGS AND CAVEATS |
1091
|
|
|
|
|
|
|
|
1092
|
|
|
|
|
|
|
Exporting to xrdb will not work if the name of your executable/script contains |
1093
|
|
|
|
|
|
|
an extension (.pl). This is a limitation of xrdb. |
1094
|
|
|
|
|
|
|
|
1095
|
|
|
|
|
|
|
If you find any bugs, please contact the author. |
1096
|
|
|
|
|
|
|
|
1097
|
|
|
|
|
|
|
=head1 TODO |
1098
|
|
|
|
|
|
|
|
1099
|
|
|
|
|
|
|
=cut |
1100
|
|
|
|
|
|
|
|
1101
|
|
|
|
|
|
|
|
1102
|
|
|
|
|
|
|
1; |
1103
|
|
|
|
|
|
|
__END__ |