%PDF-
%PDF-
Mini Shell
Mini Shell
#!/usr/bin/perl
# This is a virtually complete test of all of the protocol's features
# -- it was used by the author during development. It generates a lot
# of output to STDOUT, uses a bunch of memory, and messes with your
# display in various ways. (Though some of the most egregious have
# been commented out). Run it at your own risk.
use X11::Protocol 0.02;
use X11::Keysyms qw(%Keysyms MISCELLANY XKB_KEYS LATIN1);
%Keysyms_name = reverse %Keysyms;
sub pretty
{
my($x) = @_;
if (not ref $x)
{
if ($x == 0 and $x ne "0")
{
$x = "..." if $x =~ /[\cA-\cZ]/;
print "`$x'";
}
else
{
printf "$x=0x%x", $x;
}
}
elsif (ref($x) eq "ARRAY")
{
my($i);
print "[";
for $i (@$x) { pretty($i); print ", ";}
print "]";
}
elsif (ref($x) eq "HASH" or ref($x) eq "X11::Protocol")
{
my($k, $v);
print "{";
while (($k, $v) = each(%$x))
{
print "$k => ";
pretty($v);
print ", ";
}
print "}";
}
else
{
print $x;
}
}
sub my_sleep {
my($secs) = @_;
$x->flush();
sleep($secs);
}
%opts = @ARGV;
$display = $opts{'-d'} || $opts{'-display'} || $ENV{'DISPLAY'} || ":0.0";
$x = X11::Protocol->new($display);
pretty $x;
print "\n";
$win = $x->new_rsrc;
print "$win\n";
$x->error_handler(sub {});
$x->error_handler(\&X11::Protocol::default_error_handler);
sub print_event
{
my(%e) = @_;
my($i);
$last_event_time = $e{'time'} if $e{'time'};
exit if $e{'name'} eq "KeyPress" and ($e{'detail'} == 24 or $done);
print delete($e{'name'}), ": ";
print join(", ", map("$_ $e{$_}", keys %e)), "\n";
}
$x->{'event_handler'} = \&print_event;
#$x->{'event_handler'} = 'queue';
$x->req('CreateWindow', $win, $x->{'root'}, "InputOutput",
$x->{'root_depth'}, "CopyFromParent",
(0, 0), 100, 100, 1, "backing_store" => "WhenMapped",
'background_pixel' => $x->{'white_pixel'});
$x->req('ChangeProperty', $win,
$x->req('InternAtom', "WM_NAME", 0),
$x->req('InternAtom', "STRING", 0), 8, "Replace", "Perl X11 Client");
$x->req('ChangeWindowAttributes', $win, "event_mask" => #0x01ebffff);
$x->pack_event_mask('KeyPress', 'KeyRelease', 'ButtonPress',
'ButtonRelease', 'EnterWindow', 'LeaveWindow',
'PointerMotion', 'ButtonMotion', 'KeymapState',
'Exposure', 'VisibilityChange', 'StuctureNotify',
'SubstructureNotify', 'FocusChange',
'PropertyChange', 'ColormapChange'));
print join " ", $x->req('GetWindowAttributes', $win), "\n";
$x->request('MapWindow', $win);
req $x 'ConfigureWindow', $win, "height" => 200, "width" => 200;
$kid1 = $x->new_rsrc;
$x->req('CreateWindow', $kid1, $win, 'InputOutput', $x->{'root_depth'},
'CopyFromParent', (50, 50), 75, 75, 4);
$kid2 = $x->new_rsrc;
$x->req('CreateWindow', $kid2, $win, 'InputOutput', $x->{'root_depth'},
'CopyFromParent', (100, 100), 75, 75, 4);
$x->req('MapSubwindows', $win);
my_sleep 2;
$x->req('CirculateWindow', $win, "LowerHighest");
my_sleep 2;
$x->req('DestroySubwindows', $win);
print join " ", $x->req('GetGeometry', $win), "\n";
print join " ",
$x->req('GetGeometry', $x->{'root'}), "\n";
($root, $parent, @kids) = $x->req('QueryTree', $x->{'root'});
for $kid (@kids) {
print join " ", $x->req('GetGeometry', $kid), "\n";
}
print $x->req('InternAtom', "WM_NAME", 0), "\n";
for $atom (1 .. 90) {
print "$atom: ", $x->req('GetAtomName', $atom), ", ";
}
print "\n\n";
for $atom ($x->req('ListProperties', $win)) {
print $x->atom_name($atom), " => ";
print join(",", $x->req('GetProperty', $win, $atom, "AnyPropertyType",
0, 200, 0)), "\n";
}
$root_wid = $x->{'root'};
for (1 .. 10)
{
my($e) = $x->pack_event('code' => 2, 'detail' => 25, 'time' => 0,
'root' => $root_wid, 'event' => $win, 'child' => 0,
'root_x' => 100, 'root_y' => 100, 'event_x' => 5,
'event_y' => 5, 'state' => 0, 'same_screen' => 1,
'synthetic' => 0);
$x->req('SendEvent', "PointerWindow", 0, 0, $e);
$x->req('SendEvent', "PointerWindow", 0, 0,
$x->pack_event('name' => "KeyRelease", 'detail' => 25, 'time' => 0,
'root' => $root_wid, 'event' => $win, 'child' => 0,
'root_x' => 100, 'root_y' => 100, 'event_x' => 5,
'event_y' => 5, 'state' => 0, 'same_screen' => 1));
}
print "Grabbing...";
$x->req('GrabPointer', $win, 0, 0, 'Asynchronous', 'Asynchronous', $win, 0, 0);
my_sleep 2;
$x->req('UngrabPointer', 0);
print "done.\n";
my_sleep 2;
print "Grabbing server...";
$x->req('GrabServer');
my_sleep 2;
$x->req('UngrabServer');
print "done.\n";
print "->", join(" ", $x->req('QueryPointer', $win)), "\n";
for $motion ($x->req('GetMotionEvents', $last_event_time, 'CurrentTime', $win))
{
print "$motion->[0]: ($motion->[1], $motion->[2])\n";
}
print "-->", join(" ", $x->req('TranslateCoordinates',
$win => $root_wid, 50, 50)), "\n";
for (1 .. 10)
{
$x->req('WarpPointer', 'None', $root_wid, 0, 0, 0, 0,
rand($x->{'width_in_pixels'} * .9),
rand($x->{'height_in_pixels'} * .9));
my_sleep 1;
}
print "--->", join(" ", $x->req('GetInputFocus')), "\n";
print "---->", $x->req('QueryKeymap'), "\n";
$fid = $x->new_rsrc;
$x->req('OpenFont', $fid, 'fixed');
print "`fixed' = $fid\n";
%fixed = $x->req('QueryFont', $fid);
print join(" ", %fixed), "\n";
print join(" ", @{$fixed{'min_bounds'}}), "\n";
print join(" ", @{$fixed{'max_bounds'}}), "\n";
%prop = %{$fixed{'properties'}};
foreach $atom (keys %prop)
{
print $x->atom_name($atom), " => ", $prop{$atom}, "; ";
}
print "\n";
foreach $ci (@{$fixed{'char_infos'}})
{
print join (" ", @$ci), "; ";
}
print "\n";
print join(" ", $x->req('QueryTextExtents', $fid, "\0H\0e\0l\0l\0o")), "\n";
print join("\n", $x->req('ListFonts', '-adobe-*', 50)), "\n";
foreach $font ($x->req('ListFontsWithInfo', '-adobe-*', 5))
{
%info = %$font;
print join(" ", %info), "\n";
print join(" ", @{$info{'min_bounds'}}), "\n";
print join(" ", @{$info{'max_bounds'}}), "\n";
%prop = %{$info{'properties'}};
foreach $atom (keys %prop)
{
print $x->atom_name($atom), " => ", $prop{$atom}, "; ";
}
print "\n";
}
print join(", ", $x->req('GetFontPath')), "\n";
#$x->req('SetFontPath', $x->req('GetFontPath'));
#print join(", ", $x->req('GetFontPath')), "\n";
$pixmap = $x->new_rsrc;
$x->req('CreatePixmap', $pixmap, $win, $x->{'root_depth'}, 50, 50);
$x->req('FreePixmap', $pixmap);
$gc = $x->new_rsrc;
$x->req('CreateGC', $gc, $win, 'function' => 'Xor', 'line_width' => 2,
'join_style' => 'Miter', 'font' => $fid, 'arc_mode' => 'PieSlice',
'foreground' => $x->{'white_pixel'},
'background' => $x->{'black_pixel'},
'graphics_exposures' => 0);
$x->req('ChangeGC', $gc, 'join_style' => 'Round');
$fancy_gc = $x->new_rsrc;
$x->req('CreateGC', $fancy_gc, $win);
$x->req('CopyGC', $gc, $fancy_gc, 'function', 'line_width', 'join_style',
'font', 'arc_mode', 'background', 'graphics_exposures');
$x->req('ChangeGC', $fancy_gc, 'line_style' => 'OnOffDash');
$x->req('SetDashes', $fancy_gc, 0, (1, 2, 1, 3, 1));
$x->req('SetClipRectangles', $fancy_gc, (0, 0), 'UnSorted', [0, 40, 100, 20],
[40, 0, 20, 100]);
$x->req('ClearArea', $win, (0, 0), 200, 200, 0);
$white = $x->{'white_pixel'};
$black = $x->{'black_pixel'};
$x->req('ChangeGC', $gc, 'function' => 'Copy', 'background' => $white,
'foreground' => $black);
for (1 .. 500)
{
push @points, rand(200);
}
$x->PolyPoint($win, $gc, 'Origin', @points);
for $c (@points)
{
$c = 200 - $c;
}
$x->PolySegment($win, $gc, @points);
for $c (@points)
{
$c /= 10;
$c -= 10;
}
$x->ClearArea($win, (0, 0), 200, 200, 0);
$x->PolyLine($win, $gc, 'Previous', (100, 100), @points);
$x->ChangeGC($gc, 'function' => "Xor");
for (1 .. 200)
{
$x->req('CopyArea', $win, $win, $gc, (rand(160), rand(160)), 40, 40,
(rand(160), rand(160)));
}
$x->req('ChangeGC', $gc, 'function' => "Copy");
for (1 .. 200)
{
$x->req('CopyPlane', $win, $win, $fancy_gc, (rand(160), rand(160)),
40, 40, (rand(160), rand(160)), 1 << 0);
}
$x->req('ClearArea', $win, (0, 0), 200, 200, 0);
for (1 .. 25)
{
push @rects, [rand(100), rand(100), rand(100), rand(100)];
}
$x->req('PolyRectangle', $win, $gc, @rects);
for (1 .. 16)
{
push @arcs, [rand(150), rand(150), 50, 50, 0, rand(360 * 64)];
}
$x->req('PolyArc', $win, $gc, @arcs);
$x->req('FillPoly', $win, $gc, 'Convex', 'Origin',
(100,0)=>(150,150)=>(0,100));
@rects = ();
for (1 .. 100)
{
push @rects, [rand(190), rand(190), rand(10), rand(10)];
}
$x->req('PolyFillRectangle', $win, $gc, @rects);
@arcs = ();
for (1 .. 25)
{
push @arcs, [rand(175), rand(175), 25, 25, 90 * 64, rand(360 * 64)];
}
$x->req('PolyFillArc', $win, $gc, @arcs);
$x->req('ClearArea', $win, (0, 0), 200, 200, 0);
if ($x->{'bitmap_bit_order'} eq 'LeastSignificant'
and $x->{'bitmap_scanline_unit'} == 32
and $x->{'bitmap_scanline_pad'} == 32)
{
$bmap =
"\0\0\xff\xff\xff\xff\x0f\0" x 8 .
"\0\0\xff\0\0\0\xff\0" x 8 .
"\0\0\xff\xff\xff\xff\x0f\0" x 8 .
"\0\0\xff\0\0\0\0\0" x 8 .
"\0\0\xff\0\0\0\0\0" x 8;
for $shift (0 .. 3)
{
$x->req('PutImage', $win, $gc, 1, 56, 40,
(0, 2 + 42 * $shift), 8, 'Bitmap', $bmap);
}
}
if (0)
{
$pixmap =
# 1234567890123456789012345678
" ".
" #### ##### #### # ".
" # # # # # # ".
" #### #### #### # ".
" # # # # # ".
" # ##### # # ##### ".
" ";
@pixels = unpack("C*", $pixmap);
for $p (@pixels)
{
$p = 0 if $p == ord("#");
}
for (1 .. 50)
{
@p = @pixels;
for $p (@p)
{
$p = rand(256) if $p;
}
$x->req('PutImage', $win, $gc, 8, 25, 7,
(rand(175), rand(193)), 0, 'ZPixmap', pack("C*", @p));
}
}
($d, $v, $image) = $x->req('GetImage', $win, (0, 0), 79, 24, 0xff, 'ZPixmap');
$image =~ tr/\0/ /;
$image =~ tr/ -~/./c;
for $row (0 .. 23)
{
print substr($image, $row * 80, 80), "\n";
}
$x->req('ClearArea', $win, (0, 0), 200, 200, 0);
$smallfid = $x->new_rsrc;
$x->req('OpenFont', $smallfid, '6x10');
$x->req('PolyText8', $win, $gc, 2, 20, [0, "Hello, "],
$smallfid, [-3, "world!"]);
$x->req('PolyText8', $win, $gc, 2, 35, [0, "Perl " x 300]);
#$largefid = $x->new_rsrc;
#$x->req('OpenFont', $largefid,
# '-*-*-medium-r-normal--14-*-*-*-c-*-jisx0208.1983-0');
#$x->req('PolyText16', $win, $gc, 2, 50, $largefid,
# [0, "\061\101\061\104\061\106\061\110\061\112\061\113\061\114\061\115"
# . "\061\116\061\117\061\122\061\125\061\130\061\133"]);
$x->req('ChangeGC', $gc, 'font' => $smallfid);
$x->req('ImageText8', $win, $gc, 2, 70, "Perl");
$x->req('ImageText16', $win, $gc, 2, 80, "\0P\0e\0r\0l");
if ($x->{'root_depth'} == 8) {
$cmap = $x->new_rsrc;
$x->req('CreateColormap', $cmap, $x->{'root_visual'}, $win, 'All');
$new_cmap = $x->new_rsrc;
$x->req('CopyColormapAndFree', $new_cmap, $cmap);
$x->req('FreeColormap', $cmap);
}
$cmap = $x->{'default_colormap'};
print join(", ", $x->req('ListInstalledColormaps', $win)), "\n";
print join(", ", $x->req('ListInstalledColormaps', $root_wid)), "\n";
($color1, $r, $g, $b) = $x->req('AllocColor', $cmap,
1 * 65535, 0 * 65535, 0 * 65535);
print "$color1 = ($r, $g, $b)\n";
($color2, $r1, $g1, $b1, $r2, $g2, $b2) =
$x->req('AllocNamedColor', $cmap, 'orange');
print "orange =~= $color2 =~= ($r1, $g1, $b1) =~= ($r2, $g2, $b2)\n";
if ($x->{'root_depth'} == 8) {
($pixels, $masks) = $x->req('AllocColorCells', $cmap, 1, 0, 0);
$color3 = $pixels->[0];
print "$color3\n";
($rm, $gm, $bm, @pixels) =
$x->req('AllocColorPlanes', $cmap, 1, (0,0,1), 0);
print "$rm|$gm|$bm = ", join(", ", @pixels), "\n";
$x->req('StoreColors', $cmap, [$color3 => (65535, 0, 0)],
[$pixels[0] => (0, 0, 0), 1]);
$x->req('StoreNamedColor', $cmap, $color3, 'salmon', 7);
}
@colors = $x->req('QueryColors', $cmap, 0 .. 255);
for $c (@colors)
{
printf "(0x%04x, 0x%04x, 0x%04x), ", @$c;
print "\n" unless ++$i % 3;
}
print "\n";
($r1, $g1, $b1, $r2, $g2, $b2) = $x->req('LookupColor', $cmap, 'bisque');
print "bisque =~= ($r1, $g1, $b1) =~= ($r2, $g2, $b2)\n";
$fg_pm = $x->new_rsrc;
$x->send('CreatePixmap', $fg_pm, $win, 1, 16, 16);
$mask_pm = $x->new_rsrc;
$x->send('CreatePixmap', $mask_pm, $win, 1, 16, 16);
$cursor_gc = $x->new_rsrc;
$x->send('CreateGC', $cursor_gc, $fg_pm, 'line_width' => 2,'foreground' => 0);
$x->send('PolyFillRectangle', $fg_pm, $cursor_gc, [(0, 0), 16, 16]);
$x->send('PolyFillRectangle', $mask_pm, $cursor_gc, [(0, 0), 16, 16]);
$x->send('ChangeGC', $cursor_gc, 'foreground' => 1);
$x->send('PolyArc', $mask_pm, $cursor_gc, [1, 1, 13, 13, 0, 360*64]);
$x->send('ChangeGC', $cursor_gc, 'line_style' => 'OnOffDash');
$x->send('PolyArc', $fg_pm, $cursor_gc, [1, 1, 13, 13, 0, 360*64]);
$cursor = $x->new_rsrc;
$x->send('CreateCursor', $cursor, $fg_pm, $mask_pm, (65535, 0, 0),
(45000, 45000, 45000), (8, 8));
$x->send('ChangeWindowAttributes', $win, 'cursor' => $cursor);
$x->send('FreePixmap', $fg_pm);
$x->send('FreePixmap', $mask_pm);
$x->send('FreeGC', $cursor_gc);
my_sleep 5;
$cursor_fnt = $x->new_rsrc;
$x->req('OpenFont', $cursor_fnt, 'cursor');
$new_cursor = $x->new_rsrc;
$x->req('CreateGlyphCursor', $new_cursor, $cursor_fnt, $cursor_fnt, 0, 1,
(65535, 65535, 65535), (0, 0, 0));
$x->req('CloseFont', $cursor_fnt);
$x->req('ChangeWindowAttributes', $win, 'cursor' => $new_cursor);
$x->req('FreeCursor', $cursor);
$cursor = $new_cursor;
for $p (0 .. 10)
{
$x->req('RecolorCursor', $cursor,
(65535, 65535 - $p*6553.5, 65535- $p*6553.5), (0, 0, 0));
my_sleep 1;
}
($w, $h) = $x->req('QueryBestSize', 'Cursor', $root_wid, 16, 16);
print "$w x $h is a good size for a cursor.\n";
for $ext ($x->req('ListExtensions'))
{
($major, $event, $error) = $x->req('QueryExtension', $ext);
print "$ext: request $major, event $event, error $error\n";
}
($old) = $x->req('GetKeyboardMapping', $x->{'max_keycode'}, 1);
#$x->req('ChangeKeyboardMapping', $x->{'max_keycode'} - 1, 4,
# [$Keysyms{"a"}, $Keysyms{"A"}, 0, 0],);
$i = $x->min_keycode;
for $ar ($x->req('GetKeyboardMapping', $x->{'min_keycode'},
$x->{'max_keycode'} - $x->{'min_keycode'} + 1))
# 10))
{
print "$i: ", join(", ", map($Keysyms_name{$_} || 'NoSymbol',
@$ar)), "\n";
$i++;
}
#$x->req('ChangeKeyboardMapping', $x->{'max_keycode'}, scalar(@$old), $old);
%kc = $x->req('GetKeyboardControl');
print join(" ", %kc), "\n";
$bp = $kc{'bell_pitch'};
$x->req('Bell', 100);
$x->req('ChangeKeyboardControl', 'bell_pitch' => 2 * $bp);
my_sleep 1;
$x->req('Bell', 100);
$x->req('ChangeKeyboardControl', 'bell_pitch' => $bp);
($num, $denom, $thresh) = $x->req('GetPointerControl');
print "Acceleration: $num/$denom; Threshold: $thresh\n";
$x->req('ChangePointerControl', 1, 0, $num * 2, $denom, $thresh);
my_sleep 2;
$x->req('ChangePointerControl', 1, 0, $num, $denom, $thresh);
($t_out, $interv, $pb, $allow_exp) = $x->req('GetScreenSaver');
print "Timeout: $t_out, Interval: $interv, Blanking: $pb, ";
print "Exposures: $allow_exp\n";
$x->req('SetScreenSaver', $t_out, $interv, $pb, $allow_exp);
($t_out, $interv, $pb, $allow_exp) = $x->req('GetScreenSaver');
print "Timeout: $t_out, Interval: $interv, Blanking: $pb, ";
print "Exposures: $allow_exp\n";
#$addr = pack("C4", (127, 0, 0, 1));
#sen('ChangeHosts', 'Insert', 'Internet', $addr);
($mode, @hosts) = $x->req('ListHosts');
for $ar (@hosts)
{
print "$ar->[0]: ", join(".", unpack("C4", $ar->[1])), "\n";
}
$x->req('SetAccessControl', $mode);
$x->req('SetCloseDownMode', 'Destroy');
#$x->req('KillClient', 0x200004b);
$x->req('RotateProperties', $win, 1, ($x->req('InternAtom', 'WM_NAME', 1)));
$x->req('ForceScreenSaver', 'Activate');
@map = $x->req('GetPointerMapping');
print join(", ", @map), "\n";
$x->req('SetPointerMapping', @map);
@map = $x->req('GetModifierMapping');
for $ar (@map)
{
print "[", join(",", @$ar), "]\n";
}
#$x->req('SetModifierMapping', @map);
$x->req('NoOperation', 4);
if ($x->{'root_depth'} == 8) {
$x->req('FreeColors', $cmap, 0, $color1, $color2, $color3, @pixels);
} else {
$x->FreeColors($cmap, 0, $color1, $color2);
}
$x->req('FreeGC', $fancy_gc);
$x->req('CloseFont', $fid);
$x->req('CloseFont', $smallfid);
#$x->req('CloseFont', $largefid);
$x->init_extensions;
if ($x->{'ext'}{"SHAPE"})
{
$x->req('ShapeSelectInput', $win, 1);
$x->req('ShapeRectangles', $win, 'Bounding', 'Set', (0, 0), 'UnSorted',
[(0, 0), 50, 50], [(50, 50), 50, 50]);
$shape_pm = $x->new_rsrc;
$x->req('CreatePixmap', $shape_pm, $win, 1, 100, 100);
$shape_gc = $x->new_rsrc;
$x->req('CreateGC', $shape_gc, $shape_pm, 'foreground' => 0);
$x->req('PolyFillRectangle', $shape_pm, $shape_gc, [0, 0, 100, 100]);
$x->req('ChangeGC', $shape_gc, 'foreground' => 1);
$x->req('PolyFillArc', $shape_pm, $shape_gc, [0, 0, 100, 100, 0, 360*64]);
$x->req('ShapeMask', $win, 'Bounding', 'Union', 100, 100, $shape_pm);
$x->req('ShapeCombine', $win, 'Bounding', 'Invert', 0, 0, $x->{'root'},
'Bounding');
$x->req('ShapeOffset', $win, 'Bounding', 25, 25);
print join(", ", $x->req('ShapeQueryExtents', $win)), "\n";
print $x->req('ShapeInputSelected', $win), "\n";
($ordering, @rects) = $x->req('ShapeGetRectangles', $win, 'Bounding');
print "Ordering: $ordering\n";
for $rr (@rects)
{
print "[", join(", ", @$rr), "], ";
}
print "\n";
}
# This should be last, since it's a REAL memory hog.
if ($x->{'ext'}{'BIG_REQUESTS'})
{
print "Maximum request length: ", $x->maximum_request_length * 4, "\n";
for $i (1 .. 65536)
{
push @points, int(rand(200)), int(rand(200));
}
$x->PolyPoint($win, $gc, 'Origin', @points);
}
#print_event(%e) while %e = $x->dequeue_event;
#$x->{'event_handler'} = \&print_event;
$x->req('FreeGC', $gc);
$done = 1;
$x->handle_input while 1;
#print_event(%e) while %e = $x->next_event
Zerion Mini Shell 1.0