"Fossies" - the Fresh Open Source Software Archive 
Member "xterm-379/vttests/setpos.pl" (26 May 2019, 9108 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 "setpos.pl" see the
Fossies "Dox" file reference documentation.
1 #!/usr/bin/env perl
2 # $XTermId: setpos.pl,v 1.18 2019/05/26 23:19:29 tom Exp $
3 # -----------------------------------------------------------------------------
4 # Copyright 2019 by Thomas E. Dickey
5 #
6 # All Rights Reserved
7 #
8 # Permission is hereby granted, free of charge, to any person obtaining a
9 # copy of this software and associated documentation files (the
10 # "Software"), to deal in the Software without restriction, including
11 # without limitation the rights to use, copy, modify, merge, publish,
12 # distribute, sublicense, and/or sell copies of the Software, and to
13 # permit persons to whom the Software is furnished to do so, subject to
14 # the following conditions:
15 #
16 # The above copyright notice and this permission notice shall be included
17 # in all copies or substantial portions of the Software.
18 #
19 # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
20 # OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
21 # MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
22 # IN NO EVENT SHALL THE ABOVE LISTED COPYRIGHT HOLDER(S) BE LIABLE FOR ANY
23 # CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
24 # TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
25 # SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
26 #
27 # Except as contained in this notice, the name(s) of the above copyright
28 # holders shall not be used in advertising or otherwise to promote the
29 # sale, use or other dealings in this Software without prior written
30 # authorization.
31 # -----------------------------------------------------------------------------
32 # Exercise CSI 3/13 t which set/get the window position.
33
34 use strict;
35
36 use Getopt::Std;
37 use IO::Handle;
38
39 $| = 1;
40
41 our ( $opt_a, $opt_n, $opt_p, $opt_v, $opt_x, $opt_8 );
42 our $default_y = 100;
43 our $default_x = 150;
44
45 sub main::HELP_MESSAGE() {
46 printf STDERR <<EOF
47 Usage: $0 [options]
48 Options:
49 -8 use 8-bit controls
50 -a test position/report for middle and four corners
51 -n N repeat unless -a option used (default: 3)
52 -p Y,X use this position rather than $default_y,$default_x
53 -v verbose
54 -x report xwininfo's position for \$WINDOWID
55 EOF
56 ;
57 exit 1;
58 }
59
60 $Getopt::Std::STANDARD_HELP_VERSION = 1;
61 &getopts('an:p:vx8') || &main::HELP_MESSAGE;
62
63 our $repeat = 3;
64 $repeat = $opt_n if ($opt_n);
65 &main::HELP_MESSAGE unless ( $repeat =~ /^\d+$/ );
66
67 our $CSI = "\x1b\[";
68 $CSI = "\x9b" if ($opt_8);
69
70 if ($opt_p) {
71 &main::HELP_MESSAGE unless ( $opt_p =~ /^[-]?\d+,[-]?\d+$/ );
72 my @coord = split /,/, $opt_p;
73 $default_y = $coord[0];
74 $default_x = $coord[1];
75 }
76
77 our $wm_name = "unknown";
78 our @extents;
79
80 sub no_reply($) {
81 open TTY, "+</dev/tty" or die("Cannot open /dev/tty\n");
82 autoflush TTY 1;
83 my $old = `stty -g`;
84 system "stty raw -echo min 0 time 5";
85
86 print TTY @_;
87 close TTY;
88 system "stty $old";
89 }
90
91 sub get_reply($) {
92 open TTY, "+</dev/tty" or die("Cannot open /dev/tty\n");
93 autoflush TTY 1;
94 my $old = `stty -g`;
95 system "stty raw -echo min 0 time 5";
96
97 print TTY @_;
98 my $reply = <TTY>;
99 close TTY;
100 system "stty $old";
101 if ( defined $reply ) {
102 die("^C received\n") if ( "$reply" eq "\003" );
103 }
104 return $reply;
105 }
106
107 sub read_cmd($) {
108 my $cmd = shift;
109 my @result;
110 if ( open my $fh, "$cmd |" ) {
111 @result = <$fh>;
112 close $fh;
113 chomp @result;
114 }
115 return @result;
116 }
117
118 sub get_xprop($$) {
119 my $id = shift;
120 my $name = shift;
121 my @data = &read_cmd("xprop -id $id");
122 my $prop = "";
123 for my $n ( 0 .. $#data ) {
124 if ( $data[$n] =~ /$name\([^)]+\) =/ ) {
125 $prop = $data[$n];
126 $prop =~ s/^[^=]*=\s*//;
127 $prop =~ s/"//g;
128 last;
129 }
130 }
131 return $prop;
132 }
133
134 sub visible($) {
135 my $reply = $_[0];
136 my $n;
137 my $result = "";
138 for ( $n = 0 ; $n < length($reply) ; ) {
139 my $c = substr( $reply, $n, 1 );
140 if ( $c =~ /[[:print:]]/ ) {
141 $result .= $c;
142 }
143 else {
144 my $k = ord substr( $reply, $n, 1 );
145 if ( ord $k == 0x1b ) {
146 $result .= "\\E";
147 }
148 elsif ( $k == 0x7f ) {
149 $result .= "^?";
150 }
151 elsif ( $k == 32 ) {
152 $result .= "\\s";
153 }
154 elsif ( $k < 32 ) {
155 $result .= sprintf( "^%c", $k + 64 );
156 }
157 elsif ( $k > 128 ) {
158 $result .= sprintf( "\\%03o", $k );
159 }
160 else {
161 $result .= chr($k);
162 }
163 }
164 $n += 1;
165 }
166
167 return $result;
168 }
169
170 sub limited($) {
171 my $value = shift;
172 if ( $value >= 65536 ) {
173 $value %= 65536;
174 }
175 if ( $value >= 32768 ) {
176 $value -= 65536;
177 }
178 return $value;
179 }
180
181 sub check_position($$$) {
182 my $name = shift;
183 my $expect = shift;
184 my $actual = shift;
185 printf " ?%s:%d", $name, $expect if ( $expect != $actual );
186 }
187
188 sub report_position() {
189 my $reply = &get_reply( sprintf "%s13t", $CSI );
190 my $status = 0;
191 my @result;
192 if ( index( $reply, $CSI ) == 0 ) {
193 $reply = substr( $reply, length($CSI) );
194 $status = 1;
195 }
196 if ( $reply =~ /^3;\d+;\d+t$/ ) {
197 my $y = $reply;
198 $y =~ s/^3;(\d+);.*/$1/;
199 my $x = $reply;
200 $x =~ s/^3;\d+;(\d+).*/$1/;
201 $result[0] = &limited($y);
202 $result[1] = &limited($x);
203 printf "OK ->%s ->%d,%d", &visible($reply), $result[0], $result[1];
204 }
205 else {
206 printf "ERR ->%s", &visible($reply);
207 }
208 if ( $opt_x and $ENV{WINDOWID} ) {
209 my @actual = `xwininfo -id $ENV{WINDOWID} | grep " upper-left [XY]:"`;
210 for my $n ( 0 .. $#actual ) {
211 $actual[$n] =~ s/^.*:\s+//;
212 }
213 if ( $#actual == 3 ) {
214 printf " abs(%d,%d) rel(%d,%d)", $actual[0], $actual[1],
215 $actual[2], $actual[3]
216 if ($opt_v);
217 my $expect_y;
218 my $expect_x;
219 if ( $wm_name =~ /^gnome/i ) {
220 $expect_x = $actual[0] - ( $extents[0] + $extents[1] );
221 $expect_y = $actual[1] - ( $extents[2] + $extents[3] );
222 }
223 elsif ( $#extents == 3
224 and ( $wm_name !~ /^fvwm/i )
225 and ( $wm_name !~ /^enlightenment/i ) )
226 {
227 $expect_x = $actual[0] - ( $extents[0] );
228 $expect_y = $actual[1] - ( $extents[2] );
229 }
230 else {
231 $expect_x = $actual[0] - $actual[2];
232 $expect_y = $actual[1] - $actual[3];
233 }
234 if ( $#result > 0 ) {
235 &check_position( "X", $expect_x, $result[0] );
236 &check_position( "Y", $expect_y, $result[1] );
237 }
238 }
239 }
240 printf "\n";
241 return @result;
242 }
243
244 sub update_position() {
245 my @pos = @{ $_[0] };
246 printf "** update %d,%d\n", $pos[0], $pos[1];
247 $pos[0] += 65536 if ( $pos[0] < 0 );
248 $pos[1] += 65536 if ( $pos[1] < 0 );
249 &no_reply( sprintf "%s3;%d;%dt", $CSI, $pos[0], $pos[1] );
250 }
251
252 sub update_and_report($) {
253 my @pos = @{ $_[0] };
254 &update_position( \@pos );
255 sleep 1 if ($opt_a);
256 return &report_position;
257 }
258
259 sub get_screensize() {
260 my $reply = &get_reply( sprintf "%s15t", $CSI );
261 my @result;
262 if ( index( $reply, $CSI ) == 0 ) {
263 $reply = substr( $reply, length($CSI) );
264 if ( $reply =~ /^5;\d+;\d+t$/ ) {
265 my $y = $reply;
266 $y =~ s/^5;(\d+);.*/$1/;
267 my $x = $reply;
268 $x =~ s/^5;\d+;(\d+).*/$1/;
269 $result[0] = $x;
270 $result[1] = $y;
271 }
272 }
273 return @result;
274 }
275
276 sub doit() {
277 my @old = &report_position;
278 if ($opt_a) {
279 my @size = &get_screensize;
280 if (@size) {
281 printf "Screen %dx%d\n", $size[0], $size[1];
282 my $ulx = -$default_x;
283 my $uly = -$default_y;
284 my $lrx = $size[0] - $default_x;
285 my $lry = $size[1] - $default_y;
286 &update_and_report( [ $ulx, $uly ] );
287 &update_and_report( [ $ulx, $lry ] );
288 &update_and_report( [ $lrx, $lry ] );
289 &update_and_report( [ $lrx, $uly ] );
290 &update_position( \@old );
291 }
292 }
293 else {
294 my @pos = ( $default_y, $default_x );
295 for my $n ( 1 .. $repeat ) {
296 @pos = &update_and_report( \@pos );
297 }
298 }
299 }
300
301 printf "\x1b G" if ($opt_8);
302
303 if ( $opt_x and $ENV{WINDOWID} ) {
304 my $extents = &get_xprop( $ENV{WINDOWID}, "_NET_FRAME_EXTENTS" );
305 if ( $extents ne "" ) {
306 @extents = split /,\s*/, $extents;
307 printf "** has EWMH extents: $extents\n";
308 my $supwin = `xprop -root '_NET_SUPPORTING_WM_CHECK'`;
309 if ( $supwin ne "" ) {
310 $supwin =~ s/^.*(0x[[:xdigit:]]+).*/$1/;
311 $wm_name = &get_xprop( $supwin, "_NET_WM_NAME" );
312 $wm_name = "unknown" unless ( $wm_name ne "" );
313 printf "** using \"$wm_name\"\n";
314 }
315 }
316 }
317
318 &doit;
319
320 printf "\x1b F" if ($opt_8);
321
322 1;