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";

$union_u_typeof = $typ;

$union_u_sizeof = $siz;

} else {

$in_union = 0;

}

} else {

print "ADDING @$union_u_typeof to $t\n";

print "WAS @$typ...\n";

if ($$typ[0] eq "CARD32 pad00") {

splice(@$typ,0,1,@$union_u_typeof);

}

print "IS NOW @$typ...\n";

print "SIZ is $siz\n";

}

}

$xtypeof{$t} = join(":",@$typ);

$xsizeof{$t} = $siz;

}

# munchkeys: walk all xtypeof and generate xpackof

sub munchkeys {

for $typ (keys %xtypeof) {

print "Walking: $typ -- ";

&walk_type($typ);

$ss = length(pack($xpackof{$typ},0));

print "$xpackof{$typ}, $xsizeof{$typ} $ss\n";

if($ss != $xsizeof{$typ}) {

print "MISMATCH: $xtypeof{$typ}\n";

}

}

}

# walk_type: given a type that's in xtypeof, generate xpackof

#  *and* modify xtypeof by dropping pad fields

sub walk_type {

my($typ) = @_;

return if $xpackof{$typ} ne ""; # already done

return if !defined($xtypeof{$typ});        # not doable

my($xele,$save_1,$save_3);

my $xnew = [];

for $xele (split(/\:/,$xtypeof{$typ})) {

if($xele =~ /^(\w+) (\w+)$/) {

$save_1 = $1;

# allow preloads for "special" names like "BYTE pad"

if($xpackof{$xele} ne "") {

# assume a "whole line" subst means padding,

# and we drop the field. Might change this later.

$save_1 = $xele;

} else {

push(@$xnew,$xele);

}

if($xpackof{$save_1} eq "") {

&walk_type($save_1);

}

$xpackof{$typ} .= $xpackof{$save_1};

} elsif($xele =~ /^(\w+) (\w+) (\d+)$/) {

$save_1 = $1; $save_3 = $3;

# allow preloads for "special" names like "BYTE pad 3"

if($xpackof{"$1 $2"} ne "") {

# assume a "whole line" subst means padding,

# and we drop the field. Might change this later.

$save_1 = "$1 $2";

} else {

push(@$xnew,$xele);

}

if($xpackof{$save_1} eq "") {

&walk_type($save_1);

}

$xpackof{$typ} .= $xpackof{$save_1}.$save_3;

} elsif($xele =~ /^(\w+)$/) {

# it can't really recurse here, can it?

# maybe if something is typedef xCharInfo.

push(@$xnew,$xele);

$xpackof{$typ} .= $xpackof{$1};

} else {

die "bad element of $typ: $xele ($xtypeof{$typ})";

}

}

$xtypeof{$typ} = join(":",@$xnew);

}

for $fn ("/usr/include/X11/Xproto.h", "/usr/include/X11/Xprotostr.h",

"extra-Xproto.h", "/usr/include/X11/X.h",

"/usr/include/X11/cursorfont.h") {

open(XPROTO,"< $fn") || die "Couldn't open $fn: $@";

&munchproto;

close XPROTO;

}

# X.h to actually to pick up *Mask, GC* and the like...

&munchkeys;

open(PERLOUT,">Xproto2.perl") || die "couldn't open Xproto2.perl: $\

@";

open(LISPOUT,">Xproto2.el") || die "couldn't open Xproto2.el: $@";

print PERLOUT "package X;\n";

print PERLOUT "\%xpackof = (\n";

print LISPOUT "(setq xpackof '(\n";

for $xtype (sort keys %xpackof) {

print PERLOUT qq{"$xtype", "$xpackof{$xtype}",\n};

print LISPOUT qq{("$xtype" "$xpackof{$xtype}")\n};

}

print PERLOUT "); # xpackof\n";

print LISPOUT ")) ; xpackof\n";

print PERLOUT "\%xtypeof = (\n";

print LISPOUT "(setq xtypeof '(\n";

for $xtype (sort keys %xtypeof) {

print PERLOUT qq{"$xtype", "$xtypeof{$xtype}", \n};

print LISPOUT qq{("$xtype" (};

for (split(/\:/,$xtypeof{$xtype})) {

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

print LISPOUT qq{("$2" $1) };

$result{$2} = shift @fields;

}

print LISPOUT qq{))\n};

#    print LISPOUT qq{("$xtype" "$xtypeof{$xtype}")\n};

}

print PERLOUT "); # xtypeof\n";

print LISPOUT ")) ; xtypeof\n";

print PERLOUT "\%xsizeof = (\n";

print LISPOUT "(setq xsizeof '(\n";

for $xtype (sort keys %xtypeof) {

print PERLOUT qq{"$xtype", $xsizeof{$xtype},\n};

print LISPOUT qq{("$xtype" $xsizeof{$xtype})\n};

}

print PERLOUT "); # xsizeof\n";

print LISPOUT ")) ; xsizeof\n";

print PERLOUT "\%defines = (\n";

print LISPOUT "(setq xdefines '(\n";

for $def (sort keys %defines) {

print PERLOUT qq{"$def", $defines{$def},\n};

print LISPOUT qq{("$def" $defines{$def})\n};

}

print PERLOUT "); # defines\n";

print LISPOUT ")) ; xdefines\n";

print PERLOUT "sub pad4 { ((\$_[0]+3)>>2)<<2; }\n";

print PERLOUT qq{sub xpad { my \$l=pad4(\$_[0])-\$_[0]; "\\0" x \$l; }\

\n};

%xsubs=();

for $def (sort keys %defines) {

next if $def !~ /^X_/;

($j = $def) =~ s/^X_//;

print PERLOUT qq{\$$j = $defines{$def};\n};

# don't need X:: scoping in these copies...

my $req = "x${j}Req";

if (defined $xpackof{$req}) {

if ($xalias{$req} eq "xResourceReq") {

print PERLOUT qq{sub $req { pack(\$xpackof{"$req"},\$$j,2,\

\@_);}\n};

$xsubs{$req} = $req;

print PERLOUT "sub new$req { $req(\@_); }\n";

$xsubs{"new$req"} = "new$req";

} elsif ($xalias{$req} eq "xReq") {

print "GOTONE: xReq $j/$req isn't fake\n";

print PERLOUT qq{sub $req { pack(\$xpackof{"$req"},\$$j,0,\

1);}\n};

} else {

my @fields = split(/\:/,$xtypeof{$req});

if ($fields[1] eq "CARD16 length") {

print PERLOUT

qq{sub $req { pack(\$xpackof{"$req"},\$$j,\@_);}\n\

};

} elsif ($fields[2] eq "CARD16 length") {

print PERLOUT

qq{sub $req { pack(\$xpackof{"$req"},\$$j,\$_[1],\\

$_[0],\@_[2..\$#_]);}\n};

} else {

print "$req failed: ".join(":",@fields)."\n";

die;

}

my $fl = scalar(@fields)-2; # -length, -reqType, so points to extra

print PERLOUT "sub new$req { my \$l=\$_[$fl]; my \$x=$req(0,\@_).\$l; \

$req(pad4(length(\$x))/4,\@_).\$l.xpad(length(\$x)); }\n";

$xsubs{$req} = $req;

$xsubs{"new$req"} = "new$req";

}

} elsif ($xalias{$j} eq "xReq") {

print PERLOUT qq{sub $req { pack(\$xpackof{"$j"},\$$j,0,1);}\n\

};

$xsubs{$req} = $req;

print PERLOUT "sub new$req { $req(\@_); }\n";

$xsubs{"new$req"} = "new$req";

}

}

print PERLOUT "\%xsubs = (\n";

for $subs (sort keys %xsubs) {

print PERLOUT qq{"$subs" => \\&$subs,\n};

}

print PERLOUT ");\n";

for $def (sort keys %defines) {

print PERLOUT qq{\$requests[$defines{$def}] = "$def";\n} if $def =\

~ /^X_/;

}

{

print PERLOUT "\@xevents = (\"";

print PERLOUT join(qq{\",\"}, @events);

print PERLOUT "\"); # xevents\n";

}

print PERLOUT "package XC;\n";

for $def (sort keys %defines) {

next if $def !~ /^XC_(.*)$/;

print PERLOUT "\$$1 = $defines{$def};\n";

}

print PERLOUT "1;\n";

close PERLOUT;

close LISPOUT;

Issue_05_X 9. reqs

Download reqs

$requests[1] = "X_CreateWindow"; [done]

$requests[2] = "X_ChangeWindowAttributes"; [done]

$requests[3] = "X_GetWindowAttributes"; [done]

$requests[4] = "X_DestroyWindow"; [done]

$requests[5] = "X_DestroySubwindows"; [done]

$requests[6] = "X_ChangeSaveSet"; [done]

$requests[7] = "X_ReparentWindow"; [done]

$requests[8] = "X_MapWindow"; [done]

$requests[9] = "X_MapSubwindows"; [done]

$requests[10] = "X_UnmapWindow"; [done]

$requests[11] = "X_UnmapSubwindows"; [done]

$requests[12] = "X_ConfigureWindow"; [done]

$requests[13] = "X_CirculateWindow"; [done]

$requests[14] = "X_GetGeometry"; [done]

$requests[15] = "X_QueryTree"; [done]

$requests[16] = "X_InternAtom"; [done]

$requests[17] = "X_GetAtomName"; [done]

$requests[18] = "X_ChangeProperty"; [done]

$requests[19] = "X_DeleteProperty"; [done]

$requests[20] = "X_GetProperty"; [done]

$requests[21] = "X_ListProperties"; [done]

$requests[22] = "X_SetSelectionOwner"; [done]

$requests[23] = "X_GetSelectionOwner"; [done]

$requests[24] = "X_ConvertSelection"; [done]

$requests[25] = "X_SendEvent"; [done]

$requests[26] = "X_GrabPointer"; [done]

$requests[27] = "X_UngrabPointer"; [done]

$requests[28] = "X_GrabButton"; [done]

$requests[29] = "X_UngrabButton"; [done]

$requests[30] = "X_ChangeActivePointerGrab"; [done]

$requests[31] = "X_GrabKeyboard"; [done]

$requests[32] = "X_UngrabKeyboard"; [done]

$requests[33] = "X_GrabKey"; [done]

$requests[34] = "X_UngrabKey"; [done]

$requests[35] = "X_AllowEvents"; [done]

$requests[36] = "X_GrabServer"; [done]

$requests[37] = "X_UngrabServer"; [done]

$requests[38] = "X_QueryPointer"; [done]

$requests[39] = "X_GetMotionEvents";

$requests[40] = "X_TranslateCoords";

$requests[41] = "X_WarpPointer";

$requests[42] = "X_SetInputFocus";

$requests[43] = "X_GetInputFocus"; [done]

$requests[44] = "X_QueryKeymap";

$requests[45] = "X_OpenFont"; [done]

$requests[46] = "X_CloseFont";

$requests[47] = "X_QueryFont";

$requests[48] = "X_QueryTextExtents";

$requests[49] = "X_ListFonts"; [done]

$requests[50] = "X_ListFontsWithInfo";

$requests[51] = "X_SetFontPath";

$requests[52] = "X_GetFontPath"; [done]

$requests[53] = "X_CreatePixmap"; [done]

$requests[54] = "X_FreePixmap";

$requests[55] = "X_CreateGC"; [done]

$requests[56] = "X_ChangeGC";

$requests[57] = "X_CopyGC";

$requests[58] = "X_SetDashes";

$requests[59] = "X_SetClipRectangles";

$requests[60] = "X_FreeGC";

$requests[61] = "X_ClearArea"; [done]

$requests[62] = "X_CopyArea";

$requests[63] = "X_CopyPlane";

$requests[64] = "X_PolyPoint"; [done]

$requests[65] = "X_PolyLine"; [done]

$requests[66] = "X_PolySegment"; [done]

$requests[67] = "X_PolyRectangle"; [done]

$requests[68] = "X_PolyArc"; [done]

$requests[69] = "X_FillPoly";

$requests[70] = "X_PolyFillRectangle"; [done]

$requests[71] = "X_PolyFillArc"; [done]

$requests[72] = "X_PutImage"; [done]

$requests[73] = "X_GetImage";

$requests[74] = "X_PolyText8";

$requests[75] = "X_PolyText16";

$requests[76] = "X_ImageText8"; [done]

$requests[77] = "X_ImageText16";

$requests[78] = "X_CreateColormap";

$requests[79] = "X_FreeColormap";

$requests[80] = "X_CopyColormapAndFree";

$requests[81] = "X_InstallColormap";

$requests[82] = "X_UninstallColormap";

$requests[83] = "X_ListInstalledColormaps";

$requests[84] = "X_AllocColor";

$requests[85] = "X_AllocNamedColor";

$requests[86] = "X_AllocColorCells";

$requests[87] = "X_AllocColorPlanes";

$requests[88] = "X_FreeColors";

$requests[89] = "X_StoreColors";

$requests[90] = "X_StoreNamedColor";

$requests[91] = "X_QueryColors";

$requests[92] = "X_LookupColor";

$requests[93] = "X_CreateCursor";

$requests[94] = "X_CreateGlyphCursor";

$requests[95] = "X_FreeCursor";

$requests[96] = "X_RecolorCursor";

$requests[97] = "X_QueryBestSize";

$requests[98] = "X_QueryExtension";

$requests[99] = "X_ListExtensions"; [done]

$requests[100] = "X_ChangeKeyboardMapping";

$requests[101] = "X_GetKeyboardMapping"; [done]

$requests[102] = "X_ChangeKeyboardControl";

$requests[103] = "X_GetKeyboardControl"; [done]

$requests[104] = "X_Bell"; [done]

$requests[105] = "X_ChangePointerControl";

$requests[106] = "X_GetPointerControl";

$requests[107] = "X_SetScreenSaver";

$requests[108] = "X_GetScreenSaver";

$requests[109] = "X_ChangeHosts";

$requests[110] = "X_ListHosts";

$requests[111] = "X_SetAccessControl";

$requests[112] = "X_SetCloseDownMode";

$requests[113] = "X_KillClient";

$requests[114] = "X_RotateProperties";

$requests[115] = "X_ForceScreenSaver";

$requests[116] = "X_SetPointerMapping";

$requests[117] = "X_GetPointerMapping"; [done]

$requests[118] = "X_SetModifierMapping";

$requests[119] = "X_GetModifierMapping"; [done]

$requests[127] = "X_NoOperation";

Issue_05_X 10. wmm.pl

Download wmm.pl

#!perl

require "./xbase.pl";

require "./xatomhash.pl";

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

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

tie %xatom, XATOM, $xopen;

# features:

#   list all (id, name) [done]

#   walk tree doing something

#   move, resize, map/unmap  (by id, by name?)

#   select window with click

sub getwinname {

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

#    $atom_wm_name = xlib::x_internatom($d,$X::defines{"xTrue"},"WM_NA\

ME")

#        if ! defined($atom_wm_name);

#    die if $atom_wm_name == 0;

my @x = xlib::x_getproperty($d,$X::defines{"xFalse"}, $w,$xatom{"W\

M_NAME"},

$X::defines{"AnyPropertyType"}, 0,255)\

;

return $x[1];

}

sub list_all {

my $d = shift;

my $debug = shift;

list_level($d, $xlib::root_window, $debug);

}

sub list_level {

my $d = shift;

my $w = shift;

my $debug = shift;

my @ret;

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

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

kids

for $i (@lf) {

# need one level deeper...

my $wn = getwinname($d, $i);

if ($wn eq "") {

my @l2 = &xlib::x_querytree($d, $i);

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

kids

for $j (@l2) {

my $wn = getwinname($d, $j);

if ($wn ne "") {

printf "%x(%x): %s\n", $i, $j, $wn if $debug;

push(@ret, $i, $wn);

last;

}

}

} else {

printf "%x: %s\n", $i, $wn if $debug;

push(@ret, $i, $wn);

}

}

for $i (@lf) {

push(@ret, list_level($d, $i, $debug));

}

@ret;

}

@list = list_all($xopen,1);

print join(":",@list),"\n";

while(1) {

my $wid = shift @list;

my $wn = shift @list;

if ($wn =~ /studentloan/) {

print "changing $wn\n";

xlib::x_changeproperty($xopen,$X::defines{"PropModeReplace"},$\

wid,

$xatom{"WM_NAME"},$xatom{"STRING"},8,"h\

ello");

xlib::x_changeproperty($xopen,$X::defines{"PropModeReplace"},$\

wid,

$xatom{"WM_ICON_NAME"},$xatom{"STRING"}\

,

8,"hello icon");

}

last if scalar(@list) == 0;

}

xlib::handle_event($xopen);

Issue_05_X 11. xauth.pl

Download xauth.pl

#        2 bytes                Family value (second byte is as in pro\

tocol HOST)

#        2 bytes                address length (always MSB first)

#        A bytes                host address (as in protocol HOST)

#        2 bytes                display "number" length (always MSB fi\

rst)

#        S bytes                display "number" string

#        2 bytes                name length (always MSB first)

#        N bytes                authorization name string

#        2 bytes                data length (always MSB first)

#        D bytes                authorization data string

# define FamilyLocal (256)        /* not part of X standard (i.e. X.h)\

*/

# define FamilyWild  (65535)

# define FamilyNetname    (254)   /* not part of X standard */

# define FamilyKrb5Principal (253) /* Kerberos 5 principal name */

# define FamilyLocalHost (252)        /* for local non-net authenticat\

ion */

# from X.h,

# "FamilyChaos", 2,

# "FamilyDECnet", 1,

# "FamilyInternet", 0,

$X::defines{"FamilyLocal"} = 256;

sub unpack_xauth_record { # $data

my ($data) = @_;

my ($family, $len, $addr, $disp, $authname, $authdata);

($family, $len, $data) = unpack("nna*", $data);

($addr, $data) = unpack("a$len a*", $data);

($len, $data) = unpack("na*", $data);

($disp, $data) = unpack("a$len a*", $data);

($len, $data) = unpack("na*", $data);

($authname, $data) = unpack("a$len a*", $data);

($len, $data) = unpack("na*", $data);

($authdata, $data) = unpack("a$len a*", $data);

return { "family" => $family,

"addr"   => $addr,

"disp"   => $disp,

"authname" => $authname,

"authdata" => $authdata,

"remainder" => $data};

}

sub parse_xauth_file {

my $xadb = ();

my $data;

{

my $xafile = defined($ENV{"XAUTHORITY"})?

$ENV{"XAUTHORITY"}: ($ENV{"HOME"}."/.Xauthority");

local *XAUTH;

open(XAUTH, "<$xafile") || return $xadb;

local $/ = undef;

$data = <XAUTH>;

close XAUTH;

}

while(length($data)) {

my $res = unpack_xauth_record($data);

my $tmprec = {};

$data = $res->{"remainder"};

foreach (sort keys %$res) {

next if /^remainder$/;

$tmprec->{$_} = $res->{$_};

}

push(@$xadb, $tmprec);

}

return $xadb;

}

sub debug_xauth_file {

my $xdb = parse_xauth_file();

foreach (@$xdb) {

my $res = $_;

foreach (sort keys %$res) {

if (/^addr$/ && length($res->{$_}) == 4) { #

print "$_: ",join(".",unpack("C4",$res->{$_})),"\n"\

;

next;

}

print "$_: ",unpack("H*",$res->{$_}),"\n"

if /^authdata$/;

next if /^authdata$/;

print "$_: $res->{$_}\n";

}

}

}

sub search_xauth_file { # display

my($displayname) = @_;

my $xdb = parse_xauth_file();

my ($family, $addr, $res);

# display cases:

# :0.* -- unix, so family = FamilyLocal, addr=`hostname`

# host:0.* -- inet, so family = FamilyInternet, addr = 4byte ip ad\

dr

my($node, $off, $screen);

($node, $off, $screen) = split_display($displayname);

if ($node eq "") {

# unix domain socket case

$family = $X::defines{"FamilyLocal"};

$addr = `hostname`; chomp $addr;

} else {

# tcp case

$family = $X::defines{"FamilyInternet"};

my ($name, $aliases, $type, $len, $thisaddr) = gethostbyname($\

node);

$addr = $thisaddr;

}

foreach $res (@$xdb) {

if ($res->{"family"} eq $family

&& $res->{"addr"} eq $addr) {

return $res;

}

}

return undef;

}

# debug_xauth_file();

1;

Issue_05_X 12. xbase.pl

Download xbase.pl

#!perl

package xlib;

require "./Xproto2.perl";

sub xlibconvert { # type, data

my ($typ, $data) = @_;

my %result;

my (@fields) = unpack($X::xpackof{$typ},$data);

for (split(/\:/,$X::xtypeof{$typ})) {

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

$result{$2} = shift @fields;

}

# nice trick: roll the sizeof in here too...

$result{"sizeof"} = $X::xsizeof{$typ};

$result{"packof"} = $X::xpackof{$typ};

$result{"typeof"} = $X::xtypeof{$typ};

$result{"typ"} = $typ;

return \%result;

}

sub debugxlib { # value

my ($val) = @_;

print "$val->{typ}:\n";

for (split(/:/,$val->{"typeof"})) {

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

print "\t$2: $val->{$2}\n";

}

1;

}

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

use Socket qw(AF_INET PF_INET SOCK_STREAM INADDR_ANY AF_UNIX PF_UNIX);

sub mkport {

my($saddr,$port,$FD) = @_;

my $proto = (getprotobyname("tcp"))[2];

my $sin = Socket::sockaddr_in($port, $saddr);

socket($FD, PF_INET, SOCK_STREAM, $proto) || return "socket:$!";

connect($FD, $sin) || return "connect:$!";

select($FD); $| = 1; select(STDOUT); $| = 1;

return "OK";

}

sub mkport_unix {

my($path,$FD) = @_;

my $proto = 0;                # *not* tcp...

my $sun = Socket::sockaddr_un($path);

socket($FD, PF_UNIX, SOCK_STREAM, $proto) || return "socket:$!";

connect($FD, $sun) || return "connect:$!";

select($FD); $| = 1; select(STDOUT); $| = 1;

return "OK";

}

sub split_display { # $disp var

my ($node, $dispnum, $off, $screen);

my ($displayname) = @_;

($node,$dispnum)=split(':',$displayname);

($off,$screen) = split('\.',$dispnum);

$screen = 0 if !defined($screen);

return ($node, $off, $screen);

}

require "./xauth.pl";

sub min { my($a,$b)=@_; ($a<$b) ? $a : $b; }

sub serverprint { # $d

my $d = shift;

print {$d->{"XFD"}} @_;

if ($debug || $debugpkt) {

print "seq: $xseqnum\n"; $xseqnum++;

printf("x request: ".("%02x " x min(128,length($_[0])))."\n",

unpack("C*",$_[0]));

print "x request length = ",length($_[0]),"\n";

}

}

sub x_open_display {

my($displayname) = @_;

my($node, $off, $screen, $base);

#  local(XFD);

my($reply)="";

my $result = {};

my (@root, @pixmap_format);

($node, $off, $screen) = split_display($displayname);

$result->{"Screen"} = $screen;

print "x_open_display: n=$node, o=$off, s=$screen\n" if $debug;

if ($node eq "") {

# get a socket... /tmp/.X11-unix/X\d are unix domain sockets

my $path = "/tmp/.X11-unix/X$off";

$status = &mkport_unix($path,\*XFD);

} else {

($name, $aliases, $type, $len, $thisaddr) = gethostbyname($nod\

e);

$status = &mkport($thisaddr,$X::TCP_PORT+$off,\*XFD);

if($status ne "OK") { return undef; }

}

$result->{"XFD"} = \*XFD;

my $xauth = search_xauth_file($displayname);

# network byte order is MSB first

# byte "B" for MSB first, then CARD16 major, CARD16 minor,

#  STRING8 auth prot name, STRING8 auth prot data

my $xauthname = defined($xauth)?$xauth->{"authname"}:"";

my $xauthdata = defined($xauth)?$xauth->{"authdata"}:"";

my $x= xpack("xConnClientPrefix",

unpack("S","lB")&255,

$X::PROTOCOL, $X::PROTOCOL_REVISION,

length($xauthname),

length($xauthdata),

0);

$x.= $xauthname;

$x .= "\0" x (&pad4(length($x))-length($x));

$x.= $xauthdata;

$x .= "\0" x (&pad4(length($x))-length($x));

$xseqnum = 0;

serverprint($result, $x);

print STDOUT "reading...\n" if $debug;

# "read" doesn't work anymore with 1024, though shorter vals are o\

k

# perhaps we should just read sizeof(xConnSetupPrefix)?

sysread(XFD,$reply,1024) || ($status = "read:$!" && return undef);

print STDOUT "done reading...\n" if $debug;

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

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

if($success == 0) {

print "Proto Major: ", $output->{"majorVersion"},

" Proto Minor: ", $output->{"minorVersion"}, "\n";

$rlen = $output->{"lengthReason"};

$xlen = $output->{"sizeof"};

print "reason len: $rlen\n";

$reason = substr($reply,$xlen,$rlen);

$status = "open failed: $reason";

return undef;

} else {

$xlen = $output->{"sizeof"};

$output = &xlibconvert("xConnSetup", substr($reply, $xlen));

debugxlib($output) if $debug;

$result->{"setup"} = $output;

$xlen += $output->{"sizeof"};

$vlen = $output->{"nbytesVendor"};

$vendor = substr($reply, $xlen, $vlen);

print "Vendor: $vendor\n" if $debug;

$result->{"vendor"} = $vendor;

# ignore the rest for now...

# @output contains most of the fields...

$resource_id_base = $output->{"ridBase"};

$resource_id_mask = $output->{"ridMask"};

$resource_id_ctr = 1;        # store this in $result too?

$max_request_size = $output->{"maxRequestSize"};

$nroots = $output->{"numRoots"};

$nformats = $output->{"numFormats"};

$base = &pad4($xlen+$vlen);

for $i (0..$nformats-1) {

$pixmap_format[$i] =

&xlibconvert("xPixmapFormat", substr($reply, $base));

debugxlib($pixmap_format[$i]) if $debug;

$base += $pixmap_format[$i]->{"sizeof"};

}

$result->{"Formats"} = \@pixmap_format;

# $rootbase = &pad4($xlen+$vlen)+$X::xsizeof{"xPixmapFormat"}*$n\

formats;

# just use the first root for now...

for $i (0..$nroots-1) {

$root[$i] = &xlibconvert("xWindowRoot", substr($reply,$base)\

);

$base += $root[$i]->{"sizeof"};

debugxlib($root[$i]) if $debug;

for $j (0..$root[$i]->{"nDepths"}-1) {

my $d = &xlibconvert("xDepth", substr($reply,$base));

debugxlib($d) if $debug;

$root[$i]->{"depth"}[$j] = $d;

$base += $d->{"sizeof"};

for $k (0..$d->{"nVisuals"}-1) {

my $v = &xlibconvert("xVisualType",substr($reply,$ba\

se));

debugxlib($v) if $debug;

$d->{"visual"}[$k] = $v;

$base += $v->{"sizeof"};

}

}

}

$result->{"readqueue"} = substr($reply,$base);

$result->{"Roots"} = \@root;

$root_window = $root[$screen]->{"windowId"};

$root_white = $root[$screen]->{"whitePixel"};

$root_black = $root[$screen]->{"blackPixel"};

print "Root Window: $root_window\n" if $debug;

return $result;

}

}

sub xdebugdisplay {                        # xopendisplay result

my $disp = shift;

my ($i, $j, $k);

my ($format, $root, $depth, $visual);

debugxlib($disp->{"setup"});

for $i (0..$disp->{"setup"}->{"numFormats"}-1) {

my $format = $disp->{"Formats"}[$i];

debugxlib($format);

}

for $i (0..$disp->{"setup"}->{"numRoots"}-1) {

my $root = $disp->{"Roots"}[$i];

print "Root $i\n";

debugxlib($root);

for $j (0..$root->{"nDepths"}-1) {

my $depth = $root->{"depth"}[$j];

print "Root $i Depth $j\n";

debugxlib($depth);

for $k (0..$depth->{"nVisuals"}-1) {

my $visual = $depth->{"visual"}[$k];

print "Root $i Depth $j Visual $k\n";

debugxlib($visual);

}

}

}

}

sub next_resource_id {

$resource_id_base | ($resource_id_mask & $resource_id_ctr++);

}

sub pad4 { (($_[0]+3)>>2)<<2; }

sub x_beep {

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

serverprint($d,X::newxBellReq($percentage));

"OK";

}

sub x_washwindow {

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

serverprint($d, &{$X::xsubs{"x${func}Req"}}($w));

"OK"

}

sub x_destroywindow { x_washwindow("DestroyWindow", @_); }

sub x_destroysubwindows { x_washwindow("DestroySubwindows", @_); }

sub x_mapwindow { x_washwindow("MapWindow", @_); }

sub x_mapsubwindows { x_washwindow("MapSubwindows", @_); }

sub x_unmapwindow { x_washwindow("UnmapWindow", @_); }

sub x_unmapsubwindows { x_washwindow("UnmapSubwindows", @_); }

sub x_configurewindow {

my($d,$wind,$mask,@vals)=@_;

genvec2($d, "xConfigureWindowReq", "XID", [$wind,$mask], \@vals);

}

sub x_reparentwindow {

my ($d, $w, $p, $x, $y) = @_;

serverprint($d, X::newxReparentWindowReq($w,$p,$x,$y));

"OK"

}

sub x_circulatewindow {

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

serverprint($d, X::newxCirculateWindowReq($dir,$w));

"OK"

}

sub x_changesaveset {

my ($d, $mode, $win) = @_;

serverprint($d, X::newxChangeSaveSetReq($mode,$win));

"OK";

}

sub x_clear_area {

my($d, $wind, $expose, $x,$y,$width,$height)=@_;

serverprint($d, X::newxClearAreaReq($expose,$wind, $x,$y,$width,$h\

eight));

"OK";

}

sub x_create_pixmap {

my($d,$draw, $depth, $width, $height)=@_;

my($ret);

# 4 is length -- fix it?

serverprint($d,X::newxCreatePixmapReq($depth, $ret = &next_resourc\

e_id,

$draw, $width, $height));

$ret;

}

sub x_create_gc {

my($d,$draw, $mask, @vals)=@_;

my($ret);

genvec2($d,"xCreateGCReq","XID", [$ret = &next_resource_id, $draw,\

$mask],

\@vals);

$ret;

}

sub x_put_image {

my($d,$draw,$gc,$format,$image,$destx,$desty,$width,$height,$lpad,\

$depth,$bpl)

= @_;

my($imm,$lns,$off_l,$off);

my($chunk_lines,$chunk_bytes);

my $overhead = $X::xsizeof{"xPutImageReq"};

my $maxreq = (4*$max_request_size)-$overhead;

$lns = $xh;

$off_l = 0;

$off = 0;

$chunk_lines = int($maxreq/$bpl);

$chunk_bytes = $bpl * $chunk_lines;

while(length($image)-$off > $maxreq) {

$imm = substr($image, $off, $chunk_bytes);

# print "imm: ",length($imm),"\n";

&xlib::x_real_put_image($d,$draw,$gc,$format,

$imm,$destx,$desty+$off_l,

$width,$chunk_lines,$lpad,$depth);

$off_l += $chunk_lines;

$off = $bpl * $off_l;

}

$off = $bpl * $off_l;

if (length($image)-$off > 0) {

$imm = substr($image, $off);

# print "imm trail: ",length($imm),"\n";

&xlib::x_real_put_image($d,$draw,$gc,$format,

$imm,$destx,$desty+$off_l,

$width,$height-$off_l,$lpad,$depth);

}

}

sub x_real_put_image {

my($d,$draw,$gc,$format,$image,$destx,$desty,$width,$height,$lpad,\

$depth)

= @_;

genvecstr($d, "xPutImageReq", [$format, $draw, $gc, $width, $heigh\

t,

$destx, $desty, $lpad, $depth], $im\

age);

"OK";

}

sub x_get_window_attributes {

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

my ($rep,$q) = x_reply($d, "GetWindowAttributes", [$w]);

$rep;

}

sub x_change_window_attributes {

my $d = shift;

my ($win, $mask, @vals) = @_;

genvec2($d, "xChangeWindowAttributesReq", "XID", [$win,$mask], \@v\

als);

}

sub x_set_window_background_pixmap {

my($d,$wind,$pixmap)=@_;

x_change_window_attributes($d,$wind,$X::defines{"CWBackPixmap"},$p\

ixmap);

}

sub extend_queue {

my $d = shift;

my $l = shift;

while (length ($d->{"readqueue"}) < $l) {

my $data = "";

sysread($d->{"XFD"},$data,1024) || die "$! in extend_queue"\

;

$d->{"readqueue"} .= $data;

}

}

sub x_getatomname {

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

my ($rep,$q) = x_reply($d,"GetAtomName", [$atom]);

my $sl = $rep->{"nameLength"};

my $name; my $pl = pad4($sl)-$sl;

($name,$$q) = unpack("a$sl x$pl a*", $$q);

print "atom name: $name\n" if $debug;

$name;

}

sub x_internatom {

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

genvecstr($d, "xInternAtomReq", [$exists,length($name)], $name);

handle_event($d);

my ($rep,$q) = xqueueconvert($d,"xInternAtomReply");

$rep->{"atom"};

}

sub x_getproperty {

my ($d,$flag,$win,$prop,$type,$loff,$llen) = @_;

my ($rep,$q) =

x_reply($d,"GetProperty", [$flag,$win,$prop,$type,$loff,$llen]\

);

my $f = $rep->{"format"};        # 0 8 16 32

my $sl = $rep->{"nItems"}*$f/8;

my $val; my $pl = pad4($sl)-$sl;

($val,$$q) = unpack("a$sl x$pl a*", $$q);

print "atom value: $val\n" if $debug && ($f eq 8);

return ($f, $val, $rep->{"propertyType"});

}

sub x_changeproperty {

my ($d,$mode,$win,$prop,$type,$form,@vals) = @_;

# for format=8, use a string, else a list

my $p = "CARD$form";

if ($form == 8) {

@vals = unpack("C*",$vals[0]);

}

genvec2($d,"xChangePropertyReq",$p,

[$mode,$win,$prop,$type,$form,scalar(@vals)], \@vals);

"OK";

}

sub x_deleteproperty {

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

serverprint($d, X::newxDeletePropertyReq($w,$a));

"OK";

}

sub x_getfontpath {

my ($d) = @_;

x_iter($d, "GetFontPath", "nPaths", "STRING8");

}

sub x_listfonts {

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

x_iter($d,"ListFonts","nFonts","STRING8", [-1,length($f),$f]);

}

sub x_listextensions {

my ($d) = @_;

x_iter($d,"ListExtensions","nExtensions","STRING8");

}

sub x_get_geometry {                # very much like GetWindowAttribut\

es...

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

my ($rep,$q) = x_reply($d, "GetGeometry", [$w]);

$rep;

}

sub x_get_one {

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

my ($rep,$q) = x_reply($d, $type);

$rep;

}

sub x_get_input_focus { x_get_one("GetInputFocus",@_); }

sub x_get_keyboard_control { x_get_one("GetKeyboardControl",@_); }

require "./xerror.pl";

sub handle_event {

my $d = shift;

my $rep;

my $q = \$d->{"readqueue"};

extend_queue($d, $X::xsizeof{"xEvent"});

$rep = xlibconvert("xGenericReply",$$q);

if ($rep->{"type"} == $X::Reply) {

print "reply: \n" if $debug;

debugxlib($rep) if $debug;

extend_queue($d, $X::xsizeof{"xEvent"}+4*$rep->{"length"});

# handle reply

return $rep->{"length"};

} elsif ($rep->{"type"} == $X::Error) {

# handle error

$rep = &xlibconvert("xError",$$q);

print "xerror: $X::ErrorList[$rep->{errorCode}]\n";

printf "xerror: resid %x\n", $rep->{"resourceID"};

print  "major:  $X::requests[$rep->{majorCode}]\n";

debugxlib($rep);

$$q = substr($$q,$rep->{"sizeof"});

return undef;

} else {

# process the event off the input queue and on to the event qu\

eue...

$rep = xlibconvert("u",$$q);

print "xevent: $X::xevents[$rep->{type}]\n" if $debug;

my $h = $handler{$X::xevents[$rep->{"type"}]};

&$h if (defined $h);

debugxlib($rep) if $debug || !defined($h);

skipevent($d, "xEvent");

return 0;

}

return -1;

}

sub skipevent { # tag

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

my $q = \$d->{"readqueue"};

$$q = substr($$q, $X::xsizeof{$tag});

print "event queue length: ",length($$q),"\n" if $debug;

}

sub xqueueconvert {

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

my $ret = xlibconvert($tag,$d->{"readqueue"});

debugxlib($rep) if $debug;

skipevent($d, $tag);

($ret, \$d->{"readqueue"});

}

sub defaultroot {

my $d = shift;

return $d->{"Roots"}[$d->{"Screen"}]->{"windowId"};

}

sub defaultrootdepth {

my $d = shift;

return $d->{"Roots"}[$d->{"Screen"}]->{"rootDepth"};

}

sub x_reply {

my ($d, $func, $args) = @_;

serverprint($d, &{$X::xsubs{"newx${func}Req"}}(@$args));

handle_event($d);

xqueueconvert($d,"x${func}Reply");

}

sub x_iter_raw {

my ($d, $func, $counter, $vtype, $args) = @_;

my ($rep,$q) = x_reply($d, $func, $args);

my ($val,$i,@ret);

for $i (1..$rep->{$counter}) {

if ($vtype eq "STRING8") {

my ($sl) = unpack("C",$$q);

($sl,$val,$$q) = unpack("C a$sl a*", $$q);

} else {

($val,$$q) = unpack($X::xpackof{$vtype}."a*", $$q);

}

print "$vtype: <$val>\n" if $debug;

push(@ret,$val);

}

return ($rep, @ret);        # some reps have useful info...

}

sub x_iter {

my ($rep,@ret) = x_iter_raw(@_);

return @ret;

}

sub x_listproperties {

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

x_iter($d, "ListProperties", "nProperties", "Atom", [$w]);

}

sub x_querytree {

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

$root = defaultroot($d) if (!defined($root));

x_iter_raw($d, "QueryTree", "nChildren", "Window", [$root]);

}

sub x_get_keyboard_mapping {

my ($d, $first, $count) = @_;

x_iter_raw($d, "GetKeyboardMapping","length","KeySym", [$first,$co\

unt]);

}

sub x_get_modifier_mapping {

my ($d) = @_;

x_iter_raw($d, "GetModifierMapping","length","KeyCode");

}

sub x_get_pointer_mapping {

my ($d) = @_;

x_iter($d, "GetPointerMapping","nElts","CARD8");

}

sub x_imagetext8 {

my $d = shift;

my ($w, $gc, $x, $y, $string) = @_;

my $l = length($string);

genvecstr($d, "xImageText8Req", [$l,$w,$gc,$x,$y], $string);

"OK";

}

sub x_openfont {

my $d = shift;

my ($f) = (@_);                # font name

my $l = length($f);

genvecstr($d, "xOpenFontReq", [$ret = &next_resource_id,$l], $f);

$ret;

}

sub splitcolor {

my ($c) = @_;

return ($$c[0],$$c[1],$$c[2]);

}

sub joincolor {

my ($r,$g,$b) = @_;

return [$r,$g,$b];

}

sub x_createfontcursor {

my ($d,$ch,$fore,$back) = @_;

if (!defined($d->{"cursorfont"})) {

$d->{"cursorfont"} = x_openfont($d,"cursor");

}

my $c = $d->{"cursorfont"};

my $cursor;

my ($fr,$fg,$fb) = splitcolor($fore);

my ($br,$bg,$bb) = splitcolor($back);

print "Fore($fore): $fr,$fg,$fb\n" if $debug;

print "Back($back): $br,$bg,$bb\n" if $debug;

serverprint($d,

&X::newxCreateGlyphCursorReq($cursor = &next_resource_\

id,

$c, # sourcefont

$c, # maskfont

$ch, # sourcechar

$ch+1, # maskchar

$fr, $fg, $fb,

$br, $bg, $bb));

$cursor;

}

sub x_closedisplay {

my $d = shift;

close $d->{"XFD"};

}

sub x_create_window {

my($d,$depth,$parent,$x,$y,$w,$h,$bwid,$class,$vis,$mask, @vals) =\

@_;

my($ret);

genvec2($d,"xCreateWindowReq","XID",

[$depth, $ret = &next_resource_id, $parent,

$x,$y,$w,$h,$bwid, $class, $vis, $mask], \@vals);

$ret;

}

sub genvec {

my ($type, @vals) = @_;

my $p = $X::xpackof{$type};

my $nvals = length(pack("C*",unpack($p," "x80)));

my $val = "";

while(1) {

my @v = splice(@vals,0,$nvals);

$val .= pack($p, @v);

last if scalar(@vals) <= 0;

}

return $val;

}

sub genvec2 {

my ($d, $req, $elem, $args, $vals) = @_;

my $val = genvec($elem, @$vals);

serverprint($d,&{$X::xsubs{"new$req"}}(@$args,$val));

"OK";

}

sub genvecstr {

my ($d, $req, $args, $val) = @_;

serverprint($d,&{$X::xsubs{"new$req"}}(@$args,$val));

"OK";

}

sub xpoly1 {

my ($req, $type, $d, $draw, $gc, @vals) = @_;

genvec2($d, "x${req}Req", "x$type", [$draw,$gc], \@vals);

}

sub xpolyarcs { xpoly1("PolyArc", "Arc", @_); }

sub xpolyfillarcs { xpoly1("PolyFillArc", "Arc", @_); }

sub xpolyrects { xpoly1("PolyRectangle", "Rectangle", @_); }

sub xpolyfillrects { xpoly1("PolyFillRectangle", "Rectangle", @_); }

sub xpolysegments { xpoly1("PolySegment", "Segment", @_); }

sub xpoly2 {

my ($req, $type, $d, $mode, $draw, $gc, @points) = @_;

genvec2($d,"x${req}Req", "x$type", [$mode,$draw,$gc], \@points);

}

sub xpolypoints { xpoly2("PolyPoint", "Point", @_); }

sub xpolylines { xpoly2("PolyLine", "Point", @_); }

sub xsetselectionowner {

my ($d,$owner,$selection,$time) = @_;

serverprint($d, X::newxSetSelectionOwner($owner,$selection,$time))\

;

"OK";

}

sub xgetselectionowner {

my ($d) = @_;

my ($rep,$q) = x_reply($d, "GetSelectionOwner");

$rep->{"owner"};

}

sub xconvertselection {

my ($d,$who,$selection,$target,$prop,$time) = @_;

serverprint($d,

X::newxConvertSelection($who,$selection,$target,$prop,$t\

ime));

"OK";

}

# calls this as

# should be: xsendevent($d,false,PointerWindow,0,X::newxWhatever(...))\

;

# xsendevent($d,false,PointerWindow,0,pack($X::xpackof{"selectionClear\

"},...));

sub xsendevent {

my ($d,$prop,$dest,$mask,$event) = @_;

serverprint($d, X::newxSendEventReq($prop,$dest,$mask,unpack("C32"\

,$event)));

"OK";

}

sub xgrabpointer {

my ($d,$owner,$gwind,$mask,$pmode,$kmode,$confw,$cursor,$time) = @\

_;

my ($rep,$q) = x_reply($d, "GrabPointer",

[$owner,$gwind,$mask,$pmode,$kmode,$confw,$\

cursor,$time]);

return $rep->{"status"};

}

sub xgrabkeyboard {

my ($d,$owner,$wind,$time,$pmode,$kmode) = @_;

my ($rep,$q) = x_reply($d, "GrabKeyboard",

[$owner,$wind,$time,$pmode,$kmode]);

return $rep->{"status"};

}

sub xgrabserver {

my ($d) = @_;

serverprint($d, X::xGrabServerReq());

"OK";

}

sub xgrabbutton {

my ($d,$owner,$grabw,$mask,$pmode,$kmode,$confw,$cursor,$button,$m\

ods)

= @_;

serverprint($d, X::newxGrabButtonReq($owner,$grabw,$mask,$pmode,$k\

mode,$confw,$cursor,$button,$mods));

"OK";

}

sub xgrabkey {

my ($d,$owner,$grabw,$mods,$key,$pmode,$kmode) = @_;

serverprint($d, X::xGrabKeyReq($owner,$grabw,$mods,$key,$pmode,$km\

ode));

"OK";

}

sub x_ungrab {

my ($func, $d, @args) = @_;

serverprint($d, &{$X::xsubs{"newxUngrab${func}Req"}}(@args));

"OK";

}

sub xungrabpointer { x_ungrab("Pointer", @_); }        # time

sub xungrabkeyboard { x_ungrab("Keyboard", @_); } # time

sub xungrabbutton { x_ungrab("Button", @_); } # button,window,mods

sub xungrabkey { x_ungrab("Key", @_); }        # keycode,window,mods

sub xungrabserver { x_ungrab("Server", @_); } # nothing

sub xallowevents {

my ($d,$mode,$time) = @_;

serverprint($d, X::newxAllowEventsReq($mode,$time));

"OK";

}

sub xchangeactivepointergrab {

my ($d, $cursor, $time, $mask) = @_;

serverprint($d, X::newxChangeActivePointerGrabReq($cursor,$time,$m\

ask));

"OK";

}

sub xquerypointer {                # just like x_get_geometry

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

my ($rep,$q) = x_reply($d, "QueryPointer", [$w]);

$rep;

}

1;