1#!/usr/bin/env perl
2# $XTermId: titlestack.pl,v 1.35 2024/11/29 01:09:46 tom Exp $
3# -----------------------------------------------------------------------------
4# this file is part of xterm
5#
6# Copyright 2019,2024 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_c, $opt_g, $opt_l, $opt_s, $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 $SQ = 10;       # stack-limit
58our $TM;            # current titleModes, in various combinations
59our @cmd_buffer;    # command-input
60our $cmd_index;     # current index in $cmd_buffer[]
61our $log_fp;        # logging-output
62
63our $utf8_sample = 0;
64
65our $CSI = "\x1b[";
66our $DCS = "\x1bP";
67our $OSC = "\x1b]";
68our $ST  = "\x1b\\";
69
70sub SendHEX()  { return ( $TM & 1 ) ? 1 : 0; }
71sub ReadHEX()  { return ( $TM & 2 ) ? 1 : 0; }
72sub SendUTF8() { return ( $TM & 4 ) ? 1 : 0; }
73sub ReadUTF8() { return ( $TM & 8 ) ? 1 : 0; }
74
75sub to_hex($) {
76    my $value  = shift;
77    my $result = "";
78    my $n;
79
80    for ( $n = 0 ; $n < length($value) ; ++$n ) {
81        $result .= sprintf( "%02X", ord substr( $value, $n, 1 ) );
82    }
83    return $result;
84}
85
86sub from_hex($) {
87    my $value  = shift;
88    my $result = "";
89    if ( $value =~ /^[[:xdigit:]]+$/ and ( length($value) % 2 ) == 0 ) {
90        my $octets = "";
91        for ( my $n = 0 ; $n < length($value) ; $n += 2 ) {
92            my $pair = substr( $value, $n, 2 );
93            my $data = hex $pair;
94            $octets .= chr($data);
95        }
96        $result = decode( &ReadUTF8 ? "utf-8" : "iso-8859-1", $octets );
97    }
98    else {
99        $result = $value;
100    }
101    return $result;
102}
103
104sub show_string($) {
105    my $value = shift;
106    my $n;
107    my $octets =
108      encode( ( ( $encoding eq "utf-8" ) ? "utf-8" : "iso-8859-1" ), $value );
109
110    my $result = "";
111    for ( $n = 0 ; $n < length($octets) ; $n += 1 ) {
112        my $c = ord substr( $octets, $n, 1 );
113        if ( $c == ord '\\' ) {
114            $result .= "\\\\";
115        }
116        elsif ( $c == 0x1b ) {
117            $result .= "\\E";
118        }
119        elsif ( $c == 0x7f ) {
120            $result .= "^?";
121        }
122        elsif ( $c == 32 ) {
123            $result .= "\\s";
124        }
125        elsif ( $c < 32 ) {
126            $result .= sprintf( "^%c", $c + 64 );
127        }
128        elsif ( $c > 128 ) {
129            $result .= sprintf( "\\%03o", $c );
130        }
131        else {
132            $result .= chr($c);
133        }
134    }
135
136    printf "%s\r\n", $result;
137}
138
139sub send_command($) {
140    my $command = shift;
141    if ($opt_v) {
142        printf "send: ";
143        &show_string($command);
144    }
145    print STDERR encode( &SendUTF8 ? "utf-8" : "iso-8859-1", $command );
146}
147
148sub get_reply($) {
149    my $command = shift;
150    my $reply   = "";
151
152    &send_command($command);
153    my $start = time;
154    while (1) {
155        my $test = ReadKey 1;
156        last if not defined $test;
157        last if ( time > ( $start + 1 ) );
158
159        $reply .= $test;
160    }
161    if ($opt_v) {
162        printf "read: ";
163        &show_string($reply);
164    }
165    return $reply;
166}
167
168sub get_level() {
169    my $reply = &get_reply( sprintf( "%s#S", $CSI ) );
170    if ( index( $reply, $CSI ) == 0 ) {
171        $reply = substr( $reply, length($CSI) );
172        if ( $reply =~ /^\d+;\d+#S$/ ) {
173            $reply =~ s/#S//;
174            my @params = split /;/, $reply;
175            $SP = $params[0];
176            $SQ = $params[1];
177        }
178    }
179}
180
181sub get_titlemodes() {
182    my $reply  = &get_reply( sprintf( "%s\$q>t%s", $DCS, $ST ) );
183    my $prefix = "${DCS}1\$r";
184    my $p      = index( $reply, $prefix );
185    my $q      = index( $reply, $ST );
186    my $r      = length($reply) - length($ST);
187    if ( $p == 0 and $q == $r ) {
188        $reply = substr( $reply, 0, $q );
189        $reply = substr( $reply, length($prefix) );
190        if ( $reply =~ /^>(\d;)*\dt$/ ) {
191            $reply =~ s/^.(.+).$/$1/;
192            my @modes = split /;/, $reply;
193            $TM = 0;
194            for my $n ( 0 .. $#modes ) {
195                $TM += ( 1 << $n ) if ( $modes[$n] != 0 );
196            }
197        }
198    }
199}
200
201sub get_title($) {
202    my $icon   = shift;
203    my $reply  = &get_reply( sprintf( "%s%dt", $CSI, $icon ? 20 : 21 ) );
204    my $prefix = $icon ? "L" : "l";
205
206    if ( $opt_8 and ( $reply =~ /^$CSI/ ) ) {
207        $reply =~ s/^${CSI}//;
208        $reply =~ s/${ST}$//;
209    }
210    else {
211        $reply =~ s/^\x1b//;
212        $reply =~ s/^[\[\]]//;
213        if ( index( $reply, $ST ) >= 0 ) {
214            $reply =~ s/\x1b\\$//;
215        }
216        else {
217            $reply =~ s/\007$//;
218        }
219    }
220    if ( $reply =~ /^$prefix/ ) {
221        $reply =~ s/^$prefix//;
222        if (&ReadHEX) {
223            $reply = &from_hex($reply);
224        }
225    }
226    else {
227        $reply = "?" . $reply;
228    }
229    return $reply;
230}
231
232sub raw() {
233    ReadMode 'ultra-raw', 'STDIN';    # allow single-character inputs
234}
235
236sub cooked() {
237    ReadMode 'normal';
238}
239
240sub get_cmd() {
241    my $result;
242    select( undef, undef, undef, $opt_s );
243    if ( $cmd_index <= $#cmd_buffer ) {
244        $result = $cmd_buffer[ $cmd_index++ ];
245    }
246    else {
247        $result = "q";
248    }
249    return $result;
250}
251
252sub get_char() {
253    my $result;
254    if ($opt_c) {
255        $result = &get_cmd();
256        if ( index( $result, "char:" ) == 0 ) {
257            $result = substr( $result, 5 );
258        }
259        else {
260            $result = "q";
261        }
262    }
263    else {
264        $result = ReadKey 0;
265    }
266    printf $log_fp "char:%s\n", $result if ($opt_l);
267    return $result;
268}
269
270sub get_line() {
271    my $result;
272    if ($opt_c) {
273        $result = &get_cmd();
274        if ( index( $result, "line:" ) == 0 ) {
275            $result = substr( $result, 5 );
276        }
277        else {
278            $result = "";
279        }
280    }
281    else {
282        &cooked;
283        $result = ReadLine 0;
284        chomp $result;
285        &raw;
286    }
287    printf $log_fp "line:%s\n", $result if ($opt_l);
288    return $result;
289}
290
291sub read_cmd($) {
292    my $command = shift;
293    my @result;
294    if ( open( my $fp, "$command |" ) ) {
295        binmode( $fp, ":utf8" ) if ( $encoding eq "utf-8" );
296        @result = <$fp>;
297        close($fp);
298        chomp @result;
299    }
300    return @result;
301}
302
303sub which_modes($) {
304    my $modes  = shift;
305    my $result = "";
306    if ( $modes & 3 ) {
307        $result .= "put" if ( ( $modes & 3 ) == 1 );
308        $result .= "get" if ( ( $modes & 3 ) == 2 );
309        $result .= "p/q" if ( ( $modes & 3 ) == 3 );
310        $result .= " hex";
311    }
312    if ( $modes & 12 ) {
313        $modes /= 4;
314        $result .= "," unless ( $result eq "" );
315        $result .= "put" if ( ( $modes & 3 ) == 1 );
316        $result .= "get" if ( ( $modes & 3 ) == 2 );
317        $result .= "p/q" if ( ( $modes & 3 ) == 3 );
318        $result .= " utf";
319    }
320    $result = "default" if ( $result eq "" );
321    return $result;
322}
323
324sub which_tmode($$) {
325    my $set    = shift;
326    my $mode   = shift;
327    my $result = "";
328    $result = "set window/icon labels using hexadecimal"   if ( $mode == 0 );
329    $result = "query window/icon labels using hexadecimal" if ( $mode == 1 );
330    $result = "set window/icon labels using UTF-8"         if ( $mode == 2 );
331    $result = "query window/icon labels using UTF-8"       if ( $mode == 3 );
332    $result = "do not " . $result if ( $set == 0 and $result ne "" );
333    return $result;
334}
335
336sub get_tmode($) {
337    my $set    = shift;
338    my $help   = 0;
339    my $result = "?";
340    while ( $result !~ /^[0123]$/ ) {
341        $result = &get_char;
342        if ( $result eq "q" ) {
343            $result = -1;
344            last;
345        }
346        elsif ( $result eq "?" and not $help ) {
347            for my $n ( 0 .. 3 ) {
348                printf "\r\n\t%s = %s", $n, &which_tmode( $set, $n );
349            }
350            printf "\r\n\t:";
351            $help = 1;
352        }
353    }
354    if ( $result >= 0 ) {
355        printf "[%s]\r\n\t:", &which_tmode( $set, $result );
356    }
357    return $result;
358}
359
360sub which_item($) {
361    my $code   = shift;
362    my $result = "";
363    $result = "both" if ( $code == 0 );
364    $result = "icon" if ( $code == 1 );
365    $result = "name" if ( $code == 2 );
366    return $result;
367}
368
369sub which_selector($) {
370    my $code   = shift;
371    my $result = "";
372    $result = "both titles"  if ( $code == 0 );
373    $result = "icon title"   if ( $code == 1 );
374    $result = "window title" if ( $code == 2 );
375    return $result;
376}
377
378sub get_selector() {
379    my $result = "?";
380    my $help   = 0;
381    printf "\t:";
382    while ( $result !~ /^[012]$/ ) {
383        $result = &get_char;
384        if ( $result eq "q" ) {
385            $result = -1;
386            last;
387        }
388        elsif ( $result eq "l" ) {
389            $result = 2;
390        }
391        elsif ( $result eq "L" ) {
392            $result = 1;
393        }
394        elsif ( $result eq "?" and not $help ) {
395            for my $n ( 0 .. 2 ) {
396                printf "\r\n\t%d = %s", $n, &which_selector($n);
397            }
398            printf "\r\n\t:";
399            $help = 1;
400        }
401    }
402    if ( $result >= 0 ) {
403        printf "[%s]\r\n\t:", &which_selector($result);
404    }
405    return $result;
406}
407
408sub display_info() {
409
410    # use xprop to get properties
411    my $command = "xprop";
412    if ( $ENV{WINDOWID} ) {
413        my $windowid = $ENV{WINDOWID};
414        $command .= " -id " . $windowid if ( $windowid ne "" );
415    }
416    else {
417        printf "...xprop\r\n";
418    }
419    my @props = &read_cmd($command);
420    for my $n ( 0 .. $#props ) {
421        printf "\t%s\r\n", $props[$n]
422          if ( index( $props[$n], "WM_NAME(" ) >= 0
423            or index( $props[$n], "WM_ICON_NAME(" ) >= 0 );
424    }
425
426    # use escape sequences to get corresponding information
427    printf "... Icon title:%s\r\n",   &get_title(1);
428    printf "... Window title:%s\r\n", &get_title(0);
429
430    # show title-stack (and modes used for each level)
431    printf "... Modes[%s]\r\n",  &which_modes($TM);
432    printf "... Stack(%d):\r\n", $SP;
433    for my $n ( 0 .. $SP ) {
434        printf "\t%d [%s:%s]%s\r\n", $n, &which_item( $item_stack[$n] ),
435          &which_modes( $mode_stack[$n] ), $titlestack[$n];
436    }
437}
438
439sub set_titlemode($) {
440    my $set  = shift;
441    my $opts = "";
442    my $opt;
443    printf "\t:";
444    while ( ( $opt = &get_tmode($set) ) >= 0 ) {
445        $TM |= ( 1 << $opt ) if ($set);
446        $TM &= ~( 1 << $opt ) unless ($set);
447        $opts .= ";" unless ( $opts eq "" );
448        $opts .= $opt;
449    }
450    if ( $opts ne "" ) {
451        &send_command( sprintf( "%s>%s%s", $CSI, $opts, $set ? "t" : "T" ) );
452    }
453
454    if ($opt_l) {
455        my $save = $TM;
456        &get_titlemodes;
457
458        if ( $TM != $save ) {
459            printf $log_fp "note: expected title-modes $save, got $TM\n";
460        }
461    }
462}
463
464sub utf8_sample($) {
465    my $item = shift;
466    my $last = 4;
467    my $text;
468    if ( ( $item % $last ) == 0 ) {
469        my $chars = "THE QUICK BROWN FOX\nJUMPED OVER THE LAZY DOG";
470        $text = "";
471        for my $n ( 0 .. length($chars) ) {
472            my $chr = substr( $chars, $n, 1 );
473            if ( $chr eq " " ) {
474                $chr = "  ";
475            }
476            elsif ( ord($chr) < 32 ) {
477
478                # leave control characters as-is
479            }
480            else {
481                $chr = chr( 0xff00 + ord($chr) - 32 );
482            }
483            $text .= $chr;
484        }
485    }
486    elsif ( ( $item % $last ) == 1 ) {
487        $text = chr(0x442) . chr(0x435) . chr(0x441) . chr(0x442);
488    }
489    elsif ( ( $item % $last ) == 2 ) {
490        for my $chr ( 0x391 .. 0x3a9 ) {
491            $text .= chr($chr);
492        }
493    }
494    elsif ( ( $item % $last ) == 3 ) {
495        for my $chr ( 0x3b1 .. 0x3c9 ) {
496            $text .= chr($chr);
497        }
498    }
499    return $text;
500}
501
502sub set_titletext() {
503    my $opt = &get_selector;
504    if ( $opt >= 0 ) {
505        my $text;
506        if ($opt_g) {
507
508            if (&SendUTF8) {
509                $text = &utf8_sample( $utf8_sample++ );
510            }
511            else {
512                # ugly code, but mapping the a/e/i/o/u uppercase accented
513                # characters that repeat.
514                my $a_chars = chr(192) . chr(193) . chr(194) . chr(196);
515                my $e_chars = "";
516                my $i_chars = " ";
517                my $o_chars = chr(210) . chr(211) . chr(212) . chr(214);
518                my $u_chars = "";
519                my $gap     = " " . chr(215) . " ";
520                for my $chr ( 0 .. 3 ) {
521                    $e_chars .= chr( $chr + 200 );
522                    $i_chars .= chr( $chr + 204 ) . " ";
523                    $u_chars .= chr( $chr + 217 );
524                }
525                $text =
526                    $a_chars
527                  . $gap
528                  . $e_chars
529                  . $gap
530                  . $i_chars
531                  . $gap
532                  . $o_chars
533                  . $gap
534                  . $u_chars;
535            }
536            &cooked;
537            printf "%s\r\n", $text;
538            &raw;
539        }
540        else {
541            $text = &get_line;
542        }
543        $titlestack[$SP] = $text;
544        $item_stack[$SP] = $opt;
545        $mode_stack[$SP] = $TM;
546        if (&SendHEX) {
547            my $octets =
548              encode( ( &SendUTF8 ? "utf-8" : "iso-8859-1" ), $text );
549            $text = &to_hex($octets);
550        }
551        &send_command( sprintf( "%s%s;%s%s", $OSC, $opt, $text, $ST ) );
552    }
553}
554
555sub save_title() {
556    my $opt = &get_selector;
557    if ( $opt >= 0 ) {
558        &send_command( sprintf( "%s22;%st", $CSI, $opt ) );
559        ++$SP;
560        $titlestack[$SP] = $titlestack[ $SP - 1 ];
561        $item_stack[$SP] = $opt;
562        $mode_stack[$SP] = $mode_stack[ $SP - 1 ];
563    }
564}
565
566sub restore_title($) {
567    my $set = shift;
568    my $opt = &get_selector unless ($set);
569    if ( $opt >= 0 and $SP > 0 ) {
570        $opt = $item_stack[$SP] if ($set);
571        &send_command( sprintf( "%s23;%st", $CSI, $opt ) );
572        $SP--;
573    }
574}
575
576sub get_xprop($$) {
577    my $id   = shift;
578    my $name = shift;
579    my @data = &read_cmd("xprop -id $id");
580    my $prop = "";
581    for my $n ( 0 .. $#data ) {
582        if ( $data[$n] =~ /$name\([^)]+\) =/ ) {
583            $prop = $data[$n];
584            $prop =~ s/^[^=]*=\s*//;
585            $prop =~ s/"//g;
586            last;
587        }
588    }
589    return $prop;
590}
591
592sub get_WM_NAME() {
593    $wm_name = "missing WM_NAME";
594    my $supwin = `xprop -root '_NET_SUPPORTING_WM_CHECK'`;
595    if ( $supwin ne "" ) {
596        $supwin =~ s/^.*(0x[[:xdigit:]]+).*/$1/;
597        $wm_name = &get_xprop( $supwin, "_NET_WM_NAME" );
598        $wm_name = "unknown" if ( $wm_name eq "" );
599        printf "** using \"$wm_name\" window manager\n";
600    }
601}
602
603sub main::HELP_MESSAGE() {
604    printf STDERR <<EOF
605Usage: $0 [options]
606Options:
607  -8      use 8-bit controls
608  -b      use BEL rather than ST for terminating strings
609  -c FILE read commands from this file.
610  -g      generate title-strings rather than prompting
611  -l FILE log commands to this file.
612  -s SECS sleep this long each time a command is read from file
613  -v      verbose
614EOF
615      ;
616    exit 1;
617}
618
619$Getopt::Std::STANDARD_HELP_VERSION = 1;
620&getopts('bc:gl:s:v8') || &main::HELP_MESSAGE;
621
622if ($opt_c) {
623    open( my $cmd_fp, "<", $opt_c ) || &main::HELP_MESSAGE;
624    @cmd_buffer = <$cmd_fp>;
625    close $cmd_fp;
626    chomp @cmd_buffer;
627    $cmd_index = 0;
628}
629
630if ($opt_l) {
631    open( $log_fp, ">", $opt_l ) || &main::HELP_MESSAGE;
632}
633
634$opt_s = "1" unless ( defined($opt_s) and ( $opt_s =~ /^(\d*\.)?\d+$/ ) );
635
636$ST = "\007" if ($opt_b);
637
638$SP              = 0;
639$titlestack[$SP] = "unknown";
640$item_stack[$SP] = 0;
641$mode_stack[$SP] = $TM = 0;
642
643binmode( STDOUT, ":utf8" ) if ( $encoding eq "utf-8" );
644if ($opt_8) {
645    if ( $encoding eq "utf-8" ) {
646        undef $opt_8;
647        printf "...ignoring -8 option since locale uses %s\n", $encoding;
648    }
649    else {
650        printf STDERR "\x1b G";
651        $CSI = "\x9b";
652        $DCS = "\x90";
653        $OSC = "\x9d";
654        $ST  = "\x9c";
655    }
656}
657
658&get_WM_NAME;
659
660&raw;
661&get_titlemodes;
662&get_level;
663&raw;
664while (1) {
665    my $cmd;
666
667    printf "\r\n[$SP:$SQ] Command (? for help):";
668    $cmd = &get_char;
669    if ( not $cmd ) {
670        sleep 1;
671    }
672    elsif ( $cmd eq "?" ) {
673        printf "\r\n? help,"
674          . " d=display,"
675          . " m/M=set/reset mode,"
676          . " p=set title,"
677          . " q=quit,"
678          . " r=restore,"
679          . " s=save\r\n";
680    }
681    elsif ( $cmd eq "#" ) {
682        printf " ...comment\r\n\t#";
683        &get_line;
684    }
685    elsif ( $cmd eq "!" ) {
686        printf " ...shell\r\n";
687        &cooked;
688        system( $ENV{SHELL} );
689        &raw;
690    }
691    elsif ( $cmd eq "d" ) {
692        printf " ...display\r\n";
693        &display_info;
694    }
695    elsif ( $cmd eq "p" ) {
696        printf " ...set text\r\n";
697        &set_titletext;
698    }
699    elsif ( $cmd eq "q" ) {
700        printf " ...quit\r\n";
701        last;
702    }
703    elsif ( $cmd eq "s" ) {
704        printf " ...save title\r\n";
705        &save_title;
706    }
707    elsif ( $cmd eq "r" ) {
708        printf " ...restore title\r\n";
709        &restore_title(0);
710    }
711    elsif ( $cmd eq "m" ) {
712        printf " ...set title mode\r\n";
713        &set_titlemode(1);
714    }
715    elsif ( $cmd eq "M" ) {
716        printf " ...reset title mode\r\n";
717        &set_titlemode(0);
718    }
719}
720
721# when unstacking here, just use the selector used for the push
722while ( $SP > 0 ) {
723    &restore_title(1);
724}
725
726&send_command( sprintf( "%s>T", $CSI ) );    # reset title-modes to default
727
728&cooked;
729
730printf "\x1b F" if ($opt_8);
731