## value-to-wire.pkg
#
# Generate binary-bytestring format
# X11 protocol requests suitable for
# writing to the X server socket.
#
# The X11R6 wire protocol is documented here:
# http://mythryl.org/pub/exene/X-protocol.pdf
#
# The converse transformation is done by:
# src/lib/x-kit/xclient/src/wire/wire-to-value.pkg#
# The work of actually sending and recieving
# these bytestrings via socket is handled by
# src/lib/x-kit/xclient/src/wire/xsocket-old.pkg#
# See also:
# src/lib/x-kit/xclient/src/wire/sendevent-to-wire.pkg# Compiled by:
# src/lib/x-kit/xclient/xclient-internals.sublib### "To be on the wire is life.
### The rest is waiting."
###
### -- Karl Wallenda, highwire walker
# TODO
# - encodeAllocColorCells
# - encodeAllocColorPlanes
# - encodeChangeKeyboardMapping
# - encodeSetPointerMapping
# - encodeGetPointerMapping
# - encodeSetModifierMapping XXX BUGGO FIXME
# Used in:
# src/lib/x-kit/xclient/src/wire/display-old.pkg# src/lib/x-kit/xclient/src/wire/xsocket-old.pkg # src/lib/x-kit/xclient/src/wire/sendevent-to-wire.pkg#
# src/lib/x-kit/xclient/src/window/color-spec.pkg# src/lib/x-kit/xclient/src/window/cursors-old.pkg# src/lib/x-kit/xclient/src/window/xsession-old.pkg# src/lib/x-kit/xclient/src/window/draw-imp-old.pkg# src/lib/x-kit/xclient/src/window/font-imp-old.pkg# src/lib/x-kit/xclient/src/window/pen-to-gcontext-imp-old.pkg# src/lib/x-kit/xclient/src/window/cs-pixmap-old.pkg# src/lib/x-kit/xclient/src/window/keymap-imp-old.pkg# src/lib/x-kit/xclient/src/window/rw-pixmap-old.pkg# src/lib/x-kit/xclient/src/window/selection-imp-old.pkg# src/lib/x-kit/xclient/src/window/window-old.pkg#
# src/lib/x-kit/xclient/src/iccc/atom-imp-old.pkg# src/lib/x-kit/xclient/src/iccc/window-property-old.pkg# src/lib/x-kit/xclient/src/iccc/atom-old.pkgstipulate
package g2d = geometry2d; # geometry2d is from src/lib/std/2d/geometry2d.pkg package xt = xtypes; # xtypes is from src/lib/x-kit/xclient/src/wire/xtypes.pkg package ts = xserver_timestamp; # xserver_timestamp is from src/lib/x-kit/xclient/src/wire/xserver-timestamp.pkg package kb = keys_and_buttons; # keys_and_buttons is from src/lib/x-kit/xclient/src/wire/keys-and-buttons.pkg package w8a = rw_vector_of_one_byte_unts; # rw_vector_of_one_byte_unts is from src/lib/std/src/rw-vector-of-one-byte-unts.pkg package w8v = vector_of_one_byte_unts; # vector_of_one_byte_unts is from src/lib/std/src/vector-of-one-byte-unts.pkgherein
package value_to_wire_pith
: Value_To_Wire # Value_To_Wire is from src/lib/x-kit/xclient/src/wire/value-to-wire.api {
# Used (only) in:
#
# src/lib/x-kit/xclient/src/window/pen-old.pkg #
fun graph_op_to_wire xt::OP_CLR => 0u0;
graph_op_to_wire xt::OP_AND => 0u1;
graph_op_to_wire xt::OP_AND_NOT => 0u2;
graph_op_to_wire xt::OP_COPY => 0u3;
graph_op_to_wire xt::OP_AND_INVERTED => 0u4;
graph_op_to_wire xt::OP_NOP => 0u5;
graph_op_to_wire xt::OP_XOR => 0u6;
graph_op_to_wire xt::OP_OR => 0u7;
graph_op_to_wire xt::OP_NOR => 0u8;
graph_op_to_wire xt::OP_EQUIV => 0u9;
graph_op_to_wire xt::OP_NOT => 0u10;
graph_op_to_wire xt::OP_OR_NOT => 0u11;
graph_op_to_wire xt::OP_COPY_NOT => 0u12;
graph_op_to_wire xt::OP_OR_INVERTED => 0u13;
graph_op_to_wire xt::OP_NAND => 0u14;
graph_op_to_wire xt::OP_SET => 0u15;
end;
# Used (only) in:
#
# src/lib/x-kit/xclient/src/wire/value-to-wire.pkg # src/lib/x-kit/xclient/src/iccc/iccc-property-old.pkg #
fun gravity_to_wire xt::FORGET_GRAVITY => 0u0; # Bit gravity only
gravity_to_wire xt::UNMAP_GRAVITY => 0u0; # window gravity only
gravity_to_wire xt::NORTHWEST_GRAVITY => 0u1;
gravity_to_wire xt::NORTH_GRAVITY => 0u2;
gravity_to_wire xt::NORTHEAST_GRAVITY => 0u3;
gravity_to_wire xt::WEST_GRAVITY => 0u4;
gravity_to_wire xt::CENTER_GRAVITY => 0u5;
gravity_to_wire xt::EAST_GRAVITY => 0u6;
gravity_to_wire xt::SOUTHWEST_GRAVITY => 0u7;
gravity_to_wire xt::SOUTH_GRAVITY => 0u8;
gravity_to_wire xt::SOUTHEAST_GRAVITY => 0u9;
gravity_to_wire xt::STATIC_GRAVITY => 0u10;
end;
# Used (only) in:
#
# src/lib/x-kit/xclient/src/wire/value-to-wire.pkg #
fun bool_to_wire FALSE => 0u0;
bool_to_wire TRUE => 0u1;
end;
# Used (only) in:
#
# src/lib/x-kit/xclient/src/window/window-old.pkg #
fun stack_mode_to_wire xt::ABOVE => 0u0;
stack_mode_to_wire xt::BELOW => 0u1;
stack_mode_to_wire xt::TOP_IF => 0u2;
stack_mode_to_wire xt::BOTTOM_IF => 0u3;
stack_mode_to_wire xt::OPPOSITE => 0u4;
end;
# Process a configuration value list,
# producing a value_list.
#
fun do_val_list n f lst
=
{ v = rw_vector::make_rw_vector (n, NULL);
list::apply (f v) lst;
xt::VALUE_LIST v;
};
# This encodes the attribute "lists" (vectors) needed by:
#
# encode_create_window
# encode_change_window_attributes
#
my make_window_attribute_list: List( xt::a::Window_Attribute ) -> xt::Value_List
=
do_val_list 15 set_window_attribute
where
fun set_window_attribute rw_vec
=
{ fun update (i, x)
=
rw_vector::set (rw_vec, i, THE x);
\\ xt::a::BACKGROUND_PIXMAP_NONE => update (0, 0u0);
xt::a::BACKGROUND_PIXMAP_PARENT_RELATIVE => update (0, 0u1);
xt::a::BACKGROUND_PIXMAP xid => update (0, xt::xid_to_unt xid);
xt::a::BACKGROUND_PIXEL rgb8 => update (1, unt::from_int (rgb8::rgb8_to_int rgb8));
xt::a::BORDER_PIXMAP_COPY_FROM_PARENT => update (2, 0u0);
xt::a::BORDER_PIXMAP xid => update (2, xt::xid_to_unt xid);
xt::a::BORDER_PIXEL rgb8 => update (3, unt::from_int (rgb8::rgb8_to_int rgb8));
xt::a::BIT_GRAVITY g => update (4, gravity_to_wire g);
xt::a::WINDOW_GRAVITY g => update (5, gravity_to_wire g);
xt::a::BACKING_STORE xt::BS_NOT_USEFUL => update (6, 0u0);
xt::a::BACKING_STORE xt::BS_WHEN_MAPPED => update (6, 0u1);
xt::a::BACKING_STORE xt::BS_ALWAYS => update (6, 0u2);
xt::a::BACKING_PLANES (xt::PLANEMASK m) => update (7, m);
xt::a::BACKING_PIXEL rgb8 => update (8, unt::from_int (rgb8::rgb8_to_int rgb8));
xt::a::OVERRIDE_REDIRECT b => update ( 9, bool_to_wire b);
xt::a::SAVE_UNDER b => update (10, bool_to_wire b);
xt::a::EVENT_MASK (xt::EVENT_MASK m) => update (11, m);
xt::a::DO_NOT_PROPAGATE_MASK (xt::EVENT_MASK m) => update (12, m);
xt::a::COLOR_MAP_COPY_FROM_PARENT => update (13, 0u0);
xt::a::COLOR_MAP xid => update (13, xt::xid_to_unt xid);
xt::a::CURSOR_NONE => update (14, 0u0);
xt::a::CURSOR xid => update (14, xt::xid_to_unt xid);
end;
};
end;
stipulate
# We need to treat requests as arrays for initialization purposes,
# but we don't want them to be modifiable afterwords.
#
my ro2rw: vector_of_one_byte_unts::Vector -> rw_vector_of_one_byte_unts::Rw_Vector
=
unsafe::cast;
fun pad n
=
unt::bitwise_and (unt::from_int n, 0u3) != 0u0
?? pad (n+1)
:: n;
fun make_request_buf size
=
unsafe::vector_of_one_byte_unts::make size;
fun put8 (buf, i, w)
=
w8a::set (ro2rw buf, i, w);
fun put_word8 (buf, i, x)
=
put8 (buf, i, one_byte_unt::from_large_unt (unt::to_large_unt x));
fun put_signed8 (buf, i, x) = put8 (buf, i, one_byte_unt::from_int x);
fun put16 (buf, i, x) = pack_big_endian_unt16::set (ro2rw buf, i / 2, x);
fun put_word16 (buf, i, x) = put16 (buf, i, unt::to_large_unt x);
fun put_signed16 (buf, i, x) = put16 (buf, i, large_unt::from_int x);
fun put32 (buf, i, x) = pack_big_endian_unt1::set (ro2rw buf, i / 4, x);
fun put_word32 (buf, i, x) = put32 (buf, i, unt::to_large_unt x);
fun put_signed32 (buf, i, x) = put32 (buf, i, large_unt::from_int x);
fun put_string (buf, i, s)
=
byte::pack_string (ro2rw buf, i, substring::from_string s);
fun put_data (buf, i, bv)
=
w8a::copy_vector
{
from => bv,
into => ro2rw buf,
at => i
};
fun put_bool (buf, i, FALSE) => put8 (buf, i, 0u0);
put_bool (buf, i, TRUE ) => put8 (buf, i, 0u1);
end;
fun put_xid (buf, i, xid)
=
put_word32 (buf, i, xt::xid_to_unt xid);
fun put_xid_option (buf, i, NULL) => put_word32 (buf, i, 0u0);
put_xid_option (buf, i, THE xid) => put_word32 (buf, i, xt::xid_to_unt xid);
end;
fun put_atom (buf, i, xt::XATOM n)
=
put_word32 (buf, i, n);
fun put_atom_option (buf, i, THE (xt::XATOM n)) => put_word32 (buf, i, n );
put_atom_option (buf, i, NULL ) => put_word32 (buf, i, 0u0);
end;
fun put_rgb8 (buf, i, rgb8 ) = put_signed32 (buf, i, (rgb8::rgb8_to_int rgb8));
fun put_plane_mask (buf, i, xt::PLANEMASK n) = put_word32 (buf, i, n);
fun put_event_mask (buf, i, xt::EVENT_MASK m) = put_word32 (buf, i, m);
fun put_ptr_event_mask (buf, i, xt::EVENT_MASK m) = put_word16 (buf, i, m);
fun put_point (buf, i, { col, row } )
=
{ put_signed16 (buf, i, col);
put_signed16 (buf, i+2, row);
};
fun put_size (buf, i, { wide, high } )
=
{ put_signed16 (buf, i, wide);
put_signed16 (buf, i+2, high);
};
fun put_box (buf, i, { col, row, wide, high } )
=
{ put_signed16 (buf, i, col );
put_signed16 (buf, i+2, row );
put_signed16 (buf, i+4, wide);
put_signed16 (buf, i+6, high);
};
fun put_arc (buf, i, { col, row, wide, high, angle1, angle2 } )
=
{ put_signed16 (buf, i, col );
put_signed16 (buf, i+2, row );
put_signed16 (buf, i+4, wide );
put_signed16 (buf, i+6, high );
put_signed16 (buf, i+8, angle1);
put_signed16 (buf, i+10, angle2);
};
fun put_wgeom (buf, i, { upperleft, size, border_thickness }: g2d::Window_Site)
=
{ put_point (buf, i, upperleft );
put_size (buf, i+4, size );
put_signed16 (buf, i+8, border_thickness);
};
fun put_timestamp (buf, i, xt::CURRENT_TIME) => put32 (buf, i, 0u0);
put_timestamp (buf, i, xt::TIMESTAMP (ts::XSERVER_TIMESTAMP t)) => put32 (buf, i, t);
end;
fun put_rgb (buf, i, rgb)
=
{ (rgb::rgb_to_unts rgb)
->
(red, green, blue);
put_word16 (buf, i, red );
put_word16 (buf, i+2, green);
put_word16 (buf, i+4, blue );
};
fun put_grab_mode (buf, i, xt::SYNCHRONOUS_GRAB ) => put8 (buf, i, 0u0);
put_grab_mode (buf, i, xt::ASYNCHRONOUS_GRAB) => put8 (buf, i, 0u1);
end;
fun put_list (f, size: Int) (buf, base, list)
=
put (base, list)
where
fun put (_, []) => ();
put (i, x ! r) => { f (buf, i, x); put (i+size, r);};
end;
end;
put_points = put_list (put_point, 4);
put_boxes = put_list (put_box, 8);
put_rgb8s = put_list (put_rgb8, 4);
# Build a value list and mask from a value option rw_vector
#
fun make_value_list (xt::VALUE_LIST rw_vec)
=
f ((rw_vector::length rw_vec) - 1, 0, 0u0, [])
where
fun f (-1, n, m, l)
=>
(n, xt::VALUE_MASK m, l);
f (i, n, m, l)
=>
case (rw_vector::get (rw_vec, i))
#
THE x => f (i - 1, n+1, unt::bitwise_or (m, unt::(<<) (0u1, unt::from_int i)), x ! l);
NULL => f (i - 1, n, m, l);
esac;
end;
end;
# Put value masks and lists
#
stipulate
put_vals
=
put_list (put_word32, 4);
herein
fun put_val_list (buf, i, xt::VALUE_MASK m, vals)
=
{ put_word32 (buf, i, m );
put_vals (buf, i+4, vals);
};
fun put_val_list16 (buf, i, xt::VALUE_MASK m, vals)
=
{ put_word16 (buf, i, m );
put_vals (buf, i+4, vals);
};
end;
########################################################################
# X11 protocol request codes and sizes (from "Xproto::h")
Reqinfo = { code: one_byte_unt::Unt,
size: Int
};
req_create_window = { code => 0u1, size => 8 }: Reqinfo;
req_change_window_attributes = { code => 0u2, size => 3 }: Reqinfo;
req_get_window_attributes = { code => 0u3, size => 2 }: Reqinfo;
req_destroy_window = { code => 0u4, size => 2 }: Reqinfo; # "You can scarcely imagine the beauty and magnificence of the places we burnt.
req_destroy_subwindows = { code => 0u5, size => 2 }: Reqinfo; # -- Major General Charles Gordon
req_change_save_set = { code => 0u6, size => 2 }: Reqinfo;
req_reparent_window = { code => 0u7, size => 4 }: Reqinfo;
req_map_window = { code => 0u8, size => 2 }: Reqinfo;
req_map_subwindows = { code => 0u9, size => 2 }: Reqinfo;
req_unmap_window = { code => 0u10, size => 2 }: Reqinfo;
req_unmap_subwindows = { code => 0u11, size => 2 }: Reqinfo;
req_configure_window = { code => 0u12, size => 3 }: Reqinfo;
req_circulate_window = { code => 0u13, size => 2 }: Reqinfo;
req_get_geometry = { code => 0u14, size => 2 }: Reqinfo;
req_query_tree = { code => 0u15, size => 2 }: Reqinfo;
req_intern_atom = { code => 0u16, size => 2 }: Reqinfo;
req_get_atom_name = { code => 0u17, size => 2 }: Reqinfo;
req_change_property = { code => 0u18, size => 6 }: Reqinfo;
req_delete_property = { code => 0u19, size => 3 }: Reqinfo;
req_get_property = { code => 0u20, size => 6 }: Reqinfo;
req_list_properties = { code => 0u21, size => 2 }: Reqinfo;
req_set_selection_owner = { code => 0u22, size => 4 }: Reqinfo;
req_get_selection_owner = { code => 0u23, size => 2 }: Reqinfo;
req_convert_selection = { code => 0u24, size => 6 }: Reqinfo;
req_push_event = { code => 0u25, size => 11}: Reqinfo;
req_grab_pointer = { code => 0u26, size => 6 }: Reqinfo;
req_ungrab_pointer = { code => 0u27, size => 2 }: Reqinfo;
req_grab_button = { code => 0u28, size => 6 }: Reqinfo;
req_ungrab_button = { code => 0u29, size => 3 }: Reqinfo;
req_change_active_pointer_grab = { code => 0u30, size => 4 }: Reqinfo;
req_grab_keyboard = { code => 0u31, size => 4 }: Reqinfo;
req_ungrab_keyboard = { code => 0u32, size => 2 }: Reqinfo;
req_grab_key = { code => 0u33, size => 4 }: Reqinfo;
req_ungrab_key = { code => 0u34, size => 3 }: Reqinfo;
req_allow_events = { code => 0u35, size => 2 }: Reqinfo;
req_grab_server = { code => 0u36, size => 1 }: Reqinfo;
req_ungrab_server = { code => 0u37, size => 1 }: Reqinfo;
req_query_pointer = { code => 0u38, size => 2 }: Reqinfo;
req_get_motion_events = { code => 0u39, size => 4 }: Reqinfo;
req_translate_coordinates = { code => 0u40, size => 4 }: Reqinfo;
req_warp_pointer = { code => 0u41, size => 6 }: Reqinfo;
req_set_input_focus = { code => 0u42, size => 3 }: Reqinfo;
req_get_input_focus = { code => 0u43, size => 1 }: Reqinfo;
req_query_keymap = { code => 0u44, size => 1 }: Reqinfo;
req_open_font = { code => 0u45, size => 3 }: Reqinfo;
req_close_font = { code => 0u46, size => 2 }: Reqinfo;
req_query_font = { code => 0u47, size => 2 }: Reqinfo;
req_query_text_extents = { code => 0u48, size => 2 }: Reqinfo;
req_list_fonts = { code => 0u49, size => 2 }: Reqinfo;
req_list_fonts_with_info = { code => 0u50, size => 2 }: Reqinfo;
req_set_font_path = { code => 0u51, size => 2 }: Reqinfo;
req_get_font_path = { code => 0u52, size => 1 }: Reqinfo;
req_create_pixmap = { code => 0u53, size => 4 }: Reqinfo;
req_free_pixmap = { code => 0u54, size => 2 }: Reqinfo;
req_create_gc = { code => 0u55, size => 4 }: Reqinfo;
req_change_gc = { code => 0u56, size => 3 }: Reqinfo;
req_copy_gc = { code => 0u57, size => 4 }: Reqinfo;
req_set_dashes = { code => 0u58, size => 3 }: Reqinfo;
req_set_clip_boxes = { code => 0u59, size => 3 }: Reqinfo;
req_free_gc = { code => 0u60, size => 2 }: Reqinfo;
req_clear_area = { code => 0u61, size => 4 }: Reqinfo;
req_copy_area = { code => 0u62, size => 7 }: Reqinfo;
req_copy_plane = { code => 0u63, size => 8 }: Reqinfo;
req_poly_point = { code => 0u64, size => 3 }: Reqinfo;
req_poly_line = { code => 0u65, size => 3 }: Reqinfo;
req_poly_segment = { code => 0u66, size => 3 }: Reqinfo;
req_poly_rectangle = { code => 0u67, size => 3 }: Reqinfo;
req_poly_arc = { code => 0u68, size => 3 }: Reqinfo;
req_fill_poly = { code => 0u69, size => 4 }: Reqinfo;
req_poly_fill_box = { code => 0u70, size => 3 }: Reqinfo;
req_poly_fill_arc = { code => 0u71, size => 3 }: Reqinfo;
req_put_image = { code => 0u72, size => 6 }: Reqinfo;
req_get_image = { code => 0u73, size => 5 }: Reqinfo;
req_poly_text8 = { code => 0u74, size => 4 }: Reqinfo;
req_poly_text16 = { code => 0u75, size => 4 }: Reqinfo;
req_image_text8 = { code => 0u76, size => 4 }: Reqinfo;
req_image_text16 = { code => 0u77, size => 4 }: Reqinfo;
req_create_colormap = { code => 0u78, size => 4 }: Reqinfo;
req_free_colormap = { code => 0u79, size => 2 }: Reqinfo;
req_copy_colormap_and_free = { code => 0u80, size => 3 }: Reqinfo;
req_install_colormap = { code => 0u81, size => 2 }: Reqinfo;
req_uninstall_colormap = { code => 0u82, size => 2 }: Reqinfo;
req_list_installed_colormaps = { code => 0u83, size => 2 }: Reqinfo;
req_alloc_color = { code => 0u84, size => 4 }: Reqinfo;
req_alloc_named_color = { code => 0u85, size => 3 }: Reqinfo;
req_alloc_color_cells = { code => 0u86, size => 3 }: Reqinfo;
req_alloc_color_planes = { code => 0u87, size => 4 }: Reqinfo;
req_free_colors = { code => 0u88, size => 3 }: Reqinfo;
req_store_colors = { code => 0u89, size => 2 }: Reqinfo;
req_store_named_color = { code => 0u90, size => 4 }: Reqinfo;
req_query_colors = { code => 0u91, size => 2 }: Reqinfo;
req_lookup_color = { code => 0u92, size => 3 }: Reqinfo;
req_create_cursor = { code => 0u93, size => 8 }: Reqinfo;
req_create_glyph_cursor = { code => 0u94, size => 8 }: Reqinfo;
req_free_cursor = { code => 0u95, size => 2 }: Reqinfo;
req_recolor_cursor = { code => 0u96, size => 5 }: Reqinfo;
req_query_best_size = { code => 0u97, size => 3 }: Reqinfo;
req_query_extension = { code => 0u98, size => 2 }: Reqinfo;
req_list_extensions = { code => 0u99, size => 1 }: Reqinfo;
req_change_keyboard_mapping = { code => 0u100, size => 2 }: Reqinfo;
req_get_keyboard_mapping = { code => 0u101, size => 2 }: Reqinfo;
req_change_keyboard_control = { code => 0u102, size => 2 }: Reqinfo;
req_get_keyboard_control = { code => 0u103, size => 1 }: Reqinfo;
req_bell = { code => 0u104, size => 1 }: Reqinfo;
req_change_pointer_control = { code => 0u105, size => 3 }: Reqinfo;
req_get_pointer_control = { code => 0u106, size => 1 }: Reqinfo;
req_set_screen_saver = { code => 0u107, size => 3 }: Reqinfo;
req_get_screen_saver = { code => 0u108, size => 1 }: Reqinfo;
req_change_hosts = { code => 0u109, size => 2 }: Reqinfo;
req_list_hosts = { code => 0u110, size => 1 }: Reqinfo;
req_set_access_control = { code => 0u111, size => 1 }: Reqinfo;
req_set_close_down_mode = { code => 0u112, size => 1 }: Reqinfo;
req_kill_client = { code => 0u113, size => 2 }: Reqinfo;
req_rotate_properties = { code => 0u114, size => 3 }: Reqinfo;
req_force_screen_saver = { code => 0u115, size => 1 }: Reqinfo;
req_set_pointer_mapping = { code => 0u116, size => 1 }: Reqinfo;
req_get_pointer_mapping = { code => 0u117, size => 1 }: Reqinfo;
req_set_modifier_mapping = { code => 0u118, size => 1 }: Reqinfo;
req_get_modifier_mapping = { code => 0u119, size => 1 }: Reqinfo;
req_no_operation = { code => 0u127, size => 1 }: Reqinfo;
# Allocate a buffer for a fixed-sized message and initialize the
# code and size fields. Return the buffer.
#
fun make_request ( { code, size } : Reqinfo)
=
{ buf = make_request_buf (4*size);
#
put8 (buf, 0, code); # Request opcode.
put_signed16 (buf, 2, size); # Request size (in words).
buf;
};
# Allocate a buffer for a fixed-sized message that contains an xid
# in its first field, and initialize the code and size fields. Return
# the buffer.
#
fun make_resource_request (info, xid)
=
{ buf = make_request info;
#
put_xid (buf, 4, xid); # Resource id.
buf;
};
# Allocate and initialize a buffer for a variable-sized request.
# Return the new buffer.
#
fun make_extra_request ( { code, size }, extra)
=
{ size = size+extra;
#
buf = make_request_buf (4*size);
put8 (buf, 0, code); # Request opcode.
put_signed16 (buf, 2, size); # Request size (in words).
buf;
};
# Allocate and initialize a buffer for a variable-sized request.
# Only allot space for the header. Return the new buffer.
#
fun make_var_request ( { code, size }, extra) # THIS FUNCTION APPEARS TO BE ENTIRELY UNUSED.
=
{ size = size+extra;
#
buf = make_request_buf (4*size);
put8 (buf, 0, code); # Request opcode.
put_signed16 (buf, 2, size+extra); # Request size (in words).
buf;
};
herein
# Encode the connection request message.
#
# This consists of the byte-order,
# protocol version, and optional authentication data.
#
fun encode_xserver_connection_request { minor_version, xauthentication }
=
{
fun set_prefix size
=
{ buf = w8v::from_fn (size, \\ _ = 0u0);
put8 (buf, 0, byte::char_to_byte 'B'); # Byte order: MSB
put8 (buf, 3, 0u11); # major version: 11
put8 (buf, 5, one_byte_unt::from_int minor_version);
buf;
};
case xauthentication
#
NULL => set_prefix 12;
#
THE (xt::XAUTHENTICATION { name, data, ... } )
=>
{ auth_name_len = pad (size name);
auth_data_len = pad (vector_of_one_byte_unts::length data);
prefix = set_prefix (12 + auth_name_len + auth_data_len);
put_signed16 (prefix, 6, size name);
put_signed16 (prefix, 8, vector_of_one_byte_unts::length data);
put_string (prefix, 12, name);
put_data (prefix, 12 + auth_name_len, data);
prefix;
};
esac;
};
fun encode_create_window
{ window_id: xt::Xid,
parent_window_id: xt::Xid,
#
visual_id: xt::Visual_Id_Choice,
io_class: xt::Io_Class,
depth: Int,
site: g2d::Window_Site,
attributes: List( xt::a::Window_Attribute )
}
=
{ (make_value_list (make_window_attribute_list attributes))
->
(attribute_count, mask, attributes);
io = case io_class
#
xt::SAME_IO_AS_PARENT => 0u0;
xt::INPUT_OUTPUT => 0u1;
xt::INPUT_ONLY => 0u2;
esac;
visual_id
=
case visual_id
#
xt::SAME_VISUAL_AS_PARENT => 0u0; /* X calls this CopyFromParent */
xt::OVERRIDE_PARENT_VISUAL (xt::VISUAL_ID id) => id;
esac;
msg = make_extra_request (req_create_window, attribute_count);
put_signed8 (msg, 1, depth );
put_xid (msg, 4, window_id );
put_xid (msg, 8, parent_window_id);
put_wgeom (msg, 12, site );
put16 (msg, 22, io );
put_word32 (msg, 24, visual_id );
put_val_list (msg, 28, mask, attributes);
msg;
};
fun encode_change_window_attributes
{
window_id: xt::Xid,
attributes: List( xt::a::Window_Attribute )
}
=
{ (make_value_list (make_window_attribute_list attributes))
->
(attribute_count, mask, attributes);
msg = make_extra_request (req_change_window_attributes, attribute_count);
put_xid (msg, 4, window_id );
put_val_list (msg, 8, mask, attributes);
msg;
};
fun encode_get_window_attributes { window_id }
=
make_resource_request (req_get_window_attributes, window_id);
fun encode_destroy_window { window_id } = make_resource_request (req_destroy_window, window_id);
fun encode_destroy_subwindows { window_id } = make_resource_request (req_destroy_subwindows, window_id);
fun encode_change_save_set { window_id, insert }
=
{ msg = make_request (req_change_save_set);
#
put_bool (msg, 1, insert );
put_xid (msg, 4, window_id);
msg;
};
fun encode_reparent_window { window_id, parent_id, pos }
=
{ msg = make_resource_request (req_reparent_window, window_id);
#
put_xid (msg, 8, parent_id);
put_point (msg, 12, pos );
msg;
};
fun encode_map_window { window_id } = make_resource_request (req_map_window, window_id);
fun encode_map_subwindows { window_id } = make_resource_request (req_map_subwindows, window_id);
fun encode_unmap_window { window_id } = make_resource_request (req_unmap_window, window_id);
fun encode_unmap_subwindows { window_id } = make_resource_request (req_unmap_subwindows, window_id);
fun encode_configure_window { window_id, vals }
=
{ (make_value_list vals)
->
(nvals, mask, vals);
msg = make_extra_request (req_configure_window, nvals);
put_xid (msg, 4, window_id );
put_val_list16 (msg, 8, mask, vals);
msg;
};
fun encode_circulate_window { window_id, parent_id, place }
=
{ place = case place
#
xt::PLACE_ON_TOP => 0u0;
xt::PLACE_ON_BOTTOM => 0u1;
esac;
msg = make_request req_circulate_window;
put_xid (msg, 4, parent_id);
put_xid (msg, 8, window_id);
put8 (msg, 12, place );
msg;
};
fun encode_get_geometry { drawable }
=
make_resource_request (req_get_geometry, drawable);
fun encode_query_tree { window_id }
=
make_resource_request (req_query_tree, window_id);
fun encode_intern_atom { name, only_if_exists }
=
{ n = string::length_in_bytes name;
msg = make_extra_request (req_intern_atom, (pad n) / 4);
put_bool (msg, 1, only_if_exists);
put_signed16 (msg, 4, n );
put_string (msg, 8, name );
msg;
};
fun encode_get_atom_name { atom => (xt::XATOM id) }
=
make_resource_request (req_get_atom_name, xt::xid_from_unt id);
fun encode_change_property { window_id, name, property, mode }
=
{ property -> xt::PROPERTY_VALUE { type, value => xt::RAW_DATA { format, data } };
#
nbytes = vector_of_one_byte_unts::length data;
my (nitems, fmt)
=
case format
#
xt::RAW08 => (nbytes, 0u8);
xt::RAW16 => (nbytes / 2, 0u16);
xt::RAW32 => (nbytes / 4, 0u32);
esac;
mode = case mode
#
xt::REPLACE_PROPERTY => 0u0;
xt::PREPEND_PROPERTY => 0u1;
xt::APPEND_PROPERTY => 0u2;
esac;
msg = make_extra_request (req_change_property, (pad nbytes) / 4);
put8 (msg, 1, mode );
put_xid (msg, 4, window_id);
put_atom (msg, 8, name );
put_atom (msg, 12, type );
put8 (msg, 16, fmt );
put_signed32 (msg, 20, nitems );
put_data (msg, 24, data );
msg;
};
fun encode_delete_property { window_id, property }
=
{ msg = make_request req_delete_property;
#
put_xid (msg, 4, window_id);
put_atom (msg, 8, property );
msg;
};
fun encode_get_property { window_id, property, type, offset, len, delete }
=
{ msg = make_request req_get_property;
#
put_bool (msg, 1, delete );
put_xid (msg, 4, window_id);
put_atom (msg, 8, property );
put_atom_option (msg, 12, type );
put_signed32 (msg, 16, offset );
put_signed32 (msg, 20, len );
msg;
};
fun encode_list_properties { window_id }
=
make_resource_request (req_list_properties, window_id);
fun encode_set_selection_owner { window_id, selection, timestamp }
=
{ msg = make_request req_set_selection_owner;
#
put_xid_option (msg, 4, window_id);
put_atom (msg, 8, selection);
put_timestamp (msg, 12, timestamp);
msg;
};
fun encode_get_selection_owner { selection => (xt::XATOM x) }
=
make_resource_request (req_get_selection_owner, xt::xid_from_unt x);
fun encode_convert_selection
{ selection, target, property, requestor, timestamp }
=
{ msg = make_request req_convert_selection;
#
put_xid (msg, 4, requestor);
put_atom (msg, 8, selection);
put_atom (msg, 12, target );
put_atom_option (msg, 16, property );
put_timestamp (msg, 20, timestamp);
msg;
};
# This just encodes the header info;
# encoding of the event proper is done in:
#
# src/lib/x-kit/xclient/src/wire/sendevent-to-wire.pkg #
fun encode_push_event { send_event_to, propagate, event_mask }
=
{ msg = make_request req_push_event;
#
put_bool (msg, 1, propagate);
case send_event_to
#
xt::SEND_EVENT_TO_POINTER_WINDOW => put32 (msg, 4, 0u0);
xt::SEND_EVENT_TO_INPUT_FOCUS => put32 (msg, 4, 0u1);
xt::SEND_EVENT_TO_WINDOW wide => put_xid (msg, 4, wide);
esac;
put_event_mask (msg, 8, event_mask);
msg;
};
fun encode_grab_pointer
{ window_id, owner_events, event_mask, ptr_mode, kbd_mode, confine_to, cursor, time }
=
{ msg = make_request req_grab_pointer;
#
put_bool (msg, 1, owner_events);
put_xid (msg, 4, window_id );
put_ptr_event_mask (msg, 8, event_mask );
put_grab_mode (msg, 10, ptr_mode );
put_grab_mode (msg, 11, kbd_mode );
put_xid_option (msg, 12, confine_to );
put_xid_option (msg, 16, cursor );
put_timestamp (msg, 20, time );
msg;
};
fun encode_grab_keyboard
{ window_id, owner_events, ptr_mode, kbd_mode, time }
=
{ msg = make_request req_grab_keyboard;
#
put_bool (msg, 1, owner_events);
put_xid (msg, 4, window_id );
put_timestamp (msg, 8, time );
put_grab_mode (msg, 12, ptr_mode );
put_grab_mode (msg, 13, kbd_mode );
msg;
};
stipulate
fun ungrab info { time }
=
{ msg = make_request (info);
#
put_timestamp (msg, 4, time);
msg;
};
herein
encode_ungrab_pointer = ungrab req_ungrab_pointer;
encode_ungrab_keyboard = ungrab req_ungrab_keyboard;
end;
fun encode_change_active_pointer_grab { event_mask, cursor, time }
=
{ msg = make_request req_change_active_pointer_grab;
#
put_xid_option (msg, 4, cursor);
put_timestamp (msg, 8, time);
put_ptr_event_mask (msg, 12, event_mask);
msg;
};
stipulate
fun put_modifiers (buf, i, mset)
=
{ m = case (kb::make_modifier_keys_state mset)
#
xt::ANY_MOD_KEY => 0ux8000;
xt::MKSTATE m => m;
esac;
put_word16 (buf, i, m);
};
fun put_button (buf, i, THE (xt::MOUSEBUTTON b)) => put_signed8 (buf, i, b);
put_button (buf, i, NULL) => put8 (buf, i, 0u0);
end;
fun put_key_code (buf, i, xt::KEYCODE k)
=
put_signed8 (buf, i, k);
herein
fun encode_grab_button
{ button, modifiers, window_id, owner_events, event_mask, ptr_mode, kbd_mode,
confine_to, cursor
}
=
{ msg = make_request req_grab_button;
#
put_bool (msg, 1, owner_events);
put_xid (msg, 4, window_id );
put_ptr_event_mask (msg, 8, event_mask );
put_grab_mode (msg, 10, ptr_mode );
put_grab_mode (msg, 11, kbd_mode );
put_xid_option (msg, 12, confine_to );
put_xid_option (msg, 16, cursor );
put_button (msg, 18, button );
put_modifiers (msg, 20, modifiers );
msg;
};
fun encode_grab_key { key, modifiers, window_id, owner_events, ptr_mode, kbd_mode }
=
{ msg = make_request req_grab_key;
#
put_bool (msg, 1, owner_events);
put_xid (msg, 4, window_id );
put_modifiers (msg, 8, modifiers );
put_key_code (msg, 10, key );
put_grab_mode (msg, 11, ptr_mode );
put_grab_mode (msg, 12, kbd_mode );
msg;
};
fun encode_ungrab_button { button, modifiers, window_id }
=
{ msg = make_request req_ungrab_button;
#
put_button (msg, 1, button );
put_xid (msg, 4, window_id);
put_modifiers (msg, 8, modifiers);
msg;
};
fun encode_ungrab_key { key, modifiers, window_id }
=
{ msg = make_request req_ungrab_key;
#
put_key_code (msg, 1, key );
put_xid (msg, 4, window_id);
put_modifiers (msg, 8, modifiers);
msg;
};
end; # stipulate
fun encode_allow_events { mode, time }
=
{ msg = make_request req_allow_events;
#
mode = case mode
#
xt::ASYNC_POINTER => 0u0;
xt::SYNC_POINTER => 0u1;
xt::REPLAY_POINTER => 0u2;
xt::ASYNC_KEYBOARD => 0u3;
xt::SYNC_KEYBOARD => 0u4;
xt::REPLAY_KEYBOARD => 0u5;
xt::ASYNC_BOTH => 0u6;
xt::SYNC_BOTH => 0u7;
esac;
put8 (msg, 1, mode);
put_timestamp (msg, 4, time);
msg;
};
fun encode_query_pointer { window_id }
=
make_resource_request (req_query_pointer, window_id);
fun encode_get_motion_events { window_id, start, stop }
=
{ msg = make_request req_get_motion_events;
#
put_xid (msg, 4, window_id);
put_timestamp (msg, 8, start );
put_timestamp (msg, 12, stop );
msg;
};
fun encode_translate_coordinates { from_window, to_window, from_point }
=
{ msg = make_resource_request (req_translate_coordinates, from_window);
#
put_xid (msg, 8, to_window );
put_point (msg, 12, from_point);
msg;
};
# See p 35: http://mythryl.org/pub/exene/X-protocol-R7.pdf
# p130: http://mythryl.org/pub/exene/X-protocol-R7.pdf
#
fun encode_warp_pointer { from, to, from_box, to_point }
=
{ msg = make_request req_warp_pointer;
#
put_xid_option (msg, 4, from );
put_xid_option (msg, 8, to );
put_box (msg, 12, from_box);
put_point (msg, 20, to_point);
msg;
};
fun encode_set_input_focus { focus, revert_to, timestamp }
=
{ msg = make_request req_set_input_focus;
#
revert_to
=
case revert_to
#
xt::REVERT_TO_NONE => 0u0;
xt::REVERT_TO_POINTER_ROOT => 0u1;
xt::REVERT_TO_PARENT => 0u2;
esac;
focus
=
case focus
#
xt::INPUT_FOCUS_NONE => (xt::xid_from_unt 0u0);
xt::INPUT_FOCUS_POINTER_ROOT => (xt::xid_from_unt 0u1);
xt::INPUT_FOCUS_WINDOW w => w;
esac;
put8 (msg, 1, revert_to);
put_xid (msg, 4, focus );
put_timestamp (msg, 8, timestamp);
msg;
};
fun encode_open_font { font, name }
=
{ n = string::length_in_bytes name;
#
msg = make_extra_request (req_open_font, (pad n) / 4);
put_xid (msg, 4, font);
put_signed16 (msg, 8, n );
put_string (msg, 12, name);
msg;
};
fun encode_close_font { font } = make_resource_request (req_close_font, font);
fun encode_query_font { font } = make_resource_request (req_query_font, font);
fun encode_query_text_extents { font, string }
=
{ len = string::length_in_bytes string;
p = pad len;
msg = make_extra_request (req_query_text_extents, p / 4);
put_bool (msg, 1, ((len - p) == 2));
put_xid (msg, 4, font);
put_string (msg, 8, string);
msg;
};
stipulate
fun encode info { pattern, max }
=
{ len = string::length_in_bytes pattern;
#
msg = make_extra_request (info, (pad len) / 4);
put_signed16 (msg, 4, max);
put_signed16 (msg, 6, len);
put_string (msg, 8, pattern);
msg;
};
herein
encode_list_fonts = encode req_list_fonts;
encode_list_fonts_with_info = encode req_list_fonts_with_info;
end;
fun encode_set_font_path { path }
=
{ fun f ([], n, l)
=>
(n, string::cat (list::reverse l));
f (s ! r, n, l)
=>
{ len = string::length_in_bytes s;
# Should check that len <= 255 XXX BUGGO FIXME
f (r, n+1, s ! string::from_char (char::from_int len) ! l);
};
end;
(f (path, 0, [])) -> (nstrs, data);
len = string::length_in_bytes data;
msg = make_extra_request (req_set_font_path, (pad len) / 4);
put_signed16 (msg, 4, nstrs);
put_string (msg, 8, data);
msg;
};
fun encode_create_pixmap { pixmap_id, drawable_id, depth, size }
=
{ msg = make_resource_request (req_create_pixmap, pixmap_id);
#
put_signed8 (msg, 1, depth );
put_xid (msg, 8, drawable_id );
put_size (msg, 12, size );
msg;
};
fun encode_free_pixmap { pixmap }
=
make_resource_request (req_free_pixmap, pixmap);
fun encode_create_gc { gc_id, drawable, vals }
=
{ (make_value_list vals)
->
(nvals, mask, vals);
msg = make_extra_request (req_create_gc, nvals);
put_xid (msg, 4, gc_id );
put_xid (msg, 8, drawable );
put_val_list (msg, 12, mask, vals);
msg;
};
fun encode_change_gc { gc_id, vals }
=
{ (make_value_list vals)
->
(nvals, mask, vals);
msg = make_extra_request (req_change_gc, nvals);
put_xid (msg, 4, gc_id );
put_val_list (msg, 8, mask, vals);
msg;
};
fun encode_copy_gc { from, to, mask => xt::VALUE_MASK m }
=
{ msg = make_request (req_copy_gc);
#
put_xid (msg, 4, from);
put_xid (msg, 8, to );
put_word32 (msg, 12, m );
msg;
};
fun encode_set_dashes { gc_id, dash_offset, dashes }
=
{ n = list::length dashes;
#
msg = make_extra_request (req_set_dashes, (pad n) / 4);
put_xid (msg, 4, gc_id );
put_signed16 (msg, 8, dash_offset);
put_signed16 (msg, 10, n );
put_list (put_signed8, 1) (msg, 12, dashes );
msg;
};
fun encode_set_clip_boxes { gc_id, clip_origin, ordering, boxes }
=
{ ordering = case ordering
#
xt::UNSORTED_ORDER => 0u0;
xt::YSORTED_ORDER => 0u1;
xt::YXSORTED_ORDER => 0u2;
xt::YXBANDED_ORDER => 0u3;
esac;
msg = make_extra_request (req_set_clip_boxes, 2 * (list::length boxes));
put8 (msg, 1, ordering );
put_xid (msg, 4, gc_id );
put_point (msg, 8, clip_origin);
put_boxes (msg, 12, boxes );
msg;
};
fun encode_free_gc { gc_id }
=
make_resource_request (req_free_gc, gc_id);
fun encode_clear_area { window_id, box, exposures }
=
{ msg = make_resource_request (req_clear_area, window_id);
#
put_bool (msg, 1, exposures);
put_box (msg, 8, box );
msg;
};
fun encode_copy_area { gc_id, from, to, from_point, size, to_point }
=
{ msg = make_resource_request (req_copy_area, from);
#
put_xid (msg, 8, to );
put_xid (msg, 12, gc_id );
put_point (msg, 16, from_point);
put_point (msg, 20, to_point );
put_size (msg, 24, size );
msg;
};
fun encode_copy_plane { gc_id, from, to, from_point, size, to_point, plane }
=
{ msg = make_resource_request (req_copy_plane, from);
#
put_xid (msg, 8, to );
put_xid (msg, 12, gc_id );
put_point (msg, 16, from_point );
put_point (msg, 20, to_point );
put_size (msg, 24, size );
put32 (msg, 28, large_unt::(<<) (0u1, unt::from_int plane));
msg;
};
stipulate
fun encode_poly req_info { drawable, gc_id, relative, items }
=
{ msg = make_extra_request (req_info, list::length items);
#
put_bool (msg, 1, relative);
put_xid (msg, 4, drawable);
put_xid (msg, 8, gc_id );
put_points (msg, 12, items );
msg;
};
herein
encode_poly_point = encode_poly req_poly_point;
encode_poly_line = encode_poly req_poly_line;
end;
stipulate
fun encode (info, put_items, size) { drawable, gc_id, items }
=
{ msg = make_extra_request (info, size*(list::length items));
#
put_xid (msg, 4, drawable);
put_xid (msg, 8, gc_id );
put_items (msg, 12, items );
msg;
};
put_segs
=
put_list
( \\ (buf, i, (p1, p2): g2d::Line)
=
{ put_point (buf, i, p1);
put_point (buf, i+4, p2);
},
8
);
put_arcs = put_list (put_arc, 12);
herein
encode_poly_segment = encode (req_poly_segment, put_segs, 2);
encode_poly_box = encode (req_poly_rectangle, put_boxes, 2);
encode_poly_fill_box = encode (req_poly_fill_box, put_boxes, 2);
encode_poly_arc = encode (req_poly_arc, put_arcs, 3);
encode_poly_fill_arc = encode (req_poly_fill_arc, put_arcs, 3);
end;
fun encode_fill_poly { drawable, gc_id, shape, relative, points }
=
{ shape = case shape
#
xt::COMPLEX_SHAPE => 0u0;
xt::NONCONVEX_SHAPE => 0u1;
xt::CONVEX_SHAPE => 0u2;
esac;
msg = make_extra_request (req_fill_poly, list::length points);
put_xid (msg, 4, drawable);
put_xid (msg, 8, gc_id );
put8 (msg, 12, shape );
put_bool (msg, 13, relative);
put_points (msg, 16, points );
msg;
};
stipulate
fun put_image_format (buf, i, xt::XYBITMAP) => put8 (buf, i, 0u0);
put_image_format (buf, i, xt::XYPIXMAP) => put8 (buf, i, 0u1);
put_image_format (buf, i, xt::ZPIXMAP ) => put8 (buf, i, 0u2);
end;
herein
fun encode_put_image { drawable, gc_id, depth, size, to, lpad, format, data }
=
{ n = w8v::length data;
#
msg = make_extra_request (req_put_image, (pad n) / 4);
put_image_format (msg, 1, format );
put_xid (msg, 4, drawable);
put_xid (msg, 8, gc_id );
put_size (msg, 12, size );
put_point (msg, 16, to );
put_signed8 (msg, 20, lpad );
put_signed8 (msg, 21, depth );
put_data (msg, 24, data );
msg;
};
fun encode_get_image { drawable, box, plane_mask, format }
=
{ msg = make_resource_request (req_get_image, drawable);
#
put_image_format (msg, 1, format );
put_box (msg, 8, box );
put_plane_mask (msg, 16, plane_mask);
msg;
};
end;
stipulate
fun textlen ( NIL, n) => n;
textlen ((xt::FONT_ITEM _) ! r, n) => textlen (r, n+5);
textlen ((xt::TEXT_ITEM(_, s)) ! r, n) => textlen (r, n+2+(string::length_in_bytes s));
end;
fun encode (itemlen, req_info) { drawable, gc_id, point, items }
=
{ fun put (msg, i, (xt::FONT_ITEM fid) ! r)
=>
{ put8 (msg, i, 0u255);
#
put_word8 (msg, i+1, unt::(>>) (xt::xid_to_unt fid, 0u24)); # NOTE: unaligned( is( this ) ), so we have to do it byte-by-byte
put_word8 (msg, i+2, unt::(>>) (xt::xid_to_unt fid, 0u16));
put_word8 (msg, i+3, unt::(>>) (xt::xid_to_unt fid, 0u8));
put_word8 (msg, i+4, xt::xid_to_unt fid);
put (msg, i+5, r);
};
put (msg, i, (xt::TEXT_ITEM (delta, s)) ! r)
=>
{ n = itemlen s;
#
if (n > 254) xgripe::impossible "excessive string in PolyText";
fi;
put_signed8 (msg, i, n);
put_signed8 (msg, i+1, delta);
put_string (msg, i+2, s);
put (msg, i+2+(string::length_in_bytes s), r);
};
put (msg, i, []) => ();
end;
l = textlen (items, 0);
p = pad l;
msg = make_extra_request (req_info, p / 4);
if (p != l) put8 (msg, 16+l, 0u0); fi; # Xlib does this.
put_xid (msg, 4, drawable);
put_xid (msg, 8, gc_id );
put_point (msg, 12, point );
put (msg, 16, items );
msg;
};
herein
encode_poly_text8 = encode (string::length_in_bytes, req_poly_text8 );
encode_poly_text16 = encode (\\ s = ((string::length_in_bytes s) / 2), req_poly_text16);
end;
stipulate
fun encode (textlen, req_info) { drawable, gc_id, point, string }
=
{ len = string::length_in_bytes string;
#
msg = make_extra_request (req_info, (pad len) / 4);
put_signed8 (msg, 1, textlen string);
put_xid (msg, 4, drawable );
put_xid (msg, 8, gc_id );
put_point (msg, 12, point );
put_string (msg, 16, string );
msg;
};
herein
encode_image_text8 = encode (string::length_in_bytes, req_image_text8);
encode_image_text16 = encode (\\ s = ((string::length_in_bytes s) / 2), req_image_text16);
end;
fun encode_create_colormap { cmap, window_id, visual, all_writable }
=
{ msg = make_request req_create_colormap;
#
put_bool (msg, 1, all_writable);
put_xid (msg, 4, cmap );
put_xid (msg, 8, window_id );
put_xid (msg, 12, visual );
msg;
};
fun encode_free_colormap { cmap }
=
make_resource_request (req_free_colormap, cmap);
fun encode_copy_colormap_and_free { from, to }
=
{ msg = make_request req_copy_colormap_and_free;
#
put_xid (msg, 4, to );
put_xid (msg, 8, from);
msg;
};
fun encode_install_colormap { cmap } = make_resource_request (req_install_colormap, cmap);
fun encode_uninstall_colormap { cmap } = make_resource_request (req_uninstall_colormap, cmap);
fun encode_list_installed_colormaps { window_id }
=
make_resource_request (req_list_installed_colormaps, window_id);
fun encode_alloc_color { cmap, color }
=
{ msg = make_request (req_alloc_color);
#
put_xid (msg, 4, cmap);
put_rgb (msg, 8, color);
msg;
};
fun encode_alloc_named_color { cmap, name }
=
{ n = string::length_in_bytes name;
#
msg = make_extra_request (req_alloc_named_color, (pad n) / 4);
put_xid (msg, 4, cmap);
put_signed16 (msg, 8, n );
put_string (msg, 12, name);
msg;
};
/**************************************************************************************
fun encodeAllocColorCells = let
msg = mkReq (reqAllocColorCells)
in
raise exception XERROR "unimplemented" # ** FIX **
end
fun encodeAllocColorPlanes = let
msg = mkReq (reqAllocColorPlanes)
in
raise exception XERROR "unimplemented" # ** FIX **
end
**************************************************************************************/
fun encode_free_colors { cmap, plane_mask, pixels }
=
{ msg = make_extra_request (req_free_colors, list::length pixels);
#
put_xid (msg, 4, cmap );
put_plane_mask (msg, 8, plane_mask);
put_rgb8s (msg, 12, pixels );
msg;
};
stipulate
fun put_color_item (buf, i, xt::COLORITEM { rgb8, red, green, blue } )
=
{ rmask = case red NULL => 0u0; THE x => { put_word16 (buf, i+4, x); 0u1;}; esac;
gmask = case green NULL => 0u0; THE x => { put_word16 (buf, i+6, x); 0u2;}; esac;
bmask = case blue NULL => 0u0; THE x => { put_word16 (buf, i+8, x); 0u4;}; esac;
put_rgb8 (buf, i, rgb8);
put8 (buf, i+10, one_byte_unt::bitwise_or (rmask, one_byte_unt::bitwise_or (gmask, bmask)));
};
put_color_item_list
=
put_list (put_color_item, 12);
herein
fun encode_store_colors { cmap, items }
=
{ msg = make_extra_request (req_store_colors, 3*(list::length items));
#
put_xid (msg, 4, cmap );
put_color_item_list (msg, 8, items);
msg;
};
end;
fun encode_store_named_color
{ cmap, name, pixel, do_red, do_green, do_blue }
=
{ n = string::length_in_bytes name;
#
mask =
one_byte_unt::bitwise_or
(
do_red ?? 0u1
:: 0u0,
one_byte_unt::bitwise_or
(
do_green ?? 0u2
:: 0u0,
do_blue ?? 0u4
:: 0u0
)
);
msg = make_extra_request (req_store_named_color, (pad n) / 4);
put8 (msg, 1, mask );
put_xid (msg, 4, cmap );
put_rgb8 (msg, 8, pixel);
put_string (msg, 12, name );
msg;
};
fun encode_query_colors { cmap, pixels }
=
{ msg = make_extra_request (req_query_colors, list::length pixels);
#
put_xid (msg, 4, cmap );
put_rgb8s (msg, 8, pixels);
msg;
};
fun encode_lookup_color { cmap, name }
=
{ n = string::length_in_bytes name;
#
msg = make_extra_request (req_lookup_color, (pad n) / 4);
put_xid (msg, 4, cmap);
put_signed16 (msg, 8, n );
put_string (msg, 12, name);
msg;
};
fun encode_create_cursor { cursor, from, mask, foreground_rgb, background_rgb, hot_spot }
=
{ msg = make_request (req_create_cursor);
#
put_xid (msg, 4, cursor );
put_xid (msg, 8, from );
put_xid_option (msg, 12, mask );
put_rgb (msg, 16, foreground_rgb);
put_rgb (msg, 22, background_rgb);
put_point (msg, 24, hot_spot );
msg;
};
fun encode_create_glyph_cursor
{ cursor, src_font, mask_font, src_chr, mask_chr, foreground_rgb, background_rgb }
=
{ msg = make_request (req_create_glyph_cursor);
#
put_xid (msg, 4, cursor );
put_xid (msg, 8, src_font );
put_xid_option (msg, 12, mask_font );
put_signed16 (msg, 16, src_chr );
put_signed16 (msg, 18, mask_chr );
put_rgb (msg, 20, foreground_rgb);
put_rgb (msg, 26, background_rgb);
msg;
};
fun encode_free_cursor { cursor }
=
make_resource_request (req_free_cursor, cursor);
fun encode_recolor_cursor { cursor, foreground_color, background_color }
=
{ msg = make_request req_recolor_cursor;
#
put_xid (msg, 4, cursor );
put_rgb (msg, 8, foreground_color);
put_rgb (msg, 14, background_color);
msg;
};
fun encode_query_best_size { ilk, drawable, size }
=
{ ilk = case ilk
#
xt::CURSOR_SHAPE => 0u0;
xt::TILE_SHAPE => 0u1;
xt::STIPPLE_SHAPE => 0u2;
esac;
msg = make_request req_query_best_size;
put8 (msg, 1, ilk );
put_xid (msg, 4, drawable);
put_size (msg, 8, size );
msg;
};
fun encode_query_extension name
=
{ n = string::length_in_bytes name;
#
msg = make_extra_request (req_query_extension, (pad n) / 4);
put_signed16 (msg, 4, n );
put_string (msg, 8, name);
msg;
};
/**************************************************************************************
fun encodeChangeKeyboardMapping = let
msg = mkReq (reqChangeKeyboardMapping)
in
raise exception XERROR "unimplemented" # ** FIX **
end
**************************************************************************************/
fun encode_get_keyboard_mapping { first=>(xt::KEYCODE k), count }
=
{ msg = make_request req_get_keyboard_mapping;
#
put_signed8 (msg, 4, k );
put_signed8 (msg, 5, count);
msg;
};
fun encode_change_keyboard_control { vals }
=
{ (make_value_list vals)
->
(nvals, mask, vals);
msg = make_extra_request (req_change_keyboard_control, nvals);
put_val_list (msg, 4, mask, vals);
msg;
};
fun encode_bell { percent }
=
{ msg = make_request req_bell;
#
put_signed8 (msg, 1, percent);
msg;
};
fun encode_change_pointer_control { acceleration, threshold }
=
{ msg = make_request req_change_pointer_control;
#
case acceleration
#
NULL =>
put_bool (msg, 10, FALSE);
#
THE { numerator, denominator }
=>
{ put_bool (msg, 10, TRUE);
put_signed16 (msg, 4, numerator);
put_signed16 (msg, 6, denominator);
};
esac;
case threshold
#
NULL =>
put_bool (msg, 11, FALSE);
#
THE threshold
=>
{ put_bool (msg, 11, FALSE);
put_signed16 (msg, 8, threshold);
};
esac;
msg;
};
fun encode_set_screen_saver
{ timeout, interval, prefer_blanking, allow_exposures }
=
{ msg = make_request req_set_screen_saver;
#
fun put (msg, i, NULL ) => put8 (msg, i, 0u2);
put (msg, i, THE b) => put_bool (msg, i, b );
end;
put_signed16 (msg, 4, timeout );
put_signed16 (msg, 6, interval );
put (msg, 8, prefer_blanking);
put (msg, 9, allow_exposures);
msg;
};
fun encode_change_hosts { host, remove }
=
{ my (family, address)
=
case host
(xt::INTERNET_HOST s) => (0u0, s);
(xt::DECNET_HOST s) => (0u1, s);
(xt::CHAOS_HOST s) => (0u2, s);
esac;
len = string::length_in_bytes address;
msg = make_extra_request (req_change_hosts, (pad len) / 4);
put_bool (msg, 1, remove );
put8 (msg, 4, family );
put_signed16 (msg, 6, len );
put_string (msg, 8, address);
msg;
};
fun encode_set_access_control { enable }
=
{ msg = make_request (req_set_access_control);
#
put_bool (msg, 1, enable);
msg;
};
fun encode_set_close_down_mode { mode }
=
{ mode = case mode
#
xt::DESTROY_ALL => 0u0;
xt::RETAIN_PERMANENT => 0u1;
xt::RETAIN_TEMPORARY => 0u2;
esac;
msg = make_request (req_set_close_down_mode);
put8 (msg, 1, mode);
msg;
};
fun encode_kill_client { resource }
=
{ rid = case resource NULL => xt::xid_from_unt 0u0;
THE x => x;
esac;
make_resource_request (req_kill_client, rid);
};
fun encode_rotate_properties { window_id, delta, properties }
=
{ n = list::length properties;
#
msg = make_extra_request (req_rotate_properties, n);
put_xid (msg, 4, window_id );
put_signed16 (msg, 8, n );
put_signed16 (msg, 10, delta );
put_list (put_atom, 4) (msg, 12, properties);
msg;
};
fun encode_force_screen_saver { activate }
=
{ msg = make_request req_force_screen_saver;
#
put_bool (msg, 1, activate);
msg;
};
/**************************************************************************************
fun encodeSetPointerMapping = let
msg = mkReq (reqSetPointerMapping)
in
raise exception XERROR "unimplemented" # ** FIX **
end
fun encodeGetPointerMapping = let
msg = mkReq (reqGetPointerMapping)
in
raise exception XERROR "unimplemented" # ** FIX **
end
fun encodeSetModifierMapping = let
msg = mkExtraReq (reqSetModifierMapping, ?)
in
raise exception XERROR "unimplemented" # ** FIX **
end
**************************************************************************************/
# Fixed requests
#
request_no_operation = make_request req_no_operation;
request_get_input_focus = make_request req_get_input_focus;
request_query_keymap = make_request req_query_keymap;
request_grab_server = make_request req_grab_server;
request_ungrab_server = make_request req_ungrab_server;
request_get_font_path = make_request req_get_font_path;
request_list_extensions = make_request req_list_extensions;
request_get_keyboard_control = make_request req_get_keyboard_control;
request_get_pointer_control = make_request req_get_pointer_control;
request_get_screen_saver = make_request req_get_screen_saver;
request_list_hosts = make_request req_list_hosts;
request_get_modifier_mapping = make_request req_get_modifier_mapping;
end; # stipulate
}; # package xrequest
end;