The Labs.Com Issue_05_X

TPJ: Issue_05_X

This is a collection of programs published by The Perl Journal. You can download all source-code also from TPJ: Programs.

1. README
2. Xproto2.perl
3. clickwindow.pl
4. xhello.pl
5. extra-Xproto.h
6. xatomhash.pl
7. names
8. parse-xheader.pl
9. reqs
10. wmm.pl
11. xauth.pl
12. xbase.pl
13. xbeep.pl
14. xdpyinfo.pl
15. xerror.pl
16. xint.perl
17. xlsfont.pl
18. xwdhead.pl
19. xwininfo.c
20. xwininfo.pl
21. More Samples on X

Download README

Back in late 1991, I wrote an X library for perl.  This wasn't a bindi\

ng

to the C Xlib; this was a raw implementation of the X protocol.

It got some small amount of use around MIT; I never got around to

posting it widely, but got feedback from a few people.

perl5 has some clever new features, which should make it easier to

provide a clean "interface" than the old code had, and easier to

set up good abstractions internally.

Now that I've had time to read through the Perl5 edition of the Camel

Book, it's time to begin...  [eichin:19961101.0337EST]

discoveries:

* attempted to speed up the load of the converted Xproto.

perl *without* -w, user time:

.cooked file: 0.5s [original mechanism]

indiv. assign: 1.1s [first modification]

flattened assign: 0.52s, but more variance(?) [optimized a bit]

Note, however, that this *appears* to be *slower* than

parsing the proto file.  Perhaps that shouldn't be a surprise...

So a win might be to store a binary format instead?

Problem is that these are all variable length strings; switching to a

split on ^@ gave about the same time range.

in perl5, we should be able to say:

my($output) = &xlibconvert("xConnSetupPrefix",$reply)

$success = $output->{"success"};

this would make $output blessed? or perhaps we say

my($output) = Xlib->new(type=>"xConnSetupPrefix",data=>$repl\

y);

all output needs to be, though, is a hash... ie. convert can

do the unpack *and* stuff the fields into the hash (and perl4 could

have probably handled this too, if &xlibconvert explicitly returned

a hash...) so xlibconvert just returns a hashref, which also happens

to contain the "packof" and "sizeof" fields.  However, this only helps

with the few cases where we read now, though it would make it easier

to write more of them (as we'd need to for event handling.) We need a

better syntax for generating protocol messages, if we can...

x_beep just does:

print XFD pack($xpackof{"xBellReq"},$defines{"X_Bell"},$percentage,1\

);

we could put the $defines into a namespace directly; in fact, the X

defines are a useful set themselves, and could just become X::Bell and

the like. (maybe def:: for the others? or just make them raw values?)

so, step 1:

print XFD pack($xpackof{"xBellReq"},X::Bell,$percentage,1);

we can also, at least, define xpack as

sub xpack { my $typ=shift; pack($packof{$typ},@_); }

and then say

print XFD &xpack("xBellReq",X::Bell,$percentage,1);

which, with a name space and actual functions, could instead become

print XFD X::xBellReq(X::Bell,$percentage,1);

Then note that most of these include their *own* verb at the

beginning, there should be a clever way to instead say

print XFD X::xBellReq($percentage,1);

and now we're getting somewhere.

[eichin:19961105.0458EST]

[done] All uses of xsizeof/sizeof are in bytes -- so drop the *8 /8 al\

together.

Many use the $lll self-measuring trick, which could be generalized?

[eichin:19961106.1304EST]

[done] auth is way simple - perhaps we can just implement it next?

should fix "mismatch" code so it doesn't complain as much gratuitously

add more synonyms

[done] implement something like GetResReq/GetEmptyReq (for one arg/no \

args)

instead of forcing stuff into extra-Xproto.h?

[eichin:19961108.0113EST]

[done] finish off "xdpyinfo" features -- store xopendisplay output, an\

d then

parse it seperately...

perhaps a master data queue? or at least *some* way to handle events? \

[done]

(maybe just a hook that prints them at first...)

[eichin:19961109.1630EST]

milestones:

hello world (createwindow, gc, font) [done]

query-tree (start on wmm!) [done]

[eichin:19961117.1841EST]

request list: determine full protocol coverage based on request names

(up to 1/3 by morning...)

[eichin:19961118.1349EST]

idea from ken: calculate the length in Req subs directly? we *can*...[\

done]

[eichin:19961119.0351EST]

what about elisp, anyway? :-)

[eichin:19961120.0102EST]

how about a tie'd hash for atom name lookups? [done]

[eichin:19961120.1221EST]

now do the *reverse* as well -- what's a perl "isnumber"? that way we

can use the same data to go both ways... [done]

[eichin:19970227.0155EST]

Renamed .perl files to .pl since emacs handles that extension consiste\

ntly

now.  Leave .perl for generated files for now.  Add Makefile for relea\

se.

Issue_05_X 2. Xproto2.perl

Xproto2.perl

Issue_05_X 3. clickwindow.pl

Download clickwindow.pl

#!perl

#$xlib::debug = 1;

#$xlib::debugpkt = 1;

require "./xbase.pl";

# require "./xatomhash.pl";

$xopen = xlib::x_open_display($ENV{"DISPLAY"});

$fc = xlib::joincolor(65535,0,0);

$bc = xlib::joincolor(0,0,0);

$curs = xlib::x_createfontcursor($xopen, $XC::crosshair, $fc, $bc);

sub xx {

#    $stat = xlib::xungrabpointer($xopen, 0); # time now

$stat = xlib::xgrabpointer($xopen,

0,        # owner-events false

&xlib::defaultroot($xopen), # grabw

$X::defines{"ButtonPressMask"} |

$X::defines{"ButtonReleaseMask"},

$X::defines{"GrabModeSync"},

$X::defines{"GrabModeAsync"},

&xlib::defaultroot($xopen),

# conf window none (vs root?)

$curs,        # cursor none

$X::defines{"CurrentTime"} # time now

);

#    print "grabstat: $stat\n";

&xlib::xallowevents($xopen,

$X::defines{"SyncPointer"},

$X::defines{"CurrentTime"});

}

xx();

$SIG{"ALRM"} = $SIG{"INT"} = sub {

xlib::x_closedisplay($xopen);

exit;

};

alarm(30);

#print "waiting (30s)... $stat\n";

print "click on a window to toggle backing store...\n";

$xlib::handler{"ButtonRelease"} =

$xlib::handler{"ButtonPress"} = sub {

my $rep = xlib::xlibconvert("keyButtonPointer", $xopen->{"readq\

ueue"});

#    xlib::debugxlib($rep);

#    printf "child: 0x%x\n", $xchild = $rep->{"child"};

$xchild = $rep->{"child"};

};

$st = xlib::handle_event($xopen);

$ch1 = $xchild;

#print "event: $st, child $xchild\n";

xx();

$st = xlib::handle_event($xopen);

$ch2 = $xchild;

#print "event: $st, child $xchild\n";

# button press, button release, double check that they have the same c\

hild...

$stat = xlib::xungrabpointer($xopen, 0); # time now

if ($ch1 != $ch2) {

die "different windows, aborting on user request";

}

sub query_eval {

my ($d,$w,$sub)=@_;

&$sub($d,$w);

my @lf = &xlib::x_querytree($d, $w);

shift @lf;                        # lose the rep, we just want the\

kids

my $i;

for $i (@lf) {

query_eval($d,$i,$sub);

}

}

sub toggle_backingstore { # disp, win

my ($d,$w) = @_;

printf "toggling 0x%x (%d):", $w, $w;

my $attrs = xlib::x_get_window_attributes($d,$w);

if ($attrs->{"backingStore"} == $X::defines{"NotUseful"}) {

print "setting to Always\n";

$stat = xlib::x_change_window_attributes($d, $w,

$X::defines{"CWBackingSto\

re"},

$X::defines{"Always"});

} else {

print "setting to NotUseful\n";

$stat = xlib::x_change_window_attributes($d, $w,

$X::defines{"CWBackingSto\

re"},

$X::defines{"NotUseful"})\

;

}

}

query_eval($xopen,$ch1,\&toggle_backingstore);

Issue_05_X 4. xhello.pl

Download xhello.pl

#!/usr/bin/perl

require "./xbase.pl";

$xopen = &xlib::x_open_display($ENV{"DISPLAY"});

die $xlib::status if not defined $xopen;

$fnt = xlib::x_openfont($xopen, "fixed");

$win = xlib::x_create_window($xopen, 8,

xlib::defaultroot($xopen),

100, 200, 300, 400, 5,

$X::defines{"InputOutput"},

$X::defines{"CopyFromParent"},

$X::defines{"CWBackPixel"}

| $X::defines{"CWEventMask"},

$xlib::root_white,

$X::defines{"ButtonPressMask"}

|$X::defines{"ButtonReleaseMask"}

|$X::defines{"ExposureMask"}

|$X::defines{"KeyPressMask"}

);

$gc = xlib::x_create_gc($xopen, $win,

$X::defines{"GCForeground"}

| $X::defines{"GCBackground"}

| $X::defines{"GCFont"},

$xlib::root_black, $xlib::root_white, $fnt);

#printf "fnt %x win %x gc %x\n", $fnt,$win,$gc;

#sleep 1;

$st = xlib::x_clear_area($xopen, $win, 0, 0,0,0,0);

$xlib::handler{"Expose"} = sub {

xlib::x_imagetext8($xopen, $win, $gc, 50, 75, "hello world");

};

$xlib::handler{"KeyPress"} = sub {

my $rep = xlib::xlibconvert("keyButtonPointer", $xopen->{"readq\

ueue"});

xlib::debugxlib($rep);

};

xlib::x_mapwindow($xopen, $win);

while(defined($st = xlib::handle_event($xopen))) { # assume error for \

now?

print "event: $st\n";

}

xlib::x_closedisplay($xopen);

Issue_05_X 5. extra-Xproto.h

extra-Xproto.h

Issue_05_X 6. xatomhash.pl

Download xatomhash.pl

#

# use getatomname or internatom depending on the value looked up, but

# cache both

package XATOM;

use Tie::Hash;

sub TIEHASH {

my ($name, $d) = @_;

my $self={}; bless $self;

$self->{"display"} = $d;

$self->{"cache"} = {};

return $self;

}

sub FETCH {

my $self = shift;

my $key = shift;

my $r = $self->{"cache"}->{$key};

if (! defined($r)) {

if ($key =~ /^\d*$/) {

$r = xlib::x_getatomname($self->{"display"},$key);

} else {

$r = xlib::x_internatom($self->{"display"},

$X::defines{"xTrue"},$key);

}

$self->{"cache"}->{$key} = $r;

$self->{"cache"}->{$r} = $key;

}

return $r;

}

sub EXISTS {

my $self = shift;

my $key = shift;

return exists $self->{"cache"}->{$key};

}

sub STORE {

my $self = shift;

my ($key, $value) = @_;        # value irrelevant

my $a = xlib::x_internatom($self->{"display"},$X::defines{"xFal\

se"}, $key);

$self->{"cache"}->{$a} = $key;

return $self->{"cache"}->{$key} = $a;

}

sub DELETE {

my $self = shift;

my ($key, $value) = @_;

# delete $self->{"refs"}->{$key};

# can't actually delete something...

-1;

}

sub FIRSTKEY {

my $self = shift;

my $a = scalar keys %{$self->{"cache"}};

return each %{$self->{"cache"}};

}

sub NEXTKEY {

my $self = shift;

my $lastkey = shift;

return each %{$self->{"cache"}};

}

sub DESTROY {

my $self = shift;

}

1;

Issue_05_X 7. names

Download names

internal:

xlibconvert

debugxlib [ but exported anyway ]

xpack [ only used in x_open_display ]

split_display [ could export... ]

next_resource_id

extend_queue

skipevent

xqueueconvert

x_real_put_image

network:

mkport

mkport_unix

serverprint

other:

min

meta:

x_washwindow

x_get_one

x_reply

x_iter_raw

x_iter

genvec

genvec2

genvecstr

xpoly1

xpoly2

x_ungrab

exported:

handle_event

xdebugdisplay [but only for xdpyinfo?]

xlib::

default::

root                defaultroot

rootdepth        defaultrootdepth

window::

destroy                x_destroywindow

destroysubs        x_destroysubwindows

map                x_mapwindow

mapsubs                x_mapsubwindows

unmap                x_unmapwindow

unmapsubs        x_unmapsubwindows

configure        x_configurewindow

getgeometry        x_get_geometry

reparent        x_reparentwindow

circulate        x_circulatewindow

create                x_create_window

list                x_querytree

set_background_pixmap        x_set_window_background_p\

ixmap

attributes::

get                x_get_window_attributes

change                x_change_window_attribut\

es

clear                x_clear_area

saveset                x_changesaveset

translate        TranslateCoords [pending]

pixmap::

create                x_create_pixmap

copyarea        CopyArea [pending]

copyplane        CopyPlane [pending]

image::

put                x_put_image

get                GetImage [pending]

free                FreePixmap [pending]

poly::

arcs                xpolyarcs

fillarcs        xpolyfillarcs

rects                xpolyrects

fillrects        xpolyfillrects

segments        xpolysegments

points                xpolypoints

lines                xpolylines

fill                FillPoly [pending]

selection::

setowner        xsetselectionowner

getowner        xgetselectionowner

convert                xconvertselection

property::

change                x_changeproperty

delete                x_deleteproperty

get                x_getproperty

list                x_listproperties

rotate                RotateProperties [pending]

font::

getpath                x_getfontpath

setpath                SetFontPath [pending]

list                x_listfonts

close                CloseFont [pending]

query                QueryFont [pending]

queryextents        QueryTextExtents [pending]

open                x_openfont

text::

poly8                PolyText8 [pending]

poly16                PolyText16 [pending]

image8                x_imagetext8

image16                ImageText16 [pending]

atom::

getname                x_getatomname

intern                x_internatom

pointer::

grab                xgrabpointer

ungrab                xungrabpointer

changegrab        xchangeactivepointergrab

query                xquerypointer

getmapping        x_get_pointer_mapping

setmapping        SetPointerMapping [pending]

warp                WarpPointer [pending]

getcontrol        GetPointerControl [pending]

changecontrol        ChangePointerControl [pending]

GC::

free                FreeGC [pending]

change                ChangeGC [pending]

copy                CopyGC [pending]

create                x_create_gc

setdashes        SetDashes [pending]

setcliprects        SetClipRectangles [pending]

colormap::

create                CreateColormap [pending]

free                FreeColormap [pending]

copyandfree        CopyColormapAndFree [pending]

install                InstallColormap [pending]

uninstall        UninstallColormap [pending]

listinstalled        ListInstalledColormaps [pending]

color::

# may use a hash, or at least combine allocs

alloc                AllocColor [pending]

allocnamed        AllocNamedColor [pending]

alloccells        AllocColorCells [pending]

allocplanes        AllocColorPlanes [pending]

free                FreeColors [pending]

store                StoreColors [pending]

storenamed        StoreNamedColor [pending]

query                QueryColors [pending]

lookup                LookupColor [pending]

cursor::

create                CreateCursor [pending]

createglyph        CreateGlyphCursor [pending]

free                FreeCursor [pending]

recolor                RecolorCursor [pending]

bestize                QueryBestSize [pending]

access::

change                ChangeHosts [pending]

list                ListHosts [pending]

set                SetAccessControl [pending]

screensaver::

set                SetScreenSaver [pending]

get                GetScreenSaver [pending]

force                ForceScreenSaver [pending]

key::

grab                xgrabkeyboard

grab                xgrabkey

grab                xgrabbutton

ungrab                xungrabkeyboard

ungrab                xungrabbutton

ungrab                xungrabkey

getmapping        x_get_keyboard_mapping

getmapping        x_get_modifier_mapping

setmapping        SetModifierMapping [pending]

getcontrol        x_get_keyboard_control

getfocus        x_get_input_focus

setfocus        SetInputFocus [pending]

getmotion        GetMotionEvents [pending]

changemapping        ChangeKeyboardMapping [pending]

changecontrol        ChangeKeyboardControl [pending]

query                QueryKeymap [pending]

beep                x_beep

connection::

setmode                SetCloseDownMode [pending]

kill                KillClient [pending]

open                x_open_display

close                x_closedisplay

grab                xgrabserver

ungrab                xungrabserver

extensions::

list                x_listextensions

query                QueryExtension [pending]

event::

xsendevent

xallowevents

Issue_05_X 8. parse-xheader.pl

Download parse-xheader.pl

#!perl

$xsizeof{"int"} = 4;

$xsizeof{"char"} = 1;

$xsizeof{"BYTE"} = 1;

$xsizeof{"BOOL"} = 1;

$xsizeof{"long"} = 4;

$xsizeof{"CARD8"} = 1;

$xsizeof{"CARD16"} = 2;

$xsizeof{"CARD32"} = 4;

$xsizeof{"INT8"} = 1;

$xsizeof{"INT16"} = 2;

$xsizeof{"INT32"} = 4;

# oops, X11R4 is missing one...

# X11R6 has it though.

# $xsizeof{"xGetModifierMappingReply"} = 256;

$xpackof{"int"} = "L";

$xpackof{"char"} = "C";

$xpackof{"BYTE"} = "C";

$xpackof{"BOOL"} = "C";

$xpackof{"long"} = "L";

$xpackof{"CARD8"} = "C";

$xpackof{"CARD16"} = "S";

$xpackof{"CARD32"} = "L";

$xpackof{"INT8"} = "C";

$xpackof{"INT16"} = "S";

$xpackof{"INT32"} = "L";

# these are stored in %xpad in case we decide we want to be general la\

ter on

# but for now we copy it all into %xpackof anyhow.

for $i ("", 1..3) {

$xpad{"BYTE pad$i"} = "x";

}

$xpad{"BYTE bpad"} = "x";

$xpad{"CARD8 pad"} = "x";

$xpad{"CARD8 pad1"} = "x";

$xpad{"CARD16 pad"} = "x2";

$xpad{"CARD16 pad1"} = "x2";

$xpad{"CARD16 pad2"} = "x2";

# these are mostly Xevent subfields...

for $i ("", "00", 1..7) {

$xpad{"CARD32 pad$i"} = "x4";

}

for $i (keys %xpad) { $xpackof{$i} = $xpad{$i}; }

$incomment = 0;

sub fropcomment { # $incomment

my($incomment) = @_;

s/\/\*.*\*\///g;

if(/\*\//) {

$incomment = 0;

s/^.*\*\///;

}

next if $incomment;

if(/\/\*/) {

$incomment = 1;

s/\/\*.*//;

}

}

# walk XPROTO file and fill in any defines, xsizeof, xtypeof, requests

# we come across, sometimes calling process_struct to help

sub munchproto {

while(<XPROTO>) {

$incomment = &fropcomment($incomment);

if(/\#if defined\(\_\_cplusplus\) \|\| defined\(c\_plusplus\)/\

) {

while(<XPROTO>) {

last if (/\#else/);

}

}

next if(/\#else/);

next if(/\#endif/);

next if(/\#undef/);

next if(/\#ifdef NEED_EVENTS/);

next if(/\#ifdef NEED_REPLIES/);

next if(/\#ifndef XPROTO_H/);

next if(/\#include/);        # maybe do these some other time.

$eventing=1 if(/^\#define KeyPress/);

$eventing=0 if(/^\#define LASTEvent/);

if(/^\#define (\w+)$/) {

$defines{$1} = 1;

print "# defined flag $1\n";

next;

}

if(/^\#define sz_(\w+) (\d+)$/) {

$xsizeof{$1} = $2;

print "# processed size $1\n";

next;

}

if(/^\#define (\w+) CARD(\d+)$/) {

$xtypeof{$1} = "CARD".$2;

$xsizeof{$1} = $2/8;

print "# processed type $1\n";

next;

}

if(/^\#define (\w+)\s+(\d+)L?\s*$/) {

$defines{$1} = $2;

print "# defined flag $1 = $2\n";

my ($s,$t) = ($1,$2);

if(/^\#define X\_/) {

$requests[$t] = $s;

print "# request $t maps to $s\n";

}

if ($eventing) {

$events[$t] = $s;

print "# event code $t maps to $s\n";

}

$eventing=0 if(/^\#define LASTEvent/);

next;

}

if(/^\#define (\w+)\s+(0x[0-9a-fA-F]+)\s*$/) {

$defines{$1} = oct($2);

print "# defined flag $1 = $2\n";

next;

}

if(/^\#define (\w+)\s+\(1L?<<(\d+)\)\s*$/) {

$defines{$1} = 2**$2;

print "# defined flag $1 = $defines{$1} (2**$2)\n";

next;

}

if(/^typedef CARD(\d+) (\w+);/) {

$xtypeof{$2} = "CARD".$1;

$xsizeof{$2} = $1/8;

print "# processed type $2\n";

next;

}

if(/^typedef struct \{/) {

&process_struct();

next;

}

if(/^typedef struct _(\w+) \{/) {

&process_struct();

next;

}

if(/^typedef (\w+) (\w+);/) {

$xtypeof{$2} = $xtypeof{$1};

$xsizeof{$2} = $xsizeof{$1};

print "# processed type $2 (alias of $1)\n";

$xalias{$2} = $1;

next;

}

#        print;

}

}

# process_struct: walk XPROTO when we've got a typedef struct to work \

on

# handle some unions, filling in xsizeof and xtypeof only.  skip comme\

nts

# and WORD64 code.

sub process_struct {

my($typ,$siz) = ([],0);

while(<XPROTO>) {

$incomment = &fropcomment($incomment);

if(/\#if defined\(\_\_cplusplus\) \|\| defined\(c\_plusplus\)/\

) {

while(<XPROTO>) {

last if (/\#else/);

}

}

if(/\#ifdef WORD64/) {

while(<XPROTO>) {

last if (/\#else/);

}

}

next if(/\#else/);

next if(/\#endif/);

s/ +B16//g;

s/ B32//g;

last if(/\} (\w+)\;/);

if(/union \{/) {

my($utt);

print "# handling Union\n";

while(<XPROTO>) {

local($in_union) = !defined($xtypeof{"mappingNotify"})\

;

$utt = $_;

if(/struct \{/) {

&process_struct();

}

last if($utt =~ /\} u\;/);

}

}

while(/(\w+)\s+(\w*)\,/) {

while(/(\w+)\s+(\w+)\,/) {

push(@$typ,"$1 $2");

$siz += $xsizeof{$1};

s/$2\,//;

}

last if (/(\w+)\s+(\w+)\;/);

$_ .= <XPROTO>;

s/\/\*.*\*\///g;

s/ +B16//g;

s/ B32//g;

}

if(/(\w+)\s+(\w+)\[(\d+)\]\;/) {

push(@$typ,"$1 $2 $3");

$siz += $xsizeof{$1}*$3;

}

if(/(\w+)\s+(\w+)\;/) {

push(@$typ,"$1 $2");

$siz += $xsizeof{$1};

}

}

m/\} (\w+);/;

my $t = $1;

print "# processed type $t\n";

if($t eq "xEvent") {

# xEvent is a "special" case...

# xsizeof is already set...

# and we don't really need xtypeof...

$typ = ["BYTE raw_bits 32"];

$siz = 32;

}

if($siz != $xsizeof{$t}) {

print "### mismatch:  @$typ, $siz, $t, $xsizeof{$t}\n";

}

if ($in_union == 1) {

if ($t eq "u") {

if (!defined($xtypeof{"mappingNotify"})) {

print "SETTING union_u to @$typ/$siz\n";

&