> 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;
|