source: tol/toltcl/generic/toltableset.cpp

devel
Last change on this file was 3395277, checked in by Jorge Pérez <josp.jorge@…>, 12 years ago

refs #1812, #1818, configuracion especifica para WIN32 donde concoemos bien donde estaran los archivos devel que tomamos de la variable TOL_PREFIX_PATH

git-svn-id: ​https://www.tol-project.org/svn/tolp/trunk@6463 be4846ae-f051-483a-831f-b64e7d08527f
  • Property mode set to 100644
File size: 41.7 KB
Line 
1/* toltableset.cpp: This file implements the command to manipulate a set
2                    as a table.
3                    GNU/tolTcl Library
4
5   Copyright (C) 2001, 2002, 2003 - Bayes Decisión, SL
6
7   This program is free software; you can redistribute it and/or modify
8   it under the terms of the GNU General Public License as published by
9   the Free Software Foundation; either version 2, or (at your option)
10   any later version.
11
12   This program is distributed in the hope that it will be useful,
13   but WITHOUT ANY WARRANTY; without even the implied warranty of
14   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15   GNU General Public License for more details.
16
17   You should have received a copy of the GNU General Public License
18   along with this program; if not, write to the Free Software
19   Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
20   USA.
21 */
22
23#ifdef _MSC_VER
24/* for _finite */
25#  include <float.h>
26#endif
27
28#include <ctype.h>
29#include <toltclInt.h>
30#include <tt_crash.h>
31
32#if defined(_MSC_VER)
33#  include <win_tolinc.h>
34#endif
35
36#include <tol/tol_bcommon.h>
37#include <tol/tol_bstruct.h>
38#include <tol/tol_bdatgra.h>
39#include <tol/tol_bmatgra.h>
40#include <tol/tol_bvmatgra.h>
41#include <tol/tol_bsetgra.h>
42#include <tol/tol_btxtgra.h>
43
44#include <tt_pool.h>
45#include <tt_tclutils.h>
46
47#ifndef NDEBUG
48#define _DEBUG_TABLE_
49#endif
50
51class Tol_Table;
52class Tol_TableSet;
53
54class Tol_ColumnData {
55public:
56  enum enumColType { Text=0, Real, Date };
57
58  Tol_ColumnData( enumColType t );
59  ~Tol_ColumnData();
60  enumColType GetType() {
61    return type;
62  }
63  int HasINF() {
64    return hasINF;
65  }
66  int HasUNK() {
67    return hasUNK;
68  }
69
70  /* return the current number of rows */
71
72  int GetSize() {
73    int size;
74   
75    Tcl_ListObjLength(NULL, values, &size);
76    return size;
77  }
78
79  Tcl_Obj * GetValues() {
80    return values;
81  }
82
83  /* name <colname> type <coltype> [unknown (yes|no) INF (yes|no)] */
84
85  Tcl_Obj * GetInfo();
86
87  /* interp <-- values */
88
89  int ReturnData(Tcl_Interp * interp);
90 
91  /* return values[row] in cell */
92
93  int ReturnCell(Tcl_Interp * interp, int row);
94
95  /*
96   * return the value[row], leave in interp an error message if
97   * something went wrong.
98   */
99
100  Tcl_Obj * GetCell(Tcl_Interp * interp, int row);
101
102  /*
103   * apply script to values[0..]
104   *
105   *  eval $script $row value[$row]
106   */
107
108  int Apply(Tcl_Interp * interp, Tcl_Obj * script);
109
110  void SetName( const char * str );
111
112  int AppendBDat(Tcl_Interp * interp, BDat & dat);
113  int AppendSyntaxObject( Tcl_Interp * interp, BSyntaxObject * so );
114  int PrependSyntaxObject( Tcl_Interp * interp, BSyntaxObject * so );
115  int AppendEmpty();
116  int PrependEmpty();
117protected:
118  /* append functions */
119  int AppendReal( Tcl_Interp * interp, double v );
120  int AppendInfinity();
121  int AppendUnknown();
122  int AppendEmptyReal();
123  int AppendText( const char * txt );
124  /* prepend functions */
125  int PrependReal( Tcl_Interp * interp, double v );
126  int PrependInfinity();
127  int PrependUnknown();
128  int PrependEmptyReal();
129  int PrependText( const char * txt );
130private:
131  Tcl_DString dsName;
132  enumColType type;
133  int hasINF;
134  int hasUNK;
135  /* list of column values */
136  Tcl_Obj * values;
137};
138
139class Tol_Table {
140public:
141  enum enumHeaderType { Struct, Row, Generic };
142
143  Tol_Table(Tcl_Interp * _interp, char * name);
144  ~Tol_Table();
145
146  void CreateCommand(char * cmd_name) {
147    if (cmd_status == TCL_OK )
148      Tcl_CreateObjCommand(interp, cmd_name, Tol_Table::ObjCmd,
149                           (ClientData)this, Tol_Table::DeleteCmd);
150  }
151
152  int CmdStatus() {
153    return cmd_status;
154  }
155 
156  static int ObjCmd( ClientData clientData,
157                     Tcl_Interp *interp,
158                     int objc, Tcl_Obj *CONST objv[] );
159
160  static void DeleteCmd( ClientData clientData );
161
162  Tcl_Interp * GetInterp(void) {
163    return interp;
164  }
165  int GetRows() {
166    return rows;
167  }
168 
169  /*
170   * implement: tableset info name
171   */
172
173  int ReturnName();
174
175  /*
176   * implement: tableset info header
177   */
178
179  int ReturnHeaderInfo();
180
181  /*
182   * implement: tableset info datarows
183   */
184
185  int ReturnRowsNumber();
186
187  /*
188   * implement: tableset info rowsnames
189   */
190
191  int ReturnRowsNames();
192
193  /*
194   * implement: tableset info columns
195   */
196
197  int ReturnColumnsInfo();
198
199  /*
200   * implement: tableset data get i j
201   *
202   * interp <-- set_data(row,col)
203   */
204
205  int ReturnCell( int row, int col );
206
207  /*
208   * implement: tableset data column col
209   *
210   * interp <-- set_data(col)->ReturnData(interp)
211   */
212
213  int ReturnColumn( int col );
214
215  /*
216   * implement: tableset data apply all script
217   */
218
219  int ApplyAll( Tcl_Obj * script );
220
221  /*
222   * implement: tableset data apply row idx script
223   */
224
225  int ApplyRow( int row, Tcl_Obj * script );
226
227  /*
228   * implement: tableset data apply column idx script
229   */
230
231  int ApplyColumn( int col, Tcl_Obj * script );
232 
233protected:
234  Tcl_Interp * interp;
235
236  int   rows;
237  Tcl_DString dsName;
238  /* how are gotten header names */
239  enumHeaderType  headerType;
240  int extraColumns;
241  ToltclPool columns;
242  Tcl_Obj ** rowsNames;
243  int cmd_status;
244  Tcl_Obj ** retBuffer;
245
246  Tol_ColumnData ** Columns( int i ) {
247    return (Tol_ColumnData**)columns._GetObject(i);
248  }
249};
250
251class Tol_TableSet : public Tol_Table {
252public:
253  Tol_TableSet(Tcl_Interp * _interp, char * setname, BSet * set,
254               Tcl_Obj * obj_result); 
255protected:
256  int Build(BSet * set, Tcl_Obj * obj_result);
257};
258
259class Tol_TableMatrix : public Tol_Table {
260public:
261  Tol_TableMatrix(Tcl_Interp * _interp, char * matname, BMatrix<double> *mat,
262                  Tcl_Obj * obj_result);
263protected:
264  int Build(BMatrix<double> *mat, Tcl_Obj * obj_result); 
265};
266
267/*
268 * Tol_ColumnData implementation
269 *
270 */
271
272/*
273 *   Tol_ColumnData::Tol_ColumnData
274 *
275 *     Constructor
276 */
277
278Tol_ColumnData::Tol_ColumnData( Tol_ColumnData::enumColType t )
279{
280  Tcl_DStringInit( &dsName );
281  type = t;
282  hasINF = 0;
283  hasUNK = 0;
284  Tcl_IncrRefCount(values=Tcl_NewListObj(0, NULL));
285}
286
287/*
288 *  Tol_ColumnData::~Tol_ColumnData()
289 *
290 *    Destructor
291 */
292
293Tol_ColumnData::~Tol_ColumnData()
294{
295  Tcl_DStringFree(&dsName);
296  Tcl_DecrRefCount(values);
297}
298
299/*
300 *  Tol_ColumnData::GetInfo()
301 *
302 *    return
303 *      name <colname> type <coltype> [unknown (0|1) INF (0|1)]
304 */
305
306Tcl_Obj * Tol_ColumnData::GetInfo()
307{
308  Tcl_Obj * info;
309
310#define CD_NAME    0
311#define CD_NAMEV   CD_NAME  + 1
312#define CD_TYPE    CD_NAMEV + 1
313#define CD_TYPEV   CD_TYPE  + 1
314#define CD_UNK     CD_TYPEV + 1
315#define CD_UNKV    CD_UNK   + 1
316#define CD_INF     CD_UNKV  + 1
317#define CD_INFV    CD_INF   + 1
318#define CD_SIZE    CD_INFV  + 1
319
320  int itemc = CD_UNK;
321  Tcl_Obj * itemv[CD_SIZE];
322
323  itemv[CD_NAME] = Tcl_NewStringObj( "name", -1 );
324  itemv[CD_NAMEV] = Tcl_NewStringObj( Tcl_DStringValue(&dsName), -1 );
325  itemv[CD_TYPE] = Tcl_NewStringObj( "type", -1 );
326  switch ( type ) {
327    case Text:
328      itemv[CD_TYPEV] = Tcl_NewStringObj( "Text", -1 );
329      break;
330    case Real:
331      itemv[CD_TYPEV] = Tcl_NewStringObj( "Real", -1 );
332      itemv[CD_UNK] = Tcl_NewStringObj( "unknown", -1 );
333      itemv[CD_UNKV] = Tcl_NewIntObj( hasUNK );
334      itemv[CD_INF] = Tcl_NewStringObj( "infinity", -1 );
335      itemv[CD_INFV] = Tcl_NewIntObj( hasINF );
336      itemc = CD_SIZE;
337      break;
338    case Date:
339      itemv[CD_TYPEV] = Tcl_NewStringObj( "Date", -1 );
340  }
341  info = Tcl_NewListObj( itemc, itemv );
342  return info;
343}
344
345
346/*
347 *  Tol_ColumnData::ReturnData
348 *
349 *    return to interp the values of the column
350 *
351 */
352
353int Tol_ColumnData::ReturnData(Tcl_Interp * interp)
354{
355  Tcl_SetObjResult(interp, values);
356  return TCL_OK;
357}
358
359Tcl_Obj * Tol_ColumnData::GetCell(Tcl_Interp * interp, int row)
360{
361  Tcl_Obj * obj = NULL;
362 
363  if (Tcl_ListObjIndex(interp, values, row, &obj)==TCL_OK)
364    if (!obj) {
365      char buffer[256];
366      sprintf(buffer,"GetCell, index '%d', out of range", row);
367      Tcl_AppendResult(interp, buffer, NULL);
368    }
369  return obj;
370}
371
372int Tol_ColumnData::ReturnCell(Tcl_Interp * interp, int row)
373{
374  Tcl_Obj * obj;
375
376  if (Tcl_ListObjIndex(interp, values, row, &obj)==TCL_OK) {
377    if (obj) {
378      Tcl_SetObjResult(interp, obj);
379      return TCL_OK;
380    }
381    char buffer[256];
382    sprintf(buffer,"ReturnCell, index '%d', out of range", row);
383    Tcl_AppendResult(interp, buffer, NULL);
384  }
385  return TCL_ERROR;
386}
387
388/*
389 *  Tol_ColumnData::Apply
390 *
391 *    apply script to values[0..]
392 *
393 *      eval $script $row value[$row]
394 */
395int Tol_ColumnData::Apply(Tcl_Interp * interp, Tcl_Obj * scriptObj)
396{
397  Tcl_Obj * args[2];
398  Tcl_Obj ** items;
399  int count;
400
401  Tcl_IncrRefCount(args[0]=Tcl_NewObj());
402 
403  /* init script evaluator */
404
405  EvalScript script(interp, scriptObj, 2, args );
406  /* get the array of elements */
407  Tcl_ListObjGetElements(interp, values, &count, &items);
408  for (int r = 0; (r < count) && (script.Status()==TCL_OK); r++) {
409    /* set the arg row value */
410    if (Tcl_IsShared(args[0])) {
411      Tcl_DecrRefCount(args[0]);
412      Tcl_IncrRefCount(args[0] =Tcl_NewIntObj(r));
413    } else
414      Tcl_SetIntObj(args[0], r);
415    /* set the cell value */
416    args[1] = items[r];
417 
418   /* invoke the script */
419   
420    script.Eval();
421  }
422  Tcl_DecrRefCount(args[0]);
423  return script.Status();
424}
425
426void Tol_ColumnData::SetName( const char * str )
427{
428  Tcl_DStringFree( &dsName );
429  Tcl_ExternalToUtfDString( NULL, str, -1, &dsName ); 
430}
431
432/*
433 *  Tol_ColumnData::AppendReal
434 */
435
436int Tol_ColumnData::AppendReal(Tcl_Interp * interp, double v)
437{
438#ifdef _DEBUG_TABLE_
439  if ( type != Real ) {
440    Tcl_AppendResult( interp,
441                      "Tol_ColumnData::AppendReal called on not Real column", NULL );
442    return TCL_ERROR;
443  }
444#endif
445  return Tcl_ListObjAppendElement(interp, values, Tcl_NewDoubleObj(v));
446}
447
448/*
449 *  Tol_ColumnData::PrependReal
450 */
451
452int Tol_ColumnData::PrependReal(Tcl_Interp * interp, double v)
453{
454#ifdef _DEBUG_TABLE_
455  if ( type != Real ) {
456    Tcl_AppendResult( interp,
457                      "Tol_ColumnData::PrependReal called on not Real column", NULL );
458    return TCL_ERROR;
459  }
460#endif
461  Tcl_Obj * items[1];
462  items[0] = Tcl_NewDoubleObj(v);
463  return Tcl_ListObjReplace(NULL, values, 0, 0, 1, items);
464}
465
466/*
467 *  Tol_ColumnData::AppendInfinity
468 */
469
470int Tol_ColumnData::AppendInfinity()
471{
472#ifdef _DEBUG_TABLE_
473  if ( type != Real )
474    return TCL_ERROR;
475#endif
476  hasINF = 1;
477  return Tcl_ListObjAppendElement(NULL, values, Tcl_NewStringObj("INF",-1));
478}
479
480/*
481 *  Tol_ColumnData::PrependInfinity
482 */
483
484int Tol_ColumnData::PrependInfinity()
485{
486#ifdef _DEBUG_TABLE_
487  if ( type != Real )
488    return TCL_ERROR;
489#endif
490  hasINF = 1;
491  Tcl_Obj * items[1];
492  items[0] = Tcl_NewStringObj("INF",-1);
493  return Tcl_ListObjReplace(NULL, values, 0, 0, 1, items);
494}
495
496/*
497 *  Tol_ColumnData::AppendUnknown --
498 */
499
500int Tol_ColumnData::AppendUnknown()
501{
502#ifdef _DEBUG_TABLE_
503  if ( type != Real )
504    return TCL_ERROR;
505#endif
506  hasUNK = 1;
507  return Tcl_ListObjAppendElement(NULL, values, Tcl_NewStringObj("?",-1));
508}
509
510/*
511 *  Tol_ColumnData::PrependUnknown --
512 */
513
514int Tol_ColumnData::PrependUnknown()
515{
516#ifdef _DEBUG_TABLE_
517  if ( type != Real )
518    return TCL_ERROR;
519#endif
520  hasUNK = 1;
521  Tcl_Obj * items[1];
522  items[0] = Tcl_NewStringObj("?",-1);
523  return Tcl_ListObjReplace(NULL, values, 0, 0, 1, items);
524}
525
526/*
527 *  Tol_ColumnData::AppendEmptyReal --
528 */
529
530int Tol_ColumnData::AppendEmptyReal()
531{
532#ifdef _DEBUG_TABLE_
533  if ( type != Real )
534    return TCL_ERROR;
535#endif
536  hasUNK = 1;
537  return Tcl_ListObjAppendElement(NULL, values, Tcl_NewObj());
538}
539
540/*
541 *  Tol_ColumnData::PrependEmptyReal --
542 */
543
544int Tol_ColumnData::PrependEmptyReal()
545{
546#ifdef _DEBUG_TABLE_
547  if ( type != Real )
548    return TCL_ERROR;
549#endif
550  hasUNK = 1;
551  Tcl_Obj * items[1];
552  items[0] = Tcl_NewObj();
553  return Tcl_ListObjReplace(NULL, values, 0, 0, 1, items);
554}
555
556/*
557 *  Tol_ColumnData::AppendText --
558 *
559 */
560
561int Tol_ColumnData::AppendText( const char * txt )
562{
563#ifdef _DEBUG_TABLE_
564  if ( type == Real )
565    return TCL_ERROR;
566#endif
567
568  while (*txt && isspace(*txt))
569    ++txt;
570  return Tcl_ListObjAppendElement(NULL, values, Tcl_NewStringObj(txt,-1));
571}
572
573/*
574 *  Tol_ColumnData::PrependText --
575 *
576 */
577
578int Tol_ColumnData::PrependText( const char * txt )
579{
580#ifdef _DEBUG_TABLE_
581  if ( type == Real )
582    return TCL_ERROR;
583#endif
584  while (*txt && isspace(*txt))
585    ++txt;
586  Tcl_Obj * items[1];
587  items[0] = Tcl_NewStringObj(txt,-1);
588  return Tcl_ListObjReplace(NULL, values, 0, 0, 1, items);
589}
590
591/*
592 * Tol_columnData::AppendBDat --
593 *
594 */
595
596int Tol_ColumnData::AppendBDat(Tcl_Interp * interp, BDat & dat)
597{
598  if ( dat.IsKnown() ) {
599    double v = dat.Value();
600    if ( isinf(v) )
601      AppendInfinity();
602    else
603      AppendReal(interp, v);
604  } else
605    AppendUnknown();
606  return TCL_OK;
607}
608
609/*
610 *  Tol_ColumnData::AppendSyntaxObject --
611 *
612 */
613
614int Tol_ColumnData::AppendSyntaxObject(Tcl_Interp * interp, BSyntaxObject * so)
615{
616  enumColType so_type = Text;
617
618  if ( so->Grammar() == GraReal() )
619    so_type = Real;
620  else if ( so->Grammar() == GraDate() )
621    so_type = Date;
622  if ( type == Real ) {
623    if ( so_type == Real ) {
624      /* keep on Real column */
625
626      return AppendBDat(interp, Dat(so));
627      /*
628      BDat dat( Dat(so) );
629
630      if ( dat.IsKnown() ) {
631        double v = dat.Value();
632        if ( isinf(v) )
633          AppendInfinity();
634        else
635          AppendReal(interp, v);
636      } else
637        AppendUnknown();
638      return TCL_OK;
639      */
640    } else {
641      if ((so_type == Date) && GetSize()) {
642        /* start a Date column */
643        type = Date;
644      } else {
645        /* convert to Text column, what a shame!!! */
646        type = Text;
647      }
648    }
649  } else if ( type == Date && so_type != Date ) {
650    /* change from Date to Text */
651    type = Text;
652  }
653
654  /*** SI so_type == Text adicionar el contenido de las cadenas sin las "'s ***/
655
656  /* now add the info regardless being Text or Date */
657  BText info(so->Info());
658  AppendText(info.Buffer());
659
660  return TCL_OK;
661}
662
663/*
664 *  Tol_ColumnData::PrependSyntaxObject --
665 *
666 */
667
668int Tol_ColumnData::PrependSyntaxObject( Tcl_Interp * interp, BSyntaxObject * so )
669{
670  enumColType so_type = Text;
671
672  if ( so->Grammar() == GraReal() )
673    so_type = Real;
674  else if ( so->Grammar() == GraDate() )
675    so_type = Date;
676  if ( type == Real ) {   
677    if ( so_type == Real ) {
678      /* keep on Real column */
679     
680      BDat dat( Dat(so) );
681
682      if ( dat.IsKnown() ) {
683        double v = dat.Value();
684        if ( isinf(v) )
685          PrependInfinity();
686        else
687          PrependReal(interp, v);
688      } else
689        PrependUnknown();
690      return TCL_OK;
691    } else {
692      /* convert to Text column, what a shame!!! */
693      type = Text;
694    }
695  } else if ( type == Date && so_type != Date ) {
696    /* change from Date to Text */
697    type = Text;
698  }
699
700  /* now add the info regardless being Text or Date */
701  BText info(so->Info());
702  PrependText(info.Buffer());
703
704  return TCL_OK;
705}
706
707/*
708 *  Tol_ColumnData::AppendEmpty --
709 *
710 */
711
712int Tol_ColumnData::AppendEmpty()
713{
714  if ( type == Real )
715    AppendEmptyReal();
716  else
717    AppendText("");
718
719  return TCL_OK;
720}
721
722/*
723 *  Tol_ColumnData::PrependEmpty --
724 *
725 */
726
727int Tol_ColumnData::PrependEmpty()
728{
729 
730  if ( type == Real )
731    PrependEmptyReal();
732  else
733    PrependText("");
734  return TCL_OK;
735}
736
737/*
738 *  Tol_Table implementation
739 *
740 */
741
742/*
743 * Tol_Table::Tol_Table --
744 */
745
746Tol_Table::Tol_Table(Tcl_Interp * _interp, char * name)
747{
748  rows = 0;
749  interp = _interp;
750  rowsNames = NULL;
751  retBuffer = NULL;
752  Tcl_DStringInit( &dsName );
753  Tcl_ExternalToUtfDString( NULL, name, -1, &dsName );   
754}
755
756/*
757 *  Tol_Table::~Tol_Table()
758 *
759 *    Destructor
760 */
761
762Tol_Table::~Tol_Table()
763{
764  int i;
765
766  Tcl_DStringFree(&dsName);
767  if (rowsNames) {
768    int sizeRN;
769   
770    sizeRN = (headerType == Row) ? rows + 1: rows;
771    for ( i = 0; i < sizeRN; i++ )
772      Tcl_DecrRefCount( rowsNames[i] );
773    Tcl_Free( (char*)rowsNames );
774    rowsNames = NULL;
775  }
776  if ( retBuffer ) {
777    Tcl_Free( (char*)retBuffer );
778    retBuffer = NULL;
779  }
780  for ( i = 0; i < columns.GetSize(); i++ )
781    delete *Columns(i);
782}
783 
784/*
785 *  Tol_Table::ReturnName --
786 *
787 *    implement: tableset info name
788 */
789
790int Tol_Table::ReturnName()
791{
792  Tcl_AppendResult( interp, Tcl_DStringValue(&dsName), NULL );
793  return TCL_OK;
794}
795
796/*
797 *  Tol_Table::ReturnHeaderInfo --
798 *
799 *    implement: tableset info header
800 */
801
802int Tol_Table::ReturnHeaderInfo()
803{
804  switch ( headerType ) {
805    case Struct:
806      Tcl_AppendResult( interp, "struct", NULL );
807      break;
808    case Row:
809      char buffer[256];
810     
811      sprintf( buffer, "row %d", extraColumns );
812      Tcl_AppendResult( interp, buffer, NULL );
813      break;
814    case Generic:      Tcl_AppendResult( interp, "generic", NULL );
815      break;
816    default:
817      Tcl_AppendResult( interp, "FATAL: found invalid header type", NULL );
818      return TCL_ERROR;
819  }
820  return TCL_OK;
821}
822
823/*
824 *  Tol_Table::ReturnRowsNumber --
825 *
826 *    implement: tableset info rows
827 */
828
829int Tol_Table::ReturnRowsNumber()
830{
831  char buffer[1024];
832
833  sprintf( buffer, "%d", rows );
834  Tcl_AppendResult( interp, buffer, NULL );
835  return TCL_OK;
836}
837
838/*
839 *  Tol_Table::ReturnRowsNames --
840 *
841 *    Return the list with the name of the elements of the set.
842 *
843 */
844
845int Tol_Table::ReturnRowsNames()
846{
847  int itemc;
848 
849  itemc = (headerType == Row) ? rows + 1 : rows;
850  Tcl_SetObjResult(interp, Tcl_NewListObj(itemc, rowsNames));
851  return TCL_OK;
852}
853
854/*
855 *  Tol_Table::ReturnColumnsInfo --
856 *
857 *    implement: tableset info columns
858 */
859
860int Tol_Table::ReturnColumnsInfo()
861{
862  Tol_ColumnData * ptrCol;
863  int itemc, i;
864  Tcl_Obj ** itemv;
865 
866  itemc = columns.GetSize();
867  itemv = (Tcl_Obj**)Tcl_Alloc( itemc * sizeof(Tcl_Obj*) );
868  for ( i = 0; i < itemc; i++ ) {
869    ptrCol = *Columns(i);
870    itemv[i] = ptrCol->GetInfo();
871  }
872  Tcl_SetObjResult( interp, Tcl_NewListObj(itemc, itemv) );
873  Tcl_Free( (char*)itemv );
874  return TCL_OK;
875}
876
877/*
878 *  Tol_Table::ReturnCell
879 *
880 *    implement: tableset data get i j
881 *
882 *    interp <-- set_data(row,col)
883 */
884
885int Tol_Table::ReturnCell( int row, int col )
886{
887  Tol_ColumnData * ptrCol;
888  char buffer[1024];
889
890  /* validate arguments */
891
892  if ( row < 0 || row >= rows ) {
893    sprintf( buffer, "invalid row index must be >= 0 && < %d", rows );
894    Tcl_AppendResult( interp, buffer, NULL );   
895    return TCL_ERROR;
896  }
897  if ( col < 0 || col >= columns.GetSize() ) {
898    sprintf( buffer, "invalid column index must be >= 0 && < %d", columns.GetSize() );
899    Tcl_AppendResult( interp, buffer, NULL );   
900    return TCL_ERROR;
901  }
902  ptrCol = *Columns(col);
903  return ptrCol->ReturnCell(interp, row);
904}
905
906/*
907 *  Tol_Table::ReturnColumn
908 *
909 *    implement: tableset data column col
910 *
911 *      interp <-- set_data(col)->ReturnData(interp)
912 */
913
914int Tol_Table::ReturnColumn( int col )
915{
916  Tol_ColumnData * ptrCol;
917
918  /* validate column */
919
920  if ( col < 0 || col >= columns.GetSize() ) {
921    char buffer[1024];
922
923    sprintf( buffer, "invalid column index must be >= 0 && < %d", columns.GetSize() );
924    Tcl_AppendResult( interp, buffer, NULL );   
925    return TCL_ERROR;
926  }
927  ptrCol = *Columns(col);
928  return ptrCol->ReturnData(interp);
929}
930
931
932
933/*
934 *  Tol_Table::ApplyAll --
935 *
936 *    implement: tableset apply all script
937 */
938
939int Tol_Table::ApplyAll( Tcl_Obj * scriptObj )
940{
941  Tcl_Obj * args[3];
942  Tcl_Obj ** items;
943  Tol_ColumnData * ptrCol;
944  int i, r, c, count;
945
946  for ( i = 0; i < 2; i++ ) {
947    args[i] = Tcl_NewObj();
948    Tcl_IncrRefCount( args[i] );
949  }
950
951  /* Init script evaluator */
952
953  EvalScript script(interp, scriptObj, 3, args);
954  for ( c = 0; (script.Status()==TCL_OK) && (c<columns.GetSize()); c++ ) {
955    /* Get the column */
956    ptrCol = *Columns(c);
957
958    /* Set the arg column value */
959
960    if ( Tcl_IsShared( args[1] ) ) {
961      Tcl_DecrRefCount( args[1] );
962      args[1] = Tcl_NewIntObj( c );
963      Tcl_IncrRefCount( args[1] );
964    } else
965      Tcl_SetIntObj( args[1], c );
966    r = 0;
967    /* get the array of elements */
968    Tcl_ListObjGetElements(interp, ptrCol->GetValues(), &count, &items);
969    for (int r = 0; (r < count) && (script.Status()==TCL_OK); r++) {
970      /* set the arg row value */
971      if (Tcl_IsShared(args[0])) {
972        Tcl_DecrRefCount(args[0]);
973        Tcl_IncrRefCount(args[0] =Tcl_NewIntObj(r));
974      } else
975        Tcl_SetIntObj(args[0], r);
976      /* set the cell value */
977      args[2] = items[r];
978     
979      /* invoke the script */
980     
981      script.Eval();
982    }
983  }
984
985  for ( i = 0; i < 2; i++ )
986    Tcl_DecrRefCount(args[i]);
987 
988  return script.Status();
989}
990
991/*
992 *  Tol_Table::ApplyRow
993 *
994 *    implement: tableset apply row idx script
995 */
996
997int Tol_Table::ApplyRow( int row, Tcl_Obj * scriptObj )
998{
999  Tcl_Obj * args[2];
1000  Tol_ColumnData * ptrCol;
1001  int c;
1002 
1003  /* verify the row argument */
1004 
1005  if ( row < 0 || row >= rows ) {
1006    char buffer[1024];
1007
1008    sprintf( buffer, "invalid row index must be >= 0 && < %d", rows );
1009    Tcl_AppendResult( interp, buffer, NULL );
1010    return TCL_ERROR;
1011  }
1012
1013  Tcl_IncrRefCount(args[0] = Tcl_NewObj());
1014
1015  /* Init script evaluator */
1016
1017  EvalScript script(interp, scriptObj, 2, args);
1018 
1019  /* loop over columns */
1020
1021  for (c = 0; (script.Status() != TCL_ERROR) && (c < columns.GetSize()); c++ ) {
1022
1023    /* Get the column */
1024
1025    ptrCol = *Columns(c);
1026
1027    /* Set the arg column value */
1028   
1029    if ( Tcl_IsShared( args[0] ) ) {
1030      Tcl_DecrRefCount( args[0] );
1031      args[0] = Tcl_NewIntObj( c );
1032      Tcl_IncrRefCount( args[0] );
1033    } else
1034      Tcl_SetIntObj( args[0], c );
1035   
1036    /* set the cell value */
1037    if (!(args[1] = ptrCol->GetCell(interp, row))) {
1038      /* there was an error getting the cell value */
1039      Tcl_DecrRefCount(args[0]);
1040      return TCL_ERROR;
1041    }
1042    /* Invoke the script */
1043   
1044    script.Eval();
1045  }
1046  Tcl_DecrRefCount(args[0]);
1047  return script.Status();
1048}
1049
1050/*
1051 *  Tol_Table::ApplyColumn
1052 *
1053 *    implement: tableset apply column idx script
1054 */
1055
1056int Tol_Table::ApplyColumn( int col, Tcl_Obj * script )
1057{
1058  Tol_ColumnData * ptrCol;
1059
1060  /* validate the column argument */
1061
1062 
1063  if ( col < 0 || col >= columns.GetSize() ) {
1064    char buffer[1024];
1065
1066    sprintf( buffer, "invalid column index must be >= 0 && < %d", columns.GetSize() );
1067    Tcl_AppendResult( interp, buffer, NULL );
1068    return TCL_ERROR;
1069  }
1070
1071  ptrCol = *Columns(col);
1072 
1073  return ptrCol->Apply(interp, script);
1074}
1075
1076/*
1077 *  Tol_Table::ObjCmd --
1078 *
1079 *    implement an specific group of set given by clientData.
1080 *
1081 *    table info (name | header | rows | columns)
1082 *
1083 *    table data
1084 *
1085 *      table data get i j --> return element in row i column j
1086 *
1087 *      table data apply
1088 *
1089 *         table data apply all script  -->
1090 *
1091 *                            executes script foreach item in the table
1092 *                            concats to script 'i j value' (row, col and value)
1093 *
1094 *         table data apply row idx script -->
1095 *
1096 *                            executes script foreach item in row idx
1097 *                            concats to script 'i value' (column value)
1098 *
1099 *         table data iter column idx script -->
1100 *
1101 *                            executes script foreach item in column idx
1102 *                            concats to script 'i value' (row value)
1103 *
1104 *     table data column idx --> return data in column idx. If column's type
1105 *                             isn't real returns a list with all values. If
1106 *                             column's type is real returns a list with blt
1107 *                             vectors and probabily unknown values, ej,
1108 *                             {Y1 Y2 {} {} Y3 *INF}
1109 */
1110
1111
1112int Tol_Table::ObjCmd (ClientData clientData,
1113                       Tcl_Interp *interp,
1114                       int objc, Tcl_Obj *CONST objv[])
1115{
1116  int tcl_code;
1117  int i, j;
1118 
1119  char * cmd = Tcl_GetString(objv[0]);
1120
1121#ifdef __RELEASE__
1122  try_crash {
1123#endif
1124    Tol_Table * sgrp = (Tol_Table*) clientData;
1125 
1126    if ( objc < 2 ) {
1127      Tcl_AppendResult( interp,
1128                        "wrong # args: should be \"",
1129                        cmd, " option\"", NULL );
1130      return TCL_ERROR;
1131    }
1132 
1133    char * option = Tcl_GetString(objv[1]);
1134    int length = strlen(option);
1135 
1136    if (length && !strncmp( "info", option, length )) {
1137      if ( objc != 3 ) {
1138        Tcl_AppendResult( interp,
1139                          "wrong # args: should be \"",
1140                          cmd, " info option\"", NULL );
1141        return TCL_ERROR;
1142      }
1143      option = Tcl_GetString( objv[2] );
1144      length = strlen( option );
1145      if ( length && !strncmp( "name", option, length ) )
1146        return sgrp->ReturnName();
1147      else if ( length && !strncmp( "header", option, length ) )
1148        return sgrp->ReturnHeaderInfo();
1149      else if ( length && !strncmp( "datarows", option, length ) )
1150        return sgrp->ReturnRowsNumber();
1151      else if ( length && !strncmp( "rowsnames", option, length ) )
1152        return sgrp->ReturnRowsNames();
1153      else if ( length && !strncmp( "columns", option, length ) )
1154        return sgrp->ReturnColumnsInfo();
1155      else {
1156        Tcl_AppendResult( interp,
1157                          "invalid  arg '", option, " should be \"",
1158                          " name, header, datarows, rowsnames or columns\"", NULL );
1159        return TCL_ERROR;
1160      }
1161      //return sgrp->ReturnInfo();
1162    } else if ( length && !strncmp("data", option, length) ) {
1163      if ( objc < 3 || objc > 6 ) {
1164        Tcl_AppendResult( interp,
1165                          "wrong # args: should be: \n",
1166                          cmd, " data get i j\n",
1167                          cmd, " data apply all script\n",
1168                          cmd, " data apply row idx script\n",
1169                          cmd, " data apply column idx script\n",
1170                          cmd, " data column idx", NULL);
1171        return TCL_ERROR;
1172      }
1173      char * arg = Tcl_GetString(objv[2]);
1174   
1175      if ( !strcmp( "column", arg) ) {
1176        if (objc != 4) {
1177          Tcl_AppendResult( interp,
1178                            "wrong # args: should be \"",
1179                            cmd, " data column idx\"", NULL );
1180          return TCL_ERROR;
1181        }
1182        tcl_code = Tcl_GetIntFromObj( interp, objv[3], &i );
1183        if ( tcl_code != TCL_OK )
1184          return tcl_code;
1185        return sgrp->ReturnColumn( i );
1186      } else if ( !strcmp("get", arg) ) {
1187        if ( objc != 5 ) {
1188          Tcl_AppendResult( interp,
1189                            "wrong # args: should be \"",
1190                            cmd, " data get i j\"", NULL );
1191          return TCL_ERROR;
1192        }
1193        tcl_code = Tcl_GetIntFromObj( interp, objv[3], &i );
1194        if ( tcl_code != TCL_OK )
1195          return tcl_code;
1196        tcl_code = Tcl_GetIntFromObj( interp, objv[4], &j );
1197        if ( tcl_code != TCL_OK )
1198          return tcl_code;
1199        sgrp->ReturnCell( i, j );
1200      } else if ( !strcmp("apply", arg) ) {
1201        if (objc < 4) {
1202          Tcl_AppendResult( interp,
1203                            "wrong # args: should be: ",
1204                            cmd, " data apply all script\n",
1205                            cmd, " data apply row idx script\n",
1206                            cmd, " data apply column idx script",NULL);
1207          return TCL_ERROR;
1208        }
1209        arg = Tcl_GetString( objv[3] );
1210        if ( !strcmp("all", arg) ) {
1211          if ( objc != 5 ) {
1212            Tcl_AppendResult( interp,
1213                              "wrong # args: should be \"",
1214                              cmd,
1215                              " data apply all script\"", NULL );
1216            return TCL_ERROR;
1217          }
1218          return sgrp->ApplyAll( objv[4] );
1219          //OK de data apply all script
1220        } else if (!strcmp("row", arg) ) {
1221          if (objc != 6) {
1222            Tcl_AppendResult( interp,
1223                              " wrong # args: should be \"",
1224                              cmd,
1225                              " data apply row idx script\"", NULL );
1226            return TCL_ERROR;
1227          }
1228          tcl_code = Tcl_GetIntFromObj( interp, objv[4], &i );
1229          if ( tcl_code != TCL_OK )
1230            return tcl_code;
1231          return sgrp->ApplyRow( i, objv[5] );
1232        } else if ( !strcmp("column", arg) ) {
1233          if ( objc != 6 ) {
1234            Tcl_AppendResult( interp,
1235                              "wrong # args: should be \"",
1236                              cmd,
1237                              " data apply column idx script\"", NULL );
1238            return TCL_ERROR;
1239          }
1240          tcl_code = Tcl_GetIntFromObj( interp, objv[4], &i );
1241          if ( tcl_code != TCL_OK )
1242            return tcl_code;
1243          return sgrp->ApplyColumn( i, objv[5] );
1244        } else {
1245          Tcl_AppendResult( interp,
1246                            "wrong # args: should be: ",
1247                            cmd, " data apply all script\n",
1248                            cmd, " data apply row idx script\n",
1249                            cmd, " data apply column idx script",NULL);
1250          return TCL_ERROR;
1251        }
1252      } else {
1253        Tcl_AppendResult( interp,
1254                          "wrong # args: should be: \n",
1255                          cmd, " data get i j\n",
1256                          cmd, " data apply all script\n",
1257                          cmd, " data apply row idx script\n",
1258                          cmd, " data apply column idx script\n",
1259                          cmd, " data column idx", NULL);
1260        return TCL_ERROR;
1261      }
1262    } else {
1263      Tcl_AppendResult( interp, "bad option \"",option,
1264                        "\": must be info or data",NULL);
1265      return TCL_ERROR;
1266    }
1267#ifdef __RELEASE__
1268  } catch_crash {
1269    Tcl_AppendResult( interp,
1270                      "Fatal error in tableset subcommand, kill the application",
1271                      NULL);
1272    return TCL_ERROR;
1273  }
1274#endif
1275}
1276
1277void Tol_Table::DeleteCmd( ClientData clientData )
1278{
1279  Tol_Table * tsg = (Tol_Table*)clientData;
1280 
1281  delete tsg;
1282}
1283
1284/*
1285 * Tol_TableSet implementation
1286 */
1287
1288/*
1289 *  Tol_TableSet
1290 *
1291 *     build the matrix data, header and create the ADT
1292 *     in case of success. CmdStatus tell us if the ADT
1293 *     was created.
1294 */
1295
1296Tol_TableSet::Tol_TableSet(Tcl_Interp * _interp, char * setname, BSet * set,
1297                           Tcl_Obj * obj_result)
1298  : Tol_Table(_interp, setname)
1299{
1300  cmd_status = Build(set, obj_result);
1301}
1302
1303/*
1304 *  Tol_TableSet::Build --
1305 *
1306 *    Build the data structure associated to a SetGroup
1307 */
1308
1309int Tol_TableSet::Build( BSet * set, Tcl_Obj * obj_result )
1310{
1311  int card, subcard, i, j, k;
1312  int LastColWithData;
1313  BSyntaxObject * subso, * elem;
1314  BSet * subset;
1315  BStruct * struct0, * struct1;
1316  BText so_name;
1317  int tcl_status;
1318 
1319  Tol_ColumnData * ptrCol;
1320  ToltclPool firstRow;
1321 
1322  card = set->Card();
1323  if ( !card ) {
1324    Tcl_AppendStringsToObj( obj_result,
1325                            "could not create a table from an empty set", NULL );
1326    return TCL_ERROR;
1327  }
1328 
1329  /* rows may be equal to:
1330   *
1331   *    card if headerType == generic || headerType == struct || card == 1
1332   *
1333   *    card - 1 if headerType = row
1334   */
1335 
1336
1337  rowsNames = (Tcl_Obj**)Tcl_Alloc( sizeof(Tcl_Obj*) * card );
1338
1339  rows = 0;
1340 
1341  /* process first row */
1342 
1343  subso = (*set)[1];
1344  so_name = subso->Name();
1345  if ( !so_name.HasName() )
1346    so_name = subso->Description();
1347  Tcl_IncrRefCount(rowsNames[0] = NewExternalStringObj(so_name.Buffer()));
1348  struct0 = NULL;
1349  headerType = Generic;
1350  extraColumns = 0;
1351
1352  /* at least one column, i guess it will be Real */
1353 
1354  columns.AppendObject(ptrCol = new Tol_ColumnData( Tol_ColumnData::Real));
1355
1356  if ( subso->Grammar() == GraSet() ) {
1357    /* first element is a subset */
1358    BText * btxt;
1359 
1360    subset =  &(((BUserSet*)subso)->Contens());
1361    subcard = subset->Card();
1362    if ( subcard ) {
1363      struct0 = subset->Struct();
1364      /* loop for text labels */
1365      for ( i = 1; i <= subcard; i++ ) {
1366        elem = (*subset)[i];
1367        if ( elem->Grammar() != GraText() ||!elem->Info().Length() ) {
1368          /* No Text: invalid column name or empty text*/
1369          break;
1370        }
1371        /* at least we need this column */
1372        btxt = &(((BUserText*)elem)->Contens());
1373        if (i>1) {
1374          /* the first column was previously added
1375           * and ptrCol point to it */
1376          ptrCol = new Tol_ColumnData(Tol_ColumnData::Real);
1377          columns.AppendObject(ptrCol);
1378        }
1379        ptrCol->SetName(btxt->Buffer());       
1380      }
1381      if ( i > subcard ) {
1382        /* could be Row type */
1383        headerType = Row;
1384        /* but only at the end could be verified */
1385      }
1386    } else {
1387      /* first subset is empty, so add empty cell to the first column */
1388      tcl_status = (*Columns(0))->AppendEmpty();
1389      rows = 1;
1390#ifdef _DEBUG_TABLE_
1391      if ( tcl_status != TCL_OK ) {
1392        Tcl_AppendStringsToObj( obj_result,
1393                                "internal error", NULL );
1394        return TCL_ERROR;
1395      }
1396#endif
1397    }
1398  } else {
1399    /* first element is not a subset, add it as the first element of
1400     * the first column the header will be generic */
1401    (*Columns(0))->AppendSyntaxObject(interp, subso);
1402    rows = 1;
1403  }
1404 
1405  /* now going into the data, uff!!! */
1406
1407  for ( i = 2; i <= card; i++, rows++ ) {
1408    subso = (*set)[i];
1409    so_name = subso->Name();
1410
1411    /* set the name of this row */
1412    if ( !so_name.HasName() )
1413      so_name = subso->Description();
1414    Tcl_IncrRefCount(rowsNames[i-1] = NewExternalStringObj(so_name.Buffer()));
1415
1416    if ( subso->Grammar() == GraSet() ) {
1417      /* current element is a subset */
1418      subset =  &(((BUserSet*)subso)->Contens());
1419      subcard = subset->Card();
1420      if ( subcard ) {
1421        /* current subset has elements */
1422        struct1 = subset->Struct();
1423        if ( struct0 && struct1 != struct0 ) {
1424          /* found mismatched struct, so forget it */
1425          struct0 = NULL;
1426        }
1427        for ( j = 1; j <= subcard; j++ ) {
1428          elem = (*subset)[j];
1429          if ( j > columns.GetSize() ) {
1430            /* create a new column, always suppose it will be Real */
1431            ptrCol = new Tol_ColumnData( Tol_ColumnData::Real );
1432            columns.AppendObject( ptrCol );
1433            /* insert empty values at begining */
1434            for ( k = 0; k < rows ; k++ )
1435              ptrCol->AppendEmpty();
1436          } else
1437            ptrCol = *Columns(j-1);
1438          ptrCol->AppendSyntaxObject(interp, elem);
1439        }
1440        LastColWithData = subcard - 1;
1441      } else {
1442        /* current subset has no elements, so prepare for an empty row */
1443        LastColWithData = -1;
1444      }
1445    } else {
1446      /* current element is not a subset, add it to the first column */
1447      (*Columns(0))->AppendSyntaxObject(interp, subso);
1448      LastColWithData = 0;
1449    }
1450    /* add empty to the rest of columns */
1451    for ( j = LastColWithData + 1; j <  columns.GetSize(); j++ ) {
1452      (*Columns(j))->AppendEmpty();
1453    }
1454  }
1455 
1456  /* NOW DECIDE WICH ARE THE NAMES OF THE COLUMNS */
1457 
1458  char buffer[1024];
1459  int idx;
1460 
1461  if ( struct0 ) {
1462    /* names are taken from struct */
1463    BText btxt;
1464   
1465    subso = (*set)[1];
1466    subset =  &(((BUserSet*)subso)->Contens());
1467   
1468    /* here we can ensure that, only if rows > 0
1469     *
1470     *     subset->Card() == columns.GetSize() == struct0->Size()
1471     */
1472   
1473    /* this loop is only for the case rows == 0 */
1474
1475    for (i=columns.GetSize(); i<subset->Card(); i++) {
1476      /* create a new column, always suppose it will be Real */
1477      ptrCol = new Tol_ColumnData( Tol_ColumnData::Real );
1478      columns.AppendObject(ptrCol);
1479    }
1480     
1481    for ( i = 0; i < subset->Card(); i++ ) {
1482      btxt = (*struct0)[i].Name();
1483      (*Columns(i))->SetName(btxt.Buffer());
1484     
1485      /* Insert (prepend) at position 0 (in every column)
1486       * the corresponding element from firstRow
1487       */
1488     
1489      (*Columns(i))->PrependSyntaxObject( interp, (*subset)[i+1] );
1490    }
1491    /* so, the header type is Struct */
1492    headerType = Struct;
1493    /* and we have a one more row */
1494    ++rows;
1495  } else if (headerType == Row) {
1496
1497    /* set[1] is a subset an all its members are text
1498     * and was filled when headerType was determined
1499     */
1500
1501    subset =  &(((BUserSet*)(*set)[1])->Contens());
1502    subcard = subset->Card();
1503    if (!rows) {
1504      /* no data so insert the first row as data */
1505      headerType = Generic;
1506      rows = 1;
1507      for ( i = 0; i < subcard; i++ ) {
1508        subso = (*subset)[i+1];
1509        (*Columns(i))->AppendSyntaxObject(interp, subso);
1510      }
1511      /* this will force generic names for the columns */
1512      i = 0;
1513    } else
1514      i = subcard;
1515
1516    /* complete the extra names as columnXXX */
1517
1518    for ( ;i < columns.GetSize(); i++ ) {
1519      sprintf( buffer, "Column%d", i+1 );
1520      (*Columns(i))->SetName( buffer );
1521      ++extraColumns;
1522    }
1523  } else {
1524    /* we must provide generic names for the columns
1525     * and prepend the first row
1526     */
1527
1528    subso = (*set)[1];
1529    if ( subso->Grammar() == GraSet() ) {
1530      subset =  &(((BUserSet*)subso)->Contens());
1531      subcard = subset->Card();
1532      if ( subcard ) {
1533        /* and we'll have a one more row */
1534        ++rows;
1535      }
1536    } else {
1537      /* this cell was already added at the begining */
1538      subset = NULL;
1539      subcard = 1;
1540    }
1541    const char * ptrName;
1542    for ( i = 0; i < columns.GetSize(); i++ ) {
1543      idx = i+1;
1544      ptrCol = *Columns(i);
1545      if ( subset && subcard ) {
1546        if ( idx <= subcard ) {
1547          elem = (*subset)[idx];           
1548          ptrCol->PrependSyntaxObject( interp, elem );
1549          if (elem->Name().HasName())
1550            ptrName = elem->Name().String();
1551          else {
1552            sprintf( buffer, "Column%d", idx );
1553            ptrName = buffer;
1554          }
1555        } else {
1556          /* the first row is too short */
1557          ptrCol->PrependEmpty();
1558          sprintf( buffer, "Column%d", idx );
1559          ptrName = buffer;
1560        }
1561      } else {
1562        sprintf( buffer, "Column%d", idx );
1563        ptrName = buffer;
1564      }
1565      ptrCol->SetName(ptrName);     
1566    }
1567    /* we may grow the columns, here we have a valid subset */
1568   
1569    for ( ; i < subcard; i++ ) {
1570      idx = i+1;
1571      elem = (*subset)[idx];           
1572      columns.AppendObject(ptrCol = new Tol_ColumnData(Tol_ColumnData::Real));
1573      ptrCol->AppendSyntaxObject(interp,elem);
1574      if (elem->Name().HasName())
1575        ptrName = elem->Name().String();
1576      else {
1577        sprintf( buffer, "Column%d", idx );
1578        ptrName = buffer;
1579      }
1580      ptrCol->SetName( ptrName );
1581      /* we have to fill the rest of rows with empty */
1582      for ( j = 1;  j < rows; j++ )
1583        ptrCol->AppendEmpty();
1584    }
1585  }
1586 
1587  return TCL_OK;
1588}
1589
1590/*
1591 *  Tol_TableMatrix implementation.
1592 */
1593
1594/*
1595 *  Tol_TableMatrix
1596 *
1597 *     build the matrix data, header and create the ADT
1598 *     in case of success. CmdStatus tell us if the ADT
1599 *     was created.
1600 */
1601
1602Tol_TableMatrix::Tol_TableMatrix(Tcl_Interp * _interp, char * matname, BMatrix<double> *mat,
1603                                 Tcl_Obj * obj_result)
1604  : Tol_Table(_interp, matname)
1605{
1606  cmd_status = Build(mat, obj_result);
1607}
1608
1609/*
1610 *  Tol_TableMatrix::Build --
1611 *
1612 *    Build the actual ADT from a BMat object. Return success state.
1613 */
1614
1615int Tol_TableMatrix::Build(BMatrix<double> *mat, Tcl_Obj * obj_result)
1616{
1617  Tol_ColumnData * ptrCol;
1618  int colSize =  mat->Columns();
1619  char buffer[255];
1620
1621  rows = mat->Rows();
1622  rowsNames = (Tcl_Obj**)Tcl_Alloc(sizeof(Tcl_Obj*) * rows);
1623  extraColumns = 0;
1624  headerType = Generic;
1625  for (int col = 0; col < colSize; col++) {
1626    columns.AppendObject(ptrCol = new Tol_ColumnData( Tol_ColumnData::Real));
1627    sprintf(buffer, "column %d", col);
1628    ptrCol->SetName(buffer);
1629    for (int row = 0; row < rows; row++) {
1630      if (!col) {
1631        /* put the name to the row */
1632        sprintf(buffer, "row %d", row);
1633        Tcl_IncrRefCount(rowsNames[row]=Tcl_NewStringObj(buffer, -1));
1634      }
1635      BDat dat((*mat)(row,col));
1636      ptrCol->AppendBDat(interp, dat);
1637    }
1638  }
1639  return TCL_OK;
1640}
1641
1642/*
1643 *  Tol_CreateTable --
1644 *
1645 */
1646
1647int Tol_CreateTable(Tcl_Interp * interp,
1648                    Tcl_Obj *tblcmd, Tcl_Obj *objref,
1649                    int ismat, Tcl_Obj * obj_result)
1650{
1651  Tcl_CmdInfo cmd_info;
1652  char * tblname;
1653
1654  const BSyntaxObject * syn;
1655
1656  tblname = Tcl_GetString(tblcmd);
1657  if (!*tblname) {
1658    Tcl_AppendStringsToObj(obj_result,
1659                           "invalid table group name \"\"",NULL);
1660    return TCL_ERROR;
1661  }
1662
1663  /* verify if sgrp_name already exists as a table group */
1664
1665  if (Tcl_GetCommandInfo(interp, tblname, &cmd_info)) {
1666    if (cmd_info.objProc == Tol_Table::ObjCmd)
1667      Tcl_AppendStringsToObj(obj_result, "\"", tblname, "\"",
1668                             " already exists as a table object", NULL);
1669    else
1670      Tcl_AppendStringsToObj(obj_result, "\"", tblname, "\"",
1671                             " already exists as a command", NULL);
1672     
1673    return TCL_ERROR;
1674  }
1675
1676  // syn = Tol_GetObjFromReference( interp, GraSet(), setref, obj_result );
1677  if (!(syn=Tol_ResolveObject(interp, objref, obj_result))) {
1678    return TCL_ERROR;
1679  }
1680
1681  /* now is ok to create the obj cmd */
1682
1683  BText objname( syn->Name() );
1684  Tol_Table * ptrTable;
1685  if (ismat) {
1686    BMatrix<double> vmat;
1687    BMatrix<double> &theMat = vmat;
1688    if (syn->Grammar()==GraVMatrix()) {
1689      BVMat &V = VMat((BSyntaxObject *)syn);
1690      V.GetDMat(vmat);
1691    } else if (syn->Grammar()==GraMatrix()) {
1692      theMat = ((DMat&)Mat((BSyntaxObject *)syn));
1693    } else { 
1694      Tcl_AppendStringsToObj( obj_result, Tcl_GetString(objref),
1695                              " is not a valid Matrix|VMatrix object", NULL );   
1696      return TCL_ERROR;
1697    }
1698   
1699    ptrTable = new Tol_TableMatrix( interp, objname.Buffer(),
1700                                    &theMat, obj_result );
1701  } else if ( syn->Grammar()==GraSet() ) {
1702   
1703    BSet *ptrSet = &(Set((BSyntaxObject*)syn));
1704    ptrTable = new Tol_TableSet( interp, objname.Buffer(),
1705                                 ptrSet, obj_result );
1706  } else { 
1707    Tcl_AppendStringsToObj( obj_result, Tcl_GetString(objref),
1708                            " is not a valid Set object", NULL );   
1709    return TCL_ERROR;
1710  }
1711  if ( ptrTable->CmdStatus() != TCL_OK ) {
1712    delete ptrTable;
1713    return TCL_ERROR;
1714  }
1715  ptrTable->CreateCommand(tblname);
1716 
1717  return TCL_OK;
1718}
1719
1720/*
1721 * Destroy a list of table cmd.
1722 *
1723 */
1724
1725int Tol_DestroyTable(Tcl_Interp * interp,
1726                     int objc, Tcl_Obj *CONST objv[],
1727                     Tcl_Obj * obj_result)
1728{
1729  Tcl_CmdInfo cmd_info;
1730  char * tbl_name;
1731 
1732  for (int i=0; i<objc; ++i) {
1733    tbl_name = Tcl_GetString( objv[i] );
1734    if ( Tcl_GetCommandInfo( interp, tbl_name, &cmd_info ) &&
1735         (cmd_info.objProc == Tol_Table::ObjCmd) ) {
1736      if ( Tcl_DeleteCommand( interp, tbl_name ) ) {
1737        Tcl_AppendStringsToObj( obj_result,
1738                                "could not delete \"", tbl_name, "\"", NULL);
1739        return TCL_ERROR;
1740      }
1741    } else {
1742      Tcl_AppendStringsToObj( obj_result,
1743                              "can't find table \"", tbl_name, "\"", NULL );
1744      return TCL_ERROR;
1745    }
1746  }
1747  Tcl_ResetResult(interp);
1748  return TCL_OK;
1749}
Note: See TracBrowser for help on using the repository browser.