source: tol/toltcl/generic/tolaccess.cpp @ 3475b98

1941-docker-image-to-testdevel
Last change on this file since 3475b98 was 3475b98, checked in by Jorge Pérez <josp.jorge@…>, 18 years ago

merging from branch NameBlock

git-svn-id: ​https://www.tol-project.org/svn/tolp/trunk@654 be4846ae-f051-483a-831f-b64e7d08527f
  • Property mode set to 100644
File size: 60.0 KB
Line 
1/* tolaccess.cpp: This file implements an interface between object in tol
2                  and "objects" in tclThis file define a set of utils
3                  functions.
4                  GNU/tolTcl Library
5
6   Copyright (C) 2001, 2002, 2003 - Bayes Decisión, SL
7
8   This program is free software; you can redistribute it and/or modify
9   it under the terms of the GNU General Public License as published by
10   the Free Software Foundation; either version 2, or (at your option)
11   any later version.
12
13   This program is distributed in the hope that it will be useful,
14   but WITHOUT ANY WARRANTY; without even the implied warranty of
15   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16   GNU General Public License for more details.
17
18   You should have received a copy of the GNU General Public License
19   along with this program; if not, write to the Free Software
20   Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
21   USA.
22 */
23
24#include <ctype.h>
25
26#if defined(_MSC_VER)
27#  include <win_tolinc.h>
28#endif
29
30#include <tol/tol_init.h>
31#include <tol/tol_version_def.h>
32#include <tol/tol_bcommon.h>
33#include <tol/tol_bstruct.h>
34#include <tol/tol_blanguag.h>
35#include <tol/tol_bmatgra.h>
36#include <tol/tol_bvmatgra.h>
37#include <tol/tol_bnameblock.h>
38#include <tol/tol_bspfun.h>
39#include <tol/tol_bcodgra.h>
40#include <tol/tol_bsetgra.h>
41#include <tol/tol_btsrgra.h>
42#include <tol/tol_btxtgra.h>
43#include <tol/tol_bmethodhook.h>
44
45#include <toltclInt.h>
46#include <tt_pool.h>
47
48
49/*
50 * if SyntaxObject has IsFile implemented, uncomment the following
51 * define:
52 */
53
54/* #define ISFILE_IMPLEMENTED */
55
56typedef void (* getmethod)( const BSyntaxObject *, BText & );
57typedef int  (* checkmethod)( const BSyntaxObject * );
58
59static
60int QuickSort( Tcl_Interp * interp, Tcl_Obj * list );
61
62inline
63char * skipWhite(char * pch)
64{
65  while (*pch && isspace(*pch))
66    ++pch;
67  return pch;
68}
69
70static
71BText GetObjectName(const BSyntaxObject * so)
72{
73  return so->HasName() ? so->FullName() : so->LocalName();
74}
75
76static
77void GetName( const BSyntaxObject * so, BText & res )
78{
79  res = so->FullName();
80}
81
82static
83void GetIdentify( const BSyntaxObject * so, BText & res )
84{
85  res = so->Identify();
86}
87
88static
89void GetPath( const BSyntaxObject * so, BText & res )
90{
91  res = so->TolPath();
92}
93
94static
95int
96ExcludeAnything( const BSyntaxObject * so )
97{
98  return so != GraAnything();
99}
100
101static
102int HasNoSource( const BSyntaxObject * so )
103{
104  return !so->Source();
105}
106
107static
108int BList2TclList( Tcl_Interp * interp,
109                   BList * blist, Tcl_Obj * tcl_list,
110                   getmethod m, checkmethod accept = NULL)
111{
112  char * str;
113  Tcl_Obj * name;
114  Tcl_DString dstr;
115  BText tmp;
116
117  while(blist)
118  {
119    BSyntaxObject* so = (BSyntaxObject*)Car(blist);
120    if(!accept || (*accept)(so))
121    {
122      (*m)(so,tmp);
123      str = Tcl_ExternalToUtfDString(NULL,tmp,-1,&dstr);
124      name = Tcl_NewStringObj(str,-1);
125      Tcl_DStringFree(&dstr);
126      if ( Tcl_ListObjAppendElement(interp, tcl_list, name) != TCL_OK ) {
127        Tcl_DecrRefCount(name);
128        return TCL_ERROR;
129      }
130    }
131    blist = Cdr(blist);
132  }
133  return TCL_OK;
134}
135
136/*
137 * Fill in obj_result the result of avaluating in TOL the given
138 * string.
139 *
140 */
141
142/* cdr of console_stack point to first item */
143static BList console_stack;
144// Read only stack
145static BList console_stack_hidden;
146
147static
148void my_concat(BList* head, BList* tail)
149{
150  if (head->Cdr()) {
151    my_concat(head->Cdr(), tail);
152  } else {
153    head->PutCdr(tail);
154  }
155}
156
157int Tol_EvalExpr (Tcl_Obj * obj_expr, int hidden, Tcl_Obj * obj_result)
158{
159  BList * tol_result;
160  Tcl_DString dstr;
161  char * expr;
162 
163  Tcl_DStringInit(&dstr);
164  expr = Tcl_UtfToExternalDString(NULL,Tcl_GetString(obj_expr),-1,&dstr);
165  tol_result = MultyEvaluate(expr);
166  Tcl_DStringFree(&dstr);
167  if(tol_result) {
168    my_concat(hidden?&console_stack_hidden:&console_stack, tol_result);
169  }
170  /*  Tcl_AppendStringsToObj(obj_result,
171      "couldn't evaluate tol expresion \"",
172      Tcl_GetString(obj_expr), "\"", NULL);
173      return TCL_ERROR;*/
174  return TCL_OK;
175}
176
177int Tol_GetStructure( Tcl_Interp * interp, Tcl_Obj * name, Tcl_Obj * obj_result )
178{
179  Tcl_DString dstr;
180  BStruct * structure;
181  BStruct * substruct;
182
183  Tcl_DStringInit( &dstr );
184  Tcl_UtfToExternalDString( NULL, Tcl_GetString(name), -1, &dstr );
185  if ( Tcl_DStringLength( &dstr ) &&
186       (structure = FindStruct(Tcl_DStringValue(&dstr)))) {
187   
188    Tcl_Obj * tmp[2];
189    Tcl_Obj * info[2];
190    Tcl_Obj ** fields;
191    BText btxt;
192    int nfields;
193   
194    nfields = structure->Size();
195    fields = (Tcl_Obj**)Tcl_Alloc( sizeof(Tcl_Obj*) * nfields );
196    for ( int i = 0; i < nfields; i++ ) {
197      BField & field = (*structure)[i];
198      btxt = field.Name();
199      Tcl_DStringFree(&dstr);
200      Tcl_ExternalToUtfDString( NULL, btxt, -1, &dstr );
201      info[0] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
202      Tcl_DStringFree( &dstr );
203      if ( (substruct = field.Struct()) ) {
204        btxt = substruct->Name();
205        Tcl_ExternalToUtfDString( NULL, btxt, -1, &dstr );
206        tmp[0] = Tcl_NewStringObj( "STRUCT", 6 );
207        tmp[1] = Tcl_NewStringObj( Tcl_DStringValue(&dstr), -1);
208        info[1] = Tcl_NewListObj( 2, tmp );
209      } else if ( field.Grammar() ) {
210        btxt = field.Grammar()->Name();
211        Tcl_ExternalToUtfDString( NULL, btxt, -1, &dstr );
212        info[1] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
213      }
214      fields[i] = Tcl_NewListObj(2,info);
215    }
216    Tcl_SetListObj( obj_result, nfields, fields );
217    Tcl_Free( (char*)fields );
218  }
219  return TCL_OK;
220}
221
222BSet* ContainerGetSet(const BSyntaxObject *container)
223{
224  if (container) {
225    if (container->Grammar()==GraSet())
226      return &(((BUserSet*)container)->Contens());
227    else if (container->Grammar()==GraNameBlock())
228      return &(((BUserNameBlock*)container)->Contens().Set());
229  }
230  return NULL;
231}
232 
233/*
234 * Return the path of a set if it is a file, trigger an error in other case
235 *
236 */
237
238int Tol_GetSetPath( Tcl_Interp * interp, Tcl_Obj * name, Tcl_Obj * obj_result )
239{
240  Tcl_DString uniBuffer;
241  const BSyntaxObject * syn;
242
243 /* if name contains spaces the we should try it first as a string */
244  Tcl_DStringInit(&uniBuffer);
245  Tcl_UtfToExternalDString(NULL,Tcl_GetString(name),-1,&uniBuffer);
246  BText fname(Tcl_DStringValue(&uniBuffer));
247  syn = (BSyntaxObject*)BSetFromFile::FindCompiled(fname);
248  Tcl_DStringFree(&uniBuffer);
249  if (!syn) {
250    syn = Tol_ResolveObject(interp, name, obj_result);
251  }
252  if ( !syn )
253    return TCL_ERROR;
254  BSet *ptrSet = ContainerGetSet(syn);
255  if ( ptrSet->SubType() >= BSet::MODFile && ptrSet->SubType() <= BSet::BMIFile ) {
256    Tcl_DString dstr;
257    BText path( syn->TolPath() );
258
259    Tcl_DStringInit( &dstr );
260    Tcl_ExternalToUtfDString(NULL,path,-1,&dstr);
261    Tcl_SetStringObj( obj_result, Tcl_DStringValue(&dstr), -1 );
262    return TCL_OK;
263  } else {
264    Tcl_AppendStringsToObj( obj_result, Tcl_GetString(name),
265                            " is not a valid file object", NULL );
266    return TCL_ERROR;
267  }
268}
269
270/*
271 * Fill in obj_result the content of the given tol object's names. The
272 * object are searched in the console's stack.
273 *
274 * Return:
275 *
276 *   {GRAMMAR NAME CONTENT PATH DESCRIPTION ISFILE [Has SubSet? SUBTYPE STRUCTURE]}
277 */
278
279int Tol_ListStack(Tcl_Interp * interp,int objc,Tcl_Obj *CONST objv[],
280                  Tcl_Obj * obj_result)
281{
282  BSyntaxObject * so;
283  BText btxt;
284  Tcl_DString dstr;
285  BList * tol_item;
286  Tcl_Obj * robjv[9];
287  int robjc;
288  Tcl_Obj * tcl_item;
289  int tcl_result;
290  BSet * ptrSet = 0;
291  int tmpCard;
292  int j;
293 
294  Tcl_DStringInit(&dstr);
295 
296  tol_item = console_stack.Cdr();
297  while (tol_item) {
298    so = (BSyntaxObject*)Car(tol_item);
299   
300    /* GRAMMAR NAME */
301    btxt = so->Grammar()->Name();
302    Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
303    robjv[0] = Tcl_NewStringObj(Tcl_DStringValue(&dstr),-1);
304    Tcl_DStringFree(&dstr);
305   
306    /* OBJECT NAME */
307//  btxt = so->Identify();
308    GetName( so, btxt );
309    Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
310    robjv[1] = Tcl_NewStringObj(Tcl_DStringValue(&dstr),-1);
311    Tcl_DStringFree(&dstr);
312   
313    /* OBJECT CONTENT */
314    btxt = so->Info();
315    Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
316    robjv[2] = Tcl_NewStringObj(Tcl_DStringValue(&dstr),-1);
317    Tcl_DStringFree(&dstr);
318   
319    /* OBJECT PATH */
320    btxt = so->SourcePath();
321    Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
322    robjv[3] = Tcl_NewStringObj(Tcl_DStringValue(&dstr),-1);
323    Tcl_DStringFree(&dstr);
324   
325    /* OBJECT DESCRIPTION */
326    btxt = so->Description();
327    Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
328    robjv[4] = Tcl_NewStringObj(Tcl_DStringValue(&dstr),-1);
329    Tcl_DStringFree(&dstr);
330   
331    /* IS THE OBJECT A FILE? */
332    robjv[5] = Tcl_NewIntObj(so->IsFile());
333////    if ( so->Grammar()==GraSet() ) {
334    if ( so->Grammar()==GraSet() || so->Grammar()==GraNameBlock()) {
335      /* HAS SUBSET */
336////      ptrSet = &(((BUserSet*)so)->Contens());
337      ptrSet = ContainerGetSet(so);
338      tmpCard = ptrSet->Card();
339      for (j=1; j<=tmpCard; ++j )
340        if ( (*ptrSet)[j]->Grammar()==GraSet() )
341          break;
342      robjv[6] = Tcl_NewIntObj(j<=tmpCard);
343       
344      /* SUBTYPE INFO */
345      robjv[7] = Tcl_NewIntObj( ptrSet->SubType() );
346       
347      /* STRUCT INFO */
348      if ( ptrSet->Struct() ) {
349        btxt = ptrSet->Struct()->Name();
350        Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
351        robjv[8] = Tcl_NewStringObj( Tcl_DStringValue(&dstr), -1 );
352        Tcl_DStringFree( &dstr );
353      } else
354        robjv[8] = Tcl_NewStringObj( NULL, 0 );
355      robjc = 9;
356    } else
357      robjc = 6;
358   
359    /* build the tcl item as a list */
360    tcl_item = Tcl_NewListObj(robjc,robjv);
361   
362    /* append to the end of the result */
363    tcl_result = Tcl_ListObjAppendElement(interp,obj_result,tcl_item);
364    if (tcl_result != TCL_OK) {
365      Tcl_SetStringObj(obj_result,"",-1);
366      Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
367      return TCL_ERROR;
368    }
369    tol_item = Cdr(tol_item);
370  }
371  return TCL_OK;
372}
373
374struct tcl_info_t
375{
376  Tcl_Interp *interp;
377  int objc;
378  Tcl_Obj* CONST* objv;
379  Tcl_DString &dstr;
380};
381
382/*
383 * Tol_ReleaseStack --
384 *
385 * Recursive version in order to release stack in reverse order
386 *
387 * Preconditions:
388 *
389 *   P != NULL
390 */
391static
392int Tol_ReleaseStack(tcl_info_t &info, BList *P)
393{
394  int result;
395 
396  assert(P != NULL);
397
398  if (P->Cdr()) {
399    /* keep on looking for rest of items */
400    result = Tol_ReleaseStack(info, P->Cdr());
401    /* process this item */
402    BList *current = P->Cdr();
403    BSyntaxObject * so;
404    int i;
405    so = (BSyntaxObject*)(current->Car());
406    if (info.objc) {
407      const char* name = so->Name().String();
408      for (i = 0; i<info.objc; ++i) {
409        Tcl_UtfToExternalDString(NULL,Tcl_GetString(info.objv[i]),-1,
410                                 &info.dstr);
411        if (!strcmp(Tcl_DStringValue(&info.dstr), name)) {
412          Tcl_DStringFree(&info.dstr);
413          break;
414        }
415        Tcl_DStringFree(&info.dstr);
416      }
417    } else {
418      /* mark current as being found */
419      i = -1;
420    }
421    if (i<info.objc) {
422      BList *next = current->Cdr();
423      /* delete will DecNRefs to the Car */
424      delete current;
425      /* now try to release the BSyntaxObject */
426      DESTROY(so);
427      /* chain the list */
428      P->PutCdr(next);
429    }
430  } else {
431    /* EOR */
432    result = TCL_OK;
433  }
434  return result;
435}
436
437int Tol_ReleaseStack(Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[],
438                     Tcl_Obj * obj_result)
439{
440  Tcl_DString dstr;
441  tcl_info_t tcl_info = {interp, objc, objv, dstr};
442  Tcl_DStringInit(&dstr);
443
444  return Tol_ReleaseStack(tcl_info, &console_stack);
445}
446
447/*!
448 * Tol_GetConsoleObject --
449 *
450 *     Returns the object with given index in the console object list.
451 */
452BSyntaxObject * Tol_GetConsoleObject(int index )
453{
454  BList * current = console_stack.Cdr();
455  int i = 1;
456  while (current) {
457    if (i==index) break;
458    current = Cdr(current);
459    ++i;
460  }
461  return current ? (BSyntaxObject*)(current->Car()) : NULL;
462}
463
464
465/*
466 * return the container (File, Set or NameBlock) with name obj_name,
467 * in case of error return NULL and leave a description in
468 * obj_result.
469 *
470 */
471const BSyntaxObject * Tol_FindGlobalContainer(const char* Type,
472                                              const char* obj_name,
473                                              Tcl_Obj*    obj_result)
474{
475  BGrammar *gra;
476  BSyntaxObject* var;
477  Tcl_DString uniBuffer;
478
479  if (!strcmp(Type, "Set"))
480    gra = GraSet();
481  else if (!strcmp(Type, "NameBlock"))
482    gra = GraNameBlock();
483  else if (!strcmp(Type, "File"))
484    gra = NULL;
485  else {
486    Tcl_AppendStringsToObj(obj_result,"type '",
487                           Type,
488                           "' is not a container grammar", NULL );
489    return NULL;
490  }
491  Tcl_DStringInit(&uniBuffer);
492  Tcl_UtfToExternalDString(NULL,obj_name,-1,&uniBuffer);
493  if (!gra) {
494    /* should look in Files */
495    BText fname(Tcl_DStringValue(&uniBuffer));
496    if (!(var=(BSyntaxObject*)BSetFromFile::FindCompiled(fname))) {
497      Tcl_AppendStringsToObj(obj_result,"file \"",
498                             obj_name,
499                             "\" is not included", NULL );
500    }
501  } else if (!(var=gra->FINDVARIABLE(Tcl_DStringValue(&uniBuffer)))) {
502      Tcl_AppendStringsToObj(obj_result,"\"",
503                             obj_name,
504                             "\" isn't a ", Type, " variable", NULL );
505  }
506  Tcl_DStringFree(&uniBuffer);
507  return var;
508}
509
510/*
511 * given a tol set, returns its child corresponding to the set of
512 * indexes indexes of size n.  In case of error return NULL and leave
513 * a description in obj_result.
514 *
515 */
516
517const BSyntaxObject * Tol_FindChild(Tcl_Interp    *interp,
518                                    const BSyntaxObject *syn_obj,
519                                    Tcl_Obj       **indexes, int n,
520                                    Tcl_Obj       *obj_result)
521{
522  int tcl_code;
523  Tcl_DString dstr;
524  BSet *container;
525  int idx, card;
526  int i;
527
528  for (i=0; i<n; ++i) {
529    if (!(container = ContainerGetSet(syn_obj))) {
530      BText info(syn_obj->Info());
531      Tcl_DStringInit(&dstr);
532      Tcl_ExternalToUtfDString(NULL,info,-1,&dstr);
533      Tcl_AppendStringsToObj(obj_result,"object \"",
534                             Tcl_DStringValue(&dstr),
535                             "\" is not a container",
536                             NULL);
537      Tcl_DStringFree(&dstr);
538      break;
539    }
540    /* get the current object index */
541    tcl_code = Tcl_GetIntFromObj(interp,indexes[i],&idx);
542    if (tcl_code != TCL_OK) {
543      Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
544      break;
545    }
546    card = container->Card();
547    if (idx<1 || idx>card) {
548      Tcl_AppendStringsToObj(obj_result,
549                             "index '",
550                             Tcl_GetString(indexes[i]),
551                             "' out of range",
552                             NULL);
553      break;
554    }
555    /* take the next object in the list */
556    syn_obj = (*container)[idx];
557  }
558  return i == n ? syn_obj : NULL;
559}
560
561/*!
562 *  Tol_ResolveObject --
563 *
564 *     Resolve a SyntaxObject given a toltcl object reference. A
565 *     reference is {TYPE ?container? i1 i2 ... in} or a global
566 *     container's name of type File|Set|NameBlock|Console. When TYPE
567 *     is Console then container is not given. The grammar of the
568 *     object found is matched to the given argument grammar. If the
569 *     return value is NULL an error message is left in interp.
570 */
571
572const BSyntaxObject * Tol_ResolveObject(Tcl_Interp *interp,
573                                        Tcl_Obj    *obj_ref,
574                                        Tcl_Obj    *obj_result)
575{
576  Tcl_Obj ** items;
577  int n;
578  int tcl_code;
579  char * type;
580
581  /* look for subitem given in obj_ref */
582  tcl_code = Tcl_ListObjGetElements(interp, obj_ref, &n, &items);
583  if (tcl_code != TCL_OK) {
584    Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
585    return NULL;
586  }
587
588  // this Tcl_Obj is to leave error messages
589  const BSyntaxObject * syn = NULL;
590
591  if (n >= 2) {
592    type = Tcl_GetString(items[0]);
593    if (!strcmp(type,"Console") || !strcmp(type,"File") ||
594        !strcmp(type,"Set") || !strcmp(type,"NameBlock") ) {
595      if (!strcmp(type,"Console")) {
596        // is a reference in the console, items[1] is the first index in
597        // the path, following indexes are indexes withing containers.
598        int i1;
599        if ((tcl_code = Tcl_GetIntFromObj(interp,items[1],&i1)!=TCL_OK)) {
600          Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
601          return NULL;
602        }
603        if (!(syn=Tol_GetConsoleObject(i1))) {
604          Tcl_AppendStringsToObj(obj_result, "index ",
605                                 Tcl_GetString(items[1]),
606                                 " not found in console", NULL);
607          return NULL;
608        }
609      } else {
610      /* should be File, Set or NameBlock, it is a hierarchical container */
611        if (!(syn=Tol_FindGlobalContainer(Tcl_GetString(items[0]),
612                                          Tcl_GetString(items[1]),
613                                          obj_result))) {
614          return NULL;
615        }
616      }
617      assert(syn);
618      if (n>2) {
619        // there are more indexes & syn should be a Container
620        if (!(syn=Tol_FindChild(interp,
621                                syn, items+2, n-2, obj_result))) {
622          return NULL;
623        }
624      }
625    } else {
626      if (n==2) {
627        // look global var in grammar
628        BGrammar * gra;
629        gra = BGrammar::FindByName(type);
630        if (!gra) {
631          Tcl_AppendStringsToObj(obj_result, "\"",
632                                                   type,
633                                                   "\" isn't a grammar", NULL);
634          return NULL;
635        }
636        Tcl_DString dstr;
637        Tcl_DStringInit(&dstr);
638        Tcl_UtfToExternalDString(NULL,Tcl_GetString(items[1]),-1,&dstr);
639        if (!(syn = gra->FINDVARIABLE(Tcl_DStringValue(&dstr))))
640          Tcl_AppendStringsToObj(obj_result, "variable '",
641                                 obj_ref, "' not found in grammar '",
642                                 gra->Name().String(), "'", NULL);
643        Tcl_DStringFree(&dstr);
644        /* found and matched */
645        return syn;
646      }
647    }
648  } else {
649      Tcl_AppendStringsToObj(obj_result,
650                             "incorrect object reference in ResolveObject",
651                             NULL);
652  }
653/*  if (grammar && syn && syn->Grammar()!=grammar) {
654    Tcl_AppendStringsToObj(obj_result, "grammar for object '",
655                           Tcl_GetString(obj_ref),
656                           "' does not match grammar '",
657                           grammar->Name().String(), "'", NULL);
658    syn = NULL;
659  }
660*/
661  return syn;
662}
663
664int Tol_FindSOInSet(BSet * ptrSet, const BSyntaxObject * syn,
665                    ToltclPool & indexes)
666{
667  int j;
668  const BSyntaxObject * so;
669 
670  for (j = 1; j <= ptrSet->Card(); j++) {
671    so = (*ptrSet)[j];
672    BSet *ptrSet;
673    if (so == syn || ((ptrSet=ContainerGetSet(so)) &&
674                      Tol_FindSOInSet(ptrSet,
675                                      syn, indexes))) {
676      /* found!!! */
677      indexes.AppendObject((void*)j);     
678      return 1;
679    }
680  }
681
682  return 0;
683}
684 
685/*
686 *  Puts in obj_result the global reference of the given
687 *  syntaxobject. The syntaxobject could be given as set member or as
688 *  global variable. In case of error leave in obj_result the message.
689 *  Returns TCL_OK if succesfull or TCL_ERROR in case of error.
690 */
691
692int Tol_GetReference(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[],
693                     Tcl_Obj * obj_result)
694{
695  Tcl_Obj ** items;
696  int n;
697  int tcl_code;
698  const BSyntaxObject * source, * syn;
699  BSet * ptrSet;
700  ToltclPool indexes;
701  Tcl_DString dstr;
702  int j;
703  char * graname, * objname;
704
705  assert(!Tcl_IsShared(obj_result));
706  tcl_code = Tcl_ListObjGetElements(interp,objv[0],&n,&items);
707  assert(tcl_code == TCL_OK);
708  if (n<2) {
709    Tcl_AppendStringsToObj(obj_result,
710                           "wrong # args: should be 'tol::info",
711                           " reference {grammar|container objname ?indexes?}'",
712                           NULL);
713    return TCL_ERROR;   
714  }
715  if (n==2 && strcmp(Tcl_GetString(items[0]),"Console")) {
716  // global access
717    BGrammar * gra;
718    graname = Tcl_GetString(items[0]);
719    gra = BGrammar::FindByName(graname);
720    if (!gra) {
721      Tcl_AppendStringsToObj( obj_result, "\"",
722                              graname,
723                              "\" isn't a grammar", NULL);
724      return TCL_ERROR;
725    }
726    objname = Tcl_GetString(items[1]);
727    Tcl_UtfToExternalDString(NULL,objname,-1,&dstr);
728    syn = gra->FINDVARIABLE(Tcl_DStringValue(&dstr));
729    Tcl_DStringFree(&dstr);
730    if (!syn) {
731      Tcl_AppendStringsToObj(obj_result, "\"",
732                             Tcl_GetString(items[1]),
733                             "\" isn't a variable in grammar ",
734                             graname, NULL);
735      return TCL_ERROR;
736    }
737    source = syn->Source();
738    if (!source) {
739      /* is a global variable not defined inside a file */
740      items = (Tcl_Obj**)Tcl_Alloc(sizeof(Tcl_Obj*) * 2);
741      Tcl_ExternalToUtfDString(NULL, graname, -1, &dstr);
742      items[0] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
743      Tcl_DStringFree(&dstr);
744      Tcl_ExternalToUtfDString(NULL, objname, -1, &dstr);
745      items[1] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
746      Tcl_DStringFree(&dstr);
747      Tcl_SetListObj(obj_result, 2, items);
748      Tcl_Free((char*)items);
749      return TCL_OK;
750    }
751  } else {
752    // member access
753    if (!(syn=Tol_ResolveObject(interp,objv[0],obj_result))) {
754      return TCL_ERROR;
755    }
756    /* here we have a valid reference */
757    tcl_code = Tcl_ListObjGetElements(interp,objv[0],&n,&items);
758    assert(tcl_code == TCL_OK);
759    if (!strcmp(Tcl_GetString(items[0]),"File") ||
760        !strcmp(Tcl_GetString(items[0]),"Console")) {
761      /* here we have in objv[0] the answer */
762      Tcl_SetListObj(obj_result, n, items);
763      return TCL_OK;     
764    }
765    source = syn->Source();
766    if (!source) {
767      /* here we have in objv[0] the answer too */
768      Tcl_SetListObj(obj_result, n, items);
769      return TCL_OK;
770    }
771  }
772  /* at this point variable has to be defined inside a file */
773  assert(source);
774  ptrSet = &(((BUserSet*)source)->Contens());
775  if (Tol_FindSOInSet(ptrSet, syn, indexes)) {
776    items = (Tcl_Obj**)Tcl_Alloc(sizeof(Tcl_Obj*) * (indexes.GetSize()+2));
777    Tcl_ExternalToUtfDString(NULL, "File", -1, &dstr);
778    items[0] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
779    Tcl_DStringFree(&dstr);
780    Tcl_ExternalToUtfDString(NULL, source->Name(), -1, &dstr);
781    items[1] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
782    Tcl_DStringFree(&dstr);
783    int last = indexes.GetLast();
784    for(j = last; j >= 0; j--)
785      items[last+2-j] = Tcl_NewIntObj(long(*indexes._GetObject(j)));
786    Tcl_SetListObj(obj_result, indexes.GetSize()+2, items);
787    Tcl_Free((char*)items);
788    return TCL_OK;
789  } else {
790    /* this should not happend because syn should be inside syn->source */
791    Tcl_AppendStringsToObj(obj_result,
792                             "internal error: syn not found in syn->Source()",
793                             NULL);
794    return TCL_ERROR;
795  }
796}
797
798
799/*
800 * Iterate over a first level's children of a given set.  The set
801 * could be a container Set, File or NameBlock if the index list is
802 * empty or container[i1][i2]...[ik] for the given indexes
803 * {i1,i2,...,ik}
804 *
805 */
806
807int Tol_IterChildren(Tcl_Interp * interp,
808                     int objc,
809                     Tcl_Obj *CONST objv[],
810                     Tcl_Obj * obj_result)
811{
812#define ARG_SCRIPT    0
813#define ARG_GRAMMAR   ARG_SCRIPT+1
814#define ARG_NAME      ARG_GRAMMAR+1
815#define ARG_CONTENT   ARG_NAME+1
816#define ARG_PATH      ARG_CONTENT+1
817#define ARG_DESC      ARG_PATH+1
818#define ARG_INDEXES   ARG_DESC+1
819#define ARG_ISFILE    ARG_INDEXES+1
820#define ARG_HASSUBSET ARG_ISFILE+1
821#define ARG_SUBTYPE   ARG_HASSUBSET+1
822#define ARG_STRUCT    ARG_SUBTYPE+1
823#define NUM_ARGS      ARG_STRUCT+1
824
825  const BSyntaxObject* container;
826  Tcl_DString dstr;
827  Tcl_Obj * ArgIndexes;
828  int tcl_code, cont_loop;
829  int i, card ;
830  int n, index_length;
831  Tcl_Obj ** items;
832
833  int length = 0;
834 
835  if (Tcl_ListObjLength(interp,objv[0],&length)!=TCL_OK) {
836    Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
837    return TCL_ERROR;
838  }
839  if (length<2) {
840    Tcl_AppendStringsToObj(obj_result,
841                           "invalid object reference '",
842                           Tcl_GetString(objv[0]),
843                           "must be {TYPE ?name? i1 i2 ... ik}",
844                           NULL);
845    return TCL_ERROR;
846  }
847
848  if (!(container=Tol_ResolveObject(interp, objv[0], obj_result))) {
849    return TCL_ERROR;
850  }
851  BSet *set = ContainerGetSet(container);
852  if (!set) {
853    Tcl_AppendStringsToObj(obj_result,
854                           "object '",
855                           Tcl_GetString(objv[0]),
856                           "' is not a valid container ",
857                           NULL);
858      return TCL_ERROR;
859  }
860 
861  card = set->Card();
862 
863  int datac;
864  Tcl_Obj * datav[NUM_ARGS];
865  // is ok to ask for a list
866  Tcl_ListObjGetElements(interp,objv[0],&n,&items);
867 
868  if (strcmp(Tcl_GetString(items[0]),"Console")) {
869    if (n>2)
870      ArgIndexes = Tcl_NewListObj(n-2,items+2);
871    else
872      ArgIndexes = Tcl_NewListObj(0,NULL);
873  } else {
874    if (n>1)
875      ArgIndexes = Tcl_NewListObj(n-1,items+1);
876    else
877      ArgIndexes = Tcl_NewListObj(0,NULL);
878  }
879
880  datav[ARG_SCRIPT] = objv[1];
881 
882  datav[ARG_GRAMMAR] = Tcl_NewObj();
883  datav[ARG_NAME]    = Tcl_NewObj();
884  datav[ARG_CONTENT] = Tcl_NewObj();
885  datav[ARG_PATH]    = Tcl_NewObj();
886  datav[ARG_DESC]    = Tcl_NewObj();
887  Tcl_Obj * last_index = Tcl_NewIntObj(0);
888  Tcl_ListObjAppendElement(NULL,ArgIndexes,last_index);
889  datav[ARG_INDEXES] = ArgIndexes;
890  Tcl_ListObjLength(NULL,datav[ARG_INDEXES],&index_length);
891  datav[ARG_ISFILE] = Tcl_NewObj();
892  datav[ARG_HASSUBSET] = Tcl_NewObj();
893  datav[ARG_SUBTYPE] = Tcl_NewObj();
894  datav[ARG_STRUCT] = Tcl_NewObj();
895  for (i=ARG_GRAMMAR; i<NUM_ARGS; ++i)
896    Tcl_IncrRefCount(datav[i]);
897 
898  BSyntaxObject *syn_i;
899  BSet          *set_i; /* just in case syn_i be a container */
900  /* now iter over its children */
901 
902  Tcl_DStringInit(&dstr);
903  BText btxt;
904 
905 
906  for (i=1; i<=card; ++i) {
907    syn_i = (*set)[i];
908   
909    /* read the grammar */
910   
911    btxt = syn_i->Grammar()->Name();
912    Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
913    if (Tcl_IsShared(datav[ARG_GRAMMAR])) {
914      Tcl_DecrRefCount(datav[ARG_GRAMMAR]);
915      datav[ARG_GRAMMAR] = Tcl_NewStringObj(Tcl_DStringValue(&dstr),-1);
916      Tcl_IncrRefCount(datav[ARG_GRAMMAR]);
917    } else
918      Tcl_SetStringObj(datav[ARG_GRAMMAR], Tcl_DStringValue(&dstr),-1);
919    Tcl_DStringFree(&dstr);
920   
921    /* read the name */
922   
923    //btxt = syn_i->Identify();
924    GetName( syn_i, btxt );
925    Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
926    if (Tcl_IsShared(datav[ARG_NAME])) {
927      Tcl_DecrRefCount(datav[ARG_NAME]);
928      datav[ARG_NAME] = Tcl_NewStringObj(Tcl_DStringValue(&dstr),-1);
929      Tcl_IncrRefCount(datav[ARG_NAME]);
930    } else
931      Tcl_SetStringObj(datav[ARG_NAME], Tcl_DStringValue(&dstr),-1);
932    Tcl_DStringFree(&dstr);
933   
934    /* read the content */
935   
936    btxt = syn_i->Info();
937    Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
938    if (Tcl_IsShared(datav[ARG_CONTENT])) {
939      Tcl_DecrRefCount(datav[ARG_CONTENT]);
940      datav[ARG_CONTENT] = Tcl_NewStringObj(Tcl_DStringValue(&dstr),-1);
941      Tcl_IncrRefCount(datav[ARG_CONTENT]);
942    } else
943      Tcl_SetStringObj(datav[ARG_CONTENT],Tcl_DStringValue(&dstr),-1);
944    Tcl_DStringFree(&dstr);
945   
946    /* read the path */
947   
948    btxt = syn_i->SourcePath();
949    Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
950    if (Tcl_IsShared(datav[ARG_PATH])) {
951      Tcl_DecrRefCount(datav[ARG_PATH]);
952      datav[ARG_PATH] = Tcl_NewStringObj(Tcl_DStringValue(&dstr),-1);
953      Tcl_IncrRefCount(datav[ARG_PATH]);
954    } else
955      Tcl_SetStringObj(datav[ARG_PATH],Tcl_DStringValue(&dstr),-1);
956    Tcl_DStringFree(&dstr);
957   
958    /* read the description */
959   
960    btxt = syn_i->Description();
961    Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
962    if (Tcl_IsShared(datav[ARG_DESC])) {
963      Tcl_DecrRefCount(datav[ARG_DESC]);
964      datav[ARG_DESC] = Tcl_NewStringObj(Tcl_DStringValue(&dstr),-1);
965      Tcl_IncrRefCount(datav[ARG_DESC]);
966    } else
967      Tcl_SetStringObj(datav[ARG_DESC],Tcl_DStringValue(&dstr),-1);
968    Tcl_DStringFree(&dstr);
969   
970    if ((set_i=ContainerGetSet(syn_i))) {
971      /* update last index */
972      if (Tcl_IsShared(last_index)) {
973        last_index = Tcl_NewIntObj(i);
974        Tcl_ListObjReplace(NULL, datav[ARG_INDEXES], index_length-1,
975                           1, 1, &last_index);
976      }
977      /*
978      if (Tcl_IsShared(datav[ARG_INDEXES])) {
979        Tcl_DecrRefCount(datav[ARG_INDEXES]);
980        datav[ARG_INDEXES] = Tcl_DuplicateObj(datav[ARG_INDEXES]);
981        Tcl_IncrRefCount(datav[ARG_INDEXES]);
982        Tcl_ListObjLength(NULL,datav[ARG_INDEXES],&n);
983        Tcl_ListObjIndex(NULL,datav[ARG_INDEXES],n-1,&last_index);
984      }
985      */
986      /* set the last value index */
987      Tcl_SetIntObj(last_index,i);
988      /* to refresh the string */
989      Tcl_InvalidateStringRep(datav[ARG_INDEXES]);
990      if (Tcl_IsShared(datav[ARG_ISFILE])) {
991        Tcl_DecrRefCount(datav[ARG_ISFILE]);
992#ifdef ISFILE_IMPLEMENTED
993        datav[ARG_ISFILE] = Tcl_NewIntObj(syn_i->IsFile());
994#else
995        datav[ARG_ISFILE] = Tcl_NewIntObj(0);
996#endif
997        Tcl_IncrRefCount(datav[ARG_ISFILE]);
998      } else
999#ifdef ISFILE_IMPLEMENTED
1000        Tcl_SetIntObj(datav[ARG_ISFILE],syn_i->IsFile());
1001#else
1002      Tcl_SetIntObj(datav[ARG_ISFILE],0);
1003#endif
1004      /* verify if has subset */
1005      int tmpCard = set_i->Card();
1006      int j;
1007      for (j=1; j<=tmpCard; ++j )
1008        if (ContainerGetSet((*set_i)[j]))
1009          break;
1010      if (Tcl_IsShared(datav[ARG_HASSUBSET])) {
1011        Tcl_DecrRefCount(datav[ARG_HASSUBSET]);
1012        datav[ARG_HASSUBSET] = Tcl_NewIntObj(j<=tmpCard);
1013        Tcl_IncrRefCount(datav[ARG_HASSUBSET]);
1014      } else
1015        Tcl_SetIntObj(datav[ARG_HASSUBSET],j<=tmpCard);
1016       
1017      /* subtype info */
1018       
1019      if (Tcl_IsShared(datav[ARG_SUBTYPE])) {
1020        Tcl_DecrRefCount(datav[ARG_SUBTYPE]);
1021        datav[ARG_SUBTYPE] = Tcl_NewIntObj(set_i->SubType());
1022        Tcl_IncrRefCount(datav[ARG_SUBTYPE]);
1023      } else
1024        Tcl_SetIntObj(datav[ARG_SUBTYPE],set_i->SubType());
1025       
1026      /* STRUCT INFO */
1027      if ( set_i->Struct() ) {
1028        btxt = set_i->Struct()->Name();
1029        Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
1030      }
1031      if (Tcl_IsShared(datav[ARG_STRUCT])) {
1032        Tcl_DecrRefCount(datav[ARG_STRUCT]);
1033        datav[ARG_STRUCT] = Tcl_NewStringObj(Tcl_DStringValue(&dstr),-1);
1034        Tcl_IncrRefCount(datav[ARG_STRUCT]);
1035      } else
1036        Tcl_SetStringObj(datav[ARG_STRUCT],Tcl_DStringValue(&dstr),-1);
1037      Tcl_DStringFree(&dstr);
1038      datac = NUM_ARGS;
1039    } else
1040      datac = ARG_INDEXES;
1041    tcl_code = Tcl_EvalObjv(interp,datac,datav,TCL_EVAL_GLOBAL);
1042    if (tcl_code != TCL_OK) {
1043      /* liberar los objetos tcl */
1044      for (i=ARG_GRAMMAR; i<NUM_ARGS; ++i)
1045        Tcl_DecrRefCount(datav[i]);
1046      Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
1047      return tcl_code;
1048    }
1049    /* check if break loop */
1050    cont_loop = 1;
1051    tcl_code = Tcl_GetIntFromObj(interp,Tcl_GetObjResult(interp),&cont_loop);
1052    if (tcl_code == TCL_OK && !cont_loop)
1053      break;
1054  }
1055 
1056  /* liberar los objetos tcl */
1057  for (i=ARG_GRAMMAR; i<NUM_ARGS; ++i)
1058    Tcl_DecrRefCount(datav[i]);
1059  return TCL_OK;
1060}
1061
1062/*
1063 * Fill in obj_result the content of the matrix variable.
1064 *
1065 */
1066
1067int Tol_GetMatrixContent(Tcl_Interp * interp,
1068                         Tcl_Obj * obj_name,
1069                         Tcl_Obj * obj_result)
1070{
1071  //BGrammar * gra = NULL;
1072  const BSyntaxObject *tol_obj = NULL;
1073   
1074  if (!(tol_obj=Tol_ResolveObject(interp, obj_name, obj_result))) {
1075    return TCL_ERROR;
1076  }
1077
1078  BMatrix<double> vmat;
1079  BMatrix<double> &theMat = vmat;
1080
1081  if (tol_obj->Grammar()==GraVMatrix()) {
1082    BVMat &V = VMat((BSyntaxObject *)tol_obj);
1083    V.GetDMat(vmat);
1084  } else if (tol_obj->Grammar()==GraMatrix()) {
1085    theMat = ((DMat&)Mat((BSyntaxObject *)tol_obj));
1086  } else { 
1087    Tcl_AppendStringsToObj( obj_result, Tcl_GetString(obj_name),
1088                            " is not a valid Matrix|VMatrix object", NULL );   
1089    return TCL_ERROR;
1090  }
1091   
1092#define IT_NAME 0
1093#define IT_ROWS 1
1094#define IT_COLS 2
1095#define IT_DATA 3
1096#define IT_SIZE 4
1097     
1098  Tcl_Obj * items[4];
1099  Tcl_Obj ** subitems;
1100  int r, Rows, c, Cols;
1101  BDat & dat = BDat::Unknown();
1102 
1103  //BMatrix<BDat> & mat = (BMatrix<BDat>&)(((BUserMat*)tol_obj)->Contens());
1104 
1105  //items[IT_NAME] = Tcl_NewStringObj(tol_obj->Identify(),-1);
1106  BText tmp;
1107  GetName( tol_obj, tmp );
1108  items[IT_NAME] = Tcl_NewStringObj(tmp.Buffer(),-1);
1109  Rows = theMat.Rows();
1110  Cols = theMat.Columns();
1111  items[IT_ROWS] = Tcl_NewIntObj(Rows);
1112  items[IT_COLS] = Tcl_NewIntObj(Cols);
1113  subitems = (Tcl_Obj**)Tcl_Alloc( sizeof(Tcl_Obj*)*Rows*Cols );
1114  for ( r = 0; r < Rows; ++r )
1115    for ( c = 0; c < Cols; ++c ) {
1116      dat = theMat(r,c);
1117      if (dat.IsKnown())
1118        subitems[r*Cols+c] = Tcl_NewDoubleObj(dat.Value());
1119      else
1120        subitems[r*Cols+c] = Tcl_NewStringObj("?",-1);
1121    }
1122  items[IT_DATA] = Tcl_NewListObj( Rows*Cols, subitems );
1123  Tcl_SetListObj( obj_result,IT_SIZE, items );
1124  Tcl_Free( (char*)subitems );
1125  return TCL_OK;
1126}
1127
1128/*
1129 * Fill in obj_result the content of the serie variable.
1130 *
1131 */
1132
1133int Tol_GetSerieContent(Tcl_Interp * interp,
1134                        int objc,
1135                        Tcl_Obj *CONST objv[],
1136                        Tcl_Obj * obj_result)
1137{
1138  const BSyntaxObject* var = Tol_ResolveObject(interp,
1139                                               objv[0],
1140                                               obj_result/*,
1141                                               GraSerie()*/);
1142  if (!var) {
1143    return TCL_ERROR;
1144  }
1145
1146  // parse dates arguments
1147 
1148  BDate I0, I1;
1149  int tcl_code;
1150
1151  BUserTimeSerie * serie = (BUserTimeSerie*)var;
1152  serie->ReadData();
1153
1154  if (objc == 1) {
1155    I0 = serie->FirstDate();
1156    I1 = serie->LastDate();
1157  } else {
1158    tcl_code = Tol_ParseDate(interp,Tcl_GetString(objv[1]),I0);
1159    if (tcl_code != TCL_OK) {
1160      Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
1161      return TCL_ERROR;
1162    }
1163    if (objc == 3) {
1164      tcl_code = Tol_ParseDate(interp,Tcl_GetString(objv[2]),I1);
1165      if (tcl_code != TCL_OK) {
1166        Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
1167        return TCL_ERROR;
1168      }
1169    }
1170  }
1171 
1172  if ( !I0.HasValue() )
1173    I0 = BDate::DefaultFirst();
1174  if ( !I1.HasValue() )
1175    I1 = BDate::DefaultLast();
1176
1177  BUserTimeSet * tms;
1178  Tcl_Obj ** obj_array;
1179  int length;
1180
1181  char buffer[1024];
1182
1183  tms = serie->Dating();
1184
1185  if ( !tms ) {
1186    Tcl_AppendStringsToObj(obj_result,"Serie \"",
1187                           Tcl_GetString(objv[0]),
1188                           "\" does not have dating", NULL);
1189    return TCL_ERROR;
1190  }
1191
1192  // ajustamos el intervalo de fechas al fechado
1193
1194  I0 = tms->FirstNoLess(I0);
1195  I1 = tms->FirstNoGreat(I1);
1196  length = tms->Difference(I0,I1)+1;
1197  if ( length <= 0 ) {
1198    Tcl_SetStringObj(obj_result,
1199                     "last date must be greater or equal than first",-1);
1200    return TCL_ERROR;
1201  }
1202
1203  BDat  value;
1204  BText tmp;
1205  Tcl_Obj * subitems[2];
1206
1207  // ++ because we identify the TimeSet as the first element
1208
1209  ++length;
1210  obj_array = (Tcl_Obj**)ckalloc(length*sizeof(Tcl_Obj*));
1211
1212  //tmp = tms->Identify();
1213  GetName(tms, tmp);
1214  obj_array[0] = Tcl_NewStringObj(tmp,-1);
1215  for ( int i = 1; i < length; i++ ) {
1216    tmp = I0.GetText();
1217    subitems[0] = Tcl_NewStringObj(tmp,-1);
1218#if defined(_TOL_FROZEN_)
1219    value = (*serie)[I0];
1220#else
1221    value = (*serie)(I0);
1222#endif
1223    if ( value.IsKnown() )
1224      subitems[1] = Tcl_NewDoubleObj(value.Value());
1225    else
1226      subitems[1] = Tcl_NewStringObj("?",-1);
1227    obj_array[i] = Tcl_NewListObj(2,subitems);
1228    I0 += tms;
1229
1230    sprintf(buffer,"%d",i);
1231    Tcl_VarEval(interp, "puts ", buffer, NULL);
1232  }
1233  Tcl_SetListObj(obj_result,length,obj_array);
1234  Tcl_Free( (char*)obj_array );
1235  return TCL_OK;
1236}
1237
1238int Tol_ParseDate(Tcl_Interp * interp, char * what, BDate & date)
1239{
1240  int    year, month, day, hour, min;
1241  double sec;
1242 
1243  int tcl_code;
1244  Tcl_Obj * tcl_result;
1245  int objc;
1246  Tcl_Obj ** objv;
1247
1248  month = day = 1;
1249  hour  = min = 0;
1250  sec   = 0.0;
1251  char re_pat[] = "{^(?:y([0-9]+)(?:m([0-9]+))?(?:d([0-9]+))?)$}";
1252
1253  tcl_code = Tcl_VarEval(interp, "regexp -inline ", re_pat, " ",what, NULL);
1254  if ( tcl_code != TCL_OK )
1255    return TCL_ERROR;
1256  tcl_result = Tcl_DuplicateObj(Tcl_GetObjResult(interp));
1257  /* this should be a valid list, unless Tcl be corrupt */
1258  Tcl_ListObjGetElements(interp,tcl_result,&objc,&objv);
1259  if ( objc == 0 ) {
1260    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1261                           "invalid date: \"",what,"\"",NULL);
1262    Tcl_DecrRefCount(tcl_result);
1263    return TCL_ERROR;
1264  }
1265
1266  /* and objc must be 4 */
1267
1268  Tcl_GetIntFromObj(interp,objv[1],&year);
1269  Tcl_GetIntFromObj(interp,objv[2],&month);
1270  Tcl_GetIntFromObj(interp,objv[3],&day);
1271
1272  /* now is save to release tcl_result */
1273
1274  Tcl_DecrRefCount(tcl_result);
1275
1276  date.PutDate(year,month,day);
1277  if ( !date.HasValue() ) {
1278    Tcl_ResetResult(interp);
1279    char buffer[1024];
1280    sprintf(buffer,"y%dm%dd%d",year,month,day);
1281    tcl_result = Tcl_GetObjResult(interp);
1282    Tcl_AppendStringsToObj(tcl_result,
1283                           what," = ",buffer," is valid but unknown",NULL);
1284    return TCL_ERROR;
1285  }
1286  return TCL_OK;
1287}
1288
1289/*
1290 * Set the language to be used  by TOL. Fill in obj_result the previous
1291 * language.
1292 *
1293 */
1294
1295int Tol_SetLanguage(Tcl_Interp * interp, Tcl_Obj * lang, Tcl_Obj * obj_result)
1296{
1297  BBool curLang = BText::Language();
1298  BIdiomEnum nextLang;
1299 
1300  char * strLang = Tcl_GetString( lang );
1301  if ( !strcasecmp( strLang, "es" ) )
1302    nextLang = BSPANISH;
1303  else {
1304    /* anything else will be assumed as english */
1305    nextLang = BENGLISH;
1306  }
1307  /* set the previous language as result */
1308  if ( curLang == BSPANISH )
1309    Tcl_SetStringObj( obj_result, "es", -1 );
1310  else
1311    Tcl_SetStringObj( obj_result, "en", -1 );
1312  /* tell TOL what language to use from now on */
1313  BText::PutLanguage( nextLang );
1314  return TCL_OK;
1315}
1316
1317/*
1318 * Return the language used  by TOL. Fill in obj_result the current
1319 * language.
1320 *
1321 */
1322
1323int Tol_GetLanguage(Tcl_Interp * interp, Tcl_Obj * obj_result)
1324{
1325  BBool curLang = BText::Language();
1326 
1327  if ( curLang == BSPANISH )
1328    Tcl_SetStringObj( obj_result, "es", -1 );
1329  else
1330    Tcl_SetStringObj( obj_result, "en", -1 );
1331  return TCL_OK;
1332}
1333
1334/*
1335 * Fill in obj_result the version info corresponding to tol
1336 *
1337 *   {major MajorNum minor MinorNum release ReleaseNum coment Comment}
1338 *
1339 */
1340
1341int Tol_InfoVersion( Tcl_Interp * interp,  Tcl_Obj * obj_result )
1342{
1343#define VERSION_INFO_SIZE 4*2
1344 
1345  Tcl_Obj * items[VERSION_INFO_SIZE];
1346  char buffer[64];
1347
1348  /* Major Info */
1349  items[0] = Tcl_NewStringObj( "major", -1 );
1350  items[1] = Tcl_NewIntObj( VERSION_MAJOR );
1351  /* Minor Info */
1352  items[2] = Tcl_NewStringObj( "minor", -1 );
1353  items[3] = Tcl_NewIntObj( VERSION_MINOR );
1354  /* Release Info */
1355  items[4] = Tcl_NewStringObj( "release", -1 );
1356  sprintf(buffer,"%d", VERSION_RELEASE);
1357  items[5] = Tcl_NewStringObj(buffer, -1);
1358  /* Comment Info */
1359  items[6] = Tcl_NewStringObj( "comment", -1 );
1360  items[7] = Tcl_NewStringObj(TOLVersionBuild(), -1 );
1361  /* asign the items to the result list */
1362  Tcl_SetListObj( obj_result, VERSION_INFO_SIZE, items );
1363  return TCL_OK;
1364}
1365
1366/*
1367 * Fill in obj_result the list of files included in TOL
1368 *
1369 */
1370
1371
1372int Tol_InfoIncluded (Tcl_Interp * interp,Tcl_Obj * obj_result)
1373{
1374  BList* lst = BSetFromFile::Compiled();
1375
1376  BText txt(LstText(lst,"","",","));
1377  return BList2TclList(interp,lst,obj_result,&GetPath,&HasNoSource);
1378}
1379
1380/* OJO con la declaracion de tmpSet */
1381
1382int Tol_InfoFile(Tcl_Interp * interp, Tcl_Obj * file,
1383                 Tcl_Obj * obj_result)
1384{
1385  Tcl_DString dstr;
1386  const BSyntaxObject * so;
1387
1388  Tcl_DStringInit(&dstr);
1389  Tcl_UtfToExternalDString(NULL,Tcl_GetString(file),-1,&dstr);
1390 
1391  BText fname(Tcl_DStringValue(&dstr));
1392  so = (const BSyntaxObject*)BSetFromFile::FindCompiled(fname);
1393  Tcl_DStringFree(&dstr);
1394  if (!so) {
1395    Tcl_AppendStringsToObj(obj_result,"file \"",
1396                           Tcl_GetString(file),
1397                           "\" isn't included", NULL );
1398    return TCL_ERROR;
1399  }
1400  Tcl_Obj * info[6];
1401  /* adicionar la informacion del subtype y si tiene algun set
1402   * como descendiente
1403   */
1404  BText soInfo(so->Info());
1405  BText soPath(so->SourcePath());
1406  BText soDesc(so->Description());
1407
1408  char * pch = soInfo;
1409  if (pch) pch = skipWhite(pch);
1410  else pch = "";
1411
1412  Tcl_ExternalToUtfDString(NULL,pch,-1,&dstr);
1413  info[0] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
1414  Tcl_DStringFree(&dstr);
1415
1416  Tcl_ExternalToUtfDString(NULL,soPath,-1,&dstr);
1417  info[1] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
1418  Tcl_DStringFree(&dstr);
1419
1420  Tcl_ExternalToUtfDString(NULL,soDesc,-1,&dstr);
1421  info[2] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
1422  Tcl_DStringFree(&dstr);
1423
1424  /* HAS SUBSET */
1425  BSet * ptrSet = &(((BUserSet*)so)->Contens());
1426  int tmpCard = ptrSet->Card();
1427  int j;
1428  for (j=1; j<=tmpCard; ++j )
1429    if (ContainerGetSet((*ptrSet)[j]))
1430      break;
1431  info[3] = Tcl_NewIntObj(j<=tmpCard);
1432   
1433  /* SUBTYPE INFO */
1434  info[4] = Tcl_NewIntObj( ptrSet->SubType() );
1435  /* STRUCTURE */
1436  info[5] = Tcl_NewStringObj( NULL, 0 );
1437  Tcl_SetListObj(obj_result, 6, info);
1438  return TCL_OK;
1439}
1440
1441/*
1442 * Fill in obj_result the result of evaluating including the file
1443 * given as argument: the absolute path.
1444 *
1445 */
1446
1447int Tol_IncludeFile(Tcl_Interp * interp,Tcl_Obj * obj_file,Tcl_Obj * obj_result)
1448{
1449  Tcl_DString dstr;
1450  BText fName;
1451
1452  Tcl_DStringInit(&dstr);
1453  fName = Tcl_UtfToExternalDString(NULL,Tcl_GetString(obj_file),-1,&dstr);
1454  BSetFromFile* uSet = (BSetFromFile*)BSetFromFile::FindCompiled(fName);
1455  Tcl_DStringFree(&dstr);
1456
1457  if(uSet) {
1458    DESTROY(uSet);
1459  }
1460  IncludeFile(fName);
1461  return TCL_OK;
1462}
1463
1464int Tol_DecompileFile( Tcl_Interp * interp,
1465                       Tcl_Obj * obj_file,
1466                       Tcl_Obj * obj_result )
1467{
1468  Tcl_DString dstr;
1469  BText fName;
1470
1471  Tcl_DStringInit(&dstr);
1472  fName = Tcl_UtfToExternalDString(NULL,Tcl_GetString(obj_file),-1,&dstr);
1473  BSetFromFile* uSet = (BSetFromFile*)BSetFromFile::FindCompiled(fName);
1474  Tcl_DStringFree(&dstr);
1475
1476  if(uSet) {
1477    DESTROY(uSet);
1478  } else {
1479    Tcl_AppendStringsToObj( obj_result, "file '",
1480                            Tcl_GetString(obj_file),
1481                            "' is not compiled", NULL );
1482    return TCL_ERROR;
1483  }
1484  if ( uSet ) {
1485    Tcl_AppendStringsToObj( obj_result, "could not decompile file '",
1486                            Tcl_GetString(obj_file), "'", NULL );
1487    return TCL_ERROR;
1488  }
1489  return TCL_OK;
1490}
1491/*
1492 *
1493 * Fill in obj_result the list of grammars defined in TOL
1494 *
1495 */
1496
1497int Tol_SetGrammarsObj(Tcl_Interp * interp, Tcl_Obj * obj_result )
1498{
1499
1500  BList* lstGra = BGrammar::Instances();
1501
1502  if (BList2TclList(interp,lstGra,obj_result,&GetName,&ExcludeAnything)==TCL_OK) {
1503    Tcl_Obj * name = Tcl_NewStringObj("Anything", -1);
1504    if (Tcl_ListObjAppendElement(interp,obj_result,name) != TCL_OK) {
1505      Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
1506      return TCL_ERROR;
1507    }
1508    if (QuickSort(interp,obj_result) != TCL_OK) {
1509      Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
1510      return TCL_ERROR;
1511    }
1512    return TCL_OK;
1513  }
1514  Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
1515  return TCL_ERROR;
1516}
1517
1518/*
1519 *
1520 * Fill in obj_result the description of gra_name.
1521 *
1522 */
1523
1524int Tol_SetGrammarDescObj(Tcl_Interp * interp, Tcl_Obj * gra_name,
1525                          Tcl_Obj * obj_result )
1526{
1527  BGrammar * gra = BGrammar::FindByName(Tcl_GetString(gra_name));
1528
1529  if (gra) {
1530    BText desc(gra->Description());
1531    Tcl_SetStringObj(obj_result, desc, -1);
1532    return TCL_OK;
1533  }
1534  Tcl_AppendStringsToObj( obj_result, "\"",
1535                          Tcl_GetString(gra_name),
1536                          "\" isn't a grammar", NULL );
1537  return TCL_ERROR;
1538}
1539
1540/*
1541 *  Tol_FillFunctionInfo --
1542 *
1543 *    Used in Tol_SetFunctionsObj & Tol_SetFunctionInfoObj to return the info
1544 *    for the function requested.
1545 */
1546
1547static
1548int Tol_FillFunctionInfo(BOperator * opr, Tcl_Obj * obj_result)
1549{
1550  Tcl_Obj * info[3];
1551  Tcl_DString dstr_info;
1552  Tcl_DString dstr;
1553
1554  Tcl_DStringInit(&dstr_info);
1555  BText args(opr->Arguments());
1556 
1557  if(args.Last()!='}') // name doesn't comes within the arguments expression
1558  {   
1559      // grammar name
1560      Tcl_DStringAppend(&dstr_info, opr->Grammar()->Name(), -1);
1561      Tcl_DStringAppend(&dstr_info, " ", -1);
1562      // function name
1563      Tcl_DStringInit(&dstr);
1564      Tcl_ExternalToUtfDString(NULL, opr->FullName(), -1, &dstr);
1565      Tcl_DStringAppend(&dstr_info, Tcl_DStringValue(&dstr), -1);
1566      Tcl_DStringFree(&dstr);
1567  }
1568
1569  Tcl_ExternalToUtfDString(NULL,args.String(),-1,&dstr);
1570  Tcl_DStringAppend(&dstr_info, Tcl_DStringValue(&dstr), -1);
1571  Tcl_DStringFree(&dstr);
1572  info[0] = Tcl_NewStringObj(Tcl_DStringValue(&dstr_info), -1);
1573  Tcl_DStringFree(&dstr_info);
1574  Tcl_ExternalToUtfDString(NULL,opr->SourcePath(),-1,&dstr);
1575  info[1] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
1576  Tcl_DStringFree(&dstr);
1577  Tcl_ExternalToUtfDString(NULL,opr->Description(),-1,&dstr);
1578  info[2] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
1579  Tcl_DStringFree(&dstr);
1580  Tcl_SetListObj(obj_result, 3, info);
1581  return TCL_OK;
1582}
1583
1584/*
1585 *
1586 * Fill in obj_result the functions defined for grammar gra_name.  If gra_name
1587 * is a list it is considered as an object reference {type ?name? i1 ... ik}
1588 *
1589 */
1590
1591int Tol_SetFunctionsObj (Tcl_Interp * interp, Tcl_Obj * gra_name,
1592                         Tcl_Obj * obj_result)
1593{
1594  int length = 0;
1595 
1596  if (Tcl_ListObjLength(interp,gra_name,&length)!=TCL_OK) {
1597    Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
1598    return TCL_ERROR;
1599  }
1600  if (length>1) {
1601    const BSyntaxObject *syn;
1602    if (!(syn=Tol_ResolveObject(interp, gra_name, obj_result))) {
1603      return TCL_ERROR;
1604    }
1605   
1606    if (syn->Grammar() != GraCode()) {
1607      Tcl_AppendStringsToObj(obj_result, "'", Tcl_GetString(gra_name),
1608                             "' is not a function object", NULL);
1609      return TCL_ERROR;
1610    }
1611    BOperator * opr =  ((BGraContens<BCode>*)syn)->Contens().Operator();
1612    return Tol_FillFunctionInfo(opr, obj_result);
1613  }
1614  /* gra_name should be a grammar name */
1615  if (!strcmp(Tcl_GetString(gra_name), "Anything")) {
1616    const BSpFunHash& spf = BSpecialFunction::Instances();
1617    BSpFunHash::const_iterator iter;
1618    for(iter=spf.begin(); iter!=spf.end(); iter++)
1619    {
1620      Tcl_ListObjAppendElement(interp, obj_result,
1621                               Tcl_NewStringObj(iter->second->Name(), -1));
1622    }
1623    if (QuickSort(interp,obj_result) != TCL_OK) {
1624      Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
1625      return TCL_ERROR;
1626    }
1627    return TCL_OK;
1628  }
1629
1630  BGrammar * gra = BGrammar::FindByName(Tcl_GetString(gra_name));
1631 
1632  if (gra) {
1633    BList * lstOper = gra->GetOperators();
1634    if (BList2TclList(interp,lstOper,obj_result,&GetName) != TCL_OK) {
1635      Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
1636      DESTROY(lstOper);
1637      return TCL_ERROR;
1638    }
1639    DESTROY(lstOper);
1640    if (QuickSort(interp,obj_result) != TCL_OK) {
1641      Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
1642      return TCL_ERROR;
1643    }
1644    return TCL_OK;
1645  }
1646
1647  Tcl_AppendStringsToObj(obj_result, "'",
1648                         Tcl_GetString(gra_name),
1649                         "' isn't a grammar", NULL);
1650  return TCL_ERROR;
1651}
1652
1653static
1654BOperator* TT_FindOperator( const BGrammar *G, const char *expr )
1655{
1656  BOperator* opr = G->FindOperator( expr );
1657  if ( opr ) {
1658    return opr;
1659  }
1660  bool oldEnabled = BOut::Disable();
1661  BSyntaxObject* obj = GraCode( )->BGrammar::LeftEvaluateExpr( expr );
1662  if( oldEnabled ) { BOut::Enable( ); }
1663  if(obj)
1664  {
1665    if( obj->Mode( ) == BUSERFUNMODE )
1666    {
1667      opr = dynamic_cast<BOperator*>( obj );
1668    }   
1669    if( obj->Mode( ) == BOBJECTMODE )
1670    {
1671      BUserCode *uc = dynamic_cast<BUserCode*>( obj );
1672      opr = uc ? uc->Contens().Operator( ) : NULL;
1673      if( opr && ( opr->Grammar( ) != G ) ) { opr = NULL; }
1674    }
1675  }
1676  return( opr );
1677}
1678
1679/*
1680 * Fill in obj_result the function's prototype and description
1681 * for a given function in a given grammar.
1682 *
1683 */
1684
1685int Tol_SetFunctionInfoObj (Tcl_Obj * gra_name,
1686                            Tcl_Obj * fun_name,
1687                            Tcl_Obj * obj_result)
1688{
1689  Tcl_DString dstr;
1690  Tcl_Obj * info[3];
1691
1692  if (!strcmp(Tcl_GetString(gra_name), "Anything")) {
1693    Tcl_DStringInit(&dstr);
1694    Tcl_UtfToExternalDString(NULL,Tcl_GetString(fun_name),-1,&dstr);
1695    const BSpecialFunction * spf = BSpecialFunction::Get(Tcl_DStringValue(&dstr));
1696    Tcl_DStringFree(&dstr);
1697    if (spf) {
1698      char * name, * args;
1699      size_t len;
1700     
1701      name = ((BText&)spf->Name()).Buffer();
1702      args = ((BText&)spf->Arguments()).Buffer();
1703      len = strlen(args);
1704      if(!len || args[len-1]!='}') {
1705        info[0] = Tcl_NewStringObj("Anything ", -1);
1706        Tcl_AppendStringsToObj(info[0],name,args,NULL);
1707      } else {
1708        info[0] = Tcl_NewStringObj("", -1);;
1709        Tcl_AppendStringsToObj(info[0],args,NULL);
1710      }
1711      info[1] = Tcl_NewStringObj("",-1);
1712      Tcl_ExternalToUtfDString(NULL,spf->Description(),-1,&dstr);
1713      info[2] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
1714      Tcl_DStringFree(&dstr);
1715      Tcl_SetListObj(obj_result, 3, info);
1716      return TCL_OK;
1717    }
1718    Tcl_AppendStringsToObj( obj_result, "\"",
1719                            Tcl_GetString(fun_name),
1720                            "\" isn't a function in grammar Anything", NULL );
1721  } else {
1722    BGrammar * gra = BGrammar::FindByName(Tcl_GetString(gra_name));
1723 
1724    if (gra) {
1725      Tcl_DStringInit(&dstr);
1726      Tcl_UtfToExternalDString( NULL, Tcl_GetString( fun_name ), -1, &dstr );
1727      BOperator* opr = TT_FindOperator( gra, Tcl_DStringValue( &dstr ) );
1728      Tcl_DStringFree(&dstr);
1729      if (opr) {
1730        return Tol_FillFunctionInfo(opr, obj_result);
1731      }
1732      // release the previous use of dstr
1733      //Tcl_DStringFree(&dstr);
1734      Tcl_AppendStringsToObj( obj_result, "\"",
1735                              Tcl_GetString(fun_name),
1736                              "\" isn't a function in grammar ",
1737                              Tcl_GetString(gra_name), NULL );
1738    } else
1739      Tcl_AppendStringsToObj( obj_result, "\"",
1740                              Tcl_GetString(gra_name),
1741                              "\" isn't a grammar", NULL );
1742  }
1743  return TCL_ERROR;
1744}
1745
1746/* ojo info debe tener espacio para 7 Tcl_Obj como maximo */
1747/* retorna cuantos Tcl_Obj creo */
1748
1749int SynObj2TclObj( const BSyntaxObject * var, Tcl_Obj * info[] )
1750{
1751  Tcl_DString dstr;
1752  int infoc;
1753
1754  Tcl_DStringInit(&dstr);
1755
1756  /* GRAMMAR */
1757  info[0] = Tcl_NewStringObj(var->Grammar()->Name().String(), -1);
1758   
1759  /* NAME */
1760  BText synname;
1761 
1762  GetName(var, synname);
1763  Tcl_ExternalToUtfDString(NULL,synname,-1,&dstr);
1764  info[1] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
1765  Tcl_DStringFree(&dstr);
1766   
1767  /* REST OF FIELDS */
1768 
1769  BText varInfo(var->Info());
1770  BText varPath(var->SourcePath());
1771  BText varDesc(var->Description());
1772 
1773  /* OBJECT CONTENT */
1774  char * pch = varInfo;
1775  if (pch) pch = skipWhite(pch);
1776  else pch = "";
1777 
1778  Tcl_ExternalToUtfDString(NULL,pch,-1,&dstr);
1779  info[2] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
1780  Tcl_DStringFree(&dstr);
1781 
1782  /* OBJECT PATH */
1783  Tcl_ExternalToUtfDString(NULL,varPath,-1,&dstr);
1784  info[3] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
1785  Tcl_DStringFree(&dstr);
1786 
1787  /* OBJECT DESCRIPTION */
1788  Tcl_ExternalToUtfDString(NULL,varDesc,-1,&dstr);
1789  info[4] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
1790  Tcl_DStringFree(&dstr);
1791 
1792#ifdef ISFILE_IMPLEMENTED
1793  info[5] = Tcl_NewIntObj(var->IsFile());
1794#else
1795  info[5] = Tcl_NewIntObj(0);
1796#endif
1797  //info[6] = Tcl_NewIntObj(var->System());
1798  BSet *ptrSet;
1799  if ((ptrSet=ContainerGetSet(var))) {
1800    /* HAS SUBSET */
1801    int tmpCard = ptrSet->Card();
1802    int j;
1803    for (j=1; j<=tmpCard; ++j )
1804      if ( (*ptrSet)[j]->Grammar()==GraSet() )
1805        break;
1806    info[6] = Tcl_NewIntObj(j<=tmpCard);
1807     
1808    /* SUBTYPE */
1809    info[7] = Tcl_NewIntObj( ptrSet->SubType() );
1810     
1811    /* STRUCTURE */
1812    if ( ptrSet->Struct() ) {
1813      BText btxt( ptrSet->Struct()->Name() );
1814      Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
1815      info[8] = Tcl_NewStringObj( Tcl_DStringValue(&dstr), -1 );
1816      Tcl_DStringFree( &dstr );
1817    } else
1818      info[8] = Tcl_NewStringObj( NULL, 0 );
1819    infoc = 9;
1820  } else
1821    infoc = 6;
1822 
1823  return infoc;
1824}
1825
1826int Tol_SetVariableInfoObj (Tcl_Obj * gra_name,
1827                            Tcl_Obj * var_name,
1828                            Tcl_Obj * obj_result);
1829
1830/*!
1831 * Fill in obj_result the variables defined for grammar gra_name.
1832 * Or the element info if gra_name is a reference of an element
1833 * of a global container.
1834 */
1835int Tol_SetVariablesObj (Tcl_Interp *interp, Tcl_Obj *gra_name,
1836                         Tcl_Obj *obj_result)
1837{
1838  const BSyntaxObject *syn ;
1839 
1840  int length = 0;
1841  Tcl_Obj ** items;
1842  int tcl_code;
1843 
1844  if (Tcl_ListObjLength(interp,gra_name,&length)!=TCL_OK) {
1845    Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
1846    return TCL_ERROR;
1847  }
1848  if (length!=1) {
1849    if (length == 2) {
1850      tcl_code = Tcl_ListObjGetElements(interp,gra_name,&length,&items);
1851      assert(tcl_code == TCL_OK);
1852      if (strcmp(Tcl_GetString(items[0]),"Console"))
1853        return Tol_SetVariableInfoObj(items[0], items[1], obj_result);
1854    }
1855    if (!(syn=Tol_ResolveObject(interp, gra_name, obj_result))) {
1856      return TCL_ERROR;
1857    }
1858//    Tcl_DString dstr;
1859    Tcl_Obj * info[9];
1860    int infoc;
1861   
1862    infoc = SynObj2TclObj(syn, info);
1863    Tcl_SetListObj(obj_result,infoc,info);
1864    return TCL_OK;
1865  }
1866  BGrammar *gra = BGrammar::FindByName(Tcl_GetString(gra_name));
1867  if (!gra) {
1868    Tcl_AppendStringsToObj( obj_result, "'",
1869                            Tcl_GetString(gra_name),
1870                            "' isn't a grammar", NULL );
1871    return TCL_ERROR;
1872  }
1873  BList * lstVar = gra->GetVariables();
1874  if (BList2TclList(interp,lstVar,obj_result,&GetIdentify) != TCL_OK) {
1875    Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
1876    DESTROY(lstVar);
1877    return TCL_ERROR;
1878  }
1879  DESTROY(lstVar);
1880  if (QuickSort(interp,obj_result) != TCL_OK) {
1881    Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
1882    return TCL_ERROR;
1883  }
1884  return TCL_OK;
1885}
1886
1887/*
1888 * Fill in obj_result the variables's description for a given variable
1889 * in a given grammar.
1890 *
1891 */
1892
1893int Tol_SetVariableInfoObj (Tcl_Obj * gra_name,
1894                            Tcl_Obj * var_name,
1895                            Tcl_Obj * obj_result)
1896{
1897  BGrammar * gra = BGrammar::FindByName(Tcl_GetString(gra_name));
1898  Tcl_DString dstr;
1899 
1900  Tcl_DStringInit(&dstr);
1901  if (gra) {
1902    Tcl_UtfToExternalDString(NULL,Tcl_GetString(var_name),-1,&dstr);
1903    const BSyntaxObject* var = gra->FINDVARIABLE(Tcl_DStringValue(&dstr));
1904    Tcl_DStringFree(&dstr);
1905
1906    if (var) {
1907      Tcl_Obj * info[9];
1908      int infoc;
1909      infoc = SynObj2TclObj( var, info );
1910      Tcl_SetListObj(obj_result,infoc,info);
1911//#define __INFO_PRINT_NREFS__
1912#ifdef __INFO_PRINT_NREFS__
1913      printf("NREF = %d\n", var->NRefs());
1914#endif
1915      return TCL_OK;
1916    }
1917    Tcl_AppendStringsToObj( obj_result, "\"",
1918                            Tcl_GetString(var_name),
1919                            "\" isn't a variable in grammar ",
1920                            Tcl_GetString(gra_name), NULL );
1921  } else
1922    Tcl_AppendStringsToObj( obj_result, "\"",
1923                            Tcl_GetString(gra_name),
1924                            "\" isn't a grammar", NULL );
1925  return TCL_ERROR;
1926}
1927
1928/*
1929 * We must be sure that the strings use 7 bit ASCII chararters.
1930 * Otherwise we must take care of the Utf representation.
1931 *
1932 */
1933
1934static
1935int StrObjCompare(const void * O1, const void * O2)
1936{
1937  char * str1 = (*(Tcl_Obj**)O1)->bytes;
1938  char * str2 = (*(Tcl_Obj**)O2)->bytes;
1939  int check1, check2;
1940
1941  check1 = isalpha(str1[0]);
1942  check2 = isalpha(str2[0]);
1943
1944  if ( check1 && !check2 )
1945    return 1;
1946  if ( check2 && !check1 )
1947    return -1;
1948  return strcmp(str1,str2);
1949}
1950
1951static
1952int QuickSort( Tcl_Interp * interp, Tcl_Obj * list )
1953{
1954  Tcl_Obj ** obj_array;
1955  int length;
1956
1957  if (Tcl_ListObjGetElements(interp, list, &length, &obj_array) != TCL_OK) {
1958    return TCL_ERROR;
1959  }
1960  qsort((void*)obj_array, length, sizeof(Tcl_Obj*), &StrObjCompare);
1961  return TCL_OK;
1962}
1963
1964static
1965void Tol_HciWriter( const BText & str )
1966{
1967  Tcl_CmdInfo cmd_info;
1968
1969  if (TT_interp && Tcl_GetCommandInfo(TT_interp,"Tol_HciWriter",&cmd_info) ) {
1970    Tcl_DString dstr;
1971    Tcl_Obj * objv[2];
1972   
1973    Tcl_DStringInit(&dstr);
1974    Tcl_IncrRefCount(objv[0]=Tcl_NewStringObj("Tol_HciWriter",-1));
1975    Tcl_ExternalToUtfDString(NULL, ((BText&)str).Buffer(), -1, &dstr);
1976    Tcl_IncrRefCount(objv[1]=Tcl_NewStringObj(Tcl_DStringValue(&dstr), Tcl_DStringLength(&dstr)));
1977    Tcl_DStringFree(&dstr);
1978 
1979    int status = Tcl_EvalObjv(TT_interp, 2, objv, TCL_EVAL_GLOBAL);
1980    if (status != TCL_OK) {
1981      printf("message: %s\n", ((BText&)str).Buffer());
1982      printf("objv[1] : %s\n", Tcl_GetString(objv[1]));
1983      printf("%s\n", TT_interp->result);
1984    }
1985    /* release the objects */
1986    Tcl_DecrRefCount(objv[0]);
1987    Tcl_DecrRefCount(objv[1]);
1988  }
1989}
1990
1991void Tol_InstallHciWriter()
1992{
1993  BOut::PutHciWriter(Tol_HciWriter);
1994  BOut::PutLogHciWriter(Tol_HciWriter);
1995}
1996
1997static
1998void Tol_SerieChart(BList * series, const BText& FileName )
1999{
2000#define CMD_SERIECHART "Tol_SerieChartMethod"
2001#define GRP_NAME "__grptmp_chart__%d"
2002
2003  Tcl_CmdInfo cmd_info;
2004  static int id = 0;
2005
2006  if (TT_interp && Tcl_GetCommandInfo(TT_interp,CMD_SERIECHART,&cmd_info) ) {
2007    Tcl_DString dstr;
2008    Tcl_Obj * objv[3];
2009    Tcl_Obj * obj_result=Tcl_NewObj();
2010    int tcl_result;
2011    char grpname[1024];
2012   
2013    Tcl_IncrRefCount(obj_result);
2014
2015    // first create the group of series
2016    sprintf(grpname, GRP_NAME, ++id);
2017    tcl_result = Tol_CreateSerieGrp(TT_interp, grpname, series, obj_result);
2018    if (tcl_result==TCL_ERROR) {
2019      printf("%s -- error in Tol_CreateSerieGrp: %s\n", CMD_SERIECHART,
2020             Tcl_GetString(obj_result));
2021      Tcl_DecrRefCount(obj_result);
2022      return;
2023    }
2024    // release the obj_result
2025    Tcl_DecrRefCount(obj_result);   
2026    // chart command
2027    Tcl_IncrRefCount(objv[0]=Tcl_NewStringObj(CMD_SERIECHART,-1));
2028    // serie group argument
2029    Tcl_IncrRefCount(objv[1]=Tcl_NewStringObj(grpname,-1));   
2030    // file name argument
2031    Tcl_DStringInit(&dstr);
2032    Tcl_ExternalToUtfDString(NULL, ((BText&)FileName).Buffer(), -1, &dstr);
2033    Tcl_IncrRefCount(objv[2]=Tcl_NewStringObj(Tcl_DStringValue(&dstr), Tcl_DStringLength(&dstr)));
2034    Tcl_DStringFree(&dstr);
2035    int status = Tcl_EvalObjv(TT_interp, 3, objv, TCL_EVAL_GLOBAL);
2036    if (status != TCL_OK) {
2037      printf("%s -- error in Tcl_EvalObjv:\n", CMD_SERIECHART);
2038      printf("%s\n", TT_interp->result);
2039      printf("objv[1] : %s\n", Tcl_GetString(objv[1]));
2040      printf("objv[2] : %s\n", Tcl_GetString(objv[2]));
2041    }
2042    /* release the objects */
2043    for (int i=0; i<3; i++)
2044      Tcl_DecrRefCount(objv[i]);
2045    /* the group of series should be destroyied in the Hook */
2046    /*Tcl_VarEval(TT_interp, "tol::seriegrp destroy ", grpname, NULL);*/
2047  }
2048}
2049
2050int Tol_Tcl_Eval(char * script, const char ** result)
2051{
2052  int status;
2053 
2054  status = Tcl_Eval(TT_interp, script);
2055  *result = Tcl_GetStringResult(TT_interp);
2056  return status==TCL_OK;
2057}
2058
2059Tcl_Obj *TolObj2TclObj(BSyntaxObject *tolObj)
2060{
2061  const char *grammar = tolObj->Grammar()->Name().String();
2062
2063  if (!strcmp(grammar, "Text")) {
2064    const BText &value = Text(tolObj);
2065    return Tcl_NewStringObj(value.String(),-1);
2066  } else if (!strcmp(grammar, "Real")) {
2067    const BDat &value = Dat(tolObj);
2068    return Tcl_NewDoubleObj(value.Value());
2069  } else {
2070    return Tcl_NewStringObj(tolObj->Dump().String(),-1);   
2071  }
2072}
2073
2074int Tol_Tcl_EvalEx(const BSet &Args, const char ** result)
2075{
2076  int status;
2077  Tcl_Obj **objv;
2078  int card = Args.Card();
2079 
2080  if (!Args.Card()) {
2081    *result = "";
2082    status = TCL_OK;
2083  } else {
2084    objv = (Tcl_Obj**)Tcl_Alloc(sizeof(Tcl_Obj*)*card);
2085    for(int i=1; i<=card; i++) {
2086      objv[i-1] = TolObj2TclObj(Args[i]);
2087      Tcl_IncrRefCount(objv[i-1]);
2088    }
2089    status = Tcl_EvalObjv(TT_interp, card, objv, TCL_EVAL_GLOBAL);
2090    *result = Tcl_GetStringResult(TT_interp);
2091    for(int i=0; i<card; i++) {
2092      Tcl_DecrRefCount(objv[i]);
2093    }
2094  }
2095  return status==TCL_OK;
2096}
2097
2098int Tol_StopEvaluation()
2099{
2100  StopFlagOn();
2101  return TCL_OK;
2102}
2103
2104/*
2105 * Fill in obj_result the format .
2106 *
2107 */
2108
2109int Tol_LCFormat(Tcl_Interp*    interp,
2110                 Tcl_Obj *CONST obj_value,
2111                 Tcl_Obj *      obj_result)
2112{
2113  double value;
2114  char buffer[256];
2115 
2116  /* read the double value from tcl obj */
2117  if (Tcl_GetDoubleFromObj(TT_interp, obj_value, &value)==TCL_ERROR)
2118    {
2119      Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
2120      return TCL_ERROR;
2121    }
2122  lc_format(value, buffer);
2123  Tcl_AppendStringsToObj(obj_result, buffer, NULL);
2124  return TCL_OK;
2125}
2126
2127void Tol_InstallMethodsHook()
2128{
2129  InstallSerieChartHook(&Tol_SerieChart);
2130  InstallTclEval(&Tol_Tcl_Eval);
2131  InstallTclEvalEx(&Tol_Tcl_EvalEx);
2132}
Note: See TracBrowser for help on using the repository browser.