elk/lib/xwidgets/class.c

/* class.c
 *
 * $Id$
 *
 * Copyright 1990, 1991, 1992, 1993, 1994, 1995, Oliver Laumann, Berlin
 * Copyright 2002, 2003 Sam Hocevar <sam@zoy.org>, 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 "xt.h"

#define MAX_CLASS                128
#define MAX_CALLBACK_PER_CLASS   10

typedef struct {
    char *name;
    int has_arg;
} CALLBACK_INFO;

typedef struct {
    WidgetClass class;
    char *name;
    CALLBACK_INFO cb[MAX_CALLBACK_PER_CLASS], *cblast;
    XtResourceList sub_resources;
    int num_resources;
} CLASS_INFO;

static CLASS_INFO ctab[MAX_CLASS], *clast = ctab;

Generic_Predicate (Class)

Generic_Simple_Equal (Class, CLASS, wclass)

Generic_Print (Class, "#[class %s]", CLASS(x)->name)

Object Make_Class (WidgetClass class, char *name) {
    Object c;

    c = Find_Object (T_Class, (GENERIC)0, Match_Xt_Obj, class);
    if (Nullp (c)) {
        c = Alloc_Object (sizeof (struct S_Class), T_Class, 0);
        CLASS(c)->tag = Null;
        CLASS(c)->wclass = class;
        CLASS(c)->name = name;
        Register_Object (c, (GENERIC)0, (PFO)0, 0);
        /* See comment in Define_Class below */
        XtInitializeWidgetClass (class);
    }
    return c;
}

Object Make_Widget_Class (WidgetClass class) {
    register CLASS_INFO *p;

    for (p = ctab; p < clast; p++)
        if (p->class == class)
            return Make_Class (class, p->name);
    Primitive_Error ("undefined widget class ~s", Xt_Class_Name (class));
    /*NOTREACHED*/
}

static Object P_Find_Class (Object name) {
    register CLASS_INFO *p;
    register char *s = Get_Strsym (name);

    for (p = ctab; p < clast; p++) {
        if (streq (p->name, s))
            return Make_Class (p->class, p->name);
    }
    Primitive_Error ("no such widget class: ~s", name);
    /*NOTREACHED*/
}

static Object P_Class_Existsp (Object name) {
    register CLASS_INFO *p;
    register char *s = Get_Strsym (name);

    for (p = ctab; p < clast; p++) {
        if (streq (p->name, s))
            return True;
    }
    return False;
}

char *Class_Name (WidgetClass class) {
    register CLASS_INFO *p;

    for (p = ctab; p < clast && p->class != class; p++)
        ;
    if (p == clast)
        return "unknown";
    return p->name;
}

void Get_Sub_Resource_List (WidgetClass class, XtResourceList *rp,
                            Cardinal *np) {
    register CLASS_INFO *p;

    for (p = ctab; p < clast && p->class != class; p++)
        ;
    if (p == clast)
        Primitive_Error ("undefined widget class ~s", Xt_Class_Name (class));
    *np = p->num_resources;
    *rp = p->sub_resources;
}

static Object P_Class_Resources (Object c) {
    Check_Type (c, T_Class);
    return Get_Resources (CLASS(c)->wclass, XtGetResourceList, 1);
}

static Object P_Class_Constraint_Resources (Object c) {
    Check_Type (c, T_Class);
    return Get_Resources (CLASS(c)->wclass, XtGetConstraintResourceList, 1);
}

static Object P_Class_Sub_Resources (Object c) {
    Check_Type (c, T_Class);
    return Get_Resources (CLASS(c)->wclass, Get_Sub_Resource_List, 0);
}

void Define_Class (char *name, WidgetClass class, XtResourceList r, int nr) {
    Set_Error_Tag ("define-class");
    if (clast == ctab+MAX_CLASS)
        Primitive_Error ("too many widget classes");
    /*
     * The next line should read:
     *    XtInitializeWidgetClass (class);
     * However, there is a bug in Motif 1.1.4 that causes an application
     * to drop core if the row-column widget class is initialized before
     * the first vendor-shell widget has been created.
     * Thus, we can't initialize any classes at this point; we will do
     * it in Make_Class above instead.
     * This essentially causes a class to be initialized the first time
     * it is used.
     */
    clast->name = name;
    clast->class = class;
    clast->cb[0].name = XtNdestroyCallback;
    clast->cb[0].has_arg = 0;
    clast->cblast = clast->cb+1;
    clast->sub_resources = r;
    clast->num_resources = nr;
    clast++;
}

void Define_Callback (char *cl, char *s, int has_arg) {
    register CLASS_INFO *p;

    Set_Error_Tag ("define-callback");
    for (p = ctab; p < clast; p++)
        if (streq (p->name, cl)) {
            if (p->cblast == p->cb+MAX_CALLBACK_PER_CLASS)
                Primitive_Error ("too many callbacks for this class");
            p->cblast->name = s;
            p->cblast->has_arg = has_arg;
            p->cblast++;
            return;
        }
    Primitive_Error ("undefined class");
}

PFX2S Find_Callback_Converter (WidgetClass c, char *name, Object sname) {
    register CLASS_INFO *p;
    register CALLBACK_INFO *q;
    PFX2S conv;

    for (p = ctab; p < clast; p++)
        if (p->class == c) {
            for (q = p->cb; q < p->cblast; q++)
                if (streq (q->name, name)) {
                    if (q->has_arg) {
                        char s1[128], s2[128], msg[256];

                        /* First look for a class specific converter
                         * then for a general one.  Callback converters
                         * have a prefix "callback:" to avoid name conflicts
                         * with converters for normal resources.
                         */
                        sprintf (s1, "callback:%s-%s", p->name, name);
                        conv = Find_Converter_To_Scheme (s1);
                        if (conv == 0) {
                            sprintf(s2, "callback:%s", name);
                            conv = Find_Converter_To_Scheme (s2);
                            if (conv == 0) {
                                sprintf (msg,
                                    "no callback converter for %s or %s",
                                        s1, s2);
                                Primitive_Error (msg);
                            }
                        }
                        return conv;
                    } else return (PFX2S)0;
                }
            Primitive_Error ("no such callback: ~s", sname);
        }
    Primitive_Error ("undefined widget class ~s", Xt_Class_Name (c));
    /*NOTREACHED*/
}

void elk_init_xt_class () {
    Generic_Define (Class, "class", "class?");
    Define_Primitive (P_Find_Class,        "find-class",        1, 1, EVAL);
    Define_Primitive (P_Class_Resources,   "class-resources",   1, 1, EVAL);
    Define_Primitive (P_Class_Constraint_Resources,
                               "class-constraint-resources",    1, 1, EVAL);
    Define_Primitive (P_Class_Sub_Resources,
                               "class-sub-resources",           1, 1, EVAL);
    Define_Primitive (P_Class_Existsp,     "class-exists?",     1, 1, EVAL);
    /*
     * Doesn't work with Motif-1.1.0:
     *
    Define_Class ("simple", simpleWidgetClass, (XtResourceList)0, 0);
     */
    Define_Class ("core", widgetClass, (XtResourceList)0, 0);
    Define_Class ("constraint", constraintWidgetClass, (XtResourceList)0, 0);
    Define_Class ("composite", compositeWidgetClass, (XtResourceList)0, 0);
}