File Coverage

blib/lib/Tk/GtkSettings.pm
Criterion Covered Total %
statement 216 269 80.3
branch 78 162 48.1
condition 1 3 33.3
subroutine 30 39 76.9
pod 34 34 100.0
total 359 507 70.8


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__