regina/envir.c

   1 #ifndef lint
   2 static char *RCSid = "$Id$";
   3 #endif
   4
   5 /*
   6  *  The Regina Rexx Interpreter
   7  *  Copyright (C) 1993-1994  Anders Christensen <anders@pvv.unit.no>
   8  *
   9  *  This library is free software; you can redistribute it and/or
  10  *  modify it under the terms of the GNU Library General Public
  11  *  License as published by the Free Software Foundation; either
  12  *  version 2 of the License, or (at your option) any later version.
  13  *
  14  *  This library is distributed in the hope that it will be useful,
  15  *  but WITHOUT ANY WARRANTY; without even the implied warranty of
  16  *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17  *  Library General Public License for more details.
  18  *
  19  *  You should have received a copy of the GNU Library General Public
  20  *  License along with this library; if not, write to the Free
  21  *  Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  22  */
  23
  24 #include "rexx.h"
  25 #include "envir.h"
  26
  27 #include <string.h>
  28
  29 #ifdef HAVE_CTYPE_H
  30 # include <ctype.h>
  31 #endif
  32
  33 #if defined(VMS)
  34 # define fork() vfork()
  35 # ifdef posix_do_command
  36 #  undef posix_do_command
  37 # endif
  38 # define posix_do_command __regina_vms_do_command
  39 #endif
  40
  41 /* clear_environpart sets initial values of an environpart.
  42  * attention: cleanup_environpart() closes open file handles and removes
  43  *            temporary files, this function not.
  44  */
  45 static void clear_environpart(environpart *ep)
  46 {
  47    ep->currnum = -1 ;
  48    ep->maxnum = -1 ;
  49    ep->SameAsOutput = 0;
  50    ep->FileRedirected = 0;
  51    ep->tempname = NULL ;
  52    ep->type = 0 ;
  53    ep->hdls[1] = ep->hdls[0] = -1;
  54 }
  55
  56 void add_envir( tsd_t *TSD, const streng *name, int type, int subtype )
  57 /* an environment with the same name can be added more than once! */
  58 {
  59    struct envir *ptr=NULL ;
  60
  61    ptr = MallocTSD( sizeof(struct envir)) ;
  62    memset( &ptr->e, 0, sizeof(ptr->e) ) ;
  63    clear_environpart(&ptr->e.input);
  64    clear_environpart(&ptr->e.output);
  65    clear_environpart(&ptr->e.error);
  66
  67    ptr->e.name = Str_dupTSD( name ) ;
  68    ptr->e.subtype = subtype ;
  69    ptr->type = type ;
  70    ptr->prev = TSD->firstenvir ;
  71    ptr->next = NULL ;
  72    TSD->firstenvir = ptr ;
  73    if (ptr->prev)
  74       ptr->prev->next = ptr ;
  75 }
  76
  77 #ifdef TRACEMEM
  78 static void markenvir( const tsd_t *TSD )
  79 {
  80    struct envir *eptr=NULL ;
  81
  82    eptr = TSD->firstenvir ;
  83    for (; eptr; eptr=eptr->prev )
  84    {
  85       markmemory( eptr, TRC_ENVIRBOX ) ;
  86       markmemory( eptr->e.name, TRC_ENVIRNAME ) ;
  87       if (eptr->e.input.name)
  88          markmemory( eptr->e.input.name, TRC_ENVIRNAME ) ;
  89       if (eptr->e.output.name)
  90          markmemory( eptr->e.output.name, TRC_ENVIRNAME ) ;
  91       if (eptr->e.error.name)
  92          markmemory( eptr->e.error.name, TRC_ENVIRNAME ) ;
  93    }
  94 }
  95 #endif /* TRACEMEM */
  96
  97
  98 static struct envir *find_envir( const tsd_t *TSD, const streng *name )
  99 {
 100    struct envir *ptr=NULL ;
 101
 102 #if defined(_AMIGA) || defined(__AROS__)
 103    if ((ptr=amiga_find_envir( TSD, name))!=NULL)
 104       return ptr;
 105 #endif
 106
 107    for (ptr=TSD->firstenvir; ptr; ptr=ptr->prev)
 108       if (!Str_cmp(ptr->e.name, name))
 109          return ptr ;
 110
 111    return NULL ;
 112 }
 113
 114 /*
 115  * This function is used to determine if an environment exists. It is the
 116  * external equivalent of find_envir()
 117  */
 118 int envir_exists( const tsd_t *TSD, const streng *name )
 119 {
 120    if ( find_envir( TSD, name ) == NULL )
 121       return 0;
 122    else
 123       return 1;
 124 }
 125
 126 static void del_envirpart( const tsd_t *TSD, environpart *e )
 127 /* Deletes all allocated parts of the environpart e.
 128  * The names are set to NULL afterwards, thus allowing multiple calls.
 129  */
 130 {
 131    if ( e->name )
 132       Free_stringTSD( e->name ) ;
 133    if ( e->base )
 134       Free_stringTSD( e->base ) ;
 135    if ( e->currname )
 136       Free_stringTSD( e->currname ) ;
 137    e->name =
 138    e->base =
 139    e->currname = NULL;
 140    /* Temporary files must be deleted under all circumstances! */
 141    cleanup_envirpart(TSD, e);
 142 }
 143
 144 void del_envir( tsd_t *TSD, const streng *name )
 145 /* Deletes all allocated parts of the environment with the given name and
 146  * removes it from the linked list.
 147  */
 148 {
 149    struct envir *ptr=NULL ;
 150
 151    ptr = find_envir( TSD, name ) ;
 152    if (!ptr)
 153       return;
 154
 155    if (ptr->prev)
 156       ptr->prev->next = ptr->next ;
 157    if (ptr->next)
 158       ptr->next->prev = ptr->prev ;
 159    if (TSD->firstenvir==ptr)
 160       TSD->firstenvir = ptr->prev ;
 161
 162    /* Delete the names in the environment */
 163    if ( ptr->e.name )
 164       Free_stringTSD( ptr->e.name ) ;
 165    del_envirpart( TSD, &ptr->e.input ) ;
 166    del_envirpart( TSD, &ptr->e.output ) ;
 167    del_envirpart( TSD, &ptr->e.error ) ;
 168    FreeTSD( ptr ) ;
 169 }
 170
 171 static void set_currname( const tsd_t *TSD, environpart *e )
 172 /* Sets the initial currname of the environpart from its name. e->currname
 173  * must be free previously.
 174  */
 175 {
 176    int len ;
 177
 178    /* we need space for "." and the maximal number */
 179    len = Str_len( e->name ) ;
 180    e->currname = Str_makeTSD( len + 3*sizeof(int) ) ;
 181    memcpy( e->currname->value, e->name->value, len ) ;
 182    e->currname->len = len ; /* pro forma, will be recomputed */
 183 }
 184
 185 static void update_environpart( const tsd_t *TSD, environpart *e,
 186                                                              const nodeptr new)
 187 /* e is the environpart which has to be reset. new is the new part and has
 188  * to been valid. new->name may be NULL (for NORMAL behaviour).
 189  */
 190 {
 191    del_envirpart( TSD, e ) ;
 192
 193    if (new->name)
 194    {
 195       e->name = Str_dupTSD( new->name ) ;
 196       e->base = Str_makeTSD( 3*sizeof(int) ) ;
 197       set_currname( TSD, e ) ;
 198    }
 199
 200    e->flags = new->u.of ;
 201    clear_environpart(e);
 202 }
 203
 204 int set_envir( const tsd_t *TSD, const streng *envirname, const nodeptr ios )
 205 /* This function sets all three IO-redirections INPUT, OUTPUT and ERROR.
 206  * ios->p[0] must be the redirection of INPUT,
 207  * ios->p[1] must be the redirection of OUTPUT,
 208  * ios->p[2] must be the redirection of ERROR
 209  * ios==NULL || envirname==NULL --> don't do anything.
 210  * ios->p[x]==NULL --> don't touch this redirection.
 211  * ios->p[x].name may be NULL (for NORMAL behaviour).
 212  *
 213  * The types of all four nodes may or may not be X_ADDR_WITH.
 214  *
 215  * returns 1 on success, 0 if the envirname doesn't exist.
 216  */
 217 {
 218    struct envir *e;
 219
 220    if ((envirname == NULL) || (ios == NULL))
 221       return( 1 ) ;
 222
 223    if ((e = find_envir( TSD, envirname )) == NULL)
 224       return( 0 ) ;
 225    if (ios->p[0]) update_environpart( TSD, &e->e.input,  ios->p[0] ) ;
 226    if (ios->p[1]) update_environpart( TSD, &e->e.output, ios->p[1] ) ;
 227    if (ios->p[2]) update_environpart( TSD, &e->e.error,  ios->p[2] ) ;
 228    e->e.input.flags.isinput = 1 ;
 229
 230    return( 1 ) ;
 231 }
 232
 233 static void dup_environpart( const tsd_t *TSD, environpart *dest,
 234                                  const nodeptr prefer, const environpart *src )
 235 /* Copies src to dest if prefer isn't set. In this case prefer is used.
 236  */
 237 {
 238    if (prefer)
 239       update_environpart( TSD, dest, prefer ) ;
 240    else
 241    {
 242       if (src->name)
 243       {
 244          dest->name = Str_dupTSD( src->name ) ;
 245          dest->base = Str_makeTSD( 3*sizeof(int) ) ;
 246          set_currname( TSD, dest ) ;
 247       }
 248       dest->flags = src->flags ;
 249    }
 250    clear_environpart(dest);
 251 }
 252
 253 static struct envir *dup_envir( tsd_t *TSD, const streng *name,
 254                                                             const nodeptr ios )
 255 /* This functions returns a new instance of the environment with the given
 256  * name or NULL if there is not such an environment name.
 257  * The current IO-redirection settings are overwritten with the
 258  * environment parts given in ios->p[0..2] for INPUT, OUTPUT and ERROR.
 259  */
 260 {
 261    struct envir *prev, *new ;
 262
 263    if ((prev = find_envir( TSD, name )) == NULL)
 264       return( NULL ) ;
 265
 266    add_envir( TSD, name, prev->type, prev->e.subtype ) ;
 267    new = TSD->firstenvir ;
 268
 269    dup_environpart( TSD, &new->e.input,  ios->p[0], &prev->e.input  ) ;
 270    dup_environpart( TSD, &new->e.output, ios->p[1], &prev->e.output ) ;
 271    dup_environpart( TSD, &new->e.error,  ios->p[2], &prev->e.error  ) ;
 272    new->e.input.flags.isinput = 1 ;
 273
 274    return( new ) ;
 275 }
 276
 277 int init_envir( tsd_t *TSD )
 278 {
 279    static const struct {
 280       const char *name ;
 281       int         subtype ;
 282    } locals[] = {
 283       { "COMMAND",        SUBENVIR_COMMAND } ,
 284       { "SYSTEM",         SUBENVIR_SYSTEM  } ,
 285       { "OS2ENVIRONMENT", SUBENVIR_SYSTEM  } ,
 286       { "ENVIRONMENT",    SUBENVIR_SYSTEM  } ,
 287       { "CMD",            SUBENVIR_COMMAND } ,
 288       { "PATH",           SUBENVIR_PATH    } ,
 289       { "REGINA",         SUBENVIR_REXX    } ,
 290       { "REXX",           SUBENVIR_REXX    }
 291    };
 292    unsigned i;
 293    streng *tmp;
 294
 295    for ( i = 0; i < sizeof(locals) / sizeof(locals[0]); i++ )
 296    {
 297       tmp = Str_creTSD( locals[i].name ) ;
 298       add_envir( TSD, tmp, ENVIR_SHELL, locals[i].subtype ) ;
 299       Free_stringTSD( tmp ) ;
 300    }
 301 #ifdef TRACEMEM
 302    regmarker( TSD, markenvir ) ;
 303 #endif
 304    return(1);
 305 }
 306
 307
 308 static int get_io_flag( tsd_t *TSD, streng *command, streng **rxqueue )
 309 {
 310    int length=0, i=0, pos=0 ;
 311    int flag=0,have_space=0 ;
 312    int qname_start,qname_end;
 313    streng *tmpq=NULL;
 314
 315    flag = REDIR_NONE ;
 316    /*
 317     * All I/O redirection valid with INTERNAL queues only
 318     */
 319    if ((length=Str_len(command)) > 5
 320    &&  (get_options_flag( TSD->currlevel, EXT_INTERNAL_QUEUES )
 321       ||   external_queues_used( TSD ) == 0 ) )
 322    {
 323       if ((!memcmp(command->value,"lifo>",5)) ||
 324           (!memcmp(command->value,"LIFO>",5)))
 325                flag |= REDIR_INPUT ;
 326
 327       if ((!memcmp(command->value+length-5,">lifo",5))
 328       ||  (!memcmp(command->value+length-5,">LIFO",5)))
 329       {
 330          flag |= REDIR_OUTLIFO ;
 331          command->len -= 5;
 332       }
 333       else
 334       {
 335          if ( ( !memcmp( command->value+length-5, ">fifo" ,5 ) )
 336          ||   ( !memcmp( command->value+length-5, ">FIFO", 5 ) ) )
 337          {
 338             flag |= REDIR_OUTFIFO ;
 339             command->len -= 5;
 340          }
 341          else
 342          {
 343             if ( length >= 8 )
 344             {
 345                int j = 0;
 346
 347                for ( i = 0, pos = -1; i < length; i++ )
 348                {
 349                   if ( *(command->value + i ) == '|' )
 350                   {
 351                      pos = i;
 352                      /* don't break here, as we want the last '|' */
 353                   }
 354                }
 355                if ( pos != -1 )
 356                {
 357                   /* allow "|" [whitespace] "rxqueue" [whitespace[args]] */
 358                   /* "|" already checked */
 359                   for ( i = pos + 1, j = 0; i < length; i++ )
 360                   {
 361                      if ( !isspace(command->value[i] ) )
 362                         break;
 363                   }
 364                   if ( i+7 <= length )
 365                   {
 366                      if (mem_cmpic( command->value + i, "RXQUEUE", 7 ) == 0 )
 367                      {
 368                         i += 7;
 369                         for ( ; i < length; i++ )
 370                         {
 371                            if ( !isspace( command->value[i] ) )
 372                               break;
 373                            have_space = 1;
 374                         }
 375                         if ( i == length )
 376                         {
 377                             flag |= REDIR_OUTFIFO ;
 378                             command->len = pos;
 379                         }
 380                         else if ( have_space )
 381                         {
 382                             if ( *(command->value + i) == '/' )
 383                             {
 384                                /*
 385                                 * Only a switch, not a queuename
 386                                 */
 387                                if ( i+6 <= length
 388                                &&   mem_cmpic( command->value + i, "/CLEAR", 6 ) == 0 )
 389                                {
 390                                   flag |= REDIR_CLEAR;
 391                                   flag |= REDIR_OUTFIFO ;
 392                                }
 393                                else if ( i+5 <= length )
 394                                {
 395                                   if (mem_cmpic( command->value + i, "/FIFO", 5 ) == 0 )
 396                                      flag |= REDIR_OUTFIFO ;
 397                                   else if (mem_cmpic( command->value + i, "/LIFO", 5 ) == 0 )
 398                                      flag |= REDIR_OUTLIFO ;
 399                                   else
 400                                      flag |= REDIR_OUTFIFO ;
 401                                   /*
 402                                    * Let the queue name be determined by the caller
 403                                    */
 404                                }
 405                             }
 406                             else
 407                             {
 408                                /*
 409                                 * First word must be a queue name, optionally
 410                                 * followed by a switch
 411                                 */
 412                                have_space = 0;
 413                                qname_start = i;
 414                                for ( ; i < length; i++ )
 415                                {
 416                                   if ( isspace( command->value[i] ) )
 417                                   {
 418                                      have_space = 1;
 419                                      qname_end = i;
 420                                      /*
 421                                       * Get queuename from RXQUEUE env
 422                                       * variable, or if not set, use SESSION
 423                                       */
 424                                      tmpq = Str_make_TSD( TSD, qname_end - qname_start );
 425                                      tmpq->len = qname_end - qname_start;
 426                                      memcpy( tmpq->value, command->value + qname_start, qname_end - qname_start );
 427                                      break;
 428                                   }
 429                                }
 430                                if ( have_space )
 431                                {
 432                                   /*
 433                                    * Eat up all spaces. If we have
 434                                    * any non-spaces left, it should be
 435                                    * a switch
 436                                    */
 437                                   for ( ; i < length; i++ )
 438                                   {
 439                                      if ( !isspace( command->value[i] ) )
 440                                         break;
 441                                   }
 442                                   if ( i+6 <= length
 443                                   &&   mem_cmpic( command->value + i, "/CLEAR", 6 ) == 0 )
 444                                   {
 445                                      flag |= REDIR_CLEAR;
 446                                      flag |= REDIR_OUTFIFO ;
 447                                   }
 448                                   else if ( i+5 <= length )
 449                                   {
 450                                      if (mem_cmpic( command->value + i, "/FIFO", 5 ) == 0 )
 451                                         flag |= REDIR_OUTFIFO ;
 452                                      else if (mem_cmpic( command->value + i, "/LIFO", 5 ) == 0 )
 453                                         flag |= REDIR_OUTLIFO ;
 454                                      else
 455                                         flag |= REDIR_OUTFIFO ;
 456                                   }
 457                                }
 458                                else
 459                                {
 460                                   /*
 461                                    * Only have a queue name
 462                                    */
 463                                   tmpq = Str_make_TSD( TSD, length - qname_start );
 464                                   tmpq->len = length - qname_start;
 465                                   memcpy( tmpq->value, command->value + qname_start, length - qname_start );
 466                                   flag |= REDIR_OUTFIFO ;
 467                                }
 468                             }
 469                             command->len = pos;
 470                         }
 471                      }
 472                   }
 473                }
 474             }
 475          }
 476       }
 477    }
 478
 479    if (flag & REDIR_INPUT)
 480    {
 481       for(i=5; i<Str_len(command); i++ ) /* avoid buffer overrun */
 482          command->value[i-5]=command->value[i] ;
 483       command->len -= 5 ;
 484    }
 485    *rxqueue = tmpq;
 486    return flag ;
 487 }
 488
 489
 490 streng *perform( tsd_t *TSD, const streng *command, const streng *envir, cnodeptr this )
 491 /* If and only if this->p[1] is set, a new instance of the environment is
 492  * temporarily created and reset to the new IO-redirections.
 493  */
 494 {
 495    int rc=0, io_flag=0, clearq=0, tempenvir=0;
 496    struct envir *eptr=NULL ;
 497    streng *retstr=NULL ;
 498    streng *rxqueue=NULL;
 499    streng *cmd=Str_dupTSD(command);
 500    streng *saved_queue=NULL;
 501    char *rxq=NULL;
 502    streng *rs;
 503
 504    if (this->p[1])
 505    {
 506       if (( eptr = dup_envir( TSD, envir, this->p[1] ) ) != NULL)
 507          tempenvir = 1 ;
 508    }
 509    else
 510    {
 511       eptr = find_envir( TSD, envir ) ;
 512    }
 513
 514    if (eptr)
 515    {
 516       if ( TSD->restricted
 517       &&   eptr->e.subtype )
 518          exiterror( ERR_RESTRICTED, 5 )  ;
 519       switch (eptr->type)
 520       {
 521          case ENVIR_PIPE:
 522             retstr = SubCom( TSD, cmd, envir, &rc ) ;
 523             break ;
 524
 525          case ENVIR_SHELL:
 526             io_flag = get_io_flag( TSD, cmd, &rxqueue ) ;
 527             /*
 528              * Save the current queue name
 529              * Then change it to the value of rxqueue
 530              * Only for internal queues
 531              */
 532             if ( get_options_flag( TSD->currlevel, EXT_INTERNAL_QUEUES ) )
 533             {
 534                /*
 535                 * If no queuename specified,
 536                 * get queuename from RXQUEUE env
 537                 * variable, or if not set, use SESSION
 538                 */
 539                if ( rxqueue == NULL )
 540                {
 541                   if ( ( rxq = getenv("RXQUEUE") ) == NULL )
 542                   {
 543                      rxqueue = Str_cre_TSD( TSD, "SESSION" );
 544                   }
 545                   else
 546                   {
 547                      rxqueue = Str_cre_TSD( TSD, rxq );
 548                   }
 549                }
 550                saved_queue = set_queue( TSD, rxqueue );
 551                if ( io_flag & REDIR_CLEAR )
 552                {
 553                   clearq = 1;
 554                   io_flag -= REDIR_CLEAR;
 555                }
 556             }
 557             rc = posix_do_command( TSD, cmd, io_flag, &eptr->e ) ;
 558             /*
 559              * Change the current queue name back
 560              * to the saved name
 561              */
 562             if ( get_options_flag( TSD->currlevel, EXT_INTERNAL_QUEUES ) )
 563             {
 564                if ( clearq )
 565                   drop_buffer( TSD, 0);
 566                set_queue( TSD, saved_queue );
 567                if ( rxqueue != NULL )
 568                   Free_stringTSD( rxqueue );
 569             }
 570             retstr = int_to_streng( TSD, rc ) ;
 571             break ;
 572
 573 #if defined(_AMIGA) || defined(__AROS__)
 574          case ENVIR_AMIGA:
 575             retstr = AmigaSubCom( TSD, cmd, eptr, &rc);
 576             break;
 577 #endif
 578
 579          default:
 580              exiterror( ERR_INTERPRETER_FAILURE, 1, __FILE__, __LINE__, "" )  ;
 581       }
 582    }
 583    else
 584    {
 585       retstr = SubCom( TSD, cmd, envir, &rc ) ;
 586    }
 587
 588    if (!TSD->systeminfo->interactive) /* J18PUB 8.2.4 */
 589       setvalue(TSD,&RC_name,Str_dupTSD(retstr)) ;
 590
 591    if (tempenvir)
 592       del_envir( TSD, envir ) ;
 593
 594    /* set .RS: -1==Failure, 0=OK, 1=Error */
 595    if (rc == 0)
 596       rs = int_to_streng(TSD, 0);
 597    else if (rc < 0)
 598       rs = int_to_streng(TSD, -1);
 599    else
 600       rs = int_to_streng(TSD, 1);
 601    setvalue(TSD, dotRS_name, rs);
 602
 603    if (rc && this)
 604    {
 605       trap *traps ;
 606       int type ;
 607
 608       traceerror( TSD, this, rc ) ;
 609       traps = gettraps( TSD, TSD->currlevel ) ;
 610       type = (rc>0) ? SIGNAL_ERROR : SIGNAL_FAILURE ;
 611
 612       if ((type==SIGNAL_FAILURE) && (traps[type].on_off))
 613          condition_hook( TSD, type, rc, 0, this->lineno, Str_dupTSD(cmd), NULL ) ;
 614       else if (traps[SIGNAL_ERROR].on_off)
 615          condition_hook( TSD, SIGNAL_ERROR, rc, 0, this->lineno, Str_dupTSD(cmd), NULL ) ;
 616    }
 617
 618    Free_stringTSD( cmd ) ;
 619    return retstr ;
 620 }
 621
 622 /* run_popen is a special implementation of a direct call to posix_do_command.
 623  * It redirects input and error to "normal" and fetches the output.
 624  * This output has blanks as line-delimiters. All lines are returned
 625  * concatenated on success; NULL is returned if an errors occurs.
 626  * The global variable "RC" contains the return code of the called process.
 627  *
 628  * The command is executed in the current environment. If the environment
 629  * isn't a standard environment, SYSTEM is used.
 630  */
 631 streng *run_popen( tsd_t *TSD, const streng *command, const streng *envir )
 632 {
 633    int rc;
 634    streng *retval;
 635    struct envir *ptr=NULL ;
 636
 637    for (ptr=TSD->firstenvir; ptr; ptr=ptr->prev)
 638    {
 639       if ((ptr->type == ENVIR_SHELL) && (Str_cmp(ptr->e.name, envir) == 0))
 640          break;
 641    }
 642    if (ptr == NULL)
 643    {
 644       retval = Str_creTSD("SYSTEM"); /* temporary misuse */
 645       ptr = find_envir(TSD, retval);
 646       Free_stringTSD(retval) ;
 647    }
 648
 649    /* Create a new environment with no redirections. */
 650    add_envir(TSD, ptr->e.name, ENVIR_SHELL, ptr->e.subtype);
 651
 652    rc = posix_do_command(TSD, command, REDIR_OUTSTRING, TSD->firstenvir);
 653    retval = stack_to_line(TSD);
 654
 655    /* restore the previous environment and delete the temporary one */
 656    del_envir(TSD, ptr->e.name);
 657
 658    setvalue(TSD, &RC_name, int_to_streng(TSD, rc));
 659
 660    if (rc >= 0)
 661       return(retval);
 662
 663    /* rc shows an error while calling: */
 664    Free_stringTSD(retval);
 665    return(NULL);
 666 }