[Date Prev] [Date Next] [Thread Prev] [Thread Next] Date Index Thread Index Search archive:
Date:Mon Jul 17 09:50:03 1995 
Subject:Re: getting and setting constraint resource lists 
From:Ian Rogers 
Volume-ID:950718.02 

> I'm trying to get and set the constraint resources of a widget, and I'm
> confused about several things.  The procedure XtGetConstraintResourceList
> takes three arguments: a widget, a resourcelistptr, and a cardinalptr.
> I'm assuming that a resourcelistptr is a pointer to a resource list.  How
> do I create a resourcelistptr for the widget whose constraint resources
> I want to see?


I wrote the following a long time ago when Poplog's X interface was still
undergoing rapid change. It digs all the information out of a widget tree
(and then some!), and prints it out in a very verbose manner.

I haven't run this code for years, it may still work, it may not. I
suggest you don't have any important work unsaved in your Ved buffers when
you try it :-)

Ian.



/* --- Copyright University of Sussex 1991. All rights reserved. ----------
 > File:            $UIDE/dvp/uide1/lib/wsinfo.p
 > Purpose:         For hacking info out of widget sets (non-portable)
 > Author:          Ian Rogers, Mar  7 1991
 > Documentation:
 > Related Files:
 */


/* EXAMPLE:

    uses showtree;
    showtree(ws_class_tree("Uide"));
    ws_class_tree("Uide")

    wsinfo("Uide");


*/

compile_mode :pop11 +varsch;

loadinclude xdefs;

vars XTLIBDIRS = '-L/usr/local/X11/lib' :: XTLIBDIRS;
vars XTLIBFILES = ['-lXt' '-lXmu'] <> tl(XTLIBFILES);

uses XptWidgetSet;
uses shadowclass;
uses xpt_coretypes
uses xpt_generaltypes;
uses xt_resource;

loadinclude icdl;

section $-uide => wsinfo ws_class_tree;

define lconstant chopwidget(name);
lvars   name;
    if isendstring("Widget", name) then
        allbutlast(6, name)
    else
        name
    endif;
enddefine;

constant toolkit_members =
            [Rect UnNamedObj] <>
            maplist(XptWidgetSet("Toolkit")("WidgetSetMembers"), chopwidget),
    ;


vars
    icwidgetset,
    exclude_toolkit = false,
    ;

p_typespec core_widget_part {
    superclass  :exptr,
    class_name  :XptString,
    /* other fields */
};

defclass lconstant ic_class {
    ic_name,
    ic_subclasses,
    ic_resources,
    ic_attributes,
    ic_constraints,
    ic_widgetclass,
    ic_widgetset,
    ic_parent
};

define initic =
    consic_class(% false,false,false,[],false,false,false,false %)
enddefine;

define nametoclass =
    newassoc([]);
enddefine;


/*
    Takes a widget class name and forms a list of the names of the parent
    classes all the way up to "Object"
*/
define ClassHierarchy(class);
lvars class
    ;
    define lconstant classhierarchy(class);
    lvars   class;
    lvars   superclass, class_name,
        ;
    lconstant nullptr = consexternal_ptr()
        ;
        exacc :core_widget_part class.superclass -> superclass;
        consword(exacc :core_widget_part class.class_name) -> class_name;
        class -> nametoclass(class_name);

        if superclass /= nullptr then
            classhierarchy(superclass)
        endif, class_name,
    enddefine;

    [% classhierarchy(class) %]
enddefine;


/*
    Takes a widget set name and returns an ordered list of the Class
    Hierarchies of it's members
 */
define WidgetSetInfo(wsetname);
lvars   wsetname;
lvars   wset, members, class, info, item,
    ;
    XptLoadWidgetSet(wsetname);
    XptWidgetSet(wsetname) -> wset;
    [%  for item in wset("WidgetSetMembers") do
            unless issubstring('Gadget', 1, item) then
                item,
            endunless;
        endfor;
    %] -> members;
    clearproperty(nametoclass);
    [%
        for class in members do
            ClassHierarchy(wset(class)) <> [^class]
        endfor;
    %] -> info;

    define lconstant infosort(a, b);
    lvars   a, b;
        if null(a) then
            true;
        elseif null(b) then
            false;
        elseif hd(a) == hd(b) then
            infosort(tl(a), tl(b));
        else
            alphabefore(hd(a), hd(b));
        endif;
    enddefine;

    syssort(info, false, infosort) -> info;
    info;
enddefine;


/*
    Takes the ordered list returned from above and merges it into a list of
    trees (a. la. -showtree-), recreating the widget set inheritance tree.
 */
define wstree(flatlist);
    lvars flatlist i nodename;

    [%  until null(flatlist) do
            dest(flatlist) -> flatlist -> i;
            if null(tl(i)) then
                hd(i)
            else
                hd(i) -> nodename;
                nodename :: wstree([%
                        tl(i),
                        while not(null(flatlist))
                        and hd(hd(flatlist)) == nodename
                        do
                            dest(flatlist) -> flatlist -> i;
                            tl(i)
                        endwhile;
                    %]
                )
            endif;
        enduntil;
    %]
enddefine;


/*
    The user procedure for taking the name of a widget set, and returning
    the inheritence hierarchy
 */
define ws_class_tree with_nargs 1;
    wstree(WidgetSetInfo());
enddefine;


define normalisenode(node) -> node -> hashandle;
lvars   node,
        hashandle = false,
    ;
lvars   i
    ;
    [%  hd(node),
        for i in tl(node) do
            if isword(i) then
                i -> hashandle
            else
                i
            endif;
        endfor;
    %] -> node;
enddefine;


vars reworktree;  ;;; forward reference

define rlisttree(tree);
lvars   tree
    ;
    maplist(tree, reworktree);
enddefine;


define reworktree(node) -> ic;
lvars   node
    ;
lvars   ic = initic(),
        i nodename hashandle
        class eptr
        res = consexternal_ptr(),
    ;
lconstant   nres = consXptCardinalPtr(0),
    ;
    define lconstant getrlist;
    lvars reslist;
        exacc :exptr res -> reslist;
        [%  for i to exacc :XptCardinalPtr nres.XptCPValue do
                exacc :XptResource[] reslist[i] -> eptr;
                {%
                    exacc :XptResource eptr.XptRName,
                    exacc :XptResource eptr.XptRClass,
                    exacc :XptResource eptr.XptRType,
                    exacc :XptResource eptr.XptRDefType,
                    exacc :XptResource eptr.XptRDefAddr,
                %}
            endfor
        %]
    enddefine;

    fill_external_ptr(consexternal_ptr().copy_fixed, res) -> res;
    icwidgetset -> ic_widgetset(ic);

    if isword(node) then
        node -> ic_name(ic);

        node -> ic_widgetclass(ic);

        false -> ic_subclasses(ic);
    else
        normalisenode(node) -> node -> hashandle;
        hd(node) -> ic_name(ic);

        if hashandle then
            hashandle   -> ic_widgetclass(ic);
        else
            hd(node)    -> ic_widgetclass(ic);
            "private" :: ic_attributes(ic) -> ic_attributes(ic);
        endif;

        rlisttree(tl(node)) -> ic_subclasses(ic);
        for i in ic_subclasses(ic) do
            ic -> ic_parent(i)
        endfor;
    endif;

    if ic_widgetclass(ic) ->> class then
        if member(class, XptWidgetSet(icwidgetset)("WidgetSetMembers")) then
            XptWidgetSet(icwidgetset)(class)
        else
            false
        endif -> class;
    else
        nametoclass(hd(node)) -> class;
    endif;

    if class then
        fast_XtGetResourceList(class, res, nres);
        getrlist() -> ic_resources(ic);

        fast_XtGetConstraintResourceList(class, res, nres);
        getrlist() -> ic_constraints(ic);
    endif;
enddefine;


/****************

    The next section of this file prints out ICDL code from the
    data constructed by -reworktree-

 ****************/

vars tablevel = 0;

define out();
    repeat tablevel times pr('\t') endrepeat;
    printf();
enddefine;


define lconstant title(s);
    lvars s;
    `-`, `-`, `-`, ` `,
    explode(s),
    ` `, fast_repeat 67 - datalength(s) times `-` endrepeat;
    consstring(72);
enddefine;


define outdate;
lvars   date    = sysdaytime()
    ;
lconstant   monthnum = newassoc([   [Jan 1] [Feb 2] [Mar 3] [Apr 4] [May 5]
                                    [Jun 6] [Jul 7] [Aug 8] [Sep 9] [Oct 10]
                                    [Nov 11] [Dec 12]
                                ]
                        ),
    ;
    out('%p %p %p %p %p %p',
        [%  substring(9, 2, date),                      ;;; day
            monthnum(consword(substring(5, 3, date))),  ;;; month
            substring(25, 4, date),                     ;;; year
            substring(12, 2, date), ;;; hours
            substring(15, 2, date), ;;; minutes
            substring(18, 2, date), ;;; seconds
         %]
    );
enddefine;


define outheader();
    out('icdl_prologue\n');
    out('\tfilename\t\'%p.%p\',\n', [^icwidgetset ^icdl_extension]);
    out('\tversion\t\t%p,\n', [^icdl_version]);
    out('\tdate\t\t'); outdate(); out(',\n');
    out('\tauthor\t\t%p,\n', [% sysgetusername(popusername) %]);
    out(';\n\n');
enddefine;


define outtrailer();
    out('icdl_epilogue\n');
    out(';\n\n');
enddefine;


define outlabel(ic);
lvars   ic;
    out('IC_label \'%p %p %p\';\n\n',
        [% icwidgetset, ic.ic_name, 'Widget' %]
    );
enddefine;


define outkind(widgetset, widgetclass);
lvars   widgetset, widgetclass;
dlocal  tablevel,
    ;
    out('IC_kind widget');

    0 -> tablevel;
    if widgetclass then
        out(' [%p %p]', [% widgetset, widgetclass %]);
    endif;
    out(';\n\n');
enddefine;


define outslotopener(type);
lvars   type;
    out('IC_slot %p\n', [^type]);
enddefine;


define outslotcloser(type);
lvars   type;
    out('endIC_slot;\n\n'); ;;; -type- is ignored for now
enddefine;


define outresource(res);
lvars   res;
    out( '%p {\n',          [% res(1) %]);
    out( '\tclass:\t%p,\n', [% res(2) %]);
    out( '\ttype:\t%p,\n',  [% res(3) %]);
    out( '\thelp:\t\'\',\n');
    out( '\tflags:\t[],\n');
    out( '\t},\n');
enddefine;


define outattributes(attrs);
lvars   attrs;
dlocal  tablevel,
    ;
lvars   attr,
    ;
    if null(attrs) then
        return;
    endif;

    outslotopener('attributes');

    tablevel + 1 -> tablevel;
    for attr in attrs do
        outresource(attr);
    endfor;
    tablevel - 1 -> tablevel;

    outslotcloser('attributes');
enddefine;


define outconstraints(consts);
lvars   consts;
dlocal  tablevel,
    ;
lvars   const,
    ;
    if null(consts) then
        return;
    endif;

    outslotopener('child_attributes');

    tablevel + 1 -> tablevel;
    for const in consts do
        outresource(const);
    endfor;
    tablevel + 1 -> tablevel;

    outslotcloser('child_attributes');
enddefine;


define excludenode(node);
lvars   node;
    exclude_toolkit and member(node.ic_name, toolkit_members)
enddefine;


define mkicname(node);
lvars   node;
lvars   wset    = node.ic_widgetset,
    ;
    if excludenode(node) then
        'Toolkit' -> wset;
    endif;
    'IC' >< node.ic_name >< '_' >< wset;
enddefine;


define outic(node);
lvars   node;
dlocal  tablevel,
    ;
lvars   subnode,
    ;

    unless excludenode(node) then
        out('define:icclass ');

        if node.ic_attributes /= nil then
            out('%p ', [% node.ic_attributes %]);
        endif;
        out(mkicname(node));
        if node.ic_parent then
            out(' isa ');
            out(mkicname(node.ic_parent));
        endif;
        out(';\n');

        tablevel + 1 -> tablevel;
        outkind(node.ic_widgetset, node.ic_widgetclass);
        outlabel(node);
        outattributes(node.ic_resources);
        outconstraints(node.ic_constraints);
        tablevel - 1 -> tablevel;

        out('enddefine;\n\n\n');
    endunless;

    if node.ic_subclasses then
        applist(node.ic_subclasses, outic);
    endif;
enddefine;


define ws2icdl(wstree);
lvars   wstree;
    outheader();
    applist(wstree, outic);
    outtrailer();
enddefine;


define wsinfo(icwidgetset);
dlocal  icwidgetset,
        exclude_toolkit,
    ;
    icwidgetset /== "Toolkit" -> exclude_toolkit;
    ws2icdl(rlisttree(wstree(WidgetSetInfo(icwidgetset))));
enddefine;


endsection;