SecuritySNACCRuntime/c++-lib/c++/tcl-if.cpp

   1 /*
   2  * Copyright (c) 2000-2001 Apple Computer, Inc. All Rights Reserved.
   3  *
   4  * The contents of this file constitute Original Code as defined in and are
   5  * subject to the Apple Public Source License Version 1.2 (the 'License').
   6  * You may not use this file except in compliance with the License. Please obtain
   7  * a copy of the License at http://www.apple.com/publicsource and read it before
   8  * using this file.
   9  *
  10  * This Original Code and all software distributed under the License are
  11  * distributed on an 'AS IS' basis, WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESS
  12  * OR IMPLIED, AND APPLE HEREBY DISCLAIMS ALL SUCH WARRANTIES, INCLUDING WITHOUT
  13  * LIMITATION, ANY WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
  14  * PURPOSE, QUIET ENJOYMENT OR NON-INFRINGEMENT. Please see the License for the
  15  * specific language governing rights and limitations under the License.
  16  */
  17
  18
  19 // file: .../c++-lib/src/tcl-if.C
  20 //
  21 // $Header: /cvs/root/Security/SecuritySNACCRuntime/c++-lib/c++/Attic/tcl-if.cpp,v 1.1.1.1 2001/05/18 23:14:06 mb Exp $
  22 // $Log: tcl-if.cpp,v $
  23 // Revision 1.1.1.1  2001/05/18 23:14:06  mb
  24 // Move from private repository to open source repository
  25 //
  26 // Revision 1.2  2001/05/05 00:59:17  rmurphy
  27 // Adding darwin license headers
  28 //
  29 // Revision 1.1  2000/06/15 18:44:58  dmitch
  30 // These snacc-generated source files are now checked in to allow cross-platform build.
  31 //
  32 // Revision 1.2  2000/06/08 20:05:37  dmitch
  33 // Mods for X port. These files are actually machine generated and probably don't need to be in CVS....
  34 //
  35 // Revision 1.1.1.1  2000/03/09 01:00:06  rmurphy
  36 // Base Fortissimo Tree
  37 //
  38 // Revision 1.2  1999/02/26 00:23:41  mb
  39 // Fixed for Mac OS 8
  40 //
  41 // Revision 1.1  1999/02/25 05:21:57  mb
  42 // Added snacc c++ library
  43 //
  44 // Revision 1.6  1997/02/28 13:39:47  wan
  45 // Modifications collected for new version 1.3: Bug fixes, tk4.2.
  46 //
  47 // Revision 1.5  1997/01/01 23:24:35  rj
  48 // `typename' appears to be a reserved word in gcc 2.7, so prefix it with `_'
  49 //
  50 // Revision 1.4  1995/09/07  18:57:13  rj
  51 // duplicate code merged into a new function SnaccTcl::gettypedesc().
  52 //
  53 // Revision 1.3  1995/08/17  15:09:09  rj
  54 // snacced.[hC] renamed to tcl-if.[hC].
  55 // class SnaccEd renamed to SnaccTcl.
  56 // set Tcl's errorCode variable.
  57 //
  58 // Revision 1.2  1995/07/27  09:53:38  rj
  59 // comment leader fixed
  60 //
  61 // Revision 1.1  1995/07/27  09:52:22  rj
  62 // new file: tcl interface used by snacced.
  63
  64 #if !defined(macintosh) && !defined(__APPLE__)
  65 #include <sys/types.h>
  66 #include <sys/stat.h>
  67 #endif
  68 #include <fcntl.h>
  69 #include <assert.h>
  70 #include <unistd.h>
  71 #include <stdlib.h>
  72 #include <strstream.h>
  73 #include <fstream.h>
  74 #include <string.h>
  75
  76 #include "asn-incl.h"
  77
  78 #if TCL
  79
  80 #ifdef _AIX32
  81 extern "C" int strncasecmp (const char* s1, const char* s2, size_t number);
  82 extern "C" int strcasecmp (const char* s1, const char* s2);
  83 #endif
  84
  85 #include "tcl-if.h"
  86 #include "init.h"
  87
  88 //\[banner "utility functions"]-----------------------------------------------------------------------------------------------------
  89 static bool strniabbr (const char *pattern, const char *test, size_t min)
  90 {
  91   register      len;
  92
  93   if (strlen (pattern)<min)
  94     fprintf (stderr, "strniabbr(): strlen (pattern) < min\n");
  95   if ((len = strlen (test))<min)
  96     return false;
  97   return !strncasecmp (pattern, test, len);
  98 }
  99
 100 //\[banner "ctor & dtor"]-----------------------------------------------------------------------------------------------------------
 101 ASN1File::ASN1File (const AsnTypeDesc *typedesc)
 102 {
 103   type = typedesc;
 104   pdu = type->create();
 105   fn = NULL;
 106   fd = -1;
 107   filesize = 0;
 108 }
 109
 110 ASN1File::ASN1File (const AsnTypeDesc *typedesc, const char *_fn, int _fd)
 111 {
 112   type = typedesc;
 113   pdu = type->create();
 114
 115   int fnlen = strlen (_fn) + 1;
 116   fn = new char [fnlen];
 117   memcpy (fn, _fn, fnlen);
 118
 119   fd = _fd;
 120 }
 121
 122 ASN1File::~ASN1File()
 123 {
 124   delete pdu;
 125   delete fn;
 126   if (fd >= 0)
 127     close (fd);
 128 }
 129
 130 bool ASN1File::bad()
 131 {
 132   return fd < 0;
 133 }
 134
 135 int ASN1File::finfo (Tcl_Interp *interp)
 136 {
 137   Tcl_AppendElement (interp, fn ? fn : "");
 138   char *acc = "bad";
 139   if (!bad())
 140   {
 141     int flags;
 142     if ((flags = fcntl (fd, F_GETFL)) != -1)
 143       switch (flags & O_ACCMODE)
 144       {
 145         case O_RDONLY:
 146           acc = "ro";
 147           break;
 148         case O_WRONLY:
 149           acc = "wo";
 150           break;
 151         case O_RDWR:
 152           acc = "rw";
 153           break;
 154       }
 155   }
 156   Tcl_AppendElement (interp, acc);
 157
 158   return TCL_OK;
 159 }
 160
 161 int ASN1File::read (Tcl_Interp *interp, const char *rfn)
 162 {
 163   int rfd;
 164   TmpFD tmpfd;
 165
 166   delete pdu;
 167   pdu = type->create();
 168
 169   if (rfn)
 170   {
 171     if ((rfd = open (rfn, O_RDONLY)) < 0)
 172     {
 173       Tcl_AppendResult (interp, "can't open \"", rfn, "\": ", Tcl_PosixError (interp), NULL);
 174       return TCL_ERROR;
 175     }
 176     tmpfd = rfd;
 177   }
 178   else if (fd < 0)
 179   {
 180     Tcl_AppendResult (interp, "can't read, file is not open", NULL);
 181     Tcl_SetErrorCode (interp, "SNACC", "MUSTOPEN", NULL);
 182     return TCL_ERROR;
 183   }
 184   else
 185   {
 186     rfn = fn;
 187     lseek (rfd = fd, 0l, SEEK_SET);
 188   }
 189
 190   struct stat statbuf;
 191   if (fstat (rfd, &statbuf))
 192   {
 193     Tcl_AppendResult (interp, "can't fstat \"", rfn, "\": ", Tcl_PosixError (interp), NULL);
 194     return TCL_ERROR;
 195   }
 196
 197   filesize = statbuf.st_size;
 198
 199   char* buf = new char[filesize];
 200   if (::read (rfd, buf, filesize) != filesize)
 201   {
 202     Tcl_AppendResult (interp, "can't read \"", rfn, "\": ", Tcl_PosixError (interp), NULL);
 203     delete buf;
 204     return TCL_ERROR;
 205   }
 206
 207   AsnBuf inputBuf;
 208   inputBuf.InstallData (buf, filesize);
 209
 210   size_t decodedLen = 0;
 211   jmp_buf env;
 212   int eval;
 213   if (eval = setjmp (env))
 214   {
 215     char eno[80];
 216     sprintf (eno, "%d", eval);
 217     Tcl_AppendResult (interp, "can't decode (error ", eno, ")", NULL);
 218     Tcl_SetErrorCode (interp, "SNACC", "DECODE", eno, NULL);
 219     delete buf;
 220     return TCL_ERROR;
 221   }
 222   pdu->BDec (inputBuf, decodedLen, env);
 223   if (inputBuf.ReadError())
 224   {
 225     Tcl_AppendResult (interp, "can't decode, out of data", NULL);
 226     Tcl_SetErrorCode (interp, "SNACC", "DECODE", "EOBUF", NULL);
 227     delete buf;
 228     return TCL_ERROR;
 229   }
 230
 231 #if DEBUG
 232 cout << "DECODED:" << endl << *pdu << endl;
 233 #endif
 234
 235   if (decodedLen != filesize)
 236     sprintf (interp->result, "decoded %d of %d bytes", decodedLen, filesize);
 237
 238   delete buf;
 239   return TCL_OK;
 240 }
 241
 242 int ASN1File::write (Tcl_Interp *interp, const char *wfn)
 243 {
 244   int wfd;
 245   TmpFD tmpfd;
 246
 247   if (wfn)
 248   {
 249     if ((wfd = open (wfn, O_CREAT|O_TRUNC|O_WRONLY, 0666)) < 0)
 250     {
 251       Tcl_AppendResult (interp, "can't open \"", wfn, "\": ", Tcl_PosixError (interp), NULL);
 252       return TCL_ERROR;
 253     }
 254     tmpfd = wfd;
 255   }
 256   else if (fd < 0)
 257   {
 258     Tcl_AppendResult (interp, "can't write, file is not open", NULL);
 259     Tcl_SetErrorCode (interp, "SNACC", "MUSTOPEN", NULL);
 260     return TCL_ERROR;
 261   }
 262   else
 263   {
 264     wfn = fn;
 265     int flags;
 266     if ((flags = fcntl (fd, F_GETFL)) == -1)
 267     {
 268       Tcl_AppendResult (interp, "can't fcntl \"", wfn, "\": ", Tcl_PosixError (interp), NULL);
 269       return TCL_ERROR;
 270     }
 271     else
 272     {
 273       if ((flags & O_ACCMODE) == O_RDONLY)
 274       {
 275         Tcl_AppendResult (interp, "can't write, file is read only", NULL);
 276         Tcl_SetErrorCode (interp, "SNACC", "WRITE", "RDONLY", NULL);
 277         return TCL_ERROR;
 278       }
 279     }
 280     lseek (wfd = fd, 0l, SEEK_SET);
 281   }
 282
 283   size_t size = filesize ? filesize : 10240;
 284   char *buf;
 285   AsnBuf outputBuf;
 286   size_t encodedLen;
 287   for (;;)
 288   {
 289     size <<= 1;
 290     buf = new char[size];
 291     outputBuf.Init (buf, size);
 292     outputBuf.ResetInWriteRvsMode();
 293     encodedLen = pdu->BEnc (outputBuf);
 294     if (!outputBuf.WriteError())
 295       break;
 296     delete buf;
 297   }
 298
 299   outputBuf.ResetInReadMode();
 300   size_t hunklen = 8192;
 301   char* hunk = new char[hunklen];
 302   for (size_t written=0; written<encodedLen; written+=hunklen)
 303   {
 304     if (encodedLen-written < hunklen)
 305       hunklen = encodedLen - written;
 306     outputBuf.CopyOut (hunk, hunklen);
 307     if (::write (wfd, hunk, hunklen) != hunklen)
 308     {
 309       Tcl_AppendResult (interp, "write error on \"", wfn, "\": ", Tcl_PosixError (interp), NULL);
 310       delete hunk; // may affect errno
 311       delete buf; // may affect errno
 312       return TCL_ERROR;
 313     }
 314   }
 315
 316   delete hunk;
 317   delete buf;
 318
 319   filesize = encodedLen;
 320   if (!wfn)
 321     ftruncate (wfd, filesize);
 322
 323   return TCL_OK;
 324 }
 325
 326 //\[banner "import & export"]-------------------------------------------------------------------------------------------------------
 327 int import (Tcl_Interp *interp, int argc, char **argv)
 328 {
 329   if (argc != 2)
 330   {
 331     strcpy (interp->result, "wrong # args: should be \"snacc import filename\"");
 332     return TCL_ERROR;
 333   }
 334
 335   const char *fn = argv[1];
 336   int fd;
 337   if ((fd = open (fn, O_RDONLY)) < 0)
 338   {
 339     Tcl_AppendResult (interp, "can't open \"", fn, "\": ", Tcl_PosixError (interp), NULL);
 340     return TCL_ERROR;
 341   }
 342   TmpFD tmpfd (fd);
 343
 344   struct stat statbuf;
 345   if (fstat (fd, &statbuf))
 346   {
 347     Tcl_AppendResult (interp, "can't fstat \"", fn, "\"'s fd: ", Tcl_PosixError (interp), NULL);
 348     return TCL_ERROR;
 349   }
 350
 351   off_t filesize = statbuf.st_size;
 352
 353   char* ibuf = new char[filesize];
 354   if (::read (fd, ibuf, filesize) != filesize)
 355   {
 356     Tcl_AppendResult (interp, "read error on \"", fn, "\": ", Tcl_PosixError (interp), NULL);
 357     delete ibuf;
 358     return TCL_ERROR;
 359   }
 360
 361   int result = debinify (interp, ibuf, filesize);
 362   delete ibuf;
 363   return result;
 364 }
 365
 366 int export (Tcl_Interp *interp, int argc, char **argv)
 367 {
 368   if (argc != 3)
 369   {
 370     strcpy (interp->result, "wrong # args: should be \"snacc export str filename\"");
 371     return TCL_ERROR;
 372   }
 373
 374   const char *str = argv[1], *fn = argv[2];
 375   char* obuf = new char[strlen (str)]; // the binary buffer is as most as long as the escaped Tcl string.
 376   size_t olen;
 377   if (binify (interp, str, obuf, &olen) != TCL_OK)
 378   {
 379     delete obuf;
 380     return TCL_ERROR;
 381   }
 382
 383   int fd;
 384   if ((fd = open (fn, O_CREAT|O_TRUNC|O_WRONLY, 0666)) < 0)
 385   {
 386     Tcl_AppendResult (interp, "can't open \"", fn, "\": ", Tcl_PosixError (interp), NULL);
 387     delete obuf;
 388     return TCL_ERROR;
 389   }
 390   TmpFD tmpfd (fd);
 391
 392   if (::write (fd, obuf, olen) != olen)
 393   {
 394     Tcl_AppendResult (interp, "write error on \"", fn, "\": ", Tcl_PosixError (interp), NULL);
 395     delete obuf;
 396     return TCL_ERROR;
 397   }
 398
 399   delete obuf;
 400   return TCL_OK;
 401 }
 402
 403 //\[banner "ctor & dtor"]-----------------------------------------------------------------------------------------------------------
 404 SnaccTcl::SnaccTcl (Tcl_Interp *i)
 405 {
 406   interp = i;
 407
 408   Tcl_InitHashTable (&modules, TCL_STRING_KEYS);
 409   Tcl_InitHashTable (&types, TCL_STRING_KEYS);
 410
 411   const AsnModuleDesc **moddesc;
 412   for (moddesc=asnModuleDescs; *moddesc; moddesc++)
 413   {
 414     int created;
 415     Tcl_HashEntry *entry = Tcl_CreateHashEntry (&modules, (char*)(*moddesc)->name, &created);
 416     assert (created);
 417     Tcl_SetHashValue (entry, *moddesc);
 418
 419     const AsnTypeDesc **typedesc;
 420     for (typedesc=(*moddesc)->types; *typedesc; typedesc++)
 421     {
 422       char buf[1024];
 423       sprintf (buf, "%s %s", (*moddesc)->name, (*typedesc)->name);
 424       char *_typename = strdup (buf);
 425       int created;
 426       Tcl_HashEntry *entry = Tcl_CreateHashEntry (&types, _typename, &created);
 427       if (!created)
 428       {
 429         cerr << "fatal error: duplicate type " << _typename << endl;
 430         exit (1);
 431       }
 432       Tcl_SetHashValue (entry, *typedesc);
 433     }
 434   }
 435
 436   Tcl_InitHashTable (&files, TCL_STRING_KEYS);
 437 }
 438
 439 SnaccTcl::~SnaccTcl()
 440 {
 441   Tcl_DeleteHashTable (&files);
 442 }
 443
 444 //\[banner "utility functions"]-----------------------------------------------------------------------------------------------------
 445 const AsnTypeDesc *SnaccTcl::gettypedesc (const char *cmdname, const char *_typename)
 446 {
 447   Tcl_HashEntry *typedescentry;
 448   if (typedescentry = Tcl_FindHashEntry (&types, (char*)_typename))
 449     return (const AsnTypeDesc *)Tcl_GetHashValue (typedescentry);
 450   else
 451   {
 452     Tcl_SetErrorCode (interp, "SNACC", "ILLTYPE", NULL);
 453     Tcl_AppendResult (interp, "snacc ", cmdname, ": no type \"", _typename, "\"", NULL);
 454     return NULL;
 455   }
 456 }
 457
 458 //\[banner "data manipulation functions"]-------------------------------------------------------------------------------------------
 459 Tcl_HashEntry *SnaccTcl::create()
 460 {
 461   static unsigned int id;
 462   int created;
 463   Tcl_HashEntry *entry;
 464   do
 465   {
 466     sprintf (interp->result, "file%u", id++);
 467     entry = Tcl_CreateHashEntry (&files, interp->result, &created);
 468   }
 469   while (!created);
 470   return entry;
 471 }
 472
 473 int SnaccTcl::create (int argc, char **argv)
 474 {
 475   if (argc != 2)
 476   {
 477     strcpy (interp->result, "wrong # args: should be \"snacc create {module type}\"");
 478     return TCL_ERROR;
 479   }
 480
 481   const char    *_typename = argv[1];
 482   const AsnTypeDesc *typedesc;
 483   if (!(typedesc = gettypedesc ("type", _typename)))
 484     return TCL_ERROR;
 485
 486   Tcl_HashEntry *entry = create();
 487   ASN1File *file = new ASN1File (typedesc);
 488   Tcl_SetHashValue (entry, file);
 489
 490   return TCL_OK;
 491 }
 492
 493 //\[sep]----------------------------------------------------------------------------------------------------------------------------
 494 // snacc open {module type} filename ?flags? ?permissions?
 495
 496 int SnaccTcl::openfile (int argc, char **argv)
 497 {
 498   if (argc < 3 || argc > 5)
 499   {
 500     strcpy (interp->result, "wrong # args: should be \"snacc open {module type} filename ?flags? ?permissions?\"");
 501     return TCL_ERROR;
 502   }
 503
 504   const char    *_typename = argv[1];
 505   const char    *filename = argv[2];
 506   bool          rw_spec = false;
 507   int           oflags = 0, omode = 0666, fd = -1;
 508
 509   switch (argc)
 510   {
 511     case 5:
 512       if (Tcl_GetInt (interp, argv[4], &omode))
 513         return TCL_ERROR;
 514       // \(da fall thru
 515     case 4:
 516       {
 517         Args flags;
 518         if (Tcl_SplitList (interp, argv[3], &flags.c, &flags.v) != TCL_OK)
 519           return TCL_ERROR;
 520
 521         for (int i=0; i<flags.c; i++)
 522         {
 523           if (strniabbr ("truncate", flags.v[i], 1))
 524             oflags |= O_TRUNC;
 525           else if (strniabbr ("create", flags.v[i], 1))
 526             oflags |= O_CREAT;
 527           else if (!strcasecmp ("ro", flags.v[i]))
 528           {
 529             oflags |= O_RDONLY;
 530             rw_spec = true;
 531           }
 532           else if (!strcasecmp ("rw", flags.v[i]))
 533           {
 534             oflags |= O_RDWR;
 535             rw_spec = true;
 536           }
 537           else
 538           {
 539             Tcl_AppendResult (interp, "snacc open: illegal argument \"", flags.v[i], "\" in flags", NULL);
 540             return TCL_ERROR;
 541           }
 542         }
 543       }
 544       break;
 545   }
 546
 547   const AsnTypeDesc *typedesc;
 548   if (!(typedesc = gettypedesc ("open", _typename)))
 549     return TCL_ERROR;
 550
 551   if (rw_spec)
 552     fd = open (filename, oflags, omode);
 553   else
 554     if ((fd = open (filename, oflags | O_RDWR, omode)) < 0)
 555       fd = open (filename, oflags | O_RDONLY, omode);
 556
 557   if (fd < 0)
 558   {
 559     Tcl_AppendResult (interp, "can't open \"", filename, "\": ", Tcl_PosixError (interp), NULL);
 560     return TCL_ERROR;
 561   }
 562
 563   ASN1File *file = new ASN1File (typedesc, filename, fd);
 564   if (file->bad())
 565   {
 566     delete file;
 567     Tcl_AppendResult (interp, "internal error on \"", filename, "\": bad status", NULL);
 568     Tcl_SetErrorCode (interp, "SNACC", "OPEN", "BAD", NULL);
 569     return TCL_ERROR;
 570   }
 571
 572   Tcl_HashEntry *entry = create();
 573   Tcl_SetHashValue (entry, file);
 574
 575   return file->read (interp);
 576 }
 577
 578 //\[sep]----------------------------------------------------------------------------------------------------------------------------
 579 int SnaccTcl::finfo (int argc, char **argv)
 580 {
 581   if (argc != 2)
 582   {
 583     strcpy (interp->result, "wrong # args: should be \"snacc finfo file\"");
 584     return TCL_ERROR;
 585   }
 586
 587   Tcl_HashEntry *entry = Tcl_FindHashEntry (&files, argv[1]);
 588   if (!entry)
 589   {
 590     Tcl_AppendResult (interp, "no file named \"", argv[1], "\"", NULL);
 591     return TCL_ERROR;
 592   }
 593
 594   ASN1File *file = (ASN1File *)Tcl_GetHashValue (entry);
 595
 596   return file->finfo (interp);
 597 }
 598
 599 //\[sep]----------------------------------------------------------------------------------------------------------------------------
 600 // snacc read file ?{module type} filename?
 601
 602 int SnaccTcl::read (int argc, char **argv)
 603 {
 604   const char    *_typename, *filename;
 605
 606   switch (argc)
 607   {
 608     case 2: // reread from old fd
 609       _typename = filename = NULL;
 610       break;
 611     case 4:
 612       _typename = argv[2];
 613       filename = argv[3];
 614       break;
 615     default:
 616       strcpy (interp->result, "wrong # args: should be \"snacc read file ?{module type} filename?\"");
 617       return TCL_ERROR;
 618   }
 619
 620   Tcl_HashEntry *entry = Tcl_FindHashEntry (&files, argv[1]);
 621   if (!entry)
 622   {
 623     Tcl_AppendResult (interp, "no file named \"", argv[1], "\"", NULL);
 624     return TCL_ERROR;
 625   }
 626
 627   ASN1File *file = (ASN1File *)Tcl_GetHashValue (entry);
 628
 629   if (_typename)
 630   {
 631     const AsnTypeDesc *typedesc;
 632     if (!(typedesc = gettypedesc ("read", _typename)))
 633       return TCL_ERROR;
 634
 635     delete file;
 636     file = new ASN1File (typedesc);
 637     Tcl_SetHashValue (entry, file);
 638   }
 639
 640   return file->read (interp, filename);
 641 }
 642
 643 //\[sep]----------------------------------------------------------------------------------------------------------------------------
 644 int SnaccTcl::write (int argc, char **argv)
 645 {
 646   if (argc < 2 || argc > 3)
 647   {
 648     strcpy (interp->result, "wrong # args: should be \"snacc write file ?filename?\"");
 649     return TCL_ERROR;
 650   }
 651
 652   Tcl_HashEntry *entry = Tcl_FindHashEntry (&files, argv[1]);
 653   if (!entry)
 654   {
 655     Tcl_AppendResult (interp, "no file named \"", argv[1], "\"", NULL);
 656     return TCL_ERROR;
 657   }
 658
 659   ASN1File *file = (ASN1File *)Tcl_GetHashValue (entry);
 660
 661   return file->write (interp, argv[2]);
 662 }
 663
 664 //\[sep]----------------------------------------------------------------------------------------------------------------------------
 665 int SnaccTcl::closefile (int argc, char **argv)
 666 {
 667   if (argc != 2)
 668   {
 669     strcpy (interp->result, "wrong # args: should be \"snacc close file\"");
 670     return TCL_ERROR;
 671   }
 672
 673   Tcl_HashEntry *entry = Tcl_FindHashEntry (&files, argv[1]);
 674   if (!entry)
 675   {
 676     Tcl_AppendResult (interp, "no file named \"", argv[1], "\"", NULL);
 677     return TCL_ERROR;
 678   }
 679
 680   ASN1File *file = (ASN1File *)Tcl_GetHashValue (entry);
 681   delete file;
 682
 683   Tcl_DeleteHashEntry (entry);
 684
 685   return TCL_OK;
 686 }
 687
 688 //\[sep]----------------------------------------------------------------------------------------------------------------------------
 689 int SnaccTcl::modulesinfo (int argc, char **argv)
 690 {
 691   if (argc != 1)
 692   {
 693     strcpy (interp->result, "wrong # args: should be \"snacc modules\"");
 694     return TCL_ERROR;
 695   }
 696
 697   Tcl_HashEntry *moduleentry;
 698   Tcl_HashSearch hi;
 699   for (moduleentry=Tcl_FirstHashEntry (&modules, &hi); moduleentry; moduleentry=Tcl_NextHashEntry (&hi))
 700     Tcl_AppendElement (interp, Tcl_GetHashKey (&modules, moduleentry));
 701
 702   return TCL_OK;
 703 }
 704
 705 //\[sep]----------------------------------------------------------------------------------------------------------------------------
 706 int SnaccTcl::typesinfo (int argc, char **argv)
 707 {
 708   switch (argc)
 709   {
 710     case 1:
 711       Tcl_HashEntry *typeentry;
 712       Tcl_HashSearch hi;
 713       for (typeentry=Tcl_FirstHashEntry (&types, &hi); typeentry; typeentry=Tcl_NextHashEntry (&hi))
 714         Tcl_AppendElement (interp, Tcl_GetHashKey (&types, typeentry));
 715       return TCL_OK;
 716     case 2:
 717       Tcl_HashEntry *moduleentry;
 718       if (moduleentry = Tcl_FindHashEntry (&modules, argv[1]))
 719       {
 720         const AsnModuleDesc *moddesc = (const AsnModuleDesc *)Tcl_GetHashValue (moduleentry);
 721         const AsnTypeDesc **typedesc;
 722         for (typedesc=moddesc->types; *typedesc; typedesc++)
 723           Tcl_AppendElement (interp, (char*)(*typedesc)->name);
 724         return TCL_OK;
 725       }
 726       else
 727       {
 728         Tcl_AppendResult (interp, "snacc types: no module \"", argv[1], "\"", NULL);
 729         return TCL_ERROR;
 730       }
 731     default:
 732       strcpy (interp->result, "wrong # args: should be \"snacc types ?module?\"");
 733       return TCL_ERROR;
 734   }
 735 }
 736
 737 //\[sep]----------------------------------------------------------------------------------------------------------------------------
 738 int SnaccTcl::typeinfo (int argc, char **argv)
 739 {
 740   if (argc != 2)
 741   {
 742     strcpy (interp->result, "wrong # args: should be \"snacc type {module type}\"");
 743     return TCL_ERROR;
 744   }
 745
 746   const char    *_typename = argv[1];
 747   const AsnTypeDesc *typedesc;
 748   if (!(typedesc = gettypedesc ("type", _typename)))
 749     return TCL_ERROR;
 750
 751   Tcl_DString desc;
 752   Tcl_DStringInit (&desc);
 753   int rc = typedesc->TclGetDesc (&desc);
 754   Tcl_DStringResult (interp, &desc);
 755   return rc;
 756 }
 757
 758 //\[sep]----------------------------------------------------------------------------------------------------------------------------
 759 int SnaccTcl::info (int argc, char **argv)
 760 {
 761   if (argc != 2)
 762   {
 763     strcpy (interp->result, "wrong # args: should be \"snacc info path\"");
 764     return TCL_ERROR;
 765   }
 766
 767   Args path;
 768   if (Tcl_SplitList (interp, argv[1], &path.c, &path.v) != TCL_OK)
 769     return TCL_ERROR;
 770
 771   if (path.c < 1)
 772   {
 773     strcpy (interp->result, "snacc info: wrong # args in path");
 774     return TCL_ERROR;
 775   }
 776
 777   Tcl_HashEntry *entry = Tcl_FindHashEntry (&files, path.v[0]);
 778   if (!entry)
 779   {
 780     Tcl_AppendResult (interp, "snacc info: no file named \"", path.v[0], "\"", NULL);
 781     return TCL_ERROR;
 782   }
 783
 784   ASN1File *file = (ASN1File *)Tcl_GetHashValue (entry);
 785
 786   AsnType *var = (AsnType *)*file;
 787   for (int i=1; i<path.c; i++)
 788     if (!(var = var->_getref (path.v[i])))
 789     {
 790       Tcl_AppendResult (interp, "snacc info: illegal component \"", path.v[i], "\" in path", NULL);
 791       return TCL_ERROR;
 792     }
 793
 794   Tcl_DString desc;
 795   Tcl_DStringInit (&desc);
 796   int rc;
 797   if ((rc = var->_getdesc()->AsnTypeDesc::TclGetDesc (&desc)) == TCL_OK)
 798     rc = var->TclGetDesc (&desc);
 799   Tcl_DStringResult (interp, &desc);
 800   return rc;
 801 }
 802
 803 //\[sep]----------------------------------------------------------------------------------------------------------------------------
 804 int SnaccTcl::getval (int argc, char **argv)
 805 {
 806   if (argc != 2)
 807   {
 808     strcpy (interp->result, "wrong # args: should be \"snacc get path\"");
 809     return TCL_ERROR;
 810   }
 811
 812   Args path;
 813   if (Tcl_SplitList (interp, argv[1], &path.c, &path.v) != TCL_OK)
 814     return TCL_ERROR;
 815
 816   if (path.c < 1)
 817   {
 818     strcpy (interp->result, "snacc get: wrong # args in path");
 819     return TCL_ERROR;
 820   }
 821
 822   Tcl_HashEntry *entry = Tcl_FindHashEntry (&files, path.v[0]);
 823   if (!entry)
 824   {
 825     Tcl_AppendResult (interp, "snacc get: no file named \"", path.v[0], "\"", NULL);
 826     return TCL_ERROR;
 827   }
 828
 829   ASN1File *file = (ASN1File *)Tcl_GetHashValue (entry);
 830
 831   AsnType *var = (AsnType *)*file;
 832   for (int i=1; i<path.c; i++)
 833     if (!(var = var->_getref (path.v[i])))
 834     {
 835       Tcl_AppendResult (interp, "snacc get: illegal component \"", path.v[i], "\" in path", NULL);
 836       return TCL_ERROR;
 837     }
 838
 839   return var->TclGetVal (interp);
 840 }
 841
 842 //\[sep]----------------------------------------------------------------------------------------------------------------------------
 843 int SnaccTcl::test (int argc, char **argv)
 844 {
 845   if (argc != 2)
 846   {
 847     strcpy (interp->result, "wrong # args: should be \"snacc get path\"");
 848     return TCL_ERROR;
 849   }
 850
 851   Args path;
 852   if (Tcl_SplitList (interp, argv[1], &path.c, &path.v) != TCL_OK)
 853     return TCL_ERROR;
 854
 855   if (path.c < 1)
 856   {
 857     strcpy (interp->result, "snacc get: wrong # args in path");
 858     return TCL_ERROR;
 859   }
 860
 861   Tcl_HashEntry *entry = Tcl_FindHashEntry (&files, path.v[0]);
 862   if (!entry)
 863   {
 864     Tcl_AppendResult (interp, "snacc get: no file named \"", path.v[0], "\"", NULL);
 865     return TCL_ERROR;
 866   }
 867
 868   ASN1File *file = (ASN1File *)Tcl_GetHashValue (entry);
 869
 870   AsnType *var = (AsnType *)*file;
 871   for (int i=1; i<path.c; i++)
 872     if (!(var = var->_getref (path.v[i])))
 873     {
 874       Tcl_AppendResult (interp, "snacc test: illegal component \"", path.v[i], "\" in path", NULL);
 875       return TCL_ERROR;
 876     }
 877
 878 cout << *var;
 879   strstream s;
 880   s << *var;
 881   s.put ('\0');
 882   cout << strlen(s.str()) << endl;
 883   cout << s.str() << endl;
 884
 885   return TCL_OK;
 886 }
 887
 888 //\[sep]----------------------------------------------------------------------------------------------------------------------------
 889 int SnaccTcl::setval (int argc, char **argv)
 890 {
 891   if (argc != 3)
 892   {
 893     strcpy (interp->result, "wrong # args: should be \"snacc set path value\"");
 894     return TCL_ERROR;
 895   }
 896
 897   Args path;
 898   if (Tcl_SplitList (interp, argv[1], &path.c, &path.v) != TCL_OK)
 899     return TCL_ERROR;
 900
 901   if (path.c < 1)
 902   {
 903     strcpy (interp->result, "snacc set: wrong # args in path");
 904     return TCL_ERROR;
 905   }
 906
 907   Tcl_HashEntry *entry = Tcl_FindHashEntry (&files, path.v[0]);
 908   if (!entry)
 909   {
 910     Tcl_AppendResult (interp, "snacc set: no file named \"", path.v[0], "\"", NULL);
 911     return TCL_ERROR;
 912   }
 913
 914   ASN1File *file = (ASN1File *)Tcl_GetHashValue (entry);
 915
 916   AsnType *var = (AsnType *)*file;
 917   for (int i=1; i<path.c; i++)
 918     if (!(var = var->_getref (path.v[i], true)))
 919     {
 920       Tcl_AppendResult (interp, "snacc set: illegal component \"", path.v[i], "\" in path", NULL);
 921       return TCL_ERROR;
 922     }
 923
 924   return var->TclSetVal (interp, argv[2]);
 925 }
 926
 927 //\[sep]----------------------------------------------------------------------------------------------------------------------------
 928 int SnaccTcl::unsetval (int argc, char **argv)
 929 {
 930   if (argc != 2)
 931   {
 932     strcpy (interp->result, "wrong # args: should be \"snacc unset path\"");
 933     return TCL_ERROR;
 934   }
 935
 936   Args path;
 937   if (Tcl_SplitList (interp, argv[1], &path.c, &path.v) != TCL_OK)
 938     return TCL_ERROR;
 939
 940   if (path.c == 1)
 941   {
 942     strcpy (interp->result, "snacc unset: sorry, but you are not allowed to unset the file itself");
 943     return TCL_ERROR;
 944   }
 945   else if (path.c < 1)
 946   {
 947     strcpy (interp->result, "snacc unset: wrong # args in path");
 948     return TCL_ERROR;
 949   }
 950
 951   Tcl_HashEntry *entry = Tcl_FindHashEntry (&files, path.v[0]);
 952   if (!entry)
 953   {
 954     Tcl_AppendResult (interp, "snacc unset: no file named \"", path.v[0], "\"", NULL);
 955     return TCL_ERROR;
 956   }
 957
 958   ASN1File *file = (ASN1File *)Tcl_GetHashValue (entry);
 959
 960   AsnType *var = (AsnType *)*file;
 961   for (int i=1; i<path.c-1; i++)
 962   {
 963     if (!(var = var->_getref (path.v[i])))
 964     {
 965       Tcl_AppendResult (interp, "snacc unset: illegal component \"", path.v[i], "\" in path", NULL);
 966       return TCL_ERROR;
 967     }
 968   }
 969
 970   return var->TclUnsetVal (interp, path.v[path.c-1]);
 971 }
 972
 973 //\[sep]----------------------------------------------------------------------------------------------------------------------------
 974 int Snacc_Cmd (ClientData cd, Tcl_Interp *interp, int argc, char **argv)
 975 {
 976   SnaccTcl *ed = (SnaccTcl *)cd;
 977
 978 #ifdef DEBUG
 979   ed->ckip (interp);
 980 #endif
 981
 982   if (argc < 2)
 983   {
 984     strcpy (interp->result, "wrong # args: should be \"snacc option arg ?arg ...?\"");
 985     return TCL_ERROR;
 986   }
 987   --argc;
 988   argv++;
 989
 990   switch (**argv)
 991   {
 992     case 'c':
 993       if (!strcmp (*argv, "close"))
 994         return ed->closefile (argc, argv);
 995       else if (!strcmp (*argv, "create"))
 996         return ed->create (argc, argv);
 997       break;
 998     case 'e':
 999       if (!strcmp (*argv, "export"))
1000         return export (interp, argc, argv);
1001       break;
1002     case 'f':
1003       if (!strcmp (*argv, "finfo"))
1004         return ed->finfo (argc, argv);
1005       break;
1006     case 'g':
1007       if (!strcmp (*argv, "get"))
1008         return ed->getval (argc, argv);
1009       break;
1010     case 'i':
1011       if (!strcmp (*argv, "import"))
1012         return import (interp, argc, argv);
1013       else if (!strcmp (*argv, "info"))
1014         return ed->info (argc, argv);
1015       break;
1016     case 'm':
1017       if (!strcmp (*argv, "modules"))
1018         return ed->modulesinfo (argc, argv);
1019       break;
1020     case 'o':
1021       if (!strcmp (*argv, "open"))
1022         return ed->openfile (argc, argv);
1023       break;
1024     case 'r':
1025       if (!strcmp (*argv, "read"))
1026         return ed->read (argc, argv);
1027       break;
1028     case 's':
1029       if (!strcmp (*argv, "set"))
1030         return ed->setval (argc, argv);
1031       break;
1032     case 't':
1033       if (!strcmp (*argv, "test"))
1034         return ed->test (argc, argv);
1035       else if (!strcmp (*argv, "type"))
1036         return ed->typeinfo (argc, argv);
1037       else if (!strcmp (*argv, "types"))
1038         return ed->typesinfo (argc, argv);
1039       break;
1040     case 'u':
1041       if (!strcmp (*argv, "unset"))
1042         return ed->unsetval (argc, argv);
1043       break;
1044     case 'w':
1045       if (!strcmp (*argv, "write"))
1046         return ed->write (argc, argv);
1047       break;
1048   }
1049   sprintf (interp->result, "bad command option %s: should be close, create, export, finfo, get, import, info, modules, open, read, set, type, types, unset or write", *argv);
1050
1051   return TCL_ERROR;
1052 }
1053
1054 //\[banner "check for proper initialization & finalization"]------------------------------------------------------------------------
1055
1056 struct check
1057 {
1058   int   i, j;
1059
1060         check (int);
1061
1062   bool  bad();
1063 };
1064
1065 static int cki;
1066
1067 check::check (int v)
1068 {
1069   i = v;
1070   j = ~i;
1071 }
1072
1073 #define CK      42
1074
1075 bool check::bad()
1076 {
1077   return i != CK || j != ~CK;
1078 }
1079
1080 check   check (CK);
1081
1082 //\[banner "initialization & finalization"]-----------------------------------------------------------------------------------------
1083 void Snacc_Exit (ClientData data)
1084 {
1085   delete (SnaccTcl *)data;
1086 }
1087
1088 // prohibit function name mangling to enable tkAppInit.c:Tcl_AppInit() to call this function:
1089 extern "C" int Snacc_Init (Tcl_Interp *interp)
1090 {
1091   if (check.bad())
1092   {
1093     static const char emsg[] = "linkage error, constructors of static variables didn't get called!\n";
1094     write (2, emsg, sizeof emsg);
1095     exit (1);
1096   }
1097
1098   SnaccTcl *data = new SnaccTcl (interp);
1099   Tcl_CreateCommand (interp, "snacc", Snacc_Cmd, (ClientData)data, Snacc_Exit);
1100   return TCL_OK;
1101 }
1102
1103 #endif // TCL