1/* -*- Mode: c++ -*-
2 *  $Id: xotclMetaData.c,v 1.5 2006/09/27 08:12:40 neumann Exp $
3 *
4 *  Extended Object Tcl (XOTcl)
5 *
6 *  Copyright (C) 1999-2008 Gustaf Neumann, Uwe Zdun
7 *
8 *
9 *  xotclReference.c --
10 *
11 *  XOTcl Object References
12 *
13 */
14
15#include "xotclInt.h"
16
17#ifdef XOTCL_METADATA
18/*
19 * Meta Data
20 */
21
22void
23XOTclMetaDataRemoveDepending(XOTclClass *cl, char *name) {
24  XOTclClasses *saved = cl->order, *clPtr;
25  cl->order = 0;
26
27  clPtr = XOTclComputeDependents(cl);
28
29  while (clPtr != 0) {
30      Tcl_HashSearch hSrch;
31      Tcl_HashEntry *hPtr = &clPtr->cl->instances ?
32	Tcl_FirstHashEntry(&clPtr->cl->instances, &hSrch) : 0;
33      for (; hPtr != 0; hPtr = Tcl_NextHashEntry(&hSrch)) {
34	  XOTclObject *obj = (XOTclObject*)
35	    Tcl_GetHashKey(&clPtr->cl->instances, hPtr);
36	  Tcl_HashEntry *h1Ptr = 0;
37	  if (obj->opt)
38	    h1Ptr = Tcl_FindHashEntry(&obj->opt->metaData, name);
39	  if (h1Ptr) {
40	      Tcl_DeleteHashEntry(h1Ptr);
41	  }
42      }
43      clPtr = clPtr->next;
44  }
45
46  XOTclRemoveClasses(cl->order);
47  cl->order = saved;
48}
49
50int
51XOTclMetaDataInheritance (XOTclObject *obj, char *name) {
52  XOTclClasses *clPtr;
53  assert(obj);
54
55  if (!obj->cl->order)
56    obj->cl->order = XOTclComputePrecedence(obj->cl);
57  clPtr = obj->cl->order;
58  if (clPtr) {
59    while (clPtr != 0) {
60      if (clPtr->cl->object.opt) {
61	if (Tcl_FindHashEntry(&clPtr->cl->object.opt->metaData, name)) {
62	  return 1;
63	}
64      }
65      clPtr = clPtr->next;
66    }
67  }
68  return 0;
69}
70
71void
72XOTclMetaDataDestroy(XOTclObject *obj) {
73  if (obj->opt)
74    Tcl_DeleteHashTable(&obj->opt->metaData);
75}
76
77void
78XOTclMetaDataInit(XOTclObject *obj) {
79  XOTclRequireObjectOpt(obj);
80  Tcl_InitHashTable(&obj->opt->metaData, TCL_STRING_KEYS);
81}
82
83int
84XOTclOMetaDataMethod (ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
85  XOTclObject *obj = (XOTclObject*)cd;
86  XOTclClass  *cl  = XOTclObjectToClass(cd);
87  char *option; int add = -1;
88  int result = TCL_OK;
89  int oc; Tcl_Obj* *ov; int i;
90
91  if (!obj) return XOTclObjErrType(interp, obj->cmdName, "Object");
92  if (objc < 2)
93    return XOTclObjErrArgCnt(interp,obj->cmdName,
94				  "metadata ?(add|remove)? metaDataList");
95
96  option = ObjStr(objv[1]);
97  switch (*option) {
98  case 'a':
99    if (strcmp(option,"add") == 0) add = 1; break;
100  case 'r':
101    if (strcmp(option,"remove") == 0) add = 0; break;
102  }
103  if (add == -1) {
104    if (objc == 2) {
105      if (obj->opt) {
106	Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&obj->opt->metaData, option);
107	if (hPtr) {
108	  Tcl_Obj *entry = (Tcl_Obj *) Tcl_GetHashValue(hPtr);
109	  if (entry) {
110	    Tcl_SetObjResult(interp, (Tcl_Obj *) Tcl_GetHashValue(hPtr));
111	  } else {
112	    Tcl_ResetResult(interp);
113	  }
114	}
115	return TCL_OK;
116      }
117    }
118    if (objc == 3) {
119      if (obj->opt) {
120	Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&obj->opt->metaData, option);
121	if (!hPtr) {
122	  int nw;
123	  if (XOTclMetaDataInheritance(obj, option)) {
124	    hPtr = Tcl_CreateHashEntry(&obj->opt->metaData, option, &nw);
125	    if (!nw)
126	      return XOTclVarErrMsg(interp,
127				    "MetaData: Can't create MetaData Entry: ",
128				    option, (char*) NULL);
129	  }
130	}
131	if (hPtr) {
132	  Tcl_Obj *entry = (Tcl_Obj *) Tcl_GetHashValue(hPtr);
133	  if (entry)
134	    DECR_REF_COUNT(entry);
135	  INCR_REF_COUNT(objv[2]);
136	  Tcl_SetHashValue(hPtr, (ClientData) objv[2]);
137	  return TCL_OK;
138	}
139      }
140    }
141    return XOTclVarErrMsg(interp,"MetaData: Unknown option;  given Option: ",
142			  option, (char*) NULL);
143  }
144
145  if (Tcl_ListObjGetElements(interp, objv[2], &oc, &ov) == TCL_OK) {
146    for (i = 0; i < oc; i ++) {
147      char *value = ObjStr (ov[i]);
148      if (obj->opt) {
149	if (add) {
150	  int nw;
151	  Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&obj->opt->metaData, value);
152	  if (hPtr)
153	    return XOTclVarErrMsg(interp,
154				  "Can't add MetaData, MetaData exists: ",
155				  value,
156				  (char*) NULL);
157	  hPtr = Tcl_CreateHashEntry(&obj->opt->metaData, value, &nw);
158	  if (!nw)
159	    return XOTclVarErrMsg(interp,
160				  "MetaData: Can't create MetaData Entry: ",
161				  value,(char*) NULL);
162	} else {
163	  Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&obj->opt->metaData, value);
164	  if (hPtr) {
165	    Tcl_DeleteHashEntry(hPtr);
166	    if (cl) {
167	      XOTclMetaDataRemoveDepending(cl, value);
168	    }
169	  }
170	}
171      }
172    }
173  }
174  return result;
175}
176#endif
177