# Copyright (C) 2008, Parrot Foundation.
=head1 TITLE
xlib.pir - Test NCI with libX11
=head1 SYNOPSIS
Testing...
This is an initial version, be careful and not expect too much.
=head1 BUGS
Note that the Event structure is platform dependent.
The nci declaration attempts to be platform independent,
but depends of the size of some X11 types and struct
alignment.
=cut
########################################################################
.include 'datatypes.pasm'
#-----------------------------------------------------------------------
.sub fail
.param string msg
new $P0, 'Exception'
new $P1, 'String'
set $P1, msg
setattribute $P0, 'message', $P1
throw $P0
# Just in case...
exit 1
.end
########################################################################
.namespace ['Xlib']
# xlib handle
.const string xlib_handle = 'xlib_handle'
# attributes used for xlib types
.const string attr_XDisplay = 'x_Display'
.const string attr_XDrawable = 'x_Drawable'
.const string attr_XWindow = 'x_Window'
# attributes used for parrot objects
.const string attr_display = 'obj_display'
.const string attr_atoms = 'atoms'
.const string attr_atom_names = 'atom_names'
#-----------------------------------------------------------------------
.sub get_xlib_handle
.local pmc xlib
xlib = get_global xlib_handle
$I0 = defined xlib
if $I0 goto done
# Load library and store handler
xlib = loadlib 'libX11'
$I0 = defined xlib
unless $I0 goto check2
if xlib goto store
check2:
xlib = loadlib 'libX11.so'
$I0 = defined xlib
unless $I0 goto check3
if xlib goto store
check3:
xlib = loadlib 'libX11.so.6'
$I0 = defined xlib
unless $I0 goto check4
if xlib goto store
check4:
xlib = loadlib 'cygX11-6'
$I0 = defined xlib
unless $I0 goto failed
unless xlib goto failed
store:
set_global xlib_handle, xlib
done:
.return(xlib)
failed:
fail('No xlib')
.end
#-----------------------------------------------------------------------
.sub get_xlib_function
.param string name
.param string signature
.local pmc xlib
xlib = get_xlib_handle()
.local pmc func
func = get_global name
$I0 = defined func
if $I0 goto done
func = dlfunc xlib, name, signature
set_global name, func
done:
.return(func)
.end
#-----------------------------------------------------------------------
.sub get_Display_class
.local pmc Display
Display = get_global 'Display_class'
$I0 = defined Display
if $I0 goto done
Display = newclass ['Xlib'; 'Display']
addattribute Display, attr_XDisplay
addattribute Display, attr_atoms
addattribute Display, attr_atom_names
set_global 'Display_class', Display
# export functions to be used from Display methods
.local pmc ns, nsDisplay, nsWindow
ns = get_namespace
nsDisplay = get_namespace ['Display']
.local pmc explist
explist = new 'ResizablePMCArray'
explist[0] = 'get_xlib_handle'
explist[1] = 'get_xlib_function'
explist[2] = 'get_Window_class'
ns.'export_to'(nsDisplay, explist)
nsWindow = get_namespace ['Window']
ns.'export_to'(nsWindow, explist)
done:
.return(Display)
.end
#-----------------------------------------------------------------------
.sub get_Event_class
.local pmc Event
Event = get_global 'Event_class'
$I0 = defined Event
if $I0 goto done
Event = newclass ['Xlib'; 'Event']
addattribute Event, 'xEvent'
set_global 'Event_class', Event
done:
.return(Event)
.end
#-----------------------------------------------------------------------
.sub get_Drawable_class
.local pmc Drawable
Drawable = get_global 'Drawable_class'
$I0 = defined Drawable
if $I0 goto done
Drawable = newclass ['Xlib'; 'Drawable']
addattribute Drawable, attr_XDisplay
addattribute Drawable, attr_XWindow
addattribute Drawable, attr_display
set_global 'Drawable_class', Drawable
# export functions to be used from Drawable methods
.local pmc nsmain, ns
nsmain = get_namespace
ns = get_namespace ['Drawable']
.local pmc explist
explist = new 'ResizablePMCArray'
explist[0] = 'get_xlib_handle'
explist[1] = 'get_xlib_function'
explist[2] = 'get_Pixmap_class'
nsmain.'export_to'(ns, explist)
done:
.return(Drawable)
.end
#-----------------------------------------------------------------------
.sub get_Window_class
.local pmc Window
Window = get_global 'Window_class'
$I0 = defined Window
if $I0 goto done
.local pmc Drawable
Drawable = get_Drawable_class()
Window = subclass Drawable, ['Xlib'; 'Window']
# addattribute Window, attr_display
# addattribute Window, attr_XWindow
set_global 'Window_class', Window
# export functions to be used from Window methods
.local pmc ns, nsWindow
ns = get_namespace
nsWindow = get_namespace ['Window']
.local pmc explist
explist = new 'ResizablePMCArray'
explist[0] = 'get_xlib_handle'
explist[1] = 'get_xlib_function'
ns.'export_to'(nsWindow, explist)
done:
.return(Window)
.end
#-----------------------------------------------------------------------
.sub get_Pixmap_class
.local pmc Pixmap
Pixmap = get_global 'Pixmap_class'
$I0 = defined Pixmap
if $I0 goto done
.local pmc Drawable
Drawable = get_Drawable_class()
Pixmap = subclass Drawable, ['Xlib'; 'Pixmap']
set_global 'Pixmap_class', Pixmap
# export functions to be used from Pixmap methods
.local pmc ns, nsPixmap
ns = get_namespace
nsPixmap = get_namespace ['Pixmap']
.local pmc explist
explist = new 'ResizablePMCArray'
explist[0] = 'get_xlib_handle'
explist[1] = 'get_xlib_function'
ns.'export_to'(nsPixmap, explist)
done:
.return(Pixmap)
.end
#-----------------------------------------------------------------------
.sub OpenDisplay
.param string displayname :optional
.local pmc opendisplay
opendisplay = get_xlib_function('XOpenDisplay', 'pt')
.local pmc xdisplay
xdisplay = opendisplay(displayname)
$I0 = defined xdisplay
unless $I0 goto failed
.local pmc Display
Display = get_Display_class()
.local pmc display
display = new Display
setattribute display, attr_XDisplay, xdisplay
.return(display)
failed:
fail('Cannot open display')
.end
#-----------------------------------------------------------------------
.sub DisplayName
.param string name :optional
.local pmc func
func = get_xlib_function('XDisplayName', 'tt')
if name goto getit
name = ''
getit:
.local string dispname
dispname = func(name)
.return(dispname)
.end
#-----------------------------------------------------------------------
.sub newEvent
.local pmc Event
Event = get_Event_class()
.local pmc event
event = new Event
.return(event)
.end
#-----------------------------------------------------------------------
.sub KeysymToString
.param int keysym
.local pmc func
func = get_xlib_function('XKeysymToString', 'ti')
.local string r
r = func(keysym)
.return(r)
.end
#-----------------------------------------------------------------------
.sub StringToKeysym
.param string keystring
.local pmc func
func = get_xlib_function('XStringToKeysym', 'it')
.local int keysym
keysym = func(keystring)
.return(keysym)
.end
########################################################################
.namespace ['Xlib';'Display']
#-----------------------------------------------------------------------
.sub createfunc
.param pmc handler
.param string name
.param string ncisig
.local pmc func
func = dlfunc handler, name, ncisig
set_global name, func
.end
#-----------------------------------------------------------------------
.sub destroy :vtable
say 'Destroying xlib;Display'
.end
#-----------------------------------------------------------------------
.sub hello :method
say 'Hello'
.end
#-----------------------------------------------------------------------
.sub Close :method
.local pmc closedisplay
closedisplay = get_xlib_function('XCloseDisplay', 'ip')
$P0 = getattribute self, attr_XDisplay
$I0 = closedisplay($P0)
.end
#-----------------------------------------------------------------------
.sub DefaultScreen :method
.local pmc func
func = get_xlib_function('XDefaultScreen', 'ip')
$P0 = getattribute self, attr_XDisplay
$I0 = func($P0)
.return($I0)
.end
#-----------------------------------------------------------------------
.sub DefaultDepth :method
.param int screen :optional
.param int has_screen :opt_flag
if has_screen goto doit
screen = self.'DefaultScreen'()
doit:
.local pmc func
func = get_xlib_function('XDefaultDepth', 'ipi')
$P0 = getattribute self, attr_XDisplay
$I0 = func($P0, screen)
.return($I0)
.end
#-----------------------------------------------------------------------
.sub DefaultGC :method
.local int screen
screen = self.'DefaultScreen'()
.local pmc xdisp
xdisp = getattribute self, attr_XDisplay
.local pmc func
func = get_xlib_function('XDefaultGC','ppi')
$P1 = func(xdisp, screen)
.return($P1)
.end
#-----------------------------------------------------------------------
.sub BlackPixel :method
.param int screen :optional
.param int has :opt_flag
if has goto doit
screen = self.'DefaultScreen'()
doit:
.local pmc func
func = get_xlib_function('XBlackPixel','ipi')
$P0 = getattribute self, attr_XDisplay
$I0 = func($P0, screen)
.return($I0)
.end
#-----------------------------------------------------------------------
.sub WhitePixel :method
.param int screen :optional
.param int has :opt_flag
if has goto doit
screen = self.'DefaultScreen'()
doit:
.local pmc func
func = get_xlib_function('XWhitePixel', 'ipi')
$P0 = getattribute self, attr_XDisplay
$I0 = func($P0, screen)
.return($I0)
.end
#-----------------------------------------------------------------------
.sub InternAtom :method
.param string name
.param int only_if_exists :optional
# say name
# say only_if_exists
.local int atom
.local pmc namestore
namestore = getattribute self, attr_atom_names
.local int has_store
has_store = defined namestore
unless has_store goto get_from_lib
atom = namestore[name]
if atom goto gotit
get_from_lib:
# say 'Get Atom from lib'
.local pmc func
func = get_xlib_function('XInternAtom', 'ipti')
$P0 = getattribute self, attr_XDisplay
atom = func($P0, name, only_if_exists)
if has_store goto saveit
namestore = new 'Hash'
setattribute self, attr_atom_names, namestore
saveit:
namestore[name] = atom
gotit:
# say atom
.return(atom)
.end
#-----------------------------------------------------------------------
.sub GetAtomName :method
.param int atom
.local string name
.local pmc atomstore
atomstore = getattribute self, attr_atoms
.local int has_store
has_store = defined atomstore
unless has_store goto get_from_lib
name = atomstore[atom]
if name goto gotit
get_from_lib:
# say 'Get Atom name from lib'
.local pmc func
func = get_xlib_function('XGetAtomName', 'tpi')
$P0 = getattribute self, attr_XDisplay
name = func($P0, atom)
if has_store goto saveit
atomstore = new 'Hash'
setattribute self, attr_atoms, atomstore
saveit:
atomstore[atom] = name
gotit:
.return(name)
.end
#-----------------------------------------------------------------------
.sub RootWindow :method
.local pmc func
func = get_xlib_function('XRootWindow', 'ppi')
$P0 = getattribute self, attr_XDisplay
.local pmc window
$I0 = self.'DefaultScreen'()
$P1 = func($P0, $I0)
.local pmc arg
arg = new 'Hash'
arg [attr_display] = self
arg [attr_XWindow] = $P1
.local pmc Window
Window = get_Window_class()
window = new Window, arg
.return(window)
.end
#-----------------------------------------------------------------------
.sub CreateSimpleWindow :method
.param pmc parent
.param int x
.param int y
.param int width
.param int height
.param int border_width
.param int border
.param int background
.local pmc func
func = get_xlib_function('XCreateSimpleWindow', 'pppiiiiiii')
$P0 = getattribute self, attr_XDisplay
.local pmc parent_w
parent_w = getattribute parent, attr_XWindow
.local pmc new_window
new_window = func($P0, parent_w, x, y, width, height, border_width, border, background)
if null new_window goto failed
$I0 = defined new_window
unless $I0 goto failed
.local pmc arg
arg = new 'Hash'
arg [attr_display] = self
arg [attr_XWindow] = new_window
.local pmc window
window = new ['Xlib';'Window'], arg
.return(window)
failed:
fail("Can't create window")
.end
#-----------------------------------------------------------------------
.sub NextEvent :method
.param pmc event
.local pmc func
func = get_xlib_function('XNextEvent', 'ipp')
.local pmc disp
disp = getattribute self, attr_XDisplay
.local pmc xevent
xevent = getattribute event, 'xEvent'
$I0 = func(disp, xevent)
.return($I0)
.end
#-----------------------------------------------------------------------
.sub KeycodeToKeysym :method
.param int keysym
.local pmc func
func = get_xlib_function('XKeycodeToKeysym', 'ipii')
.local pmc disp
disp = getattribute self, attr_XDisplay
.local int keycode
keycode = func(disp, keysym, 0)
.return(keycode)
.end
#-----------------------------------------------------------------------
.sub KeysymToKeycode :method
.param int keysym
.local pmc func
func = get_xlib_function('XKeysymToKeycode', 'ipi')
.local pmc disp
disp = getattribute self, attr_XDisplay
.local int keycode
keycode = func(disp, keysym)
.return(keycode)
.end
########################################################################
.namespace ['Xlib';'Event']
#-----------------------------------------------------------------------
.sub get_event_struct
.local pmc arg
arg = get_global 'st_xevent'
$I0 = defined arg
if $I0 goto done
# Check native type sizes
.include 'iglobals.pasm'
.local pmc config_hash, interp
interp = getinterp
config_hash = interp[.IGLOBALS_CONFIG_HASH]
.local int intsize
intsize = config_hash['intsize']
# say intsize
.local int longsize
longsize = config_hash['longsize']
# say longsize
.local int ptrsize
ptrsize = config_hash['ptrsize']
# say ptrsize
.local int timesize
timesize = 4
.local int aligned
aligned = intsize
# If size of long is 8, assume that padding in the struct
eq longsize, 8, adjust8
goto doit
adjust8:
aligned = 8
doit:
.local int char_t
.local int int_t
.local int long_t
.local int ptr_t
.local int time_t
char_t = .DATATYPE_CHAR
int_t = .DATATYPE_INT
long_t = .DATATYPE_LONG
ptr_t = .DATATYPE_PTR
time_t = .DATATYPE_UINT32
arg = new 'FixedIntegerArray'
set arg, 45
# say 'Event struct'
.local int offs
offs = 0
# type
arg[0] = int_t
arg[1] = 1
arg[2] = offs
# say offs
add offs, aligned
#serial
arg[3] = long_t
arg[4] = 1
arg[5] = offs
# say offs
add offs, longsize
# send_event
arg[6] = int_t
arg[7] = 1
arg[8] = offs
# say offs
add offs, aligned
# display
arg[9] = ptr_t
arg[10] = 1
arg[11] = offs
# say offs
add offs, ptrsize
# window
arg[12] = ptr_t
arg[13] = 1
arg[14] = offs
# say offs
add offs, ptrsize
# root
arg[15] = ptr_t
arg[16] = 1
arg[17] = offs
# say offs
add offs, ptrsize
# subwindow
arg[18] = ptr_t
arg[19] = 1
arg[20] = offs
# say offs
add offs, ptrsize
# time
arg[21] = time_t
arg[22] = 1
arg[23] = offs
# say offs
add offs, aligned
# x
arg[24] = int_t
arg[25] = 1
arg[26] = offs
# say offs
add offs, intsize
# y
arg[27] = int_t
arg[28] = 1
arg[29] = offs
# say offs
add offs, intsize
# x_root
arg[30] = int_t
arg[31] = 1
arg[32] = offs
# say offs
add offs, intsize
# y_root
arg[33] = int_t
arg[34] = 1
arg[35] = offs
# say offs
add offs, intsize
# state
arg[36] = int_t
arg[37] = 1
arg[38] = offs
# say offs
add offs, intsize
# keycode
arg[39] = int_t
arg[40] = 1
arg[41] = offs
# say offs
add offs, intsize
# say offs
# filler
arg[42] = char_t
arg[43] = 128
arg[44] = offs
set_global 'st_xevent', arg
done:
.return(arg)
.end
#-----------------------------------------------------------------------
.sub init :vtable
.local pmc arg
arg = get_event_struct()
.local pmc xevent
xevent = new 'ManagedStruct', arg
xevent[0] = 0
setattribute self, 'xEvent', xevent
.end
#-----------------------------------------------------------------------
.sub type :method
.local pmc xevent
xevent = getattribute self, 'xEvent'
$I0 = xevent[0]
.return($I0)
.end
#-----------------------------------------------------------------------
.sub serial :method
.local pmc xevent
xevent = getattribute self, 'xEvent'
$I0 = xevent[1]
.return($I0)
.end
#-----------------------------------------------------------------------
.sub time :method
.local pmc xevent
xevent = getattribute self, 'xEvent'
$I0 = xevent[7]
.return($I0)
.end
#-----------------------------------------------------------------------
.sub x :method
.local pmc xevent
xevent = getattribute self, 'xEvent'
$I0 = xevent[8]
.return($I0)
.end
#-----------------------------------------------------------------------
.sub y :method
.local pmc xevent
xevent = getattribute self, 'xEvent'
$I0 = xevent[9]
.return($I0)
.end
#-----------------------------------------------------------------------
.sub keycode :method
.local pmc xevent
xevent = getattribute self, 'xEvent'
$I0 = xevent[13]
.return($I0)
.end
########################################################################
.namespace ['Xlib';'Drawable']
#-----------------------------------------------------------------------
.sub DrawPoint :method
.param int x
.param int y
.local pmc disp
disp = getattribute self, attr_display
.local pmc xdisp
xdisp = self.'getdisplay'()
.local pmc gc
gc = disp.'DefaultGC'()
.local pmc xwin
xwin = getattribute self, attr_XWindow
.local pmc func
func = get_xlib_function('XDrawPoint', 'ipppii')
$I0 = func(xdisp, xwin, gc, x, y)
.return($I0)
.end
#-----------------------------------------------------------------------
.sub DrawLine :method
.param int x1
.param int y1
.param int x2
.param int y2
.local pmc disp
disp = getattribute self, attr_display
.local pmc xdisp
xdisp = self.'getdisplay'()
.local pmc gc
gc = disp.'DefaultGC'()
.local pmc xwin
xwin = getattribute self, attr_XWindow
.local pmc func
func = get_xlib_function('XDrawLine', 'ipppiiii')
$I0 = func(xdisp, xwin, gc, x1, y1, x2, y2)
.return($I0)
.end
#-----------------------------------------------------------------------
.sub CopyArea :method
.param pmc source
.param int src_x
.param int src_y
.param int width
.param int height
.param int dest_x
.param int dest_y
.local pmc disp, xdisp, src_xdraw, dest_xdraw, gc
disp = getattribute self, attr_display
gc = disp.'DefaultGC'()
xdisp = self.'getdisplay'()
src_xdraw = getattribute source, attr_XWindow
dest_xdraw = getattribute self, attr_XWindow
.local pmc func
func = get_xlib_function('XCopyArea', 'ippppiiiiii')
$I0 = func(xdisp, src_xdraw, dest_xdraw, gc, src_x, src_y, width, height, dest_x, dest_y)
.end
#-----------------------------------------------------------------------
.sub CreatePixmap :method
.param int width
.param int height
.param int depth :optional
.param int has_depth :opt_flag
# Create a pixmap for the screen that contains this drawable
.local pmc disp
disp = getattribute self, attr_display
.local pmc xdisp
xdisp = self.'getdisplay'()
.local pmc xwin
xwin = getattribute self, attr_XWindow
if has_depth goto doit
depth = disp.'DefaultDepth'()
doit:
.local pmc func
func = get_xlib_function('XCreatePixmap', 'pppiii')
.local pmc xpixmap
xpixmap = func(xdisp, xwin, width, height, depth)
.local pmc arg
arg = new 'Hash'
arg [attr_display] = disp
arg [attr_XDisplay] = xdisp
arg [attr_XWindow] = xpixmap
.local pmc Pixmap
Pixmap = get_Pixmap_class()
.local pmc pixmap
pixmap = new Pixmap, arg
.return(pixmap)
.end
########################################################################
.namespace ['Xlib';'Window']
#-----------------------------------------------------------------------
.sub getdisplay :method
.local pmc disp
disp = getattribute self, attr_display
.local pmc xdisp
xdisp = getattribute disp, attr_XDisplay
.return(xdisp)
.end
#-----------------------------------------------------------------------
.sub Destroy :method
.local pmc xdisp
xdisp = self.'getdisplay'()
.local pmc xwin
xwin = getattribute self, attr_XWindow
.local pmc func
func = get_xlib_function('XDestroyWindow', 'ipp')
$I0 = func(xdisp, xwin)
.return($I0)
.end
#-----------------------------------------------------------------------
.sub SelectInput :method
.param int mask
.local pmc xdisp
xdisp = self.'getdisplay'()
.local pmc xwin
xwin = getattribute self, attr_XWindow
# TESTING
.local pmc protocols
protocols = get_xlib_function('XSetWMProtocols', 'ipppi')
.local pmc disp
disp = getattribute self, attr_display
$I0 = disp.'InternAtom'('WM_DELETE_WINDOW')
$P0 = new 'ResizableIntegerArray'
$P0[0] = .DATATYPE_INT
$P0[1] = 1
$P0[2] = 0
$P1 = new 'ManagedStruct', $P0
$P1[0] = $I0
protocols(xdisp, xwin, $P1, 1)
.local pmc func
func = get_xlib_function('XSelectInput', 'ippi')
$I0 = func(xdisp, xwin, mask)
.return($I0)
.end
#-----------------------------------------------------------------------
.sub Map :method
.local pmc xdisp
xdisp = self.'getdisplay'()
.local pmc xwin
xwin = getattribute self, attr_XWindow
.local pmc func
func = get_xlib_function('XMapWindow', 'ipp')
$I0 = func(xdisp, xwin)
.return($I0)
.end
#-----------------------------------------------------------------------
.sub Unmap :method
.local pmc xdisp
xdisp = self.'getdisplay'()
.local pmc xwin
xwin = getattribute self, attr_XWindow
.local pmc func
func = get_xlib_function('XUnmapWindow', 'ipp')
$I0 = func(xdisp, xwin)
.return($I0)
.end
#-----------------------------------------------------------------------
.sub ClearArea :method
.param int x
.param int y
.param int width
.param int height
.param int exposures
.local pmc xdisp
xdisp = self.'getdisplay'()
.local pmc xwin
xwin = getattribute self, attr_XWindow
.local pmc func
func = get_xlib_function('XClearArea', 'ippiiiii')
$I0 = func(xdisp, xwin, x, y, width, height, exposures)
.return($I0)
.end
#-----------------------------------------------------------------------
.sub StoreName :method
.param string name
.local pmc xdisp
xdisp = self.'getdisplay'()
.local pmc xwin
xwin = getattribute self, attr_XWindow
.local pmc func
func = get_xlib_function('XStoreName', 'ippt')
$I0 = func(xdisp, xwin, name)
.return($I0)
.end
########################################################################
.namespace ['Xlib';'Pixmap']
#-----------------------------------------------------------------------
.sub getdisplay :method
.local pmc disp
disp = getattribute self, attr_display
.local pmc xdisp
xdisp = getattribute disp, attr_XDisplay
.return(xdisp)
.end
#-----------------------------------------------------------------------
.sub destroy :vtable
.local pmc drawable
drawable = getattribute self, attr_XWindow
$I0 = defined drawable
unless $I0 goto done
.local pmc xdisp
xdisp = self.'getdisplay'()
.local pmc func
func = get_xlib_function('XFreePixmap', 'ipp')
$I0 = func(xdisp, drawable)
null drawable
setattribute self, attr_XWindow, drawable
done:
.end
#-----------------------------------------------------------------------
# Local Variables:
# mode: pir
# fill-column: 100
# End:
# vim: expandtab shiftwidth=4 ft=pir:
