1# treec.tcl --
2#
3#       Implementation of a tree data structure for Tcl.
4#       This code based on critcl, API compatible to the PTI [x].
5#       [x] Pure Tcl Implementation.
6#
7# Copyright (c) 2005 Andreas Kupries <andreas_kupries@users.sourceforge.net>
8#
9# See the file "license.terms" for information on usage and redistribution
10# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
11#
12# RCS: @(#) $Id: tree_c.tcl,v 1.6 2008/03/25 07:15:34 andreas_kupries Exp $
13
14package require critcl
15# @sak notprovided struct_treec
16package provide struct_treec 2.1.1
17package require Tcl 8.2
18
19namespace eval ::struct {
20    # Supporting code for the main command.
21
22    catch {
23	#critcl::cheaders -g
24	#critcl::debug memory symbols
25    }
26
27    critcl::cheaders tree/*.h
28    critcl::csources tree/*.c
29
30    critcl::ccode {
31	/* -*- c -*- */
32
33	#include <util.h>
34	#include <t.h>
35	#include <tn.h>
36	#include <ms.h>
37	#include <m.h>
38
39	/* .................................................. */
40	/* Global tree management, per interp
41	*/
42
43	typedef struct TDg {
44	    long int counter;
45	    char buf [50];
46	} TDg;
47
48	static void
49	TDgrelease (ClientData cd, Tcl_Interp* interp)
50	{
51	    ckfree((char*) cd);
52	}
53
54	static CONST char*
55	TDnewName (Tcl_Interp* interp)
56	{
57#define KEY "tcllib/struct::tree/critcl"
58
59	    Tcl_InterpDeleteProc* proc = TDgrelease;
60	    TDg*                  tdg;
61
62	    tdg = Tcl_GetAssocData (interp, KEY, &proc);
63	    if (tdg  == NULL) {
64		tdg = (TDg*) ckalloc (sizeof (TDg));
65		tdg->counter = 0;
66
67		Tcl_SetAssocData (interp, KEY, proc,
68				  (ClientData) tdg);
69	    }
70
71	    tdg->counter ++;
72	    sprintf (tdg->buf, "tree%d", tdg->counter);
73	    return tdg->buf;
74
75#undef  KEY
76	}
77
78	static void
79	TDdeleteCmd (ClientData clientData)
80	{
81	    /* Release the whole tree. */
82	    t_delete ((T*) clientData);
83	}
84    }
85
86    # Main command, tree creation.
87
88    critcl::ccommand tree_critcl {dummy interp objc objv} {
89      /* Syntax
90       *  - epsilon                         |1
91       *  - name                            |2
92       *  - name =|:=|as|deserialize source |4
93       */
94
95      CONST char* name;
96      T*          td;
97      Tcl_Obj*    fqn;
98      Tcl_CmdInfo ci;
99
100#define USAGE "?name ?=|:=|as|deserialize source??"
101
102      if ((objc != 4) && (objc != 2) && (objc != 1)) {
103        Tcl_WrongNumArgs (interp, 1, objv, USAGE);
104        return TCL_ERROR;
105      }
106
107      if (objc < 2) {
108        name = TDnewName (interp);
109      } else {
110        name = Tcl_GetString (objv [1]);
111      }
112
113      if (!Tcl_StringMatch (name, "::*")) {
114        /* Relative name. Prefix with current namespace */
115
116        Tcl_Eval (interp, "namespace current");
117        fqn = Tcl_GetObjResult (interp);
118        fqn = Tcl_DuplicateObj (fqn);
119        Tcl_IncrRefCount (fqn);
120
121        if (!Tcl_StringMatch (Tcl_GetString (fqn), "::")) {
122          Tcl_AppendToObj (fqn, "::", -1);
123        }
124        Tcl_AppendToObj (fqn, name, -1);
125      } else {
126        fqn = Tcl_NewStringObj (name, -1);
127        Tcl_IncrRefCount (fqn);
128      }
129      Tcl_ResetResult (interp);
130
131      if (Tcl_GetCommandInfo (interp,
132                              Tcl_GetString (fqn),
133                              &ci)) {
134        Tcl_Obj* err;
135
136        err = Tcl_NewObj ();
137        Tcl_AppendToObj    (err, "command \"", -1);
138        Tcl_AppendObjToObj (err, fqn);
139        Tcl_AppendToObj    (err, "\" already exists, unable to create tree", -1);
140
141        Tcl_DecrRefCount (fqn);
142        Tcl_SetObjResult (interp, err);
143        return TCL_ERROR;
144      }
145
146      if (objc == 4) {
147        Tcl_Obj* type = objv[2];
148        Tcl_Obj* src  = objv[3];
149        int srctype;
150
151        static CONST char* types [] = {
152          ":=", "=", "as", "deserialize", NULL
153        };
154        enum types {
155          T_ASSIGN, T_IS, T_AS, T_DESER
156        };
157
158        if (Tcl_GetIndexFromObj (interp, type, types, "type",
159                                 0, &srctype) != TCL_OK) {
160          Tcl_DecrRefCount (fqn);
161          Tcl_ResetResult (interp);
162          Tcl_WrongNumArgs (interp, 1, objv, USAGE);
163          return TCL_ERROR;
164        }
165
166        td = t_new ();
167
168        switch (srctype) {
169        case T_ASSIGN:
170        case T_AS:
171        case T_IS:
172          if (tms_assign (interp, td, src) != TCL_OK) {
173            t_delete (td);
174            Tcl_DecrRefCount (fqn);
175            return TCL_ERROR;
176          }
177          break;
178
179        case T_DESER:
180          if (t_deserialize (td, interp, src) != TCL_OK) {
181            t_delete (td);
182            Tcl_DecrRefCount (fqn);
183            return TCL_ERROR;
184          }
185          break;
186        }
187      } else {
188        td = t_new ();
189      }
190
191      td->cmd = Tcl_CreateObjCommand (interp, Tcl_GetString (fqn),
192                                      tms_objcmd, (ClientData) td,
193                                      TDdeleteCmd);
194
195      Tcl_SetObjResult (interp, fqn);
196      Tcl_DecrRefCount (fqn);
197      return TCL_OK;
198    }
199
200  namespace eval tree {
201    critcl::ccommand prune_critcl {dummy interp objc objv} {
202      return 5;
203    }
204  }
205}
206
207# ### ### ### ######### ######### #########
208## Ready
209