X11-Protocol-0.56/0000755000175000017500000000000010512256531012250 5ustar smccsmccX11-Protocol-0.56/Makefile.PL0000644000175000017500000000073707615056416014243 0ustar smccsmccuse ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile ('ABSTRACT' => 'Raw interface to X Window System servers', 'AUTHOR' => 'Stephen McCamant ', 'NAME' => 'X11::Protocol', 'VERSION_FROM' => 'Protocol.pm', # finds $VERSION 'PMLIBDIRS' => ['Protocol/', 'Protocol/Ext', 'Protocol/Connection'], 'dist' => {COMPRESS => 'gzip -9', SUFFIX => 'gz'}, ); X11-Protocol-0.56/README0000644000175000017500000001455010512253737013142 0ustar smccsmccX11::Protocol, version 0.56 Copyright (C) 1997-2006 Stephen McCamant. All rights reserved. This module is free software; you can redistribute and/or modify it under the same terms as Perl itself. (As an exception, the file Keysyms.pm, which is derived from a file in the standard X11 distribution, has another, less restrictive copying policy, as do some of the extension modules in the directory Protocol/Ext: see those files for details). Module list information:123456789 123456789 123456789 123456789 12345 X11::Protocol bdpO Raw interface to X Window System servers X11::Keysyms bdpf X11 key symbols (translation of keysymdef.h) X11::Auth bdpO Read and handle X11 '.Xauthority' files New in this version: 0.56 - Fix infinite loop regression in robust_req in 0.54 caused by handle_input change (found by Scott Smedley) X11::Protocol and the related modules in this distribution are a rough equivalent of Xlib (libX11.a, with a bit of Xau and Xext mixed in) used for drawing windows on and otherwise manipulating X11 window servers. OTHER THINGS YOU NEED * perl 5.002 (not tested recently; recent versions have only been tested with 5.6.1 and 5.8.*) * an X11 server (any version; it also doesn't have to be on the same computer, but you must be able to connect to it over a socket. For Win32 users, a free X server is apparently available from http://sources.redhat.com/win32-x11/ though the author hasn't tried it) * documentation about the X protocol (or at least Xlib, though its interface is subtly different). O'Reilly has a good book, and the full X distribution includes the definitive specification. As of this writing, the latest version can be obtained from the X.org CVS repository at: http://cvs.freedesktop.org/*checkout*/xorg/xc/doc/hardcopy/XProtocol/proto.PS.gz For Debian users, this is in the xspecs package. Speaking of Debian, this module is also available as the Debian package "libx11-protocol-perl"; thanks to tony mancill for maintaing it. *********************** NOTE *********************** * This module's interface is admittedly a little cumbersome, but its low level approach is intentional -- a higher-level interface, ideally more object-oriented, easier to use, and plug-compatible with an XS Xlib interface, would be a significant different project. (A project that this author made an abortive start at, but is unlikely to finish any time soon.) * The interface has become stable, though mainly through the passage of time rather than through extensive debugging. For better or worse, it probably isn't going to change much in the future. **************************************************** BUILDING Like any other module: % perl Makefile.PL % make % make test % make install DOCUMENTATION See the PODs at the end of each .pm file (converted into man pages by the makefile) for detailed information. EXAMPLES test.pl is a good example of a complete program; it's also a translation of an Xlib based program (in this case, `basicwin' from O'Reilly & Associates's _Xlib Programming Manual_). eg/anim.pl demonstrates buffered animation (needs IO::Select). eg/full_test.pl uses just about every request in the protocol. You might not want to run it, since it can do weird things to your display, but it can show prototype calls if the documentation is unclear. eg/long-run.pl is a program that runs for a long time and allocates many windows, as a stress-test of the resource-allocation code. eg/random-win.pl demonstrates how to handle requests that might cause errors, by picking random resource identifiers and trying to paint over them with randomly-colored rectangles if they're windows. eg/render-clock.pl uses the Render extension to draw an analog clock. It's a bit spiffier that "xclock -render", in the author's opinion, but falls short of fdclock. eg/render-test.pl is like eg/full_test.pl, but just for the Render extension. eg/teletype.pl shows how it's possible to connect to more than one server at once (needs IO::Select). eg/widgets* are four examples that all do the same thing, with different tools. They demonstrate all the techniques needed to implement two simple custom widgets, a scroll bar and a progress meter, with the different options available for X11 programming from Perl: - widgets1.pl uses X11::Protocol directly. - widgets2.pl uses X11::Xlib from Ken Fox's X11-Motif distribution. Unfortunately, even the latest alpha version of X11-Motif I could find is missing interfaces for all the needed Xlib structures, so the code has to play games with pack() to get some calls to work. This may mean that the example may not work correctly on platforms whose Xlib structures are laid out differently that the author's Linux x86 box. - widgets3.pl is an example of how programming X11::Protocol would be nicer with an object-oriented interface. It's a blatant ploy to get someone else interested in picking up the half-finished library it depends on, which is not included in this distribution (email me if you're interested). - widgets.c is a C Xlib version of the same functionality, for comparison. eg/wintree.pl is a small utility that acts like a cross between xlsclients, xwininfo, and pstree, showing the hierarchy of windows and their parents. Takes a window ID, or by default starts at the root. "-g" includes geometries, "-v" uses VT100 line drawing characters. Beware that it hardcodes some assumptions about how certain X servers encode resource IDs. SEE ALSO This is by no means the only way to put windows up on an X server from Perl. * The most popular and portable windowing interface for Perl is Perl/Tk, available as the Tk module from CPAN. * The Motif widget set, as well as some support for other standard X libraries, can be accessed using the X11::Motif modules, available from CPAN. An alpha version is also available directly from the author's homepage at http://www.vulpes.com/X11-Motif-1.2a8.tar.gz . * Several other X widgets sets have Perl interfaces, incluing GTK (the Gtk module), Qt (the PerlQt module), wxWindows (the Wx module) and Sx (a simplified Athena wrapper, available with the similarly named module). * For testing or automating the operation of other programs, the Xlib-based X11::GUITest module has more specialized support, including for the XTEST extension, than X11::Protocol. Send questions, bug reports, and feature requests to me, Stephen McCamant . X11-Protocol-0.56/Changes0000644000175000017500000000527510512252672013556 0ustar smccsmccRevision history for Perl module X11::Protocol. 0.01 Tue Dec 31 1996 - original version; created by h2xs 1.18 - as seen briefly on c.l.p.m 0.02 Tue Jul 29 1997 - first CPAN release - changed pack("Ii") to "Ll", for Alphas, etc - added next_event(), as suggested by Brian Wheeler - reworked event handling, based on work by Brian Wheeler - added X11::Auth, ditched xauth(1) - added README - changed format of $x->pixmap_formats based on a closer reading of the spec - $x->visuals now corresponds to documentation - moved Connection::* and Ext::* under X11::Protocol:: - random cleanup 0.03 Wed Aug 27 1997 - fixed minor bug in SelectionNotify event - added forgotten `format' field in ClientMessage event - added forgotten `GCFillRule' const type - added $x->{'do_interp'} to control interpretation - renamed forgotten X11::Connection::INETFH - fixed typos 0.04 Thu Jan 15 1998 - made anim.pl's letters rectangular instead of square - changed default display on Win32 from unix:0 to localhost:0 - fixed ORA's contatct information in pod - fixed typo 0.50 Sun Jan 26 2003 - fixed [GS]etModifierMapping to be 8 x N, not N x 8 - fixed doc typo re ChangeKeyboardMapping - fixed TranslateCoordinates reply, thanks to Damien Neil - authorization -w cleanup suggested by Harold Bamford - fixed QueryTree reply, also found by Craig Agricola - minor stylistic changes - added more examples - make Auth work in more cases (including one that can happen when SSH tunneling) 0.51 Sun May 11 2003 - enabled buffering on sockets, added ->flush() - added Ext/{XC_MISC,DPMS,XFree86_Misc}.pm from Jay Kominek - improved resource reuse, with XC_MISC, for long running programs - fixed embarrassing "elseQ" typo in pack_event 0.52 Mon Oct 13 2003 - fixed some -w warnings - fixed "bufffer" typo spotted by Jason Zou - corrected a few documentation typos - fixed buffering bug: "read" should have been "sysread" (problem reported by Scott Smedley) - allow reply processing to recover from getting an error instead (modeled after a patch from Scott Smedley) - add a version of req() that automatically catches errors 0.53 Sun Apr 4 2004 - Fixed AUTOLOAD scalar context bug reported by Mark Horowitz - Added Render extension 0.54 Sun May 1 2005 - Minor changes to render-clock example - Add new Host types from X11R6.7 - Fix handle_input_for bug reported by Rich Williams 0.55 Thu Jan 19 2006 - Fix spurious error on zero-length .Xauthority field in X11::Auth (reported independently by Cyril Bouthors and Anthony DeStefano) 0.56 Sun Oct 8 2006 - Fix infinite loop regression in robust_req in 0.54 caused by handle_input change (found by Scott Smedley) X11-Protocol-0.56/META.yml0000644000175000017500000000045710512256531013527 0ustar smccsmcc# http://module-build.sourceforge.net/META-spec.html #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# name: X11-Protocol version: 0.56 version_from: Protocol.pm installdirs: site requires: distribution_type: module generated_by: ExtUtils::MakeMaker version 6.30_01 X11-Protocol-0.56/Todo0000644000175000017500000000266510033640410013100 0ustar smccsmcc* Save caller info so that protocol errors give useful tracebacks (use Carp::longmess?) * Use (Self|Auto)Loader to reduce startup time; would require major restructuring * Documentation needs more examples, better explanations. Borrow text from official protocol spec? * Real test suite Porting: 64-bit architectures? avoid '/' as path separator; use File::something? Extensions: Traditional: MIT-SCREEN-SAVER MIT-SHM MIT-SUNDRY-NONSTANDARD DOUBLE-BUFFER Multi-Buffering SYNC XTEST XFree86: XFree86-Bigfont XFree86-DGA XFree86-DRI XFree86-VidModeExtension Other small: Extended-Visual-Information FontCache RECORD SECURITY TOG-CUP XC-APPGROUP Larger projects: Display Postscript? GLX / SGI-GLX (OpenGL) LBX X3D-PEX XInputExtension XKEYBOARD XVideo Authentication protocols: XDM-something SUN-DES-1 MIT-KERBEROS-5 Other modules: X11::Xlib -- XS to libX11.a Ken Fox has done this as part of X11-Motif, calling it X11::Lib. X11::Display, X11::Window, X11::GC, etc -- more OO, more intuitive interace, could be on top of Xlib (was in progress, now abandoned) Long-term goals: Widget library Perl window manager: See PerlWM, http://www.miranda.org/~jkominek/perlwm/ also perlwm, http://perlwm.sourceforge.net/ If you have something you think should go on this list, or if you want to work on one or more of the above, I'd be happy to hear from you at . X11-Protocol-0.56/Auth.pm0000644000175000017500000001254310363621003013506 0ustar smccsmcc#!/usr/bin/perl package X11::Auth; # Copyright (C) 1997, 1999, 2005 Stephen McCamant. All rights # reserved. This program is free software; you can redistribute and/or # modify it under the same terms as Perl itself. use Carp; use strict; use vars '$VERSION'; use FileHandle; require 5.000; $VERSION = 0.05; sub new { my($class, $fname) = @_; $fname = $fname || $main::ENV{"XAUTHORITY"} || "$main::ENV{HOME}/.Xauthority"; return 0 unless -e $fname; my $self = bless {}, $class; $self->{filename} = $fname; my($fh) = new FileHandle; $fh->open("<$fname") or croak "Can't open $fname: $!"; $self->{filehandle} = $fh; return $self; } sub open { new(@_) } sub read { my($self, $len) = @_; my($buf); my $ret = read $self->{filehandle}, $buf, $len; if (not defined $ret) { croak "Can't read authority file " . $self->{filename} . ": $!"; } elsif ($ret < $len) { warn "Expecting $len bytes, got $ret at " . tell($self->{filename}); croak "Unexpected short read from authority file" . $self->{filename}; } return $buf; } sub get_one { my $self = shift; my(@a, $x); my $warned_nulls = 0; RETRY: { if ($self->{filehandle}->eof) { close $self->{filehandle}; return (); } $x = unpack("n", $self->read(2)); # Family my $type = {256 => 'Local', 65535 => 'Wild', 254 => 'Netname', 253 => 'Krb5Principal', 252 => 'LocalHost', 0 => 'Internet', 1 => 'DECnet', 2 => 'Chaos', 5 => 'ServerInterpreted', 6 => 'InternetV6'}->{$x}; if (not defined($type)) { warn "Error in $self->{filename}: unknown address type $x"; } push @a, $type; $x = unpack("n", $self->read(2)); # Address push @a, $self->read($x); $x = unpack("n", $self->read(2)); # Display `number' push @a, $self->read($x); $x = unpack("n", $self->read(2)); # Authorization name push @a, $self->read($x); $x = unpack("n", $self->read(2)); # Authorization data push @a, $self->read($x); if ($type eq "Internet" and $a[1] eq "" and $a[2] eq "" and $a[3] eq "" and $a[4] eq "") { warn "Error in $self->{filename}: unexpected null bytes" unless $warned_nulls; $warned_nulls = 1; @a = (); next RETRY; } return @a; } } sub get_all { my $self = shift; return @{$self->{data}} if $self->{data}; my(@a, @x); while (@x = $self->get_one) { push @a, [@x]; } $self->{data} = [@a]; return @a; } sub get_by_host { my $self = shift; my($host, $fam, $dpy) = @_; if ($host eq "localhost" or $host eq "127.0.0.1") { require Sys::Hostname; $host = Sys::Hostname::hostname(); } my($addr); $addr = gethostbyname($host) if $fam eq "Internet"; #print "host $host, addr $addr\n"; my($d); for $d ($self->get_all) { next unless $dpy eq $d->[2]; next unless $fam eq $d->[0] or ($fam eq "Internet" and $d->[0] eq "Local"); if ($fam eq "Internet" or $fam eq "Local") { if ($addr && $d->[1] eq $addr or $d->[1] eq $host) { return ($d->[3], $d->[4]); } } } return (); } 1; __END__ =head1 NAME X11::Auth - Perl module to read X11 authority files =head1 SYNOPSIS require X11::Auth; $a = new X11::Auth; ($auth_type, $auth_data) = $a->get_by_host($host, $disp_num); =head1 DESCRIPTION This module is an approximate perl replacement for the libXau C library and the xauth(1) program. It reads and interprets the files (usually '~/.Xauthority') that hold authorization data used in connecting to X servers. Since it was written mainly for the use of X11::Protocol, its functionality is currently restricted to reading, not writing, of these files. =head1 METHODS =head2 new $auth = X11::Auth->new; $auth = X11::Auth->open($filename); Open an authority file, and create an object to handle it. The filename will be taken from the XAUTHORITY environment variable, if present, or '.Xauthority' in the user's home directory, or it may be overridden by an argument. 'open' may be used as a synonym. =head2 get_one ($family, $host_addr, $display_num, $auth_name, $auth_data) = $auth->get_one; Read one entry from the file. Returns a null list at end of file. $family is usually 'Internet' or 'Local', and $display_num can be any string. =head2 get_all @auth_data = $auth->get_all; Read all of the entries in the file. Each member of the array returned is an array ref similar to the list returned by get_one(). =head2 get_by_host ($auth_name, $auth_data) = $auth->get_by_host($host, $family, $display_num); Get authentication data for a connection of type $family to display $display_num on $host. If $family is 'Internet', the host will be translated into an appropriate address by gethostbyname(). If no data is found, returns an empty list. =head1 COMPATIBILITY The following table shows the (rough) correspondence between libXau calls and X11::Auth methods: libXau X11::Auth ------ --------- XauFileName $ENV{XAUTHORITY} || "$ENV{HOME}/.Xauthority" fopen(XauFileName(), "rb") $auth = new X11::Auth XauReadAuth $auth->get_one XauWriteAuth XauGetAuthByAddr $auth->get_by_host XauGetBestAuthByAddr XauLockAuth XauUnlockAuth XauDisposeAuth =head1 AUTHOR Stephen McCamant =head1 SEE ALSO L, L, L, L, lib/Xau/README in the X11 source distribution. =cut X11-Protocol-0.56/Keysyms.pm0000644000175000017500000014650207615075223014271 0ustar smccsmcc# Keysyms.pm semi-automatically derived from: # $XConsortium: keysymdef.h,v 1.21 94/08/28 16:17:06 rws Exp $ # #********************************************************** #Copyright (c) 1987, 1994 X Consortium # #Permission is hereby granted, free of charge, to any person obtaining #a copy of this software and associated documentation files (the #"Software"), to deal in the Software without restriction, including #without limitation the rights to use, copy, modify, merge, publish, #distribute, sublicense, and/or sell copies of the Software, and to #permit persons to whom the Software is furnished to do so, subject to #the following conditions: # #The above copyright notice and this permission notice shall be included #in all copies or substantial portions of the Software. # #THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS #OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF #MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. #IN NO EVENT SHALL THE X CONSORTIUM BE LIABLE FOR ANY CLAIM, DAMAGES OR #OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, #ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR #OTHER DEALINGS IN THE SOFTWARE. # #Except as contained in this notice, the name of the X Consortium shall #not be used in advertising or otherwise to promote the sale, use or #other dealings in this Software without prior written authorization #from the X Consortium. # # #Copyright 1987 by Digital Equipment Corporation, Maynard, Massachusetts # # All Rights Reserved # #Permission to use, copy, modify, and distribute this software and its #documentation for any purpose and without fee is hereby granted, #provided that the above copyright notice appear in all copies and that #both that copyright notice and this permission notice appear in #supporting documentation, and that the name of Digital not be #used in advertising or publicity pertaining to distribution of the #software without specific, written prior permission. # #DIGITAL DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING #ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL #DIGITAL BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR #ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, #WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, #ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS #SOFTWARE. # #***************************************************************** package X11::Keysyms; use Carp; $VERSION = 0.01; sub import { my($pkg, $var, @x) = @_; my($into) = caller(); croak "Need the name of a variable to import into" unless $var; $var =~ s/^%//; my(%KL); if (@x) { @KL{@x} = (1) x @x; } else { @KL{'MISCELLANY', 'XKB_KEYS', 'LATIN1', 'LATIN2', 'LATIN3', 'LATIN4', 'GREEK'} = (1) x 7; } local(*Keysyms) = *{"${into}::$var"}; # print STDERR "Exporting into ${into}::$var\n"; $Keysyms{"VoidSymbol"} = 0xFFFFFF; # void symbol #ifdef XK_MISCELLANY # # * TTY Functions, cleverly chosen to map to ascii, for convenience of # * programming, but could have been arbitrary (at the cost of lookup # * tables in client code. if ($KL{'MISCELLANY'}) { $Keysyms{"BackSpace"} = 0xFF08; # back space, back char $Keysyms{"Tab"} = 0xFF09; $Keysyms{"Linefeed"} = 0xFF0A; # Linefeed, LF $Keysyms{"Clear"} = 0xFF0B; $Keysyms{"Return"} = 0xFF0D; # Return, enter $Keysyms{"Pause"} = 0xFF13; # Pause, hold $Keysyms{"Scroll_Lock"} = 0xFF14; $Keysyms{"Sys_Req"} = 0xFF15; $Keysyms{"Escape"} = 0xFF1B; $Keysyms{"Delete"} = 0xFFFF; # Delete, rubout # International & multi-key character composition $Keysyms{"Multi_key"} = 0xFF20; # Multi-key character compose # Japanese keyboard support $Keysyms{"Kanji"} = 0xFF21; # Kanji, Kanji convert $Keysyms{"Muhenkan"} = 0xFF22; # Cancel Conversion $Keysyms{"Henkan_Mode"} = 0xFF23; # Start/Stop Conversion $Keysyms{"Henkan"} = 0xFF23; # Alias for Henkan_Mode $Keysyms{"Romaji"} = 0xFF24; # to Romaji $Keysyms{"Hiragana"} = 0xFF25; # to Hiragana $Keysyms{"Katakana"} = 0xFF26; # to Katakana $Keysyms{"Hiragana_Katakana"} = 0xFF27; # Hiragana/Katakana toggle $Keysyms{"Zenkaku"} = 0xFF28; # to Zenkaku $Keysyms{"Hankaku"} = 0xFF29; # to Hankaku $Keysyms{"Zenkaku_Hankaku"} = 0xFF2A; # Zenkaku/Hankaku toggle $Keysyms{"Touroku"} = 0xFF2B; # Add to Dictionary $Keysyms{"Massyo"} = 0xFF2C; # Delete from Dictionary $Keysyms{"Kana_Lock"} = 0xFF2D; # Kana Lock $Keysyms{"Kana_Shift"} = 0xFF2E; # Kana Shift $Keysyms{"Eisu_Shift"} = 0xFF2F; # Alphanumeric Shift $Keysyms{"Eisu_toggle"} = 0xFF30; # Alphanumeric toggle # 0xFF31 thru 0xFF3F are under XK_KOREAN # Cursor control & motion $Keysyms{"Home"} = 0xFF50; $Keysyms{"Left"} = 0xFF51; # Move left, left arrow $Keysyms{"Up"} = 0xFF52; # Move up, up arrow $Keysyms{"Right"} = 0xFF53; # Move right, right arrow $Keysyms{"Down"} = 0xFF54; # Move down, down arrow $Keysyms{"Prior"} = 0xFF55; # Prior, previous $Keysyms{"Page_Up"} = 0xFF55; $Keysyms{"Next"} = 0xFF56; # Next $Keysyms{"Page_Down"} = 0xFF56; $Keysyms{"End"} = 0xFF57; # EOL $Keysyms{"Begin"} = 0xFF58; # BOL # Misc Functions $Keysyms{"Select"} = 0xFF60; # Select, mark $Keysyms{"Print"} = 0xFF61; $Keysyms{"Execute"} = 0xFF62; # Execute, run, do $Keysyms{"Insert"} = 0xFF63; # Insert, insert here $Keysyms{"Undo"} = 0xFF65; # Undo, oops $Keysyms{"Redo"} = 0xFF66; # redo, again $Keysyms{"Menu"} = 0xFF67; $Keysyms{"Find"} = 0xFF68; # Find, search $Keysyms{"Cancel"} = 0xFF69; # Cancel, stop, abort, exit $Keysyms{"Help"} = 0xFF6A; # Help $Keysyms{"Break"} = 0xFF6B; $Keysyms{"Mode_switch"} = 0xFF7E; # Character set switch $Keysyms{"script_switch"} = 0xFF7E; # Alias for mode_switch $Keysyms{"Num_Lock"} = 0xFF7F; # Keypad Functions, keypad numbers cleverly chosen to map to ascii $Keysyms{"KP_Space"} = 0xFF80; # space $Keysyms{"KP_Tab"} = 0xFF89; $Keysyms{"KP_Enter"} = 0xFF8D; # enter $Keysyms{"KP_F1"} = 0xFF91; # PF1, KP_A, ... $Keysyms{"KP_F2"} = 0xFF92; $Keysyms{"KP_F3"} = 0xFF93; $Keysyms{"KP_F4"} = 0xFF94; $Keysyms{"KP_Home"} = 0xFF95; $Keysyms{"KP_Left"} = 0xFF96; $Keysyms{"KP_Up"} = 0xFF97; $Keysyms{"KP_Right"} = 0xFF98; $Keysyms{"KP_Down"} = 0xFF99; $Keysyms{"KP_Prior"} = 0xFF9A; $Keysyms{"KP_Page_Up"} = 0xFF9A; $Keysyms{"KP_Next"} = 0xFF9B; $Keysyms{"KP_Page_Down"} = 0xFF9B; $Keysyms{"KP_End"} = 0xFF9C; $Keysyms{"KP_Begin"} = 0xFF9D; $Keysyms{"KP_Insert"} = 0xFF9E; $Keysyms{"KP_Delete"} = 0xFF9F; $Keysyms{"KP_Equal"} = 0xFFBD; # equals $Keysyms{"KP_Multiply"} = 0xFFAA; $Keysyms{"KP_Add"} = 0xFFAB; $Keysyms{"KP_Separator"} = 0xFFAC; # separator, often comma $Keysyms{"KP_Subtract"} = 0xFFAD; $Keysyms{"KP_Decimal"} = 0xFFAE; $Keysyms{"KP_Divide"} = 0xFFAF; $Keysyms{"KP_0"} = 0xFFB0; $Keysyms{"KP_1"} = 0xFFB1; $Keysyms{"KP_2"} = 0xFFB2; $Keysyms{"KP_3"} = 0xFFB3; $Keysyms{"KP_4"} = 0xFFB4; $Keysyms{"KP_5"} = 0xFFB5; $Keysyms{"KP_6"} = 0xFFB6; $Keysyms{"KP_7"} = 0xFFB7; $Keysyms{"KP_8"} = 0xFFB8; $Keysyms{"KP_9"} = 0xFFB9; # # * Auxilliary Functions; note the duplicate definitions for left and right # * function keys; Sun keyboards and a few other manufactures have such # * function key groups on the left and/or right sides of the keyboard. # * We've not found a keyboard with more than 35 function keys total. $Keysyms{"F1"} = 0xFFBE; $Keysyms{"F2"} = 0xFFBF; $Keysyms{"F3"} = 0xFFC0; $Keysyms{"F4"} = 0xFFC1; $Keysyms{"F5"} = 0xFFC2; $Keysyms{"F6"} = 0xFFC3; $Keysyms{"F7"} = 0xFFC4; $Keysyms{"F8"} = 0xFFC5; $Keysyms{"F9"} = 0xFFC6; $Keysyms{"F10"} = 0xFFC7; $Keysyms{"F11"} = 0xFFC8; $Keysyms{"L1"} = 0xFFC8; $Keysyms{"F12"} = 0xFFC9; $Keysyms{"L2"} = 0xFFC9; $Keysyms{"F13"} = 0xFFCA; $Keysyms{"L3"} = 0xFFCA; $Keysyms{"F14"} = 0xFFCB; $Keysyms{"L4"} = 0xFFCB; $Keysyms{"F15"} = 0xFFCC; $Keysyms{"L5"} = 0xFFCC; $Keysyms{"F16"} = 0xFFCD; $Keysyms{"L6"} = 0xFFCD; $Keysyms{"F17"} = 0xFFCE; $Keysyms{"L7"} = 0xFFCE; $Keysyms{"F18"} = 0xFFCF; $Keysyms{"L8"} = 0xFFCF; $Keysyms{"F19"} = 0xFFD0; $Keysyms{"L9"} = 0xFFD0; $Keysyms{"F20"} = 0xFFD1; $Keysyms{"L10"} = 0xFFD1; $Keysyms{"F21"} = 0xFFD2; $Keysyms{"R1"} = 0xFFD2; $Keysyms{"F22"} = 0xFFD3; $Keysyms{"R2"} = 0xFFD3; $Keysyms{"F23"} = 0xFFD4; $Keysyms{"R3"} = 0xFFD4; $Keysyms{"F24"} = 0xFFD5; $Keysyms{"R4"} = 0xFFD5; $Keysyms{"F25"} = 0xFFD6; $Keysyms{"R5"} = 0xFFD6; $Keysyms{"F26"} = 0xFFD7; $Keysyms{"R6"} = 0xFFD7; $Keysyms{"F27"} = 0xFFD8; $Keysyms{"R7"} = 0xFFD8; $Keysyms{"F28"} = 0xFFD9; $Keysyms{"R8"} = 0xFFD9; $Keysyms{"F29"} = 0xFFDA; $Keysyms{"R9"} = 0xFFDA; $Keysyms{"F30"} = 0xFFDB; $Keysyms{"R10"} = 0xFFDB; $Keysyms{"F31"} = 0xFFDC; $Keysyms{"R11"} = 0xFFDC; $Keysyms{"F32"} = 0xFFDD; $Keysyms{"R12"} = 0xFFDD; $Keysyms{"F33"} = 0xFFDE; $Keysyms{"R13"} = 0xFFDE; $Keysyms{"F34"} = 0xFFDF; $Keysyms{"R14"} = 0xFFDF; $Keysyms{"F35"} = 0xFFE0; $Keysyms{"R15"} = 0xFFE0; # Modifiers $Keysyms{"Shift_L"} = 0xFFE1; # Left shift $Keysyms{"Shift_R"} = 0xFFE2; # Right shift $Keysyms{"Control_L"} = 0xFFE3; # Left control $Keysyms{"Control_R"} = 0xFFE4; # Right control $Keysyms{"Caps_Lock"} = 0xFFE5; # Caps lock $Keysyms{"Shift_Lock"} = 0xFFE6; # Shift lock $Keysyms{"Meta_L"} = 0xFFE7; # Left meta $Keysyms{"Meta_R"} = 0xFFE8; # Right meta $Keysyms{"Alt_L"} = 0xFFE9; # Left alt $Keysyms{"Alt_R"} = 0xFFEA; # Right alt $Keysyms{"Super_L"} = 0xFFEB; # Left super $Keysyms{"Super_R"} = 0xFFEC; # Right super $Keysyms{"Hyper_L"} = 0xFFED; # Left hyper $Keysyms{"Hyper_R"} = 0xFFEE; # Right hyper } #endif # XK_MISCELLANY # # * ISO 9995 Function and Modifier Keys # * Byte 3 = 0xFE #ifdef XK_XKB_KEYS if ($KL{'XKB_KEYS'}) { $Keysyms{"ISO_Lock"} = 0xFE01; $Keysyms{"ISO_Level2_Latch"} = 0xFE02; $Keysyms{"ISO_Level3_Shift"} = 0xFE03; $Keysyms{"ISO_Level3_Latch"} = 0xFE04; $Keysyms{"ISO_Level3_Lock"} = 0xFE05; $Keysyms{"ISO_Group_Shift"} = 0xFF7E; # Alias for mode_switch $Keysyms{"ISO_Group_Latch"} = 0xFE06; $Keysyms{"ISO_Group_Lock"} = 0xFE07; $Keysyms{"ISO_Next_Group"} = 0xFE08; $Keysyms{"ISO_Next_Group_Lock"} = 0xFE09; $Keysyms{"ISO_Prev_Group"} = 0xFE0A; $Keysyms{"ISO_Prev_Group_Lock"} = 0xFE0B; $Keysyms{"ISO_First_Group"} = 0xFE0C; $Keysyms{"ISO_First_Group_Lock"} = 0xFE0D; $Keysyms{"ISO_Last_Group"} = 0xFE0E; $Keysyms{"ISO_Last_Group_Lock"} = 0xFE0F; $Keysyms{"ISO_Left_Tab"} = 0xFE20; $Keysyms{"ISO_Move_Line_Up"} = 0xFE21; $Keysyms{"ISO_Move_Line_Down"} = 0xFE22; $Keysyms{"ISO_Partial_Line_Up"} = 0xFE23; $Keysyms{"ISO_Partial_Line_Down"} = 0xFE24; $Keysyms{"ISO_Partial_Space_Left"} = 0xFE25; $Keysyms{"ISO_Partial_Space_Right"} = 0xFE26; $Keysyms{"ISO_Set_Margin_Left"} = 0xFE27; $Keysyms{"ISO_Set_Margin_Right"} = 0xFE28; $Keysyms{"ISO_Release_Margin_Left"} = 0xFE29; $Keysyms{"ISO_Release_Margin_Right"} = 0xFE2A; $Keysyms{"ISO_Release_Both_Margins"} = 0xFE2B; $Keysyms{"ISO_Fast_Cursor_Left"} = 0xFE2C; $Keysyms{"ISO_Fast_Cursor_Right"} = 0xFE2D; $Keysyms{"ISO_Fast_Cursor_Up"} = 0xFE2E; $Keysyms{"ISO_Fast_Cursor_Down"} = 0xFE2F; $Keysyms{"ISO_Continuous_Underline"} = 0xFE30; $Keysyms{"ISO_Discontinuous_Underline"} = 0xFE31; $Keysyms{"ISO_Emphasize"} = 0xFE32; $Keysyms{"ISO_Center_Object"} = 0xFE33; $Keysyms{"ISO_Enter"} = 0xFE34; $Keysyms{"dead_grave"} = 0xFE50; $Keysyms{"dead_acute"} = 0xFE51; $Keysyms{"dead_circumflex"} = 0xFE52; $Keysyms{"dead_tilde"} = 0xFE53; $Keysyms{"dead_macron"} = 0xFE54; $Keysyms{"dead_breve"} = 0xFE55; $Keysyms{"dead_abovedot"} = 0xFE56; $Keysyms{"dead_diaeresis"} = 0xFE57; $Keysyms{"dead_abovering"} = 0xFE58; $Keysyms{"dead_doubleacute"} = 0xFE59; $Keysyms{"dead_caron"} = 0xFE5A; $Keysyms{"dead_cedilla"} = 0xFE5B; $Keysyms{"dead_ogonek"} = 0xFE5C; $Keysyms{"dead_iota"} = 0xFE5D; $Keysyms{"dead_voiced_sound"} = 0xFE5E; $Keysyms{"dead_semivoiced_sound"} = 0xFE5F; $Keysyms{"First_Virtual_Screen"} = 0xFED0; $Keysyms{"Prev_Virtual_Screen"} = 0xFED1; $Keysyms{"Next_Virtual_Screen"} = 0xFED2; $Keysyms{"Last_Virtual_Screen"} = 0xFED4; $Keysyms{"Terminate_Server"} = 0xFED5; $Keysyms{"Pointer_Left"} = 0xFEE0; $Keysyms{"Pointer_Right"} = 0xFEE1; $Keysyms{"Pointer_Up"} = 0xFEE2; $Keysyms{"Pointer_Down"} = 0xFEE3; $Keysyms{"Pointer_UpLeft"} = 0xFEE4; $Keysyms{"Pointer_UpRight"} = 0xFEE5; $Keysyms{"Pointer_DownLeft"} = 0xFEE6; $Keysyms{"Pointer_DownRight"} = 0xFEE7; $Keysyms{"Pointer_Button_Dflt"} = 0xFEE8; $Keysyms{"Pointer_Button1"} = 0xFEE9; $Keysyms{"Pointer_Button2"} = 0xFEEA; $Keysyms{"Pointer_Button3"} = 0xFEEB; $Keysyms{"Pointer_Button4"} = 0xFEEC; $Keysyms{"Pointer_Button5"} = 0xFEED; $Keysyms{"Pointer_DblClick_Dflt"} = 0xFEEE; $Keysyms{"Pointer_DblClick1"} = 0xFEEF; $Keysyms{"Pointer_DblClick2"} = 0xFEF0; $Keysyms{"Pointer_DblClick3"} = 0xFEF1; $Keysyms{"Pointer_DblClick4"} = 0xFEF2; $Keysyms{"Pointer_DblClick5"} = 0xFEF3; $Keysyms{"Pointer_Drag_Dflt"} = 0xFEF4; $Keysyms{"Pointer_Drag1"} = 0xFEF5; $Keysyms{"Pointer_Drag2"} = 0xFEF6; $Keysyms{"Pointer_Drag3"} = 0xFEF7; $Keysyms{"Pointer_Drag4"} = 0xFEF8; $Keysyms{"Pointer_EnableKeys"} = 0xFEF9; $Keysyms{"Pointer_Accelerate"} = 0xFEFA; $Keysyms{"Pointer_DfltBtnNext"} = 0xFEFB; $Keysyms{"Pointer_DfltBtnPrev"} = 0xFEFC; } #endif # # * 3270 Terminal Keys # * Byte 3 = 0xFD #ifdef XK_3270 if ($KL{'3270'}) { $Keysyms{"3270_Duplicate"} = 0xFD01; $Keysyms{"3270_FieldMark"} = 0xFD02; $Keysyms{"3270_Right2"} = 0xFD03; $Keysyms{"3270_Left2"} = 0xFD04; $Keysyms{"3270_BackTab"} = 0xFD05; $Keysyms{"3270_EraseEOF"} = 0xFD06; $Keysyms{"3270_EraseInput"} = 0xFD07; $Keysyms{"3270_Reset"} = 0xFD08; $Keysyms{"3270_Quit"} = 0xFD09; $Keysyms{"3270_PA1"} = 0xFD0A; $Keysyms{"3270_PA2"} = 0xFD0B; $Keysyms{"3270_PA3"} = 0xFD0C; $Keysyms{"3270_Test"} = 0xFD0D; $Keysyms{"3270_Attn"} = 0xFD0E; $Keysyms{"3270_CursorBlink"} = 0xFD0F; $Keysyms{"3270_AltCursor"} = 0xFD10; $Keysyms{"3270_KeyClick"} = 0xFD11; $Keysyms{"3270_Jump"} = 0xFD12; $Keysyms{"3270_Ident"} = 0xFD13; $Keysyms{"3270_Rule"} = 0xFD14; $Keysyms{"3270_Copy"} = 0xFD15; $Keysyms{"3270_Play"} = 0xFD16; $Keysyms{"3270_Setup"} = 0xFD17; $Keysyms{"3270_Record"} = 0xFD18; $Keysyms{"3270_ChangeScreen"} = 0xFD19; $Keysyms{"3270_DeleteWord"} = 0xFD1A; $Keysyms{"3270_ExSelect"} = 0xFD1B; $Keysyms{"3270_CursorSelect"} = 0xFD1C; $Keysyms{"3270_PrintScreen"} = 0xFD1D; $Keysyms{"3270_Enter"} = 0xFD1E; } #endif # # * Latin 1 # * Byte 3 = 0 #ifdef XK_LATIN1 if ($KL{'LATIN1'}) { $Keysyms{"space"} = 0x020; $Keysyms{"exclam"} = 0x021; $Keysyms{"quotedbl"} = 0x022; $Keysyms{"numbersign"} = 0x023; $Keysyms{"dollar"} = 0x024; $Keysyms{"percent"} = 0x025; $Keysyms{"ampersand"} = 0x026; $Keysyms{"apostrophe"} = 0x027; $Keysyms{"quoteright"} = 0x027; # deprecated $Keysyms{"parenleft"} = 0x028; $Keysyms{"parenright"} = 0x029; $Keysyms{"asterisk"} = 0x02a; $Keysyms{"plus"} = 0x02b; $Keysyms{"comma"} = 0x02c; $Keysyms{"minus"} = 0x02d; $Keysyms{"period"} = 0x02e; $Keysyms{"slash"} = 0x02f; $Keysyms{"0"} = 0x030; $Keysyms{"1"} = 0x031; $Keysyms{"2"} = 0x032; $Keysyms{"3"} = 0x033; $Keysyms{"4"} = 0x034; $Keysyms{"5"} = 0x035; $Keysyms{"6"} = 0x036; $Keysyms{"7"} = 0x037; $Keysyms{"8"} = 0x038; $Keysyms{"9"} = 0x039; $Keysyms{"colon"} = 0x03a; $Keysyms{"semicolon"} = 0x03b; $Keysyms{"less"} = 0x03c; $Keysyms{"equal"} = 0x03d; $Keysyms{"greater"} = 0x03e; $Keysyms{"question"} = 0x03f; $Keysyms{"at"} = 0x040; $Keysyms{"A"} = 0x041; $Keysyms{"B"} = 0x042; $Keysyms{"C"} = 0x043; $Keysyms{"D"} = 0x044; $Keysyms{"E"} = 0x045; $Keysyms{"F"} = 0x046; $Keysyms{"G"} = 0x047; $Keysyms{"H"} = 0x048; $Keysyms{"I"} = 0x049; $Keysyms{"J"} = 0x04a; $Keysyms{"K"} = 0x04b; $Keysyms{"L"} = 0x04c; $Keysyms{"M"} = 0x04d; $Keysyms{"N"} = 0x04e; $Keysyms{"O"} = 0x04f; $Keysyms{"P"} = 0x050; $Keysyms{"Q"} = 0x051; $Keysyms{"R"} = 0x052; $Keysyms{"S"} = 0x053; $Keysyms{"T"} = 0x054; $Keysyms{"U"} = 0x055; $Keysyms{"V"} = 0x056; $Keysyms{"W"} = 0x057; $Keysyms{"X"} = 0x058; $Keysyms{"Y"} = 0x059; $Keysyms{"Z"} = 0x05a; $Keysyms{"bracketleft"} = 0x05b; $Keysyms{"backslash"} = 0x05c; $Keysyms{"bracketright"} = 0x05d; $Keysyms{"asciicircum"} = 0x05e; $Keysyms{"underscore"} = 0x05f; $Keysyms{"grave"} = 0x060; $Keysyms{"quoteleft"} = 0x060; # deprecated $Keysyms{"a"} = 0x061; $Keysyms{"b"} = 0x062; $Keysyms{"c"} = 0x063; $Keysyms{"d"} = 0x064; $Keysyms{"e"} = 0x065; $Keysyms{"f"} = 0x066; $Keysyms{"g"} = 0x067; $Keysyms{"h"} = 0x068; $Keysyms{"i"} = 0x069; $Keysyms{"j"} = 0x06a; $Keysyms{"k"} = 0x06b; $Keysyms{"l"} = 0x06c; $Keysyms{"m"} = 0x06d; $Keysyms{"n"} = 0x06e; $Keysyms{"o"} = 0x06f; $Keysyms{"p"} = 0x070; $Keysyms{"q"} = 0x071; $Keysyms{"r"} = 0x072; $Keysyms{"s"} = 0x073; $Keysyms{"t"} = 0x074; $Keysyms{"u"} = 0x075; $Keysyms{"v"} = 0x076; $Keysyms{"w"} = 0x077; $Keysyms{"x"} = 0x078; $Keysyms{"y"} = 0x079; $Keysyms{"z"} = 0x07a; $Keysyms{"braceleft"} = 0x07b; $Keysyms{"bar"} = 0x07c; $Keysyms{"braceright"} = 0x07d; $Keysyms{"asciitilde"} = 0x07e; $Keysyms{"nobreakspace"} = 0x0a0; $Keysyms{"exclamdown"} = 0x0a1; $Keysyms{"cent"} = 0x0a2; $Keysyms{"sterling"} = 0x0a3; $Keysyms{"currency"} = 0x0a4; $Keysyms{"yen"} = 0x0a5; $Keysyms{"brokenbar"} = 0x0a6; $Keysyms{"section"} = 0x0a7; $Keysyms{"diaeresis"} = 0x0a8; $Keysyms{"copyright"} = 0x0a9; $Keysyms{"ordfeminine"} = 0x0aa; $Keysyms{"guillemotleft"} = 0x0ab; # left angle quotation mark $Keysyms{"notsign"} = 0x0ac; $Keysyms{"hyphen"} = 0x0ad; $Keysyms{"registered"} = 0x0ae; $Keysyms{"macron"} = 0x0af; $Keysyms{"degree"} = 0x0b0; $Keysyms{"plusminus"} = 0x0b1; $Keysyms{"twosuperior"} = 0x0b2; $Keysyms{"threesuperior"} = 0x0b3; $Keysyms{"acute"} = 0x0b4; $Keysyms{"mu"} = 0x0b5; $Keysyms{"paragraph"} = 0x0b6; $Keysyms{"periodcentered"} = 0x0b7; $Keysyms{"cedilla"} = 0x0b8; $Keysyms{"onesuperior"} = 0x0b9; $Keysyms{"masculine"} = 0x0ba; $Keysyms{"guillemotright"} = 0x0bb; # right angle quotation mark $Keysyms{"onequarter"} = 0x0bc; $Keysyms{"onehalf"} = 0x0bd; $Keysyms{"threequarters"} = 0x0be; $Keysyms{"questiondown"} = 0x0bf; $Keysyms{"Agrave"} = 0x0c0; $Keysyms{"Aacute"} = 0x0c1; $Keysyms{"Acircumflex"} = 0x0c2; $Keysyms{"Atilde"} = 0x0c3; $Keysyms{"Adiaeresis"} = 0x0c4; $Keysyms{"Aring"} = 0x0c5; $Keysyms{"AE"} = 0x0c6; $Keysyms{"Ccedilla"} = 0x0c7; $Keysyms{"Egrave"} = 0x0c8; $Keysyms{"Eacute"} = 0x0c9; $Keysyms{"Ecircumflex"} = 0x0ca; $Keysyms{"Ediaeresis"} = 0x0cb; $Keysyms{"Igrave"} = 0x0cc; $Keysyms{"Iacute"} = 0x0cd; $Keysyms{"Icircumflex"} = 0x0ce; $Keysyms{"Idiaeresis"} = 0x0cf; $Keysyms{"ETH"} = 0x0d0; $Keysyms{"Eth"} = 0x0d0; # deprecated $Keysyms{"Ntilde"} = 0x0d1; $Keysyms{"Ograve"} = 0x0d2; $Keysyms{"Oacute"} = 0x0d3; $Keysyms{"Ocircumflex"} = 0x0d4; $Keysyms{"Otilde"} = 0x0d5; $Keysyms{"Odiaeresis"} = 0x0d6; $Keysyms{"multiply"} = 0x0d7; $Keysyms{"Ooblique"} = 0x0d8; $Keysyms{"Ugrave"} = 0x0d9; $Keysyms{"Uacute"} = 0x0da; $Keysyms{"Ucircumflex"} = 0x0db; $Keysyms{"Udiaeresis"} = 0x0dc; $Keysyms{"Yacute"} = 0x0dd; $Keysyms{"THORN"} = 0x0de; $Keysyms{"Thorn"} = 0x0de; # deprecated $Keysyms{"ssharp"} = 0x0df; $Keysyms{"agrave"} = 0x0e0; $Keysyms{"aacute"} = 0x0e1; $Keysyms{"acircumflex"} = 0x0e2; $Keysyms{"atilde"} = 0x0e3; $Keysyms{"adiaeresis"} = 0x0e4; $Keysyms{"aring"} = 0x0e5; $Keysyms{"ae"} = 0x0e6; $Keysyms{"ccedilla"} = 0x0e7; $Keysyms{"egrave"} = 0x0e8; $Keysyms{"eacute"} = 0x0e9; $Keysyms{"ecircumflex"} = 0x0ea; $Keysyms{"ediaeresis"} = 0x0eb; $Keysyms{"igrave"} = 0x0ec; $Keysyms{"iacute"} = 0x0ed; $Keysyms{"icircumflex"} = 0x0ee; $Keysyms{"idiaeresis"} = 0x0ef; $Keysyms{"eth"} = 0x0f0; $Keysyms{"ntilde"} = 0x0f1; $Keysyms{"ograve"} = 0x0f2; $Keysyms{"oacute"} = 0x0f3; $Keysyms{"ocircumflex"} = 0x0f4; $Keysyms{"otilde"} = 0x0f5; $Keysyms{"odiaeresis"} = 0x0f6; $Keysyms{"division"} = 0x0f7; $Keysyms{"oslash"} = 0x0f8; $Keysyms{"ugrave"} = 0x0f9; $Keysyms{"uacute"} = 0x0fa; $Keysyms{"ucircumflex"} = 0x0fb; $Keysyms{"udiaeresis"} = 0x0fc; $Keysyms{"yacute"} = 0x0fd; $Keysyms{"thorn"} = 0x0fe; $Keysyms{"ydiaeresis"} = 0x0ff; } #endif # XK_LATIN1 # # * Latin 2 # * Byte 3 = 1 #ifdef XK_LATIN2 if ($KL{'LATIN2'}) { $Keysyms{"Aogonek"} = 0x1a1; $Keysyms{"breve"} = 0x1a2; $Keysyms{"Lstroke"} = 0x1a3; $Keysyms{"Lcaron"} = 0x1a5; $Keysyms{"Sacute"} = 0x1a6; $Keysyms{"Scaron"} = 0x1a9; $Keysyms{"Scedilla"} = 0x1aa; $Keysyms{"Tcaron"} = 0x1ab; $Keysyms{"Zacute"} = 0x1ac; $Keysyms{"Zcaron"} = 0x1ae; $Keysyms{"Zabovedot"} = 0x1af; $Keysyms{"aogonek"} = 0x1b1; $Keysyms{"ogonek"} = 0x1b2; $Keysyms{"lstroke"} = 0x1b3; $Keysyms{"lcaron"} = 0x1b5; $Keysyms{"sacute"} = 0x1b6; $Keysyms{"caron"} = 0x1b7; $Keysyms{"scaron"} = 0x1b9; $Keysyms{"scedilla"} = 0x1ba; $Keysyms{"tcaron"} = 0x1bb; $Keysyms{"zacute"} = 0x1bc; $Keysyms{"doubleacute"} = 0x1bd; $Keysyms{"zcaron"} = 0x1be; $Keysyms{"zabovedot"} = 0x1bf; $Keysyms{"Racute"} = 0x1c0; $Keysyms{"Abreve"} = 0x1c3; $Keysyms{"Lacute"} = 0x1c5; $Keysyms{"Cacute"} = 0x1c6; $Keysyms{"Ccaron"} = 0x1c8; $Keysyms{"Eogonek"} = 0x1ca; $Keysyms{"Ecaron"} = 0x1cc; $Keysyms{"Dcaron"} = 0x1cf; $Keysyms{"Dstroke"} = 0x1d0; $Keysyms{"Nacute"} = 0x1d1; $Keysyms{"Ncaron"} = 0x1d2; $Keysyms{"Odoubleacute"} = 0x1d5; $Keysyms{"Rcaron"} = 0x1d8; $Keysyms{"Uring"} = 0x1d9; $Keysyms{"Udoubleacute"} = 0x1db; $Keysyms{"Tcedilla"} = 0x1de; $Keysyms{"racute"} = 0x1e0; $Keysyms{"abreve"} = 0x1e3; $Keysyms{"lacute"} = 0x1e5; $Keysyms{"cacute"} = 0x1e6; $Keysyms{"ccaron"} = 0x1e8; $Keysyms{"eogonek"} = 0x1ea; $Keysyms{"ecaron"} = 0x1ec; $Keysyms{"dcaron"} = 0x1ef; $Keysyms{"dstroke"} = 0x1f0; $Keysyms{"nacute"} = 0x1f1; $Keysyms{"ncaron"} = 0x1f2; $Keysyms{"odoubleacute"} = 0x1f5; $Keysyms{"udoubleacute"} = 0x1fb; $Keysyms{"rcaron"} = 0x1f8; $Keysyms{"uring"} = 0x1f9; $Keysyms{"tcedilla"} = 0x1fe; $Keysyms{"abovedot"} = 0x1ff; } #endif # XK_LATIN2 # # * Latin 3 # * Byte 3 = 2 #ifdef XK_LATIN3 if ($KL{'LATIN3'}) { $Keysyms{"Hstroke"} = 0x2a1; $Keysyms{"Hcircumflex"} = 0x2a6; $Keysyms{"Iabovedot"} = 0x2a9; $Keysyms{"Gbreve"} = 0x2ab; $Keysyms{"Jcircumflex"} = 0x2ac; $Keysyms{"hstroke"} = 0x2b1; $Keysyms{"hcircumflex"} = 0x2b6; $Keysyms{"idotless"} = 0x2b9; $Keysyms{"gbreve"} = 0x2bb; $Keysyms{"jcircumflex"} = 0x2bc; $Keysyms{"Cabovedot"} = 0x2c5; $Keysyms{"Ccircumflex"} = 0x2c6; $Keysyms{"Gabovedot"} = 0x2d5; $Keysyms{"Gcircumflex"} = 0x2d8; $Keysyms{"Ubreve"} = 0x2dd; $Keysyms{"Scircumflex"} = 0x2de; $Keysyms{"cabovedot"} = 0x2e5; $Keysyms{"ccircumflex"} = 0x2e6; $Keysyms{"gabovedot"} = 0x2f5; $Keysyms{"gcircumflex"} = 0x2f8; $Keysyms{"ubreve"} = 0x2fd; $Keysyms{"scircumflex"} = 0x2fe; } #endif # XK_LATIN3 # # * Latin 4 # * Byte 3 = 3 #ifdef XK_LATIN4 if ($KL{'LATIN4'}) { $Keysyms{"kra"} = 0x3a2; $Keysyms{"kappa"} = 0x3a2; # deprecated $Keysyms{"Rcedilla"} = 0x3a3; $Keysyms{"Itilde"} = 0x3a5; $Keysyms{"Lcedilla"} = 0x3a6; $Keysyms{"Emacron"} = 0x3aa; $Keysyms{"Gcedilla"} = 0x3ab; $Keysyms{"Tslash"} = 0x3ac; $Keysyms{"rcedilla"} = 0x3b3; $Keysyms{"itilde"} = 0x3b5; $Keysyms{"lcedilla"} = 0x3b6; $Keysyms{"emacron"} = 0x3ba; $Keysyms{"gcedilla"} = 0x3bb; $Keysyms{"tslash"} = 0x3bc; $Keysyms{"ENG"} = 0x3bd; $Keysyms{"eng"} = 0x3bf; $Keysyms{"Amacron"} = 0x3c0; $Keysyms{"Iogonek"} = 0x3c7; $Keysyms{"Eabovedot"} = 0x3cc; $Keysyms{"Imacron"} = 0x3cf; $Keysyms{"Ncedilla"} = 0x3d1; $Keysyms{"Omacron"} = 0x3d2; $Keysyms{"Kcedilla"} = 0x3d3; $Keysyms{"Uogonek"} = 0x3d9; $Keysyms{"Utilde"} = 0x3dd; $Keysyms{"Umacron"} = 0x3de; $Keysyms{"amacron"} = 0x3e0; $Keysyms{"iogonek"} = 0x3e7; $Keysyms{"eabovedot"} = 0x3ec; $Keysyms{"imacron"} = 0x3ef; $Keysyms{"ncedilla"} = 0x3f1; $Keysyms{"omacron"} = 0x3f2; $Keysyms{"kcedilla"} = 0x3f3; $Keysyms{"uogonek"} = 0x3f9; $Keysyms{"utilde"} = 0x3fd; $Keysyms{"umacron"} = 0x3fe; } #endif # XK_LATIN4 # # * Katakana # * Byte 3 = 4 #ifdef XK_KATAKANA if ($KL{'KATAKANA'}) { $Keysyms{"overline"} = 0x47e; $Keysyms{"kana_fullstop"} = 0x4a1; $Keysyms{"kana_openingbracket"} = 0x4a2; $Keysyms{"kana_closingbracket"} = 0x4a3; $Keysyms{"kana_comma"} = 0x4a4; $Keysyms{"kana_conjunctive"} = 0x4a5; $Keysyms{"kana_middledot"} = 0x4a5; # deprecated $Keysyms{"kana_WO"} = 0x4a6; $Keysyms{"kana_a"} = 0x4a7; $Keysyms{"kana_i"} = 0x4a8; $Keysyms{"kana_u"} = 0x4a9; $Keysyms{"kana_e"} = 0x4aa; $Keysyms{"kana_o"} = 0x4ab; $Keysyms{"kana_ya"} = 0x4ac; $Keysyms{"kana_yu"} = 0x4ad; $Keysyms{"kana_yo"} = 0x4ae; $Keysyms{"kana_tsu"} = 0x4af; $Keysyms{"kana_tu"} = 0x4af; # deprecated $Keysyms{"prolongedsound"} = 0x4b0; $Keysyms{"kana_A"} = 0x4b1; $Keysyms{"kana_I"} = 0x4b2; $Keysyms{"kana_U"} = 0x4b3; $Keysyms{"kana_E"} = 0x4b4; $Keysyms{"kana_O"} = 0x4b5; $Keysyms{"kana_KA"} = 0x4b6; $Keysyms{"kana_KI"} = 0x4b7; $Keysyms{"kana_KU"} = 0x4b8; $Keysyms{"kana_KE"} = 0x4b9; $Keysyms{"kana_KO"} = 0x4ba; $Keysyms{"kana_SA"} = 0x4bb; $Keysyms{"kana_SHI"} = 0x4bc; $Keysyms{"kana_SU"} = 0x4bd; $Keysyms{"kana_SE"} = 0x4be; $Keysyms{"kana_SO"} = 0x4bf; $Keysyms{"kana_TA"} = 0x4c0; $Keysyms{"kana_CHI"} = 0x4c1; $Keysyms{"kana_TI"} = 0x4c1; # deprecated $Keysyms{"kana_TSU"} = 0x4c2; $Keysyms{"kana_TU"} = 0x4c2; # deprecated $Keysyms{"kana_TE"} = 0x4c3; $Keysyms{"kana_TO"} = 0x4c4; $Keysyms{"kana_NA"} = 0x4c5; $Keysyms{"kana_NI"} = 0x4c6; $Keysyms{"kana_NU"} = 0x4c7; $Keysyms{"kana_NE"} = 0x4c8; $Keysyms{"kana_NO"} = 0x4c9; $Keysyms{"kana_HA"} = 0x4ca; $Keysyms{"kana_HI"} = 0x4cb; $Keysyms{"kana_FU"} = 0x4cc; $Keysyms{"kana_HU"} = 0x4cc; # deprecated $Keysyms{"kana_HE"} = 0x4cd; $Keysyms{"kana_HO"} = 0x4ce; $Keysyms{"kana_MA"} = 0x4cf; $Keysyms{"kana_MI"} = 0x4d0; $Keysyms{"kana_MU"} = 0x4d1; $Keysyms{"kana_ME"} = 0x4d2; $Keysyms{"kana_MO"} = 0x4d3; $Keysyms{"kana_YA"} = 0x4d4; $Keysyms{"kana_YU"} = 0x4d5; $Keysyms{"kana_YO"} = 0x4d6; $Keysyms{"kana_RA"} = 0x4d7; $Keysyms{"kana_RI"} = 0x4d8; $Keysyms{"kana_RU"} = 0x4d9; $Keysyms{"kana_RE"} = 0x4da; $Keysyms{"kana_RO"} = 0x4db; $Keysyms{"kana_WA"} = 0x4dc; $Keysyms{"kana_N"} = 0x4dd; $Keysyms{"voicedsound"} = 0x4de; $Keysyms{"semivoicedsound"} = 0x4df; $Keysyms{"kana_switch"} = 0xFF7E; # Alias for mode_switch } #endif # XK_KATAKANA # # * Arabic # * Byte 3 = 5 #ifdef XK_ARABIC if ($KL{'ARABIC'}) { $Keysyms{"Arabic_comma"} = 0x5ac; $Keysyms{"Arabic_semicolon"} = 0x5bb; $Keysyms{"Arabic_question_mark"} = 0x5bf; $Keysyms{"Arabic_hamza"} = 0x5c1; $Keysyms{"Arabic_maddaonalef"} = 0x5c2; $Keysyms{"Arabic_hamzaonalef"} = 0x5c3; $Keysyms{"Arabic_hamzaonwaw"} = 0x5c4; $Keysyms{"Arabic_hamzaunderalef"} = 0x5c5; $Keysyms{"Arabic_hamzaonyeh"} = 0x5c6; $Keysyms{"Arabic_alef"} = 0x5c7; $Keysyms{"Arabic_beh"} = 0x5c8; $Keysyms{"Arabic_tehmarbuta"} = 0x5c9; $Keysyms{"Arabic_teh"} = 0x5ca; $Keysyms{"Arabic_theh"} = 0x5cb; $Keysyms{"Arabic_jeem"} = 0x5cc; $Keysyms{"Arabic_hah"} = 0x5cd; $Keysyms{"Arabic_khah"} = 0x5ce; $Keysyms{"Arabic_dal"} = 0x5cf; $Keysyms{"Arabic_thal"} = 0x5d0; $Keysyms{"Arabic_ra"} = 0x5d1; $Keysyms{"Arabic_zain"} = 0x5d2; $Keysyms{"Arabic_seen"} = 0x5d3; $Keysyms{"Arabic_sheen"} = 0x5d4; $Keysyms{"Arabic_sad"} = 0x5d5; $Keysyms{"Arabic_dad"} = 0x5d6; $Keysyms{"Arabic_tah"} = 0x5d7; $Keysyms{"Arabic_zah"} = 0x5d8; $Keysyms{"Arabic_ain"} = 0x5d9; $Keysyms{"Arabic_ghain"} = 0x5da; $Keysyms{"Arabic_tatweel"} = 0x5e0; $Keysyms{"Arabic_feh"} = 0x5e1; $Keysyms{"Arabic_qaf"} = 0x5e2; $Keysyms{"Arabic_kaf"} = 0x5e3; $Keysyms{"Arabic_lam"} = 0x5e4; $Keysyms{"Arabic_meem"} = 0x5e5; $Keysyms{"Arabic_noon"} = 0x5e6; $Keysyms{"Arabic_ha"} = 0x5e7; $Keysyms{"Arabic_heh"} = 0x5e7; # deprecated $Keysyms{"Arabic_waw"} = 0x5e8; $Keysyms{"Arabic_alefmaksura"} = 0x5e9; $Keysyms{"Arabic_yeh"} = 0x5ea; $Keysyms{"Arabic_fathatan"} = 0x5eb; $Keysyms{"Arabic_dammatan"} = 0x5ec; $Keysyms{"Arabic_kasratan"} = 0x5ed; $Keysyms{"Arabic_fatha"} = 0x5ee; $Keysyms{"Arabic_damma"} = 0x5ef; $Keysyms{"Arabic_kasra"} = 0x5f0; $Keysyms{"Arabic_shadda"} = 0x5f1; $Keysyms{"Arabic_sukun"} = 0x5f2; $Keysyms{"Arabic_switch"} = 0xFF7E; # Alias for mode_switch } #endif # XK_ARABIC # # * Cyrillic # * Byte 3 = 6 #ifdef XK_CYRILLIC if ($KL{'CYRILLIC'}) { $Keysyms{"Serbian_dje"} = 0x6a1; $Keysyms{"Macedonia_gje"} = 0x6a2; $Keysyms{"Cyrillic_io"} = 0x6a3; $Keysyms{"Ukrainian_ie"} = 0x6a4; $Keysyms{"Ukranian_je"} = 0x6a4; # deprecated $Keysyms{"Macedonia_dse"} = 0x6a5; $Keysyms{"Ukrainian_i"} = 0x6a6; $Keysyms{"Ukranian_i"} = 0x6a6; # deprecated $Keysyms{"Ukrainian_yi"} = 0x6a7; $Keysyms{"Ukranian_yi"} = 0x6a7; # deprecated $Keysyms{"Cyrillic_je"} = 0x6a8; $Keysyms{"Serbian_je"} = 0x6a8; # deprecated $Keysyms{"Cyrillic_lje"} = 0x6a9; $Keysyms{"Serbian_lje"} = 0x6a9; # deprecated $Keysyms{"Cyrillic_nje"} = 0x6aa; $Keysyms{"Serbian_nje"} = 0x6aa; # deprecated $Keysyms{"Serbian_tshe"} = 0x6ab; $Keysyms{"Macedonia_kje"} = 0x6ac; $Keysyms{"Byelorussian_shortu"} = 0x6ae; $Keysyms{"Cyrillic_dzhe"} = 0x6af; $Keysyms{"Serbian_dze"} = 0x6af; # deprecated $Keysyms{"numerosign"} = 0x6b0; $Keysyms{"Serbian_DJE"} = 0x6b1; $Keysyms{"Macedonia_GJE"} = 0x6b2; $Keysyms{"Cyrillic_IO"} = 0x6b3; $Keysyms{"Ukrainian_IE"} = 0x6b4; $Keysyms{"Ukranian_JE"} = 0x6b4; # deprecated $Keysyms{"Macedonia_DSE"} = 0x6b5; $Keysyms{"Ukrainian_I"} = 0x6b6; $Keysyms{"Ukranian_I"} = 0x6b6; # deprecated $Keysyms{"Ukrainian_YI"} = 0x6b7; $Keysyms{"Ukranian_YI"} = 0x6b7; # deprecated $Keysyms{"Cyrillic_JE"} = 0x6b8; $Keysyms{"Serbian_JE"} = 0x6b8; # deprecated $Keysyms{"Cyrillic_LJE"} = 0x6b9; $Keysyms{"Serbian_LJE"} = 0x6b9; # deprecated $Keysyms{"Cyrillic_NJE"} = 0x6ba; $Keysyms{"Serbian_NJE"} = 0x6ba; # deprecated $Keysyms{"Serbian_TSHE"} = 0x6bb; $Keysyms{"Macedonia_KJE"} = 0x6bc; $Keysyms{"Byelorussian_SHORTU"} = 0x6be; $Keysyms{"Cyrillic_DZHE"} = 0x6bf; $Keysyms{"Serbian_DZE"} = 0x6bf; # deprecated $Keysyms{"Cyrillic_yu"} = 0x6c0; $Keysyms{"Cyrillic_a"} = 0x6c1; $Keysyms{"Cyrillic_be"} = 0x6c2; $Keysyms{"Cyrillic_tse"} = 0x6c3; $Keysyms{"Cyrillic_de"} = 0x6c4; $Keysyms{"Cyrillic_ie"} = 0x6c5; $Keysyms{"Cyrillic_ef"} = 0x6c6; $Keysyms{"Cyrillic_ghe"} = 0x6c7; $Keysyms{"Cyrillic_ha"} = 0x6c8; $Keysyms{"Cyrillic_i"} = 0x6c9; $Keysyms{"Cyrillic_shorti"} = 0x6ca; $Keysyms{"Cyrillic_ka"} = 0x6cb; $Keysyms{"Cyrillic_el"} = 0x6cc; $Keysyms{"Cyrillic_em"} = 0x6cd; $Keysyms{"Cyrillic_en"} = 0x6ce; $Keysyms{"Cyrillic_o"} = 0x6cf; $Keysyms{"Cyrillic_pe"} = 0x6d0; $Keysyms{"Cyrillic_ya"} = 0x6d1; $Keysyms{"Cyrillic_er"} = 0x6d2; $Keysyms{"Cyrillic_es"} = 0x6d3; $Keysyms{"Cyrillic_te"} = 0x6d4; $Keysyms{"Cyrillic_u"} = 0x6d5; $Keysyms{"Cyrillic_zhe"} = 0x6d6; $Keysyms{"Cyrillic_ve"} = 0x6d7; $Keysyms{"Cyrillic_softsign"} = 0x6d8; $Keysyms{"Cyrillic_yeru"} = 0x6d9; $Keysyms{"Cyrillic_ze"} = 0x6da; $Keysyms{"Cyrillic_sha"} = 0x6db; $Keysyms{"Cyrillic_e"} = 0x6dc; $Keysyms{"Cyrillic_shcha"} = 0x6dd; $Keysyms{"Cyrillic_che"} = 0x6de; $Keysyms{"Cyrillic_hardsign"} = 0x6df; $Keysyms{"Cyrillic_YU"} = 0x6e0; $Keysyms{"Cyrillic_A"} = 0x6e1; $Keysyms{"Cyrillic_BE"} = 0x6e2; $Keysyms{"Cyrillic_TSE"} = 0x6e3; $Keysyms{"Cyrillic_DE"} = 0x6e4; $Keysyms{"Cyrillic_IE"} = 0x6e5; $Keysyms{"Cyrillic_EF"} = 0x6e6; $Keysyms{"Cyrillic_GHE"} = 0x6e7; $Keysyms{"Cyrillic_HA"} = 0x6e8; $Keysyms{"Cyrillic_I"} = 0x6e9; $Keysyms{"Cyrillic_SHORTI"} = 0x6ea; $Keysyms{"Cyrillic_KA"} = 0x6eb; $Keysyms{"Cyrillic_EL"} = 0x6ec; $Keysyms{"Cyrillic_EM"} = 0x6ed; $Keysyms{"Cyrillic_EN"} = 0x6ee; $Keysyms{"Cyrillic_O"} = 0x6ef; $Keysyms{"Cyrillic_PE"} = 0x6f0; $Keysyms{"Cyrillic_YA"} = 0x6f1; $Keysyms{"Cyrillic_ER"} = 0x6f2; $Keysyms{"Cyrillic_ES"} = 0x6f3; $Keysyms{"Cyrillic_TE"} = 0x6f4; $Keysyms{"Cyrillic_U"} = 0x6f5; $Keysyms{"Cyrillic_ZHE"} = 0x6f6; $Keysyms{"Cyrillic_VE"} = 0x6f7; $Keysyms{"Cyrillic_SOFTSIGN"} = 0x6f8; $Keysyms{"Cyrillic_YERU"} = 0x6f9; $Keysyms{"Cyrillic_ZE"} = 0x6fa; $Keysyms{"Cyrillic_SHA"} = 0x6fb; $Keysyms{"Cyrillic_E"} = 0x6fc; $Keysyms{"Cyrillic_SHCHA"} = 0x6fd; $Keysyms{"Cyrillic_CHE"} = 0x6fe; $Keysyms{"Cyrillic_HARDSIGN"} = 0x6ff; } #endif # XK_CYRILLIC # # * Greek # * Byte 3 = 7 #ifdef XK_GREEK if ($KL{'GREEK'}) { $Keysyms{"Greek_ALPHAaccent"} = 0x7a1; $Keysyms{"Greek_EPSILONaccent"} = 0x7a2; $Keysyms{"Greek_ETAaccent"} = 0x7a3; $Keysyms{"Greek_IOTAaccent"} = 0x7a4; $Keysyms{"Greek_IOTAdiaeresis"} = 0x7a5; $Keysyms{"Greek_OMICRONaccent"} = 0x7a7; $Keysyms{"Greek_UPSILONaccent"} = 0x7a8; $Keysyms{"Greek_UPSILONdieresis"} = 0x7a9; $Keysyms{"Greek_OMEGAaccent"} = 0x7ab; $Keysyms{"Greek_accentdieresis"} = 0x7ae; $Keysyms{"Greek_horizbar"} = 0x7af; $Keysyms{"Greek_alphaaccent"} = 0x7b1; $Keysyms{"Greek_epsilonaccent"} = 0x7b2; $Keysyms{"Greek_etaaccent"} = 0x7b3; $Keysyms{"Greek_iotaaccent"} = 0x7b4; $Keysyms{"Greek_iotadieresis"} = 0x7b5; $Keysyms{"Greek_iotaaccentdieresis"} = 0x7b6; $Keysyms{"Greek_omicronaccent"} = 0x7b7; $Keysyms{"Greek_upsilonaccent"} = 0x7b8; $Keysyms{"Greek_upsilondieresis"} = 0x7b9; $Keysyms{"Greek_upsilonaccentdieresis"} = 0x7ba; $Keysyms{"Greek_omegaaccent"} = 0x7bb; $Keysyms{"Greek_ALPHA"} = 0x7c1; $Keysyms{"Greek_BETA"} = 0x7c2; $Keysyms{"Greek_GAMMA"} = 0x7c3; $Keysyms{"Greek_DELTA"} = 0x7c4; $Keysyms{"Greek_EPSILON"} = 0x7c5; $Keysyms{"Greek_ZETA"} = 0x7c6; $Keysyms{"Greek_ETA"} = 0x7c7; $Keysyms{"Greek_THETA"} = 0x7c8; $Keysyms{"Greek_IOTA"} = 0x7c9; $Keysyms{"Greek_KAPPA"} = 0x7ca; $Keysyms{"Greek_LAMDA"} = 0x7cb; $Keysyms{"Greek_LAMBDA"} = 0x7cb; $Keysyms{"Greek_MU"} = 0x7cc; $Keysyms{"Greek_NU"} = 0x7cd; $Keysyms{"Greek_XI"} = 0x7ce; $Keysyms{"Greek_OMICRON"} = 0x7cf; $Keysyms{"Greek_PI"} = 0x7d0; $Keysyms{"Greek_RHO"} = 0x7d1; $Keysyms{"Greek_SIGMA"} = 0x7d2; $Keysyms{"Greek_TAU"} = 0x7d4; $Keysyms{"Greek_UPSILON"} = 0x7d5; $Keysyms{"Greek_PHI"} = 0x7d6; $Keysyms{"Greek_CHI"} = 0x7d7; $Keysyms{"Greek_PSI"} = 0x7d8; $Keysyms{"Greek_OMEGA"} = 0x7d9; $Keysyms{"Greek_alpha"} = 0x7e1; $Keysyms{"Greek_beta"} = 0x7e2; $Keysyms{"Greek_gamma"} = 0x7e3; $Keysyms{"Greek_delta"} = 0x7e4; $Keysyms{"Greek_epsilon"} = 0x7e5; $Keysyms{"Greek_zeta"} = 0x7e6; $Keysyms{"Greek_eta"} = 0x7e7; $Keysyms{"Greek_theta"} = 0x7e8; $Keysyms{"Greek_iota"} = 0x7e9; $Keysyms{"Greek_kappa"} = 0x7ea; $Keysyms{"Greek_lamda"} = 0x7eb; $Keysyms{"Greek_lambda"} = 0x7eb; $Keysyms{"Greek_mu"} = 0x7ec; $Keysyms{"Greek_nu"} = 0x7ed; $Keysyms{"Greek_xi"} = 0x7ee; $Keysyms{"Greek_omicron"} = 0x7ef; $Keysyms{"Greek_pi"} = 0x7f0; $Keysyms{"Greek_rho"} = 0x7f1; $Keysyms{"Greek_sigma"} = 0x7f2; $Keysyms{"Greek_finalsmallsigma"} = 0x7f3; $Keysyms{"Greek_tau"} = 0x7f4; $Keysyms{"Greek_upsilon"} = 0x7f5; $Keysyms{"Greek_phi"} = 0x7f6; $Keysyms{"Greek_chi"} = 0x7f7; $Keysyms{"Greek_psi"} = 0x7f8; $Keysyms{"Greek_omega"} = 0x7f9; $Keysyms{"Greek_switch"} = 0xFF7E; # Alias for mode_switch } #endif # XK_GREEK # # * Technical # * Byte 3 = 8 #ifdef XK_TECHNICAL if ($KL{'TECHNICAL'}) { $Keysyms{"leftradical"} = 0x8a1; $Keysyms{"topleftradical"} = 0x8a2; $Keysyms{"horizconnector"} = 0x8a3; $Keysyms{"topintegral"} = 0x8a4; $Keysyms{"botintegral"} = 0x8a5; $Keysyms{"vertconnector"} = 0x8a6; $Keysyms{"topleftsqbracket"} = 0x8a7; $Keysyms{"botleftsqbracket"} = 0x8a8; $Keysyms{"toprightsqbracket"} = 0x8a9; $Keysyms{"botrightsqbracket"} = 0x8aa; $Keysyms{"topleftparens"} = 0x8ab; $Keysyms{"botleftparens"} = 0x8ac; $Keysyms{"toprightparens"} = 0x8ad; $Keysyms{"botrightparens"} = 0x8ae; $Keysyms{"leftmiddlecurlybrace"} = 0x8af; $Keysyms{"rightmiddlecurlybrace"} = 0x8b0; $Keysyms{"topleftsummation"} = 0x8b1; $Keysyms{"botleftsummation"} = 0x8b2; $Keysyms{"topvertsummationconnector"} = 0x8b3; $Keysyms{"botvertsummationconnector"} = 0x8b4; $Keysyms{"toprightsummation"} = 0x8b5; $Keysyms{"botrightsummation"} = 0x8b6; $Keysyms{"rightmiddlesummation"} = 0x8b7; $Keysyms{"lessthanequal"} = 0x8bc; $Keysyms{"notequal"} = 0x8bd; $Keysyms{"greaterthanequal"} = 0x8be; $Keysyms{"integral"} = 0x8bf; $Keysyms{"therefore"} = 0x8c0; $Keysyms{"variation"} = 0x8c1; $Keysyms{"infinity"} = 0x8c2; $Keysyms{"nabla"} = 0x8c5; $Keysyms{"approximate"} = 0x8c8; $Keysyms{"similarequal"} = 0x8c9; $Keysyms{"ifonlyif"} = 0x8cd; $Keysyms{"implies"} = 0x8ce; $Keysyms{"identical"} = 0x8cf; $Keysyms{"radical"} = 0x8d6; $Keysyms{"includedin"} = 0x8da; $Keysyms{"includes"} = 0x8db; $Keysyms{"intersection"} = 0x8dc; $Keysyms{"union"} = 0x8dd; $Keysyms{"logicaland"} = 0x8de; $Keysyms{"logicalor"} = 0x8df; $Keysyms{"partialderivative"} = 0x8ef; $Keysyms{"function"} = 0x8f6; $Keysyms{"leftarrow"} = 0x8fb; $Keysyms{"uparrow"} = 0x8fc; $Keysyms{"rightarrow"} = 0x8fd; $Keysyms{"downarrow"} = 0x8fe; } #endif # XK_TECHNICAL # # * Special # * Byte 3 = 9 #ifdef XK_SPECIAL if ($KL{'SPECIAL'}) { $Keysyms{"blank"} = 0x9df; $Keysyms{"soliddiamond"} = 0x9e0; $Keysyms{"checkerboard"} = 0x9e1; $Keysyms{"ht"} = 0x9e2; $Keysyms{"ff"} = 0x9e3; $Keysyms{"cr"} = 0x9e4; $Keysyms{"lf"} = 0x9e5; $Keysyms{"nl"} = 0x9e8; $Keysyms{"vt"} = 0x9e9; $Keysyms{"lowrightcorner"} = 0x9ea; $Keysyms{"uprightcorner"} = 0x9eb; $Keysyms{"upleftcorner"} = 0x9ec; $Keysyms{"lowleftcorner"} = 0x9ed; $Keysyms{"crossinglines"} = 0x9ee; $Keysyms{"horizlinescan1"} = 0x9ef; $Keysyms{"horizlinescan3"} = 0x9f0; $Keysyms{"horizlinescan5"} = 0x9f1; $Keysyms{"horizlinescan7"} = 0x9f2; $Keysyms{"horizlinescan9"} = 0x9f3; $Keysyms{"leftt"} = 0x9f4; $Keysyms{"rightt"} = 0x9f5; $Keysyms{"bott"} = 0x9f6; $Keysyms{"topt"} = 0x9f7; $Keysyms{"vertbar"} = 0x9f8; } #endif # XK_SPECIAL # # * Publishing # * Byte 3 = a #ifdef XK_PUBLISHING if ($KL{'PUBLISHING'}) { $Keysyms{"emspace"} = 0xaa1; $Keysyms{"enspace"} = 0xaa2; $Keysyms{"em3space"} = 0xaa3; $Keysyms{"em4space"} = 0xaa4; $Keysyms{"digitspace"} = 0xaa5; $Keysyms{"punctspace"} = 0xaa6; $Keysyms{"thinspace"} = 0xaa7; $Keysyms{"hairspace"} = 0xaa8; $Keysyms{"emdash"} = 0xaa9; $Keysyms{"endash"} = 0xaaa; $Keysyms{"signifblank"} = 0xaac; $Keysyms{"ellipsis"} = 0xaae; $Keysyms{"doubbaselinedot"} = 0xaaf; $Keysyms{"onethird"} = 0xab0; $Keysyms{"twothirds"} = 0xab1; $Keysyms{"onefifth"} = 0xab2; $Keysyms{"twofifths"} = 0xab3; $Keysyms{"threefifths"} = 0xab4; $Keysyms{"fourfifths"} = 0xab5; $Keysyms{"onesixth"} = 0xab6; $Keysyms{"fivesixths"} = 0xab7; $Keysyms{"careof"} = 0xab8; $Keysyms{"figdash"} = 0xabb; $Keysyms{"leftanglebracket"} = 0xabc; $Keysyms{"decimalpoint"} = 0xabd; $Keysyms{"rightanglebracket"} = 0xabe; $Keysyms{"marker"} = 0xabf; $Keysyms{"oneeighth"} = 0xac3; $Keysyms{"threeeighths"} = 0xac4; $Keysyms{"fiveeighths"} = 0xac5; $Keysyms{"seveneighths"} = 0xac6; $Keysyms{"trademark"} = 0xac9; $Keysyms{"signaturemark"} = 0xaca; $Keysyms{"trademarkincircle"} = 0xacb; $Keysyms{"leftopentriangle"} = 0xacc; $Keysyms{"rightopentriangle"} = 0xacd; $Keysyms{"emopencircle"} = 0xace; $Keysyms{"emopenrectangle"} = 0xacf; $Keysyms{"leftsinglequotemark"} = 0xad0; $Keysyms{"rightsinglequotemark"} = 0xad1; $Keysyms{"leftdoublequotemark"} = 0xad2; $Keysyms{"rightdoublequotemark"} = 0xad3; $Keysyms{"prescription"} = 0xad4; $Keysyms{"minutes"} = 0xad6; $Keysyms{"seconds"} = 0xad7; $Keysyms{"latincross"} = 0xad9; $Keysyms{"hexagram"} = 0xada; $Keysyms{"filledrectbullet"} = 0xadb; $Keysyms{"filledlefttribullet"} = 0xadc; $Keysyms{"filledrighttribullet"} = 0xadd; $Keysyms{"emfilledcircle"} = 0xade; $Keysyms{"emfilledrect"} = 0xadf; $Keysyms{"enopencircbullet"} = 0xae0; $Keysyms{"enopensquarebullet"} = 0xae1; $Keysyms{"openrectbullet"} = 0xae2; $Keysyms{"opentribulletup"} = 0xae3; $Keysyms{"opentribulletdown"} = 0xae4; $Keysyms{"openstar"} = 0xae5; $Keysyms{"enfilledcircbullet"} = 0xae6; $Keysyms{"enfilledsqbullet"} = 0xae7; $Keysyms{"filledtribulletup"} = 0xae8; $Keysyms{"filledtribulletdown"} = 0xae9; $Keysyms{"leftpointer"} = 0xaea; $Keysyms{"rightpointer"} = 0xaeb; $Keysyms{"club"} = 0xaec; $Keysyms{"diamond"} = 0xaed; $Keysyms{"heart"} = 0xaee; $Keysyms{"maltesecross"} = 0xaf0; $Keysyms{"dagger"} = 0xaf1; $Keysyms{"doubledagger"} = 0xaf2; $Keysyms{"checkmark"} = 0xaf3; $Keysyms{"ballotcross"} = 0xaf4; $Keysyms{"musicalsharp"} = 0xaf5; $Keysyms{"musicalflat"} = 0xaf6; $Keysyms{"malesymbol"} = 0xaf7; $Keysyms{"femalesymbol"} = 0xaf8; $Keysyms{"telephone"} = 0xaf9; $Keysyms{"telephonerecorder"} = 0xafa; $Keysyms{"phonographcopyright"} = 0xafb; $Keysyms{"caret"} = 0xafc; $Keysyms{"singlelowquotemark"} = 0xafd; $Keysyms{"doublelowquotemark"} = 0xafe; $Keysyms{"cursor"} = 0xaff; } #endif # XK_PUBLISHING # # * APL # * Byte 3 = b #ifdef XK_APL if ($KL{'APL'}) { $Keysyms{"leftcaret"} = 0xba3; $Keysyms{"rightcaret"} = 0xba6; $Keysyms{"downcaret"} = 0xba8; $Keysyms{"upcaret"} = 0xba9; $Keysyms{"overbar"} = 0xbc0; $Keysyms{"downtack"} = 0xbc2; $Keysyms{"upshoe"} = 0xbc3; $Keysyms{"downstile"} = 0xbc4; $Keysyms{"underbar"} = 0xbc6; $Keysyms{"jot"} = 0xbca; $Keysyms{"quad"} = 0xbcc; $Keysyms{"uptack"} = 0xbce; $Keysyms{"circle"} = 0xbcf; $Keysyms{"upstile"} = 0xbd3; $Keysyms{"downshoe"} = 0xbd6; $Keysyms{"rightshoe"} = 0xbd8; $Keysyms{"leftshoe"} = 0xbda; $Keysyms{"lefttack"} = 0xbdc; $Keysyms{"righttack"} = 0xbfc; } #endif # XK_APL # # * Hebrew # * Byte 3 = c #ifdef XK_HEBREW if ($KL{'HEBREW'}) { $Keysyms{"hebrew_doublelowline"} = 0xcdf; $Keysyms{"hebrew_aleph"} = 0xce0; $Keysyms{"hebrew_bet"} = 0xce1; $Keysyms{"hebrew_beth"} = 0xce1; # deprecated $Keysyms{"hebrew_gimel"} = 0xce2; $Keysyms{"hebrew_gimmel"} = 0xce2; # deprecated $Keysyms{"hebrew_dalet"} = 0xce3; $Keysyms{"hebrew_daleth"} = 0xce3; # deprecated $Keysyms{"hebrew_he"} = 0xce4; $Keysyms{"hebrew_waw"} = 0xce5; $Keysyms{"hebrew_zain"} = 0xce6; $Keysyms{"hebrew_zayin"} = 0xce6; # deprecated $Keysyms{"hebrew_chet"} = 0xce7; $Keysyms{"hebrew_het"} = 0xce7; # deprecated $Keysyms{"hebrew_tet"} = 0xce8; $Keysyms{"hebrew_teth"} = 0xce8; # deprecated $Keysyms{"hebrew_yod"} = 0xce9; $Keysyms{"hebrew_finalkaph"} = 0xcea; $Keysyms{"hebrew_kaph"} = 0xceb; $Keysyms{"hebrew_lamed"} = 0xcec; $Keysyms{"hebrew_finalmem"} = 0xced; $Keysyms{"hebrew_mem"} = 0xcee; $Keysyms{"hebrew_finalnun"} = 0xcef; $Keysyms{"hebrew_nun"} = 0xcf0; $Keysyms{"hebrew_samech"} = 0xcf1; $Keysyms{"hebrew_samekh"} = 0xcf1; # deprecated $Keysyms{"hebrew_ayin"} = 0xcf2; $Keysyms{"hebrew_finalpe"} = 0xcf3; $Keysyms{"hebrew_pe"} = 0xcf4; $Keysyms{"hebrew_finalzade"} = 0xcf5; $Keysyms{"hebrew_finalzadi"} = 0xcf5; # deprecated $Keysyms{"hebrew_zade"} = 0xcf6; $Keysyms{"hebrew_zadi"} = 0xcf6; # deprecated $Keysyms{"hebrew_qoph"} = 0xcf7; $Keysyms{"hebrew_kuf"} = 0xcf7; # deprecated $Keysyms{"hebrew_resh"} = 0xcf8; $Keysyms{"hebrew_shin"} = 0xcf9; $Keysyms{"hebrew_taw"} = 0xcfa; $Keysyms{"hebrew_taf"} = 0xcfa; # deprecated $Keysyms{"Hebrew_switch"} = 0xFF7E; # Alias for mode_switch } #endif # XK_HEBREW # # * Thai # * Byte 3 = d #ifdef XK_THAI if ($KL{'THAI'}) { $Keysyms{"Thai_kokai"} = 0xda1; $Keysyms{"Thai_khokhai"} = 0xda2; $Keysyms{"Thai_khokhuat"} = 0xda3; $Keysyms{"Thai_khokhwai"} = 0xda4; $Keysyms{"Thai_khokhon"} = 0xda5; $Keysyms{"Thai_khorakhang"} = 0xda6; $Keysyms{"Thai_ngongu"} = 0xda7; $Keysyms{"Thai_chochan"} = 0xda8; $Keysyms{"Thai_choching"} = 0xda9; $Keysyms{"Thai_chochang"} = 0xdaa; $Keysyms{"Thai_soso"} = 0xdab; $Keysyms{"Thai_chochoe"} = 0xdac; $Keysyms{"Thai_yoying"} = 0xdad; $Keysyms{"Thai_dochada"} = 0xdae; $Keysyms{"Thai_topatak"} = 0xdaf; $Keysyms{"Thai_thothan"} = 0xdb0; $Keysyms{"Thai_thonangmontho"} = 0xdb1; $Keysyms{"Thai_thophuthao"} = 0xdb2; $Keysyms{"Thai_nonen"} = 0xdb3; $Keysyms{"Thai_dodek"} = 0xdb4; $Keysyms{"Thai_totao"} = 0xdb5; $Keysyms{"Thai_thothung"} = 0xdb6; $Keysyms{"Thai_thothahan"} = 0xdb7; $Keysyms{"Thai_thothong"} = 0xdb8; $Keysyms{"Thai_nonu"} = 0xdb9; $Keysyms{"Thai_bobaimai"} = 0xdba; $Keysyms{"Thai_popla"} = 0xdbb; $Keysyms{"Thai_phophung"} = 0xdbc; $Keysyms{"Thai_fofa"} = 0xdbd; $Keysyms{"Thai_phophan"} = 0xdbe; $Keysyms{"Thai_fofan"} = 0xdbf; $Keysyms{"Thai_phosamphao"} = 0xdc0; $Keysyms{"Thai_moma"} = 0xdc1; $Keysyms{"Thai_yoyak"} = 0xdc2; $Keysyms{"Thai_rorua"} = 0xdc3; $Keysyms{"Thai_ru"} = 0xdc4; $Keysyms{"Thai_loling"} = 0xdc5; $Keysyms{"Thai_lu"} = 0xdc6; $Keysyms{"Thai_wowaen"} = 0xdc7; $Keysyms{"Thai_sosala"} = 0xdc8; $Keysyms{"Thai_sorusi"} = 0xdc9; $Keysyms{"Thai_sosua"} = 0xdca; $Keysyms{"Thai_hohip"} = 0xdcb; $Keysyms{"Thai_lochula"} = 0xdcc; $Keysyms{"Thai_oang"} = 0xdcd; $Keysyms{"Thai_honokhuk"} = 0xdce; $Keysyms{"Thai_paiyannoi"} = 0xdcf; $Keysyms{"Thai_saraa"} = 0xdd0; $Keysyms{"Thai_maihanakat"} = 0xdd1; $Keysyms{"Thai_saraaa"} = 0xdd2; $Keysyms{"Thai_saraam"} = 0xdd3; $Keysyms{"Thai_sarai"} = 0xdd4; $Keysyms{"Thai_saraii"} = 0xdd5; $Keysyms{"Thai_saraue"} = 0xdd6; $Keysyms{"Thai_sarauee"} = 0xdd7; $Keysyms{"Thai_sarau"} = 0xdd8; $Keysyms{"Thai_sarauu"} = 0xdd9; $Keysyms{"Thai_phinthu"} = 0xdda; $Keysyms{"Thai_maihanakat_maitho"} = 0xdde; $Keysyms{"Thai_baht"} = 0xddf; $Keysyms{"Thai_sarae"} = 0xde0; $Keysyms{"Thai_saraae"} = 0xde1; $Keysyms{"Thai_sarao"} = 0xde2; $Keysyms{"Thai_saraaimaimuan"} = 0xde3; $Keysyms{"Thai_saraaimaimalai"} = 0xde4; $Keysyms{"Thai_lakkhangyao"} = 0xde5; $Keysyms{"Thai_maiyamok"} = 0xde6; $Keysyms{"Thai_maitaikhu"} = 0xde7; $Keysyms{"Thai_maiek"} = 0xde8; $Keysyms{"Thai_maitho"} = 0xde9; $Keysyms{"Thai_maitri"} = 0xdea; $Keysyms{"Thai_maichattawa"} = 0xdeb; $Keysyms{"Thai_thanthakhat"} = 0xdec; $Keysyms{"Thai_nikhahit"} = 0xded; $Keysyms{"Thai_leksun"} = 0xdf0; $Keysyms{"Thai_leknung"} = 0xdf1; $Keysyms{"Thai_leksong"} = 0xdf2; $Keysyms{"Thai_leksam"} = 0xdf3; $Keysyms{"Thai_leksi"} = 0xdf4; $Keysyms{"Thai_lekha"} = 0xdf5; $Keysyms{"Thai_lekhok"} = 0xdf6; $Keysyms{"Thai_lekchet"} = 0xdf7; $Keysyms{"Thai_lekpaet"} = 0xdf8; $Keysyms{"Thai_lekkao"} = 0xdf9; } #endif # XK_THAI # # * Korean # * Byte 3 = e #ifdef XK_KOREAN if ($KL{'KOREAN'}) { $Keysyms{"Hangul"} = 0xff31; # Hangul start/stop(toggle) $Keysyms{"Hangul_Start"} = 0xff32; # Hangul start $Keysyms{"Hangul_End"} = 0xff33; # Hangul end, English start $Keysyms{"Hangul_Hanja"} = 0xff34; # Start Hangul->Hanja Conversion $Keysyms{"Hangul_Jamo"} = 0xff35; # Hangul Jamo mode $Keysyms{"Hangul_Romaja"} = 0xff36; # Hangul Romaja mode $Keysyms{"Hangul_Codeinput"} = 0xff37; # Hangul code input mode $Keysyms{"Hangul_Jeonja"} = 0xff38; # Jeonja mode $Keysyms{"Hangul_Banja"} = 0xff39; # Banja mode $Keysyms{"Hangul_PreHanja"} = 0xff3a; # Pre Hanja conversion $Keysyms{"Hangul_PostHanja"} = 0xff3b; # Post Hanja conversion $Keysyms{"Hangul_SingleCandidate"} = 0xff3c; # Single candidate $Keysyms{"Hangul_MultipleCandidate"} = 0xff3d; # Multiple candidate $Keysyms{"Hangul_PreviousCandidate"} = 0xff3e; # Previous candidate $Keysyms{"Hangul_Special"} = 0xff3f; # Special symbols $Keysyms{"Hangul_switch"} = 0xFF7E; # Alias for mode_switch # Hangul Consonant Characters $Keysyms{"Hangul_Kiyeog"} = 0xea1; $Keysyms{"Hangul_SsangKiyeog"} = 0xea2; $Keysyms{"Hangul_KiyeogSios"} = 0xea3; $Keysyms{"Hangul_Nieun"} = 0xea4; $Keysyms{"Hangul_NieunJieuj"} = 0xea5; $Keysyms{"Hangul_NieunHieuh"} = 0xea6; $Keysyms{"Hangul_Dikeud"} = 0xea7; $Keysyms{"Hangul_SsangDikeud"} = 0xea8; $Keysyms{"Hangul_Rieul"} = 0xea9; $Keysyms{"Hangul_RieulKiyeog"} = 0xeaa; $Keysyms{"Hangul_RieulMieum"} = 0xeab; $Keysyms{"Hangul_RieulPieub"} = 0xeac; $Keysyms{"Hangul_RieulSios"} = 0xead; $Keysyms{"Hangul_RieulTieut"} = 0xeae; $Keysyms{"Hangul_RieulPhieuf"} = 0xeaf; $Keysyms{"Hangul_RieulHieuh"} = 0xeb0; $Keysyms{"Hangul_Mieum"} = 0xeb1; $Keysyms{"Hangul_Pieub"} = 0xeb2; $Keysyms{"Hangul_SsangPieub"} = 0xeb3; $Keysyms{"Hangul_PieubSios"} = 0xeb4; $Keysyms{"Hangul_Sios"} = 0xeb5; $Keysyms{"Hangul_SsangSios"} = 0xeb6; $Keysyms{"Hangul_Ieung"} = 0xeb7; $Keysyms{"Hangul_Jieuj"} = 0xeb8; $Keysyms{"Hangul_SsangJieuj"} = 0xeb9; $Keysyms{"Hangul_Cieuc"} = 0xeba; $Keysyms{"Hangul_Khieuq"} = 0xebb; $Keysyms{"Hangul_Tieut"} = 0xebc; $Keysyms{"Hangul_Phieuf"} = 0xebd; $Keysyms{"Hangul_Hieuh"} = 0xebe; # Hangul Vowel Characters $Keysyms{"Hangul_A"} = 0xebf; $Keysyms{"Hangul_AE"} = 0xec0; $Keysyms{"Hangul_YA"} = 0xec1; $Keysyms{"Hangul_YAE"} = 0xec2; $Keysyms{"Hangul_EO"} = 0xec3; $Keysyms{"Hangul_E"} = 0xec4; $Keysyms{"Hangul_YEO"} = 0xec5; $Keysyms{"Hangul_YE"} = 0xec6; $Keysyms{"Hangul_O"} = 0xec7; $Keysyms{"Hangul_WA"} = 0xec8; $Keysyms{"Hangul_WAE"} = 0xec9; $Keysyms{"Hangul_OE"} = 0xeca; $Keysyms{"Hangul_YO"} = 0xecb; $Keysyms{"Hangul_U"} = 0xecc; $Keysyms{"Hangul_WEO"} = 0xecd; $Keysyms{"Hangul_WE"} = 0xece; $Keysyms{"Hangul_WI"} = 0xecf; $Keysyms{"Hangul_YU"} = 0xed0; $Keysyms{"Hangul_EU"} = 0xed1; $Keysyms{"Hangul_YI"} = 0xed2; $Keysyms{"Hangul_I"} = 0xed3; # Hangul syllable-final (JongSeong) Characters $Keysyms{"Hangul_J_Kiyeog"} = 0xed4; $Keysyms{"Hangul_J_SsangKiyeog"} = 0xed5; $Keysyms{"Hangul_J_KiyeogSios"} = 0xed6; $Keysyms{"Hangul_J_Nieun"} = 0xed7; $Keysyms{"Hangul_J_NieunJieuj"} = 0xed8; $Keysyms{"Hangul_J_NieunHieuh"} = 0xed9; $Keysyms{"Hangul_J_Dikeud"} = 0xeda; $Keysyms{"Hangul_J_Rieul"} = 0xedb; $Keysyms{"Hangul_J_RieulKiyeog"} = 0xedc; $Keysyms{"Hangul_J_RieulMieum"} = 0xedd; $Keysyms{"Hangul_J_RieulPieub"} = 0xede; $Keysyms{"Hangul_J_RieulSios"} = 0xedf; $Keysyms{"Hangul_J_RieulTieut"} = 0xee0; $Keysyms{"Hangul_J_RieulPhieuf"} = 0xee1; $Keysyms{"Hangul_J_RieulHieuh"} = 0xee2; $Keysyms{"Hangul_J_Mieum"} = 0xee3; $Keysyms{"Hangul_J_Pieub"} = 0xee4; $Keysyms{"Hangul_J_PieubSios"} = 0xee5; $Keysyms{"Hangul_J_Sios"} = 0xee6; $Keysyms{"Hangul_J_SsangSios"} = 0xee7; $Keysyms{"Hangul_J_Ieung"} = 0xee8; $Keysyms{"Hangul_J_Jieuj"} = 0xee9; $Keysyms{"Hangul_J_Cieuc"} = 0xeea; $Keysyms{"Hangul_J_Khieuq"} = 0xeeb; $Keysyms{"Hangul_J_Tieut"} = 0xeec; $Keysyms{"Hangul_J_Phieuf"} = 0xeed; $Keysyms{"Hangul_J_Hieuh"} = 0xeee; # Ancient Hangul Consonant Characters $Keysyms{"Hangul_RieulYeorinHieuh"} = 0xeef; $Keysyms{"Hangul_SunkyeongeumMieum"} = 0xef0; $Keysyms{"Hangul_SunkyeongeumPieub"} = 0xef1; $Keysyms{"Hangul_PanSios"} = 0xef2; $Keysyms{"Hangul_KkogjiDalrinIeung"} = 0xef3; $Keysyms{"Hangul_SunkyeongeumPhieuf"} = 0xef4; $Keysyms{"Hangul_YeorinHieuh"} = 0xef5; # Ancient Hangul Vowel Characters $Keysyms{"Hangul_AraeA"} = 0xef6; $Keysyms{"Hangul_AraeAE"} = 0xef7; # Ancient Hangul syllable-final (JongSeong) Characters $Keysyms{"Hangul_J_PanSios"} = 0xef8; $Keysyms{"Hangul_J_KkogjiDalrinIeung"} = 0xef9; $Keysyms{"Hangul_J_YeorinHieuh"} = 0xefa; # Korean currency symbol $Keysyms{"Korean_Won"} = 0xeff; } #endif # XK_KOREAN } 1; __END__ =head1 NAME X11::Keysyms - Perl module for names of X11 keysyms =head1 SYNOPSIS use X11::Keysyms '%Keysyms', qw(MISCELLANY XKB_KEYS LATIN1); %Keysyms_name = reverse %Keysyms; $ks = $Keysyms{'BackSpace'}; $name = $Keysysms_name{$ks}; =head1 DESCRIPTION This module exports a hash mapping the names of X11 keysyms, such as 'A' or 'Linefeed' or 'Hangul_J_YeorinHieuh', onto the numbers that represent them. The first argument to 'use' is the name of the variable the hash should be exported into, and the rest are names of subsets of the keysysms to export: one or more of 'MISCELLANY', 'XKB_KEYS', '3270', 'LATIN1', 'LATIN2', 'LATIN3', 'LATIN4', 'KATAKANA', 'ARABIC', 'CYRILLIC', 'GREEK', 'TECHNICAL', 'SPECIAL', 'PUBLISHING', 'APL', 'HEBREW', 'THAI', 'KOREAN'. If this list is omitted, the list 'MISCELLANY', 'XKB_KEYS', 'LATIN1', 'LATIN2', 'LATIN3', 'LATIN4', 'GREEK' is used. =head1 AUTHOR This module was generated semi-automatically by Stephen McCamant () from the header file 'X11/keysymdef.h', distributed by the X Consortium. =head1 SEE ALSO L, L, I. =cut X11-Protocol-0.56/test.pl0000644000175000017500000001315510512252345013570 0ustar smccsmcc# Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) BEGIN { $| = 1; print "1..3\n"; } END {print "not ok 1\n" unless $loaded;} use X11::Protocol; $loaded = 1; print "ok 1\n"; ######################### End of black magic. # Insert your test code below (better if it prints "ok 13" # (correspondingly "not ok 13") depending on the success of chunk 13 # of the test code): # This isn't really proper test code, just a simple example. # A rough perl translation of the `basicwin' program from ORA's _Xlib # Programming Manual_, chapter 3. use X11::Protocol; %args = @ARGV; $display = $args{'-d'} || $args{'-display'} || $ENV{DISPLAY}; $x = X11::Protocol->new($display); while (my $id = int rand(2**24)) { # Check that we can continue after an error without crashing or # getting stuck. Because of a regression in versions 0.54 and # 0.55, this would get stuck in an infinite loop. my($result,) = $x->robust_req('GetGeometry', $id); if (not ref $result) { print "ok 2\n"; last; } } $x->event_handler('queue'); $d_width = $x->width_in_pixels; $d_height = $x->height_in_pixels; $w = $d_width / 2; $h = $d_height / 3; $win = $x->new_rsrc; $x->CreateWindow($win, $x->root, 'InputOutput', $x->root_depth, 'CopyFromParent', (0, 0), $w, $h, 4, 'background_pixel' => $x->white_pixel, 'bit_gravity' => 'Static', 'event_mask' => $x->pack_event_mask('Exposure', 'KeyPress', 'ButtonPress', 'StructureNotify')); $x->ChangeProperty($win, $x->atom('WM_ICON_NAME'), $x->atom('STRING'), 8, 'Replace', "basicwin"); $x->ChangeProperty($win, $x->atom('WM_NAME'), $x->atom('STRING'), 8, 'Replace', "Basic Window Program"); $x->ChangeProperty($win, $x->atom('WM_NORMAL_HINTS'), $x->atom('WM_SIZE_HINTS'), 32, 'Replace', pack("Ix16IIx44", 4|8|16, 320, 200)); $x->ChangeProperty($win, $x->atom('WM_HINTS'), $x->atom('WM_HINTS'), 32, 'Replace', pack("IIIx24", 1|2, 1, 1)); $progname = $0; $progname =~ s[^.*/][]; $name = $args{'-name'} || $ENV{'RESOURCE_NAME'} || $progname; $x->ChangeProperty($win, $x->atom('WM_CLASS'), $x->atom('STRING'), 8, 'Replace', "$name\0Basicwin"); $font = $x->new_rsrc; $x->OpenFont($font, "9x15"); # $cursorfont = $x->new_rsrc; # $x->OpenFont($cursorfont, "cursor"); # $cursor = $x->new_rsrc; # $x->CreateGlyphCursor($cursor, $cursorfont, $cursorfont, 4, 5, # (65535,65535,65535), (0,0,0)); # $x->ChangeWindowAttributes($win, 'cursor' => $cursor); $gc = getGC($win, $font); $x->MapWindow($win); while (1) { $x->handle_input until %e = $x->dequeue_event; if ($e{name} eq "Expose") { next unless $e{count} == 0; if ($win_size eq "TOO_SMALL") { TooSmall($win, $gc, $font); } else { place_text($win, $gc, $font, $w, $h); place_graphics($win, $gc, $w, $h); } } elsif ($e{name} eq "ConfigureNotify") { $w = $e{width}; $h = $e{height}; if ($w < 320 or $h < 200) { $win_size = "TOO_SMALL"; } else { $win_size = "BIG_ENOUGH"; } $x->ClearArea($win, (0, 0), $w, $h, 1); # Shouldn't be necessary } elsif ($e{name} eq "ButtonPress" or $e{name} eq "KeyPress") { $x->CloseFont($font); $x->FreeGC($gc); undef $x; print "ok 3\n"; exit; } } sub getGC { my($win, $font) = @_; my($gc) = $x->new_rsrc; $x->CreateGC($gc, $win, 'font' => $font, 'foreground' => $x->black_pixel, 'line_width' => 6, 'line_style' => 'OnOffDash', 'cap_style' => 'Round', 'join_style' => 'Round'); $x->SetDashes($gc, 0, (12, 24)); return $gc; } sub text_width { my($font, $text) = @_; $text =~ s/(.)/\0$1/g; # 8-bit -> 16-bit my(%extents) = $x->QueryTextExtents($font, $text); return $extents{overall_width}; } sub place_text { my($win, $gc, $font, $w, $h) = @_; my $string1 = "Hi! I'm a window, who are you?"; my $string2 = "To terminate program, press any key"; my $string3 = "or button while in this window"; my $string4 = "Screen Dimensions:"; my(%font_info) = $x->QueryFont($font); my($font_h) = $font_info{font_ascent} + $font_info{font_descent}; $x->PolyText8($win, $gc, ($w - text_width($font, $string1))/2, $font_h, [0, $string1]); $x->PolyText8($win, $gc, ($w - text_width($font, $string2))/2, $h - 2 * $font_h, [0, $string2]); $x->PolyText8($win, $gc, ($w - text_width($font, $string3))/2, $h - $font_h, [0, $string3]); my $cd_height = " Height - @{[$x->height_in_pixels]} pixels"; my $cd_width = " Width - @{[$x->width_in_pixels]} pixels"; my $cd_depth = " Depth - @{[$x->root_depth]} plane(s)"; my($y0) = $h / 2 - $font_h - $font_info{font_descent}; my($x_off) = $w / 4; $x->PolyText8($win, $gc, $x_off, $y0, [0, $string4]); $x->PolyText8($win, $gc, $x_off, $y0 + $font_h, [0, $cd_height]); $x->PolyText8($win, $gc, $x_off, $y0 + 2 * $font_h, [0, $cd_width]); $x->PolyText8($win, $gc, $x_off, $y0 + 3 * $font_h, [0, $cd_depth]); } sub place_graphics { my($win, $gc, $w, $h) = @_; my($height) = $h / 2; my($width) = 3 * $w / 4; my($ex) = $w/2 - $width/2; my($y) = $h/2 - $height/2; $x->PolyRectangle($win, $gc, [$ex, $y, $width, $height]); } sub TooSmall { my($win, $gc, $font) = @_; my(%font_info) = $x->QueryFont($font); my($y_off) = $font_info{font_ascent}; my($x_off) = 2; $x->PolyText8($win, $gc, $x_off, $y_off, [0, "Too Small"]); } X11-Protocol-0.56/Protocol/0000755000175000017500000000000010512256531014051 5ustar smccsmccX11-Protocol-0.56/Protocol/Connection.pm0000644000175000017500000000464307615075443016530 0ustar smccsmcc#!/usr/bin/perl package X11::Protocol::Connection; # Copyright (C) 1997 Stephen McCamant. All rights reserved. This program # is free software; you can redistribute and/or modify it under the same # terms as Perl itself. use Carp; use strict; use vars '$VERSION'; $VERSION = 0.01; sub give { croak "X11 connection object doesn't support output"; } sub get { croak "X11 connection object doesn't support input"; } sub fh { croak "X11 connection object is incompatible with perl filehandles"; } sub open { croak "X11 connection object can't open itself"; } 1; __END__ =head1 NAME X11::Protocol::Connection - Perl module abstract base class for X11 client to server connections =head1 SYNOPSIS # In connection object module package X11::Protocol::Connection::CarrierPigeon; use X11::Protocol::Connection; @ISA = ('X11::Protocol::Connection'); sub open { ... } sub give { ... } sub get { ... } sub fh { ... } ... # In program $connection = X11::Protocol::Connection::CarrierPigeon ->open($host, $display_number); $x = X11::Protocol->new($connection); $connection->give($data); $reply = unpack("I", $connection->get(4)); use IO::Select; $sel = IO::select->new($connection->fh); if ($sel->can_read == $connection->fh) ... =head1 DESCRIPTION This module is an abstract base class for the various X11::Protocol::Connection::* modules that provide connections to X servers for the X11::Protocol module. It provides stubs for the following methods: =head2 open $conn = X11::Protocol::Connection::Foo->open($host, $display_num) Open a connection to the specified display (numbered from 0) on the specified $host. =head2 give $conn->give($data) Send the given data to the server. Normally, this method is used only by the protocol module itself. =head2 get $data = $conn->get($n) Read $n bytes of data from the server. Normally, this method is used only by the protocol module itself. =head2 fh $filehandle = $conn->fh Return an object suitable for use as a filehandle. This is mainly useful for doing select() and other such system calls. =head1 AUTHOR Stephen McCamant . =head1 SEE ALSO L, L, L, L, L, L, L, L. =cut X11-Protocol-0.56/Protocol/Connection/0000755000175000017500000000000010512256531016150 5ustar smccsmccX11-Protocol-0.56/Protocol/Connection/INETFH.pm0000644000175000017500000000274107615075354017503 0ustar smccsmcc#!/usr/bin/perl package X11::Protocol::Connection::INETFH; # Copyright (C) 1997 Stephen McCamant. All rights reserved. This program # is free software; you can redistribute and/or modify it under the same # terms as Perl itself. use X11::Protocol::Connection::FileHandle; use FileHandle; use Socket; use Carp; use strict; use vars qw($VERSION @ISA); @ISA = ('X11::Protocol::Connection::FileHandle'); $VERSION = 0.01; sub open { my($pkg) = shift; my($host, $dispnum) = @_; my($sock) = new FileHandle; socket $sock, PF_INET(), SOCK_STREAM(), getprotobyname("tcp") or croak "socket: $!"; connect $sock, sockaddr_in(6000 + $dispnum, inet_aton $host) or croak "Can't connect to display `$host:$dispnum': $!"; $sock->autoflush(1); return bless \$sock, $pkg; } 1; __END__ =head1 NAME X11::Protocol::Connection::INETFH - Perl module for FileHandle-based TCP/IP X11 connections =head1 SYNOPSIS use X11::Protocol; use X11::Protocol::Connection::INETFH; $conn = X11::Protocol::Connection::INETFH ->open($host, $display_number); $x = X11::Protocol->new($conn); =head1 DESCRIPTION This module is used by X11::Protocol to establish a connection and communicate with a server over an internet-type TCP/IP socket connection, using the FileHandle module. =head1 AUTHOR Stephen McCamant . =head1 SEE ALSO L, L, L, L, L. =cut X11-Protocol-0.56/Protocol/Connection/Socket.pm0000644000175000017500000000312007742321124017734 0ustar smccsmcc#!/usr/bin/perl package X11::Protocol::Connection::Socket; # Copyright (C) 1997, 1999, 2003 Stephen McCamant. All rights # reserved. This program is free software; you can redistribute and/or # modify it under the same terms as Perl itself. use IO::Socket; use Carp; use strict; use vars '$VERSION', '@ISA'; use X11::Protocol::Connection; @ISA = ('X11::Protocol::Connection'); $VERSION = 0.02; sub give { my($self) = shift; my($msg) = @_; my($sock) = $$self; $sock->write($msg, length($msg)) or croak $!; } sub get { my($self) = shift; my($len) = @_; my($x, $n, $o) = ("", 0, 0); my($sock) = $$self; until ($o == $len) { $n = $sock->sysread($x, $len - $o, $o); croak $! unless defined $n; $o += $n; } return $x; } sub fh { my($self) = shift; return $$self; } sub flush { my($self) = shift; my($sock) = $$self; $sock->flush; } 1; __END__ =head1 NAME X11::Protocol::Connection::Socket - Perl module base class for IO::Socket-based X11 connections =head1 SYNOPSIS package X11::Protocol::Connection::WeirdSocket; use X11::Protocol::Connection::Socket; @ISA = ('X11::Protocol::Connection::Socket') =head1 DESCRIPTION This module defines get(), give() and fh() methods common to X11::Protocol::Connection types that are based on IO::Socket. They expect the object they are called with to be a reference to an IO::Socket. =head1 AUTHOR Stephen McCamant . =head1 SEE ALSO L, L, L, L, L. =cut X11-Protocol-0.56/Protocol/Connection/INETSocket.pm0000644000175000017500000000270607615075374020441 0ustar smccsmcc#!/usr/bin/perl package X11::Protocol::Connection::INETSocket; # Copyright (C) 1997 Stephen McCamant. All rights reserved. This program # is free software; you can redistribute and/or modify it under the same # terms as Perl itself. use X11::Protocol::Connection::Socket; use IO::Socket; use Socket; use Carp; use strict; use vars qw($VERSION @ISA); @ISA = ('X11::Protocol::Connection::Socket'); $VERSION = 0.01; sub open { my($pkg) = shift; my($host, $dispnum) = @_; my($sock) = IO::Socket::INET->new('PeerAddr' => $host, 'PeerPort' => 6000 + $dispnum, 'Type' => SOCK_STREAM(), 'Proto' => "tcp"); croak "Can't connect to display `$host:$dispnum': $!" unless $sock; $sock->autoflush(1); return bless \$sock, $pkg; } 1; __END__ =head1 NAME X11::Protocol::Connection::INETSocket - Perl module for IO::Socket::INET-based X11 connections =head1 SYNOPSIS use X11::Protocol; use X11::Protocol::Connection::INETSocket; $conn = X11::Protocol::Connection::INETSocket ->open($host, $display_number); $x = X11::Protocol->new($conn); =head1 DESCRIPTION This module is used by X11::Protocol to establish a connection and communicate with a server over a TCP/IP connection, using the IO::Socket::INET module. =head1 AUTHOR Stephen McCamant . =head1 SEE ALSO L, L, L, L, L. =cut X11-Protocol-0.56/Protocol/Connection/UNIXFH.pm0000644000175000017500000000274007615075431017522 0ustar smccsmcc#!/usr/bin/perl package X11::Protocol::Connection::UNIXFH; # Copyright (C) 1997 Stephen McCamant. All rights reserved. This program # is free software; you can redistribute and/or modify it under the same # terms as Perl itself. use X11::Protocol::Connection::FileHandle; use FileHandle; use Socket; use Carp; use strict; use vars qw($VERSION @ISA); @ISA = ('X11::Protocol::Connection::FileHandle'); $VERSION = 0.01; sub open { my($pkg) = shift; my($host, $dispnum) = @_; my($sock) = new FileHandle; socket $sock, PF_UNIX(), SOCK_STREAM(), 0 or croak "socket: $!"; connect $sock, sockaddr_un("/tmp/.X11-unix/X$dispnum") or croak "Can't connect to display `unix:$dispnum': $!"; $sock->autoflush(1); return bless \$sock, $pkg; } 1; __END__ =head1 NAME X11::Protocol::Connection::UNIXFH - Perl module for FileHandle-based Unix-domain X11 connections =head1 SYNOPSIS use X11::Protocol; use X11::Protocol::Connection::UNIXFH; $conn = X11::Protocol::Connection::UNIXFH ->open($host, $display_number); $x = X11::Protocol->new($conn); =head1 DESCRIPTION This module is used by X11::Protocol to establish a connection and communicate with a server over a local Unix-domain socket connection, using the FileHandle module. The host argument is ignored. =head1 AUTHOR Stephen McCamant . =head1 SEE ALSO L, L, L, L, L. =cut X11-Protocol-0.56/Protocol/Connection/FileHandle.pm0000644000175000017500000000305107742321131020500 0ustar smccsmcc#!/usr/bin/perl package X11::Protocol::Connection::FileHandle; # Copyright (C) 1997, 2003 Stephen McCamant. All rights reserved. This # program is free software; you can redistribute and/or modify it # under the same terms as Perl itself. use FileHandle; use Carp; use strict; use vars '$VERSION', '@ISA'; use X11::Protocol::Connection; @ISA = ('X11::Protocol::Connection'); $VERSION = 0.02; sub give { my($self) = shift; my($msg) = @_; my($fh) = $$self; $fh->print($msg) or croak $!; } sub get { my($self) = shift; my($len) = @_; my($x, $n, $o) = ("", 0, 0); my($fh) = $$self; until ($o == $len) { $n = sysread $fh, $x, $len - $o, $o; croak $! unless defined $n; $o += $n; } return $x; } sub fh { my($self) = shift; return $$self; } sub flush { my($self) = shift; my($fh) = $$self; } 1; __END__ =head1 NAME X11::Protocol::Connection::FileHandle - Perl module base class for FileHandle-based X11 connections =head1 SYNOPSIS package X11::Protocol::Connection::WeirdFH; use X11::Protocol::Connection::FileHandle; @ISA = ('X11::Protocol::Connection::FileHandle') =head1 DESCRIPTION This module defines get(), give() and fh() methods common to X11::Protocol::Connection types that are based on the FileHandle package. They expect the object they are called with to be a reference to a FileHandle. =head1 AUTHOR Stephen McCamant . =head1 SEE ALSO L, L, L, L, L. =cut X11-Protocol-0.56/Protocol/Connection/UNIXSocket.pm0000644000175000017500000000270107623476213020454 0ustar smccsmcc#!/usr/bin/perl package X11::Protocol::Connection::UNIXSocket; # Copyright (C) 1997 Stephen McCamant. All rights reserved. This program # is free software; you can redistribute and/or modify it under the same # terms as Perl itself. use X11::Protocol::Connection::Socket; use IO::Socket; use Socket; use Carp; use strict; use vars qw($VERSION @ISA); @ISA = ('X11::Protocol::Connection::Socket'); $VERSION = 0.01; sub open { my($pkg) = shift; my($host, $dispnum) = @_; my($sock) = IO::Socket::UNIX->new('Type' => SOCK_STREAM(), 'Peer' => "/tmp/.X11-unix/X$dispnum"); croak "Can't connect to display `unix:$dispnum': $!" unless $sock; $sock->autoflush(0); return bless \$sock, $pkg; } 1; __END__ =head1 NAME X11::Protocol::Connection::UNIXSocket - Perl module for IO::Socket::UNIX-based X11 connections =head1 SYNOPSIS use X11::Protocol; use X11::Protocol::Connection::UNIXSocket; $conn = X11::Protocol::Connection::UNIXSocket ->open($host, $display_number); $x = X11::Protocol->new($conn); =head1 DESCRIPTION This module is used by X11::Protocol to establish a connection and communicate with a server over a local Unix-domain socket connection, using the IO::Socket::UNIX module. The host argument is ignored. =head1 AUTHOR Stephen McCamant . =head1 SEE ALSO L, L, L, L, L. =cut X11-Protocol-0.56/Protocol/Constants.pm0000644000175000017500000005664407623616131016407 0ustar smccsmcc#!/usr/bin/perl package X11::Protocol::Constants; # Copyright (C) 1997, 1999, 2003 Stephen McCamant. All rights # reserved. This program is free software; you can redistribute and/or # modify it under the same terms as Perl itself. use strict; use Exporter; use vars ('$VERSION', '@EXPORT', '@EXPORT_OK', '%EXPORT_TAGS', '@ISA'); $VERSION = 0.01; @ISA = ('Exporter'); # It seems as if the designers of the protocol started out trying to make # all the constants distinct, got most of the way, then gave up. # Protocol.pm has classes, and Xlib has longer names. # There are just two bad collisions: Cap/Round vs. Join/Round and # ALL the focus mode flags (that aren't also crossing notify ones). my @x_dot_h = ('NoEventMask', 'KeyPressMask', 'KeyReleaseMask', 'ButtonPressMask', 'ButtonReleaseMask', 'EnterWindowMask', 'LeaveWindowMask', 'PointerMotionMask', 'PointerMotionHintMask', 'Button1MotionMask', 'Button2MotionMask', 'Button3MotionMask', 'Button4MotionMask', 'Button5MotionMask', 'ButtonMotionMask', 'KeymapStateMask', 'ExposureMask', 'VisibilityChangeMask', 'StructureNotifyMask', 'ResizeRedirectMask', 'SubstructureNotifyMask', 'SubstructureRedirectMask', 'FocusChangeMask', 'PropertyChangeMask', 'ColormapChangeMask', 'OwnerGrabButtonMask', 'KeyPress' , 'KeyRelease', 'ButtonPress', 'ButtonRelease', 'MotionNotify', 'EnterNotify', 'LeaveNotify', 'FocusIn', 'FocusOut', 'KeymapNotify', 'Expose', 'GraphicsExposure', 'NoExposure', 'VisibilityNotify', 'CreateNotify', 'DestroyNotify', 'UnmapNotify', 'MapNotify', 'MapRequest', 'ReparentNotify', 'ConfigureNotify', 'ConfigureRequest', 'GravityNotify', 'ResizeRequest', 'CirculateNotify', 'CirculateRequest', 'PropertyNotify', 'SelectionClear', 'SelectionRequest', 'SelectionNotify', 'ColormapNotify', 'ClientMessage', 'MappingNotify', 'LASTEvent', 'ShiftMask', 'LockMask', 'ControlMask', 'Mod1Mask', 'Mod2Mask', 'Mod3Mask', 'Mod4Mask', 'Mod5Mask', 'ShiftMapIndex', 'LockMapIndex', 'ControlMapIndex', 'Mod1MapIndex', 'Mod2MapIndex', 'Mod3MapIndex', 'Mod4MapIndex', 'Mod5MapIndex', 'Button1Mask', 'Button2Mask', 'Button3Mask', 'Button4Mask', 'Button5Mask', 'Button1', 'Button2', 'Button3', 'Button4', 'Button5', 'AnyModifier', 'NotifyAncestor', 'NotifyVirtual', 'NotifyInferior', 'NotifyNonlinear', 'NotifyNonlinearVirtual', 'NotifyPointer', 'NotifyPointerRoot', 'NotifyDetailNone', 'VisibilityUnobscured', 'VisibilityPartiallyObscured', 'VisibilityFullyObscured', 'PlaceOnTop', 'PlaceOnBottom', 'FamiliyInternet', 'FamiliyDECnet', 'FamiliyChaos', 'PropertyNewValue', 'PropertyDeleted', 'ColormapUninstalled', 'ColormapInstalled', 'GrabModeSync', 'GrabModeAsync', 'GrabSuccess', 'GrabInvalidTime', 'GrabNotViewable', 'GrabFrozen', 'AlreadyGrabbed', 'AsyncPointer', 'SyncPointer', 'ReplayPointer', 'AsyncKeyboard', 'SyncKeyboard', 'ReplayKeyboard', 'AsyncBoth', 'SyncBoth', 'RevertToNone', 'RevertToPointerRoot', 'RevertToParent', 'BadRequest', 'BadValue', 'BadWindow', 'BadPixmap', 'BadAtom', 'BadCursor', 'BadFont', 'BadMatch', 'BadDrawable', 'BadAccess', 'BadAlloc', 'BadColormap', 'BadGC', 'BadIDChoice', 'BadName', 'BadLength', 'BadImplementation', 'FirstExtensionError', 'LastExtensionError', 'CopyFromParent', 'InputOutput', 'InputOnly', 'ForgetGravity', 'StaticGravity', 'NorthWestGravity', 'NorthGravity', 'NorthEastGravity', 'WestGravity', 'CenterGravity', 'EastGravity', 'SouthWestGravity', 'SouthGravity', 'SouthEastGravity', 'UnmapGravity', 'WhenMapped', 'Always', 'NotUseful', 'IsUnmapped', 'IsUnviewable', 'IsViewable', 'SetModeInsert', 'SetModeDelete', 'RetainPermanent', 'RetainTemporary', 'DestroyAll', 'Above', 'Below', 'TopIf', 'BottomIf', 'Opposite', 'RaiseLowest', 'LowerHighest', 'PropModeReplace', 'PropModePrepend', 'PropModeAppend', 'GXclear', 'GXand', 'GXandReverse', 'GXcopy', 'GXandInverted', 'GXnoop', 'GXxor', 'GXor', 'GXnor', 'GXequiv', 'GXinvert', 'GXorReverse', 'GXcopyInverted', 'GXorInverted', 'GXnand', 'GXset', 'LineSolid', 'LineOnOffDash', 'LineDoubleDash', 'CapNotLast', 'CapButt', 'CapRound', 'CapProjecting', 'JoinMiter', 'JoinRound', 'JoinBevel', 'FillSolid', 'FillTiled', 'FillStippled', 'FillOpaqueStippled', 'EvenOddRule', 'WindingRule', 'ClipByChildren', 'IncludeInferiors', 'YSorted', 'YXSorted', 'YXBanded', 'Unsorted', 'CoordModeOrigin', 'CoordModePrevious', 'Complex', 'Nonconvex', 'Convex', 'ArcChord', 'ArcPieSlice', 'FontLeftToRight', 'FontRightToLeft', 'FontChange', 'XYPixmap', 'ZPixmap', 'XYBitmap', 'AllocNone', 'AllocAll', 'DoRed', 'DoGreen', 'DoBlue', 'CursorShape', 'TileShape', 'StippleShape', 'AutoRepeatModeOff', 'AutoRepeatModeOn', 'AutoRepeatModeDefault', 'LedModeOff', 'LedModeOn', 'MappingModifier', 'MappingKeyboard', 'MappingPointer', 'MappingSuccess', 'MappingBusy', 'MappingFailed', 'DontPreferBlanking', 'PreferBlanking', 'DefaultBlanking', 'DisableScreenSaver', 'DisableScreenInterval', 'DontAllowExposures', 'AllowExposures', 'DefaultExposures', 'ScreenSaverReset', 'ScreenSaverActive', 'HostInsert', 'HostDelete', 'DisableAccess', 'EnableAccess', 'StaticGray', 'GrayScale', 'StaticColor', 'PseudoColor', 'TrueColor', 'DirectColor', 'GreyScale', 'StaticGrey', 'StaticColour', 'PseudoColour', 'TrueColour', 'DirectColour', 'LSBFirst', 'MSBFirst'); my @protocol = ( 'StaticGray', 'GrayScale', 'StaticColor', 'PseudoColor', 'TrueColor', 'DirectColor', 'GreyScale', 'StaticGrey', 'StaticColour', 'PseudoColour', 'TrueColour', 'DirectColour', 'Forget', 'Static', 'NorthWest', 'North', 'NorthEast', 'West', 'Center', 'East', 'SouthWest', 'South', 'SouthEast', 'Unmap', 'KeyPress', 'KeyRelease', 'ButtonPress', 'ButtonRelease', 'EnterWindow', 'LeaveWindow', 'PointerMotion', 'PointerMotionHint', 'Button1Motion', 'Button2Motion', 'Button3Motion', 'Button4Motion', 'Button5Motion', 'ButtonMotion', 'KeymapState', 'Exposure', 'VisibilityChange', 'StructureNotify', 'ResizeRedirect', 'SubstructureNotify', 'SubstructureRedirect', 'FocusChange', 'PropertyChange', 'ColormapChange', 'OwnerGrabButton', 'MotionNotify', 'EnterNotify', 'LeaveNotify', 'FocusIn', 'FocusOut', 'KeymapNotify', 'Expose', 'GraphicsExposure', 'NoExposure', 'VisibilityNotify', 'CreateNotify', 'DestroyNotify', 'UnmapNotify', 'MapNotify', 'MapRequest', 'ReparentNotify', 'ConfigureNotify', 'ConfigureRequest', 'GravityNotify', 'ResizeRequest', 'CirculateNotify', 'CirculateRequest', 'PropertyNotify', 'SelectionClear', 'SelectionRequest', 'SelectionNotify', 'ColormapNotify', 'ClientMessage', 'MappingNotify', 'Shift', 'Lock', 'Control', 'Mod1', 'Mod2', 'Mod3', 'Mod4', 'Mod5', 'LeastSignificant', 'MostSignificant', 'Never', 'WhenMapped', 'Always', 'False', 'True', 'CopyFromParent', 'InputOutput', 'InputOnly', 'Unmapped', 'Unviewable', 'Viewable', 'Above', 'Below', 'TopIf', 'BottomIf', 'Opposite', 'RaiseLowest', 'LowerHighest', 'Replace', 'Prepend', 'Append', 'Ancestor', 'Virtual', 'Inferior', 'Nonlinear', 'NonlinearVirtual', 'Normal', 'Grab', 'Ungrab', 'WhileGrabbed', 'Unobscured', 'PartiallyObscured', 'FullyObscured', 'Top', 'Bottom', 'NewValue', 'Deleted', 'Uninstalled', 'Installed', 'Modifier', 'Keyboard', 'Pointer', 'Synchronous', 'Asynchronous', 'Success', 'AlreadyGrabbed', 'InvalidTime', 'NotViewable', 'Frozen', 'AsyncPointer', 'SyncPointer', 'ReplayPointer', 'AsyncKeyboard', 'SyncKeyboard', 'ReplayKeyboard', 'AsyncBoth', 'SyncBoth', 'None', 'PointerRoot', 'Parent', 'LeftToRight', 'RightToLeft', 'UnSorted', 'YSorted', 'YXSorted', 'YXBanded', 'Origin', 'Previous', 'Complex', 'Nonconvex', 'Convex', 'Bitmap', 'XYPixmap', 'ZPixmap', 'Cursor', 'Tile', 'Stipple', 'Off', 'On', 'Default', 'No', 'Yes', 'Default', 'Insert', 'Delete', 'Internet', 'DECnet', 'Chaos', 'Disabled', 'Enabled', 'Destroy', 'RetainPermanent', 'RetainTemporary', 'Reset', 'Activate', 'Success', 'Busy', 'Failed', 'Clear', 'And', 'AndReverse', 'Copy', 'AndInverted', 'NoOp', 'Xor', 'Or', 'Nor', 'Equiv', 'Invert', 'OrReverse', 'CopyInverted', 'OrInverted', 'Nand', 'Set', 'Solid', 'OnOffDash', 'DoubleDash', 'NotLast', 'Butt', 'Round', 'Projecting', 'Miter', 'Round', 'Bevel', 'Solid', 'Tiled', 'Stippled', 'OpaqueStippled', 'EvenOdd', 'Winding', 'ClipByChildren', 'IncludeInferiors', 'Chord', 'PieSlice'); my @masks = ( 'KeyPress_mask', 'KeyRelease_mask', 'ButtonPress_mask', 'ButtonRelease_mask', 'EnterWindow_mask', 'LeaveWindow_mask', 'PointerMotion_mask', 'PointerMotionHint_mask', 'Button1Motion_mask', 'Button2Motion_mask', 'Button3Motion_mask', 'Button4Motion_mask', 'Button5Motion_mask', 'ButtonMotion_mask', 'KeymapState_mask', 'Exposure_mask', 'VisibilityChange_mask', 'StructureNotify_mask', 'ResizeRedirect_mask', 'SubstructureNotify_mask', 'SubstructureRedirect_mask', 'FocusChange_mask', 'PropertyChange_mask', 'ColormapChange_mask', 'OwnerGrabButton_mask', ); my @masks_m = ( 'KeyPress_m', 'KeyRelease_m', 'ButtonPress_m', 'ButtonRelease_m', 'EnterWindow_m', 'LeaveWindow_m', 'PointerMotion_m', 'PointerMotionHint_m', 'Button1Motion_m', 'Button2Motion_m', 'Button3Motion_m', 'Button4Motion_m', 'Button5Motion_m', 'ButtonMotion_m', 'KeymapState_m', 'Exposure_m', 'VisibilityChange_m', 'StructureNotify_m', 'ResizeRedirect_m', 'SubstructureNotify_m', 'SubstructureRedirect_m', 'FocusChange_m', 'PropertyChange_m', 'ColormapChange_m', 'OwnerGrabButton_m', ); my @disambig = ( 'PointerDetail', 'PointerRootDetail', 'NoDetail', 'NotifyNormal', 'NotifyGrab', 'NotifyUngrab', 'NotifyWhileGrabbed', 'NotifyHint', 'RoundCap', 'RoundJoin', ); %EXPORT_TAGS = ('X_dot_h' => \@x_dot_h, 'Protocol' => \@protocol, 'Masks' => \@masks, 'Masks_m' => \@masks_m, 'Disambiguate' => \@disambig); Exporter::export_ok_tags(keys %EXPORT_TAGS); { my %seen; push @{$EXPORT_TAGS{all}}, grep {!$seen{$_}++} @{$EXPORT_TAGS{$_}} foreach keys %EXPORT_TAGS; } # VisualClass sub StaticGray () { 0 } sub StaticGrey () { 0 } sub GrayScale () { 1 } sub GreyScale () { 1 } sub StaticColor () { 2 } sub StaticColour () { 2 } sub PseudoColor () { 3 } sub PseudoColour () { 3 } sub TrueColor () { 4 } sub TrueColour () { 4 } sub DirectColor () { 5 } sub DirectColour () { 5 } # (Bit|Win)Gravity sub Forget () { 0 } sub Unmap () { 0 } sub Static () { 1 } sub NorthWest () { 2 } sub North () { 3 } sub NorthEast () { 4 } sub West () { 5 } sub Center () { 6 } sub East () { 7 } sub SouthWest () { 8 } sub South () { 9 } sub SouthEast () { 10 } sub ForgetGravity () { 0 } sub UnmapGravity () { 0 } sub StaticGravity () { 1 } sub NorthWestGravity () { 2 } sub NorthGravity () { 3 } sub NorthEastGravity () { 4 } sub WestGravity () { 5 } sub CenterGravity () { 6 } sub EastGravity () { 7 } sub SouthWestGravity () { 8 } sub SouthGravity () { 9 } sub SouthEastGravity () { 10 } # EventMask sub KeyPress_m () { 1 } sub KeyRelease_m () { 2 } sub ButtonPress_m () { 4 } sub ButtonRelease_m () { 8 } sub EnterWindow_m () { 16 } sub LeaveWindow_m () { 32 } sub PointerMotion_m () { 64 } sub PointerMotionHint_m () { 128 } sub Button1Motion_m () { 256 } sub Button2Motion_m () { 512 } sub Button3Motion_m () { 1024 } sub Button4Motion_m () { 2048 } sub Button5Motion_m () { 4096 } sub ButtonMotion_m () { 8192 } sub KeymapState_m () { 16384 } sub Exposure_m () { 32768 } sub VisibilityChange_m () { 65536 } # As far as I can go in my head. sub StructureNotify_m () { 131072 } # Luckily, perl can compute these at sub ResizeRedirect_m () { 1<<18 } # compile time. sub SubstructureNotify_m () { 1<<19 } sub SubstructureRedirect_m () { 1<<20 } sub FocusChange_m () { 1<<21 } sub PropertyChange_m () { 1<<22 } sub ColormapChange_m () { 1<<23 } sub OwnerGrabButton_m () { 1<<24 } sub KeyPress_mask () { 1 } sub KeyRelease_mask () { 2 } sub ButtonPress_mask () { 4 } sub ButtonRelease_mask () { 8 } sub EnterWindow_mask () { 16 } sub LeaveWindow_mask () { 32 } sub PointerMotion_mask () { 64 } sub PointerMotionHint_mask () { 128 } sub Button1Motion_mask () { 256 } sub Button2Motion_mask () { 512 } sub Button3Motion_mask () { 1024 } sub Button4Motion_mask () { 2048 } sub Button5Motion_mask () { 4096 } sub ButtonMotion_mask () { 8192 } sub KeymapState_mask () { 16384 } sub Exposure_mask () { 32768 } sub VisibilityChange_mask () { 65536 } sub StructureNotify_mask () { 1<<17 } sub ResizeRedirect_mask () { 1<<18 } sub SubstructureNotify_mask () { 1<<19 } sub SubstructureRedirect_mask () { 1<<20 } sub FocusChange_mask () { 1<<21 } sub PropertyChange_mask () { 1<<22 } sub ColormapChange_mask () { 1<<23 } sub OwnerGrabButton_mask () { 1<<24 } sub NoEventMask () { 0 } # Xlib sub KeyPressMask () { 1 } sub KeyReleaseMask () { 2 } sub ButtonPressMask () { 4 } sub ButtonReleaseMask () { 8 } sub EnterWindowMask () { 16 } sub LeaveWindowMask () { 32 } sub PointerMotionMask () { 64 } sub PointerMotionHintMask () { 128 } sub Button1MotionMask () { 256 } sub Button2MotionMask () { 512 } sub Button3MotionMask () { 1024 } sub Button4MotionMask () { 2048 } sub Button5MotionMask () { 4096 } sub ButtonMotionMask () { 8192 } sub KeymapStateMask () { 16384 } sub ExposureMask () { 32768 } sub VisibilityChangeMask () { 65536 } sub StructureNotifyMask () { 1<<17 } sub ResizeRedirectMask () { 1<<18 } sub SubstructureNotifyMask () { 1<<19 } sub SubstructureRedirectMask () { 1<<20 } sub FocusChangeMask () { 1<<21 } sub PropertyChangeMask () { 1<<22 } sub ColormapChangeMask () { 1<<23 } sub OwnerGrabButtonMask () { 1<<24 } # Plain old Events sub KeyPress () { 2 } sub KeyRelease () { 3 } sub ButtonPress () { 4 } sub ButtonRelease () { 5 } sub MotionNotify () { 6 } sub EnterWindow () { 7 } sub LeaveWindow () { 8 } sub FocusIn () { 9 } sub FocusOut () { 10 } sub KeymapNotify () { 11 } sub Expose () { 12 } sub GraphicsExposure () { 13 } sub NoExposure () { 14 } sub VisibilityNotify () { 15 } sub CreateNotify () { 16 } sub DestroyNotify () { 17 } sub UnmapNotify () { 18 } sub MapNotify () { 19 } sub MapRequest () { 20 } sub ReparentNotify () { 21 } sub ConfigureNotify () { 22 } sub ConfigureRequest () { 23 } sub GravityNotify () { 24 } sub ResizeRequest () { 25 } sub CirculateNotify () { 26 } sub CirculateRequest () { 27 } sub PropertyNotify () { 28 } sub SelectionClear () { 29 } sub SelectionRequest () { 30 } sub SelectionNotify () { 31 } sub ColormapNotify () { 32 } sub ClientMessage () { 33 } sub MappingNotify () { 34 } sub LASTEvent () { 35 } # Xlib # KeyMasks sub Shift () { 1 } sub Lock () { 2 } sub Control () { 4 } sub Mod1 () { 8 } sub Mod2 () { 16 } sub Mod3 () { 32 } sub Mod4 () { 64 } sub Mod5 () { 128 } sub ShiftMask () { 1 } sub LockMask () { 2 } sub ControlMask () { 4 } sub Mod1Mask () { 8 } sub Mod2Mask () { 16 } sub Mod3Mask () { 32 } sub Mod4Mask () { 64 } sub Mod5Mask () { 128 } sub ShiftMapIndex () { 0 } sub LockMapIndex () { 1 } sub ControlMapIndex () { 2 } sub Mod1MapIndex () { 3 } sub Mod2MapIndex () { 4 } sub Mod3MapIndex () { 5 } sub Mod4MapIndex () { 6 } sub Mod5MapIndex () { 7 } # Button masks sub Button1Mask () { 256 } sub Button2Mask () { 512 } sub Button3Mask () { 1024 } sub Button4Mask () { 2048 } sub Button5Mask () { 4096 } sub AnyModifier () { 1<<15 } # Button names. Dubious value. sub Button1 () { 1 } sub Button2 () { 2 } sub Button3 () { 3 } sub Button4 () { 4 } sub Button5 () { 5 } # Significance sub LeastSignificant () { 0 } sub MostSignificant () { 1 } sub LSBFirst () { 0 } sub MSBFirst () { 1 } # BackingStore sub Never () { 0 } sub WhenMapped () { 1 } sub Always () { 2 } sub NotUseful () { 0 } # Booleans sub False () { 0 } sub True () { 1 } # Window Classes sub CopyFromParent () { 0 } sub InputOutput () { 1 } # Bad hash collision between this sub InputOnly () { 2 } # and this. (IO). Oh well. # MapStates sub Unmapped () { 0 } sub Unviewable () { 1 } sub Viewable () { 2 } sub IsUnmapped () { 0 } sub IsUnviewable () { 1 } sub IsViewable () { 2 } # StackModes sub Above () { 0 } sub Below () { 1 } sub TopIf () { 2 } sub BottomIf () { 3 } sub Opposite () { 4 } # CirculateDirections sub RaiseLowest () { 0 } sub LowerHighest () { 1 } # Circulation requests sub PlaceOnTop () { 0 } sub PlaceOnBottom () { 1 } # PropertyChangeModes sub Replace () { 0 } sub Prepend () { 1 } sub Append () { 2 } sub PropModeReplace () { 0 } sub PropModePrepend () { 1 } sub PropModeAppend () { 2 } # CrossingNotifyDetails sub Ancestor () { 0 } sub Virtual () { 1 } sub Inferior () { 2 } sub Nonlinear () { 3 } sub NonlinearVirtual () { 4 } # ... and FocusDetails sub PointerDetail () { 5 } # uh-oh sub PointerRootDetail () { 6 } # " sub NoDetail () { 7 } # " sub NotifyAncestor () { 0 } sub NotifyVirtual () { 1 } sub NotifyInferior () { 2 } sub NotifyNonlinear () { 3 } sub NotifyNonlinearVirtual () { 4 } sub NotifyPointerl () { 5 } sub NotifyPointerRoot () { 6 } sub NotifyDetailNone () { 7 } # CrossingNotifyModes sub Normal () { 0 } sub Grab () { 1 } sub Ungrab () { 2 } # ... and FocusModes sub WhileGrabbed () { 3 } sub NotifyNormal () { 0 } sub NotifyGrab () { 1 } sub NotifyUngrab () { 2 } sub NotifyWhileGrabbed () { 3 } sub NotifyHint () { 1 } # VisibilityStates sub Unobscured () { 0 } sub PartiallyObscured () { 1 } sub FullyObscured () { 2 } sub VisibilityUnobscured () { 0 } sub VisibilityPartiallyObscured () { 1 } sub VisibilityFullyObscured () { 2 } # CirculatePlaces sub Top () { 0 } sub Bottom () { 1 } # PropertyNotifyStates sub NewValue () { 0 } sub Deleted () { 1 } sub PropertyNewValue () { 0 } sub PropertyDeleted () { 1 } # ColormapNotifyStates sub Uninstalled () { 0 } sub Installed () { 1 } sub ColormapUninstalled () { 0 } sub ColormapInstalled () { 1 } # MappingNotifyRequests sub Modifier () { 0 } sub Keyboard () { 1 } sub Pointer () { 2 } sub MappingModifier () { 0 } sub MappingKeyboard () { 1 } sub MappingPointer () { 2 } # Synchroni(city|zation)Modes sub Synchronous () { 0 } sub Asynchronous () { 1 } sub GrabModeSync () { 0 } sub GrabModeAsync () { 1 } # GrabStatuses sub Success () { 0 } sub AlreadyGrabbed () { 1 } sub InvalidTime () { 2 } sub NotViewable () { 3 } sub Frozen () { 4 } sub GrabSuccess () { 0 } # No `GrabAlreadyGrabbed' sub GrabInvalidTime () { 2 } sub GrabNotViewable () { 3 } sub GrabFrozen () { 4 } # AllowEventsModes sub AsyncPointer () { 0 } sub SyncPointer () { 1 } sub ReplayPointer () { 2 } sub AsyncKeyboard () { 3 } sub SyncKeyboard () { 4 } sub ReplayKeyboard () { 5 } sub AsyncBoth () { 6 } sub SyncBoth () { 7 } # InputFocusRevertTos sub None () { 0 } sub PointerRoot () { 1 } sub Parent () { 2 } sub RevertToNone () { 0 } sub RevertToPointerRoot () { 1 } sub RevertToParent () { 2 } # DrawDirections sub LeftToRight () { 0 } sub RightToLeft () { 1 } sub FontLeftToRight () { 0 } sub FontRightToLeft () { 1 } sub FrontChange () { 255 } # ClipRectangleOrderings sub UnSorted () { 0 } # The capitalization of `Un' things is inconsistent sub Unsorted () { 0 } # in these constants. Xlib gets it `right'. sub YSorted () { 1 } sub YXSorted () { 2 } sub YXBanded () { 3 } # CoordinateModes sub Origin () { 0 } sub Previous () { 1 } sub CoordModeOrigin () { 0 } sub CoordModePrevious () { 1 } # PolyShapes sub Complex () { 0 } sub Nonconvex () { 1 } sub Convex () { 2 } # ImageFormats sub Bitmap () { 0 } sub XYPixmap () { 1 } sub ZPixmap () { 2 } sub XYBitmap () { 0 } # SizeClasses sub Cursor () { 0 } sub Tile () { 1 } sub Stipple () { 2 } sub CursorShape () { 0 } sub TileShape () { 1 } sub StippleShape () { 2 } # LedModes sub Off () { 0 } sub On () { 1 } # ... and AutoRepeatModes sub Default () { 2 } sub AutoRepeatModeOff () { 0 } sub AutoRepeatModeOn () { 1 } sub AutoRepeatModeDefault () { 2 } sub LedModeOff () { 0 } sub LedModeOn () { 1 } # ScreenSaver modes sub No () { 0 } sub Yes () { 1 } # sub Default () { 2 } # HostChangeModes sub Insert () { 0 } sub Delete () { 1 } sub SetModeInsert () { 0 } sub SetModeDelete () { 1 } sub HostInsert () { 0 } sub HostDelete () { 1 } # HostFamilies sub Internet () { 0 } sub DECnet () { 1 } # slightly obscure sub Chaos () { 2 } # really obscure sub FamilyInternet () { 0 } sub FamilyDECnet () { 1 } sub FamilyChaos () { 2 } # AccessModes sub Disabled () { 0 } sub Enabled () { 1 } sub DisableAccess () { 0 } sub EnableAccess () { 1 } # CloseDownModes sub Destroy () { 0 } sub RetainPermanent () { 1 } sub RetainTemporary () { 2 } sub DestroyAll () { 0 } # ScreenSaverActions sub Reset () { 0 } sub Activate () { 1 } # MappingChangeStatuses # sub Success () { 0 } sub Busy () { 1 } sub Failed () { 2 } sub MappingSuccess () { 0 } sub MappingBusy () { 1 } sub MappingFailed () { 2 } # dest # \ 0 1 # --------- # s 0 | 8 | 4 | # r --------- # c 1 | 2 | 1 | # --------- # GC Functions sub Clear () { 0 } # Yes, we have all 16 logically possible functions. sub And () { 1 } sub AndReverse () { 2 } # When was the last time you used this? sub Copy () { 3 } sub AndInverted () { 4 } # or this? sub NoOp () { 5 } # or this??? sub Xor () { 6 } # This one sounds useful... sub Or () { 7 } sub Nor () { 8 } sub Equiv () { 9 } sub Invert () { 10 } sub OrReverse () { 11 } sub CopyInverted () { 12 } sub OrInverted () { 13 } sub Nand () { 14 } sub Set () { 15 } sub GXclear () { 0 } sub GXand () { 1 } sub GXandReverse () { 2 } sub GXcopy () { 3 } sub GXandInverted () { 4 } sub GXnoop () { 5 } sub GXxor () { 6 } sub GXor () { 7 } sub GXnor () { 8 } sub GXequiv () { 9 } sub GXinvert () { 10 } sub GXorReverse () { 11 } sub GXcopyInverted () { 12 } sub GXorInverted () { 13 } sub GXnand () { 14 } sub GXset () { 15 } # GC LineStyles sub Solid () { 0 } sub OnOffDash () { 1 } sub DoubleDash () { 2 } sub LineSolid () { 0 } sub LineOnOffDash () { 1 } sub LineDoubleDash () { 2 } # GC CapStyles sub NotLast () { 0 } sub Butt () { 1 } sub RoundCap () { 2 } # @#!$ protocol designers... sub Projecting () { 3 } sub CapNotLast () { 0 } sub CapButt () { 1 } sub CapRound () { 2 } sub CapProjecting () { 3 } # GC JoinStyles sub Miter () { 0 } sub RoundJoin () { 1 } # right next to each other! sub Bevel () { 2 } sub JoinMiter () { 0 } sub JoinRound () { 1 } sub JoinBevel () { 2 } # GC FillStyles #sub Solid () { 0 } sub Tiled () { 1 } sub Stippled () { 2 } sub OpaqueStippled () { 3 } sub FillSolid () { 0 } sub FillTiled () { 1 } sub FillStippled () { 2 } sub FillOpaqueStippled () { 3 } # GC FillRules sub EvenOdd () { 0 } sub Winding () { 1 } sub EvenOddRule () { 0 } sub WindingRule () { 1 } # GC SubwindowModes sub ClipByChildren () { 0 } sub IncludeInferiors () { 1 } # GC ArcModes sub Chord () { 0 } sub PieSlice () { 1 } sub ArcChord () { 0 } sub ArcPieSlice () { 1 } sub BadRequest () { 1 } sub BadValue () { 2 } sub BadWindow () { 3 } sub BadPixmap () { 4 } sub BadAtom () { 5 } sub BadCursor () { 6 } sub BadFont () { 7 } sub BadMatch () { 8 } sub BadDrawable () { 9 } sub BadAccess () { 10 } sub BadAlloc () { 11 } sub BadColormap () { 12 } sub BadGC () { 13 } sub BadIDChoice () { 14 } sub BadName () { 15 } sub BadLength () { 16 } sub BadImplementation () { 17 } sub FirstExtensionError () { 128 } sub LastExtensionError () { 255 } # Colormap allocation styles sub AllocNone () { 0 } sub AllocAll () { 1 } # Color storage flags sub DoRed () { 1 } sub DoGreen () { 2 } sub DoBlue () { 4 } # `SCREEN SAVER STUFF' sub DontPreferBlanking () { 0 } sub PreferBlanking () { 1 } sub DefaultBlanking () { 2 } sub DisableScreenSaver () { 0 } sub DisableScreenInterval () { 0 } sub DontAllowExposures () { 0 } sub AllowExposures () { 1 } sub DefaultExposures () { 2 } 1; X11-Protocol-0.56/Protocol/Ext/0000755000175000017500000000000010512256531014611 5ustar smccsmccX11-Protocol-0.56/Protocol/Ext/RENDER.pm0000644000175000017500000005065010033642715016135 0ustar smccsmcc#!/usr/bin/perl # The X Rendering Extension package X11::Protocol::Ext::RENDER; # Copyright (C) 2004 Stephen McCamant. All rights reserved. This program # is free software; you can redistribute and/or modify it under the same # terms as Perl itself. use X11::Protocol qw(pad padding padded make_num_hash); use Carp; use strict; use vars '$VERSION'; $VERSION = 0.01; sub new { my($pkg, $x, $request_num, $event_num, $error_num) = @_; my($self) = {}; # Constants $x->{'ext_const'}{'PictType'} = ['Indexed', 'Direct']; $x->{'ext_const_num'}{'PictType'} = {make_num_hash($x->{'ext_const'}{'PictType'})}; $x->{'ext_const'}{'PictOp'} = ['Clear', 'Src', 'Dst', 'Over', 'OverReverse', 'In', 'InReverse', 'Out', 'OutReverse', 'Atop', 'AtopReverse', 'Xor', 'Add', 'Saturate', undef, undef, 'DisjointClear', 'DisjointSrc', 'DisjointDst', 'DisjointOver', 'DisjointOverReverse', 'DisjointIn', 'DisjointInReverse', 'DisjointOut', 'DisjointOutReverse', 'DisjointAtop', 'DisjointAtopReverse', 'DisjointXor', undef, undef, undef, undef, 'ConjointClear', 'ConjointSrc', 'ConjointDst', 'ConjointOver', 'ConjointOverReverse', 'ConjointIn', 'ConjointInReverse', 'ConjointOut', 'ConjointOutReverse', 'ConjointAtop', 'ConjointAtopReverse', 'ConjointXor']; $x->{'ext_const_num'}{'PictOp'} = {make_num_hash($x->{'ext_const'}{'PictOp'})}; $x->{'ext_const'}{'SubPixel'} = ['Unknown', 'HorizontalRGB', 'HorizontalBGR', 'VerticalRGB', 'VerticalBGR', 'None']; $x->{'ext_const_num'}{'SubPixel'} = {make_num_hash($x->{'ext_const'}{'SubPixel'})}; $x->{'ext_const'}{'PolyEdge'} = ['Sharp', 'Smooth']; $x->{'ext_const_num'}{'PolyEdge'} = {make_num_hash($x->{'ext_const'}{'PolyEdge'})}; $x->{'ext_const'}{'PolyMode'} = ['Precise', 'Imprecise']; $x->{'ext_const_num'}{'PolyMode'} = {make_num_hash($x->{'ext_const'}{'PolyMode'})}; my @errors = ('PictFormat', 'Picture', 'PictOp', 'GlyphSet', 'Glyph'); my @error_types = (1, 1, 1, 1, 1); my $err; for $err (@errors) { $x->{'ext_const'}{'Error'}[$error_num] = $err; $x->{'ext_error_type'}[$error_num] = shift @error_types; $error_num++; } $x->{'ext_const_num'}{'Error'} = {make_num_hash($x->{'ext_const'}{'Error'})}; # Events: none my($Card16, $Int16, $Card8, $Int8); if (pack("L", 1) eq "\0\0\0\1") { $Int8 = "xxxc"; $Card8 = "xxxC"; $Int16 = "xxs"; $Card16 = "xxS"; } elsif (pack("L", 1) eq "\1\0\0\0") { $Int8 = "cxxx"; $Card8 = "Cxxx"; $Int16 = "sxx"; $Card16 = "Sxx"; } else { croak "Can't determine byte order!\n"; } my @Attributes_ValueMask = (['repeat', sub { pack($Card8, $_[1]) }], # ['fill_nearest', sub { pack($Card8, $_[1]) }], ['alpha_map', sub { $_[1] = 0 if $_[1] eq "None"; pack("L", $_[1]) }], ['alpha_x_origin', sub { pack($Int16, $_[1]) }], ['alpha_y_origin', sub { pack($Int16, $_[1]) }], ['clip_x_origin', sub { pack($Int16, $_[1]) }], ['clip_y_origin', sub { pack($Int16, $_[1]) }], ['clip_mask', sub { $_[1] = 0 if $_[1] eq "None"; pack("L", $_[1]) }], ['graphics_exposures', sub { pack($Card8, $_[1]) }], ['subwindow_mode', sub { $_[1] = $_[0]->num('GCSubwindowMode', $_[1]); pack($Card8, $_[1]); }], ['poly_edge', sub { $_[1] = $_[0]->num('PolyEdge', $_[1]); pack($Card8, $_[1]); }], ['poly_mode', sub { $_[1] = $_[0]->num('PolyMode', $_[1]); pack($Card8, $_[1]); }], ['dither', sub { $_[1] = 0 if $_[1] eq "None"; pack("L", $_[1]) }], ['component_alpha', sub { pack($Card8, $_[1]) }], ); # Requests $x->{'ext_request'}{$request_num} = [ ["RenderQueryVersion", sub { my $self = shift; return pack("LL", 0, 8); # We suport version 0.8 }, sub { my $self = shift; my($data) = @_; my($major, $minor) = unpack("xxxxxxxxLLxxxxxxxxxxxxxxx", $data); return ($major, $minor); }], ["RenderQueryPictFormats", sub { my $self = shift; return ""; }, sub { my $self = shift; my($data) = @_; my($num_formats, $num_screens, $num_depths, $num_visuals, $num_subpixel) = unpack("xxxxxxxxLLLLLxxxx", substr($data, 0, 32)); my(@formats, @screens, @subpixels); my $index = 32; for (0 .. $num_formats - 1) { push @formats, [unpack("LCCxxSSSSSSSSL", substr($data, $index, 28))]; $formats[$#formats][1] = $self->interp('PictType', $formats[$#formats][1]); $index += 28; } for (0 .. $num_screens - 1) { my($ndepths, $fallback) = unpack("LL", substr($data, $index, 8)); $index += 8; my @depths; for (0 .. $ndepths - 1) { my($depth, $nvisuals) = unpack("CxSxxxx", substr($data, $index, 8)); $index += 8; my @visuals; for (0 .. $nvisuals - 1) { my($visual, $format) = unpack("LL", substr($data, $index, 8)); $index += 8; push @visuals, [$visual, $format]; } push @depths, [$depth, @visuals]; } push @screens, [$fallback, @depths]; } for (0 .. $num_subpixel - 1) { my $sp = unpack("L", substr($data, $index, 4)); $index += 4; $sp = $self->interp('SubPixel', $sp); push @subpixels, $sp; } return ([@formats], [@screens], [@subpixels]); }], ["RenderQueryPictIndexValues", sub { my $self = shift; my($format) = @_; return pack("L", $format); }, sub { my($self) = shift; my($data) = @_; my($num_vals) = unpack("xxxxxxxxLxxxxxxxxxxxxxxxxxxxx", substr($data, 0, 32)); my @values; for my $index (0 .. $num_vals - 1) { my($pixel, $r, $g, $b, $alpha) =\ unpack("LSSSS", substr($data, 32 + 12*$index, 12)); push @values, [$index, $r, $g, $b, $alpha]; } return @values; }], ["RenderQueryDithers", sub { die "RenderQueryDithers is unspecified"; }, sub { die "RenderQueryDithers is unspecified"; }], ["RenderCreatePicture", sub { my $self = shift; my($pid, $drawable, $format, %values) = @_; my($mask, $i, @values); for $i (0 .. 12) { if (exists $values{$Attributes_ValueMask[$i][0]}) { $mask |= (1 << $i); push @values, &{$Attributes_ValueMask[$i][1]} ($self, $values{$Attributes_ValueMask[$i][0]}); } } return pack("LLLL", $pid, $drawable, $format, $mask) . join("", @values); }], ["RenderChangePicture", sub { my $self = shift; my($pid, %values) = @_; my($mask, $i, @values); for $i (0 .. 12) { if (exists $values{$Attributes_ValueMask[$i][0]}) { $mask |= (1 << $i); push @values, &{$Attributes_ValueMask[$i][1]} ($self, $values{$Attributes_ValueMask[$i][0]}); } } return pack("LL", $pid, $mask) . join("", @values); }], ["RenderSetPictureClipRectangles", sub { my $self = shift; my($picture, $x_origin, $y_origin, @rects) = @_; my $r; for $r (@rects) { $r = pack("ssSS", @$r); } return pack("Lss", $picture, $x_origin, $y_origin) . join("", @rects); }], ["RenderFreePicture", sub { my $self = shift; my($picture) = @_; return pack("L", $picture); }], ["RenderComposite", sub { my $self = shift; my($op, $src, $mask, $dst, $src_x, $src_y, $mask_x, $mask_y, $dst_x, $dst_y, $width, $height) = @_; $op = $self->num('PictOp', $op); $mask = 0 if $mask eq "None"; return pack("CxxxLLLssssssSS", $op, $src, $mask, $dst, $src_x, $src_y, $mask_x, $mask_y, $dst_x, $dst_y, $width, $height); }], ["RenderScale", sub { die "RenderScale is unspecified"; }], ["RenderTrapezoids", sub { my $self = shift; my($op, $src, $src_x, $src_y, $dst, $mask_format, @traps) = @_; $op = $self->num('PictOp', $op); $mask_format = 0 if $mask_format eq "None"; my $trap; for $trap (@traps) { my($top, $bottom, $lx1, $ly1, $lx2, $ly2, $rx1, $ry1, $rx2, $ry2) = @$trap; $top *= 2**16; $bottom *= 2**16; $lx1 *= 2**16; $ly1 *= 2**16; $lx2 *= 2**16; $ly2 *= 2**16; $rx1 *= 2**16; $ry1 *= 2**16; $rx2 *= 2**16; $ry2 *= 2**16; $trap = pack("llllllllll", $top, $bottom, $lx1, $ly1, $lx2, $ly2, $rx1, $ry1, $rx2, $ry2); } return pack("CxxxLLLss", $op, $src, $dst, $mask_format, $src_x, $src_y) . join("", @traps); }], ["RenderTriangles", sub { my $self = shift; my($op, $src, $src_x, $src_y, $dst, $mask_format, @tris) = @_; $op = $self->num('PictOp', $op); $mask_format = 0 if $mask_format eq "None"; my $tri; for $tri (@tris) { my($x1, $y1, $x2, $y2, $x3, $y3) = @$tri; $x1 *= 2**16; $y1 *= 2**16; $x2 *= 2**16; $y2 *= 2**16; $x3 *= 2**16; $y3 *= 2**16; $tri = pack("llllll", $x1, $y1, $x2, $y2, $x3, $y3); } return pack("CxxxLLLss", $op, $src, $dst, $mask_format, $src_x, $src_y) . join("", @tris); }], ["RenderTriStrip", sub { my $self = shift; my($op, $src, $src_x, $src_y, $dst, $mask_format, @points) = @_; $op = $self->num('PictOp', $op); $mask_format = 0 if $mask_format eq "None"; my $pt; for $pt (@points) { my($x, $y) = @$pt; $x *= 2**16; $y *= 2**16; $pt = pack("ll", $x, $y); } return pack("CxxxLLLss", $op, $src, $dst, $mask_format, $src_x, $src_y) . join("", @points); }], ["RenderTriFan", sub { my $self = shift; my($op, $src, $src_x, $src_y, $dst, $mask_format, @points) = @_; $op = $self->num('PictOp', $op); $mask_format = 0 if $mask_format eq "None"; my $pt; for $pt (@points) { my($x, $y) = @$pt; $x *= 2**16; $y *= 2**16; $pt = pack("ll", $x, $y); } return pack("CxxxLLLss", $op, $src, $dst, $mask_format, $src_x, $src_y) . join("", @points); }], ["RenderColorTrapezoids", sub { die "RenderColorTrapezoids is unimplemented"; # Also unimplemented in the XFree86 server, BTW. }], ["RenderColorTriangles", sub { # N.B. This is not implemented in XFree86 yet, so it will # always give a BadImplementation error. my $self = shift; my($op, $dst, @color_tris) = @_; $op = $self->num('PictOp', $op); my $ct; for $ct (@color_tris) { my($x1, $y1, $r1, $g1, $b1, $a1, $x2, $y2, $r2, $g2, $b2, $a2, $x3, $y3, $r3, $g3, $b3, $a3) = @$ct; $x1 *= 2**16; $y1 *= 2**16; $x2 *= 2**16; $y2 *= 2**16; $x3 *= 2**16; $y3 *= 2**16; $ct = pack("llSSSS llSSSS llSSSS", $x1, $y1, $r1, $g1, $b1, $a1, $x2, $y2, $r2, $g2, $b2, $a2, $x3, $y3, $r3, $g3, $b3, $a3); } return pack("CxxxL", $op, $dst) . join("", @color_tris); }], ["RenderTransform", sub { die "RenderTransform is unspecified " . "(did you mean RenderSetPictureTransform?)"; }], ["RenderCreateGlyphSet", sub { my $self = shift; my($gsid, $format) = @_; return pack("LL", $gsid, $format); }], ["RenderReferenceGlyphSet", sub { my $self = shift; my($new, $existing) = @_; return pack("LL", $new, $existing); }], ["RenderFreeGlyphSet", sub { my $self = shift; my($gsid) = @_; return pack("L", $gsid); }], ["RenderAddGlyphs", sub { my $self = shift; my($gsid, @glyphs) = @_; my $g; my(@gids, @infos, @datas); for $g (@glyphs) { my($id, $width, $height, $x, $y, $x_off, $y_off, $data) = @$g; push @gids, $id; push @infos, pack("SSssss", $width, $height, $x, $y, $x_off, $y_off); push @datas, pack(padded($data), $data); } return pack("LLL*", $gsid, scalar @glyphs, @gids) . join("", @infos) . join("", @datas); }], ["RenderAddGlyphsFromPicture", sub { die "RenderAddGlyphsFromPicture is unimplemented"; # And the specification is broken, since it doesn't say # which glyphs you're adding! }], ["RenderFreeGlyphs", sub { my $self = shift; my($gsid, @glyphs) = @_; return pack("LL*", $gsid, @glyphs); }], ["RenderCompositeGlyphs8", sub { my $self = shift; my($op, $src, $dst, $mask_format, $glyphable, $src_x, $src_y, @items) = @_; $op = $self->num('PictOp', $op); $mask_format = 0 if $mask_format eq "None"; my $it; for $it (@items) { if (ref($it) eq "ARRAY") { my($dx, $dy, $str) = @$it; $it = pack("Cxxxss".padded($str), length($str), $dx, $dy, $str); } else { $it = pack("CxxxxxxxL", 255, $it); } } return pack("CxxxLLLLss", $op, $src, $dst, $mask_format, $glyphable, $src_x, $src_y) . join("", @items); }], ["RenderCompositeGlyphs16", sub { my $self = shift; my($op, $src, $dst, $mask_format, $glyphable, $src_x, $src_y, @items) = @_; $op = $self->num('PictOp', $op); $mask_format = 0 if $mask_format eq "None"; my $it; for $it (@items) { if (ref($it) eq "ARRAY") { my($dx, $dy, $str) = @$it; $it = pack("Cxxxss".padded($str), length($str)/2, $dx, $dy, $str); } else { $it = pack("CxxxxxxxL", 255, $it); } } return pack("CxxxLLLLss", $op, $src, $dst, $mask_format, $glyphable, $src_x, $src_y) . join("", @items); }], ["RenderCompositeGlyphs32", sub { my $self = shift; my($op, $src, $dst, $mask_format, $glyphable, $src_x, $src_y, @items) = @_; $op = $self->num('PictOp', $op); $mask_format = 0 if $mask_format eq "None"; my $it; for $it (@items) { if (ref($it) eq "ARRAY") { my($dx, $dy, $str) = @$it; $it = pack("Cxxxss".padded($str), length($str)/4, $dx, $dy, $str); } else { $it = pack("CxxxxxxxL", 255, $it); } } return pack("CxxxLLLLss", $op, $src, $dst, $mask_format, $glyphable, $src_x, $src_y) . join("", @items); }], ["RenderFillRectangles", sub { my $self = shift; my($op, $dst, $color, @rects) = @_; $op = $self->num('PictOp', $op); $color = pack("SSSS", @$color); my $r; for $r (@rects) { $r = pack("ssSS", @$r); } return pack("CxxxL", $op, $dst) . $color . join("", @rects); }], ["RenderCreateCursor", sub { my $self = shift; my($cid, $src, $x, $y) = @_; return pack("LLSS", $cid, $src, $x, $y); }], ["RenderSetPictureTransform", sub { my $self = shift; my($pict, @trans) = @_; my $trans = pack("l9", map($_ * 2**16, @trans)); return pack("L", $pict) . $trans; }], ["RenderQueryFilters", sub { my $self = shift; my($drawable) = @_; return pack("L", $drawable); }, sub { my $self = shift; my($data) = @_; my(@aliases, @filters); my($num_al, $num_filt) = unpack("xxxxxxxxLLxxxxxxxxxxxxxxxx", substr($data, 0, 32)); my $index = 32; for (0 .. $num_al - 1) { my $alias = unpack("S", substr($data, $index, 2)); $index += 2; push @aliases, $alias; } $index += padding($index); for (0 .. $num_filt) { my $len = unpack("C", substr($data, $index, 1)); $index++; my $str = substr($data, $index, $len); $index += $len; push @filters, $str; } return ([@filters], [@aliases]); }], ["RenderSetPictureFilter", sub { my $self = shift; my($picture, $filter, @args) = @_; return pack("LSxx".padded($filter)."L*", $picture, length($filter), $filter, map($_ * 2**16, @args)); }], ["RenderCreateAnimCursor", sub { my $self = shift; my($cid, @frames) = @_; my $fr; for $fr (@frames) { $fr = pack("LL", @$fr); } return pack("L", $cid) . join("", @frames); }], ]; my($i); for $i (0 .. $#{$x->{'ext_request'}{$request_num}}) { $x->{'ext_request_num'}{$x->{'ext_request'}{$request_num}[$i][0]} = [$request_num, $i]; } ($self->{'major'}, $self->{'minor'}) = $x->req('RenderQueryVersion', 0, 8); if ($self->{'major'} != 0) { carp "Wrong RENDER version ($self->{'major'} != 0)"; return 0; } return bless $self, $pkg; } 1; __END__ =head1 NAME X11::Protocol::Ext::RENDER - Perl module for the X Rendering Extension =head1 SYNOPSIS use X11::Protocol; $x = X11::Protocol->new($ENV{'DISPLAY'}); $x->init_extension('RENDER') or die; =head1 DESCRIPTION The RENDER extension adds a new set of drawing primitives which effectively represent a replacement of the drawing routines in the core protocol, redesigned based on the needs of more modern clients. It adds long-desired features such as subpixel positioning, alpha compositing, direct specification of colors, and multicolored or animated cursors. On the other hand, it omits features that are no longer commonly used: wide lines, arbitrary polygons (only triangles and horizontally-aligned trapezoids are supported), ellipses, bitwise rendering operations, and server-side fonts (in favor of "glyphs" that are rendered on the client side and transmitted once). As of this writing (early 2004), the specification and implementation both have rough edges, but there are relatively few alternatives for offloading fancy graphics processing to the server, as is necessary over slow links or if the client is written in a slow language. Another possibility you might consider is the 2D subset of OpenGL, though it doesn't yet have an X11::Protocol-compatible interface. =head1 SYMBOLIC CONSTANTS This extension adds the constant types 'PictType', 'PictOp', 'SubPixel', 'PolyEdge', and 'PolyMode', with values as defined in the standard. =head1 REQUESTS This extension adds several requests, called as shown below: $x->RenderQueryVersion($major, $minor) => ($major, $minor) $x->RenderQueryPictFormats() => ([[$id, $type, $depth, $red, $red_m, $green, $green_m, $blue, $blue_m, $alpha, $alpha_m, $cmap], ...], [[$fallback, [$depth, [$visual, $format], ...], ...], ...], [$subpixel, ...]) $x->RenderQueryPictIndexValues($pict_format) => ([$index, $red, $green, $blue, $alpha], ...) $x->RenderQueryFilters($drawable) => ([@filters], [@aliases]) $x->RenderCreatePicture($picture, $drawable, $format, 'attribute' => $value, ...) $x->RenderChangePicture($picture, 'attribute' => $value, ...) $x->RenderSetPictureClipRectangles($pic, $x_origin, $y_origin, [$x, $y, $width, $height], ...) $x->RenderSetPictureTransform($pict, $m11, $m12, $m13, $m21, $m22, $m23, $m31, $m32, $m33); $x->RenderSetPictureFilter($pict, $filter, @args) $x->RenderComposite($op, $src, $mask, $dst, $src_x, $src_y, $mask_x, $mask_y, $dst_x, $dst_y, $width, $height) $x->RenderFillRectangles($op, $dst, [$red, $green, $blue, $alpha], [$x, $y, $width, $height], ...) $x->RenderTrapezoids($op, $src, $src_x, $src_y, $dst, $mask_format, [$top, $bottom, $lx1, $ly1, $lx2, $ly2, $rx1, $ry1, $rx2, $ry2] ,...) $x->RenderTriangles($op, $src, $src_x, $src_y, $dst, $mask_format, [$x1, $y1, $x2, $y2, $x3, $y3]) $x->RenderTriStrip($op, $src, $src_x, $src_y, $dst, $mask_format, [$x, $y], [$x, $y], [$x, $y], [$x, $y], ...) $x->RenderTriFan($op, $src, $src_x, $src_y, $dst, $mask_format, [$x, $y], [$x, $y], [$x, $y], [$x, $y], ...) $x->RenderCreateGlyphSet($gsid, $format) $x->RenderReferenceGlyphSet($gsid, $existing) $x->RenderFreeGlyphSet($gsid) $x->RenderAddGlyphs($gsid, [$glyph, $width, $height, $x, $y, $x_off, $y_off, $data], ...) Warning: with some server implementations (including XFree86 through 4.4) passing more than one glyph to AddGlyphs can hang or crash the server. So don't do that. $x->RenderFreeGylphs($gsid, @glyphs) $x->RenderCompositeGlyphs8($op, $src, $dst, $mask_format, $gsid, $src_x, $src_y, [$delta_x, $delta_y, $str], ...) $x->RenderCompositeGlyphs16($op, $src, $dst, $mask_format, $gsid, $src_x, $src_y, [$delta_x, $delta_y, $str], ...) $x->RenderCompositeGlyphs32($op, $src, $dst, $mask_format, $gsid, $src_x, $src_y, [$delta_x, $delta_y, $str], ...) In these three requests, new GlyphSetIDs can also be interspersed with the array references. $x->RenderCreateCursor($cid, $source, $hot_x, $hot_y) $x->RenderCreateAnimCursor($cid, [$cursor, $delay], ...) =head1 AUTHOR Stephen McCamant . =head1 SEE ALSO L, L, I. =cut X11-Protocol-0.56/Protocol/Ext/XC_MISC.pm0000644000175000017500000000531007657513073016310 0ustar smccsmcc#!/usr/bin/perl # The XC-MISC Extension package X11::Protocol::Ext::XC_MISC; # This module was originally written in 1998 by Jay Kominek. As of # February 10th, 2003, he has placed it in the public domain. use X11::Protocol qw(pad padding padded make_num_hash); use Carp; use strict; use vars '$VERSION'; $VERSION = 0.01; sub new { my($pkg, $x, $request_num, $event_num, $error_num) = @_; my($self) = {}; # Constants # Events # Requests $x->{'ext_request'}{$request_num} = [ ["XCMiscGetVersion", sub { my($self) = shift; my($major, $minor) = @_; return pack("SS", $major, $minor); }, sub { my($self) = shift; my($data) = @_; my($major,$minor) = unpack("xxxxxxxxSSxxxxxxxxxxxxxxxxxxxx",$data); return($major,$minor); }], ["XCMiscGetXIDRange", sub { my($self) = shift; return ""; }, sub { my($self) = shift; my($data) = @_; my($start_id,$count) = unpack("xxxxxxxxLLxxxxxxxxxxxxxxxx",$data); return($start_id,$count); }], ["XCMiscGetXIDList", sub { my($self) = shift; return pack("L",shift); }, sub { my($self) = shift; my($data) = @_; my($count,@ids) = unpack("xxxxxxxxLxxxxxxxxxxxxxxxxxxxxL*",$data); return($count,@ids); }] ]; my($i); for $i (0 .. $#{$x->{'ext_request'}{$request_num}}) { $x->{'ext_request_num'}{$x->{'ext_request'}{$request_num}[$i][0]} = [$request_num, $i]; } ($self->{'major'},$self->{'minor'}) = $x->req('XCMiscGetVersion', 1, 1); if ($self->{'major'} != 1) { carp "Wrong XC-MISC version ($self->{'major'} != 1)"; return undef; } return bless $self, $pkg; } 1; __END__ =head1 NAME X11::Protocol::Ext::XC_MISC - Perl module for the X11 Protocol XC-MISC Extension =head1 SYNOPSIS use X11::Protocol; $x = X11::Protocol->new(); $x->init_extension('XC-MISC'); =head1 DESCRIPTION This module is used by the programmer to pre-acquire large numbers of X resource IDs to be used with the X11::Protocol module. If supported by the server, X11::Protocol will load this module automatically when additional resource IDs are needed via the standard new_rsrc() interface. However, if you anticipate that a program will run for a long time and allocate many resources, it would be a good idea to initialize the extension at startup to verify its existence. =head1 REQUESTS This extension adds three requests, called as shown below: $x->XCMiscGetVersion => ($major, $minor) $x->XCMiscGetXIDRange => ($start_id, $count) $x->XCMiscGetXIDList($count) => ($count, @ids) =head1 AUTHOR Jay Kominek . =head1 SEE ALSO L, L, I. X11-Protocol-0.56/Protocol/Ext/DPMS.pm0000644000175000017500000000654707657512530015740 0ustar smccsmcc#!/usr/bin/perl package X11::Protocol::Ext::DPMS; # The Display Power Management Signaling # Extension # This module was originally written in 1998 by Jay Kominek. As of # February 10th, 2003, he has placed it in the public domain. use X11::Protocol qw(pad padding padded make_num_hash); use Carp; use strict; use vars '$VERSION'; $VERSION = 0.01; sub new { my($pkg, $x, $request_num, $event_num, $error_num) = @_; my($self) = {}; # Constants $x->{'ext_const'}{'DPMSPowerLevels'} = ['DPMSModeOn','DPMSModeStandby', 'DPMSModeSuspend','DPMSModeOff']; $x->{'ext_const_num'}{'DPMSPowerLevels'} = {make_num_hash($x->{'ext_const'}{'DPMSPowerLevels'})}; # Events # Requests $x->{'ext_request'}{$request_num} = [ ["DPMSGetVersion", sub { my($self) = shift; return pack("SS",1,1); }, sub { my($self) = shift; my($data) = @_; my($major,$minor) = unpack("xxxxxxxxSSxxxxxxxxxxxxxxxxxxxx",$data); return($major,$minor); }], ["DPMSCapable", sub { my($self) = shift; return ""; }, sub { my($self) = shift; my($data) = @_; my($capable) = unpack("xxxxxxxxCxxxxxxxxxxxxxxxxxxxxxxx",$data); return($capable); }], ["DPMSGetTimeouts", sub { my($self) = shift; return ""; }, sub { my($self) = shift; my($data) = @_; my($standby,$suspend,$off) = unpack("xxxxxxxxSSSxxxxxxxxxxxxxxxxxx",$data); return($standby,$suspend,$off); }], ["DPMSSetTimeouts", sub { my($self) = shift; my($standby,$suspend,$off) = @_; return pack("SSSxx",$standby,$suspend,$off); }], ["DPMSEnable", sub { my($self) = shift; return ""; }], ["DPMSDisable", sub { my($self) = shift; return ""; }], ["DPMSForceLevel", sub { my($self) = shift; return(pack("Sxx",$self->num('DPMSPowerLevels',@_[0]))); }], ["DPMSInfo", sub { my($self) = shift; return ""; }, sub { my($self) = shift; my($data) = @_; my($power_level,$state) = unpack("xxxxxxxxSCxxxxxxxxxxxxxxxxxxxxx",$data); return($self->interp('DPMSPowerLevels',$power_level),$state); }] ]; my($i); for $i (0 .. $#{$x->{'ext_request'}{$request_num}}) { $x->{'ext_request_num'}{$x->{'ext_request'}{$request_num}[$i][0]} = [$request_num, $i]; } ($self->{'major'}, $self->{'minor'}) = $x->req('DPMSGetVersion'); return bless $self, $pkg; } 1; __END__ =head1 NAME X11::Protocol::Ext::DPMS - Perl module for the X11 Protocol DPMS Extension =head1 SYNOPSIS use X11::Protocol; $x = X11::Protocol->new(); $x->init_extension('DPMS'); =head1 DESCRIPTION This module is used to control the DPMS features of compliant monitors. =head1 SYMBOLIC CONSTANTS This extension adds the constant type DPMSPowerLevels, with values as defined in the standard. =head1 REQUESTS This extension adds several requests, called as shown below: $x->DPMSGetVersion => ($major, $minor) $x->DPMSCapable => ($capable) $x->DPMSGetTimeouts => ($standby_timeout, $suspend_timeout, $off_timeout) $x->DPMSSetTimeouts($standby_timeout, $suspend_timeout, $off_timeout) => () $x->DPMSEnable => () $x->DPMSDisable => () $x->DPMSForceLevel($power_level) => () $x->DPMSInfo => ($power_level,$state) =head1 AUTHOR Jay Kominek =head1 SEE ALSO L, L, I X11-Protocol-0.56/Protocol/Ext/SHAPE.pm0000644000175000017500000001376107623553114016025 0ustar smccsmcc#!/usr/bin/perl # The `X11 Nonrectangular Window Shape Extension' package X11::Protocol::Ext::SHAPE; # Copyright (C) 1997 Stephen McCamant. All rights reserved. This program # is free software; you can redistribute and/or modify it under the same # terms as Perl itself. use X11::Protocol qw(pad padding padded make_num_hash); use Carp; use strict; use vars '$VERSION'; $VERSION = 0.01; sub new { my($pkg, $x, $request_num, $event_num, $error_num) = @_; my($self) = {}; # Constants $x->{'ext_const'}{'ShapeKind'} = ['Bounding', 'Clip']; $x->{'ext_const_num'}{'ShapeKind'} = {make_num_hash($x->{'ext_const'}{'ShapeKind'})}; $x->{'ext_const'}{'ShapeOp'} = ['Set', 'Union', 'Intersect', 'Subtract', 'Invert']; $x->{'ext_const_num'}{'ShapeOp'} = {make_num_hash($x->{'ext_const'}{'ShapeOp'})}; # Events $x->{'ext_const'}{'Events'}[$event_num] = "ShapeNotify"; $x->{'ext_events'}[$event_num] = ["xCxxLssSSLCxxxxxxxxxxx", ['shape_kind', 'ShapeKind'], 'x', 'y', 'width', 'height', 'time', 'shaped']; # Requests $x->{'ext_request'}{$request_num} = [ ["ShapeQueryVersion", sub { my($self) = shift; return ""; }, sub { my($self) = shift; my($data) = @_; my($major, $minor) = unpack("xxxxxxxxSSxxxxxxxxxxxxxxxxxxxx", $data); return ($major, $minor); }], ["ShapeRectangles", sub { my($self) = shift; my($dest, $kind, $op, $x, $y, $ordering, @rects) = @_; $op = $self->num('ShapeOp', $op); $kind = $self->num('ShapeKind', $kind); $ordering = $self->num('ClipRectangleOrdering', $ordering); my($r); for $r (@rects) { $r = pack("ssSS", @$r); } return pack("CCCxLss", $op, $kind, $ordering, $dest, $x, $y) . join("", @rects); }], ["ShapeMask", sub { my($self) = shift; my($win, $kind, $op, $x, $y, $pixmap) = @_; $op = $self->num('ShapeOp', $op); $kind = $self->num('ShapeKind', $kind); $pixmap = 0 if $pixmap eq "None"; return pack("CCxxLssL", $op, $kind, $win, $x, $y, $pixmap); }], ["ShapeCombine", sub { my($self) = shift; my($dst, $d_kind, $op, $x, $y, $src, $s_kind) = @_; $op = $self->num('ShapeOp', $op); $d_kind = $self->num('ShapeKind', $d_kind); $s_kind = $self->num('ShapeKind', $s_kind); return pack("CCCxLssL", $op, $d_kind, $s_kind, $dst, $x, $y, $src); }], ["ShapeOffset", sub { my($self) = shift; my($win, $kind, $x, $y) = @_; $kind = $self->num('ShapeKind', $kind); return pack("CxxxLss", $kind, $win, $x, $y); }], ["ShapeQueryExtents", sub { my($self) = shift; my($win) = @_; return pack("L", $win); }, sub { my($self) = shift; my($data) = @_; my($b, $c, $b_x, $b_y, $b_w, $b_h, $c_x, $c_y, $c_w, $c_h) = unpack("xxxxxxxxCCxxssSSssSSxxxx", $data); return ($b, $c, $b_x, $b_y, $b_w, $b_h, $c_x, $c_y, $c_w, $c_h); }], ["ShapeSelectInput", sub { my($self) = shift; my($win, $enable) = @_; return pack("LCxxx", $win, $enable); }], # The R6 documentation gets the next two minor opcodes wrong; # this usage follows . ["ShapeInputSelected", sub { my($self) = shift; my($win) = @_; return pack("L", $win); }, sub { my($self) = shift; my($data) = @_; return unpack("xCxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx", $data); }], ["ShapeGetRectangles", sub { my($self) = shift; my($win, $kind) = @_; $kind = $self->num('ShapeKind', $kind); return pack("LCxxx", $win, $kind); }, sub { my($self) = shift; my($data) = @_; my($ordering, $nrects) = unpack("xCxxxxxxLxxxxxxxxxxxxxxxxxxxx", substr($data, 0, 32)); my($i, @rects); for $i (0 .. $nrects - 1) { push @rects, [unpack("ssSS", substr($data, 32 + 8 * $i, 8))]; } return ($self->interp('ClipRectangleOrdering', $ordering), @rects); }] ]; my($i); for $i (0 .. $#{$x->{'ext_request'}{$request_num}}) { $x->{'ext_request_num'}{$x->{'ext_request'}{$request_num}[$i][0]} = [$request_num, $i]; } ($self->{'major'}, $self->{'minor'}) = $x->req('ShapeQueryVersion'); if ($self->{'major'} != 1) { carp "Wrong SHAPE version ($self->{'major'} != 1)"; return 0; } return bless $self, $pkg; } 1; __END__ =head1 NAME X11::Protocol::Ext::SHAPE - Perl module for the X11 Protocol Nonrectangular Window Shape Extension =head1 SYNOPSIS use X11::Protocol; $x = X11::Protocol->new($ENV{'DISPLAY'}); $x->init_extension('SHAPE') or die; =head1 DESCRIPTION This module is used by the X11::Protocol module to participate in the shaped window extension to the X protocol, allowing windows to be of any shape, not just rectangles. =head1 SYMBOLIC CONSTANTS This extension adds the constant types 'ShapeKind' and 'ShapeOp', with values as defined in the standard. =head1 EVENTS This extension adds the event type 'ShapeNotify', with values as specified in the standard. This event is selected using the ShapeSelectInput() request. =head1 REQUESTS This extension adds several requests, called as shown below: $x->ShapeQueryVersion => ($major, $minor) $x->ShapeRectangles($dest, $destKind, $op, $xOff, $yOff, $ordering, @rectangles) $x->ShapeMask($dest, $destKind, $op, $xOff, $yOff, $source) $x->ShapeCombine($dest, $destKind, $op, $xOff, $yOff, $source, $sourceKind) $x->ShapeOffset($dest, $destKind, $xOff, $yOff) $x->ShapeQueryExtents($dest) => ($boundingShaped, $clipShaped, ($xBoundingShape, $yBoundingShape, $widthBoundingShape, $heightBoundingShape) ($xClipShape, $yClipShape, $widthClipShape, $heightClipShape)) $x->ShapeSelectInput($window, $enable) $x->ShapeInputSelected($window) => $enable $x->ShapeGetRectangles($window, $kind) => ($ordering, [$x, $y, $width, $height], ...) =head1 AUTHOR Stephen McCamant . =head1 SEE ALSO L, L, I. =cut X11-Protocol-0.56/Protocol/Ext/BIG_REQUESTS.pm0000644000175000017500000000367107623552553017126 0ustar smccsmcc#!/usr/bin/perl package X11::Protocol::Ext::BIG_REQUESTS; # The `Big Requests Extension' # Copyright (C) 1997 Stephen McCamant. All rights reserved. This program # is free software; you can redistribute and/or modify it under the same # terms as Perl itself. # The actual mechanism for packing large requests is in X11::Protocol -- # it just checks whether $x->{'ext'}{'BIG_REQUESTS'} is defined. # The only thing this module does is issue the BigReqEnable request. use X11::Protocol qw(pad padding padded make_num_hash); use Carp; use strict; use vars '$VERSION'; $VERSION = 0.01; sub new { my($pkg, $x, $request_num, $event_num, $error_num) = @_; my($self) = {}; # Constants # Events # Requests $x->{'ext_request'}{$request_num} = [ ["BigReqEnable", sub { my($self) = shift; return ""; }, sub { my($self) = shift; my($data) = @_; my($max_len) = unpack("xxxxxxxxIxxxxxxxxxxxxxxxxxxxx", $data); return ($max_len); }] ]; my($i); for $i (0 .. $#{$x->{'ext_request'}{$request_num}}) { $x->{'ext_request_num'}{$x->{'ext_request'}{$request_num}[$i][0]} = [$request_num, $i]; } $x->{'maximum_request_length'} = $x->req('BigReqEnable'); return bless $self, $pkg; } 1; __END__ =head1 NAME X11::Protocol::Ext::BIG_REQUESTS - Perl module for the X11 protocol Big Requests extension =head1 SYNOPSIS use X11::Protocol; $x = X11::Protocol->new($ENV{'DISPLAY'}); $x->init_extension('BIG_REQUESTS') or die; =head1 DESCRIPTION This module is used by the X11::Protocol module to participate in the 'Big Requests' extension to the X protocol. Once initialized, it transparently allows requests of more than 262140 (65535 * 4) bytes. The new maximum request length is avaliable as C<$x-Emaximum_request_length>. =head1 AUTHOR Stephen McCamant . =head1 SEE ALSO L, L, I. =cut X11-Protocol-0.56/Protocol/Ext/XFree86_Misc.pm0000644000175000017500000001102207657512537017326 0ustar smccsmcc#!/usr/bin/perl package X11::Protocol::Ext::XFree86_Misc; # XFree86-Misc Extension # This module was originally written in 1998 by Jay Kominek. As of # February 10th, 2003, he has placed it in the public domain. use X11::Protocol qw(pad padding padded make_num_hash); use Carp; use strict; use vars '$VERSION'; $VERSION = 0.01; sub new { my($pkg, $x, $request_num, $event_num, $error_num) = @_; my($self) = { }; my(@tmp) = ('MICROSOFT','MOUSESYS','MMSERIES','LOGITECH','BUSMOUSE', 'PS/2','MMHIT','GLIDEPOINT','IMSERIAL','THINKING', 'IMPS2','THINKINGPS2','MMANPLUSPS2','GLIDEPOINTPS2', 'NETPS2','NETSCROLLPS2','SYSMOUSE','AUTOMOSE'); @tmp[127..128] = ('XQUEUE','OSMOUSE'); # Constants $x->{'ext_const'}{'MouseTypes'} = [@tmp]; $x->{'ext_const_num'}{'MouseTypes'} = {make_num_hash($x->{'ext_const'}{'MouseTypes'})}; $x->{'ext_const'}{'KeyboardTypes'} = ['Unknown','84 Key','101 Key', 'Other', 'XQUEUE']; $x->{'ext_const_num'}{'KeyboardTypes'} = {make_num_hash($x->{'ext_const'}{'KeyboardTypes'})}; my(@tmp); @tmp[1,2,128] = ('Clear DTR','Clear RTS','Reopen'); $x->{'ext_const'}{'MouseFlags'} = [@tmp]; $x->{'ext_const_num'}{'MouseFlags'} = {make_num_hash($x->{'ext_const'}{'MouseFlags'})}; # Events # Requests $x->{'ext_request'}{$request_num} = [ ["XF86MiscQueryVersion", sub { my($self) = shift; return ""; }, sub { my($self) = shift; my($data) = @_; my($major,$minor) = unpack("xxxxxxxxSSxxxxxxxxxxxxxxxxxxxx",$data); return($major,$minor); }], ["XF86MiscGetSaver", sub { my($self) = shift; my($screen) = @_; return pack("Sxx",$screen); }, sub { my($self) = shift; my($data) = @_; my($suspend,$off) = unpack("xxxxxxxxLLxxxxxxxxxxxxxxxx",$data); return($suspend,$off); }], ["XF86MiscSetSaver", sub { my($self) = shift; my($screen,$suspend,$off) = @_; return pack("SxxLL",$screen,$suspend,$off); }], ["XF86MiscGetMouseSettings", sub { return ""; }, sub { my($self) = shift; my($data) = @_; my($type,$baudrate,$samplerate,$resolution,$buttons, $emulate3,$chord,$emulate3timeout,$flags,$devnamelen) = unpack("xxxxxxxxLLLLLCCxxLLL",$data); return(mousetype=>$self->interp('MouseTypes',$type), baudrate=>$baudrate,samplerate=>$samplerate, resolution=>$resolution,buttons=>$buttons, emulate3buttons=>$emulate3,chordmiddle=>$chord, emulate3timeout=>$emulate3timeout,flags=>$flags, device=>substr($data,44,$devnamelen-1)); }], ["XF86MiscGetKbdSettings", sub { return ""; }, sub { my($self) = shift; my($data) = @_; my($type,$rate,$delay,$servnumlock) = unpack("xxxxxxxxLLLCxxxxxxxxxxxx",$data); return($type,$rate,$delay,$servnumlock); }], ["XF86MiscSetMouseSettings", sub { my($self) = shift; my(%args) = @_; return pack("LLLLLCCxxLL",$self->pack('MouseTypes',$args{mousetype}), $args{baudrate},$args{samplerate},$args{resolution}, $args{buttons},$args{emulate3buttons},$args{chordmiddle}, $args{emulate3timeout},$args{flags}); }], ["XF86MiscSetKbdSettings", sub { my($self) = shift; my($type,$rate,$delay,$servnumlock) = @_; return pack("LLLCxxx",$self->pack('KeyboardTypes',$type), $rate,$delay,$servnumlock); }] ]; my($i); for $i (0..$#{$x->{'ext_request'}{$request_num}}) { $x->{'ext_request_num'}{$x->{'ext_request'}{$request_num}[$i][0]} = [$request_num, $i]; } ($self->{'major'}, $self->{'minor'}) = $x->req('XF86MiscQueryVersion'); return(bless $self, $pkg); } 1; __END__ =head1 NAME X11::Protocol::Ext::XFree86_Misc.pm - Perl module for the XFree86 Misc Extension =head1 SYNOPSIS use X11::Protocol; $x = X11::Protocol->new(); $x->init_extension('XFree86-Misc'); =head1 DESCRIPTION This module is used to access miscellaneous features of XFree86 servers =head1 SYMBOLIC CONSTANTS This extension adds the MouseTypes, KeyboardTypes and MouseFlags constants, with values as defined in the XFree86 3.3.3 source code. =head1 REQUESTS This extension adds several requests, called as shown below: $x->XF86MiscQueryVersion => ($major, $minor) $x->XF86MiscGetSaver($screen) => ($suspendtime, $offtime) $x->XF86MiscSetSaver($screen, $suspendtime, $offtime) $x->XF86MiscGetMouseSettings => (%settings) $x->XF86MiscSetMouseSettings(%settings) $x->XF86MiscGetKbdSettings => ($type, $rate, $delay, $servnumlock) $x->XF86MiscSetKbdSettings($type, $rate, $delay, $servnumlock) =head1 AUTHOR Jay Kominek =head1 SEE ALSO L, L X11-Protocol-0.56/Protocol.pm0000644000175000017500000031205210512256236014414 0ustar smccsmcc#!/usr/bin/perl package X11::Protocol; # Copyright (C) 1997-2000, 2003-2006 Stephen McCamant. All rights # reserved. This program is free software; you can redistribute and/or # modify it under the same terms as Perl itself. use Carp; use strict; use vars qw($VERSION $AUTOLOAD @ISA @EXPORT_OK); require Exporter; @ISA = ('Exporter'); @EXPORT_OK = qw(pad padding padded hexi make_num_hash default_error_handler); $VERSION = "0.56"; sub padding ($) { my($x) = @_; -$x & 3; } sub pad ($) { my($x) = @_; padding(length($x)); } sub padded ($) { my $l = length($_[0]); "a" . $l . "x" x (-$l & 3); } sub hexi ($) { "0x" . sprintf("%x", $_[0]); } length(pack("L", 0)) == 4 or croak "can't happen"; my($Byte_Order, $Card16, $Int16, $Card8, $Int8); if (pack("L", 1) eq "\0\0\0\1") { $Byte_Order = 'B'; $Int8 = "xxxc"; $Card8 = "xxxC"; $Int16 = "xxs"; $Card16 = "xxS"; } elsif (pack("L", 1) eq "\1\0\0\0") { $Byte_Order = 'l'; $Int8 = "cxxx"; $Card8 = "Cxxx"; $Int16 = "sxx"; $Card16 = "Sxx"; } else { croak "Can't determine byte order!\n"; } my($Default_Display); if ($^O eq "MSWin32") { $Default_Display = "localhost"; } else { $Default_Display = "unix"; } sub give { my($self) = shift; $self->{'connection'}->give(@_); } sub get { my($self) = shift; return $self->{'connection'}->get(@_); } sub flush { my $self = shift; $self->{'connection'}->flush(); } my(%Const) = ( 'VisualClass' => ['StaticGray', 'GrayScale', 'StaticColor', 'PseudoColor', 'TrueColor', 'DirectColor'], 'BitGravity' => ['Forget', 'Static', 'NorthWest', 'North', 'NorthEast', 'West', 'Center', 'East', 'SouthWest', 'South', 'SouthEast'], 'WinGravity' => ['Unmap', 'Static', 'NorthWest', 'North', 'NorthEast', 'West', 'Center', 'East', 'SouthWest', 'South', 'SouthEast'], 'EventMask' => ['KeyPress', 'KeyRelease', 'ButtonPress', 'ButtonRelease', 'EnterWindow', 'LeaveWindow', 'PointerMotion', 'PointerMotionHint', 'Button1Motion', 'Button2Motion', 'Button3Motion', 'Button4Motion', 'Button5Motion', 'ButtonMotion', 'KeymapState', 'Exposure', 'VisibilityChange', 'StructureNotify', 'ResizeRedirect', 'SubstructureNotify', 'SubstructureRedirect', 'FocusChange', 'PropertyChange', 'ColormapChange', 'OwnerGrabButton'], 'Events' => [0, 0, 'KeyPress' , 'KeyRelease', 'ButtonPress', 'ButtonRelease', 'MotionNotify', 'EnterNotify', 'LeaveNotify', 'FocusIn', 'FocusOut', 'KeymapNotify', 'Expose', 'GraphicsExposure', 'NoExposure', 'VisibilityNotify', 'CreateNotify', 'DestroyNotify', 'UnmapNotify', 'MapNotify', 'MapRequest', 'ReparentNotify', 'ConfigureNotify', 'ConfigureRequest', 'GravityNotify', 'ResizeRequest', 'CirculateNotify', 'CirculateRequest', 'PropertyNotify', 'SelectionClear', 'SelectionRequest', 'SelectionNotify', 'ColormapNotify', 'ClientMessage', 'MappingNotify'], 'PointerEvent' => [0, 0, 'ButtonPress', 'ButtonRelease', 'EnterWindow', 'LeaveWindow', 'PointerMotion', 'PointerMotionHint', 'Button1Motion', 'Button2Motion', 'Button3Motion', 'Button4Motion', 'Button5Motion', 'ButtonMotion', 'KeymapState'], 'DeviceEvent' => ['KeyPress', 'KeyRelease', 'ButtonPress', 'ButtonRelease', 0, 0, 'PointerMotion', 'PointerMotionHint', 'Button1Motion', 'Button2Motion', 'Button3Motion', 'Button4Motion', 'Button5Motion', 'ButtonMotion'], 'KeyMask' => ['Shift', 'Lock', 'Control', 'Mod1', 'Mod2', 'Mod3', 'Mod4', 'Mod5'], 'Significance' => ['LeastSignificant', 'MostSignificant'], 'BackingStore' => ['Never', 'WhenMapped', 'Always'], 'Bool' => ['False', 'True'], 'Class' => ['CopyFromParent', 'InputOutput', 'InputOnly'], 'MapState' => ['Unmapped', 'Unviewable', 'Viewable'], 'StackMode' => ['Above', 'Below', 'TopIf', 'BottomIf', 'Opposite'], 'CirculateDirection' => ['RaiseLowest', 'LowerHighest'], 'ChangePropertyMode' => ['Replace', 'Prepend', 'Append'], 'CrossingNotifyDetail' => ['Ancestor', 'Virtual', 'Inferior', 'Nonlinear', 'NonlinearVirtual'], 'CrossingNotifyMode' => ['Normal', 'Grab', 'Ungrab'], 'FocusDetail' => ['Ancestor', 'Virtual', 'Inferior', 'Nonlinear', 'NonlinearVirtual', 'Pointer', 'PointerRoot', 'None'], 'FocusMode' => ['Normal', 'Grab', 'Ungrab', 'WhileGrabbed'], 'VisibilityState' => ['Unobscured', 'PartiallyObscured', 'FullyObscured'], 'CirculatePlace' => ['Top', 'Bottom'], 'PropertyNotifyState' => ['NewValue', 'Deleted'], 'ColormapNotifyState' => ['Uninstalled', 'Installed'], 'MappingNotifyRequest' => ['Modifier', 'Keyboard', 'Pointer'], 'SyncMode' => ['Synchronous', 'Asynchronous'], 'GrabStatus' => ['Success', 'AlreadyGrabbed', 'InvalidTime', 'NotViewable', 'Frozen'], 'AllowEventsMode' => ['AsyncPointer', 'SyncPointer', 'ReplayPointer', 'AsyncKeyboard', 'SyncKeyboard', 'ReplayKeyboard', 'AsyncBoth', 'SyncBoth'], 'InputFocusRevertTo' => ['None', 'PointerRoot', 'Parent'], 'DrawDirection' => ['LeftToRight', 'RightToLeft'], 'ClipRectangleOrdering' => ['UnSorted', 'YSorted', 'YXSorted', 'YXBanded'], 'CoordinateMode' => ['Origin', 'Previous'], 'PolyShape' => ['Complex', 'Nonconvex', 'Convex'], 'ImageFormat' => ['Bitmap', 'XYPixmap', 'ZPixmap'], 'SizeClass' => ['Cursor', 'Tile', 'Stipple'], 'LedMode' => ['Off', 'On'], 'AutoRepeatMode' => ['Off', 'On', 'Default'], 'ScreenSaver' => ['No', 'Yes', 'Default'], 'HostChangeMode' => ['Insert', 'Delete'], 'HostFamily' => ['Internet', 'DECnet', 'Chaos', 0, 0, 'ServerInterpreted', 'InternetV6'], 'AccessMode' => ['Disabled', 'Enabled'], 'CloseDownMode' => ['Destroy', 'RetainPermanent', 'RetainTemporary'], 'ScreenSaverAction' => ['Reset', 'Activate'], 'MappingChangeStatus' => ['Success', 'Busy', 'Failed'], 'GCFunction' => ['Clear', 'And', 'AndReverse', 'Copy', 'AndInverted', 'NoOp', 'Xor', 'Or', 'Nor', 'Equiv', 'Invert', 'OrReverse', 'CopyInverted', 'OrInverted', 'Nand', 'Set'], 'GCLineStyle' => ['Solid', 'OnOffDash', 'DoubleDash'], 'GCCapStyle' => ['NotLast', 'Butt', 'Round', 'Projecting'], 'GCJoinStyle' => ['Miter', 'Round', 'Bevel'], 'GCFillStyle' => ['Solid', 'Tiled', 'Stippled', 'OpaqueStippled'], 'GCFillRule' => ['EvenOdd', 'Winding'], 'GCSubwindowMode' => ['ClipByChildren', 'IncludeInferiors'], 'GCArcMode' => ['Chord', 'PieSlice'], 'Error' => [0, 'Request', 'Value', 'Window', 'Pixmap', 'Atom', 'Cursor', 'Font', 'Match', 'Drawable', 'Access', 'Alloc', 'Colormap', 'GContext', 'IDChoice', 'Name', 'Length', 'Implementation'], ); my(%Const_num) = (); # Filled in dynamically sub interp { my($self) = shift; return $_[1] unless $self->{'do_interp'}; return $self->do_interp(@_); } sub do_interp { my $self = shift; my($type, $num) = @_; carp "Unknown constant type `$type'\n" unless exists $self->{'const'}{$type} or exists $self->{'ext_const'}{$type}; return $num if $num < 0; return $self->{'const'}{$type}[$num] || $self->{'ext_const'}{$type}[$num]; } sub make_num_hash { my($from) = @_; my(%hash); @hash{@$from} = (0 .. $#{$from}); return %hash; } sub num ($$) { my($self) = shift; my($type, $x) = @_; carp "Unknown constant type `$type'\n" unless exists $self->{'const'}{$type} or exists $self->{'ext_const'}{$type}; $self->{'const_num'}{$type} = {make_num_hash($self->{'const'}{$type})} unless exists $self->{'const_num'}{$type}; if (exists $self->{'const_num'}{$type}{$x}) { return $self->{'const_num'}{$type}{$x}; } elsif (exists $self->{'ext_const_num'}{$type}{$x}) { return $self->{'ext_const_num'}{$type}{$x}; } else { return $x; } } my(@Attributes_ValueMask) = (["background_pixmap", sub {$_[1] = 0 if $_[1] eq "None"; $_[1] = 1 if $_[1] eq "ParentRelative"; pack "L", $_[1];}], ["background_pixel", sub {pack "L", $_[1];}], ["border_pixmap", sub {$_[1] = 0 if $_[1] eq "CopyFromParent"; pack "L", $_[1];}], ["border_pixel", sub {pack "L", $_[1];}], ["bit_gravity", sub {$_[1] = $_[0]->num('BitGravity', $_[1]); pack $Card8, $_[1];}], ["win_gravity", sub {$_[1] = $_[0]->num('WinGravity', $_[1]); pack $Card8, $_[1];}], ["backing_store", sub {$_[1] = 0 if $_[1] eq "NotUseful"; $_[1] = 1 if $_[1] eq "WhenMapped"; $_[1] = 2 if $_[1] eq "Always"; pack $Card8, $_[1];}], ["backing_planes", sub {pack "L", $_[1];}], ["backing_pixel", sub {pack "L", $_[1];}], ["override_redirect", sub {pack $Card8, $_[1];}], ["save_under", sub {pack $Card8, $_[1];}], ["event_mask", sub {pack "L", $_[1];}], ["do_not_propagate_mask", sub {pack "L", $_[1];}], ["colormap", sub {$_[1] = 0 if $_[1] eq "CopyFromParent"; pack "L", $_[1];}], ["cursor", sub {$_[1] = 0 if $_[1] eq "None"; pack "L", $_[1];}]); my(@Configure_ValueMask) = (["x", sub {pack $Int16, $_[1];}], ["y", sub {pack $Int16, $_[1];}], ["width", sub {pack $Card16, $_[1];}], ["height", sub {pack $Card16, $_[1];}], ["border_width", sub {pack $Card16, $_[1];}], ["sibling", sub {pack "L", $_[1];}], ["stack_mode", sub {$_[1] = $_[0]->num('StackMode', $_[1]); pack $Card8, $_[1];}]); my(@GC_ValueMask) = (['function', sub { $_[1] = $_[0]->num('GCFunction', $_[1]); $_[1] = pack($Card8, $_[1]); }, sub {}], ['plane_mask', sub {$_[1] = pack("L", $_[1]);}, sub {}], ['foreground', sub {$_[1] = pack("L", $_[1]);}, sub {}], ['background', sub {$_[1] = pack("L", $_[1]);}, sub {}], ['line_width', sub {$_[1] = pack($Card16, $_[1]);}, sub {}], ['line_style', sub { $_[1] = $_[0]->num('GCLineStyle', $_[1]); $_[1] = pack($Card8, $_[1]); }, sub {}], ['cap_style', sub { $_[1] = $_[0]->num('GCCapStyle', $_[1]); $_[1] = pack($Card8, $_[1]); }, sub {}], ['join_style', sub { $_[1] = $_[0]->num('GCJoinStyle', $_[1]); $_[1] = pack($Card8, $_[1]); }, sub {}], ['fill_style', sub { $_[1] = $_[0]->num('GCFillStyle', $_[1]); $_[1] = pack($Card8, $_[1]); }, sub {}], ['fill_rule', sub { $_[1] = $_[0]->num('GCFillRule', $_[1]); $_[1] = pack($Card8, $_[1]); }, sub {}], ['tile', sub {$_[1] = pack("L", $_[1]);}, sub {}], ['stipple', sub {$_[1] = pack("L", $_[1]);}, sub {}], ['tile_stipple_x_origin', sub {$_[1] = pack($Int16, $_[1]);}, sub {}], ['tile_stipple_y_origin', sub {$_[1] = pack($Int16, $_[1]);}, sub {}], ['font', sub {$_[1] = pack("L", $_[1]);}, sub {}], ['subwindow_mode', sub { $_[1] = $_[0]->num('GCSubwindowMode', $_[1]); $_[1] = pack($Card8, $_[1]); }, sub {}], ['graphics_exposures', sub {$_[1] = pack($Card8, $_[1]);}, sub {}], ['clip_x_origin', sub {$_[1] = pack($Int16, $_[1]);}, sub {}], ['clip_y_origin', sub {$_[1] = pack($Int16, $_[1]);}, sub {}], ['clip_mask', sub { $_[1] = 0 if $_[1] eq "None"; $_[1] = pack("L", $_[1]); }, sub {}], ['dash_offset', sub {$_[1] = pack($Card16, $_[1]);}, sub {}], ['dashes', sub {$_[1] = pack($Card8, $_[1]);}, sub {}], ['arc_mode', sub { $_[1] = $_[0]->num('GCArcMode', $_[1]); $_[1] = pack($Card8, $_[1]); }, sub {}]); my(@KeyboardControl_ValueMask) = (['key_click_percent', sub {$_[1] = pack($Int8, $_[1]);}], ['bell_percent', sub {$_[1] = pack($Int8, $_[1]);}], ['bell_pitch', sub {$_[1] = pack($Int16, $_[1])}], ['bell_duration', sub {$_[1] = pack($Int16, $_[1])}], ['led', sub {$_[1] = pack($Card8, $_[1])}], ['led_mode', sub {$_[1] = $_[0]->num('LedMode', $_[1]); $_[1] = pack($Card8, $_[1]);}], ['key', sub {$_[1] = pack($Card8, $_[1]);}], ['auto_repeat_mode', sub {$_[1] = $_[0]->num('AutoRepeatMode', $_[1]); $_[1] = pack($Card8, $_[1]);}]); my(@Events) = (0, 0, # if ($code >= 2 and $code <= 5) # (Key|Button)(Press|Release) (["xCxxLLLLssssSCx", 'detail', 'time', 'root', 'event', ['child', ['None']], 'root_x', 'root_y', 'event_x', 'event_y', 'state', 'same_screen']) x 4, # elsif ($code == 6) # MotionNotify ["xCxxLLLLssssSCx", ['detail', ['Normal', 'Hint']], 'time', 'root', 'event', ['child', ['None']], 'root_x', 'root_y', 'event_x', 'event_y', 'state', 'same_screen'], # elsif ($code == 7 or $code == 8) # (Enter|Leave)Notify (["xCxxLLLLssssSCC", ['detail', 'CrossingNotifyDetail'], 'time', 'root', 'event', ['child', ['None']], 'root_x', 'root_y', 'event_x', 'event_y', 'state', ['mode', 'CrossingNotifyMode'], [0, sub {$_[0]{'flags'} |= 1 if $_[0]{'focus'}; $_[0]{'flags'} |= 2 if $_[0]{'same_screen'};}], 'flags', [sub {$_[0]{'focus'} = $_[0]{'flags'} & 1; $_[0]{'same_screen'} = (($_[0]{'flags'} & 2) != 0)}, 0] ]) x 2, # elsif ($code == 9 or $code == 10) # Focus(In|Out) (["xCxxLCxxxxxxxxxxxxxxxxxxxxxxx", ['detail', 'FocusDetail'], 'event', ['mode', 'FocusMode']]) x 2, # elsif ($code == 11) # KeymapNotify (weird) [sub { my($self, $data, %h) = @_; my($keys) = "\0" . substr($data, 1, 31); $h{'keys'} = $keys; delete $h{sequence_number}; return %h; }, sub { my $self = shift; my(%h) = @_; my($data) = "\0" . substr($h{"keys"}, 1, 31); return ($data, 0); }], # elsif ($code == 12) # Expose ["xxxxLSSSSSxxxxxxxxxxxxxx", 'window', 'x', 'y', 'width', 'height', 'count'], # elsif ($code == 13) # GraphicsExposure ["xxxxLSSSSSSCxxxxxxxxxxx", 'drawable', 'x', 'y', 'width', 'height', 'minor_opcode', 'count', 'major_opcode'], # elsif ($code == 14) # NoExposure ["xxxxLSCxxxxxxxxxxxxxxxxxxxxx", 'drawable', 'minor_opcode', 'major_opcode'], # elsif ($code == 15) # VisibilityNotify ["xxxxLCxxxxxxxxxxxxxxxxxxxxxxx", 'window', ['state', 'VisibilityState']], # elsif ($code == 16) # CreateNotify ["xxxxLLssSSSCxxxxxxxxx", 'parent', 'window', 'x', 'y', 'width', 'height', 'border_width', 'override_redirect'], # elsif ($code == 17) # DestroyNotify ["xxxxLLxxxxxxxxxxxxxxxxxxxx", 'event', 'window'], # elsif ($code == 18) # UnmapNotify ["xxxxLLCxxxxxxxxxxxxxxxxxxx", 'event', 'window', 'from_configure'], # elsif ($code == 19) # MapNotify ["xxxxLLCxxxxxxxxxxxxxxxxxxx", 'event', 'window', 'override_redirect'], # elsif ($code == 20) # MapRequest ["xxxxLLxxxxxxxxxxxxxxxxxxxx", 'parent', 'window'], # elsif ($code == 21) # ReparentNotify ["xxxxLLLssCxxxxxxxxxxx", 'event', 'window', 'parent', 'x', 'y', 'override_redirect'], # elsif ($code == 22) # ConfigureNotify ["xxxxLLLssSSSCxxxxx", 'event', 'window', 'above_sibling', 'x', 'y', 'width', 'height', 'border_width', 'override_redirect'], # elsif ($code == 23) # ConfigureRequest ["xCxxLLLssSSSSxxxx", ['stack_mode', 'StackMode'], 'parent', 'window', [0, sub { my($m) = 0; $m = 1 if exists $_[0]{'x'}; $m |= 2 if exists $_[0]{'y'}; $m |= 4 if exists $_[0]{'width'}; $m |= 8 if exists $_[0]{'height'}; $m |= 16 if exists $_[0]{'border_width'}; $m |= 32 if exists $_[0]{'sibling'}; $m |= 64 if exists $_[0]{'stack_mode'}; $_[0]{'mask'} = $m; }], ['sibling', ['None']], 'x', 'y', 'width', 'height', 'border_width', 'mask', [sub { my($m) = $_[0]{'mask'}; delete $_[0]{'x'} unless $m & 1; delete $_[0]{'y'} unless $m & 2; delete $_[0]{'width'} unless $m & 4; delete $_[0]{'height'} unless $m & 8; delete $_[0]{'border_width'} unless $m & 16; delete $_[0]{'sibling'} unless $m & 32; delete $_[0]{'stack_mode'} unless $m & 64; }, 0]], # elsif ($code == 24) # GravityNotify ["xxxxLLssxxxxxxxxxxxxxxxx", 'event', 'window', 'x', 'y'], # elsif ($code == 25) # ResizeRequest ["xxxxLSSxxxxxxxxxxxxxxxxxxxx", 'window', 'width', 'height'], # elsif ($code == 26 or $code == 27) # Circulate(Notify|Request) (["xxxxLLxxxxCxxxxxxxxxxxxxxx", 'event', 'window', ['place', 'CirculatePlace']]) x 2, # elsif ($code == 28) # PropertyNotify ["xxxxLLLCxxxxxxxxxxxxxxx", 'window', 'atom', 'time', ['state', 'PropertyNotifyState']], # elsif ($code == 29) # SelectionClear ["xxxxLLLxxxxxxxxxxxxxxxx", 'time', 'owner', 'selection'], # elsif ($code == 30) # SelectionRequest ["xxxxLLLLLLxxxx", ['time', ['CurrentTime']], 'owner', 'requestor', 'selection', 'target', ['property', ['None']]], # elsif ($code == 31) # SelectionNotify ["xxxxLLLLLxxxxxxxx", ['time', ['CurrentTime']], 'requestor', 'selection', 'target', ['property', ['None']]], # elsif ($code == 32) # ColormapNotify ["xxxxLLCCxxxxxxxxxxxxxxxxxx", 'window', ['colormap', ['None']], 'new', ['state', 'ColormapNotifyState']], # elsif ($code == 33) # ClientMessage [sub { my($self, $data, %h) = @_; my($format) = unpack("C", substr($data, 1, 1)); my($win, $type) = unpack("LL", substr($data, 4, 8)); my($dat) = substr($data, 12, 20); return (%h, 'window' => $win, 'type' => $type, 'data' => $dat, 'format' => $format); }, sub { my $self = shift; my(%h) = @_; my($data) = pack("xCxxLL", $h{'format'}, $h{window}, $h{type}) . substr($h{data}, 0, 20); return ($data, 1); }], # elsif ($code == 34) # MappingNotify ["xxxxCCCxxxxxxxxxxxxxxxxxxxxxxxxx", ['request', 'MappingNotifyRequest'], 'first_keycode', 'count'] ); sub unpack_event { my $self = shift; my($data) = @_; my($code, $detail, $seq) = unpack("CCS", substr($data, 0, 4)); my($name) = $self->do_interp('Events', $code & 127); my(%ret); $ret{'synthetic'} = 1 if $code & 128; $code &= 127; $ret{'name'} = $name; $ret{'code'} = $code; $ret{'sequence_number'} = $seq; my($info); $info = $self->{'events'}[$code] || $self->{'ext_events'}[$code]; if ($info) { my(@i) = @$info; if (ref $i[0] eq "CODE") { %ret = &{$i[0]}($self, $data, %ret); } else { my($format, @fields) = @i; my(@unpacked) = unpack($format, $data); my($f); for $f (@fields) { if (not ref $f) { $ret{$f} = shift @unpacked; } else { my(@f) = @$f; if (ref $f[0] eq "CODE" or ref $f[1] eq "CODE") { &{$f[0]}(\%ret) if $f[0]; } elsif (not ref $f[1]) { $ret{$f[0]} = $self->interp($f[1], shift @unpacked); } else { my($v) = shift @unpacked; $v = $f[1][$v] if $self->{'do_interp'} and ($v == 0 or $v == 1 && $f[1][1]); $ret{$f[0]} = $v; } } } } } else { carp "Unknown event (code $code)!"; $ret{'data'} = $data; } return %ret; } sub pack_event { my $self = shift; my(%h) = @_; my($code) = $h{code}; $code = $self->num('Events', $h{name}) unless exists $h{code}; $h{sequence_number} = 0 unless $h{sequence_number}; $h{synthetic} = 0 unless $h{synthetic}; my($data, $info); my($do_seq) = 1; $info = $self->{'events'}[$code] || $self->{'ext_events'}[$code]; if ($info) { my(@i) = @$info; if (ref $i[0] eq "CODE") { ($data, $do_seq) = &{$i[1]}($self, %h); } else { my($format, @fields) = @i; my(@topack) = (); my($f); for $f (@fields) { if (not ref $f) { push @topack, $h{$f}; } else { my(@f) = @$f; if (ref $f[0] eq "CODE" or ref $f[1] eq "CODE") { &{$f[1]}(\%h) if $f[1]; } elsif (not ref $f[1]) { push @topack, $self->num($f[1], $h{$f[0]}); } else { my($v) = $h{$f[0]}; $v = 0 if $v eq $f[1][0]; $v = 1 if $v eq $f[1][1] and $f[1][1]; push @topack, $v; } } } $data = pack($format, @topack); } substr($data, 2, 2) = pack("S", $h{sequence_number}) if $do_seq; substr($data, 0, 1) = pack("C", $code | ($h{synthetic} ? 128 : 0)); } else { carp "Unknown event (code $code)!"; return pack("Cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx", $code); } return $data; } sub unpack_event_mask { my $self = shift; my($x) = @_; my(@ans, $i); for $i (@{$Const{'EventMask'}}) { push @ans, $i if $x & 1; $x >>= 1; } @ans; } sub pack_event_mask { my $self = shift; my(@x) = @_; my($i, $mask); $mask = 0; for $i (@x) { $mask |= 1 << $self->num('EventMask', $i); } return $mask; } sub format_error_msg { my($self, $data) = @_; my($type, $seq, $info, $minor_op, $major_op) = unpack("xCSLSCxxxxxxxxxxxxxxxxxxxxx", $data); my($t); $t = join("", "Protocol error: bad $type (", $self->do_interp('Error', $type), "); ", "Sequence Number $seq\n", " Opcode ($major_op, $minor_op) = ", ($self->do_interp('Request', $major_op) or $self->{'ext_request'}{$major_op}[$minor_op][0]), "\n"); if ($type == 2) { $t .= " Bad value $info (" . hexi($info) . ")\n"; } elsif ($self->{'error_type'}[$type] == 1 or $self->{'ext_error_type'}[$type] == 1) { $t .= " Bad resource $info (" . hexi($info) . ")\n"; } return $t; } sub default_error_handler { my($self, $data) = @_; croak($self->format_error_msg($data)); } sub handle_input { my $self = shift; my($type_b, $type); $self->flush; $type_b = $self->get(1); $type = unpack "C", $type_b; if ($type == 0) { my $data = $type_b . $self->get(31); &{$self->{'error_handler'}}($self, $data); $self->{'error_seq'} = unpack("xxSx28", $data); return -1; } elsif ($type > 1) { if ($self->{'event_handler'} eq "queue") { push @{$self->{'event_queue'}}, $type_b . $self->get(31); } else { &{$self->{'event_handler'}} ($self->unpack_event($type_b . $self->get(31))); } return -$type; } else { # $type == 1 my($data) = $self->get(31); my($seq, $len) = unpack "SL", substr($data, 1, 6); $data = join("", $type_b, $data, $self->get(4 * $len)); if ($self->{'replies'}->{$seq}) { ${$self->{'replies'}->{$seq}} = $data; return $seq; } else { carp "Unexpected reply to request $seq", " (of $self->{'sequence_num'})"; return $seq; } } } sub handle_input_for { my($self, $seq) = @_; for (;;) { my $stat = $self->handle_input(); return if $stat == $seq; # Normal reply for this request return if $stat == -1 && $self->{'error_seq'} == $seq; # Error for this } } sub dequeue_event { my $self = shift; my($data) = shift @{$self->{'event_queue'}}; return () unless $data; return $self->unpack_event($data); } sub next_event { my $self = shift; if ($self->{'event_handler'} ne "queue") { carp "Setting event_handler to 'queue' to avoid infinite loop", "in next_event()"; $self->{'event_handler'} = "queue"; } my(%e); $self->handle_input until %e = $self->dequeue_event; return %e; } sub next_sequence { my $self = shift; my $ret = $self->{'sequence_num'}++; $self->{'sequence_num'} &= 0xffff; return $ret; } sub add_reply { my $self = shift; my($seq, $var) = @_; $self->{'replies'}->{$seq} = $var; } sub delete_reply { my $self = shift; my($seq) = @_; delete $self->{'replies'}->{$seq}; } my(@Requests) = (0, ['CreateWindow', sub { my $self = shift; my($wid, $parent, $class, $depth, $visual, $x, $y, $width, $height, $border_width, %values) = @_; my($mask, $i, @values); $mask = 0; for $i (0 .. 14) { if (exists $values{$Attributes_ValueMask[$i][0]}) { $mask |= (1 << $i); push @values, &{$Attributes_ValueMask[$i][1]} ($self, $values{$Attributes_ValueMask[$i][0]}); } } $visual = 0 if $visual eq 'CopyFromParent'; $class = $self->num('Class', $class); return pack("LLssSSSSLL", $wid, $parent, $x, $y, $width, $height, $border_width, $class, $visual, $mask) . join("", @values), $depth; }], ['ChangeWindowAttributes', sub { my $self = shift; my($wid, %values) = @_; my($mask, $i, @values); $mask = 0; for $i (0 .. 14) { if (exists $values{$Attributes_ValueMask[$i][0]}) { $mask |= (1 << $i); push @values, &{$Attributes_ValueMask[$i][1]} ($self, $values{$Attributes_ValueMask[$i][0]}); } } return pack("LL", $wid, $mask) . join "", @values; }], ['GetWindowAttributes', sub { my $self = shift; my($wid) = @_; return pack "L", $wid; }, sub { my $self = shift; my($data) = @_; my($backing_store, $visual, $class, $bit_gravity, $win_gravity, $backing_planes, $backing_pixel, $save_under, $map_is_installed, $map_state, $override_redirect, $colormap, $all_event_masks, $your_event_mask, $do_not_propagate_mask) = unpack("xCxxxxxxLSCCLLCCCCLLLS", $data); $colormap = "None" if !$colormap and $self->{'do_interp'}; return ("backing_store" => $self->interp('BackingStore', $backing_store), "visual" => $visual, "class" => $self->interp('Class', $class), "bit_gravity" => $self->interp('BitGravity', $bit_gravity), "win_gravity" => $self->interp('WinGravity', $win_gravity), "backing_planes" => $backing_planes, "backing_pixel" => $backing_pixel, "save_under" => $save_under, "map_is_installed" => $map_is_installed, "map_state" => $self->interp('MapState', $map_state), "override_redirect" => $override_redirect, "colormap" => $colormap, "all_event_masks" => $all_event_masks, "your_event_mask" => $your_event_mask, "do_not_propagate_mask" => $do_not_propagate_mask); }], ['DestroyWindow', sub { my $self = shift; my($wid) = @_; return pack "L", $wid; }], ['DestroySubwindows', sub { my $self = shift; my($wid) = @_; return pack "L", $wid; }], ['ChangeSaveSet', sub { my $self = shift; my($mode, $wid) = @_; $mode = 0 if $mode eq "Insert"; $mode = 1 if $mode eq "Delete"; return pack("L", $wid), $mode; }], ['ReparentWindow', sub { my $self = shift; my($wid, $new_parent, $x, $y) = @_; return pack "LLss", $wid, $new_parent, $x, $y; }], ['MapWindow', sub { my $self = shift; my($wid) = @_; return pack "L", $wid; }], ['MapSubwindows', sub { my $self = shift; my($wid) = @_; return pack "L", $wid; }], ['UnmapWindow', sub { my $self = shift; my($wid) = @_; return pack "L", $wid; }], ['UnmapSubwindows', sub { my $self = shift; my($wid) = @_; return pack "L", $wid; }], ['ConfigureWindow', sub { my $self = shift; my($wid, %values) = @_; my($mask, $i, @values); $mask = 0; for $i (0 .. 6) { if (exists $values{$Configure_ValueMask[$i][0]}) { $mask |= (1 << $i); push @values, &{$Configure_ValueMask[$i][1]} ($self, $values{$Configure_ValueMask[$i][0]}); } } return pack("LSxx", $wid, $mask) . join "", @values; }], ['CirculateWindow', sub { my $self = shift; my($wid, $dir) = @_; $dir = $self->num('CirculateDirection', $dir); return pack("L", $wid), $dir; }], ['GetGeometry', sub { my $self = shift; my($drawable) = @_; return pack "L", $drawable; }, sub { my $self = shift; my($data) = @_; my($depth, $root, $x, $y, $width, $height, $border_width) = unpack("xCxxxxxxLssSSSxxxxxxxxxx", $data); return ("depth" => $depth, "root" => $root, "x" => $x, "y" => $y, "width" => $width, "height" => $height, "border_width" => $border_width); }], ['QueryTree', sub { my $self = shift; my($wid) = @_; return pack "L", $wid; }, sub { my $self = shift; my($data) = @_; my($root, $parent, $n) = unpack("xxxxxxxxLLSxxxxxxxxxxxxxx", substr($data, 0, 32)); $parent = "None" if $parent == 0 and $self->{'do_interp'}; return ($root, $parent, unpack("L*", substr($data, 32))); }], ['InternAtom', sub { my $self = shift; my($string, $only_if_exists) = @_; return pack("Sxx" . padded($string), length($string), $string), $only_if_exists; }, sub { my $self = shift; my($data) = @_; my($atom) = unpack("xxxxxxxxLxxxxxxxxxxxxxxxxxxxx", $data); $atom = "None" if $atom == 0 and $self->{'do_interp'}; return $atom; }], ['GetAtomName', sub { my $self = shift; my($atom) = @_; return pack "L", $atom; }, sub { my $self = shift; my($data) = @_; my($len) = unpack "xxxxxxxxSxxxxxxxxxxxxxxxxxxxxxx", substr($data, 0, 32); return substr($data, 32, $len); }], ['ChangeProperty', sub { my $self = shift; my($window, $property, $type, $format, $mode, $data) = @_; $mode = $self->num('ChangePropertyMode', $mode); my($x) = $format / 8; return pack("LLLCxxxL" . padded($data), $window, $property, $type, $format, length($data) / $x, $data), $mode; }], ['DeleteProperty', sub { my $self = shift; my($wid, $atom) = @_; return pack "LL", $wid, $atom; }], ['GetProperty', sub { my $self = shift; my($wid, $prop, $type, $offset, $length, $delete) = @_; $type = 0 if $type eq "AnyPropertyType"; return pack("LLLLL", $wid, $prop, $type, $offset, $length), $delete; }, sub { my $self = shift; my($data) = @_; my($format, $type, $bytes_after, $len) = unpack "xCxxxxxxLLLxxxxxxxxxxxx", substr($data, 0, 32); my($m) = $format / 8; my($val) = substr($data, 32, $len * $m); return ($val, $type, $format, $bytes_after); }], ['ListProperties', sub { my $self = shift; my($wid) = @_; return pack "L", $wid; }, sub { my $self = shift; my($data) = @_; my($n) = unpack "xxxxxxxxSxxxxxxxxxxxxxxxxxxxxxx", substr($data, 0, 32); return unpack "L*", substr($data, 32, $n * 4); }], ['SetSelectionOwner', sub { my $self = shift; my($selection, $owner, $time) = @_; $owner = 0 if $owner eq "None"; $time = 0 if $time eq "CurrentTime"; return pack "LLL", $owner, $selection, $time; }], ['GetSelectionOwner', sub { my $self = shift; my($selection) = @_; return pack "L", $selection; }, sub { my $self = shift; my($data) = @_; my($win) = unpack "xxxxxxxxLxxxxxxxxxxxxxxxxxxxx", $data; $win = "None" if $win == 0 and $self->{'do_interp'}; return $win; }], ['ConvertSelection', sub { my $self = shift; my($selection, $target, $prop, $requestor, $time) = @_; $prop = 0 if $prop eq "None"; $time = 0 if $time eq "CurrentTime"; return pack("LLLLL", $requestor, $selection, $target, $prop, $time); }], ['SendEvent', sub { my $self = shift; my($destination, $propagate, $event_mask, $event) = @_; $destination = 0 if $destination eq "PointerWindow"; $destination = 1 if $destination eq "InputFocus"; return pack("LL", $destination, $event_mask) . $event, $propagate; }], ['GrabPointer', sub { my $self = shift; my($window, $owner_events, $event_mask, $pointer_mode, $keybd_mode, $confine_window, $cursor, $time) = @_; $pointer_mode = $self->num('SyncMode', $pointer_mode); $keybd_mode = $self->num('SyncMode', $keybd_mode); $confine_window = 0 if $confine_window eq "None"; $cursor = 0 if $cursor eq "None"; $time = 0 if $time eq "CurrentTime"; return pack("LSCCLLL", $window, $event_mask, $pointer_mode, $keybd_mode, $confine_window, $cursor, $time), $owner_events; }, sub { my $self = shift; my($data) = @_; my($status) = unpack("xCxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx", $data); return $self->interp('GrabStatus', $status); }], ['UngrabPointer', sub { my $self = shift; my($time) = @_; $time = 0 if $time eq 'CurrentTime'; return pack "L", $time; }], ['GrabButton', sub { my $self = shift; my($modifiers, $button, $win, $owner_events, $mask, $p_mode, $k_mode, $confine_w, $cursor) = @_; $p_mode = $self->num('SyncMode', $p_mode); $k_mode = $self->num('SyncMode', $k_mode); $confine_w = 0 if $confine_w eq "None"; $cursor = 0 if $cursor eq "None"; $button = 0 if $button eq "AnyButton"; $modifiers = 0x8000 if $modifiers eq "AnyModifier"; return pack("LSCCLLCxS", $win, $mask, $p_mode, $k_mode, $confine_w, $cursor, $button, $modifiers), $owner_events; }], ['UngrabButton', sub { my $self = shift; my($modifiers, $button, $win) = @_; $button = 0 if $button eq "AnyButton"; $modifiers = 0x8000 if $modifiers eq "AnyModifier"; return pack("LSxx", $win, $modifiers), $button; }], ['ChangeActivePointerGrab', sub { my $self = shift; my($mask, $cursor, $time) = @_; $cursor = 0 if $cursor eq "None"; $time = 0 if $time eq "CurrentTime"; return pack "LLSxx", $cursor, $time, $mask; }], ['GrabKeyboard', sub { my $self = shift; my($win, $owner_events, $p_mode, $k_mode, $time) = @_; $time = 0 if $time eq "CurrentTime"; $p_mode = $self->num('SyncMode', $p_mode); $k_mode = $self->num('SyncMode', $k_mode); return pack("LLCCxx", $win, $time, $p_mode, $k_mode), $owner_events; }, sub { my $self = shift; my($data) = @_; my($status) = unpack("xCxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx", $data); return $self->interp('GrabStatus', $status); }], ['UngrabKeyboard', sub { my $self = shift; my($time) = @_; $time = 0 if $time eq "CurrentTime"; return pack("L", $time); }], ['GrabKey', sub { my $self = shift; my($key, $modifiers, $win, $owner_events, $p_mode, $k_mode) = @_; $modifiers = 0x8000 if $modifiers eq "AnyModifier"; $key = 0 if $key eq "AnyKey"; $p_mode = $self->num('SyncMode', $p_mode); $k_mode = $self->num('SyncMode', $k_mode); return pack("LSCCCxxx", $win, $modifiers, $key, $p_mode, $k_mode), $owner_events; }], ['UngrabKey', sub { my $self = shift; my($key, $modifiers, $win) = @_; $key = 0 if $key eq "AnyKey"; $modifiers = 0x8000 if $modifiers eq "AnyModifier"; return pack("LSxx", $win, $modifiers), $key; }], ['AllowEvents', sub { my $self = shift; my($mode, $time) = @_; $mode = $self->num('AllowEventsMode', $mode); $time = 0 if $time eq "CurrentTime"; return pack("L", $time), $mode; }], ['GrabServer', sub { my $self = shift; return ""; }], ['UngrabServer', sub { my $self = shift; return ""; }], ['QueryPointer', sub { my $self = shift; my($window) = @_; return pack "L", $window; }, sub { my $self = shift; my($data) = @_; my($same_s, $root, $child, $root_x, $root_y, $win_x, $win_y, $mask) = unpack "xCxxxxxxLLssssSxxxxxx", $data; $child = 'None' if $child == 0 and $self->{'do_interp'}; return ('same_screen' => $same_s, 'root' => $root, 'child' => $child, 'root_x' => $root_x, 'root_y' => $root_y, 'win_x' => $win_x, 'win_y' => $win_y, 'mask' => $mask); }], ['GetMotionEvents', sub { my $self = shift; my($start, $stop, $win) = @_; $start = 0 if $start eq "CurrentTime"; $stop = 0 if $stop eq "CurrentTime"; return pack "LLL", $win, $start, $stop; }, sub { my $self = shift; my($data) = @_; my($n) = unpack "xxxxxxxxLxxxxxxxxxxxxxxxxxxxx", substr($data, 0, 32); my($events) = substr($data, 32, 8 * $n); my(@ret, $off); for $off (0 .. $n - 1) { push @ret, [unpack "Lss", substr($events, 8 * $off, 8)]; } return @ret; }], ['TranslateCoordinates', sub { my $self = shift; my($src_w, $dest_w, $src_x, $src_y) = @_; return pack "LLss", $src_w, $dest_w, $src_x, $src_y; }, sub { my $self = shift; my($data) = @_; my($same_screen, $child, $dest_x, $dest_y) = unpack "xCxxxxxxLssxxxxxxxxxxxxxxxx", $data; $child = "None" if $child == 0 and $self->{'do_interp'}; return ($same_screen, $child, $dest_x, $dest_y); }], ['WarpPointer', sub { my $self = shift; my($src_w, $dst_w, $src_x, $src_y, $src_width, $src_height, $dst_x, $dst_y) = @_; $src_w = 0 if $src_w eq "None"; $dst_w = 0 if $dst_w eq "None"; return pack("LLssSSss", $src_w, $dst_w, $src_x, $src_y, $src_width, $src_height, $dst_x, $dst_y); }], ['SetInputFocus', sub { my $self = shift; my($focus, $revert_to, $time) = @_; $revert_to = $self->num('InputFocusRevertTo', $revert_to); $focus = 0 if $focus eq "None"; $focus = 1 if $focus eq "ParentRoot"; $time = 0 if $time eq "CurrentTime"; return pack("LL", $focus, $time), $revert_to; }], ['GetInputFocus', sub { my $self = shift; return ""; }, sub { my $self = shift; my($data) = @_; my($revert_to, $focus) = unpack "xCxxxxxxLxxxxxxxxxxxxxxxxxxxx", $data; $revert_to = $self->interp('InputFocusRevertTo', $revert_to); $focus = "None" if $focus == 0 and $self->{'do_interp'}; $focus = "PointerRoot" if $focus == 1 and $self->{'do_interp'}; return ($focus, $revert_to); }], ['QueryKeymap', sub { my $self = shift; return ""; }, sub { my $self = shift; my($data) = @_; return substr($data, 8, 32); }], ['OpenFont', sub { my $self = shift; my($fid, $name) = @_; return pack("LSxx" . padded($name), $fid, length($name), $name); }], ['CloseFont', sub { my $self = shift; my($font) = @_; return pack "L", $font; }], ['QueryFont', sub { my $self = shift; my($font) = @_; return pack "L", $font; }, sub { my $self = shift; my($data) = @_; my($min_bounds) = substr($data, 8, 12); my($max_bounds) = substr($data, 24, 12); my($min_char_or_byte2, $max_char_or_byte2, $default_char, $n, $draw_direction, $min_byte1, $max_byte1, $all_chars_exist, $font_ascent, $font_descent, $m) = unpack("SSSSCCCCssL", substr($data, 40, 20)); my($properties) = substr($data, 60, 8 * $n); my($char_infos) = substr($data, 60 + 8 * $n, 12 * $m); $draw_direction = $self->interp('DrawDirection', $draw_direction); my(%ret) = ('min_char_or_byte2' => $min_char_or_byte2, 'max_char_or_byte2' => $max_char_or_byte2, 'default_char' => $default_char, 'draw_direction' => $draw_direction, 'min_byte1' => $min_byte1, 'max_byte1' => $max_byte1, 'all_chars_exist' => $all_chars_exist, 'font_ascent' => $font_ascent, 'font_descent' => $font_descent); $ret{'min_bounds'} = [unpack("sssssS", $min_bounds)]; $ret{'max_bounds'} = [unpack("sssssS", $max_bounds)]; my($i, @char_infos, %font_props); for $i (0 .. $m - 1) { push @char_infos, [unpack("sssssS", substr($char_infos, 12 * $i, 12))]; } for $i (0 .. $n - 1) { my($atom, $value) = unpack("LL", substr($properties, 8 * $i, 8)); $font_props{$atom} = $value; } $ret{'properties'} = {%font_props}; $ret{'char_infos'} = [@char_infos]; return %ret; }], ['QueryTextExtents', sub { my $self = shift; my($font, $string) = @_; return pack("L" . padded($string), $font, $string), (pad($string) == 2); }, sub { my $self = shift; my($data) = @_; my($draw_direction, $font_a, $font_d, $overall_a, $overall_d, $overall_w, $overall_l, $overall_r) = unpack("xCxxxxxxsssslllxxxx", $data); $draw_direction = $self->interp('DrawDirection', $draw_direction); return ('draw_direction' => $draw_direction, 'font_ascent' => $font_a, 'font_descent' => $font_d, 'overall_ascent' => $overall_a, 'overall_descent' => $overall_d, 'overall_width' => $overall_w, 'overall_left' => $overall_l, 'overall_right' => $overall_r); }], ['ListFonts', sub { my $self = shift; my($pat, $max) = @_; return pack("SS" . padded($pat), $max, length($pat), $pat); }, sub { my $self = shift; my($data) = @_; my($n) = unpack("xxxxxxxxSxxxxxxxxxxxxxxxxxxxxxx", substr($data, 0, 32)); my($list) = substr($data, 32); my(@ret, $offset, $len, $i); $offset = 0; while ($i++ < $n) { $len = unpack("C", substr($list, $offset, 1)); push @ret, substr($list, $offset + 1, $len); $offset += $len + 1; } return @ret; }], ['ListFontsWithInfo', sub { my $self = shift; my($pat, $max) = @_; return pack("SS" . padded($pat), $max, length($pat), $pat); }, sub { my $self = shift; my($data) = @_; my($n) = unpack("C", substr($data, 1, 1)); return () if $n == 0; my($min_bounds) = substr($data, 8, 12); my($max_bounds) = substr($data, 24, 12); my($min_char_or_byte2, $max_char_or_byte2, $default_char, $m, $draw_direction, $min_byte1, $max_byte1, $all_chars_exist, $font_ascent, $font_descent) = unpack("SSSSCCCCssxxxx", substr($data, 40, 20)); my($properties) = substr($data, 60, 8 * $m); my($name) = substr($data, 60 + 8 * $m, $n); $draw_direction = $self->interp('DrawDirection', $draw_direction); my(%ret) = ('min_char_or_byte2' => $min_char_or_byte2, 'max_char_or_byte2' => $max_char_or_byte2, 'default_char' => $default_char, 'draw_direction' => $draw_direction, 'min_byte1' => $min_byte1, 'max_byte1' => $max_byte1, 'all_chars_exist' => $all_chars_exist, 'font_ascent' => $font_ascent, 'font_descent' => $font_descent, 'name' => $name); $ret{'min_bounds'} = [unpack("sssssS", $min_bounds)]; $ret{'max_bounds'} = [unpack("sssssS", $max_bounds)]; my($i, %font_props); for $i (0 .. $m - 1) { my($atom, $value) = unpack("LL", substr($properties, 8 * $i, 8)); $font_props{$atom} = $value; } $ret{'properties'} = {%font_props}; return %ret; }, 'HASH'], ['SetFontPath', sub { my $self = shift; my(@dirs) = @_; my($n, $d, $path); for $d (@dirs) { $d = pack("C", length $d) . $d; $n++; } $path = join("", @dirs); return pack("Sxx" . padded($path), $n, $path); }], ['GetFontPath', sub { my $self = shift; return ""; }, sub { my $self = shift; my($data) = @_; my($n) = unpack("xxxxxxxxSxxxxxxxxxxxxxxxxxxxxxx", substr($data, 0, 32)); my($list) = substr($data, 32); my(@ret, $offset, $len, $i); $offset = 0; while ($i++ < $n) { $len = unpack("C", substr($list, $offset, 1)); push @ret, substr($list, $offset + 1, $len); $offset += $len + 1; } return @ret; }], ['CreatePixmap', sub { my $self = shift; my($pixmap, $drawable, $depth, $w, $h) = @_; return pack("LLSS", $pixmap, $drawable, $w, $h), $depth; }], ['FreePixmap', sub { my $self = shift; my($pixmap) = @_; return pack "L", $pixmap; }], ['CreateGC', sub { my $self = shift; my($gc, $drawable, %values) = @_; my($i, $mask, @values); $mask = 0; for $i (0 .. $#GC_ValueMask) { if (exists $values{$GC_ValueMask[$i][0]}) { $mask |= (1 << $i); push @values, &{$GC_ValueMask[$i][1]}($self, $values{$GC_ValueMask[$i][0]}); delete $values{$GC_ValueMask[$i][0]}; } } croak "Invalid GC components: ", join(",", keys %values), "\n" if %values; return pack("LLL", $gc, $drawable, $mask) . join("", @values); }], ['ChangeGC', sub { my $self = shift; my($gc, %values) = @_; my($i, $mask, @values); $mask = 0; for $i (0 .. $#GC_ValueMask) { if (exists $values{$GC_ValueMask[$i][0]}) { $mask |= (1 << $i); push @values, &{$GC_ValueMask[$i][1]}($self, $values{$GC_ValueMask[$i][0]}); } } return pack("LL", $gc, $mask) . join("", @values); }], ['CopyGC', sub { my $self = shift; my($src, $dst, @values) = @_; my(%values, $i, $mask); $mask = 0; @values{@values} = (1) x @values; for $i (0 .. $#GC_ValueMask) { $mask |= (1 << $i) if exists $values{$GC_ValueMask[$i][0]}; } return pack "LLL", $src, $dst, $mask; }], ['SetDashes', sub { my $self = shift; my($gc, $offset, @dashes) = @_; my($dash_list) = pack("C*", @dashes); my($n) = length $dash_list; return pack("LSS" . padded($dash_list), $gc, $offset, $n, $dash_list); }], ['SetClipRectangles', sub { my $self = shift; my($gc, $clip_x_o, $clip_y_o, $ordering, @rects) = @_; $ordering = $self->num('ClipRectangleOrdering', $ordering); my($x); for $x (@rects) { $x = pack("ssSS", @$x); } return pack("Lss", $gc, $clip_x_o, $clip_y_o) . join("", @rects), $ordering; }], ['FreeGC', sub { my $self = shift; my($gc) = @_; return pack "L", $gc; }], ['ClearArea', sub { my $self = shift; my($win, $x, $y, $w, $h, $exposures) = @_; return pack("LssSS", $win, $x, $y, $w, $h), $exposures; }], ['CopyArea', sub { my $self = shift; my($src_d, $dst_d, $gc, $src_x, $src_y, $w, $h, $dst_x, $dst_y) = @_; return pack("LLLssssSS", $src_d, $dst_d, $gc, $src_x, $src_y, $dst_x, $dst_y, $w, $h); }], ['CopyPlane', sub { my $self = shift; my($src_d, $dst_d, $gc, $src_x, $src_y, $w, $h, $dst_x, $dst_y, $plane) = @_; return pack("LLLssssSSL", $src_d, $dst_d, $gc, $src_x, $src_y, $dst_x, $dst_y, $w, $h, $plane); }], ['PolyPoint', sub { my $self = shift; my($drawable, $gc, $coord_mode, @points) = @_; $coord_mode = $self->num('CoordinateMode', $coord_mode); return pack("LLs*", $drawable, $gc, @points), $coord_mode; }], ['PolyLine', sub { my $self = shift; my($drawable, $gc, $coord_mode, @points) = @_; $coord_mode = $self->num('CoordinateMode', $coord_mode); return pack("LLs*", $drawable, $gc, @points), $coord_mode; }], ['PolySegment', sub { my $self = shift; my($drawable, $gc, @points) = @_; return pack("LLs*", $drawable, $gc, @points); }], ['PolyRectangle', sub { my $self = shift; my($drawable, $gc, @rects) = @_; my($rr); for $rr (@rects) { $rr = pack("ssSS", @$rr); } return pack("LL", $drawable, $gc) . join("", @rects); }], ['PolyArc', sub { my $self = shift; my($drawable, $gc, @arcs) = @_; my($ar); for $ar (@arcs) { $ar = pack("ssSSss", @$ar); } return pack("LL", $drawable, $gc) . join("", @arcs); }], ['FillPoly', sub { my $self = shift; my($drawable, $gc, $shape, $coord_mode, @points) = @_; $shape = $self->num('PolyShape', $shape); $coord_mode = $self->num('CoordinateMode', $coord_mode); return pack("LLCCxxs*", $drawable, $gc, $shape, $coord_mode, @points); }], ['PolyFillRectangle', sub { my $self = shift; my($drawable, $gc, @rects) = @_; my($rr); for $rr (@rects) { $rr = pack("ssSS", @$rr); } return pack("LL", $drawable, $gc) . join("", @rects); }], ['PolyFillArc', sub { my $self = shift; my($drawable, $gc, @arcs) = @_; my($ar); for $ar (@arcs) { $ar = pack("ssSSss", @$ar); } return pack("LL", $drawable, $gc) . join("", @arcs); }], ['PutImage', sub { my $self = shift; my($drawable, $gc, $depth, $w, $h, $x, $y, $left_pad, $format, $data) = @_; $format = $self->num('ImageFormat', $format); return pack("LLSSssCCxx" . padded($data), $drawable, $gc, $w, $h, $x, $y, $left_pad, $depth, $data), $format; }], ['GetImage', sub { my $self = shift; my($drawable, $x, $y, $w, $h, $mask, $format) = @_; $format = $self->num('ImageFormat', $format); croak "GetImage() format must be (XY|Z)Pixmap" if $format == 0; return pack("LssSSL", $drawable, $x, $y, $w, $h, $mask), $format; }, sub { my $self = shift; my($data) = @_; my($depth, $visual) = unpack("xCxxxxxxLxxxxxxxxxxxxxxxxxxxx", substr($data, 0, 32)); return ($depth, $visual, substr($data, 32)); }], ['PolyText8', sub { my $self = shift; my($drawable, $gc, $x, $y, @items) = @_; my(@i, $ir, @item, $n, $r, $items); for $ir (@items) { if (not ref $ir) { push @i, pack("CN", 255, $ir); } else { @item = @$ir; $n = 0; $r = length($item[1]); while ($r > 0) { if ($r >= 254) { push @i, pack("Cc", 254, 0) . substr($item[1], $n, 254); $n += 254; $r -= 254; } else { push @i, pack("Cc", $r, $item[0]) . substr($item[1], $n); $n += $r; # Superfluous $r = 0; # $r -= $r would be more symmetrical } } } } $items = join("", @i); return pack("LLss" . padded($items), $drawable, $gc, $x, $y, $items); }], ['PolyText16', sub { my $self = shift; my($drawable, $gc, $x, $y, @items) = @_; my(@i, $ir, @item, $n, $r, $items); for $ir (@items) { if (not ref $ir) { push @i, pack("CN", 255, $ir); } else { @item = @$ir; $n = 0; $r = length($item[1]); while ($r > 0) { if ($r >= 508) { push @i, pack("Cc", 254, 0) . substr($item[1], $n, 508); $n += 508; $r -= 508; } else { push @i, pack("Cc", $r / 2, $item[0]) . substr($item[1], $n); $n += $r; # Unnecessary $r = 0; # $r -= $r would be more symmetrical } } } } $items = join("", @i); return pack("LLss" . padded($items), $drawable, $gc, $x, $y, $items); }], ['ImageText8', sub { my $self = shift; my($drawable, $gc, $x, $y, $str) = @_; return pack("LLss" . padded($str), $drawable, $gc, $x, $y, $str), length($str); }], ['ImageText16', sub { my $self = shift; my($drawable, $gc, $x, $y, $str) = @_; return pack("LLss" . padded($str), $drawable, $gc, $x, $y, $str), length($str)/2; }], ['CreateColormap', sub { my $self = shift; my($mid, $visual, $win, $alloc) = @_; $alloc = 0 if $alloc eq "None"; $alloc = 1 if $alloc eq "All"; return pack("LLL", $mid, $win, $visual), $alloc; }], ['FreeColormap', sub { my $self = shift; my($cmap) = @_; return pack("L", $cmap); }], ['CopyColormapAndFree', sub { my $self = shift; my($mid, $src) = @_; return pack("LL", $mid, $src); }], ['InstallColormap', sub { my $self = shift; my($cmap) = @_; return pack("L", $cmap); }], ['UninstallColormap', sub { my $self = shift; my($cmap) = @_; return pack("L", $cmap); }], ['ListInstalledColormaps', sub { my $self = shift; my($win) = @_; return pack("L", $win); }, sub { my $self = shift; my($data) = @_; return unpack("L*", substr($data, 32)); }], ['AllocColor', sub { my $self = shift; my($cmap, $r, $g, $b) = @_; return pack("LSSSxx", $cmap, $r, $g, $b); }, sub { my $self = shift; my($data) = @_; my($r, $g, $b, $pixel) = unpack("xxxxxxxxSSSxxLxxxxxxxxxxxx", $data); return ($pixel, $r, $g, $b); }], ['AllocNamedColor', sub { my $self = shift; my($cmap, $name) = @_; return pack("LSxx" . padded($name), $cmap, length($name), $name); }, sub { my $self = shift; my($data) = @_; return unpack("xxxxxxxxLSSSSSSxxxxxxxx", $data); }], ['AllocColorCells', sub { my $self = shift; my($cmap, $colors, $planes, $contig) = @_; return pack("LSS", $cmap, $colors, $planes), $contig; }, sub { my $self = shift; my($data) = @_; my($n,$m) = unpack("xxxxxxxxSSxxxxxxxxxxxxxxxxxxxx",substr($data, 0, 32)); return ([unpack("L*", substr($data, 32, 4 * $n))], [unpack("L*", substr($data, 32 + 4 * $n, 4 * $m))]); }], ['AllocColorPlanes', sub { my $self = shift; my($cmap, $colors, $reds, $greens, $blues, $contig) = @_; return pack("LSSSS", $cmap, $colors, $reds, $greens, $blues), $contig; }, sub { my $self = shift; my($data) = @_; my($n, $r_mask, $g_mask, $b_mask) = unpack("xxxxxxxxSxxLLLxxxxxxxx", substr($data, 0, 32)); return ($r_mask, $g_mask, $b_mask, unpack("L*", substr($data, 32, 4*$n))); }], ['FreeColors', sub { my $self = shift; my($cmap, $mask, @pixels) = @_; return pack("LLL*", $cmap, $mask, @pixels); }], ['StoreColors', sub { my $self = shift; my($cmap, @actions) = @_; my($l, @l); for $l (@actions) { @l = @$l; if (@l == 4) { $l = pack("LSSSCx", @l, 7); } elsif (@l == 5) { $l = pack("LSSSCx", @l); } else { croak "Wrong # of items in arg to StoreColors"; } } return pack("L", $cmap) . join("", @actions); }], ['StoreNamedColor', sub { my $self = shift; my($cmap, $pixel, $name, $do) = @_; return pack("LLSxx" . padded($name), $cmap, $pixel, length($name), $name), $do; }], ['QueryColors', sub { my $self = shift; my($cmap, @pixels) = @_; return pack("LL*", $cmap, @pixels); }, sub { my $self = shift; my($data) = @_; my($n) = unpack("xxxxxxxxSxxxxxxxxxxxxxxxxxxxxxx", substr($data, 0, 32)); my($i, @colors); for $i (0 .. $n - 1) { push @colors, [unpack("SSSxx", substr($data, 32 + 8 * $i, 8))]; } return @colors; }], ['LookupColor', sub { my $self = shift; my($cmap, $name) = @_; return pack("LSxx" . padded($name), $cmap, length($name), $name); }, sub { my $self = shift; my($data) = @_; return unpack("xxxxxxxxSSSSSSxxxxxxxxxxxx", $data); }], ['CreateCursor', sub { my $self = shift; my($cid, $src, $mask, $fr, $fg, $fb, $br, $bg, $bb, $x, $y) = @_; $mask = 0 if $mask eq "None"; return pack("LLLSSSSSSSS", $cid, $src, $mask, $fr, $fg, $fb, $br, $bg, $bb, $x, $y); }], ['CreateGlyphCursor', sub { my $self = shift; my($cid, $src_fnt, $mask_fnt, $src_ch, $mask_ch, $fr, $fg, $fb, $br, $bg, $bb) = @_; $mask_fnt = 0 if $mask_fnt eq "None"; return pack("LLLSSSSSSSS", $cid, $src_fnt, $mask_fnt, $src_ch, $mask_ch, $fr, $fg, $fb, $br, $bg, $bb); }], ['FreeCursor', sub { my $self = shift; my($cursor) = @_; return pack("L", $cursor); }], ['RecolorCursor', sub { my $self = shift; my($cursor, $fr, $fg, $fb, $br, $bg, $bb) = @_; return pack("LSSSSSS", $cursor, $fr, $fg, $fb, $br, $bg, $bb); }], ['QueryBestSize', sub { my $self = shift; my($class, $drawable, $w, $h) = @_; $class = $self->num('SizeClass', $class); return pack("LSS", $drawable, $w, $h), $class; }, sub { my $self = shift; my($data) = @_; my($w, $h) = unpack("xxxxxxxxSSxxxxxxxxxxxxxxxxxxxx", $data); return ($w, $h); }], ['QueryExtension', sub { my $self = shift; my($name) = @_; return pack("Sxx" . padded($name), length($name), $name); }, sub { my $self = shift; my($data) = @_; my($present, $major, $event, $error) = unpack("xxxxxxxxCCCCxxxxxxxxxxxxxxxxxxxx", $data); return () unless $present; return ($major, $event, $error); }], ['ListExtensions', sub { my $self = shift; return ""; }, sub { my $self = shift; my($data) = @_; my($num) = unpack("xCxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx", substr($data, 0, 32)); my($list) = substr($data, 32); my(@ret, $offset, $len, $i); $offset = 0; while ($i++ < $num) { $len = unpack("C", substr($list, $offset, 1)); push @ret, substr($list, $offset + 1, $len); $offset += $len + 1; } return @ret; }], ['ChangeKeyboardMapping', sub { my $self = shift; my($first, $m, @info) = @_; my($ar); for $ar (@info) { $ar = pack("L$m", @{$ar}[0 .. $m - 1]); } return pack("CCxx", $first, $m) . join("", @info), scalar(@info); }], ['GetKeyboardMapping', sub { my $self = shift; my($first, $count) = @_; return pack("CCxx", $first, $count); }, sub { my $self = shift; my($data) = @_; my($n,$l) = unpack("xCxxLxxxxxxxxxxxxxxxxxxxxxxxx", substr($data, 0, 32)); my(@ret, $i); for $i (0 .. $l/$n - 1) { push @ret, [unpack("L$n", substr($data, 32 + $i * $n * 4))]; } return @ret; }], ['ChangeKeyboardControl', sub { my $self = shift; my(%values) = @_; my($mask, $i, @values); $mask = 0; for $i (0 .. 7) { if (exists $values{$KeyboardControl_ValueMask[$i][0]}) { $mask |= (1 << $i); push @values, &{$KeyboardControl_ValueMask[$i][1]} ($self, $values{$KeyboardControl_ValueMask[$i][0]}); } } return pack("L", $mask). join "", @values; }], ['GetKeyboardControl', sub { my $self = shift; return ""; }, sub { my $self = shift; my($data) = @_; my($global_auto_repeat, $led_mask, $key_click_percent, $bell_percent, $bell_pitch, $bell_duration) = unpack("xCxxxxxxLCCSSxx", substr($data, 0, 20)); my($auto_repeats) = substr($data, 20, 32); return ('global_auto_repeat' => $self->interp('LedMode', $global_auto_repeat), 'led_mask' => $led_mask, 'key_click_percent' => $key_click_percent, 'bell_percent' => $bell_percent, 'bell_pitch' => $bell_pitch, 'bell_duration' => $bell_duration, 'auto_repeats' => $auto_repeats); }], ['Bell', sub { my $self = shift; my($percent) = @_; return "", unpack("C", pack("c", $percent)); # Ick }], ['ChangePointerControl', sub { my $self = shift; my($do_accel, $do_thresh, $num, $denom, $thresh) = @_; return pack("sssCC", $num, $denom, $thresh, $do_accel, $do_thresh); }], ['GetPointerControl', sub { my $self = shift; return ""; }, sub { my $self = shift; my($data) = @_; my($num, $deno, $thresh) = unpack("xxxxxxxxSSSxxxxxxxxxxxxxxxxxx", $data); return ($num, $deno, $thresh); }], ['SetScreenSaver', sub { my $self = shift; my($timeout, $interval, $pref_blank, $exposures) = @_; $pref_blank = $self->num('ScreenSaver', $pref_blank); $exposures = $self->num('ScreenSaver', $exposures); return pack("ssCCxx", $timeout, $interval, $pref_blank, $exposures); }], ['GetScreenSaver', sub { my $self = shift; return ""; }, sub { my $self = shift; my($data) = @_; my($timeout, $interval, $pref_blank, $exposures) = unpack("xxxxxxxxSSCCxxxxxxxxxxxxxxxxxx", $data); $pref_blank = $self->interp('ScreenSaver', $pref_blank); $exposures = $self->interp('ScreenSaver', $exposures); return ($timeout, $interval, $pref_blank, $exposures); }], ['ChangeHosts', sub { my $self = shift; my($mode, $family, $address) = @_; $mode = $self->num('HostChangeMode', $mode); $family = $self->num('HostFamily', $family); return pack("CxS" . padded($address), $family, length($address), $address), $mode; }], ['ListHosts', sub { my $self = shift; return ""; }, sub { my $self = shift; my($data) = @_; my($mode, $n) = unpack("xCxxxxxxSxxxxxxxxxxxxxxxxxxxxxx", substr($data, 0, 32)); $mode = $self->interp('AccessMode', $mode); my(@ret, $fam, $off, $l); $off = 32; while ($n-- > 0) { ($fam, $l) = unpack("CxS", substr($data, $off, 4)); $fam = $self->interp('HostFamily', $fam); push @ret, [$fam, substr($data, $off + 4, $l)]; $off += 4 + $l + padding($l); } return ($mode, @ret); }], ['SetAccessControl', sub { my $self = shift; my($mode) = @_; $mode = $self->num('AccessMode', $mode); return "", $mode; }], ['SetCloseDownMode', sub { my $self = shift; my($mode) = @_; $mode = $self->num('CloseDownMode', $mode); return "", $mode; }], ['KillClient', sub { my $self = shift; my($rsrc) = @_; $rsrc = 0 if $rsrc eq "AllTemporary"; return pack("L", $rsrc); }], ['RotateProperties', sub { my $self = shift; my($win, $delta, @atoms) = @_; return pack("LSsL*", $win, scalar(@atoms), $delta, @atoms); }], ['ForceScreenSaver', sub { my $self = shift; my($mode) = @_; $mode = $self->num('ScreenSaverAction', $mode); return "", $mode; }], ['SetPointerMapping', sub { my $self = shift; my(@map) = @_; my($map) = pack("C*", @map); return pack(padded($map), $map), length($map); }, sub { my $self = shift; my($data) = @_; my($status) = unpack("xCxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx", $data); $status = $self->interp('MappingChangeStatus', $status); return $status; }], ['GetPointerMapping', sub { my $self = shift; return ""; }, sub { my $self = shift; my($data) = @_; my($n) = unpack("xCxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx", substr($data, 0, 32)); return unpack("C*", substr($data, 32, $n)); }], ['SetModifierMapping', sub { my $self = shift; my(@keycodes) = @_; my($n) = scalar(@{$keycodes[0]}); my($kr); for $kr (@keycodes) { $kr = pack("C$n", @$kr, (0) x (@$kr - $n)); } return join("", @keycodes), $n; }, sub { my $self = shift; my($data) = @_; my($status) = unpack("xCxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx", $data); return $self->interp('MappingChangeStatus', $status); }], ['GetModifierMapping', sub { my $self = shift; return ""; }, sub { my $self = shift; my($data) = @_; my($n) = unpack("xCxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx", substr($data, 0, 32)); my(@ret, $i); for $i (0 .. 7) { push @ret, [unpack("C$n", substr($data, 32 + $n * $i))]; } return @ret; }], 0, 0, 0, 0, 0, 0, 0, ['NoOperation', sub { my $self = shift; my($len) = @_; $len = 1 unless defined $len; return "\0" x (($len - 1) * 4); }]); my($i); for $i (0 .. 127) { if (ref $Requests[$i] and $Requests[$i][0]) { $Const{'Request'}[$i] = $Requests[$i][0]; } else { $Const{'Request'}[$i] = ""; } } sub get_request { my $self = shift; my($name) = @_; my($major, $minor); $major = $self->num('Request', $name); if ($major =~ /^\d+$/) { # Core request return ($self->{'requests'}[$major], $major); } else { # Extension request croak "Unknown request `$name'" unless exists $self->{'ext_request_num'}{$name}; ($major, $minor) = @{$self->{'ext_request_num'}{$name}}; croak "Unknown request `$name'" if int($major) == 0; return ($self->{'ext_request'}{$major}[$minor], $major, $minor); } } sub assemble_request { my $self = shift; my($op, $args, $major, $minor) = (@_, 0); my($data); ($data, $minor) = (&{$op->[1]}($self, @$args), $minor); $minor = 0 unless defined $minor; my($len) = (length($data) / 4) + 1; croak "Request too long!\n" if $len > $self->{'maximum_request_length'}; if ($len <= 65535) { return pack("CCS", $major, $minor, $len) . $data; } else { croak "Can't happen" unless $self->{'ext'}{'BIG_REQUESTS'}; return pack("CCSL", $major, $minor, 0, $len) . $data; } } sub req { my $self = shift; my($name, @args) = @_; my($op, $major, $minor) = $self->get_request($name); if (@$op == 2) { # No reply $self->give($self->assemble_request($op, \@args, $major, $minor)); $self->next_sequence(); } elsif (@$op == 3) { # One reply my($seq, $data); $self->give($self->assemble_request($op, \@args, $major, $minor)); $seq = $self->next_sequence(); $self->add_reply($seq & 0xffff, \$data); $self->handle_input_for($seq & 0xffff); $self->delete_reply($seq & 0xffff); return &{$op->[2]}($self, $data); } elsif (@$op == 4) { # Many replies my($seq, $data, @stuff, @ret); $self->give($self->assemble_request($op, \@args, $major, $minor)); $seq = $self->next_sequence(); $self->add_reply($seq & 0xffff, \$data); for (;;) { $data = 0; $self->handle_input_for($seq & 0xffff); @stuff = &{$op->[2]}($self, $data); last unless @stuff; if ($op->[3] eq "ARRAY") { push @ret, [@stuff]; } elsif ($op->[3] eq "HASH") { push @ret, {@stuff}; } else { push @ret, @stuff; } } $self->delete_reply($seq & 0xffff); return @ret; } else { croak "Can't handle request $name"; } } sub robust_req { my $self = shift; my($name, @args) = @_; my($op, $major, $minor) = $self->get_request($name); # Luckily, ListFontsWithInfo can't cause any errors return [$self->req($name, @args)] if @$op == 4; my $err_data; local($self->{'error_handler'}) = sub { $err_data = $_[1]; }; my($seq, $data); $self->give($self->assemble_request($op, \@args, $major, $minor)); $seq = $self->next_sequence() & 0xffff; if (@$op == 2) { # No real reply, but fake up a request with a reply so we can # tell how long to wait before knowing the real request # succeeded my($fake_op, $fake_major) = $self->get_request("GetScreenSaver"); $self->give($self->assemble_request($fake_op, [], $fake_major, 0)); $seq = $self->next_sequence() & 0xffff; } $self->add_reply($seq, \$data); for (;;) { my $stat = $self->handle_input(); if ($stat == $seq) { $self->delete_reply($seq); if (@$op == 3) { return [&{$op->[2]}($self, $data)]; } else { return []; } } elsif ($stat == -1 && $self->{'error_seq'} == $seq) { my($type, undef, $info, $minor_op, $major_op) = unpack("xCSLSCxxxxxxxxxxxxxxxxxxxxx", $err_data); return($self->interp('Error', $type), $major_op, $minor_op, $info); } } } sub send { my $self = shift; my($name, @args) = @_; my($op, $major, $minor) = $self->get_request($name); $self->give($self->assemble_request($op, \@args, $major, $minor)); return $self->next_sequence(); } sub unpack_reply { my $self = shift; my($name, $data) = @_; my($op) = $self->get_request($name); return &{$op->[2]}($self, $data); } sub request { my $self = shift; $self->req(@_); } sub atom_name { my $self = shift; my($num) = @_; if ($self->{'atom_names'}->[$num]) { return $self->{'atom_names'}->[$num]; } else { my($name) = $self->req('GetAtomName', $num); $self->{'atom_names'}->[$num] = $name; return $name; } } sub atom { my $self = shift; my($name) = @_; if (exists $self->{'atoms'}{$name}) { return $self->{'atoms'}{$name}; } else { my($atom) = $self->req('InternAtom', $name, 0); $self->{'atoms'}{$name} = $atom; return $atom; } } sub choose_screen { my $self = shift; my($screen) = @_; my($k); for $k (keys %{$self->{'screens'}[$screen]}) { $self->{$k} = $self->{'screens'}[$screen]{$k}; } } sub init_extension { my $self = shift; my($name) = @_; my($major, $event, $error) = $self->req('QueryExtension', $name) or return 0; $name =~ tr/-/_/; unless (defined eval { require("X11/Protocol/Ext/$name.pm") }) { return 0 if substr($@, 0, 30) eq "Can't locate X11/Protocol/Ext/"; croak($@); } my($pkg) = "X11::Protocol::Ext::$name"; my $obj = $pkg->new($self, $major, $event, $error); return 0 if not $obj; $self->{'ext'}{$name} = [$major, $event, $error, $obj]; } sub init_extensions { my $self = shift; my($ext); for $ext ($self->req('ListExtensions')) { $self->init_extension($ext); } } sub new_rsrc { my $self = shift; if ($self->{'rsrc_id'} == $self->{'rsrc_max'} + 1) { if (exists $self->{'ext'}{'XC_MISC'}) { my($start, $count) = $self->req('XCMiscGetXIDRange'); $self->{'rsrc_shift'} = 0; $self->{'rsrc_id'} = 0; $self->{'rsrc_base'} = $start; $self->{'rsrc_max'} = $count - 1; #print "Got $start $count\n"; } else { croak "Out of resource IDs, and we don't have XC_MISC"; } } my $ret = ($self->{'rsrc_id'}++ << $self->{'rsrc_shift'}) + $self->{'rsrc_base'}; return $ret; } sub new { my($class) = shift; my($host, $dispnum, $screen); my($conn, $display, $family); if (@_ == 0 or $_[0] eq '') { if ($main::ENV{'DISPLAY'}) { $display = $main::ENV{'DISPLAY'}; } else { carp "Can't find DISPLAY -- guessing `$Default_Display:0'"; $display = "$Default_Display:0"; } } else { if (ref $_[0]) { $conn = $_[0]; } else { $display = $_[0]; } } unless ($conn) { $display =~ /^(?:[^:]*?\/)?(.*):(\d+)(?:.(\d+))?$/ or croak "Invalid display: `$display'\n"; $host = $Default_Display unless $host = $1; $dispnum = $2; $screen = 0 unless $screen = $3; if ($] >= 5.00301) { # IO::Socket is bundled if ($host eq 'unix') { require 'X11/Protocol/Connection/UNIXSocket.pm'; $conn = X11::Protocol::Connection::UNIXSocket ->open($host, $dispnum); $host = 'localhost'; $family = 'Local'; } else { require 'X11/Protocol/Connection/INETSocket.pm'; $conn = X11::Protocol::Connection::INETSocket ->open($host, $dispnum); $family = 'Internet'; } } else { # Use FileHandle if ($host eq 'unix') { require 'X11/Protocol/Connection/UNIXFH.pm'; $conn = X11::Protocol::Connection::UNIXFH ->open($host, $dispnum); $host = 'localhost'; $family = 'Local'; } else { require 'X11/Protocol/Connection/INETFH.pm'; $conn = X11::Protocol::Connection::INETFH ->open($host, $dispnum); $family = 'Internet'; } } } my $self = {}; bless $self, $class; $self->{'connection'} = $conn; $self->{'byte_order'} = $Byte_Order; $self->{'protocol_major_version'} = 11; $self->{'protocol_minor_version'} = 0; $self->{'const'} = \%Const; $self->{'const_num'} = \%Const_num; $self->{'authorization_protocol_name'} = ''; $self->{'authorization_protocol_data'} = ''; my($auth); if (ref($_[1]) eq "ARRAY") { ($self->{'authorization_protocol_name'}, $self->{'authorization_protocol_data'}) = @{$_[1]}; } elsif ($display and eval {require X11::Auth}) { $auth = X11::Auth->new() and ($self->{'authorization_protocol_name'}, $self->{'authorization_protocol_data'}) = ($auth->get_by_host($host, $family, $dispnum), "", ""); } $self->give(pack("A2 SSSS xx" . padded($self->{'authorization_protocol_name'}) . padded($self->{'authorization_protocol_data'}), $self->{'byte_order'}, $self->{'protocol_major_version'}, $self->{'protocol_minor_version'}, length($self->{'authorization_protocol_name'}), length($self->{'authorization_protocol_data'}), $self->{'authorization_protocol_name'}, $self->{'authorization_protocol_data'})); $self->flush; my($ret) = ord($self->get(1)); if ($ret == 0) { my($len, $major, $minor, $xlen) = unpack("CSSS", $self->get(7)); my($reason) = $self->get($xlen * 4); croak("Connection to server failed -- (version $major.$minor)\n", substr($reason, 0, $len)); } elsif ($ret == 2) { croak("FIXME: authentication required\n"); } elsif ($ret == 1) { my($major, $minor, $xlen) = unpack('xSSS', $self->get(7)); ($self->{'release_number'}, $self->{'resource_id_base'}, $self->{'resource_id_mask'}, $self->{'motion_buffer_size'}, my($vlen), $self->{'maximum_request_length'}, my($screens), my($formats), $self->{'image_byte_order'}, $self->{'bitmap_bit_order'}, $self->{'bitmap_scanline_unit'}, $self->{'bitmap_scanline_pad'}, $self->{'min_keycode'}, $self->{'max_keycode'}) = unpack('LLLLSSCCCCCCCCxxxx', $self->get(32)); $self->{'bitmap_bit_order'} = $self->interp('Significance', $self->{'bitmap_bit_order'}); $self->{'image_byte_order'} = $self->interp('Significance', $self->{'image_byte_order'}); $self->{'vendor'} = substr($self->get($vlen + padding $vlen), 0, $vlen); $self->{'rsrc_shift'} = 0; my $mask = $self->{'resource_id_mask'}; $self->{'rsrc_shift'}++ until ($mask >> $self->{'rsrc_shift'}) & 1; $self->{'rsrc_id'} = 0; $self->{'rsrc_base'} = $self->{'resource_id_base'}; $self->{'rsrc_max'} = $mask; my($fmts) = $self->get(8 * $formats); my($n, $fmt); for $n (0 .. $formats - 1) { $fmt = substr($fmts, 8 * $n, 8); my($depth, $bpp, $pad) = unpack('CCC', $fmt); $self->{'pixmap_formats'}{$depth} = {'bits_per_pixel' => $bpp, 'scanline_pad' => $pad}; } my(@screens); while ($screens--) { my($root_wid, $def_cmap, $w_pixel, $b_pixel, $input_masks, $w_p, $h_p, $w_mm, $h_mm, $min_maps, $max_maps, $root_visual, $b_store, $s_unders, $depth, $n_depths) = unpack('LLLLLSSSSSSLCCCC', $self->get(40)); my(%s) = ('root' => $root_wid, 'width_in_pixels' => $w_p, 'height_in_pixels' => $h_p, 'width_in_millimeters' => $w_mm, 'height_in_millimeters' => $h_mm, 'root_depth' => $depth, 'root_visual' => $root_visual, 'default_colormap' => $def_cmap, 'white_pixel' => $w_pixel, 'black_pixel' => $b_pixel, 'min_installed_maps' => $min_maps, 'max_installed_maps' => $max_maps, 'backing_stores' => $self->interp('BackingStore', $b_store), 'save_unders' => $s_unders, 'current_input_masks' => $input_masks); my($nd, @depths) = (); for $nd (1 .. $n_depths) { my($dep, $n_visuals) = unpack('CxSxxxx', $self->get(8)); my($nv, %vt, @visuals) = (); for $nv (1 .. $n_visuals) { my($vid, $class, $bits_per_rgb, $map_ent, $red_mask, $green_mask, $blue_mask) = unpack('LCCSLLLxxxx', $self->get(24)); $class = $self->interp('VisualClass', $class); %vt = ('visual_id' => $vid, 'class' => $class, 'red_mask' => $red_mask, 'green_mask' => $green_mask, 'blue_mask' => $blue_mask, 'bits_per_rgb_value' => $bits_per_rgb, 'colormap_entries', => $map_ent); push @visuals, {%vt}; delete $vt{'visual_id'}; $self->{'visuals'}{$vid} = {%vt, 'depth' => $dep}; } push @depths, {'depth' => $dep, 'visuals' => [@visuals]}; } $s{'allowed_depths'} = [@depths]; push @screens, {%s}; } $self->{'screens'} = [@screens]; $self->{'sequence_num'} = 1; $self->{'error_handler'} = \&default_error_handler; $self->{'event_handler'} = sub {}; $self->{'requests'} = \@Requests; $self->{'events'} = \@Events; # 1 = uses rsrc/atom id field $self->{'error_type'} = [undef, 0, 1, 1, 1, 1, 1, 1, 0, 1, 0, 0, 1, 1, 1, 0, 0, 0]; $self->choose_screen($screen) if defined($screen) and $screen <= $#{$self->{'screens'}}; $self->{'do_interp'} = 1; } else { croak("Unknown response"); } $self->init_extension("XC-MISC"); return $self; } sub AUTOLOAD { my($name) = $AUTOLOAD; $name =~ s/^.*:://; return if $name eq "DESTROY"; # Avoid problems during final cleanup if ($name =~ /^[A-Z]/) { # Protocol request my($obj) = shift; # Make this faster next time no strict 'refs'; # This is slightly icky my($op, $major, $minor) = $obj->get_request($name); if (@$op == 2) { # No reply *{$AUTOLOAD} = sub { my $self = shift; $self->give($self->assemble_request($op, \@_, $major, $minor)); $self->next_sequence(); }; } elsif (@$op == 3) { # One reply *{$AUTOLOAD} = sub { my $self = shift; my($seq, $data); $self->give($self->assemble_request($op, \@_, $major, $minor)); $seq = $self->next_sequence(); $self->add_reply($seq & 0xffff, \$data); $self->handle_input_for($seq & 0xffff); $self->delete_reply($seq & 0xffff); return &{$op->[2]}($self, $data); }; } else { # ListFontsWithInfo # Not worth it } return $obj->req($name, @_); } else { # Instance variable if (@_ == 1) { return $_[0]->{$name}; } elsif (@_ == 2) { $_[0]->{$name} = $_[1]; } else { croak "No such function `$name'"; } } } 1; __END__ =head1 NAME X11::Protocol - Perl module for the X Window System Protocol, version 11 =head1 SYNOPSIS use X11::Protocol; $x = X11::Protocol->new(); $win = $x->new_rsrc; $x->CreateWindow($win, $x->root, 'InputOutput', $x->root_depth, 'CopyFromParent', ($x_coord, $y_coord), $width, $height, $border_w); ... =head1 DESCRIPTION X11::Protocol is a client-side interface to the X11 Protocol (see X(1) for information about X11), allowing perl programs to display windows and graphics on X11 servers. A full description of the protocol is beyond the scope of this documentation; for complete information, see the I, available as Postscript or *roff source from C, or I of O'Reilly & Associates's series of books about X (ISBN 1-56592-083-X, C), which contains most of the same information. =head1 DISCLAIMER ``The protocol contains many management mechanisms that are not intended for normal applications. Not all mechanisms are needed to build a particular user interface. It is important to keep in mind that the protocol is intended to provide mechanism, not policy.'' -- Robert W. Scheifler =head1 BASIC METHODS =head2 new $x = X11::Protocol->new(); $x = X11::Protocol->new($display_name); $x = X11::Protocol->new($connection); $x = X11::Protocol->new($display_name, [$auth_type, $auth_data]); $x = X11::Protocol->new($connection, [$auth_type, $auth_data]); Open a connection to a server. $display_name should be an X display name, of the form 'host:display_num.screen_num'; if no arguments are supplied, the contents of the DISPLAY environment variable are used. Alternatively, a pre-opened connection, of one of the X11::Protocol::Connection classes (see L, L, L, L, L, L, L) can be given. The authorization data is obtained using X11::Auth or the second argument. If the display is specified by $display_name, rather than $connection, a choose_screen() is also performed, defaulting to screen 0 if the '.screen_num' of the display name is not present. Returns the new protocol object. =head2 new_rsrc $x->new_rsrc; Returns a new resource identifier. A unique resource ID is required for every object that the server creates on behalf of the client: windows, fonts, cursors, etc. (IDs are chosen by the client instead of the server for efficiency -- the client doesn't have to wait for the server to acknowledge the creation before starting to use the object). Note that the total number of available resource IDs, while large, is finite. Beginning from the establishment of a connection, resource IDs are allocated sequentially from a range whose size is server dependent (commonly 2**21, about 2 million). If this limit is reached and the server does not support the XC_MISC extension, subsequent calls to new_rsrc will croak. If the server does support this extension, the module will attempt to request a new range of free IDs from the server. This should allow the program to continue, but it is an imperfect solution, as over time the set of available IDs may fragment, requiring increasingly frequent round-trip range requests from the server. For long-running programs, the best approach may be to keep track of free IDs as resources are destroyed. In the current version, however, no special support is provided for this. =head2 handle_input $x->handle_input; Get one chunk of information from the server, and do something with it. If it's an error, handle it using the protocol object's handler ('error_handler' -- default is kill the program with an explanatory message). If it's an event, pass it to the chosen event handler, or put it in a queue if the handler is 'queue'. If it's a reply to a request, save using the object's 'replies' hash for further processing. =head2 atom_name $name = $x->atom_name($atom); Return the string corresponding to the atom $atom. This is similar to the GetAtomName request, but caches the result for efficiency. =head2 atom $atom = $x->atom($name); The inverse operation; Return the (numeric) atom corresponding to $name. This is similar to the InternAtom request, but caches the result. =head2 choose_screen $x->choose_screen($screen_num); Indicate that you prefer to use a particular screen of the display. Per-screen information, such as 'root', 'width_in_pixels', and 'white_pixel' will be made available as $x->{'root'} instead of $x->{'screens'}[$screen_num]{'root'} =head1 SYMBOLIC CONSTANTS Generally, symbolic constants used by the protocol, like 'CopyFromParent' or 'PieSlice' are passed to methods as strings, and converted into numbers by the module. Their names are the same as those in the protocol specification, including capitalization, but with hyphens ('-') changed to underscores ('_') to look more perl-ish. If you want to do the conversion yourself for some reason, the following methods are available: =head2 num $num = $x->num($type, $str) Given a string representing a constant and a string specifying what type of constant it is, return the corresponding number. $type should be a name like 'VisualClass' or 'GCLineStyle'. If the name is not recognized, it is returned intact. =head2 interp $name = $x->interp($type, $num) The inverse operation; given a number and string specifying its type, return a string representing the constant. You can disable interp() and the module's internal interpretation of numbers by setting $x->{'do_interp'} to zero. Of course, this isn't very useful, unless you have you own definitions for all the constants. Here is a list of available constant types: AccessMode, AllowEventsMode, AutoRepeatMode, BackingStore, BitGravity, Bool, ChangePropertyMode, CirculateDirection, CirculatePlace, Class, ClipRectangleOrdering, CloseDownMode, ColormapNotifyState, CoordinateMode, CrossingNotifyDetail, CrossingNotifyMode, DeviceEvent, DrawDirection, Error, EventMask, Events, FocusDetail, FocusMode, GCArcMode, GCCapStyle, GCFillRule, GCFillStyle, GCFunction, GCJoinStyle, GCLineStyle, GCSubwindowMode, GrabStatus, HostChangeMode, HostFamily, ImageFormat, InputFocusRevertTo, KeyMask, LedMode, MapState, MappingChangeStatus, MappingNotifyRequest, PointerEvent, PolyShape, PropertyNotifyState, Request, ScreenSaver, ScreenSaverAction, Significance, SizeClass, StackMode, SyncMode, VisibilityState, VisualClass, WinGravity =head1 SERVER INFORMATION At connection time, the server sends a large amount of information about itself to the client. This information is stored in the protocol object for future reference. It can be read directly, like $x->{'release_number'} or, for object oriented True Believers, using a method: $x->release_number The method method also has a one argument form for setting variables, but it isn't really useful for some of the more complex structures. Here is an example of what the object's information might look like: 'connection' => X11::Connection::UNIXSocket(0x814526fd), 'byte_order' => 'l', 'protocol_major_version' => 11, 'protocol_minor_version' => 0, 'authorization_protocol_name' => 'MIT-MAGIC-COOKIE-1', 'release_number' => 3110, 'resource_id_base' => 0x1c000002, 'motion_buffer_size' => 0, 'maximum_request_length' => 65535, # units of 4 bytes 'image_byte_order' => 'LeastSiginificant', 'bitmap_bit_order' => 'LeastSiginificant', 'bitmap_scanline_unit' => 32, 'bitmap_scanline_pad' => 32, 'min_keycode' => 8, 'max_keycode' => 134, 'vendor' => 'The XFree86 Project, Inc', 'pixmap_formats' => {1 => {'bits_per_pixel' => 1, 'scanline_pad' => 32}, 8 => {'bits_per_pixel' => 8, 'scanline_pad' => 32}}, 'screens' => [{'root' => 43, 'width_in_pixels' => 800, 'height_in_pixels' => 600, 'width_in_millimeters' => 271, 'height_in_millimeters' => 203, 'root_depth' => 8, 'root_visual' => 34, 'default_colormap' => 33, 'white_pixel' => 0, 'black_pixel' => 1, 'min_installed_maps' => 1, 'max_installed_maps' => 1, 'backing_stores' => 'Always', 'save_unders' => 1, 'current_input_masks' => 0x58003d, 'allowed_depths' => [{'depth' => 1, 'visuals' => []}, {'depth' => 8, 'visuals' => [ {'visual_id' => 34, 'blue_mask' => 0, 'green_mask' => 0, 'red_mask' => 0, 'class' => 'PseudoColor', 'bits_per_rgb_value' => 6, 'colormap_entries' => 256}, {'visual_id' => 35, 'blue_mask' => 0xc0, 'green_mask' => 0x38, 'red_mask' => 0x7, 'class' => 'DirectColor', 'bits_per_rgb_value' => 6, 'colormap_entries' => 8}, ...]}]], 'visuals' => {34 => {'depth' => 8, 'class' => 'PseudoColor', 'red_mask' => 0, 'green_mask' => 0, 'blue_mask'=> 0, 'bits_per_rgb_value' => 6, 'colormap_entries' => 256}, 35 => {'depth' => 8, 'class' => 'DirectColor', 'red_mask' => 0x7, 'green_mask' => 0x38, 'blue_mask'=> 0xc0, 'bits_per_rgb_value' => 6, 'colormap_entries' => 8}, ...} 'error_handler' => &\X11::Protocol::default_error_handler, 'event_handler' => sub {}, 'do_interp' => 1 =head1 REQUESTS =head2 request $x->request('CreateWindow', ...); $x->req('CreateWindow', ...); $x->CreateWindow(...); Send a protocol request to the server, and get the reply, if any. For names of and information about individual requests, see below and/or the protocol reference manual. =head2 robust_req $x->robust_req('CreateWindow', ...); Like request(), but if the server returns an error, return the error information rather than calling the error handler (which by default just croaks). If the request succeeds, returns an array reference containing whatever request() would have. Otherwise, returns the error type, the major and minor opcodes of the failed request, and the extra error information, if any. Note that even if the request normally wouldn't have a reply, this method still has to wait for a round-trip time to see whether an error occurred. If you're concerned about performance, you should design your error handling to be asynchronous. =head2 add_reply $x->add_reply($sequence_num, \$var); Add a stub for an expected reply to the object's 'replies' hash. When a reply numbered $sequence_num comes, it will be stored in $var. =head2 delete_reply $x->delete_reply($sequence_num); Delete the entry in 'replies' for the specified reply. (This should be done after the reply is received). =head2 send $x->send('CreateWindow', ...); Send a request, but do not wait for a reply. You must handle the reply, if any, yourself, using add_reply(), handle_input(), delete_reply(), and unpack_reply(), generally in that order. =head2 unpack_reply $x->unpack_reply('GetWindowAttributes', $data); Interpret the raw reply data $data, according to the reply format for the named request. Returns data in the same format as C. This section includes only a short calling summary for each request; for full descriptions, see the protocol standard. Argument order is usually the same as listed in the spec, but you generally don't have to pass lengths of strings or arrays, since perl keeps track. Symbolic constants are generally passed as strings. Most replies are returned as lists, but when there are many values, a hash is used. Lists usually come last; when there is more than one, each is passed by reference. In lists of multi-part structures, each element is a list ref. Parenthesis are inserted in arg lists for clarity, but are optional. Requests are listed in order by major opcode, so related requests are usually close together. Replies follow the '=>'. $x->CreateWindow($wid, $parent, $class, $depth, $visual, ($x, $y), $width, $height, $border_width, 'attribute' => $value, ...) $x->ChangeWindowAttributes($window, 'attribute' => $value, ...) $x->GetWindowAttributes($window) => ('backing_store' => $backing_store, ...) This is an example of a return value that is meant to be assigned to a hash. $x->DestroyWindow($win) $x->DestroySubwindows($win) $x->ChangeSaveSet($window, $mode) $x->ReparentWindow($win, $parent, ($x, $y)) $x->MapWindow($win) $x->MapSubwindows($win) $x->UnmapWindow($win) $x->UnmapSubwindows($win) $x->ConfigureWindow($win, 'attribute' => $value, ...) $x->CirculateWindow($win, $direction) Note that this request actually circulates the subwindows of $win, not the window itself. $x->GetGeometry($drawable) => ('root' => $root, ...) $x->QueryTree($win) => ($root, $parent, @kids) $x->InternAtom($name, $only_if_exists) => $atom $x->GetAtomName($atom) => $name $x->ChangeProperty($window, $property, $type, $format, $mode, $data) $x->DeleteProperty($win, $atom) $x->GetProperty($window, $property, $type, $offset, $length, $delete) => ($value, $type, $format, $bytes_after) Notice that the value comes first, so you can easily ignore the rest. $x->ListProperties($window) => (@atoms) $x->SetSelectionOwner($selection, $owner, $time) $x->GetSelectionOwner($selection) => $owner $x->ConvertSelection($selection, $target, $property, $requestor, $time) $x->SendEvent($destination, $propagate, $event_mask, $event) The $event argument should be the result of a pack_event() (see L<"EVENTS">) $x->GrabPointer($grab_window, $owner_events, $event_mask, $pointer_mode, $keyboard_mode, $confine_to, $cursor, $time) => $status $x->UngrabPointer($time) $x->GrabButton($modifiers, $button, $grab_window, $owner_events, $event_mask, $pointer_mode, $keyboard_mode, $confine_to, $cursor) $x->UngrabButton($modifiers, $button, $grab_window) $x->ChangeActivePointerGrab($event_mask, $cursor, $time) $x->GrabKeyboard($grab_window, $owner_events, $pointer_mode, $keyboard_mode, $time) => $status $x->UngrabKeyboard($time) $x->GrabKey($key, $modifiers, $grab_window, $owner_events, $pointer_mode, $keyboard_mode) $x->UngrabKey($key, $modifiers, $grab_window) $x->AllowEvents($mode, $time) $x->GrabServer $x->UngrabServer $x->QueryPointer($window) => ('root' => $root, ...) $x->GetMotionEvents($start, $stop, $window) => ([$time, ($x, $y)], [$time, ($x, $y)], ...) $x->TranslateCoordinates($src_window, $dst_window, $src_x, $src_y) => ($same_screen, $child, $dst_x, $dst_y) $x->WarpPointer($src_window, $dst_window, $src_x, $src_y, $src_width, $src_height, $dst_x, $dst_y) $x->SetInputFocus($focus, $revert_to, $time) $x->GetInputFocus => ($focus, $revert_to) $x->QueryKeymap => $keys $keys is a bit vector, so you should use vec() to read it. $x->OpenFont($fid, $name) $x->CloseFont($font) $x->QueryFont($font) => ('min_char_or_byte2' => $min_char_or_byte2, ..., 'min_bounds' => [$left_side_bearing, $right_side_bearing, $character_width, $ascent, $descent, $attributes], ..., 'char_infos' => [[$left_side_bearing, $right_side_bearing, $character_width, $ascent, $descent, $attributes], ...], 'properties' => {$prop => $value, ...} ) $x->QueryTextExtents($font, $string) => ('draw_direction' => $draw_direction, ...) $x->ListFonts($pattern, $max_names) => @names $x->ListFontsWithInfo($pattern, $max_names) => ({'name' => $name, ...}, {'name' => $name, ...}, ...) The information in each hash is the same as the the information returned by QueryFont, but without per-character size information. This request is special in that it is the only request that can have more than one reply. This means you should probably only use request() with it, not send(), as the reply counting is complicated. Luckily, you never need this request anyway, as its function is completely duplicated by other requests. $x->SetFontPath(@strings) $x->GetFontPath => @strings $x->CreatePixmap($pixmap, $drawable, $depth, $width, $height) $x->FreePixmap($pixmap) $x->CreateGC($cid, $drawable, 'attribute' => $value, ...) $x->ChangeGC($gc, 'attribute' => $value, ...) $x->CopyGC($src, $dest, 'attribute', 'attribute', ...) $x->SetDashes($gc, $dash_offset, (@dashes)) $x->SetClipRectangles($gc, ($clip_x_origin, $clip_y_origin), $ordering, [$x, $y, $width, $height], ...) $x->ClearArea($window, ($x, $y), $width, $height, $exposures) $x->CopyArea($src_drawable, $dst_drawable, $gc, ($src_x, $src_y), $width, $height, ($dst_x, $dst_y)) $x->CopyPlane($src_drawable, $dst_drawable, $gc, ($src_x, $src_y), $width, $height, ($dst_x, $dst_y), $bit_plane) $x->PolyPoint($drawable, $gc, $coordinate_mode, ($x, $y), ($x, $y), ...) $x->PolyLine($drawable, $gc, $coordinate_mode, ($x, $y), ($x, $y), ...) $x->PolySegment($drawable, $gc, ($x, $y) => ($x, $y), ($x, $y) => ($x, $y), ...) $x->PolyRectangle($drawable, $gc, [($x, $y), $width, $height], ...) $x->PolyArc($drawable, $gc, [($x, $y), $width, $height, $angle1, $angle2], ...) $x->FillPoly($drawable, $gc, $shape, $coordinate_mode, ($x, $y), ...) $x->PolyFillRectangle($drawable, $gc, [($x, $y), $width, $height], ...) $x->PolyFillArc($drawable, $gc, [($x, $y), $width, $height, $angle1, $angle2], ...) $x->PutImage($drawable, $gc, $depth, $width, $height, ($dst_x, $dst_y), $left_pad, $format, $data) Currently, the module has no code to handle the various bitmap formats that the server might specify. Therefore, this request will not work portably without a lot of work. $x->GetImage($drawable, ($x, $y), $width, $height, $plane_mask, $format) $x->PolyText8($drawable, $gc, ($x, $y), ($font OR [$delta, $string]), ...) $x->PolyText16($drawable, $gc, ($x, $y), ($font OR [$delta, $string]), ...) $x->ImageText8($drawable, $gc, ($x, $y), $string) $x->ImageText16($drawable, $gc, ($x, $y), $string) $x->CreateColormap($mid, $visual, $window, $alloc) $x->FreeColormap($cmap) $x->CopyColormapAndFree($mid, $src_cmap) $x->InstallColormap($cmap) $x->UninstallColormap($cmap) $x->ListInstalledColormaps($window) => @cmaps $x->AllocColor($cmap, ($red, $green, $blue)) => ($pixel, ($red, $green, $blue)) $x->AllocNamedColor($cmap, $name) => ($pixel, ($exact_red, $exact_green, $exact_blue), ($visual_red, $visual_green, $visual_blue)) $x->AllocColorCells($cmap, $colors, $planes, $contiguous) => ([@pixels], [@masks]) $x->AllocColorPlanes($cmap, $colors, ($reds, $greens, $blues), $contiguous) => (($red_mask, $green_mask, $blue_mask), @pixels) $x->FreeColors($cmap, $plane_mask, @pixels) $x->StoreColors($cmap, [$pixel, $red, $green, $blue, $do_mask], ...) The 1, 2, and 4 bits in $do_mask are do-red, do-green, and do-blue. $do_mask can be omitted, defaulting to 7, the usual case -- change the whole color. $x->StoreNamedColor($cmap, $pixel, $name, $do_mask) $do_mask has the same interpretation as above, but is mandatory. $x->QueryColors($cmap, @pixels) => ([$red, $green, $blue], ...) $x->LookupColor($cmap, $name) => (($exact_red, $exact_green, $exact_blue), ($visual_red, $visual_green, $visual_blue)) $x->CreateCursor($cid, $source, $mask, ($fore_red, $fore_green, $fore_blue), ($back_red, $back_green, $back_blue), ($x, $y)) $x->CreateGlyphCursor($cid, $source_font, $mask_font, $source_char, $mask_char, ($fore_red, $fore_green, $fore_blue), ($back_red, $back_green, $back_blue)) $x->FreeCursor($cursor) $x->RecolorCursor($cursor, ($fore_red, $fore_green, $fore_blue), ($back_red, $back_green, $back_blue)) $x->QueryBestSize($class, $drawable, $width, $height) => ($width, $height) $x->QueryExtension($name) => ($major_opcode, $first_event, $first_error) If the extension is not present, an empty list is returned. $x->ListExtensions => (@names) $x->ChangeKeyboardMapping($first_keycode, $keysysms_per_keycode, @keysyms) $x->GetKeyboardMapping($first_keycode, $count) => ($keysysms_per_keycode, [$keysym, ...], [$keysym, ...], ...) $x->ChangeKeyboardControl('attribute' => $value, ...) $x->GetKeyboardControl => ('global_auto_repeat' => $global_auto_repeat, ...) $x->Bell($percent) $x->ChangePointerControl($do_acceleration, $do_threshold, $acceleration_numerator, $acceleration_denominator, $threshold) $x->GetPointerControl => ($acceleration_numerator, $acceleration_denominator, $threshold) $x->SetScreenSaver($timeout, $interval, $prefer_blanking, $allow_exposures) $x->GetScreenSaver => ($timeout, $interval, $prefer_blanking, $allow_exposures) $x->ChangeHosts($mode, $host_family, $host_address) $x->ListHosts => ($mode, [$family, $host], ...) $x->SetAccessControl($mode) $x->SetCloseDownMode($mode) $x->KillClient($resource) $x->RotateProperties($win, $delta, @props) $x->ForceScreenSaver($mode) $x->SetPointerMapping(@map) => $status $x->GetPointerMapping => @map $x->SetModifierMapping(@keycodes) => $status $x->GetModiferMapping => @keycodes $x->NoOperation($length) $length specifies the length of the entire useless request, in four byte units, and is optional. =head1 EVENTS To receive events, first set the 'event_mask' attribute on a window to indicate what types of events you desire (see L<"pack_event_mask">). Then, set the protocol object's 'event_handler' to a subroutine reference that will handle the events. Alternatively, set 'event_handler' to 'queue', and retrieve events using dequeue_event() or next_event(). In both cases, events are returned as a hash. For instance, a typical MotionNotify event might look like this: %event = ('name' => 'MotionNotify', 'sequence_number' => 12, 'state' => 0, 'event' => 58720256, 'root' => 43, 'child' => None, 'same_screen' => 1, 'time' => 966080746, 'detail' => 'Normal', 'event_x' => 10, 'event_y' => 3, 'code' => 6, 'root_x' => 319, 'root_y' => 235) =head2 pack_event_mask $mask = $x->pack_event_mask('ButtonPress', 'KeyPress', 'Exposure'); Make an event mask (suitable as the 'event_mask' of a window) from a list of strings specifying event types. =head2 unpack_event_mask @event_types = $x->unpack_event_mask($mask); The inverse operation; convert an event mask obtained from the server into a list of names of event categories. =head2 dequeue_event %event = $x->dequeue_event; If there is an event waiting in the queue, return it. =head2 next_event %event = $x->next_event; Like Xlib's XNextEvent(), this function is equivalent to $x->handle_input until %event = dequeue_event; =head2 pack_event $data = $x->pack_event(%event); Given an event in hash form, pack it into a string. This is only useful as an argument to SendEvent(). =head2 unpack_event %event = $x->unpack_event($data); The inverse operation; given the raw data for an event (32 bytes), unpack it into hash form. Normally, this is done automatically. =head1 EXTENSIONS Protocol extensions add new requests, event types, and error types to the protocol. Support for them is compartmentalized in modules in the X11::Protocol::Ext:: hierarchy. For an example, see L. You can tell if the module has loaded an extension by looking at $x->{'ext'}{$extension_name} If the extension has been initialized, this value will be an array reference, [$major_request_number, $first_event_number, $first_error_number, $obj], where $obj is an object containing information private to the extension. =head2 init_extension $x->init_extension($name); Initialize an extension: query the server to find the extension's request number, then load the corresponding module. Returns 0 if the server does not support the named extension, or if no module to interface with it exists. =head2 init_extensions $x->init_extensions; Initialize protocol extensions. This does a ListExtensions request, then calls init_extension() for each extension that the server supports. =head1 WRITING EXTENSIONS Internally, the X11::Protocol module is table driven. All an extension has to do is to add new add entries to the protocol object's tables. An extension module should C, and should define an new() method X11::Protocol::Ext::NAME ->new($x, $request_num, $event_num, $error_num) where $x is the protocol object and $request_num, $event_num and $error_num are the values returned by QueryExtension(). The new() method should add new types of constant like $x->{'ext_const'}{'ConstantType'} = ['Constant', 'Constant', ...] and set up the corresponding name to number translation hashes like $x->{'ext_const_num'}{'ConstantType'} = {make_num_hash($x->{'ext_const'}{'ConstantType'})} Event names go in $x->{'ext_const'}{'Events'}[$event_number] while specifications for event contents go in $x->{'ext_event'}[$event_number] each element of which is either C<[\&unpack_sub, \&pack_sub]> or C<[$pack_format, $field, $field, ...]>, where each $field is C<'name'>, C<['name', 'const_type']>, or C<['name', ['special_name_for_zero', 'special_name_for_one']]>, where C<'special_name_for_one'> is optional. Finally, $x->{'ext_request'}{$major_request_number} should be an array of arrays, with each array either C<[$name, \&packit]> or C<[$name, \&packit, \&unpackit]>, and $x->{'ext_request_num'}{$request_name} should be initialized with C<[$minor_num, $major_num]> for each request the extension defines. For examples of code that does all of this, look at X11::Protocol::Ext::SHAPE. X11::Protocol exports several functions that might be useful in extensions (note that these are I methods). =head2 padding $p = padding $x; Given an integer, compute the number need to round it up to a multiple of 4. For instance, C is 3. =head2 pad $p = pad $str; Given a string, return the number of extra bytes needed to make a multiple of 4. Equivalent to C. =head2 padded $data = pack(padded($str), $str); Return a format string, suitable for pack(), for a string padded to a multiple of 4 bytes. For instance, C gives C<"Hello\0\0\0">. =head2 hexi $str = hexi $n; Format a number in hexidecimal, and add a "0x" to the front. =head2 make_num_hash %hash = make_num_hash(['A', 'B', 'C']); Given a reference to a list of strings, return a hash mapping the strings onto numbers representing their position in the list, as used by C<$x-E{'ext_const_num'}>. =head1 BUGS This module is too big (~2500 lines), too slow (10 sec to load on a slow machine), too inefficient (request args are copied several times), and takes up too much memory (3000K for basicwin). If you have more than 65535 replies outstanding at once, sequence numbers can collide. The protocol is too complex. =head1 AUTHOR Stephen McCamant . =head1 SEE ALSO L, L, L, L, L, L, L, L, L, I, I, I. =cut X11-Protocol-0.56/eg/0000755000175000017500000000000010512256531012643 5ustar smccsmccX11-Protocol-0.56/eg/widgets1.pl0000644000175000017500000005461410512254402014734 0ustar smccsmcc#!/usr/bin/perl use X11::Protocol; use X11::Protocol::Constants qw(Exposure_m ButtonPress_m ButtonRelease_m ButtonMotion_m PointerMotionHint_m StructureNotify_m Expose ButtonPress ButtonRelease MotionNotify ClientMessage ConfigureNotify Convex Nonconvex InputOutput CopyFromParent Replace Origin); use IO::Select; use strict; sub clamp { $_[1] < $_[0] ? $_[0] : $_[1] > $_[2] ? $_[2] : $_[1] } sub sign { $_[0] ? $_[0] / abs($_[0]) : 0 } sub min { $_[0] <= $_[1] ? $_[0] : $_[1] } sub max { $_[0] >= $_[1] ? $_[0] : $_[1] } # Look and feel parameters to play with: my $length = 300; my $thumb = 100; my $thickness = 20; my $padding = 5; my $depth = 2; my $relief_frac = .1; # relief area / thickness, 0 => relief doesn't scale my $trough_rgb = [0xa3a3, 0xa3a3, 0xb3b3]; my $bg_rgb = [0xc6c6, 0xc6c6, 0xd6d6]; my $fill_rgb = [0xb6b6, 0x3030, 0x6060]; my $shade = .5; # 0 => shadows black, hilights white; 1 => no shading # for relief, 0 => raised, 1 => sunk, 2 => ridge, 3 => groove my $prog_relief = 1; my $sbar_relief = 1; my $slider_relief = 0; my $arrow_relief = 0; my $dimple_relief = 1; my $arrow_change = 1; # these bits will flip when pressed my $dimple = .3; # size / scrollbar thickness, 0 for none my $font_frac = .6; # text fills 60% of the height of the progresss bar # Note that the progress bar prefers scalable fonts, so that it can keep # the same proportions when the window is resized. Depending on how modern # your X installation is, this may be nontrivial. # * The best case is if you have a font that includes both hand-edited # bitmaps for small sizes and outlines that can be scaled arbitrarily. # All recent X releases come with bitmaps provided by Adobe for Helvetica, # so if you also have a corresponding Type 1 outline, that's the best # choice: # (bitmaps for sizes 8, 10, 11, 12, 14, 17, 18, 20, 24, 25, and 34) #my $fontname = "-adobe-helvetica-medium-r-normal--%d-*-*-*-*-*-iso8859-1"; # (If you're using Debian Linux like me, you'll need to install the # gsfonts and gsfonts-x11 packages to get the Type 1 versions. The # outline isn't the genuine Adobe version; it's a free clone that # can also be accessed directly (without Adobe's bitmaps) as) my $fontname = "-urw-nimbus sans l-regular-r-normal--%d-*-*-*-*-*-iso8859-1"; # * Recent X releases also include some scalable fonts, though not any # sans-serif ones. In the following, adobe-utopia can be replaced by # adobe-courier, bitstream-courier, or bitstream-charter: #my $fontname = "-adobe-utopia-medium-r-normal--%d-*-*-*-*-*-iso8859-1"; # * Also, recent X servers can scale bitmaps, though the results are usually # fairly ugly. # * If your X system predates XLFD (the 14-hyphen names), your font # selection is probably pretty miniscule; try to pick something around # 12 pixels: #my $fontname = "7x13"; my $cursor_id = 132; my $initial_delay = 0.15; # secs my $delay = 0.05; # secs my $accel = 0.5; my $smooth_progress = 0; # and un-smooth scrollbar my $text_shading_style = 1; # 0 => diagonalish, 1 => squarish # +--------------------------------------------------+ # | main_win ^v padding [bg] | # | +----------------------------------------------+ | # | |#prog_win########### ^ |<| # | |##########[fill]#### :thickness |>| # | |#################### : |:| # | |<-------- length -----------:---------------->|:| # | |#################### V [trough] |:| # | +----------------------------------------------+:| # | ^v padding :| # | +----------------------------------------------+:| # | | sbar_win +------------------------+ |:| # |<| |+----+ slider_win +----+| [trough] |:| # |>|<-slider->|| <| |<-lt_win | |> || |:| # |:| pos |+----+ rt_win->+----+| |:| # |:| +------------------------+ |:| # |:+----------:------------------------:----------+:| # |: : ^v padding : :| # +:-----------:------------------------:-----------:+ # : : : : # : : : : # padding :<------- thumb -------->: padding my($main_win, $prog_win, $sbar_win, $slider_win, $lt_win, $rt_win); my($trough_gc, $bg_gc, $fill_gc, $hilite_gc, $shadow_gc); my $frac = 0; my $X = X11::Protocol->new; my $cmap = $X->default_colormap; my($bg,) = $X->AllocColor($cmap, (@$bg_rgb)); my($trough,) = $X->AllocColor($cmap, (@$trough_rgb)); my($shadow,) = $X->AllocColor($cmap, (map($_ * $shade, @$bg_rgb))); my($hilite,) = $X->AllocColor($cmap, (map(65535 - $shade * (65535 - $_), @$bg_rgb))); my $delete_atom = $X->atom('WM_DELETE_WINDOW'); my $fontsize = $font_frac * $thickness; my $font = $X->new_rsrc; $X->OpenFont($font, sprintf($fontname, $fontsize)); my $total_wd = 2*$padding + $length; my $base_wd = 2*$padding + 2*$depth + 4; my $total_ht = 3*$padding + 2*$thickness; my $base_ht = 3*$padding + 4*$depth + 3; my $cursor_font = $X->new_rsrc; $X->OpenFont($cursor_font, "cursor"); my $cursor = $X->new_rsrc; $X->CreateGlyphCursor($cursor, $cursor_font, $cursor_font, $cursor_id, $cursor_id + 1, (0, 0, 0), (65535, 65535, 65535)); $main_win = $X->new_rsrc; $X->CreateWindow($main_win, $X->root, InputOutput, CopyFromParent, CopyFromParent, (0, 0), $total_wd, $total_ht, 0, 'cursor' => $cursor, 'background_pixel' => $bg, 'event_mask' => StructureNotify_m); $X->ChangeProperty($main_win, $X->atom('WM_ICON_NAME'), $X->atom('STRING'), 8, Replace, "widgets"); $X->ChangeProperty($main_win, $X->atom('WM_NAME'), $X->atom('STRING'), 8, Replace, "Raw X widgets (X11::Protocol)"); $X->ChangeProperty($main_win, $X->atom('WM_CLASS'), $X->atom('STRING'), 8, Replace, "widgets\0Widgets"); $X->ChangeProperty($main_win, $X->atom('WM_NORMAL_HINTS'), $X->atom('WM_SIZE_HINTS'), 32, Replace, pack("Lx16llx16llllllx4", 8|16|128|256, $base_wd, $base_ht, 3, 2, 1000, 1, $base_wd, $base_ht)); $X->ChangeProperty($main_win, $X->atom('WM_HINTS'), $X->atom('WM_HINTS'), 32, Replace, pack("LLLx24", 1|2, 1, 1)); $X->ChangeProperty($main_win, $X->atom('WM_PROTOCOLS'), $X->atom('ATOM'), 32, Replace, pack("L", $delete_atom)); $prog_win = $X->new_rsrc; $X->CreateWindow($prog_win, $main_win, InputOutput, CopyFromParent, CopyFromParent, ($padding, $padding), $length, $thickness, 0, 'background_pixel' => $trough, 'event_mask' => Exposure_m); $sbar_win = $X->new_rsrc; $X->CreateWindow($sbar_win, $main_win, InputOutput, CopyFromParent, CopyFromParent, ($padding, 2*$padding + $thickness), $length, $thickness, 0, 'background_pixel' => $trough, 'event_mask' => Exposure_m); $bg_gc = $X->new_rsrc; $X->CreateGC($bg_gc, $main_win, 'foreground' => $bg); $shadow_gc = $X->new_rsrc; $X->CreateGC($shadow_gc, $main_win, 'foreground' => $shadow); $hilite_gc = $X->new_rsrc; $X->CreateGC($hilite_gc, $main_win, 'foreground' => $hilite); # floor : ceil :: int : away sub away { sign($_[0]) * int(abs($_[0]) + .9999) } sub draw_slope_poly { my($win, $relief, $dep, $fill, @p) = @_; if ($relief > 1) { draw_slope_poly($win, $relief ^ 3, $dep, $fill, @p); $relief &= 1; $dep /= 2; $fill = 0; } my($tl, $br) = ($hilite_gc, $shadow_gc)[$relief, !$relief]; my(@gc, @ip); $#gc = $#ip = $#p; my $j; for $j (-2 .. $#p - 2) { my($ix, $iy) = ($p[$j+1][0] - $p[$j][0], $p[$j+1][1] - $p[$j][1]); $gc[$j] = $ix > $iy ? $tl : $ix < $iy ? $br : $ix > 0 ? $tl : $br; my($ox, $oy) = ($p[$j+2][0] - $p[$j+1][0], $p[$j+2][1] - $p[$j+1][1]); if ($ix*$oy > $iy*$ox) { $ix = -$ix; $iy = -$iy; } else { $ox = -$ox; $oy = -$oy; } my($in) = sqrt($ix*$ix + $iy*$iy); $ix /= $in; $iy /= $in; my($on) = sqrt($ox*$ox + $oy*$oy); $ox /= $on; $oy /= $on; my($mx, $my) = (($ix + $ox)/2, ($iy + $oy)/2); my($mn) = max(abs($mx), abs($my)); $mx /= $mn; $my /= $mn; $ip[$j+1][0] = $p[$j+1][0] + away(($dep - 1) * $mx); $ip[$j+1][1] = $p[$j+1][1] + away(($dep - 1) * $my); } $X->FillPoly($win, $fill, Nonconvex, Origin, map(@{$ip[$_]}, 0 .. $#p)) if $fill; for $j (-1 .. $#p - 1) { $X->FillPoly($win, $gc[$j], Convex, Origin, @{$p[$j]}, @{$ip[$j]}, @{$ip[$j + 1]}, @{$p[$j + 1]}); $X->PolySegment($win, $gc[$j], @{$p[$j]} => @{$p[$j+1]}, @{$ip[$j]} => @{$ip[$j+1]}); } for $j (-1 .. $#p - 1) { $X->PolySegment($win, $bg_gc, @{$p[$j+1]}, @{$ip[$j+1]}) if $gc[$j] != $gc[$j + 1]; } } sub draw_slope { my($win, $x, $y, $wd, $ht, $relief) = @_; draw_slope_poly($win, $relief, $depth, 0, [$x, $y], [$x + $wd - 1, $y], [$x + $wd - 1, $y + $ht - 1], [$x, $y + $ht - 1]); } sub paint_arrow { my($win, $x, $y, $s, $dir, $relief) = @_; my @s = ($s / 2, $s, $s / 2, 0); my @p = ([$x + $s[$dir], $y + $s[$dir - 1]], ($dir & 1 xor $dir & 2) ? [$x, $y] : [$x + $s, $y + $s], ($dir & 2) ? [$x + $s, $y] : [$x, $y + $s]); @p[1,2] = @p[2,1] if $dir & 1; draw_slope_poly($win, $relief, $depth, $bg_gc, @p); } sub paint_slope_circle { my($win, $x, $y, $s, $dep, $relief) = @_; my($tl, $br) = ($hilite_gc, $shadow_gc)[$relief & 1, !($relief & 1)]; my @outer = ($x, $y, $s, $s); my @inner = ($x + $dep, $y + $dep, $s - 2*$dep, $s - 2*$dep); my @tl = (35*64, 160*64); my @br = (215*64, 160*64); $X->PolyFillArc($win, $bg_gc, [@outer, 0, 360*64]); $X->PolyFillArc($win, $tl, [@outer, @tl]); $X->PolyArc($win, $tl, [@outer, @tl], [@inner, @tl]); $X->PolyFillArc($win, $br, [@outer, @br]); $X->PolyArc($win, $br, [@outer, @br], [@inner, @br]); if ($relief & 2) { my @middle = ($x + $depth/2, $y + $depth/2, $s - $depth, $s - $depth); $X->PolyFillArc($win, $br, [@middle, @tl]); $X->PolyFillArc($win, $tl, [@middle, @br]); } $X->PolyFillArc($win, $bg_gc, [@inner, 0, 360*64]); } my $inner_thick = $thickness - 2 * $depth; my $slider_pos = $depth; my $pos_min = $depth; my $pos_max = $length - $thumb - $depth - 2 * $inner_thick; $slider_win = $X->new_rsrc; $X->CreateWindow($slider_win, $sbar_win, InputOutput, CopyFromParent, CopyFromParent, ($slider_pos, $depth), $thumb + 2 * $inner_thick, $inner_thick, 0, 'background_pixel' => $bg, 'event_mask' => Exposure_m | ButtonPress_m | ButtonMotion_m | PointerMotionHint_m); $lt_win = $X->new_rsrc; $X->CreateWindow($lt_win, $slider_win, InputOutput, CopyFromParent, CopyFromParent, (0, 0), $inner_thick, $inner_thick, 0, 'background_pixel' => $trough, 'event_mask' => Exposure_m | ButtonPress_m | ButtonRelease_m); $rt_win = $X->new_rsrc; $X->CreateWindow($rt_win, $slider_win, InputOutput, CopyFromParent, CopyFromParent, ($thumb + $inner_thick, 0), $inner_thick, $inner_thick, 0, 'background_pixel' => $trough, 'event_mask' => Exposure_m | ButtonPress_m | ButtonRelease_m); my $lt_state = 0; my $rt_state = 0; $X->MapWindow($lt_win); $X->MapWindow($rt_win); $X->MapWindow($slider_win); sub slider_update { my($delta, $warp) = @_; my $old_pos = $slider_pos; $slider_pos = clamp($pos_min, $slider_pos + $delta, $pos_max); $X->WarpPointer(0, 0, 0, 0, 0, 0, $slider_pos - $old_pos, 0) if $warp; $X->ConfigureWindow($slider_win, 'x' => $slider_pos); prog_update(($slider_pos - $pos_min) / ($pos_max - $pos_min), 1); } my %extents = $X->QueryTextExtents($font, "\0001\0000\0000\0%"); my $text_wd = $extents{'overall_width'} + 4+2; my $text_x = int(($length - $text_wd) / 2); my $text_baseline = int(($thickness + $extents{'font_ascent'} - $extents{'font_descent'}) / 2) - $depth; my $prog_pixmap = $X->new_rsrc; $X->CreatePixmap($prog_pixmap, $prog_win, $X->root_depth, $text_wd, $inner_thick); $trough_gc = $X->new_rsrc; $X->CreateGC($trough_gc, $prog_pixmap, 'font' => $font, 'foreground' => $trough); $fill_gc = $X->new_rsrc; my($fill_pixel,) = $X->AllocColor($cmap, (@$fill_rgb)); $X->CreateGC($fill_gc, $prog_pixmap, 'font' => $font, 'foreground' => $fill_pixel); $X->ChangeGC($shadow_gc, 'font' => $font); $X->ChangeGC($hilite_gc, 'font' => $font); $X->ChangeGC($bg_gc, 'font' => $font); sub paint_shaded_text { my($drawable, $x, $y, $text) = @_; my($br_gc, $tl_gc) = ($shadow_gc, $hilite_gc); $X->PolyText8($drawable, $br_gc, ($x + 1, $y + 1), @$text) if $text_shading_style; $X->PolyText8($drawable, $br_gc, ($x, $y + 1), @$text); $X->PolyText8($drawable, $br_gc, ($x + 1, $y), @$text); $X->PolyText8($drawable, $tl_gc, ($x - 1, $y - 1), @$text) if $text_shading_style; $X->PolyText8($drawable, $tl_gc, ($x, $y - 1), @$text); $X->PolyText8($drawable, $tl_gc, ($x - 1, $y), @$text); $X->PolyText8($drawable, $bg_gc, ($x, $y), @$text); } my $font_height = $extents{'font_ascent'} + $extents{'font_descent'}; sub prog_update { my($newfrac, $increm) = @_; my $oldfrac = $frac; $frac = $newfrac; my $str = int(100 * $frac) . "%"; my $text = [map([1, $_], split(//, $str))]; $text->[1][0] = -$font_height/10 if $text->[0][1] eq "1"; # kerning my $realend = int($frac * ($length - 2 * $depth)) + $depth; if ($increm) { my $newend = $realend; my $oldend = int($oldfrac * ($length - 2 * $depth)) + $depth; my $x; my($left, $right); my $count = 0; if ($newend > $oldend) { $right = \$newend; $left = \$oldend; } else { $right = \$oldend; $left = \$newend; } if ($$left >= $text_x and $$left < $text_x + $text_wd) { $$left = $text_x + $text_wd - 1; $count++; } if ($$right >= $text_x and $$right < $text_x + $text_wd) { $$right = $text_x; $count++; } if ($count == 2) { # do nothing } elsif ($newend > $oldend) { if ($smooth_progress) { for ($x = $oldend; $x < $newend; $x++) { $X->PolySegment($prog_win, $fill_gc, ($x, $depth) => ($x, $thickness - $depth - 1)); } } else { $X->PolyFillRectangle($prog_win, $fill_gc, [($oldend, $depth), $newend - $oldend, $inner_thick]); } } elsif ($newend < $oldend) { if ($smooth_progress) { for ($x = $oldend - 1; $x >= $newend; $x--) { $X->PolySegment($prog_win, $trough_gc, ($x, $depth) => ($x, $thickness - $depth - 1)); } } else { $X->PolyFillRectangle($prog_win, $trough_gc, [($newend, $depth), $oldend - $newend, $inner_thick]); } } } else { $X->PolyFillRectangle($prog_win, $fill_gc, [($depth, $depth), $realend - $depth, $inner_thick]); } my $end = clamp(0, $realend - $text_x, $text_wd); $X->PolyFillRectangle($prog_pixmap, $fill_gc, [0, 0, $end, $inner_thick]) if $end > 0; $X->PolyFillRectangle($prog_pixmap, $trough_gc, [$end, 0, $text_wd - $end, $inner_thick]) if $end < $text_wd; $str =~ s/(.)/\0$1/g; my $wd = {$X->QueryTextExtents($font, $str)}->{'overall_width'}; paint_shaded_text($prog_pixmap, 1 + int(($text_wd - $wd) / 2), $text_baseline, $text); $X->CopyArea($prog_pixmap, $prog_win, $bg_gc, (0, 0), $text_wd, $inner_thick, ($text_x, $depth)); } $X->MapWindow($prog_win); $X->MapWindow($sbar_win); $X->MapWindow($main_win); my $fds = IO::Select->new($X->connection->fh); my $timeout = 0; my($slider_speed, $pointer_pos, $last_pos); my(%dirty); my $resize_pending = 0; # Since this program can't necessarily handle events as fast as the X # server can generate them, it's important to use some sort of `flow # control' to throw out excess events when we're behind. # For pointer motion events, this is accomplished by selecting # PointerMotionHint on the slider (see above), so that the server # never sends a sequence of motion events -- instead, it sends one, # which we throw away but use as our cue to query the pointer # position. The query_pointer is then a sign to the server that we'd # be willing to accept one more event, and so on. Notice that this # requires several round trips between the server and the client for # each motion, which in C programs is a source of performance # problems, but here the difference is lost in the noise (we also do a # round trip to calculate the width of the text when updating the # progress bar, which could be done on the client side the way Xlib # does). # Expose and ConfigureNotify (resize) events have the same problem, # though it's only noticeable if your window manager supports opaque # window movement or opaque resize, respectively (the latter is fairly # rare in X, perhaps because average X clients handle it fairly # poorly; I for one am quite envious of how smoothly windows resize in # Windows NT). We can't do anything to tell the server to only send us # one of these events, but the next best thing is to just ignore them # until there aren't any other events pending. (In some toolkits this # would be called `idle-loop' processing). It's always safe to ignore # intermediate resizes, but with expose events we can only do this # because we always redraw the whole window, instead of just the # newly-visible part. A more sophisticated approach would keep track # of the exposed region, either with a bounding box or some more # precise data structure, and then clip the drawing to that (either # client-side or using a clip mask in the GC). Of course, that almost # certainly wouldn't be a speed win, because it would be doing a lot # of work in perl to save a few iterations of highly optimized C in # the server. $X->{'event_handler'} = "queue"; for (;;) { if ($timeout) { while (not $fds->can_read($timeout)) { slider_update(int $slider_speed, 1); $slider_speed += sign($slider_speed) * $accel; if ($slider_pos == $pos_min or $slider_pos == $pos_max) { $timeout = 0; last; } else { $timeout = $delay; } } } if (not $fds->can_read(0.001)) { if ($resize_pending) { $resize_pending = 0; $total_ht = max($total_ht, $base_ht); $length = $total_wd - 2 * $padding; $thickness = int(($total_ht - 3 * $padding) / 2 + 0.5); $depth = int($relief_frac * $thickness) if $relief_frac; $inner_thick = $thickness - 2*$depth; $thumb = $length / 3; $X->ConfigureWindow($prog_win, 'width' => $length, 'height' => $thickness); $fontsize = int($font_frac * $thickness); $X->CloseFont($font); $X->OpenFont($font, sprintf($fontname, $fontsize)); map($X->ChangeGC($_, 'font' => $font), $bg_gc, $hilite_gc, $shadow_gc); %extents = $X->QueryTextExtents($font, "\0001\0000\0000\0%"); $text_wd = $extents{'overall_width'} + 4+2; $text_x = int(($length - $text_wd) / 2); $text_baseline = int(($thickness + $extents{'font_ascent'} - $extents{'font_descent'}) / 2) - $depth; $font_height = $extents{'font_ascent'} + $extents{'font_descent'}; $X->FreePixmap($prog_pixmap); $X->CreatePixmap($prog_pixmap, $prog_win, $X->root_depth, $text_wd, $inner_thick); $X->ConfigureWindow($sbar_win, 'x' => $padding, 'y' => 2 * $padding + $thickness, 'width' => $length, 'height' => $thickness); $pos_min = $depth; $pos_max = $length - $thumb - $depth - 2 * $inner_thick; $slider_pos = $pos_min + $frac * ($pos_max - $pos_min); $X->ConfigureWindow($slider_win, 'x' => $slider_pos, 'y' => $depth, 'width' => $thumb + 2 * $inner_thick, 'height' => $inner_thick); $X->ConfigureWindow($lt_win, 'width' => $inner_thick, 'height' => $inner_thick); $X->ConfigureWindow($rt_win, 'x' => $thumb + $inner_thick, 'width' => $inner_thick, 'height' => $inner_thick) } if ($dirty{$prog_win}) { draw_slope($prog_win, 0, 0, $length, $thickness, $prog_relief); prog_update($frac, 0); $dirty{$prog_win} = 0; } if ($dirty{$sbar_win}) { draw_slope($sbar_win, 0, 0, $length, $thickness, $sbar_relief); $dirty{$sbar_win} = 0; } if ($dirty{$slider_win}) { draw_slope($slider_win, $inner_thick, 0, $thumb, $inner_thick, $slider_relief); paint_slope_circle($slider_win, $thumb / 2 + (2 - $dimple)/2*$inner_thick, (1 - $dimple) * $inner_thick / 2, $dimple * $inner_thick, $depth, $dimple_relief) if $dimple; $dirty{$slider_win} = 0; } if ($dirty{$lt_win}) { paint_arrow($lt_win, 0, 0, $inner_thick - 1, 3, $arrow_relief ^ $lt_state); $dirty{$lt_win} = 0; } if ($dirty{$rt_win}) { paint_arrow($rt_win, 0, 0, $inner_thick - 1, 1, $arrow_relief ^ $rt_state); $dirty{$rt_win} = 0; } } my %e = $X->next_event; if ($e{code} == ClientMessage and unpack("L", $e{data}) == $delete_atom) { exit; } elsif ($e{code} == ConfigureNotify) { if ($e{width} != $total_wd or $e{height} != $total_ht) { $resize_pending++; ($total_wd, $total_ht) = ($e{width}, $e{height}); } } elsif ($e{code} == Expose) { next unless $e{count} == 0; my $id = $e{window}; if ($id == $sbar_win) { if ($e{'x'} < $depth or $e{'y'} < $depth or $e{'x'} + $e{width} > $length - $depth or $e{'y'} + $e{height} > $thickness - $depth) { # In the scrollbar, we throw out exposures that don't # include the border (including all the ones caused by # moving the slider), since the server fills the # trough in with the window's background color # automatically. $dirty{$sbar_win}++; } } else { $dirty{$id}++; } } elsif ($e{code} == ButtonPress) { my $id = $e{event}; if ($id == $slider_win) { $pointer_pos = $slider_pos; $last_pos = $e{root_x}; } elsif ($id == $lt_win) { next if 2*abs($e{event_y} - $inner_thick / 2) > $e{event_x}; $lt_state = $arrow_change; slider_update(-1, 1); paint_arrow($lt_win, 0, 0, $inner_thick - 1, 3, $arrow_relief ^ $lt_state); $slider_speed = -1; $timeout = $initial_delay; } elsif ($id == $rt_win) { next if 2*abs($e{event_y} - $inner_thick / 2) > $inner_thick - $e{event_x}; $rt_state = $arrow_change; slider_update(1, 1); paint_arrow($rt_win, 0, 0, $inner_thick - 1, 1, $arrow_relief ^ $rt_state); $slider_speed = 1; $timeout = $initial_delay; } } elsif ($e{code} == MotionNotify) { my $id = $e{event}; if ($id == $slider_win and defined $last_pos) { my %e2 = $X->QueryPointer($slider_win); $pointer_pos += $e2{'root_x'} - $last_pos; slider_update($pointer_pos - $slider_pos, 0); $last_pos = $e2{'root_x'}; } } elsif ($e{code} == ButtonRelease) { my $id = $e{event}; if ($id == $slider_win and defined $last_pos) { slider_update($e{root_x} - $last_pos, 0); undef $last_pos; } elsif ($id == $lt_win) { $lt_state = 0; paint_arrow($lt_win, 0, 0, $inner_thick - 1, 3, $arrow_relief ^ $lt_state); $timeout = 0; } elsif ($id == $rt_win) { $rt_state = 0; paint_arrow($rt_win, 0, 0, $inner_thick - 1, 1, $arrow_relief ^ $rt_state); $timeout = 0; } } } X11-Protocol-0.56/eg/random-win.pl0000644000175000017500000000212407742410126015255 0ustar smccsmcc#!/usr/bin/perl # Overwrite a bunch of randomly chosen windows on the screen with # random-colored rectangles. You might want to learn about the # "xrefresh" program before trying this one. # Demonstrates the use of "robust_req" use X11::Protocol; $X = X11::Protocol->new; my $gc = $X->new_rsrc; $X->req('CreateGC', $gc, $X->root); for (1 .. 2500) { my $client = rand(50); my $client_id = rand(200); my $id = $client << 21 | $client_id; printf "XID %x ", $id; my($result,) = $X->robust_req('GetGeometry', $id); my %geom; if (ref $result) { print "exists\n"; %geom = @$result; } else { print "does not exist\n"; next; } # Make sure we've got a Window rather than a Pixmap, since overwriting # Pixmaps is more permanent and therefore less amusing. next unless ref $X->robust_req('GetWindowAttributes', $id); $X->req('ChangeGC', $gc, 'foreground' => rand(2**32)); my($result,) = $X->robust_req('PolyFillRectangle', $id, $gc, [5, 5, $geom{width}-10, $geom{height}-10]); if (not ref $result) { print "Ignoring $result error\n"; } } X11-Protocol-0.56/eg/wintree.pl0000644000175000017500000000446610033145175014666 0ustar smccsmccuse X11::Protocol; my $opt_g = 0; my $opt_v = 0; my $do_root = 1; # This is a fudge factor relating to how the X server allocates resource IDs. # 21 seems to be the right value for XFree86 4.2. my $client_shift = 21; $x = new X11::Protocol; sub get_prop { my($win, $name) = @_; return ($x->GetProperty($win, $x->atom($name), $x->atom("STRING"), 0, 65535, 0))[0]; } sub pre_walk { my $win = shift; my($root, $dad, @kids) = $x->QueryTree($win); my @argv = split(/\0/, get_prop($win, "WM_COMMAND")); my $cmd = $argv[0]; $cmd =~ s[^.*/][]; $cmd_name{$win >> $client_shift} = $cmd if $cmd ne ""; map(pre_walk($_), @kids); } sub tree { my $win = shift; my($root, $dad, @kids) = $x->QueryTree($win); my $client = $win >> $client_shift; my $dad_client = $dad >> $client_shift; $id = $win & 0xfffff; my $name = ""; if ($client != $dad_client) { my $client_id = sprintf "%x", $client; $client_id = "$cmd_name{$client}:$client_id" if exists $cmd_name{$client}; $name = "($client_id)"; } $name .= sprintf("%x", $id); if ($opt_g) { my %geo = $x->GetGeometry($win); $name .= "($geo{width}x$geo{height}+$geo{x}+$geo{y})"; } my $title = get_prop($win, "WM_ICON_NAME") || get_prop($win, "WM_NAME"); $name .= "`" . $title ."'" if $title; if (not @kids) { return "-$name\n"; } my @lines; for my $kid (@kids) { push @lines, tree($kid); } my $i; for ($i = $#lines; substr($lines[$i], 0, 1) ne "-"; $i--) { $lines[$i] = " " . $lines[$i]; } if ($i > 0) { $lines[$i] = "`" . $lines[$i]; $lines[$i] = "|" . $lines[$i] while $i-- > 1; $lines[$i] = "+" . $lines[$i]; } else { $lines[0] = "-" . $lines[0]; } return("-$name-" . shift @lines, map(" " x (length($name) + 2) . $_, @lines)); } sub vt_ify { my @x = @_; for my $l (@x) { if ($opt_v) { $l =~ s/\|-/\cNtq\cO/g; $l =~ s/\| /\cNx\cO /g; $l =~ s/`-/\cNmq\cO/g; #`; $l =~ s/---/\cNqqq\cO/g; $l =~ s/-\+-/\cNqwq\cO/g; } } return @x; } pre_walk($x->root); foreach my $arg (@ARGV) { if ($arg eq "-g") { $opt_g = 1; } elsif ($arg eq "-v") { $opt_v = 1; } else { $do_root = 0; print tree(hex $arg); } } print tree($x->root) if $do_root; X11-Protocol-0.56/eg/teletype.pl0000644000175000017500000000557607036431222015047 0ustar smccsmcc#!/usr/bin/perl # Put up windows on two displays, and echo input from one on the other. use X11::Protocol; use X11::Keysyms '%keysyms'; %keysyms_name = reverse %keysyms; use IO::Select; die "usage: $0 display display\n" unless @ARGV == 2; $x1 = X11::Protocol->new($ARGV[0]); $x2 = X11::Protocol->new($ARGV[1]); $win1 = $x1->new_rsrc; $win2 = $x2->new_rsrc; $x1->CreateWindow($win1, $x1->root, 'InputOutput', $x1->root_depth, 'CopyFromParent', (0,0), 200, 200, 1, # 'backing_store' => 'Always', 'background_pixel' => $x1->white_pixel, 'event_mask' => $x1->pack_event_mask('KeyPress', 'Exposure', 'ButtonPress')); $x2->CreateWindow($win2, $x2->root, 'InputOutput', $x2->root_depth, 'CopyFromParent', (0,0), 200, 200, 1, # 'backing_store' => 'Always', 'background_pixel' => $x2->white_pixel, 'event_mask' => $x2->pack_event_mask('KeyPress', 'Exposure', 'ButtonPress')); $x1->ChangeProperty($win1, $x1->atom("WM_NAME"), $x1->atom("STRING"), 8, 'Replace', "Window #1"); $x2->ChangeProperty($win2, $x2->atom("WM_NAME"), $x2->atom("STRING"), 8, 'Replace', "Window #2"); $x1->MapWindow($win1); $x2->MapWindow($win2); $fnt1 = $x1->new_rsrc; $fnt2 = $x2->new_rsrc; $x1->OpenFont($fnt1, 'fixed'); $x2->OpenFont($fnt2, 'fixed'); $gc1 = $x1->new_rsrc; $gc2 = $x2->new_rsrc; $x1->CreateGC($gc1, $win1, 'foreground' => $x1->black_pixel, 'font' => $fnt1, 'graphics_exposures' => 0); $x2->CreateGC($gc2, $win2, 'foreground' => $x2->black_pixel, 'font' => $fnt2, 'graphics_exposures' => 0); $i = $x1->min_keycode; for $ar ($x1->GetKeyboardMapping($x1->min_keycode, $x1->max_keycode - $x1->min_keycode + 1)) { $table[0][$i++] = [map($keysyms_name{$_}, @$ar)]; } $i = $x2->min_keycode; for $ar ($x2->GetKeyboardMapping($x2->min_keycode, $x2->max_keycode - $x2->min_keycode + 1)) { $table[1][$i++] = [map($keysyms_name{$_}, @$ar)]; } sub print_event { my($disp, $win, $gc, $font, $t, %e) = @_; if ($e{name} eq "KeyPress") { my($key) = $t->[$e{detail}][0]; exit if $key eq "q" or $key eq "Q"; $disp->PolyText8($win, $gc, ($e{event_x}, $e{event_y}), [0, $key]); (my $key16 = $key) =~ s/(.)/\0$1/g;; my $dx = {$disp->QueryTextExtents($font, $key16)}->{'overall_width'}; $disp->WarpPointer(0, 0, 0, 0, 0, 0, $dx, 0); } elsif ($e{name} eq "ButtonPress") { $disp->PolyPoint($win, $gc, 'Origin', ($e{event_x}, $e{event_y})); } elsif ($e{name} eq "Expose") { $disp->PolyRectangle($win, $gc, [($e{'x'}, $e{'y'}), $e{width}, $e{height}]); } } $x1->event_handler(sub {print_event($x2, $win2, $gc2, $fnt2, $table[1], @_)}); $x2->event_handler(sub {print_event($x1, $win1, $gc1, $fnt1, $table[0], @_)}); $sel = IO::Select->new($x1->connection->fh, $x2->connection->fh); for (;;) { for $fh ($sel->can_read) { $x1->handle_input if $fh == $x1->connection->fh; $x2->handle_input if $fh == $x2->connection->fh; } } X11-Protocol-0.56/eg/widgets2.pl0000644000175000017500000006447510512254506014750 0ustar smccsmcc#!/usr/bin/perl use X11::Lib; use IO::Select; use strict; sub clamp { $_[1] < $_[0] ? $_[0] : $_[1] > $_[2] ? $_[2] : $_[1] } sub sign { $_[0] ? $_[0] / abs($_[0]) : 0 } sub min { $_[0] <= $_[1] ? $_[0] : $_[1] } sub max { $_[0] >= $_[1] ? $_[0] : $_[1] } # Look and feel parameters to play with: my $length = 300; my $thumb = 100; my $thickness = 20; my $padding = 5; my $depth = 2; my $relief_frac = .1; # relief area / thickness, 0 => relief doesn't scale my $trough_rgb = [0xa3a3, 0xa3a3, 0xb3b3]; my $bg_rgb = [0xc6c6, 0xc6c6, 0xd6d6]; my $fill_rgb = [0xb6b6, 0x3030, 0x6060]; my $shade = .5; # 0 => shadows black, hilights white; 1 => no shading # for relief, 0 => raised, 1 => sunk, 2 => ridge, 3 => groove my $prog_relief = 1; my $sbar_relief = 1; my $slider_relief = 0; my $arrow_relief = 0; my $dimple_relief = 1; my $arrow_change = 1; # these bits will flip when pressed my $dimple = .3; # size / scrollbar thickness, 0 for none my $font_frac = .6; # text fills 60% of the height of the progresss bar # Note that the progress bar prefers scalable fonts, so that it can keep # the same proportions when the window is resized. Depending on how modern # your X installation is, this may be nontrivial. # * The best case is if you have a font that includes both hand-edited # bitmaps for small sizes and outlines that can be scaled arbitrarily. # All recent X releases come with bitmaps provided by Adobe for Helvetica, # so if you also have a corresponding Type 1 outline, that's the best # choice: # (bitmaps for sizes 8, 10, 11, 12, 14, 17, 18, 20, 24, 25, and 34) #my $fontname = "-adobe-helvetica-medium-r-normal--%d-*-*-*-*-*-iso8859-1"; # (If you're using Debian Linux like me, you'll need to install the # gsfonts and gsfonts-x11 packages to get the Type 1 versions. The # outline isn't the genuine Adobe version; it's a free clone that # can also be accessed directly (without Adobe's bitmaps) as) my $fontname = "-urw-nimbus sans l-regular-r-normal--%d-*-*-*-*-*-iso8859-1"; # * Recent X releases also include some scalable fonts, though not any # sans-serif ones. In the following, adobe-utopia can be replaced by # adobe-courier, bitstream-courier, or bitstream-charter: #my $fontname = "-adobe-utopia-medium-r-normal--%d-*-*-*-*-*-iso8859-1"; # * Also, recent X servers can scale bitmaps, though the results are usually # fairly ugly. # * If your X system predates XLFD (the 14-hyphen names), your font # selection is probably pretty miniscule; try to pick something around # 12 pixels: #my $fontname = "7x13"; my $cursor_id = 132; my $initial_delay = 0.15; # secs my $delay = 0.05; # secs my $accel = 0.5; my $smooth_progress = 0; # and un-smooth scrollbar my $text_shading_style = 1; # 0 => diagonalish, 1 => squarish # +--------------------------------------------------+ # | main_win ^v padding [bg] | # | +----------------------------------------------+ | # | |#prog_win########### ^ |<| # | |##########[fill]#### :thickness |>| # | |#################### : |:| # | |<-------- length -----------:---------------->|:| # | |#################### V [trough] |:| # | +----------------------------------------------+:| # | ^v padding :| # | +----------------------------------------------+:| # | | sbar_win +------------------------+ |:| # |<| |+----+ slider_win +----+| [trough] |:| # |>|<-slider->|| <| |<-lt_win | |> || |:| # |:| pos |+----+ rt_win->+----+| |:| # |:| +------------------------+ |:| # |:+----------:------------------------:----------+:| # |: : ^v padding : :| # +:-----------:------------------------:-----------:+ # : : : : # : : : : # padding :<------- thumb -------->: my $frac = 0; my $dpy = X::OpenDisplay(""); my $cmap = X::DefaultColormap($dpy, X::DefaultScreen($dpy)); sub alloc_color { my($cmap, $r, $g, $b) = @_; my $xcolor_data = pack("ISSScx", 0, $r, $g, $b, 7); my $xcolor_addr = unpack("I", pack("P", $xcolor_data)); my $xcolor_obj = \$xcolor_addr; bless $xcolor_obj, "X::Color"; X::AllocColor($dpy, $cmap, $xcolor_obj); return unpack("Ix2x2x2xx", $xcolor_data); } my $bg = alloc_color($cmap, @$bg_rgb); my $trough = alloc_color($cmap, @$trough_rgb); my $shadow = alloc_color($cmap, map($_ * $shade, @$bg_rgb)); my $hilite = alloc_color($cmap, map(65535 - $shade * (65535 - $_), @$bg_rgb)); my $fill = alloc_color($cmap, @$fill_rgb); my $delete_atom = X::InternAtom($dpy, "WM_DELETE_WINDOW", 0); my $fontsize = $font_frac * $thickness; my $font = X::LoadQueryFont($dpy, sprintf($fontname, $fontsize)); my $total_wd = 2*$padding + $length; my $base_wd = 2*$padding + 2*$depth + 4; my $total_ht = 3*$padding + 2*$thickness; my $base_ht = 3*$padding + 4*$depth + 3; my $cursor = X::CreateFontCursor($dpy, $cursor_id); my $root = X::RootWindow($dpy, X::DefaultScreen($dpy)); my $attr_data = pack("x4Ix4x4x4x4x4x4x4x4Ix4x4x4I", $bg, X::StructureNotifyMask, $$cursor); my $attr_addr = unpack("I", pack("P", $attr_data)); my $attr_obj = \$attr_addr; bless $attr_obj, "X::SetWindowAttributes"; my $copy_from_parent_visual = 0; my $copy_from_parent_visual_obj = \$copy_from_parent_visual; bless $copy_from_parent_visual_obj, "X::Visual"; my $main_win = X::CreateWindow($dpy, $root, 0, 0, $total_wd, $total_ht, 0, X::CopyFromParent, X::CopyFromParent, $copy_from_parent_visual_obj, X::CWCursor | X::CWBackPixel | X::CWEventMask, $attr_obj); my $wm_hints = X::AllocWMHints(); my $wm_data = pack("IIix24", 1+2, 1, 1); $$wm_hints = unpack("I", pack("P", $wm_data)); X::SetWMHints($dpy, $main_win, $wm_hints); my $normal_hints = X::AllocSizeHints(); my $normal_data = pack("Iiiiiiiiiiiiiiiiii", 8+16+128+256, 0, 0, $base_wd, $base_ht, $base_wd, $base_ht, 0, 0, 0, 0, 3, 2, 1000, 1, $base_ht, $base_wd, 0); $$normal_hints = unpack("I", pack("P", $normal_data)); X::SetWMNormalHints($dpy, $main_win, $normal_hints); my $class_hint = X::AllocClassHint(); $class_hint->name($0); $class_hint->class("widgets"); # XXX Why does this need an X? X::XSetClassHint($dpy, $main_win, $class_hint); my $STRING = X::InternAtom($dpy, "STRING", 0); my $window_name = "Raw X Widgets (X11::Lib)"; my $window_name_data = pack("pIiI", $window_name, $$STRING, 8, length $window_name); my $window_name_addr = unpack("I", pack("P", $window_name_data)); my $window_name_obj = \$window_name_addr; bless $window_name_obj, "X::TextProperty"; X::SetWMName($dpy, $main_win, $window_name_obj); my $icon_name = "widgets"; my $icon_name_data = pack("pIiI", $icon_name, $$STRING, 8, length $icon_name); my $icon_name_addr = unpack("I", pack("P", $icon_name_data)); my $icon_name_obj = \$icon_name_addr; bless $icon_name_obj, "X::TextProperty"; X::SetWMIconName($dpy, $main_win, $icon_name_obj); my $protos_data = pack("I", $$delete_atom); my $protos_addr = unpack("I", pack("P", $protos_data)); my $protos_obj = \$protos_addr; bless $protos_obj, "DUMMY_AtomPtr"; X::SetWMProtocols($dpy, $main_win, $protos_obj, 1); my $prog_win = X::CreateSimpleWindow($dpy, $main_win, $padding, $padding, $length, $thickness, 0, 0, $trough); X::SelectInput($dpy, $prog_win, X::ExposureMask); my $sbar_win = X::CreateSimpleWindow($dpy, $main_win, $padding, 2*$padding + $thickness, $length, $thickness, 0, 0, $trough); X::SelectInput($dpy, $sbar_win, X::ExposureMask); my $dummy_gcvals = new X::GCValues; my $bg_gc = X::CreateGC($dpy, $main_win, 0, $dummy_gcvals); X::SetForeground($dpy, $bg_gc, $bg); my $shadow_gc = X::CreateGC($dpy, $main_win, 0, $dummy_gcvals); X::SetForeground($dpy, $shadow_gc, $shadow); my $hilite_gc = X::CreateGC($dpy, $main_win, 0, $dummy_gcvals); X::SetForeground($dpy, $hilite_gc, $hilite); # floor : ceil :: int : away sub away { sign($_[0]) * int(abs($_[0]) + .9999) } sub draw_slope_poly { my($win, $relief, $dep, $fill, @p) = @_; if ($relief > 1) { draw_slope_poly($win, $relief ^ 3, $dep, $fill, @p); $relief &= 1; $dep /= 2; $fill = 0; } my($tl, $br) = ($hilite_gc, $shadow_gc)[$relief, !$relief]; my(@gc, @ip); $#gc = $#ip = $#p; my $j; for $j (-2 .. $#p - 2) { my($ix, $iy) = ($p[$j+1][0] - $p[$j][0], $p[$j+1][1] - $p[$j][1]); $gc[$j] = $ix > $iy ? $tl : $ix < $iy ? $br : $ix > 0 ? $tl : $br; my($ox, $oy) = ($p[$j+2][0] - $p[$j+1][0], $p[$j+2][1] - $p[$j+1][1]); if ($ix*$oy > $iy*$ox) { $ix = -$ix; $iy = -$iy; } else { $ox = -$ox; $oy = -$oy; } my($in) = sqrt($ix*$ix + $iy*$iy); $ix /= $in; $iy /= $in; my($on) = sqrt($ox*$ox + $oy*$oy); $ox /= $on; $oy /= $on; my($mx, $my) = (($ix + $ox)/2, ($iy + $oy)/2); my($mn) = max(abs($mx), abs($my)); $mx /= $mn; $my /= $mn; $ip[$j+1][0] = $p[$j+1][0] + away(($dep - 1) * $mx); $ip[$j+1][1] = $p[$j+1][1] + away(($dep - 1) * $my); } if ($fill) { my $ip_data = pack("s*", map(@{$_}[0,1], @ip)); my $ip_addr = unpack("I", pack("P", $ip_data)); my $ip_obj = \$ip_addr; bless $ip_obj, "X::Point"; X::FillPolygon($dpy, $win, $fill, $ip_obj, scalar @ip, X::Nonconvex, X::CoordModeOrigin); } for $j (-1 .. $#p - 1) { my $quad_data = pack("s*", map(@{$_}[0, 1], $p[$j], $ip[$j], $ip[$j + 1], $p[$j + 1])); my $quad_addr = unpack("I", pack("P", $quad_data)); my $quad_obj = \$quad_addr; bless $quad_obj, "X::Point"; X::FillPolygon($dpy, $win, $gc[$j], $quad_obj, 4, X::Convex, X::CoordModeOrigin); &X::DrawLine($dpy, $win, $gc[$j], @{$p[$j]} => @{$p[$j+1]}); &X::DrawLine($dpy, $win, $gc[$j], @{$ip[$j]} => @{$ip[$j+1]}); } for $j (-1 .. $#p - 1) { &X::DrawLine($dpy, $win, $bg_gc, @{$p[$j+1]} => @{$ip[$j+1]}) if $gc[$j] != $gc[$j + 1]; } } sub draw_slope { my($win, $x, $y, $wd, $ht, $relief) = @_; draw_slope_poly($win, $relief, $depth, 0, [$x, $y], [$x + $wd - 1, $y], [$x + $wd - 1, $y + $ht - 1], [$x, $y + $ht - 1]); } sub paint_arrow { my($win, $x, $y, $s, $dir, $relief) = @_; my @s = ($s / 2, $s, $s / 2, 0); my @p = ([$x + $s[$dir], $y + $s[$dir - 1]], ($dir & 1 xor $dir & 2) ? [$x, $y] : [$x + $s, $y + $s], ($dir & 2) ? [$x + $s, $y] : [$x, $y + $s]); @p[1,2] = @p[2,1] if $dir & 1; draw_slope_poly($win, $relief, $depth, $bg_gc, @p); } sub paint_slope_circle { my($win, $x, $y, $s, $dep, $relief) = @_; my($tl, $br) = ($hilite_gc, $shadow_gc)[$relief & 1, !($relief & 1)]; my @outer = ($x, $y, $s, $s); my @inner = ($x + $dep, $y + $dep, $s - 2*$dep, $s - 2*$dep); my @tl = (35*64, 160*64); my @br = (215*64, 160*64); &X::FillArc($dpy, $win, $bg_gc, @outer, 0, 360 * 64); &X::FillArc($dpy, $win, $tl, @outer, @tl); &X::DrawArc($dpy, $win, $tl, @outer, @tl); &X::DrawArc($dpy, $win, $tl, @inner, @tl); &X::FillArc($dpy, $win, $br, @outer, @br); &X::DrawArc($dpy, $win, $br, @outer, @br); &X::DrawArc($dpy, $win, $br, @inner, @br); if ($relief & 2) { my @middle = ($x + $depth/2, $y + $depth/2, $s - $depth, $s - $depth); &X::FillArc($dpy, $win, $br, @middle, @tl); &X::FillArc($dpy, $win, $tl, @middle, @br); } &X::FillArc($dpy, $win, $bg_gc, @inner, 0, 360*64); } my $inner_thick = $thickness - 2 * $depth; my $slider_pos = $depth; my $pos_min = $depth; my $pos_max = $length - $thumb - $depth - 2 * $inner_thick; my $slider_win = X::CreateSimpleWindow($dpy, $sbar_win, $slider_pos, $depth, $thumb + 2 * $inner_thick, $inner_thick, 0, 0, $bg); X::SelectInput($dpy, $slider_win, X::ExposureMask | X::ButtonPressMask | X::ButtonMotionMask | X::PointerMotionHintMask); my $lt_win = X::CreateSimpleWindow($dpy, $slider_win, 0, 0, $inner_thick, $inner_thick, 0, 0, $trough); X::SelectInput($dpy, $lt_win, X::ExposureMask | X::ButtonPressMask | X::ButtonReleaseMask); my $rt_win = X::CreateSimpleWindow($dpy, $slider_win, $thumb + $inner_thick, 0, $inner_thick, $inner_thick, 0, 0, $trough); X::SelectInput($dpy, $rt_win, X::ExposureMask | X::ButtonPressMask | X::ButtonReleaseMask); my $lt_state = 0; my $rt_state = 0; X::MapWindow($dpy, $lt_win); X::MapWindow($dpy, $rt_win); X::MapWindow($dpy, $slider_win); sub slider_update { my($delta, $warp) = @_; my $old_pos = $slider_pos; $slider_pos = clamp($pos_min, $slider_pos + $delta, $pos_max); X::WarpPointer($dpy, X::Window->nil, X::Window->nil, 0, 0, 0, 0, $slider_pos - $old_pos, 0) if $warp; X::MoveWindow($dpy, $slider_win, $slider_pos, $depth); prog_update(($slider_pos - $pos_min) / ($pos_max - $pos_min), 1); } my $text_wd = X::TextWidth($font, "100%", 4) + 4 + 2; my $text_x = int(($length - $text_wd) / 2); my $dummy_charstruct_data = "\0" x 12; my $dummy_charstruct_addr = unpack("I", pack("P", $dummy_charstruct_data)); my $dummy_charstruct_obj = \$dummy_charstruct_addr; bless $dummy_charstruct_obj, "X::CharStruct"; my($ascent, $descent, $dummy_int); X::TextExtents($font, "100%", 4, $dummy_int, $ascent, $descent, $dummy_charstruct_obj); my $text_baseline = int(($thickness + $ascent - $descent) / 2) - $depth; my $root_depth = X::DisplayPlanes($dpy, X::DefaultScreen($dpy)); my $prog_pixmap = X::CreatePixmap($dpy, $prog_win, $text_wd, $inner_thick, $root_depth); my $trough_gc = X::CreateGC($dpy, $main_win, 0, $dummy_gcvals); X::SetForeground($dpy, $trough_gc, $trough); my $fill_gc = X::CreateGC($dpy, $main_win, 0, $dummy_gcvals); X::SetForeground($dpy, $fill_gc, $fill); my $fid = unpack("x4I", unpack("P8", pack("I", $$font))); my $fid_obj = \$fid; bless $fid_obj, "X::Font"; X::SetFont($dpy, $trough_gc, $fid_obj); X::SetFont($dpy, $fill_gc, $fid_obj); X::SetFont($dpy, $shadow_gc, $fid_obj); X::SetFont($dpy, $hilite_gc, $fid_obj); X::SetFont($dpy, $bg_gc, $fid_obj); sub paint_shaded_text { my($drawable, $x, $y, $text, $n) = @_; my($br_gc, $tl_gc) = ($shadow_gc, $hilite_gc); X::DrawText($dpy, $drawable, $br_gc, $x + 1, $y + 1, $text, $n) if $text_shading_style; X::DrawText($dpy, $drawable, $br_gc, $x, $y + 1, $text, $n); X::DrawText($dpy, $drawable, $br_gc, $x + 1, $y, $text, $n); X::DrawText($dpy, $drawable, $tl_gc, $x - 1, $y - 1, $text, $n) if $text_shading_style; X::DrawText($dpy, $drawable, $tl_gc, $x, $y - 1, $text, $n); X::DrawText($dpy, $drawable, $tl_gc, $x - 1, $y, $text, $n); X::DrawText($dpy, $drawable, $bg_gc, $x, $y, $text, $n); } my $font_height = $ascent + $descent; sub prog_update { my($newfrac, $increm) = @_; my $oldfrac = $frac; $frac = $newfrac; my $str = int(100 * $frac) . "%"; my $text = [map([1, $_], split(//, $str))]; $text->[1][0] = -$font_height/10 if $text->[0][1] eq "1"; # kerning my $text_data = join("", map(pack("PiiL", $_->[1], 1, $_->[0], 0), @$text)); my $text_addr = unpack("I", pack("P", $text_data)); my $text_obj = \$text_addr; bless $text_obj, "X::TextItem"; my $realend = int($frac * ($length - 2 * $depth)) + $depth; if ($increm) { my $newend = $realend; my $oldend = int($oldfrac * ($length - 2 * $depth)) + $depth; my $x; my($left, $right); my $count = 0; if ($newend > $oldend) { $right = \$newend; $left = \$oldend; } else { $right = \$oldend; $left = \$newend; } if ($$left >= $text_x and $$left < $text_x + $text_wd) { $$left = $text_x + $text_wd - 1; $count++; } if ($$right >= $text_x and $$right < $text_x + $text_wd) { $$right = $text_x; $count++; } if ($count == 2) { # do nothing } elsif ($newend > $oldend) { if ($smooth_progress) { for ($x = $oldend; $x < $newend; $x++) { X::DrawLine($dpy, $prog_win, $fill_gc, $x, $depth => $x, $thickness - $depth - 1); } } else { X::FillRectangle($dpy, $prog_win, $fill_gc, $oldend, $depth, $newend - $oldend, $inner_thick); } } elsif ($newend < $oldend) { if ($smooth_progress) { for ($x = $oldend - 1; $x >= $newend; $x--) { X::DrawLine($dpy, $prog_win, $trough_gc, $x, $depth => $x, $thickness - $depth - 1); } } else { X::FillRectangle($dpy, $prog_win, $trough_gc, $newend, $depth, $oldend - $newend, $inner_thick); } } } else { X::FillRectangle($dpy, $prog_win, $fill_gc, $depth, $depth, $realend - $depth, $inner_thick); } my $end = clamp(0, $realend - $text_x, $text_wd); X::FillRectangle($dpy, $prog_pixmap, $fill_gc, 0, 0, $end, $inner_thick) if $end > 0; X::FillRectangle($dpy, $prog_pixmap, $trough_gc, $end, 0, $text_wd - $end, $inner_thick) if $end < $text_wd; my $wd = X::TextWidth($font, $str, length $str); paint_shaded_text($prog_pixmap, 1 + int(($text_wd - $wd) / 2), $text_baseline, $text_obj, scalar @$text); X::CopyArea($dpy, $prog_pixmap, $prog_win, $bg_gc, 0, 0, $text_wd, $inner_thick, $text_x, $depth); } X::MapWindow($dpy, $prog_win); X::MapWindow($dpy, $sbar_win); X::MapWindow($dpy, $main_win); my $fds = IO::Select->new(X::ConnectionNumber($dpy)); my $timeout = 0; my($slider_speed, $pointer_pos, $last_pos); my(%dirty); my $resize_pending = 0; # Since this program can't necessarily handle events as fast as the X # server can generate them, it's important to use some sort of `flow # control' to throw out excess events when we're behind. # For pointer motion events, this is accomplished by selecting # PointerMotionHint on the slider (see above), so that the server # never sends a sequence of motion events -- instead, it sends one, # which we throw away but use as our cue to query the pointer # position. The query_pointer is then a sign to the server that we'd # be willing to accept one more event, and so on. Notice that this # requires several round trips between the server and the client for # each motion, which in C programs is a source of performance # problems, but here the difference is lost in the noise (we also do a # round trip to calculate the width of the text when updating the # progress bar, which could be done on the client side the way Xlib # does). # Expose and ConfigureNotify (resize) events have the same problem, # though it's only noticeable if your window manager supports opaque # window movement or opaque resize, respectively (the latter is fairly # rare in X, perhaps because average X clients handle it fairly # poorly; I for one am quite envious of how smoothly windows resize in # Windows NT). We can't do anything to tell the server to only send us # one of these events, but the next best thing is to just ignore them # until there aren't any other events pending. (In some toolkits this # would be called `idle-loop' processing). It's always safe to ignore # intermediate resizes, but with expose events we can only do this # because we always redraw the whole window, instead of just the # newly-visible part. A more sophisticated approach would keep track # of the exposed region, either with a bounding box or some more # precise data structure, and then clip the drawing to that (either # client-side or using a clip mask in the GC). Of course, that almost # certainly wouldn't be a speed win, because it would be doing a lot # of work in perl to save a few iterations of highly optimized C in # the server. for (;;) { if ($timeout) { X::Flush($dpy); while (not $fds->can_read($timeout)) { slider_update(int $slider_speed, 1); $slider_speed += sign($slider_speed) * $accel; if ($slider_pos == $pos_min or $slider_pos == $pos_max) { $timeout = 0; last; } else { $timeout = $delay; } X::Flush($dpy); } } X::Flush($dpy); if (not $fds->can_read(0.001)) { if ($resize_pending) { $resize_pending = 0; $total_ht = max($total_ht, $base_ht); $length = $total_wd - 2 * $padding; $thickness = int(($total_ht - 3 * $padding + 1) / 2); $depth = int($relief_frac * $thickness) if $relief_frac; $inner_thick = $thickness - 2 * $depth; $thumb = $length / 3; X::ResizeWindow($dpy, $prog_win, $length, $thickness); $fontsize = int($font_frac * $thickness); # XXX - where is XFreeFont()? #X::FreeFont($dpy, $font); $font = X::LoadQueryFont($dpy, sprintf($fontname, $fontsize)); $fid = unpack("x4I", unpack("P8", pack("I", $$font))); X::SetFont($dpy, $bg_gc, $fid_obj); X::SetFont($dpy, $hilite_gc, $fid_obj); X::SetFont($dpy, $shadow_gc, $fid_obj); $text_wd = X::TextWidth($font, "100%", 4) + 4 + 2; $text_x = int(($length - $text_wd) / 2); X::TextExtents($font, "100%", 4, $dummy_int, $ascent, $descent, $dummy_charstruct_obj); $text_baseline = int(($thickness + $ascent - $descent) / 2) - $depth; $font_height = $ascent + $descent; # XXX - let me guess; same place as XFreeFont()? #X::FreePixmap($dpy, $prog_pixmap); $prog_pixmap = X::CreatePixmap($dpy, $prog_win, $text_wd, $inner_thick, $root_depth); X::MoveResizeWindow($dpy, $sbar_win, $padding, 2 * $padding + $thickness, $length, $thickness); $pos_min = $depth; $pos_max = $length - $thumb - $depth - 2 * $inner_thick; $slider_pos = $pos_min + $frac * ($pos_max - $pos_min); X::MoveResizeWindow($dpy, $slider_win, $slider_pos, $depth, $thumb + 2 * $inner_thick, $inner_thick); X::ResizeWindow($dpy, $lt_win, $inner_thick, $inner_thick); X::MoveResizeWindow($dpy, $rt_win, $thumb + $inner_thick, 0, $inner_thick, $inner_thick); } if ($dirty{$$prog_win}) { draw_slope($prog_win, 0, 0, $length, $thickness, $prog_relief); prog_update($frac, 0); $dirty{$$prog_win} = 0; } if ($dirty{$$sbar_win}) { draw_slope($sbar_win, 0, 0, $length, $thickness, $sbar_relief); $dirty{$$sbar_win} = 0; } if ($dirty{$$slider_win}) { draw_slope($slider_win, $inner_thick, 0, $thumb, $inner_thick, $slider_relief); paint_slope_circle($slider_win, $thumb / 2 + (2 - $dimple)/2*$inner_thick, (1 - $dimple) * $inner_thick / 2, $dimple * $inner_thick, $depth, $dimple_relief) if $dimple; $dirty{$$slider_win} = 0; } if ($dirty{$$lt_win}) { paint_arrow($lt_win, 0, 0, $inner_thick - 1, 3, $arrow_relief ^ $lt_state); $dirty{$$lt_win} = 0; } if ($dirty{$$rt_win}) { paint_arrow($rt_win, 0, 0, $inner_thick - 1, 1, $arrow_relief ^ $rt_state); $dirty{$$rt_win} = 0; } } my $e = X::Event::internal_new(0); X::NextEvent($dpy, $e); my $type = $e->type; if ($type == X::ClientMessage) { if (unpack("x28I", unpack("P32", pack("I", $$e))) == $$delete_atom) { exit; } } elsif ($type == X::ConfigureNotify) { my($wd, $ht) = unpack("x32ii", unpack("P40", pack("I", $$e))); if ($wd != $total_wd or $ht != $total_ht) { $resize_pending++; ($total_wd, $total_ht) = ($wd, $ht); } } elsif ($type == X::Expose) { bless $e, "X::Event::ExposeEvent"; next unless unpack("x36i", unpack("P40", pack("I", $$e))) == 0; my $id = $e->window; if ($$id == $$sbar_win) { if ($e->x < $depth or $e->y < $depth or $e->x + $e->width > $length - $depth or $e->y + $e->height > $thickness - $depth) { # In the scrollbar, we throw out exposures that don't # include the border (including all the ones caused by # moving the slider), since the server fills the # trough in with the window's background color # automatically. $dirty{$$sbar_win}++; } } else { $dirty{$$id}++; } } elsif ($type == X::ButtonPress) { bless $e, "X::Event::ButtonEvent"; my $id = $e->window; if ($$id == $$slider_win) { $pointer_pos = $slider_pos; $last_pos = unpack("x40i", unpack("P44", pack("I", $$e))); } elsif ($$id == $$lt_win) { next if 2*abs($e->y - $inner_thick / 2) > $e->x; $lt_state = $arrow_change; slider_update(-1, 1); paint_arrow($lt_win, 0, 0, $inner_thick - 1, 3, $arrow_relief ^ $lt_state); $slider_speed = -1; $timeout = $initial_delay; } elsif ($$id == $$rt_win) { next if 2*abs($e->y - $inner_thick / 2) > $inner_thick - $e->x; $rt_state = $arrow_change; slider_update(1, 1); paint_arrow($rt_win, 0, 0, $inner_thick - 1, 1, $arrow_relief ^ $rt_state); $slider_speed = 1; $timeout = $initial_delay; } } elsif ($type == X::MotionNotify) { if ($ {$e->window} == $$slider_win and defined $last_pos) { my($dummy_win, $root_x); $dummy_win = X::Window->nil; X::QueryPointer($dpy, $slider_win, $dummy_win, $dummy_win, $root_x, $dummy_int, $dummy_int, $dummy_int, $dummy_int); $pointer_pos += $root_x - $last_pos; slider_update($pointer_pos - $slider_pos, 0); $last_pos = $root_x } } elsif ($type == X::ButtonRelease) { bless $e, "X::Event::ButtonEvent"; my $id = $e->window; if ($$id == $$slider_win and defined $last_pos) { my $root_x = unpack("x40i", unpack("P44", pack("I", $$e))); slider_update($root_x - $last_pos, 0); undef $last_pos; } elsif ($$id == $$lt_win) { $lt_state = 0; paint_arrow($lt_win, 0, 0, $inner_thick - 1, 3, $arrow_relief ^ $lt_state); $timeout = 0; } elsif ($$id == $$rt_win) { $rt_state = 0; paint_arrow($rt_win, 0, 0, $inner_thick - 1, 1, $arrow_relief ^ $rt_state); $timeout = 0; } } } X11-Protocol-0.56/eg/widgets3.pl0000644000175000017500000005174510512254520014741 0ustar smccsmcc#!/usr/bin/perl use X11::Window; use X11::Constants qw(Exposure_m ButtonPress_m ButtonRelease_m ButtonMotion_m PointerMotionHint_m StructureNotify_m Expose ButtonPress ButtonRelease MotionNotify ClientMessage ConfigureNotify Convex); use IO::Select; use strict; sub clamp { $_[1] < $_[0] ? $_[0] : $_[1] > $_[2] ? $_[2] : $_[1] } sub sign { $_[0] ? $_[0] / abs($_[0]) : 0 } sub min { $_[0] <= $_[1] ? $_[0] : $_[1] } sub max { $_[0] >= $_[1] ? $_[0] : $_[1] } # Look and feel parameters to play with: my $length = 300; my $thumb = 100; my $thickness = 20; my $padding = 5; my $depth = 2; my $relief_frac = .1; # relief area / thickness, 0 => relief doesn't scale my $trough_rgb = [0xa3a3, 0xa3a3, 0xb3b3]; my $bg_rgb = [0xc6c6, 0xc6c6, 0xd6d6]; my $fill_rgb = [0xb6b6, 0x3030, 0x6060]; my $shade = .5; # 0 => shadows black, hilights white; 1 => no shading # for relief, 0 => raised, 1 => sunk, 2 => ridge, 3 => groove my $prog_relief = 1; my $sbar_relief = 1; my $slider_relief = 0; my $arrow_relief = 0; my $dimple_relief = 1; my $arrow_change = 1; # these bits will flip when pressed my $dimple = .3; # size / scrollbar thickness, 0 for none my $font_frac = .6; # text fills 60% of the height of the progresss bar # Note that the progress bar prefers scalable fonts, so that it can keep # the same proportions when the window is resized. Depending on how modern # your X installation is, this may be nontrivial. # * The best case is if you have a font that includes both hand-edited # bitmaps for small sizes and outlines that can be scaled arbitrarily. # All recent X releases come with bitmaps provided by Adobe for Helvetica, # so if you also have a corresponding Type 1 outline, that's the best # choice: # (bitmaps for sizes 8, 10, 11, 12, 14, 17, 18, 20, 24, 25, and 34) #my $fontname = "-adobe-helvetica-medium-r-normal--%d-*-*-*-*-*-iso8859-1"; # (If you're using Debian Linux like me, you'll need to install the # gsfonts and gsfonts-x11 packages to get the Type 1 versions. The # outline isn't the genuine Adobe version; it's a free clone that # can also be accessed directly (without Adobe's bitmaps) as) my $fontname = "-urw-nimbus sans l-regular-r-normal--%d-*-*-*-*-*-iso8859-1"; # * Recent X releases also include some scalable fonts, though not any # sans-serif ones. In the following, adobe-utopia can be replaced by # adobe-courier, bitstream-courier, or bitstream-charter: #my $fontname = "-adobe-utopia-medium-r-normal--%d-*-*-*-*-*-iso8859-1"; # * Also, recent X servers can scale bitmaps, though the results are usually # fairly ugly. # * If your X system predates XLFD (the 14-hyphen names), your font # selection is probably pretty miniscule; try to pick something around # 12 pixels: #my $fontname = "7x13"; my $cursor = "top_left_arrow"; my $initial_delay = 0.15; # secs my $delay = 0.05; # secs my $accel = 0.5; my $smooth_progress = 0; # and un-smooth scrollbar my $text_shading_style = 1; # 0 => diagonalish, 1 => squarish # +--------------------------------------------------+ # | main_win ^v padding [bg] | # | +----------------------------------------------+ | # | |#prog_win########### ^ |<| # | |##########[fill]#### :thickness |>| # | |#################### : |:| # | |<-------- length -----------:---------------->|:| # | |#################### V [trough] |:| # | +----------------------------------------------+:| # | ^v padding :| # | +----------------------------------------------+:| # | | sbar_win +------------------------+ |:| # |<| |+----+ slider_win +----+| [trough] |:| # |>|<-slider->|| <| |<-lt_win | |> || |:| # |:| pos |+----+ rt_win->+----+| |:| # |:| +------------------------+ |:| # |:+----------:------------------------:----------+:| # |: : ^v padding : :| # +:-----------:------------------------:-----------:+ # : : : : # : : : : # padding :<------- thumb -------->: padding my($main_win, $prog_win, $sbar_win, $slider_win, $lt_win, $rt_win); my($trough_gc, $bg_gc, $fill_gc, $hilite_gc, $shadow_gc); my $frac = 0; my $d = X11::Display->new; my $s = $d->default_screen; my $cmap = $s->default_cmap; my $bg = $cmap->color->rgb(@$bg_rgb)->alloc; my $trough = $cmap->color->rgb(@$trough_rgb)->alloc; my $shadow = $cmap->color->rgb(map($_ * $shade, @$bg_rgb))->alloc; my $hilite = $cmap->color->rgb(map(65535 - $shade * (65535 - $_), @$bg_rgb))->alloc; my $delete_atom = $d->atom('WM_DELETE_WINDOW')->id; my $fontsize = $font_frac * $thickness; my $font = $d->font(sprintf($fontname, $fontsize)); my $total_wd = 2*$padding + $length; my $base_wd = 2*$padding + 2*$depth + 4; my $total_ht = 3*$padding + 2*$thickness; my $base_ht = 3*$padding + 4*$depth + 3; $main_win = $s->root->new_subwin(-wd => $total_wd, -ht => $total_ht, -cursor => $d->cursor(-shape => $cursor), -bg => $bg, -event_mask => StructureNotify_m); $main_win->prop('WM_ICON_NAME' => "widgets") ->prop('WM_NAME' => "Raw X widgets (X11::Window)") ->prop('WM_CLASS' => "widgets\0Widgets") ->prop('WM_NORMAL_HINTS' => pack("Lx16llx16llllllx4", 8|16|128|256, $base_wd, $base_ht, 3, 2, 1000, 1, $base_wd, $base_ht), -type => 'WM_SIZE_HINTS', -format => 32) ->prop('WM_HINTS' => pack("LLLx24", 1|2, 1, 1), -type => 'WM_HINTS', -format => 32) ->prop('WM_PROTOCOLS' => pack("L", $delete_atom), -type => 'ATOM', -format => 32); $prog_win = $main_win->new_subwin(-x => $padding, -y => $padding, -wd => $length, -ht => $thickness, -bg => $trough, -event_mask => Exposure_m); $sbar_win = $main_win->new_subwin(-x => $padding, -y => 2*$padding + $thickness, -wd => $length, -ht => $thickness, -bg => $trough, -event_mask => Exposure_m); $bg_gc = $main_win->gc(-fg => $bg); $shadow_gc = $main_win->gc(-fg => $shadow); $hilite_gc = $main_win->gc(-fg => $hilite); # floor : ceil :: int : away sub away { sign($_[0]) * int(abs($_[0]) + .9999) } sub draw_slope_poly { my($win, $relief, $dep, $fill, @p) = @_; if ($relief > 1) { draw_slope_poly($win, $relief ^ 3, $dep, $fill, @p); $relief &= 1; $dep /= 2; $fill = 0; } my($tl, $br) = ($hilite_gc, $shadow_gc)[$relief, !$relief]; my(@gc, @ip); $#gc = $#ip = $#p; my $j; for $j (-2 .. $#p - 2) { my($ix, $iy) = ($p[$j+1][0] - $p[$j][0], $p[$j+1][1] - $p[$j][1]); $gc[$j] = $ix > $iy ? $tl : $ix < $iy ? $br : $ix > 0 ? $tl : $br; my($ox, $oy) = ($p[$j+2][0] - $p[$j+1][0], $p[$j+2][1] - $p[$j+1][1]); if ($ix*$oy > $iy*$ox) { $ix = -$ix; $iy = -$iy; } else { $ox = -$ox; $oy = -$oy; } my($in) = sqrt($ix*$ix + $iy*$iy); $ix /= $in; $iy /= $in; my($on) = sqrt($ox*$ox + $oy*$oy); $ox /= $on; $oy /= $on; my($mx, $my) = (($ix + $ox)/2, ($iy + $oy)/2); my($mn) = max(abs($mx), abs($my)); $mx /= $mn; $my /= $mn; $ip[$j+1][0] = $p[$j+1][0] + away(($dep - 1) * $mx); $ip[$j+1][1] = $p[$j+1][1] + away(($dep - 1) * $my); } $fill->fill_poly(-targ => $win, -points => [map(@{$ip[$_]}, 0..$#p)]) if $fill; for $j (-1 .. $#p - 1) { $gc[$j]->fill_poly(-targ => $win, -shape => Convex, -points => [$p[$j], $ip[$j], $ip[$j + 1], $p[$j + 1]]); $gc[$j]->draw_line(-targ => $win, -line => [@{$p[$j]}, @{$p[$j+1]}]); $gc[$j]->draw_line(-targ => $win, -line => [@{$ip[$j]}, @{$ip[$j+1]}]); } for $j (-1 .. $#p - 1) { $bg_gc->draw_line(-targ => $win, -line => [@{$p[$j+1]}, @{$ip[$j+1]}]) if $gc[$j] != $gc[$j + 1]; } } sub draw_slope { my($win, $x, $y, $wd, $ht, $relief) = @_; draw_slope_poly($win, $relief, $depth, 0, [$x, $y], [$x + $wd - 1, $y], [$x + $wd - 1, $y + $ht - 1], [$x, $y + $ht - 1]); } sub paint_arrow { my($win, $x, $y, $s, $dir, $relief) = @_; my @s = ($s / 2, $s, $s / 2, 0); my @p = ([$x + $s[$dir], $y + $s[$dir - 1]], ($dir & 1 xor $dir & 2) ? [$x, $y] : [$x + $s, $y + $s], ($dir & 2) ? [$x + $s, $y] : [$x, $y + $s]); @p[1,2] = @p[2,1] if $dir & 1; draw_slope_poly($win, $relief, $depth, $bg_gc, @p); } sub pi () { 3.14159265358979 } sub paint_slope_circle { my($win, $x, $y, $s, $dep, $relief) = @_; my($tl, $br) = ($hilite_gc, $shadow_gc)[$relief & 1, !($relief & 1)]; my @outer = (-x => $x, -y => $y, -wd => $s, -ht => $s); my @inner = (-x => $x + $dep, -y => $y + $dep, -wd => $s - 2*$dep, -ht => $s - 2*$dep); my @tl = (-angle1 => 0.2 * pi, -angle2 => 0.9 * pi); my @br = (-angle1 => 1.2 * pi, -angle2 => 0.9 * pi); $bg_gc->fill_oval(-targ => $win, @outer); $tl->fill_arc(-targ => $win, @outer, @tl); $tl->draw_arc(-targ => $win, @outer, @tl); $tl->draw_arc(-targ => $win, @inner, @tl); $br->fill_arc(-targ => $win, @outer, @br); $br->draw_arc(-targ => $win, @outer, @br); $br->draw_arc(-targ => $win, @inner, @br); if ($relief & 2) { my @middle = (-x => $x + $depth/2, -y => $y + $depth/2, -wd => $s - $depth, -ht => $s - $depth); $br->fill_arc(-targ => $win, @middle, @tl); $tl->fill_arc(-targ => $win, @middle, @br); } $bg_gc->fill_oval(-targ => $win, @inner); } my $inner_thick = $thickness - 2 * $depth; my $slider_pos = $depth; my $pos_min = $depth; my $pos_max = $length - $thumb - $depth - 2 * $inner_thick; $slider_win = $sbar_win->new_subwin(-x => $slider_pos, -y => $depth, -wd => $thumb + 2 * $inner_thick, -ht => $inner_thick, -bg => $bg, -event_mask => Exposure_m | ButtonPress_m | ButtonRelease_m | ButtonMotion_m | PointerMotionHint_m); $lt_win = $slider_win->new_subwin(-x => 0, -y => 0, -wd => $inner_thick, -ht => $inner_thick, -bg => $trough, -event_mask => Exposure_m | ButtonPress_m | ButtonRelease_m); $rt_win = $slider_win->new_subwin(-x => $thumb + $inner_thick, -y => 0, -wd => $inner_thick, -ht => $inner_thick, -bg => $trough, -event_mask => Exposure_m | ButtonPress_m | ButtonRelease_m); my $lt_state = 0; my $rt_state = 0; $lt_win->map; $rt_win->map; $slider_win->map; sub slider_update { my($delta, $warp) = @_; my $old_pos = $slider_pos; $slider_pos = clamp($pos_min, $slider_pos + $delta, $pos_max); $d->warp_pointer(-x => $slider_pos - $old_pos, -y => 0) if $warp; $slider_win->pos($slider_pos, $depth); prog_update(($slider_pos - $pos_min) / ($pos_max - $pos_min), 1); } my $text_wd = $font->text("100%")->width + 4 + 2; my $text_x = int(($length - $text_wd) / 2); my $text_baseline = int(($thickness + $font->ascent - $font->descent)/2) - $depth; my $prog_pixmap = $prog_win->pixmap(-wd => $text_wd, -ht => $inner_thick); $trough_gc = $prog_pixmap->gc(-font => $font, -fg => $trough); $fill_gc = $prog_pixmap->gc(-fg => $cmap->color->rgb(@$fill_rgb)->alloc); $shadow_gc->font($font); $hilite_gc->font($font); $bg_gc->font($font); sub paint_shaded_text { my($drawable, $x, $y, $text) = @_; my @args = (-target => $drawable, -text => $text); my($br_gc, $tl_gc) = ($shadow_gc, $hilite_gc); $br_gc->draw_str(@args, -x => $x + 1, -y => $y + 1) if $text_shading_style; $br_gc->draw_str(@args, -x => $x, -y => $y + 1); $br_gc->draw_str(@args, -x => $x + 1, -y => $y); $tl_gc->draw_str(@args, -x => $x - 1, -y => $y - 1) if $text_shading_style; $tl_gc->draw_str(@args, -x => $x, -y => $y - 1); $tl_gc->draw_str(@args, -x => $x - 1, -y => $y); $bg_gc->draw_str(@args, -x => $x, -y => $y); } sub prog_update { my($newfrac, $increm) = @_; my $oldfrac = $frac; $frac = $newfrac; my $str = int(100 * $frac) . "%"; my $text = [map([1, $_], split(//, $str))]; $text->[1][0] = -$font->height/10 if $text->[0][1] eq "1"; # kerning my $realend = int($frac * ($length - 2 * $depth)) + $depth; if ($increm) { my $newend = $realend; my $oldend = int($oldfrac * ($length - 2 * $depth)) + $depth; my $x; my($left, $right); my $count = 0; if ($newend > $oldend) { $right = \$newend; $left = \$oldend; } else { $right = \$oldend; $left = \$newend; } if ($$left >= $text_x and $$left < $text_x + $text_wd) { $$left = $text_x + $text_wd - 1; $count++; } if ($$right >= $text_x and $$right < $text_x + $text_wd) { $$right = $text_x; $count++; } if ($count == 2) { # do nothing } elsif ($newend > $oldend) { if ($smooth_progress) { for ($x = $oldend; $x < $newend; $x++) { $fill_gc->draw_line(-targ => $prog_win, -x1 => $x, -y1 => $depth, -x2 => $x, -y2 => $thickness - $depth - 1); } } else { $fill_gc->fill_rect(-targ => $prog_win, -x => $oldend, -y => $depth, -wd => ($newend - $oldend), -ht => $inner_thick); } } elsif ($newend < $oldend) { if ($smooth_progress) { for ($x = $oldend - 1; $x >= $newend; $x--) { $trough_gc->draw_line(-targ => $prog_win, -x1 => $x, -y1 => $depth, -x2 => $x, -y2 => $thickness - $depth - 1); } } else { $trough_gc->fill_rect(-targ => $prog_win, -x => $newend, -y => $depth, -wd => ($oldend - $newend), -ht => $inner_thick); } } } else { $fill_gc->fill_rect(-targ => $prog_win, -x => $depth, -y => $depth, -wd => $realend - $depth, -ht => $inner_thick); } my $end = clamp(0, $realend - $text_x, $text_wd); $fill_gc->fill_rect(-x => 0, -y => 0, -wd => $end, -ht => $inner_thick) if $end > 0; $trough_gc->fill_rect(-x => $end, -y => 0, -wd => $text_wd - $end, -ht => $inner_thick) if $end < $text_wd; paint_shaded_text($prog_pixmap, 1 + int(($text_wd - $font->text($str)->width) / 2), $text_baseline, $text); $bg_gc->copy_area(-src => $prog_pixmap, -dest => $prog_win, -dest_x => $text_x, -dest_y => $depth); } $prog_win->map; $sbar_win->map; $main_win->map; my $fds = IO::Select->new($d->filehandle); my $timeout = 0; my($slider_speed, $pointer_pos, $last_pos); my(%dirty); my $resize_pending = 0; # Since this program can't necessarily handle events as fast as the X # server can generate them, it's important to use some sort of `flow # control' to throw out excess events when we're behind. # For pointer motion events, this is accomplished by selecting # PointerMotionHint on the slider (see above), so that the server # never sends a sequence of motion events -- instead, it sends one, # which we throw away but use as our cue to query the pointer # position. The query_pointer is then a sign to the server that we'd # be willing to accept one more event, and so on. Notice that this # requires several round trips between the server and the client for # each motion, which in C programs is a source of performance # problems, but here the difference is lost in the noise (we also do a # round trip to calculate the width of the text when updating the # progress bar, which could be done on the client side the way Xlib # does). # Expose and ConfigureNotify (resize) events have the same problem, # though it's only noticeable if your window manager supports opaque # window movement or opaque resize, respectively (the latter is fairly # rare in X, perhaps because average X clients handle it fairly # poorly; I for one am quite envious of how smoothly windows resize in # Windows NT). We can't do anything to tell the server to only send us # one of these events, but the next best thing is to just ignore them # until there aren't any other events pending. (In some toolkits this # would be called `idle-loop' processing). It's always safe to ignore # intermediate resizes, but with expose events we can only do this # because we always redraw the whole window, instead of just the # newly-visible part. A more sophisticated approach would keep track # of the exposed region, either with a bounding box or some more # precise data structure, and then clip the drawing to that (either # client-side or using a clip mask in the GC). Of course, that almost # certainly wouldn't be a speed win, because it would be doing a lot # of work in perl to save a few iterations of highly optimized C in # the server. for (;;) { if ($timeout) { while (not $fds->can_read($timeout)) { slider_update(int $slider_speed, 1); $slider_speed += sign($slider_speed) * $accel; if ($slider_pos == $pos_min or $slider_pos == $pos_max) { $timeout = 0; last; } else { $timeout = $delay; } } } if (not $fds->can_read(0.001)) { if ($resize_pending) { $resize_pending = 0; $total_ht = max($total_ht, $base_ht); $length = $total_wd - 2 * $padding; $thickness = int(($total_ht - 3 * $padding) / 2 + 0.5); $depth = int($relief_frac * $thickness) if $relief_frac; $inner_thick = $thickness - 2*$depth; $thumb = $length / 3; $prog_win->size($length, $thickness); $fontsize = int($font_frac * $thickness); $font->close; $font = $d->font(sprintf($fontname, $fontsize)); map($_->font($font), $bg_gc, $hilite_gc, $shadow_gc); $text_wd = $font->text("100%")->width + 4 + 2; $text_x = int(($length - $text_wd) / 2); $text_baseline = int(($thickness + $font->ascent - $font->descent)/2) - $depth; $prog_pixmap->free; $prog_pixmap = $prog_win->pixmap(-wd => $text_wd, -ht => $inner_thick); $trough_gc->target($prog_pixmap); $fill_gc->target($prog_pixmap); $sbar_win->pos($padding, 2*$padding + $thickness); $sbar_win->size($length, $thickness); $pos_min = $depth; $pos_max = $length - $thumb - $depth - 2 * $inner_thick; $slider_pos = $pos_min + $frac * ($pos_max - $pos_min); $slider_win->pos($slider_pos, $depth); $slider_win->size($thumb + 2 * $inner_thick, $inner_thick); $lt_win->size($inner_thick, $inner_thick); $rt_win->pos($thumb + $inner_thick, 0); $rt_win->size($inner_thick, $inner_thick); } if ($dirty{$prog_win->id}) { draw_slope($prog_win, 0, 0, $length, $thickness, $prog_relief); prog_update($frac, 0); $dirty{$prog_win->id} = 0; } if ($dirty{$sbar_win->id}) { draw_slope($sbar_win, 0, 0, $length, $thickness, $sbar_relief); $dirty{$sbar_win->id} = 0; } if ($dirty{$slider_win->id}) { draw_slope($slider_win, $inner_thick, 0, $thumb, $inner_thick, $slider_relief); paint_slope_circle($slider_win, $thumb / 2 + (2 - $dimple)/2*$inner_thick, (1 - $dimple) * $inner_thick / 2, $dimple * $inner_thick, $depth, $dimple_relief) if $dimple; $dirty{$slider_win->id} = 0; } if ($dirty{$lt_win->id}) { paint_arrow($lt_win, 0, 0, $inner_thick - 1, 3, $arrow_relief ^ $lt_state); $dirty{$lt_win->id} = 0; } if ($dirty{$rt_win->id}) { paint_arrow($rt_win, 0, 0, $inner_thick - 1, 1, $arrow_relief ^ $rt_state); $dirty{$rt_win->id} = 0; } } my $e = $d->next_event; if ($e->code == ClientMessage and ($e->longs)[0] == $delete_atom) { exit; } elsif($e->code == ConfigureNotify) { if ($e->wd != $total_wd or $e->ht != $total_ht) { $resize_pending++; ($total_wd, $total_ht) = ($e->wd, $e->ht); } } elsif ($e->code == Expose) { next unless $e->count == 0; my $id = $e->window->id; if ($id == $sbar_win->id) { if ($e->x < $depth or $e->y < $depth or $e->x + $e->wd > $length - $depth or $e->y + $e->ht > $thickness - $depth) { # In the scrollbar, we throw out exposures that don't # include the border (including all the ones caused by # moving the slider), since the server fills the # trough in with the window's background color # automatically. $dirty{$sbar_win->id}++; } } else { $dirty{$id}++; } } elsif ($e->code == ButtonPress) { my $id = $e->window->id; if ($id == $slider_win->id) { $pointer_pos = $slider_pos; $last_pos = $e->root_x; } elsif ($id == $lt_win->id) { next if 2*abs($e->y - $inner_thick / 2) > $e->x; $lt_state = $arrow_change; slider_update(-1, 1); paint_arrow($lt_win, 0, 0, $inner_thick - 1, 3, $arrow_relief ^ $lt_state); $slider_speed = -1; $timeout = $initial_delay; } elsif ($id == $rt_win->id) { next if 2*abs($e->y - $inner_thick / 2) > $inner_thick - $e->x; $rt_state = $arrow_change; slider_update(1, 1); paint_arrow($rt_win, 0, 0, $inner_thick - 1, 1, $arrow_relief ^ $rt_state); $slider_speed = 1; $timeout = $initial_delay; } } elsif ($e->code == MotionNotify) { my $id = $e->window->id; if ($id == $slider_win->id and defined $last_pos) { my %e2 = $slider_win->query_pointer; $pointer_pos += $e2{'root_x'} - $last_pos; slider_update($pointer_pos - $slider_pos, 0); $last_pos = $e2{'root_x'}; } } elsif ($e->code == ButtonRelease) { my $id = $e->window->id; if ($id == $slider_win->id and defined $last_pos) { slider_update($e->root_x - $last_pos, 0); undef $last_pos; } elsif ($id == $lt_win->id) { $lt_state = 0; paint_arrow($lt_win, 0, 0, $inner_thick - 1, 3, $arrow_relief ^ $lt_state); $timeout = 0; } elsif ($id == $rt_win->id) { $rt_state = 0; paint_arrow($rt_win, 0, 0, $inner_thick - 1, 1, $arrow_relief ^ $rt_state); $timeout = 0; } } } X11-Protocol-0.56/eg/long-run.pl0000644000175000017500000000613307623615735014762 0ustar smccsmcc#!/usr/bin/perl use X11::Protocol; use X11::Protocol::Constants qw(InputOutput CopyFromParent Replace Exposure_m); use IO::Select; use strict; $| = 1; my $big_size = 1000; my $small_wd = 50; my $small_ht = 20; my $X = X11::Protocol->new; my $cmap = $X->default_colormap; my($bg_pixel,) = $X->AllocColor($cmap, (0xdddd, 0xdddd, 0xdddd)); my $main_win = $X->new_rsrc; $X->CreateWindow($main_win, $X->root, InputOutput, CopyFromParent, CopyFromParent, (0, 0), $big_size, $big_size, 0, 'background_pixel' => $bg_pixel); $X->ChangeProperty($main_win, $X->atom('WM_ICON_NAME'), $X->atom('STRING'), 8, Replace, "long run"); $X->ChangeProperty($main_win, $X->atom('WM_NAME'), $X->atom('STRING'), 8, Replace, "Long-running X11::Protocol test"); $X->ChangeProperty($main_win, $X->atom('WM_CLASS'), $X->atom('STRING'), 8, Replace, "longrun\0LongRun"); $X->ChangeProperty($main_win, $X->atom('WM_NORMAL_HINTS'), $X->atom('WM_SIZE_HINTS'), 32, Replace, pack("Lx16llx16llllllx4", 8|16|128|256, $big_size, $big_size, 1, 1, 1, 1, $big_size, $big_size)); $X->ChangeProperty($main_win, $X->atom('WM_HINTS'), $X->atom('WM_HINTS'), 32, Replace, pack("LLLx24", 1|2, 1, 1)); my $delete_atom = $X->atom('WM_DELETE_WINDOW'); $X->ChangeProperty($main_win, $X->atom('WM_PROTOCOLS'), $X->atom('ATOM'), 32, Replace, pack("L", $delete_atom)); my $text_gc = $X->new_rsrc; my($text_pixel,) = $X->AllocColor($cmap, (0x0000, 0x0000, 0x0000)); my $font = $X->new_rsrc; $X->OpenFont($font, "fixed"); $X->CreateGC($text_gc, $main_win, 'foreground' => $text_pixel, 'font' => $font); $X->MapWindow($main_win); my $fds = IO::Select->new($X->connection->fh); my $num_cols = $big_size / $small_wd; my @cols; my %visible; sub label { my($win) = @_; $X->PolyText8($win, $text_gc, 4, ($small_ht + 10) / 2, [0, sprintf("%x", $win)]); } sub handle_event { my(%e) = @_; if ($e{'name'} eq "Expose") { my $win = $e{'window'}; label($win) if $visible{$win}; } } $X->{'event_handler'} = \&handle_event; my $last_id; for (;;) { while ($fds->can_read(0)) { $X->handle_input; } for (my $x = 0; $x < $big_size; $x += $small_wd) { my @column; for (my $y = 0; $y < $big_size; $y += $small_ht) { # my($rand_pixel,) = # $X->AllocColor($cmap, (rand(65536), rand(65535), rand(65535))); my $rand_pixel = rand(2**32); my $win = $X->new_rsrc; if ($win != $last_id + 1) { print "x"; } $last_id = $win; $X->CreateWindow($win, $main_win, InputOutput, CopyFromParent, CopyFromParent, ($x, $y), $small_wd, $small_ht, 1, 'background_pixel' => $rand_pixel, 'event_mask' => Exposure_m); if (rand() < 0.001) { $X->MapWindow($win); push @column, $win if rand() < 0.9; $visible{$win} = 1; label($win); } else { $X->DestroyWindow($win); } } push @cols, [@column]; if (@cols >= $num_cols) { for my $win (@{shift @cols}) { delete $visible{$win}; $X->DestroyWindow($win); } } } print "."; } X11-Protocol-0.56/eg/render-test.pl0000644000175000017500000001547510027735315015453 0ustar smccsmcc#!/usr/bin/perl use X11::Protocol; use strict; use IO::Select; my $X = new X11::Protocol; $X->init_extension("RENDER") or die; my($mono1, $rgb24, $rgba32); my($formats, $screens, $subpixels) = $X->RenderQueryPictFormats(); print "Formats:\n"; for my $f (@$formats) { print " ", join(", ", @$f), "\n"; $mono1 = $f->[0] if $f->[2] == 1 and $f->[10] == 1; $rgb24 = $f->[0] if $f->[2] == 24 and $f->[3] == 16 and $f->[5] == 8 and $f->[7] == 0; $rgba32 = $f->[0] if $f->[2] == 32 and $f->[3] == 16 and $f->[5] == 8 and $f->[7] == 0 and $f->[9] == 24; } print "Screens:\n"; for my $s (@$screens) { my @s = @$s; print " Fallback: $s[0]\n"; shift @s; for my $d (@s) { my @d = @$d; print " Depth: $d[0]\n"; shift @d; for my $v (@d) { print " @$v\n"; } } } print "Subpixels:\n"; for my $sp (@$subpixels) { print " $sp\n"; } my $win = $X->new_rsrc; $X->CreateWindow($win, $X->root, 'InputOutput', $X->root_depth, 'CopyFromParent', (0, 0), 500, 500, 4, 'background_pixel' => $X->white_pixel, 'bit_gravity' => 'Static', 'event_mask' => $X->pack_event_mask('Exposure', 'KeyPress', 'ButtonPress', 'StructureNotify')); my($filters, $aliases) = $X->RenderQueryFilters($win); print "Aliases: " . join(" ", @$aliases), "\n"; print "Filters: " . join(" ", @$filters), "\n"; $X->MapWindow($win); my $picture = $X->new_rsrc; $X->RenderCreatePicture($picture, $win, $rgb24); $X->RenderChangePicture($picture, 'poly_mode' => 'Imprecise'); $X->RenderSetPictureClipRectangles($picture, 0, 0, [50, 0, 400, 50], [0, 50, 500, 400], [50, 450, 400, 50]); my $pixmap = $X->new_rsrc; $X->CreatePixmap($pixmap, $win, 32, 1000, 1000); my $pix_pict = $X->new_rsrc; $X->RenderCreatePicture($pix_pict, $pixmap, $rgba32); $X->RenderFillRectangles('Src', $pix_pict, [0xffff, 0, 0, 0x8000], [0, 0, 1000, 1000]); my $pixmap2 = $X->new_rsrc; $X->CreatePixmap($pixmap2, $win, 32, 1000, 1000); my $pix_pict2 = $X->new_rsrc; $X->RenderCreatePicture($pix_pict2, $pixmap2, $rgba32); $X->RenderSetPictureFilter($pix_pict2, "bilinear"); $X->RenderSetPictureFilter($picture, "bilinear"); my $cursor1_pixmap = $X->new_rsrc; $X->CreatePixmap($cursor1_pixmap, $win, 32, 32, 32); my $cursor1_pict = $X->new_rsrc; $X->RenderCreatePicture($cursor1_pict, $cursor1_pixmap, $rgba32); $X->RenderFillRectangles('Src', $cursor1_pict, [0, 0, 0xffff, 0xffff], [0, 0, 32, 32]); $X->RenderFillRectangles('Src', $cursor1_pict, [0, 0, 0, 0x4000], [4, 4, 24, 24]); my $cursor1 = $X->new_rsrc; $X->RenderCreateCursor($cursor1, $cursor1_pict, 16, 16); my $cursor2_pixmap = $X->new_rsrc; $X->CreatePixmap($cursor2_pixmap, $win, 32, 32, 32); my $cursor2_pict = $X->new_rsrc; $X->RenderCreatePicture($cursor2_pict, $cursor2_pixmap, $rgba32); $X->RenderFillRectangles('Src', $cursor2_pict, [0, 0x8000, 0xffff, 0xffff], [0, 0, 32, 32]); $X->RenderFillRectangles('Src', $cursor2_pict, [0, 0, 0, 0x4000], [4, 4, 24, 24]); my $cursor2 = $X->new_rsrc; $X->RenderCreateCursor($cursor2, $cursor2_pict, 16, 16); my $anim_cursor = $X->new_rsrc; $X->RenderCreateAnimCursor($anim_cursor, [$cursor1, 500], [$cursor2, 100]); $X->ChangeWindowAttributes($win, 'cursor' => $anim_cursor); my $fixed_gs = $X->new_rsrc; $X->RenderCreateGlyphSet($fixed_gs, $mono1); my $fixed_font = $X->new_rsrc; $X->OpenFont($fixed_font, "fixed"); sub pad_bit { my($bits) = @_; # return join("", map($_ ? "\x80\x00\x00\x00" : "\x00\xff\xff\xff", # unpack("b*", $bits))); return join("", map($_ . "\0\0\0", split(//, $bits))); # return $bits; } my @glyphs = ([0, 8, 8, 0, 0, 9, 0, pad_bit("\x00\x00\x00\x00\x00\x00\x00\x00")], [1, 8, 8, 0, 0, 9, 0, pad_bit("\xff\xff\xff\xff\xff\xff\xff\xff")], [2, 8, 8, 0, 0, 9, 0, pad_bit("\xff\x81\x81\x81\x81\x81\x81\xff")]); $X->RenderAddGlyphs($fixed_gs, $glyphs[0]); $X->RenderAddGlyphs($fixed_gs, $glyphs[1]); $X->RenderAddGlyphs($fixed_gs, $glyphs[2]); $X->event_handler('queue'); my $fds = IO::Select->new($X->connection->fh); sub draw { $X->RenderFillRectangles('Src', $picture, [(0xffff)x4], [0, 0, 500, 500]); $X->RenderFillRectangles('Src', $pix_pict, [0xffff, 0, 0, 0x8000], [0, 0, 1000, 1000]); $X->RenderFillRectangles('Src', $pix_pict2, [0, 0x8000, 0, 0x8000], [0, 0, 1000, 1000]); my @rects; for my $i (0 .. 11) { for my $j (0 .. 11) { push @rects, [40 * $i, 40 * $j, 35, 35]; } } $X->RenderFillRectangles('Over', $picture, [0, 0, 0xffff, 0x8000], @rects); @rects = (); for my $i (0 .. 11) { for my $j (0 .. 11) { push @rects, [40 * $i + 23, 40 * $j + 23, 15, 15]; } } $X->RenderFillRectangles('Src', $picture, [0, 0, 0xffff, 0x8000], @rects); $X->RenderTriangles('Over', $pix_pict, 500, 500, $picture, 'None', [(250, 100), (100, 350), (400, 350)]); $X->RenderTrapezoids('Over', $pix_pict, 240, 0, $picture, 'None', [100, 200, ((240, 0),(0,500)),((500,500),(260,0))]); my @strip; for my $i (0 .. 40) { push @strip, [300 + 100*sin($i/10), 300 + 100*cos($i/10)]; push @strip, [300 + 120*sin($i/10 + .05), 300 + 120*cos($i/10 + .05)]; } $X->RenderTriStrip('Over', $pix_pict2, 500, 500, $picture, 'None', @strip); my @spiral; for my $i (0 .. 40) { push @spiral, [150 + (50 + $i*2)*sin($i/10), 300 + (50 + $i*2)*cos($i/10)]; } $X->RenderTriFan('Over', $pix_pict2, 500, 500, $picture, 'None', [150, 300], @spiral); $X->RenderFillRectangles('Src', $pix_pict2, [0, 0, 0, 0x8000], [0, 0, 1000, 1000]); $X->RenderTriangles('Atop', $pix_pict, 500, 500, $pix_pict2, 'None', [(125, 50), (50, 175), (200, 175)]); $X->RenderComposite('Over', $pix_pict2, 'None', $picture, 0, 0, 0, 0, 200, 240, 250, 250); $X->RenderSetPictureTransform($pix_pict2, (0.5, -0.5, 0), (0, 0.5, 0), (0, 0, 0.5)); $X->RenderComposite('Over', $pix_pict2, 'None', $picture, 0, 0, 0, 0, 50, 50, 500, 250); $X->RenderCompositeGlyphs8('Over', $pix_pict, $picture, 'None', $fixed_gs, 0, 0, [150, 50, "\0\1\2\2\2\1\1\0\0\1\2\2\1"], $fixed_gs, [-100, 50, "\1\2"x10]); $X->RenderCompositeGlyphs16('Over', $pix_pict, $picture, 'None', $fixed_gs, 0, 0, [150, 60, pack("S*", 2, 0, 1, 2)]); $X->RenderCompositeGlyphs32('Over', $pix_pict, $picture, 'None', $fixed_gs, 0, 0, [150, 70, pack("L*", 2, 1, 0, 2)]); # $X->RenderCompositeGlyphs8('Over', $pix_pict, $picture, 'None', # $fixed_font, 100, 100, [150, 50, "Perl"]); } for (;;) { my %e; $X->handle_input; if (%e = $X->dequeue_event) { if ($e{'name'} eq "Expose") { draw(); } elsif ($e{'name'} eq "ButtonPress" or $e{'name'} eq "KeyPress") { exit; } } } X11-Protocol-0.56/eg/full_test.pl0000644000175000017500000004264507657530237015232 0ustar smccsmcc#!/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 X11-Protocol-0.56/eg/render-clock.pl0000644000175000017500000002774310232505262015562 0ustar smccsmcc#!/usr/bin/perl use strict; use X11::Protocol; use IO::Select; use Time::HiRes 'gettimeofday'; sub min { $_[0] <= $_[1] ? $_[0] : $_[1] } sub max { $_[0] >= $_[1] ? $_[0] : $_[1] } my $X = new X11::Protocol; $X->init_extension("RENDER") or die "The Render extension is required"; my($rgba32, $screen_fmt); my($formats, $screens,) = $X->RenderQueryPictFormats(); for my $f (@$formats) { $rgba32 = $f->[0] if $f->[2] == 32 and $f->[3] == 16 and $f->[5] == 8 and $f->[7] == 0 and $f->[9] == 24; } for my $s (@$screens) { my @s = @$s; shift @s; for my $d (@s) { my @d = @$d; next unless shift(@d) == $X->root_depth; for my $v (@d) { if ($v->[0] == $X->root_visual) { $screen_fmt = $v->[1]; } } } } my $size = 70; my($width_fact, $radius, $tick_size, $depth); use constant PI => 4*atan2(1,1); sub tri_to_traps { my($x1, $y1, $x2, $y2, $x3, $y3) = @_; my @points = ([$x1, $y1], [$x2, $y2], [$x3, $y3]); @points = sort {$a->[1] <=> $b->[1]} @points; ($x1, $y1, $x2, $y2, $x3, $y3) = (@{$points[0]}, @{$points[1]}, @{$points[2]}); my($trap1, $trap2); if (($x2-$x1)*($y3-$y1) < ($x3-$x1)*($y2-$y1)) { $trap1 = [$y1, $y2, ($x1, $y1), ($x2, $y2), ($x1, $y1), ($x3, $y3)]; $trap2 = [$y2, $y3, ($x2, $y2), ($x3, $y3), ($x1, $y1), ($x3, $y3)]; } else { $trap1 = [$y1, $y2, ($x1, $y1), ($x3, $y3), ($x1, $y1), ($x2, $y2)], $trap2 = [$y2, $y3, ($x1, $y1), ($x3, $y3), ($x2, $y2), ($x3, $y3)]; } return ($trap1, $trap2); } sub render_tri { my($op, $src_pict, $src_x, $src_y, $dst_pict, $mask, $tri) = @_; my($trap1, $trap2) = tri_to_traps(@$tri); $X->RenderTrapezoids($op, $src_pict, $src_x, $src_y, $dst_pict, $mask, $trap1, $trap2); # $X->RenderTriangles($op, $src_pict, $src_x, $src_y, $dst_pict, $mask, # $tri); } sub render_quad { my($op, $src_pict, $src_x, $src_y, $dst_pict, $mask, @points) = @_; render_tri($op, $src_pict, $src_x, $src_y, $dst_pict, $mask, [@points[0,1, 2,3, 4,5]]); render_tri($op, $src_pict, $src_x, $src_y, $dst_pict, $mask, [@points[0,1, 4,5, 6,7]]); } sub polar2rect { my($r, $theta) = @_; my $x = $size/2 + $r * sin($theta); my $y = $size/2 - $r * cos($theta); return ($x, $y); } my $win = $X->new_rsrc; $X->CreateWindow($win, $X->root, 'InputOutput', $X->root_depth, 'CopyFromParent', (0, 0), $size, $size, 0, 'background_pixel' => $X->white_pixel, 'event_mask' => $X->pack_event_mask('Exposure', 'KeyPress', 'ButtonRelease', 'StructureNotify')); $X->ChangeProperty($win, $X->atom('WM_ICON_NAME'), $X->atom('STRING'), 8, 'Replace', "render-clock"); $X->ChangeProperty($win, $X->atom('WM_NAME'), $X->atom('STRING'), 8, 'Replace', "Rendered Clock"); $X->ChangeProperty($win, $X->atom('WM_NORMAL_HINTS'), $X->atom('WM_SIZE_HINTS'), 32, 'Replace', pack("Lx40llllx12", 128, 1, 1, 1, 1)); $X->ChangeProperty($win, $X->atom('WM_HINTS'), $X->atom('WM_HINTS'), 32, 'Replace', pack("IIIx24", 1|2, 1, 1)); my $delete_atom = $X->atom('WM_DELETE_WINDOW'); $X->ChangeProperty($win, $X->atom('WM_PROTOCOLS'), $X->atom('ATOM'), 32, 'Replace', pack("L", $delete_atom)); my $progname = $0; $progname =~ s[^.*/][]; $progname = $ENV{'RESOURCE_NAME'} || $progname; $X->ChangeProperty($win, $X->atom('WM_CLASS'), $X->atom('STRING'), 8, 'Replace', "$progname\0Render-clock"); my($tick_color, $minute_color, $hour_color, $second_color); # Red Green Blue Opacity # $tick_color = [0, 0, 0, 0xffff]; # $minute_color = [0xffff,0, 0, 0x8000]; # $hour_color = [0, 0xffff,0, 0x8000]; # $second_color = [0, 0, 0xffff,0x8000]; # # Red Green Blue Opacity # $tick_color = [0, 0, 0, 0xffff]; # $minute_color = [0, 0, 0, 0x8000]; # $hour_color = [0, 0, 0, 0x8000]; # $second_color = [0, 0, 0, 0x8000]; # # Red Green Blue Opacity # $tick_color = [0, 0, 0, 0xffff]; # $minute_color = [0, 0, 0x4fff,0x8000]; # $hour_color = [0, 0, 0x4fff,0x8000]; # $second_color = [0, 0, 0x4fff,0x8000]; # Red Green Blue Opacity $tick_color = [0, 0, 0, 0xffff]; $minute_color = [0xffff,0, 0, 0x8000]; $hour_color = [0, 0x4fff,0, 0x8000]; $second_color = [0, 0, 0x4fff,0x8000]; my($face_pixmap, $face_pict); my $black_pixmap = $X->new_rsrc; $X->CreatePixmap($black_pixmap, $win, 32, 1, 1); my $black_pict = $X->new_rsrc; $X->RenderCreatePicture($black_pict, $black_pixmap, $rgba32, 'repeat' => 1); $X->RenderFillRectangles('Src', $black_pict, $tick_color, [0, 0, 1, 1]); my $red_pixmap = $X->new_rsrc; $X->CreatePixmap($red_pixmap, $win, 32, 1, 1); my $red_pict = $X->new_rsrc; $X->RenderCreatePicture($red_pict, $red_pixmap, $rgba32, 'repeat' => 1); $X->RenderFillRectangles('Src', $red_pict, $minute_color, [0, 0, 1, 1]); my $green_pixmap = $X->new_rsrc; $X->CreatePixmap($green_pixmap, $win, 32, 1, 1); my $green_pict = $X->new_rsrc; $X->RenderCreatePicture($green_pict, $green_pixmap, $rgba32, 'repeat' => 1); $X->RenderFillRectangles('Src', $green_pict, $hour_color, [0, 0, 1, 1]); my $blue_pixmap = $X->new_rsrc; $X->CreatePixmap($blue_pixmap, $win, 32, 1, 1); my $blue_pict = $X->new_rsrc; $X->RenderCreatePicture($blue_pict, $blue_pixmap, $rgba32, 'repeat' => 1); $X->RenderFillRectangles('Src', $blue_pict, $second_color, [0, 0, 1, 1]); my $hilite_pixmap = $X->new_rsrc; $X->CreatePixmap($hilite_pixmap, $win, 32, 1, 1); my $hilite_pict = $X->new_rsrc; $X->RenderCreatePicture($hilite_pict, $hilite_pixmap, $rgba32, 'repeat' => 1); my($buffer_pixmap, $buffer_pict); sub setup_face { $width_fact = 2; $radius = 0.475 * $size; $tick_size = $size / 10; $depth = $size / 150; if ($face_pixmap) { $X->FreePixmap($face_pixmap); $X->RenderFreePicture($face_pict); } else { $face_pixmap = $X->new_rsrc; $face_pict = $X->new_rsrc; } $X->CreatePixmap($face_pixmap, $win, 32, $size, $size); $X->RenderCreatePicture($face_pict, $face_pixmap, $rgba32, 'poly_edge' => 'Smooth', 'poly_mode' => 'Precise'); $X->RenderFillRectangles('Src', $face_pict, [0xefff,0xefff,0xefff,0xffff], [0, 0, $size, $size]); for my $tick (0 .. 59) { my $theta = $tick/30 * PI; my $size_outer = 0.01; my $inner_rad; if ($tick % 5) { $inner_rad = $radius - $tick_size/2; } else { $inner_rad = $radius - $tick_size; } my $size_inner = $size_outer * ($radius/$inner_rad); my($x1, $y1) = polar2rect($radius, $theta - $size_outer); my($x2, $y2) = polar2rect($radius, $theta + $size_outer); my($x3, $y3) = polar2rect($inner_rad, $theta + $size_inner); my($x4, $y4) = polar2rect($inner_rad, $theta - $size_inner); render_quad('Over', $black_pict, $size, $size, $face_pict, 'None', ($x1, $y1), ($x2, $y2), ($x3, $y3), ($x4, $y4)); } #$X->RenderFillRectangles('Over', $face_pict, [0,0,0,0xffff], # [$size/2-5, $size/2-5, 10, 10]); if ($buffer_pixmap) { $X->FreePixmap($buffer_pixmap); $X->RenderFreePicture($buffer_pict); } else { $buffer_pixmap = $X->new_rsrc; $buffer_pict = $X->new_rsrc; } $X->CreatePixmap($buffer_pixmap, $win, $X->root_depth, $size, $size); $X->RenderCreatePicture($buffer_pict, $buffer_pixmap, $screen_fmt, 'poly_edge' => 'Smooth', 'poly_mode' => 'Precise'); } setup_face(); my $copy_gc = $X->new_rsrc; $X->CreateGC($copy_gc, $win); $X->MapWindow($win); sub draw_hand { my($pict, $x1, $y1, $x2, $y2, $x3, $y3, $x4, $y4) = @_; my @p = ([$x1, $y1], [$x2, $y2], [$x3, $y3], [$x4, $y4]); my @ip; $#ip = $#p; for my $j (-2 .. $#p - 2) { my($ix, $iy) = ($p[$j+1][0] - $p[$j][0], $p[$j+1][1] - $p[$j][1]); my($ox, $oy) = ($p[$j+2][0] - $p[$j+1][0], $p[$j+2][1] - $p[$j+1][1]); if ($ix*$oy > $iy*$ox) { $ix = -$ix; $iy = -$iy; } else { $ox = -$ox; $oy = -$oy; } my($in) = sqrt($ix*$ix + $iy*$iy); $ix /= $in; $iy /= $in; my($on) = sqrt($ox*$ox + $oy*$oy); $ox /= $on; $oy /= $on; my($mx, $my) = (($ix + $ox)/2, ($iy + $oy)/2); my($mn) = max(abs($mx), abs($my)); $mx /= $mn; $my /= $mn; $ip[$j+1][0] = $p[$j+1][0] + $depth * $mx; $ip[$j+1][1] = $p[$j+1][1] + $depth * $my; } render_quad('Over', $pict, $size, $size, $buffer_pict, 'None', ($x1, $y1), ($x2, $y2), ($x3, $y3), ($x4, $y4)); for my $j (-1 .. $#p - 1) { my $angle = atan2($p[$j+1][1]-$p[$j][1], $p[$j+1][0]-$p[$j][0]); my $gray = 0x8000 + 0x4000 * sin($angle + 3*PI / 4); my $alpha = 0.5; $X->RenderFillRectangles('Src', $hilite_pict, [$gray, $gray, $gray, $alpha*0xffff], [0, 0, 1, 1]); render_quad('Over', $hilite_pict, $size, $size, $buffer_pict, 'None', @{$p[$j]}, @{$ip[$j]}, @{$ip[$j + 1]}, @{$p[$j + 1]}); } } sub draw { $X->RenderFillRectangles('Src', $buffer_pict, [0xffff, 0xffff, 0xffff, 0xffff], [0, 0, $size, $size]); $X->RenderComposite('Over', $face_pict, 'None', $buffer_pict, 0, 0, 0, 0, 0, 0, $size, $size); my($unix_time, $microsec) = gettimeofday(); my($sec, $min, $hour) = localtime($unix_time); $sec += $microsec / 1_000_000; { my $hour_theta = ($hour % 12 + $min/60 + $sec/3600)/6 * PI; my $hour_size_outer = 0.04 * $width_fact; my $hour_size_inner = $hour_size_outer * (.6/.3) * 1.4; my($x1, $y1) = polar2rect(.6*$radius, $hour_theta - $hour_size_outer); my($x2, $y2) = polar2rect(.6*$radius, $hour_theta + $hour_size_outer); my($x3, $y3) = polar2rect(-.3*$radius, $hour_theta - $hour_size_inner); my($x4, $y4) = polar2rect(-.3*$radius, $hour_theta + $hour_size_inner); draw_hand($green_pict, ($x1, $y1), ($x2, $y2), ($x3, $y3), ($x4, $y4)); } { my $min_theta = ($min + $sec/60)/30 * PI; my $min_size_outer = 0.02 * $width_fact; my $min_size_inner = $min_size_outer * (.8/.2) * 1.3; my($x1, $y1) = polar2rect(.8*$radius, $min_theta - $min_size_outer); my($x2, $y2) = polar2rect(.8*$radius, $min_theta + $min_size_outer); my($x3, $y3) = polar2rect(-.2*$radius, $min_theta - $min_size_inner); my($x4, $y4) = polar2rect(-.2*$radius, $min_theta + $min_size_inner); draw_hand($red_pict, ($x1, $y1), ($x2, $y2), ($x3, $y3), ($x4, $y4)); } { my $sec_theta = $sec/30 * PI; my $sec_size_outer = 0.01 * $width_fact; my $sec_size_inner = $sec_size_outer * (.95/.15) * 1.3; my($x1, $y1) = polar2rect(.95*$radius, $sec_theta - $sec_size_outer); my($x2, $y2) = polar2rect(.95*$radius, $sec_theta + $sec_size_outer); my($x3, $y3) = polar2rect(-.15*$radius, $sec_theta - $sec_size_inner); my($x4, $y4) = polar2rect(-.15*$radius, $sec_theta + $sec_size_inner); draw_hand($blue_pict, ($x1, $y1), ($x2, $y2), ($x3, $y3), ($x4, $y4)); } $X->CopyArea($buffer_pixmap, $win, $copy_gc, 0, 0, $size, $size, 0, 0); } $X->event_handler('queue'); my $fds = IO::Select->new($X->connection->fh); my $start_time = time; my $sample_time = Time::HiRes::time; my $frames = 0; my $delay = 0.00001; for (;;) { $X->flush(); $X->GetScreenSaver(); # AKA XSync() #$X->handle_input if $fds->can_read(0); Time::HiRes::sleep(0.01 + $delay); my %e; while (%e = $X->dequeue_event) { if ($e{'name'} eq "Expose") { draw(); } elsif ($e{'name'} eq "ButtonRelease" or $e{'name'} eq "KeyPress") { exit; } elsif ($e{'name'} eq "ConfigureNotify") { my($w, $h) = @e{'width', 'height'}; $size = min($w, $h); setup_face(); $frames = 0; $start_time = time; $sample_time = Time::HiRes::time; } elsif ($e{'name'} eq "ClientMessage" and unpack("L", $e{'data'}) == $delete_atom) { exit; } } draw(); $frames++; if (!($frames % 20)) { my $fps = $frames/(Time::HiRes::time-$sample_time); #print "$fps FPS delay $delay\n"; if ($fps > 30) { $delay = 0.75 * $delay + 0.25 * ($delay + 1/30 - 1/$fps); } elsif ($fps < 30) { $delay = 0.75 * $delay; } } } X11-Protocol-0.56/eg/widgets.c0000644000175000017500000006214510512255153014464 0ustar smccsmcc#include #include #include #include #include #include #include #include #include #include #include #define clamp(min, x, max) ((x) < (min) ? (min) : (x) > (max) ? (max) : (x)) #define sign(x) ((x) > 0 ? 1 : (x) < 0 ? -1 : 0) #define abs(x) ((x) >= 0 ? (x) : -(x)) #define min(a, b) ((a) <= (b) ? (a) : (b)) #define max(a, b) ((a) >= (b) ? (a) : (b)) #ifdef NEED_HYPOT /* SVID 3, BSD 4.3, XOpen, C99 and GNU all have hypot(). Why don't you? */ #define hypot(a, b) sqrt((a)*(a) + (b)*(b)) #endif /* Look and feel parameters to play with: */ int length = 300; int thumb = 100; int thickness = 20; int padding = 5; int depth = 2; double relief_frac = .1; /*relief area / thickness, 0 => relief doesn't scale*/ XColor trough = {0, 0xa3a3, 0xa3a3, 0xb3b3, 0, 0}; XColor bg = {0, 0xc6c6, 0xc6c6, 0xd6d6, 0, 0}; XColor fill = {0, 0xb6b6, 0x3030, 0x6060, 0, 0}; double shade = .5001; /* 0 => shadows black, hilights white; 1 => no shading */ /* for relief, 0 => raised, 1 => sunk, 2 => ridge, 3 => groove */ int prog_relief = 1; int sbar_relief = 1; int slider_relief = 0; int arrow_relief = 0; int dimple_relief = 1; int arrow_change = 1; /* these bits will flip when pressed */ double dimple = .3001; /* size / scrollbar thickness, 0 for none */ double font_frac = .6001;/* text fills 60% of the height of the progresss bar*/ /* Note that the progress bar prefers scalable fonts, so that it can keep the same proportions when the window is resized. Depending on how modern your X installation is, this may be nontrivial. * The best case is if you have a font that includes both hand-edited bitmaps for small sizes and outlines that can be scaled arbitrarily. All recent X releases come with bitmaps provided by Adobe for Helvetica, so if you also have a corresponding Type 1 outline, that's the best choice: (bitmaps for sizes 8, 10, 11, 12, 14, 17, 18, 20, 24, 25, and 34) */ /*char *fontname="-adobe-helvetica-medium-r-normal--%d-*-*-*-*-*-iso8859-1";*/ /* Appending the following subsetting hint will speed up resizes, at the expense of excluding premade bitmaps: "[48 49 50 51 52 53 54 55 56 57 37]"; */ /* (If you're using Debian Linux like me, you'll need to install the gsfonts and gsfonts-x11 packages to get the Type 1 versions. The outline isn't the genuine Adobe version; it's a free clone that can also be accessed directly (without Adobe's bitmaps) as)*/ char *fontname = "-urw-nimbus sans l-regular-r-normal--%d-*-*-*-*-*-iso8859-1"; /* * Recent X releases also include some scalable fonts, though not any sans-serif ones. In the following, adobe-utopia can be replaced by adobe-courier, bitstream-courier, or bitstream-charter: char *fontname = "-adobe-utopia-medium-r-normal--%d-*-*-*-*-*-iso8859-1"; * Also, recent X servers can scale bitmaps, though the results are usually fairly ugly. * If your X system predates XLFD (the 14-hyphen names), your font selection is probably pretty miniscule; try to pick something around 12 pixels: char *fontname = "7x13"; */ int cursor_id = XC_top_left_arrow; int initial_delay = 150000; /* usecs */ int delay = 50000; /* usecs */ double accel = 0.5; Bool smooth_progress = False; /* and un-smooth scrollbar */ int text_shading_style = 1; /* 0 => diagonalish, 1 => squarish */ /* +--------------------------------------------------+ | main_win ^v padding [bg] | | +----------------------------------------------+ | | |#prog_win########### ^ |<| | |##########[fill]#### :thickness |>| | |#################### : |:| | |<-------- length -----------:---------------->|:| | |#################### V [trough] |:| | +----------------------------------------------+:| | ^v padding :| | +----------------------------------------------+:| | | sbar_win +------------------------+ |:| |<| |+----+ slider_win +----+| [trough] |:| |>|<-slider->|| <| |<-lt_win | |> || |:| |:| pos |+----+ rt_win->+----+| |:| |:| +------------------------+ |:| |:+----------:------------------------:----------+:| |: : ^v padding : :| +:-----------:------------------------:-----------:+ : : : : : : : : padding :<------- thumb -------->: padding */ Window main_win, prog_win, sbar_win, slider_win, lt_win, rt_win; GC trough_gc, bg_gc, fill_gc, hilite_gc, shadow_gc; double frac = 0; Display *dpy; Colormap cmap; XColor shadow, hilite; Atom delete_atom; int fontsize; XFontStruct *font; char buf[256]; int total_wd, base_wd, total_ht, base_ht; int inner_thick, slider_pos, pos_min, pos_max; int lt_state, rt_state; int text_wd, text_x, text_baseline; Pixmap prog_pixmap; int font_height; /* floor : ceil :: int : away */ int away(double x) { return sign(x) * (int)(abs(x) + 0.9999); } void draw_slope_poly(Window win, int relief, int dep, GC fill, XPoint *p, int n) { GC tl, br; GC *gc; XPoint *ip; int j; if (relief > 1) { draw_slope_poly(win, relief ^ 3, dep, fill, p, n); /* tail recurse( */ relief &= 1; dep /= 2; fill = 0; } if (relief) { tl = shadow_gc; br = hilite_gc; } else { tl = hilite_gc; br = shadow_gc; } gc = (GC*)malloc(n * sizeof(GC)); ip = (XPoint*)malloc(n * sizeof(XPoint)); for (j = 0; j < n; j++) { int j_t_1 = (j + 1) % n; int j_t_2 = (j + 2) % n; double ix = (double)p[j_t_1].x - (double)p[j].x; double iy = (double)p[j_t_1].y - (double)p[j].y; double ox, oy, in, on, mx, my, mn; ox = (double)p[j_t_2].x - (double)p[j_t_1].x; oy = (double)p[j_t_2].y - (double)p[j_t_1].y; gc[j] = ix > iy ? tl : ix < iy ? br : ix > 0 ? tl : br; if (ix * oy > iy * ox) { ix = -ix; iy = -iy; } else { ox = -ox; oy = -oy; } in = hypot(ix, iy); ix /= in; iy /= in; on = hypot(ox, oy); ox /= on; oy /= on; mx = (ix + ox) / 2; my = (iy + oy) / 2; mn = max(abs(mx), abs(my)); mx /= mn; my /= mn; ip[j_t_1].x = p[j_t_1].x + away((double)(dep - 1) * mx); ip[j_t_1].y = p[j_t_1].y + away((double)(dep - 1) * my); } if (fill) XFillPolygon(dpy, win, fill, ip, n, Nonconvex, CoordModeOrigin); for (j = 0; j < n; j++) { XPoint quad[4]; int j_t_1 = (j + 1) % n; quad[0] = p[j]; quad[1] = ip[j]; quad[2] = ip[j_t_1]; quad[3] = p[j_t_1]; XFillPolygon(dpy, win, gc[j], quad, 4, Convex, CoordModeOrigin); XDrawLine(dpy, win, gc[j], p[j].x, p[j].y, p[j_t_1].x, p[j_t_1].y); XDrawLine(dpy, win, gc[j], ip[j].x, ip[j].y, ip[j_t_1].x, ip[j_t_1].y); } for (j = 0; j < n; j++) { int j_t_1 = (j + 1) % n; if (gc[j] != gc[j_t_1]) XDrawLine(dpy, win, bg_gc, p[j_t_1].x, p[j_t_1].y, ip[j_t_1].x, ip[j_t_1].y); } free(gc); free(ip); } void draw_slope(Window win, int x, int y, int wd, int ht, int relief) { XPoint rect[4]; rect[0].x = x; rect[0].y = y; rect[1].x = x + wd - 1; rect[1].y = y; rect[2].x = x + wd - 1; rect[2].y = y + ht - 1; rect[3].x = x; rect[3].y = y + ht - 1; draw_slope_poly(win, relief, depth, 0, rect, 4); } void paint_arrow(Window win, int x, int y, int s, int dir, int relief) { XPoint p[3]; int S[4]; S[0] = 0; S[1] = s / 2; S[2] = s; S[3] = s / 2; p[0].x = x + S[(dir + 1) % 4]; p[0].y = y + S[dir]; if (!(dir & 1) == !(dir & 2)) { p[1].x = x + s; p[1].y = y + s; } else { p[1].x = x; p[1].y = y; } if (dir & 2) { p[2].x = x + s; p[2].y = y; } else { p[2].x = x; p[2].y = y + s; } if (dir & 1) { XPoint temp; temp = p[1]; p[1] = p[2]; p[2] = temp; } draw_slope_poly(win, relief, depth, bg_gc, p, 3); } void paint_slope_circle(Window win, int x, int y, int s, int dep, int relief) { GC tl, br; int inner_x = x + dep; int inner_y = y + dep; int inner_s = s - 2 * dep; if (relief & 1) { tl = shadow_gc; br = hilite_gc; } else { tl = hilite_gc; br = shadow_gc; } XFillArc(dpy, win, bg_gc, x, y, s, s, 0, 360 * 64); XFillArc(dpy, win, tl, x, y, s, s, 35 * 64, 160 * 64); XDrawArc(dpy, win, tl, x, y, s, s, 35 * 64, 160 * 64); XDrawArc(dpy, win, tl, inner_x, inner_y, inner_s, inner_s, 35*64, 160*64); XFillArc(dpy, win, br, x, y, s, s, 215 * 64, 160 * 64); XDrawArc(dpy, win, br, x, y, s, s, 215 * 64, 160 * 64); XDrawArc(dpy, win, br, inner_x, inner_y, inner_s, inner_s, 215*64, 160*64); if (relief & 2) { int mid_x = x + dep / 2; int mid_y = y + dep / 2; int mid_s = s - dep; XFillArc(dpy, win, br, mid_x, mid_y, mid_s, mid_s, 35*64, 160*64); XFillArc(dpy, win, tl, mid_x, mid_y, mid_s, mid_s, 215*64, 160*64); } XFillArc(dpy, win, bg_gc, inner_x, inner_y, inner_s, inner_s, 0, 360*64); } void paint_shaded_text(Drawable dable, int x, int y, XTextItem *text, int n) { GC br_gc = shadow_gc; GC tl_gc = hilite_gc; if (text_shading_style) XDrawText(dpy, dable, br_gc, x + 1, y + 1, text, n); XDrawText(dpy, dable, br_gc, x, y + 1, text, n); XDrawText(dpy, dable, br_gc, x + 1, y, text, n); if (text_shading_style) XDrawText(dpy, dable, tl_gc, x - 1, y - 1, text, n); XDrawText(dpy, dable, tl_gc, x, y - 1, text, n); XDrawText(dpy, dable, tl_gc, x - 1, y, text, n); XDrawText(dpy, dable, bg_gc, x, y, text, n); } void prog_update(double newfrac, int increm) { double oldfrac = frac; char str[5]; /* 1 0 0 % \0 */ int realend, end, n, wd; XTextItem text[4]; frac = newfrac; sprintf(str, "%d%%", (int)(frac * 100.0)); for (n = 0; str[n] != '\0'; n++) { text[n].font = None; text[n].nchars = 1; text[n].chars = &str[n]; text[n].delta = 1; } if (str[0] == '1') text[1].delta = -font_height / 10; /* kerning */ realend = (int)(frac * (double)(length - 2 * depth)) + depth; if (increm) { int newend = realend; int oldend = (int)(oldfrac * (double)(length - 2 * depth)) + depth; int x, *left, *right, count = 0; if (newend > oldend) { right = &newend; left = &oldend; } else { right = &oldend; left = &newend; } if (*left >= text_x && *left < text_x + text_wd) { *left = text_x + text_wd - 1; count++; } if (*right >= text_x && *right < text_x + text_wd) { *right = text_x; count++; } if (count == 2) { /* do nothing */ } else if (newend > oldend) { if (smooth_progress) { for (x = oldend; x < newend; x++) { XDrawLine(dpy, prog_win, fill_gc, x, depth, x, thickness - depth - 1); } } else { XFillRectangle(dpy, prog_win, fill_gc, oldend, depth, newend - oldend, inner_thick); } } else if (newend < oldend) { if (smooth_progress) { for (x = oldend - 1; x >= newend; x--) { XDrawLine(dpy, prog_win, trough_gc, x, depth, x, thickness - depth - 1); } } else { XFillRectangle(dpy, prog_win, trough_gc, newend, depth, oldend - newend, inner_thick); } } } else { XFillRectangle(dpy, prog_win, fill_gc, depth, depth, realend - depth, inner_thick); } end = clamp(0, realend - text_x, text_wd); if (end > 0) XFillRectangle(dpy, prog_pixmap, fill_gc, 0, 0, end, inner_thick); if (end < text_wd) XFillRectangle(dpy, prog_pixmap, trough_gc, end, 0, text_wd - end, inner_thick); wd = XTextWidth(font, str, n); paint_shaded_text(prog_pixmap, 1 + (text_wd - wd) / 2, text_baseline, text, n); XCopyArea(dpy, prog_pixmap, prog_win, bg_gc, 0, 0, text_wd, inner_thick, text_x, depth); } void slider_update(double delta, Bool warp) { XWindowChanges changes; int old_pos = slider_pos; slider_pos = clamp(pos_min, slider_pos + delta, pos_max); if (warp) XWarpPointer(dpy, None, None, 0, 0, 0, 0, slider_pos - old_pos, 0); changes.x = slider_pos; XConfigureWindow(dpy, slider_win, CWX, &changes); prog_update((double)(slider_pos - pos_min) / (pos_max - pos_min), 1); } void mainloop(void); int main(int argc, char **argv) { XSetWindowAttributes attr; XGCValues gc_values; dpy = XOpenDisplay(0); cmap = DefaultColormap(dpy, DefaultScreen(dpy)); shadow.red = (unsigned short)((double)(bg.red) * shade); shadow.green = (unsigned short)((double)(bg.green) * shade); shadow.blue = (unsigned short)((double)(bg.blue) * shade); hilite.red = 65535 - (unsigned short)((65535.0-(double)(bg.red)) * shade); hilite.green = 65535-(unsigned short)((65535.0-(double)(bg.green))*shade); hilite.blue = 65535 - (unsigned short)((65535.0-(double)(bg.blue))*shade); XAllocColor(dpy, cmap, &bg); XAllocColor(dpy, cmap, &trough); XAllocColor(dpy, cmap, &shadow); XAllocColor(dpy, cmap, &hilite); XAllocColor(dpy, cmap, &fill); fontsize = (int)(font_frac * (double)thickness); sprintf(buf, fontname, fontsize); font = XLoadQueryFont(dpy, buf); total_wd = 2 * padding + length; base_wd = 2 * padding + 2 * depth + 4; total_ht = 3 * padding + 2 * thickness; base_ht = 3 * padding + 4 * depth + 3; attr.cursor = XCreateFontCursor(dpy, cursor_id); attr.background_pixel = bg.pixel; attr.event_mask = StructureNotifyMask; main_win = XCreateWindow(dpy, RootWindow(dpy, DefaultScreen(dpy)), 0, 0, total_wd, total_ht, 0, CopyFromParent,CopyFromParent,CopyFromParent, CWCursor|CWBackPixel|CWEventMask, &attr); { XSizeHints normal_hints; XWMHints wm_hints; XClassHint class_hints; XTextProperty window_name, icon_name; char *window_str = "Raw X Widgets (C Xlib)"; char *icon_str = "widgets"; normal_hints.min_width = normal_hints.base_width = base_wd; normal_hints.min_height = normal_hints.base_height = base_ht; normal_hints.min_aspect.x = 3; normal_hints.min_aspect.y = 2; normal_hints.max_aspect.x = 1000; normal_hints.max_aspect.y = 1; normal_hints.flags = PSize | PMinSize | PAspect | PBaseSize; wm_hints.input = True; wm_hints.initial_state = NormalState; wm_hints.flags = InputHint | StateHint; class_hints.res_name = argv[0]; class_hints.res_class = "widgets"; XStringListToTextProperty(&window_str, 1, &window_name); XStringListToTextProperty(&icon_str, 1, &icon_name); XSetWMProperties(dpy, main_win, &window_name, &icon_name, argv, argc, &normal_hints, &wm_hints, &class_hints); } delete_atom = XInternAtom(dpy, "WM_DELETE_WINDOW", False); XSetWMProtocols(dpy, main_win, &delete_atom, 1); attr.background_pixel = trough.pixel; attr.event_mask = ExposureMask; prog_win = XCreateWindow(dpy, main_win, padding, padding, length, thickness, 0, CopyFromParent,CopyFromParent,CopyFromParent, CWBackPixel|CWEventMask, &attr); attr.background_pixel = trough.pixel; attr.event_mask = ExposureMask; sbar_win = XCreateWindow(dpy, main_win, padding, 2* padding + thickness, length, thickness, 0, CopyFromParent,CopyFromParent,CopyFromParent, CWBackPixel|CWEventMask, &attr); gc_values.foreground = bg.pixel; bg_gc = XCreateGC(dpy, main_win, GCForeground, &gc_values); gc_values.foreground = shadow.pixel; shadow_gc = XCreateGC(dpy, main_win, GCForeground, &gc_values); gc_values.foreground = hilite.pixel; hilite_gc = XCreateGC(dpy, main_win, GCForeground, &gc_values); inner_thick = thickness - 2 * depth; slider_pos = depth; pos_min = depth; pos_max = length - thumb - depth - 2 * inner_thick; attr.background_pixel = bg.pixel; attr.event_mask = ExposureMask | ButtonPressMask | ButtonMotionMask | PointerMotionHintMask; slider_win = XCreateWindow(dpy, sbar_win, slider_pos, depth, thumb + 2 * inner_thick, inner_thick, 0, CopyFromParent,CopyFromParent,CopyFromParent, CWBackPixel|CWEventMask, &attr); attr.background_pixel = trough.pixel; attr.event_mask = ExposureMask | ButtonPressMask | ButtonReleaseMask; lt_win = XCreateWindow(dpy, slider_win, 0, 0, inner_thick, inner_thick, 0, CopyFromParent,CopyFromParent,CopyFromParent, CWBackPixel|CWEventMask, &attr); rt_win = XCreateWindow(dpy, slider_win, thumb + inner_thick, 0, inner_thick, inner_thick, 0, CopyFromParent,CopyFromParent,CopyFromParent, CWBackPixel|CWEventMask, &attr); lt_state = rt_state = 0; XMapWindow(dpy, lt_win); XMapWindow(dpy, rt_win); XMapWindow(dpy, slider_win); text_wd = XTextWidth(font, "100%", 4) + 4 + 2; text_x = (length - text_wd) / 2; text_baseline = (thickness + font->ascent - font->descent) / 2 - depth; prog_pixmap = XCreatePixmap(dpy, prog_win, text_wd, inner_thick, DisplayPlanes(dpy, DefaultScreen(dpy))); gc_values.foreground = trough.pixel; gc_values.font = font->fid; trough_gc = XCreateGC(dpy, main_win, GCForeground|GCFont, &gc_values); gc_values.foreground = fill.pixel; fill_gc = XCreateGC(dpy, main_win, GCForeground|GCFont, &gc_values); XSetFont(dpy, shadow_gc, font->fid); XSetFont(dpy, hilite_gc, font->fid); XSetFont(dpy, bg_gc, font->fid); font_height = font->ascent + font->descent; XMapWindow(dpy, prog_win); XMapWindow(dpy, sbar_win); XMapWindow(dpy, main_win); mainloop(); return 0; } void mainloop(void) { fd_set fds; struct timeval timeout, short_time; double slider_speed; int pointer_pos, last_pos = -1; int prog_dirty = 0, sbar_dirty = 0, slider_dirty = 0, lt_dirty = 0, rt_dirty = 0; int resize_pending = 0; int x_fd = ConnectionNumber(dpy); XEvent e; FD_ZERO(&fds); FD_SET(x_fd, &fds); timeout.tv_sec = 0; timeout.tv_usec = 0; /* Even though this program can probably handle events as fast as the X server can generate them, it can't hurt to use some sort of `flow control' to throw out excess events in case we're ever behind. */ /* For pointer motion events, this is accomplished by selecting PointerMotionHint on the slider (see above), so that the server never sends a sequence of motion events -- instead, it sends one, which we throw away but use as our cue to query the pointer position. The query_pointer is then a sign to the server that we'd be willing to accept one more event, and so on. Notice that this requires at least one round trip between the server and the client for each motion, which puts a limit on performance. */ /* Expose and ConfigureNotify (resize) events have the same problem, though it's only noticeable if your window manager supports opaque window movement or opaque resize, respectively (the latter is fairly rare in X, perhaps because average X clients handle it fairly poorly; I for one am quite envious of how smoothly windows resize in Windows NT). We can't do anything to tell the server to only send us one of these events, but the next best thing is to just ignore them until there aren't any other events pending. (In some toolkits this would be called `idle-loop' processing). It's always safe to ignore intermediate resizes, but with expose events we can only do this because we always redraw the whole window, instead of just the newly-visible part. A more sophisticated approach would keep track of the exposed region, either with a bounding box or some more precise data structure, and then clip the drawing to that (either client-side or using a clip mask in the GC). */ for (;;) { if (timeout.tv_usec) { XFlush(dpy); while (!select(x_fd + 1, &fds, 0, 0, &timeout)) { FD_SET(x_fd, &fds); slider_update(slider_speed, 1); slider_speed += sign(slider_speed) * accel; if (slider_pos == pos_min || slider_pos == pos_max) { timeout.tv_sec = timeout.tv_usec = 0; break; } else { timeout.tv_sec = 0; timeout.tv_usec = delay; } XFlush(dpy); } } FD_SET(x_fd, &fds); XFlush(dpy); short_time.tv_sec = 0; short_time.tv_usec = 1000; if (!select(x_fd + 1, &fds, 0, 0, &short_time)) { if (resize_pending) { XWindowChanges changes; resize_pending = 0; total_ht = max(total_ht, base_ht); length = total_wd - 2 * padding; thickness = (total_ht - 3 * padding + 1) / 2; if (relief_frac) depth = (int)(relief_frac * (double)thickness); inner_thick = thickness - 2 * depth; thumb = length / 3; XResizeWindow(dpy, prog_win, length, thickness); fontsize = (int)(font_frac * (double)thickness); XFreeFont(dpy, font); sprintf(buf, fontname, fontsize); font = XLoadQueryFont(dpy, buf); XSetFont(dpy, bg_gc, font->fid); XSetFont(dpy, hilite_gc, font->fid); XSetFont(dpy, shadow_gc, font->fid); text_wd = XTextWidth(font, "100%", 4) + 4 + 2; text_x = (length - text_wd) / 2; text_baseline = (thickness + font->ascent - font->descent) / 2 - depth; font_height = font->ascent + font->descent; XFreePixmap(dpy, prog_pixmap); prog_pixmap = XCreatePixmap(dpy, prog_win, text_wd, inner_thick, DisplayPlanes(dpy, DefaultScreen(dpy))); changes.y = 2 * padding + thickness; changes.width = length; changes.height = thickness; XConfigureWindow(dpy, sbar_win, CWY|CWWidth|CWHeight, &changes); pos_min = depth; pos_max = length - thumb - depth - 2 * inner_thick; slider_pos = pos_min + (int)(frac * (double)(pos_max - pos_min)); XMoveResizeWindow(dpy, slider_win, slider_pos, depth, thumb + 2 * inner_thick, inner_thick); XResizeWindow(dpy, lt_win, inner_thick, inner_thick); changes.x = thumb + inner_thick; changes.width = changes.height = inner_thick; XConfigureWindow(dpy, rt_win, CWX|CWWidth|CWHeight, &changes); } if (prog_dirty) { draw_slope(prog_win, 0, 0, length, thickness, prog_relief); prog_update(frac, 0); prog_dirty = 0; } if (sbar_dirty) { draw_slope(sbar_win, 0, 0, length, thickness, sbar_relief); sbar_dirty = 0; } if (slider_dirty) { draw_slope(slider_win, inner_thick, 0, thumb, inner_thick, slider_relief); if (dimple) paint_slope_circle(slider_win, thumb / 2 +(int)((2.0 - dimple)/2.0 * (double)inner_thick), (int)((1.0 - dimple) * (double)inner_thick / 2.0), (int)(dimple * (double)inner_thick), depth, dimple_relief); slider_dirty = 0; } if (lt_dirty) { paint_arrow(lt_win, 0, 0, inner_thick - 1, 3, arrow_relief ^ lt_state); lt_dirty = 0; } if (rt_dirty) { paint_arrow(rt_win, 0, 0, inner_thick - 1, 1, arrow_relief ^ rt_state); rt_dirty = 0; } } XNextEvent(dpy, &e); switch (e.type) { case ClientMessage: if (e.xclient.data.l[0] == delete_atom) exit(0); break; case ConfigureNotify: { int wd = e.xconfigure.width; int ht = e.xconfigure.height; if (wd != total_wd || ht != total_ht) { resize_pending++; total_wd = wd; total_ht = ht; } break; } case Expose: { Window win = e.xexpose.window; if (win == sbar_win) { if (e.xexpose.x < depth || e.xexpose.y < depth || e.xexpose.x + e.xexpose.width > length - depth || e.xexpose.y + e.xexpose.height > thickness - depth) { /* In the scrollbar, we throw out exposures that don't include the border (including all the ones caused by moving the slider), since the server fills the trough in with the window's background color automatically. */ sbar_dirty++; } } else if (win == prog_win) prog_dirty++; else if (win == slider_win) slider_dirty++; else if (win == lt_win) lt_dirty++; else if (win == rt_win) rt_dirty++; break; } case ButtonPress: { Window win = e.xbutton.window; if (win == slider_win) { pointer_pos = slider_pos; last_pos = e.xbutton.x_root; } else if (win == lt_win) { if (2*abs(e.xbutton.y - inner_thick / 2) <= e.xbutton.x) { lt_state = arrow_change; slider_update(-1, 1); paint_arrow(lt_win, 0, 0, inner_thick - 1, 3, arrow_relief ^ lt_state); slider_speed = -1; timeout.tv_sec = 0; timeout.tv_usec = initial_delay; } } else if (win == rt_win) { if (2*abs(e.xbutton.y - inner_thick / 2) <= inner_thick - e.xbutton.x) { rt_state = arrow_change; slider_update(1, 1); paint_arrow(rt_win, 0, 0, inner_thick - 1, 1, arrow_relief ^ rt_state); slider_speed = 1; timeout.tv_sec = 0; timeout.tv_usec = initial_delay; } } break; } case MotionNotify: if (e.xmotion.window == slider_win && last_pos != -1) { int na, root_x; Window NA; XQueryPointer(dpy, slider_win, &NA, &NA, &root_x, &na, &na, &na, (unsigned int *)&na); pointer_pos += root_x - last_pos; slider_update(pointer_pos - slider_pos, 0); last_pos = root_x; } break; case ButtonRelease: { Window win = e.xbutton.window; if (win == slider_win && last_pos != -1) { slider_update(e.xbutton.x_root - last_pos, 0); last_pos = -1; } else if (win == lt_win) { lt_state = 0; paint_arrow(lt_win, 0, 0, inner_thick - 1, 3, arrow_relief ^ lt_state); timeout.tv_sec = 0; timeout.tv_usec = 0; } else if (win == rt_win) { rt_state = 0; paint_arrow(rt_win, 0, 0, inner_thick - 1, 1, arrow_relief ^ rt_state); timeout.tv_sec = 0; timeout.tv_usec = 0; } break; } } } } X11-Protocol-0.56/eg/anim.pl0000644000175000017500000000542507623642531014142 0ustar smccsmcc#!/usr/bin/perl use X11::Protocol; use IO::Select; $pi = 3.1415926535898; $r = 1; $theta = 0; $size = 250; $x = X11::Protocol->new; $win = $x->new_rsrc; $x->CreateWindow($win, $x->root, 'InputOutput', $x->root_depth, 'CopyFromParent', (0, 0), 2 * $size, 2 * $size, 1, # 'backing_store' => 'Always', 'background_pixel' => $x->white_pixel); $x->ChangeProperty($win, $x->atom('WM_NAME'), $x->atom('STRING'), 8, 'Replace', "Animation test"); $x->MapWindow($win); $pm = $x->new_rsrc; $x->CreatePixmap($pm, $win, $x->root_depth, 2 * $size, 2 * $size); $gc = $x->new_rsrc; $x->CreateGC($gc, $pm, 'foreground' => $x->black_pixel, 'graphics_exposures' => 0); $egc = $x->new_rsrc; $x->CreateGC($egc, $pm, 'foreground' => $x->white_pixel, 'graphics_exposures' => 0); $x->PolyFillRectangle($pm, $egc, [(0, 0), 2 * $size, 2 * $size]); $sel = IO::Select->new($x->connection->fh); sub r2p { my($x, $y) = @_; $x -= .5; $x *= .75; $y -= .5; return [-atan2($y, $x), sqrt($x*$x + $y*$y)]; } $P = [[['Simple', $gc], [r2p(0, 0), r2p(.75, 0), r2p(1, .25), r2p(.75, .5), r2p(.15, .5), r2p(.15, 1), r2p(0, 1)]], [['Convex', $egc], [r2p(.15, .15), r2p(.75, .15), r2p(.85, .25), r2p(.75, .35), r2p(.15, .35)]]]; $E = [[['Simple', $gc], [r2p(0, 0), r2p(1, 0), r2p(1, .2), r2p(.2, .2), r2p(.2, .4), r2p(.75, .4), r2p(.75, .6), r2p(.2, .6), r2p(.2, .8), r2p(1, .8), r2p(1, 1), r2p(0, 1)]]]; $R = [[['Simple', $gc], [r2p(0, 0), r2p(.75, 0), r2p(1, .25), r2p(.75, .5), r2p(1, 1), r2p(.85, 1), r2p(.6, .5), r2p(.15, .5), r2p(.15, 1), r2p(0, 1)]], [['Convex', $egc], [r2p(.15, .15), r2p(.75, .15), r2p(.85, .25), r2p(.75, .35), r2p(.15, .35)]]]; $L = [[['Simple', $gc], [r2p(0, 0), r2p(.2, 0), r2p(.2, .8), r2p(1, .8), r2p(1, 1), r2p(0, 1)]]]; for (;;) { for $img ($P, $E, $R, $L) { $r = 5; while ($r < 6.25 * $size) { @polys = (); for $poly (@$img) { @a = ($poly->[0]); for $p (@{$poly->[1]}) { push @{$a[1]}, $size + $r * $p->[1] * sin($theta + $p->[0]); push @{$a[1]}, $size + $r * $p->[1] * cos($theta + $p->[0]); } push @polys, [@a]; } for $poly (@old_polys) { $x->FillPoly($pm, $egc, $poly->[0][0], 'Origin', @{$poly->[1]}) if $poly->[0][1] != $egc; } for $poly (@polys) { $x->FillPoly($pm, $poly->[0][1], $poly->[0][0], 'Origin', @{$poly->[1]}); } $x->CopyArea($pm, $win, $gc, (0, 0), 2 * $size, 2 * $size, (0, 0)); # On my Linux/x86 2.0, anything less than 1/100 sec causes # other things (e.g., mouse tracking) to slow down terribly. $x->flush(); select(undef, undef, undef, 1/99); @old_polys = @polys; $r *= 1.05; $theta += .1; $x->handle_input if $sel->can_read(0); } } } X11-Protocol-0.56/MANIFEST0000644000175000017500000000347510033641253013407 0ustar smccsmccAuth.pm Read .Xauthority files Changes List of changes from previous versions Keysyms.pm Names of keysyms (like keysymdef.h) MANIFEST List of files META.yml Module meta-data (added by MakeMaker) Makefile.PL Source for Makefile Protocol.pm The X11 Window System Protocol Protocol/Connection.pm Base class for connections Protocol/Connection/FileHandle.pm Base class for FileHandle connections Protocol/Connection/INETFH.pm TCP/IP FileHandle connections Protocol/Connection/INETSocket.pm TCP/IP IO::Socket connections Protocol/Connection/Socket.pm Base class for IO:Socket connections Protocol/Connection/UNIXFH.pm Unix-domain FileHandle connections Protocol/Connection/UNIXSocket.pm Unix-domain IO::Socket connections Protocol/Constants.pm X11 Protocol symbolic constants Protocol/Ext/BIG_REQUESTS.pm BIG-REQUESTS extension Protocol/Ext/SHAPE.pm SHAPE extension Protocol/Ext/XC_MISC.pm XC-MISC (resource ID) extension Protocol/Ext/DPMS.pm Display Power Management extension Protocol/Ext/XFree86_Misc.pm XFree86 miscellaneous extension Protocol/Ext/RENDER.pm X Render extension README The Instructions Todo The Wishlist eg/anim.pl Animated example eg/full_test.pl Exhaustive test of Protocol.pm et al. eg/long-run.pl A long-running example eg/teletype.pl Two-display example eg/random-win.pl Error recovering example eg/render-clock.pl Render extension clock example eg/render-test.pl Exhaustive Render extension test eg/widgets1.pl User interface widget example eg/widgets2.pl X11-Motif version of widget example eg/widgets3.pl Unfinished OO-interface widget example eg/widgets.c C Xlib version of widget example eg/wintree.pl Window hierarchy utility example test.pl Short test of Protocol.pm et al.