titlestack.pl revision a5ae21e4 
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
39use strict;
40use warnings;
41
42use Getopt::Std;
43use Encode qw(decode encode);
44use Term::ReadKey;
45use I18N::Langinfo qw(langinfo CODESET);
46
47our $target = "";
48
49our $encoding = lc( langinfo( CODESET() ) );
50our $wm_name;
51our ( $opt_b, $opt_g, $opt_v, $opt_8 );
52
53our @titlestack;    # stack of title-strings, using current encoding
54our @item_stack;    # selector used when doing a push
55our @mode_stack;    # titleModes in effect when titlestack was loaded
56our $SP;            # stack-pointer
57our $TM;            # current titleModes, in various combinations
58
59our $utf8_sample = 0;
60
61our $CSI = "\x1b[";
62our $OSC = "\x1b]";
63our $ST  = "\x1b\\";
64
65sub SendHEX()  { return ( $TM & 1 ) ? 1 : 0; }
66sub ReadHEX()  { return ( $TM & 2 ) ? 1 : 0; }
67sub SendUTF8() { return ( $TM & 4 ) ? 1 : 0; }
68sub ReadUTF8() { return ( $TM & 8 ) ? 1 : 0; }
69
70sub 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
81sub 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
99sub 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
134sub 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
143sub 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
163sub 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
194sub raw() {
195    ReadMode 'ultra-raw', 'STDIN';    # allow single-character inputs
196}
197
198sub cooked() {
199    ReadMode 'normal';
200}
201
202sub 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
214sub 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
235sub 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
247sub 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
271sub 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
280sub 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
289sub 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
319sub 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
350sub 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
366sub 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
404sub 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
458sub 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
469sub 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
479sub 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
495sub 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
506sub main::HELP_MESSAGE() {
507    printf STDERR <<EOF
508Usage: $0 [options]
509Options:
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
514EOF
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
528binmode( STDOUT, ":utf8" ) if ( $encoding eq "utf-8" );
529if ($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;
546while (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
606while ( $SP > 0 ) {
607    &restore_title(1);
608}
609
610&send_command( sprintf( "%s>T", $CSI ) );    # reset title-modes to default
611
612&cooked;
613
614printf "\x1b F" if ($opt_8);
615