elk/lib/xlib/wm.c

/* wm.c
 *
 * $Id$
 *
 * Copyright 1990, 1991, 1992, 1993, 1994, 1995, Oliver Laumann, Berlin
 * Copyright 2002, 2003 Sam Hocevar <sam@hocevar.net>, Paris
 *
 * This software was derived from Elk 1.2, which was Copyright 1987, 1988,
 * 1989, Nixdorf Computer AG and TELES GmbH, Berlin (Elk 1.2 has been written
 * by Oliver Laumann for TELES Telematic Services, Berlin, in a joint project
 * between TELES and Nixdorf Microprocessor Engineering, Berlin).
 *
 * Oliver Laumann, TELES GmbH, Nixdorf Computer AG and Sam Hocevar, as co-
 * owners or individual owners of copyright in this software, grant to any
 * person or company a worldwide, royalty free, license to
 *
 *    i) copy this software,
 *   ii) prepare derivative works based on this software,
 *  iii) distribute copies of this software or derivative works,
 *   iv) perform this software, or
 *    v) display this software,
 *
 * provided that this notice is not removed and that neither Oliver Laumann
 * nor Teles nor Nixdorf are deemed to have made any representations as to
 * the suitability of this software for any purpose nor are held responsible
 * for any defects of this software.
 *
 * THERE IS ABSOLUTELY NO WARRANTY FOR THIS SOFTWARE.
 */

#include "xlib.h"

static Object Sym_Pointer_Root;

static Object P_Reparent_Window (Object w, Object parent, Object x,
                                 Object y) {
    Check_Type (w, T_Window);
    Check_Type (parent, T_Window);
    XReparentWindow (WINDOW(w)->dpy, WINDOW(w)->win, WINDOW(parent)->win,
        Get_Integer (x), Get_Integer (y));
    return Void;
}

static Object P_Install_Colormap (Object c) {
    Check_Type (c, T_Colormap);
    XInstallColormap (COLORMAP(c)->dpy, COLORMAP(c)->cm);
    return Void;
}

static Object P_Uninstall_Colormap (Object c) {
    Check_Type (c, T_Colormap);
    XUninstallColormap (COLORMAP(c)->dpy, COLORMAP(c)->cm);
    return Void;
}

static Object P_List_Installed_Colormaps (Object w) {
    int i, n;
    Colormap *ret;
    Object v;
    GC_Node;

    Check_Type (w, T_Window);
    ret = XListInstalledColormaps (WINDOW(w)->dpy, WINDOW(w)->win, &n);
    v = Make_Vector (n, Null);
    GC_Link (v);
    for (i = 0; i < n; i++) {
        Object c;

        c = Make_Colormap (0, WINDOW(w)->dpy, ret[i]);
        VECTOR(v)->data[i] = c;
    }
    XFree ((char *)ret);
    GC_Unlink;
    return v;
}

static Object P_Set_Input_Focus (Object d, Object win, Object revert_to,
                                 Object time) {
    Window focus = PointerRoot;

    Check_Type (d, T_Display);
    if (!EQ(win, Sym_Pointer_Root))
        focus = Get_Window (win);
    XSetInputFocus (DISPLAY(d)->dpy, focus, Symbols_To_Bits (revert_to, 0,
        Revert_Syms), Get_Time (time));
    return Void;
}

static Object P_Input_Focus (Object d) {
    Window win;
    int revert_to;
    Object ret, x;
    GC_Node;

    Check_Type (d, T_Display);
    XGetInputFocus (DISPLAY(d)->dpy, &win, &revert_to);
    ret = Cons (Null, Null);
    GC_Link (ret);
    x = Make_Window (0, DISPLAY(d)->dpy, win);
    Car (ret) = x;
    x = Bits_To_Symbols ((unsigned long)revert_to, 0, Revert_Syms);
    Cdr (ret) = x;
    GC_Unlink;
    return ret;
}

static Object P_General_Warp_Pointer (Object dpy, Object dst, Object dstx,
                                      Object dsty, Object src, Object srcx,
                                      Object srcy, Object srcw, Object srch) {
    Check_Type (dpy, T_Display);
    XWarpPointer (DISPLAY(dpy)->dpy, Get_Window (src), Get_Window (dst),
        Get_Integer (srcx), Get_Integer (srcy), Get_Integer (srcw),
        Get_Integer (srch), Get_Integer (dstx), Get_Integer (dsty));
    return Void;
}

static Object P_Bell (int argc, Object *argv) {
    register int percent = 0;

    Check_Type (argv[0], T_Display);
    if (argc == 2) {
        percent = Get_Integer (argv[1]);
        if (percent < -100 || percent > 100)
            Range_Error (argv[1]);
    }
    XBell (DISPLAY(argv[0])->dpy, percent);
    return Void;
}

static Object P_Set_Access_Control (Object dpy, Object on) {
    Check_Type (dpy, T_Display);
    Check_Type (on, T_Boolean);
    XSetAccessControl (DISPLAY(dpy)->dpy, EQ(on, True));
    return Void;
}

static Object P_Change_Save_Set (Object win, Object mode) {
    Check_Type (win, T_Window);
    XChangeSaveSet (WINDOW(win)->dpy, WINDOW(win)->win,
        Symbols_To_Bits (mode, 0, Saveset_Syms));
    return Void;
}

static Object P_Set_Close_Down_Mode (Object dpy, Object mode) {
    Check_Type (dpy, T_Display);
    XSetCloseDownMode (DISPLAY(dpy)->dpy,
        Symbols_To_Bits (mode, 0, Closemode_Syms));
    return Void;
}

static Object P_Get_Pointer_Mapping (Object dpy) {
    unsigned char map[256];
    register int i, n;
    Object ret;

    Check_Type (dpy, T_Display);
    n = XGetPointerMapping (DISPLAY(dpy)->dpy, map, 256);
    ret = Make_Vector (n, Null);
    for (i = 0; i < n; i++)
        VECTOR(ret)->data[i] = Make_Integer (map[i]);
    return ret;
}

static Object P_Set_Pointer_Mapping (Object dpy, Object map) {
    register int i, n;
    register unsigned char *p;
    Object ret;
    Alloca_Begin;

    Check_Type (dpy, T_Display);
    Check_Type (map, T_Vector);
    n = VECTOR(map)->size;
    Alloca (p, unsigned char*, n);
    for (i = 0; i < n; i++)
        p[i] = Get_Integer (VECTOR(map)->data[i]);
    ret = XSetPointerMapping (DISPLAY(dpy)->dpy, p, n) == MappingSuccess ?
        True : False;
    Alloca_End;
    return ret;
}

void elk_init_xlib_wm () {
    Define_Primitive (P_Reparent_Window,  "reparent-window",  4, 4, EVAL);
    Define_Primitive (P_Install_Colormap, "install-colormap", 1, 1, EVAL);
    Define_Primitive (P_Uninstall_Colormap,
                        "uninstall-colormap",                 1, 1, EVAL);
    Define_Primitive (P_List_Installed_Colormaps,
                        "list-installed-colormaps",           1, 1, EVAL);
    Define_Primitive (P_Set_Input_Focus,  "set-input-focus",  4, 4, EVAL);
    Define_Primitive (P_Input_Focus,      "input-focus",      1, 1, EVAL);
    Define_Primitive (P_General_Warp_Pointer,
                        "general-warp-pointer",               9, 9, EVAL);
    Define_Primitive (P_Bell,             "bell",             1, 2, VARARGS);
    Define_Primitive (P_Set_Access_Control,
                        "set-access-control",                 2, 2, EVAL);
    Define_Primitive (P_Change_Save_Set,  "change-save-set",  2, 2, EVAL);
    Define_Primitive (P_Set_Close_Down_Mode,
                        "set-close-down-mode",                2, 2, EVAL);
    Define_Primitive (P_Get_Pointer_Mapping,
                        "get-pointer-mapping",                1, 1, EVAL);
    Define_Primitive (P_Set_Pointer_Mapping,
                        "set-pointer-mapping",                2, 2, EVAL);
    Define_Symbol(&Sym_Pointer_Root, "pointer-root");
}