File Coverage

blib/lib/Term/ExtendedColor/Xresources.pm
Criterion Covered Total %
statement 24 94 25.5
branch 0 30 0.0
condition 0 3 0.0
subroutine 8 12 66.6
pod 4 4 100.0
total 36 143 25.1


line stmt bran cond sub pod time code
1             #!/usr/bin/perl
2             package Term::ExtendedColor::Xresources;
3 1     1   78641 use strict;
  1         2  
  1         24  
4 1     1   5 use warnings;
  1         1  
  1         24  
5              
6             BEGIN {
7 1     1   4 use Exporter;
  1         2  
  1         30  
8 1     1   4 use vars qw($VERSION @ISA @EXPORT_OK);
  1         2  
  1         78  
9              
10 1     1   3 $VERSION = '0.082';
11 1         18 @ISA = qw(Exporter);
12 1         26 @EXPORT_OK = qw(
13             set_xterm_color
14             get_xterm_color
15             get_xterm_colors
16              
17             set_background_color
18             set_foreground_color
19             );
20             }
21              
22 1     1   5 use Carp qw(croak);
  1         2  
  1         45  
23 1     1   434 use Term::ReadKey;
  1         1571  
  1         71  
24              
25             {
26 1     1   6 no warnings;
  1         2  
  1         748  
27             *get_xterm_color = *get_xterm_colors;
28             }
29              
30             sub get_xterm_colors {
31 0     0 1   my $arg = shift;
32              
33 0 0         my $index = (exists($arg->{index})) ? $arg->{index} : [0 .. 255];
34              
35 0           my @indexes;
36              
37 0 0         if(ref($index) eq 'ARRAY') {
    0          
38 0           push(@indexes, @{$index});
  0            
39             }
40             elsif(ref($index) eq '') {
41 0           push(@indexes, $index);
42             }
43              
44 0 0         if( grep { $_ < 0 } @indexes ) {
  0            
45 0           croak("Index must be a value within 0 .. 255, inclusive\n");
46             }
47              
48 0 0         open(my $tty, '<', '/dev/tty') or croak("Can not open /dev/tty: $!\n");
49              
50 0           my $colors;
51 0           for my $i(@indexes) {
52 0 0         next if not defined $i;
53              
54 0           ReadMode('raw', $tty);
55              
56 0           print "\e]4;$i;?\a"; # the '?' indicates a query
57              
58 0           my $response = '';
59 0           my ($r, $g, $b);
60 0           while(1) {
61 0 0         if ($response =~ m[ rgb: (.{4}) / (.{4}) / (.{4}) ]x) {
62 0           ($r, $g, $b) = map { substr $_, 0, 2 } ($1, $2, $3);
  0            
63 0           last;
64             }
65             else {
66 0           $response .= ReadKey(0, $tty);
67             }
68             }
69              
70 0           ReadMode('normal');
71              
72 0           $colors->{$i}->{raw} = $response;
73             # Return in base 10 by default
74 0 0         if($arg->{type} eq 'hex') {
75 0           $colors->{$i}->{red} = $r; # ff
76 0           $colors->{$i}->{green} = $g;
77 0           $colors->{$i}->{blue} = $b;
78 0           $colors->{$i}->{rgb} = "$r$g$b";
79             }
80             else {
81 0           ($r, $g, $b) = (hex($r), hex($g), hex($b));
82              
83 0           $colors->{$i}->{red} = $r; # 255
84 0           $colors->{$i}->{green} = $g;
85 0           $colors->{$i}->{blue} = $b;
86 0           $colors->{$i}->{rgb} = "$r/$g/$b"; # 255/255/0
87             }
88              
89 0           $colors->{$i}{r} = $colors->{$i}{red};
90 0           $colors->{$i}{g} = $colors->{$i}{green};
91 0           $colors->{$i}{b} = $colors->{$i}{blue};
92             }
93 0           return $colors;
94             }
95              
96             sub set_xterm_color {
97             # color => index
98 0     0 1   my $old_colors = shift;
99              
100 0 0         if(ref($old_colors) ne 'HASH') {
101 0           croak("Hash reference expected");
102             }
103              
104 0           my %new_colors;
105              
106 0           for my $index(keys(%{ $old_colors })) {
  0            
107 0 0 0       if( ($index < 0) or ($index > 255) ) {
108 0           next;
109             }
110 0 0         if($old_colors->{$index} !~ /^[A-Fa-f0-9]{6}$/) {
111 0           next;
112             }
113              
114 0           my($r, $g, $b) = $old_colors->{$index} =~ m/(..)/g;
115              
116              
117 0           my $term = $ENV{TERM};
118              
119             # This is for GNU Screen and Tmux
120             # Tmux identifies itself as GNU Screen
121             # "\eP\e]4;198;rgb:50/20/40\a\e\\"
122              
123             # echo -e "\033]12;green\007" should change the cursor color, but inside of
124             # screen, you have to wrap all that with "\eP" and "\a\e\\"
125              
126 0 0         if($term =~ m/^screen/) {
127 0           $new_colors{ $index } = "\eP\e]4;$index;rgb:$r/$g/$b\a\e\\";
128             }
129             else {
130 0           $new_colors{ $index } = "\e]4;$index;rgb:$r/$g/$b\e\\"
131             }
132             }
133 0 0         if(!defined( wantarray() )) {
134 0           print for values %new_colors;
135             }
136             else {
137 0           return \%new_colors;
138             }
139             }
140              
141             sub set_background_color {
142 0     0 1   my $color = shift;
143 0           $color =~ s/^#//g;
144              
145 0           my $esc = "\e]11;#$color\007";
146              
147 0 0         if(!defined( wantarray() )) {
148 0           print $esc;
149             }
150             else {
151 0           return $esc;
152             }
153             }
154              
155             sub set_foreground_color {
156 0     0 1   my $color = shift;
157 0           $color =~ s/^#//g;
158              
159 0           my $esc = "\e]10;#$color\007";
160              
161 0 0         if(!defined( wantarray() )) {
162 0           print $esc;
163             }
164             else {
165 0           return $esc;
166             }
167             }
168              
169             1;
170              
171             __END__