"Fossies" - the Fresh Open Source Software Archive 
Member "xterm-379/vttests/titlestack.pl" (20 Sep 2019, 16362 Bytes) of package /linux/misc/xterm-379.tgz:
As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style:
standard) with prefixed line numbers and
code folding option.
Alternatively you can here
view or
download the uninterpreted source code file.
For more information about "titlestack.pl" see the
Fossies "Dox" file reference documentation.
1 #!/usr/bin/env perl
2 # $XTermId: titlestack.pl,v 1.29 2019/09/20 00:50:10 tom Exp $
3 # -----------------------------------------------------------------------------
4 # this file is part of xterm
5 #
6 # Copyright 2019 by Thomas E. Dickey
7 #
8 # All Rights Reserved
9 #
10 # Permission is hereby granted, free of charge, to any person obtaining a
11 # copy of this software and associated documentation files (the
12 # "Software"), to deal in the Software without restriction, including
13 # without limitation the rights to use, copy, modify, merge, publish,
14 # distribute, sublicense, and/or sell copies of the Software, and to
15 # permit persons to whom the Software is furnished to do so, subject to
16 # the following conditions:
17 #
18 # The above copyright notice and this permission notice shall be included
19 # in all copies or substantial portions of the Software.
20 #
21 # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
22 # OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
23 # MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
24 # IN NO EVENT SHALL THE ABOVE LISTED COPYRIGHT HOLDER(S) BE LIABLE FOR ANY
25 # CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
26 # TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
27 # SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
28 #
29 # Except as contained in this notice, the name(s) of the above copyright
30 # holders shall not be used in advertising or otherwise to promote the
31 # sale, use or other dealings in this Software without prior written
32 # authorization.
33 # -----------------------------------------------------------------------------
34 # Test the title-stack and title-mode options of xterm.
35
36 # TODO: add test for arbitrary x property
37 # TODO: allow -g and -v options to toggle interactively
38
39 use strict;
40 use warnings;
41
42 use Getopt::Std;
43 use Encode qw(decode encode);
44 use Term::ReadKey;
45 use I18N::Langinfo qw(langinfo CODESET);
46
47 our $target = "";
48
49 our $encoding = lc( langinfo( CODESET() ) );
50 our $wm_name;
51 our ( $opt_b, $opt_g, $opt_v, $opt_8 );
52
53 our @titlestack; # stack of title-strings, using current encoding
54 our @item_stack; # selector used when doing a push
55 our @mode_stack; # titleModes in effect when titlestack was loaded
56 our $SP; # stack-pointer
57 our $TM; # current titleModes, in various combinations
58
59 our $utf8_sample = 0;
60
61 our $CSI = "\x1b[";
62 our $OSC = "\x1b]";
63 our $ST = "\x1b\\";
64
65 sub SendHEX() { return ( $TM & 1 ) ? 1 : 0; }
66 sub ReadHEX() { return ( $TM & 2 ) ? 1 : 0; }
67 sub SendUTF8() { return ( $TM & 4 ) ? 1 : 0; }
68 sub ReadUTF8() { return ( $TM & 8 ) ? 1 : 0; }
69
70 sub to_hex($) {
71 my $value = shift;
72 my $result = "";
73 my $n;
74
75 for ( $n = 0 ; $n < length($value) ; ++$n ) {
76 $result .= sprintf( "%02X", ord substr( $value, $n, 1 ) );
77 }
78 return $result;
79 }
80
81 sub from_hex($) {
82 my $value = shift;
83 my $result = "";
84 if ( $value =~ /^[[:xdigit:]]+$/ and ( length($value) % 2 ) == 0 ) {
85 my $octets = "";
86 for ( my $n = 0 ; $n < length($value) ; $n += 2 ) {
87 my $pair = substr( $value, $n, 2 );
88 my $data = hex $pair;
89 $octets .= chr($data);
90 }
91 $result = decode( &ReadUTF8 ? "utf-8" : "iso-8859-1", $octets );
92 }
93 else {
94 $result = $value;
95 }
96 return $result;
97 }
98
99 sub show_string($) {
100 my $value = shift;
101 my $n;
102 my $octets =
103 encode( ( ( $encoding eq "utf-8" ) ? "utf-8" : "iso-8859-1" ), $value );
104
105 my $result = "";
106 for ( $n = 0 ; $n < length($octets) ; $n += 1 ) {
107 my $c = ord substr( $octets, $n, 1 );
108 if ( $c == ord '\\' ) {
109 $result .= "\\\\";
110 }
111 elsif ( $c == 0x1b ) {
112 $result .= "\\E";
113 }
114 elsif ( $c == 0x7f ) {
115 $result .= "^?";
116 }
117 elsif ( $c == 32 ) {
118 $result .= "\\s";
119 }
120 elsif ( $c < 32 ) {
121 $result .= sprintf( "^%c", $c + 64 );
122 }
123 elsif ( $c > 128 ) {
124 $result .= sprintf( "\\%03o", $c );
125 }
126 else {
127 $result .= chr($c);
128 }
129 }
130
131 printf "%s\r\n", $result;
132 }
133
134 sub send_command($) {
135 my $command = shift;
136 if ($opt_v) {
137 printf "send: ";
138 &show_string($command);
139 }
140 print STDERR encode( &SendUTF8 ? "utf-8" : "iso-8859-1", $command );
141 }
142
143 sub get_reply($) {
144 my $command = shift;
145 my $reply = "";
146
147 &send_command($command);
148 my $start = time;
149 while (1) {
150 my $test = ReadKey 1;
151 last if not defined $test;
152 last if ( time > ( $start + 1 ) );
153
154 $reply .= $test;
155 }
156 if ($opt_v) {
157 printf "read: ";
158 &show_string($reply);
159 }
160 return $reply;
161 }
162
163 sub get_title($) {
164 my $icon = shift;
165 my $reply = &get_reply( sprintf( "%s%dt", $CSI, $icon ? 20 : 21 ) );
166 my $prefix = $icon ? "L" : "l";
167
168 if ( $opt_8 and ( $reply =~ /^$CSI/ ) ) {
169 $reply =~ s/^${CSI}//;
170 $reply =~ s/${ST}$//;
171 }
172 else {
173 $reply =~ s/^\x1b//;
174 $reply =~ s/^[\[\]]//;
175 if ( index( $reply, $ST ) >= 0 ) {
176 $reply =~ s/\x1b\\$//;
177 }
178 else {
179 $reply =~ s/\007$//;
180 }
181 }
182 if ( $reply =~ /^$prefix/ ) {
183 $reply =~ s/^$prefix//;
184 if (&ReadHEX) {
185 $reply = &from_hex($reply);
186 }
187 }
188 else {
189 $reply = "?" . $reply;
190 }
191 return $reply;
192 }
193
194 sub raw() {
195 ReadMode 'ultra-raw', 'STDIN'; # allow single-character inputs
196 }
197
198 sub cooked() {
199 ReadMode 'normal';
200 }
201
202 sub read_cmd($) {
203 my $command = shift;
204 my @result;
205 if ( open( my $fp, "$command |" ) ) {
206 binmode( $fp, ":utf8" ) if ( $encoding eq "utf-8" );
207 @result = <$fp>;
208 close($fp);
209 chomp @result;
210 }
211 return @result;
212 }
213
214 sub which_modes($) {
215 my $modes = shift;
216 my $result = "";
217 if ( $modes & 3 ) {
218 $result .= "put" if ( ( $modes & 3 ) == 1 );
219 $result .= "get" if ( ( $modes & 3 ) == 2 );
220 $result .= "p/q" if ( ( $modes & 3 ) == 3 );
221 $result .= " hex";
222 }
223 if ( $modes & 12 ) {
224 $modes /= 4;
225 $result .= "," unless ( $result eq "" );
226 $result .= "put" if ( ( $modes & 3 ) == 1 );
227 $result .= "get" if ( ( $modes & 3 ) == 2 );
228 $result .= "p/q" if ( ( $modes & 3 ) == 3 );
229 $result .= " utf";
230 }
231 $result = "default" if ( $result eq "" );
232 return $result;
233 }
234
235 sub which_tmode($$) {
236 my $set = shift;
237 my $mode = shift;
238 my $result = "";
239 $result = "set window/icon labels using hexadecimal" if ( $mode == 0 );
240 $result = "query window/icon labels using hexadecimal" if ( $mode == 1 );
241 $result = "set window/icon labels using UTF-8" if ( $mode == 2 );
242 $result = "query window/icon labels using UTF-8" if ( $mode == 3 );
243 $result = "do not " . $result if ( $set == 0 and $result ne "" );
244 return $result;
245 }
246
247 sub get_tmode($) {
248 my $set = shift;
249 my $help = 0;
250 my $result = "?";
251 while ( $result !~ /^[0123]$/ ) {
252 $result = ReadKey 0;
253 if ( $result eq "q" ) {
254 $result = -1;
255 last;
256 }
257 elsif ( $result eq "?" and not $help ) {
258 for my $n ( 0 .. 3 ) {
259 printf "\r\n\t%s = %s", $n, &which_tmode( $set, $n );
260 }
261 printf "\r\n\t:";
262 $help = 1;
263 }
264 }
265 if ( $result >= 0 ) {
266 printf "[%s]\r\n\t:", &which_tmode( $set, $result );
267 }
268 return $result;
269 }
270
271 sub which_item($) {
272 my $code = shift;
273 my $result = "";
274 $result = "both" if ( $code == 0 );
275 $result = "icon" if ( $code == 1 );
276 $result = "name" if ( $code == 2 );
277 return $result;
278 }
279
280 sub which_selector($) {
281 my $code = shift;
282 my $result = "";
283 $result = "both titles" if ( $code == 0 );
284 $result = "icon title" if ( $code == 1 );
285 $result = "window title" if ( $code == 2 );
286 return $result;
287 }
288
289 sub get_selector() {
290 my $result = "?";
291 my $help = 0;
292 printf "\t:";
293 while ( $result !~ /^[012]$/ ) {
294 $result = ReadKey 0;
295 if ( $result eq "q" ) {
296 $result = -1;
297 last;
298 }
299 elsif ( $result eq "l" ) {
300 $result = 2;
301 }
302 elsif ( $result eq "L" ) {
303 $result = 1;
304 }
305 elsif ( $result eq "?" and not $help ) {
306 for my $n ( 0 .. 2 ) {
307 printf "\r\n\t%d = %s", $n, &which_selector($n);
308 }
309 printf "\r\n\t:";
310 $help = 1;
311 }
312 }
313 if ( $result >= 0 ) {
314 printf "[%s]\r\n\t:", &which_selector($result);
315 }
316 return $result;
317 }
318
319 sub display_info() {
320
321 # use xprop to get properties
322 my $command = "xprop";
323 if ( $ENV{WINDOWID} ) {
324 my $windowid = $ENV{WINDOWID};
325 $command .= " -id " . $windowid if ( $windowid ne "" );
326 }
327 else {
328 printf "...xprop\r\n";
329 }
330 my @props = &read_cmd($command);
331 for my $n ( 0 .. $#props ) {
332 printf "\t%s\r\n", $props[$n]
333 if ( index( $props[$n], "WM_NAME(" ) >= 0
334 or index( $props[$n], "WM_ICON_NAME(" ) >= 0 );
335 }
336
337 # use escape sequences to get corresponding information
338 printf "... Icon title:%s\r\n", &get_title(1);
339 printf "... Window title:%s\r\n", &get_title(0);
340
341 # show title-stack (and modes used for each level)
342 printf "... Modes[%s]\r\n", &which_modes($TM);
343 printf "... Stack(%d):\r\n", $SP;
344 for my $n ( 0 .. $SP ) {
345 printf "\t%d [%s:%s]%s\r\n", $n, &which_item( $item_stack[$n] ),
346 &which_modes( $mode_stack[$n] ), $titlestack[$n];
347 }
348 }
349
350 sub set_titlemode($) {
351 my $set = shift;
352 my $opts = "";
353 my $opt;
354 printf "\t:";
355 while ( ( $opt = &get_tmode($set) ) >= 0 ) {
356 $TM |= ( 1 << $opt ) if ($set);
357 $TM &= ~( 1 << $opt ) unless ($set);
358 $opts .= ";" unless ( $opts eq "" );
359 $opts .= $opt;
360 }
361 if ( $opts ne "" ) {
362 &send_command( sprintf( "%s>%s%s", $CSI, $opts, $set ? "t" : "T" ) );
363 }
364 }
365
366 sub utf8_sample($) {
367 my $item = shift;
368 my $last = 4;
369 my $text;
370 if ( ( $item % $last ) == 0 ) {
371 my $chars = "THE QUICK BROWN FOX\nJUMPED OVER THE LAZY DOG";
372 $text = "";
373 for my $n ( 0 .. length($chars) ) {
374 my $chr = substr( $chars, $n, 1 );
375 if ( $chr eq " " ) {
376 $chr = " ";
377 }
378 elsif ( ord($chr) < 32 ) {
379
380 # leave control characters as-is
381 }
382 else {
383 $chr = chr( 0xff00 + ord($chr) - 32 );
384 }
385 $text .= $chr;
386 }
387 }
388 elsif ( ( $item % $last ) == 1 ) {
389 $text = chr(0x442) . chr(0x435) . chr(0x441) . chr(0x442);
390 }
391 elsif ( ( $item % $last ) == 2 ) {
392 for my $chr ( 0x391 .. 0x3a9 ) {
393 $text .= chr($chr);
394 }
395 }
396 elsif ( ( $item % $last ) == 3 ) {
397 for my $chr ( 0x3b1 .. 0x3c9 ) {
398 $text .= chr($chr);
399 }
400 }
401 return $text;
402 }
403
404 sub set_titletext() {
405 my $opt = &get_selector;
406 if ( $opt >= 0 ) {
407 my $text;
408 if ($opt_g) {
409
410 if (&SendUTF8) {
411 $text = &utf8_sample( $utf8_sample++ );
412 }
413 else {
414 # ugly code, but mapping the a/e/i/o/u uppercase accented
415 # characters that repeat.
416 my $a_chars = chr(192) . chr(193) . chr(194) . chr(196);
417 my $e_chars = "";
418 my $i_chars = " ";
419 my $o_chars = chr(210) . chr(211) . chr(212) . chr(214);
420 my $u_chars = "";
421 my $gap = " " . chr(215) . " ";
422 for my $chr ( 0 .. 3 ) {
423 $e_chars .= chr( $chr + 200 );
424 $i_chars .= chr( $chr + 204 ) . " ";
425 $u_chars .= chr( $chr + 217 );
426 }
427 $text =
428 $a_chars
429 . $gap
430 . $e_chars
431 . $gap
432 . $i_chars
433 . $gap
434 . $o_chars
435 . $gap
436 . $u_chars;
437 }
438 printf "%s\r\n", $text;
439 }
440 else {
441 &cooked;
442 $text = ReadLine 0;
443 chomp $text;
444 &raw;
445 }
446 $titlestack[$SP] = $text;
447 $item_stack[$SP] = $opt;
448 $mode_stack[$SP] = $TM;
449 if (&SendHEX) {
450 my $octets =
451 encode( ( &SendUTF8 ? "utf-8" : "iso-8859-1" ), $text );
452 $text = &to_hex($octets);
453 }
454 &send_command( sprintf( "%s%s;%s%s", $OSC, $opt, $text, $ST ) );
455 }
456 }
457
458 sub save_title() {
459 my $opt = &get_selector;
460 if ( $opt >= 0 ) {
461 &send_command( sprintf( "%s22;%st", $CSI, $opt ) );
462 ++$SP;
463 $titlestack[$SP] = $titlestack[ $SP - 1 ];
464 $item_stack[$SP] = $opt;
465 $mode_stack[$SP] = $mode_stack[ $SP - 1 ];
466 }
467 }
468
469 sub restore_title($) {
470 my $set = shift;
471 my $opt = &get_selector unless ($set);
472 if ( $opt >= 0 and $SP > 0 ) {
473 $opt = $item_stack[$SP] if ($set);
474 &send_command( sprintf( "%s23;%st", $CSI, $opt ) );
475 $SP--;
476 }
477 }
478
479 sub get_xprop($$) {
480 my $id = shift;
481 my $name = shift;
482 my @data = &read_cmd("xprop -id $id");
483 my $prop = "";
484 for my $n ( 0 .. $#data ) {
485 if ( $data[$n] =~ /$name\([^)]+\) =/ ) {
486 $prop = $data[$n];
487 $prop =~ s/^[^=]*=\s*//;
488 $prop =~ s/"//g;
489 last;
490 }
491 }
492 return $prop;
493 }
494
495 sub get_WM_NAME() {
496 $wm_name = "missing WM_NAME";
497 my $supwin = `xprop -root '_NET_SUPPORTING_WM_CHECK'`;
498 if ( $supwin ne "" ) {
499 $supwin =~ s/^.*(0x[[:xdigit:]]+).*/$1/;
500 $wm_name = &get_xprop( $supwin, "_NET_WM_NAME" );
501 $wm_name = "unknown" if ( $wm_name eq "" );
502 printf "** using \"$wm_name\" window manager\n";
503 }
504 }
505
506 sub main::HELP_MESSAGE() {
507 printf STDERR <<EOF
508 Usage: $0 [options]
509 Options:
510 -8 use 8-bit controls
511 -b use BEL rather than ST for terminating strings
512 -g generate title-strings rather than prompting
513 -v verbose
514 EOF
515 ;
516 exit 1;
517 }
518
519 $Getopt::Std::STANDARD_HELP_VERSION = 1;
520 &getopts('bgv8') || &main::HELP_MESSAGE;
521
522 $ST = "\007" if ($opt_b);
523
524 $titlestack[ $SP = 0 ] = "unknown";
525 $item_stack[$SP] = 0;
526 $mode_stack[$SP] = $TM = 0;
527
528 binmode( STDOUT, ":utf8" ) if ( $encoding eq "utf-8" );
529 if ($opt_8) {
530 if ( $encoding eq "utf-8" ) {
531 undef $opt_8;
532 printf "...ignoring -8 option since locale uses %s\n", $encoding;
533 }
534 else {
535 printf STDERR "\x1b G";
536 $CSI = "\x9b";
537 $OSC = "\x9d";
538 $ST = "\x9c";
539 }
540 }
541
542 &get_WM_NAME;
543
544 &raw;
545 &raw;
546 while (1) {
547 my $cmd;
548
549 printf "\r\nCommand (? for help):";
550 $cmd = ReadKey 0;
551 if ( not $cmd ) {
552 sleep 1;
553 }
554 elsif ( $cmd eq "?" ) {
555 printf "\r\n? help,"
556 . " d=display,"
557 . " m/M=set/reset mode,"
558 . " p=set title,"
559 . " q=quit,"
560 . " r=restore,"
561 . " s=save\r\n";
562 }
563 elsif ( $cmd eq "#" ) {
564 printf " ...comment\r\n\t#";
565 &cooked;
566 ReadLine 0;
567 &raw;
568 }
569 elsif ( $cmd eq "!" ) {
570 printf " ...shell\r\n";
571 &cooked;
572 system( $ENV{SHELL} );
573 &raw;
574 }
575 elsif ( $cmd eq "d" ) {
576 printf " ...display\r\n";
577 &display_info;
578 }
579 elsif ( $cmd eq "p" ) {
580 printf " ...set text\r\n";
581 &set_titletext;
582 }
583 elsif ( $cmd eq "q" ) {
584 printf " ...quit\r\n";
585 last;
586 }
587 elsif ( $cmd eq "s" ) {
588 printf " ...save title\r\n";
589 &save_title;
590 }
591 elsif ( $cmd eq "r" ) {
592 printf " ...restore title\r\n";
593 &restore_title(0);
594 }
595 elsif ( $cmd eq "m" ) {
596 printf " ...set title mode\r\n";
597 &set_titlemode(1);
598 }
599 elsif ( $cmd eq "M" ) {
600 printf " ...reset title mode\r\n";
601 &set_titlemode(0);
602 }
603 }
604
605 # when unstacking here, just use the selector used for the push
606 while ( $SP > 0 ) {
607 &restore_title(1);
608 }
609
610 &send_command( sprintf( "%s>T", $CSI ) ); # reset title-modes to default
611
612 &cooked;
613
614 printf "\x1b F" if ($opt_8);