regina/builtin.c

   1 /*
   2  *  The Regina Rexx Interpreter
   3  *  Copyright (C) 1992-1994  Anders Christensen <anders@pvv.unit.no>
   4  *
   5  *  This library is free software; you can redistribute it and/or
   6  *  modify it under the terms of the GNU Library General Public
   7  *  License as published by the Free Software Foundation; either
   8  *  version 2 of the License, or (at your option) any later version.
   9  *
  10  *  This library is distributed in the hope that it will be useful,
  11  *  but WITHOUT ANY WARRANTY; without even the implied warranty of
  12  *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13  *  Library General Public License for more details.
  14  *
  15  *  You should have received a copy of the GNU Library General Public
  16  *  License along with this library; if not, write to the Free
  17  *  Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  18  */
  19
  20 #include "rexx.h"
  21 #include <stdlib.h>
  22 #include <string.h>
  23 #include <math.h>
  24 #include <time.h>
  25 #include <stdio.h>
  26 #include <assert.h>
  27 #include <limits.h>
  28
  29 #ifdef HAVE_UNISTD_H
  30 #include <unistd.h>
  31 #endif
  32
  33 #ifdef HAVE_PROCESS_H
  34 #include <process.h>
  35 #endif
  36
  37 #ifdef SunKludges
  38 double pow( double, double ) ;
  39 #endif
  40
  41 #if defined(HAVE_PUTENV) && defined(FIX_PROTOS) && defined(ultrix)
  42 void putenv( char* );
  43 #endif
  44
  45 #define UPPERLETTER(a) ((((a)&0xdf)>='A')&&(((a)&0xdf)<='Z'))
  46 #define NUMERIC(a) (((a)>='0')&&((a)<='9'))
  47
  48 static const char *WeekDays[] = { "Sunday", "Monday", "Tuesday", "Wednesday",
  49                                   "Thursday", "Friday", "Saturday" } ;
  50 const char *months[] = { "January", "February", "March", "April", "May",
  51                          "June", "July", "August", "September", "October",
  52                          "November", "December" } ;
  53
  54 struct envirlist {
  55    struct envirlist *next ;
  56    streng *ptr ;
  57 };
  58
  59 typedef struct { /* bui_tsd: static variables of this module (thread-safe) */
  60    struct envirlist * first_envirvar;
  61    lineboxptr         srcline_ptr;      /* std_sourceline() */
  62    lineboxptr         srcline_first;    /* std_sourceline() */
  63    int                srcline_lineno;   /* std_sourceline() */
  64    int                seed;
  65 } bui_tsd_t; /* thread-specific but only needed by this module. see
  66               * init_builtin
  67               */
  68
  69 /* init_builtin initializes the module.
  70  * Currently, we set up the thread specific data.
  71  * The function returns 1 on success, 0 if memory is short.
  72  */
  73 int init_builtin( tsd_t *TSD )
  74 {
  75    bui_tsd_t *bt;
  76
  77    if (TSD->bui_tsd != NULL)
  78       return(1);
  79
  80    if ( ( TSD->bui_tsd = MallocTSD( sizeof(bui_tsd_t) ) ) == NULL )
  81       return(0);
  82    bt = (bui_tsd_t *)TSD->bui_tsd;
  83    memset( bt, 0, sizeof(bui_tsd_t) );  /* correct for all values */
  84
  85 #if defined(HAVE_RANDOM)
  86    srandom((int) (time((time_t *)0)+getpid())%(3600*24)) ;
  87 #else
  88    srand((unsigned) (time((time_t *)0)+getpid())%(3600*24)) ;
  89 #endif
  90    return(1);
  91 }
  92
  93 static int contained_in( const char *first, const char *fend, const char *second, const char *send )
  94 /*
  95  * Determines if one string exists in another string. Search is done
  96  * based on words.
  97  */
  98 {
  99    /*
 100     * Skip over any leading spaces in the search string
 101     */
 102    for (; (first<fend)&&(rx_isspace(*first)); first++)
 103    {
 104       ;
 105    }
 106    /*
 107     * Trim any trailing spaces in the search string
 108     */
 109    for (; (first<fend)&&(rx_isspace(*(fend-1))); fend--)
 110    {
 111       ;
 112    }
 113    /*
 114     * Skip over any leading spaces in the searched string
 115     */
 116    for (; (second<send)&&(rx_isspace(*second)); second++)
 117    {
 118       ;
 119    }
 120    /*
 121     * Trim any trailing spaces in the searched string
 122     */
 123    for (; (second<send)&&(rx_isspace(*(send-1))); send--)
 124    {
 125       ;
 126    }
 127    /*
 128     * If the length of the search string is less than the string to
 129     * search we won't find a match
 130     */
 131    if (fend-first > send-second)
 132       return 0;
 133
 134    for (; (first<fend); )
 135    {
 136       for (; (first<fend)&&(!rx_isspace(*first)); first++, second++)
 137       {
 138          if ((*first)!=(*second))
 139             return 0 ;
 140       }
 141
 142       if ((second<send)&&(!rx_isspace(*second)))
 143          return 0 ;
 144
 145       if (first==fend)
 146          return 1 ;
 147
 148       for (; (first<fend)&&(rx_isspace(*first)); first++)
 149       {
 150          ;
 151       }
 152       for (; (second<send)&&(rx_isspace(*second)); second++)
 153       {
 154          ;
 155       }
 156    }
 157
 158    return 1 ;
 159 }
 160
 161
 162 streng *std_wordpos( tsd_t *TSD, cparamboxptr parms )
 163 {
 164    streng *seek=NULL, *target=NULL ;
 165    char *sptr=NULL, *tptr=NULL, *end=NULL, *send=NULL ;
 166    int start=1, res=0 ;
 167
 168    checkparam(  parms,  2,  3 , "WORDPOS" ) ;
 169    seek = parms->value ;
 170    target = parms->next->value ;
 171    if ((parms->next->next)&&(parms->next->next->value))
 172       start = atopos( TSD, parms->next->next->value, "WORDPOS", 3 ) ;
 173
 174    end = target->value + Str_len(target) ;
 175    /* Then lets position right in the target */
 176    for (tptr=target->value; (tptr<end) && rx_isspace(*tptr) ; tptr++)  /* FGC: ordered */
 177    {
 178       ;
 179    }
 180    for (res=1; (res<start); res++)
 181    {
 182       for (; (tptr<end)&&(!rx_isspace(*tptr)); tptr++ )
 183       {
 184          ;
 185       }
 186       for (; (tptr<end) && rx_isspace(*tptr); tptr++ )
 187       {
 188          ;
 189       }
 190    }
 191
 192    send = seek->value + Str_len(seek) ;
 193    for (sptr=seek->value; (sptr<send) && rx_isspace(*sptr); sptr++)
 194    {
 195       ;
 196    }
 197    if (sptr<send)
 198    {
 199       for ( ; (sptr<send)&&(tptr<end); )
 200       {
 201          if (contained_in( sptr, send, tptr, end ))
 202             break ;
 203
 204          for (; (tptr<end)&&(!rx_isspace(*tptr)); tptr++)
 205          {
 206             ;
 207          }
 208          for (; (tptr<end)&&(rx_isspace(*tptr)); tptr++)
 209          {
 210             ;
 211          }
 212          res++ ;
 213       }
 214    }
 215    if ((sptr>=send)||((sptr<send)&&(tptr>=end)))
 216       res = 0 ;
 217
 218    return int_to_streng( TSD, res ) ;
 219 }
 220
 221
 222 streng *std_wordlength( tsd_t *TSD, cparamboxptr parms )
 223 {
 224    int i=0, number=0 ;
 225    streng *string=NULL ;
 226    char *ptr=NULL, *end=NULL ;
 227
 228    checkparam(  parms,  2,  2 , "WORDLENGTH" ) ;
 229    string = parms->value ;
 230    number = atopos( TSD, parms->next->value, "WORDLENGTH", 2 ) ;
 231
 232    end = (ptr=string->value) + Str_len(string) ;
 233    for (; (ptr<end) && rx_isspace(*ptr); ptr++)
 234    {
 235       ;
 236    }
 237    for (i=0; i<number-1; i++)
 238    {
 239       for (; (ptr<end)&&(!rx_isspace(*ptr)); ptr++)
 240       {
 241          ;
 242       }
 243       for (; (ptr<end)&&(rx_isspace(*ptr)); ptr++ )
 244       {
 245          ;
 246       }
 247    }
 248
 249    for (i=0; (((ptr+i)<end)&&(!rx_isspace(*(ptr+i)))); i++)
 250    {
 251       ;
 252    }
 253    return (int_to_streng( TSD,i)) ;
 254 }
 255
 256
 257
 258 streng *std_wordindex( tsd_t *TSD, cparamboxptr parms )
 259 {
 260    int i=0, number=0 ;
 261    streng *string=NULL ;
 262    char *ptr=NULL, *end=NULL ;
 263
 264    checkparam(  parms,  2,  2 , "WORDINDEX" ) ;
 265    string = parms->value ;
 266    number = atopos( TSD, parms->next->value, "WORDINDEX", 2 ) ;
 267
 268    end = (ptr=string->value) + Str_len(string) ;
 269    for (; (ptr<end) && rx_isspace(*ptr); ptr++)
 270    {
 271       ;
 272    }
 273    for (i=0; i<number-1; i++)
 274    {
 275       for (; (ptr<end)&&(!rx_isspace(*ptr)); ptr++)
 276       {
 277          ;
 278       }
 279       for (; (ptr<end)&&(rx_isspace(*ptr)); ptr++)
 280       {
 281          ;
 282       }
 283    }
 284
 285    return ( int_to_streng( TSD, (ptr<end) ? (ptr - string->value + 1 ) : 0) ) ;
 286 }
 287
 288
 289 streng *std_delword( tsd_t *TSD, cparamboxptr parms )
 290 {
 291    char *rptr=NULL, *cptr=NULL, *end=NULL ;
 292    streng *string=NULL ;
 293    int length=(-1), start=0, i=0 ;
 294
 295    checkparam(  parms,  2,  3 , "DELWORD" ) ;
 296    string = Str_dupTSD(parms->value) ;
 297    start = atopos( TSD, parms->next->value, "DELWORD", 2 ) ;
 298    if ((parms->next->next)&&(parms->next->next->value))
 299       length = atozpos( TSD, parms->next->next->value, "DELWORD", 3 ) ;
 300
 301    end = (cptr=string->value) + Str_len(string) ;
 302    for (; (cptr<end) && rx_isspace(*cptr); cptr++ )
 303    {
 304       ;
 305    }
 306    for (i=0; i<(start-1); i++)
 307    {
 308       for (; (cptr<end)&&(!rx_isspace(*cptr)); cptr++)
 309       {
 310          ;
 311       }
 312       for (; (cptr<end) && rx_isspace(*cptr); cptr++)
 313       {
 314          ;
 315       }
 316    }
 317
 318    rptr = cptr ;
 319    for (i=0; (i<(length))||((length==(-1))&&(cptr<end)); i++)
 320    {
 321       for (; (cptr<end)&&(!rx_isspace(*cptr)); cptr++ )
 322       {
 323          ;
 324       }
 325       for (; (cptr<end) && rx_isspace(*cptr); cptr++ )
 326       {
 327          ;
 328       }
 329    }
 330
 331    for (; (cptr<end);)
 332    {
 333       for (; (cptr<end)&&(!rx_isspace(*cptr)); *(rptr++) = *(cptr++))
 334       {
 335          ;
 336       }
 337       for (; (cptr<end) && rx_isspace(*cptr); *(rptr++) = *(cptr++))
 338       {
 339          ;
 340       }
 341    }
 342
 343    string->len = (rptr - string->value) ;
 344    return string ;
 345 }
 346
 347
 348 streng *std_xrange( tsd_t *TSD, cparamboxptr parms )
 349 {
 350    int start=0, stop=0xff, i=0, length=0 ;
 351    streng *result=NULL ;
 352
 353    checkparam(  parms,  0,  2 , "XRANGE" ) ;
 354    if ( parms->value )
 355       start = (unsigned char) getonechar( TSD, parms->value, "XRANGE", 1 ) ;
 356
 357    if ( ( parms->next )
 358    && ( parms->next->value ) )
 359       stop = (unsigned char) getonechar( TSD, parms->next->value, "XRANGE", 2 ) ;
 360
 361    length = stop - start + 1 ;
 362    if (length<1)
 363       length = 256 + length ;
 364
 365    result = Str_makeTSD( length ) ;
 366    for (i=0; (i<length); i++)
 367    {
 368       if (start==256)
 369         start = 0 ;
 370       result->value[i] = (char) start++ ;
 371    }
 372 /*    result->value[i] = (char) stop ; */
 373    result->len = i ;
 374
 375    return result ;
 376 }
 377
 378
 379 streng *std_lastpos( tsd_t *TSD, cparamboxptr parms )
 380 {
 381    int res=0, start=0, i=0, j=0, nomore=0 ;
 382    streng *needle=NULL, *heystack=NULL ;
 383
 384    checkparam(  parms,  2,  3 , "LASTPOS" ) ;
 385    needle = parms->value ;
 386    heystack = parms->next->value ;
 387    if ((parms->next->next)&&(parms->next->next->value))
 388       start = atopos( TSD, parms->next->next->value, "LASTPOS", 3 ) ;
 389    else
 390       start = Str_len( heystack ) ;
 391
 392    nomore = Str_len( needle ) ;
 393    if (start>Str_len(heystack))
 394       start = Str_len( heystack ) ;
 395
 396    if (nomore>start
 397    ||  nomore==0)
 398       res = 0 ;
 399    else
 400    {
 401       for (i=start-nomore ; i>=0; i-- )
 402       {
 403          /*
 404           * FGC: following loop was "<=nomore"
 405           */
 406          for (j=0; (j<nomore)&&(needle->value[j]==heystack->value[i+j]);j++) ;
 407          if (j>=nomore)
 408          {
 409             res = i + 1 ;
 410             break ;
 411          }
 412       }
 413    }
 414    return (int_to_streng( TSD,res)) ;
 415 }
 416
 417
 418
 419 streng *std_pos( tsd_t *TSD, cparamboxptr parms )
 420 {
 421    int start=1, res=0 ;
 422    streng *needle=NULL, *heystack=NULL ;
 423    checkparam(  parms,  2,  3 , "POS" ) ;
 424
 425    needle = parms->value ;
 426    heystack = parms->next->value ;
 427    if ((parms->next->next)&&(parms->next->next->value))
 428       start = atopos( TSD, parms->next->next->value, "POS", 3 ) ;
 429
 430    if ((!needle->len)
 431    ||  (!heystack->len)
 432    ||  (start>heystack->len))
 433       res = 0 ;
 434    else
 435    {
 436       res = bmstrstr(heystack, start-1, needle, 0) + 1 ;
 437    }
 438
 439    return (int_to_streng( TSD, res ) ) ;
 440 }
 441
 442
 443
 444 streng *std_subword( tsd_t *TSD, cparamboxptr parms )
 445 {
 446    int i=0, length=0, start=0 ;
 447    char *cptr=NULL, *eptr=NULL, *cend=NULL ;
 448    streng *string=NULL, *result=NULL ;
 449
 450    checkparam(  parms,  2,  3 , "SUBWORD" ) ;
 451    string = parms->value ;
 452    start = atopos( TSD, parms->next->value, "SUBWORD", 2 ) ;
 453    if ((parms->next->next)&&(parms->next->next->value))
 454       length = atozpos( TSD, parms->next->next->value, "SUBWORD", 3 ) ;
 455    else
 456       length = -1 ;
 457
 458    cptr = string->value ;
 459    cend = cptr + Str_len(string) ;
 460    for (i=1; i<start; i++)
 461    {
 462       for ( ; (cptr<cend)&&(rx_isspace(*cptr)); cptr++)
 463       {
 464          ;
 465       }
 466       for ( ; (cptr<cend)&&(!rx_isspace(*cptr)); cptr++)
 467       {
 468          ;
 469       }
 470    }
 471    for ( ; (cptr<cend)&&(rx_isspace(*cptr)); cptr++)
 472    {
 473       ;
 474    }
 475
 476    eptr = cptr ;
 477    if (length>=0)
 478    {
 479       for( i=0; (i<length); i++ )
 480       {
 481          for (;(eptr<cend)&&(rx_isspace(*eptr)); eptr++) /* wount hit 1st time */
 482          {
 483             ;
 484          }
 485          for (;(eptr<cend)&&(!rx_isspace(*eptr)); eptr++)
 486          {
 487             ;
 488          }
 489       }
 490    }
 491    else
 492       eptr = cend;
 493
 494    /* fixes bug 1113373 */
 495    while ((eptr > cptr) && rx_isspace(*(eptr-1)))
 496    {
 497       eptr--;
 498    }
 499
 500    result = Str_makeTSD( eptr-cptr ) ;
 501    memcpy( result->value, cptr, (eptr-cptr) ) ;
 502    result->len = (eptr-cptr) ;
 503
 504    return result ;
 505 }
 506
 507
 508
 509 streng *std_symbol( tsd_t *TSD, cparamboxptr parms )
 510 {
 511    int type=0 ;
 512
 513    checkparam(  parms,  1,  1 , "SYMBOL" ) ;
 514
 515    type = valid_var_symbol( parms->value ) ;
 516    if (type==SYMBOL_BAD)
 517       return Str_creTSD("BAD") ;
 518
 519    if ( ( type != SYMBOL_CONSTANT ) && ( type != SYMBOL_NUMBER ) )
 520    {
 521       assert(type==SYMBOL_STEM||type==SYMBOL_SIMPLE||type==SYMBOL_COMPOUND);
 522       if (isvariable(TSD, parms->value))
 523          return Str_creTSD("VAR") ;
 524    }
 525
 526    return Str_creTSD("LIT") ;
 527 }
 528
 529
 530 #if defined(TRACEMEM)
 531 static void mark_envirvars( const tsd_t *TSD )
 532 {
 533    struct envirlist *ptr=NULL ;
 534    bui_tsd_t *bt;
 535
 536    bt = (bui_tsd_t *) TSD->bui_tsd;
 537    for (ptr=bt->first_envirvar; ptr; ptr=ptr->next)
 538    {
 539       markmemory( ptr, TRC_STATIC ) ;
 540       markmemory( ptr->ptr, TRC_STATIC ) ;
 541    }
 542 }
 543
 544 static void add_new_env( const tsd_t *TSD, streng *ptr )
 545 {
 546    struct envirlist *newElem=NULL ;
 547    bui_tsd_t *bt;
 548
 549    bt = (bui_tsd_t *) TSD->bui_tsd;
 550    newElem = (struct envirlist *) MallocTSD( sizeof( struct envirlist )) ;
 551    newElem->next = bt->first_envirvar ;
 552    newElem->ptr = ptr ;
 553
 554    if (!bt->first_envirvar)
 555       regmarker( TSD, mark_envirvars ) ;
 556
 557    bt->first_envirvar = newElem ;
 558 }
 559 #endif
 560
 561 /*
 562  * ext_pool_value processes the request of the BIF value() and putenv() for the external
 563  * variable pool known as the "environment" in terms of the C library.
 564  *
 565  * name has to be a '\0'-terminated streng, value is either NULL or the
 566  * new content of the variable called name.
 567  */
 568 streng *ext_pool_value( tsd_t *TSD, streng *name, streng *value,
 569                                streng *env )
 570 {
 571    streng *retval=NULL;
 572    int ok=HOOK_GO_ON;
 573
 574    (env = env); /* Make the compiler happy */
 575
 576    /*
 577     * Get the current value from the exit if we have one, or from the
 578     * environment directly if not...
 579     */
 580    if ( TSD->systeminfo->hooks & HOOK_MASK( HOOK_GETENV ) )
 581       ok = hookup_input_output( TSD, HOOK_GETENV, name, &retval );
 582
 583 #ifdef VMS
 584    if ( ok == HOOK_GO_ON )
 585    {
 586       /*
 587        * Either there was no exit handler, or the exit handler didn't
 588        * handle the GETENV. Get the environment variable directly from
 589        * the system.
 590        */
 591       retval = vms_resolv_symbol( TSD, name, value, env );
 592    }
 593    else if ( value )
 594       exiterror( ERR_SYSTEM_FAILURE, 1, "No support for setting an environment variable" );
 595    /*
 596     * FIXME: What happens if value is set and HOOK_GO_ON isn't set?
 597     *        What happens with the different Pools SYMBOL, SYSTEM, LOGICAL?
 598     */
 599    return retval;
 600 #else
 601    if ( ok == HOOK_GO_ON )
 602    {
 603       char *val = mygetenv( TSD, name->value, NULL, 0 );
 604       if ( val )
 605       {
 606          retval = Str_creTSD( val );
 607          FreeTSD( val );
 608       }
 609    }
 610
 611    /*
 612     * retval is prepared. Check for setting a new value.
 613     */
 614    if ( value )
 615    {
 616       /*
 617        * We are setting a value in the external environment
 618        */
 619
 620       if ( TSD->restricted )
 621          exiterror( ERR_RESTRICTED, 2, "VALUE", 2 );
 622
 623       if ( TSD->systeminfo->hooks & HOOK_MASK( HOOK_SETENV ) )
 624          ok = hookup_output2( TSD, HOOK_SETENV, name, value );
 625
 626       if ( ok == HOOK_GO_ON )
 627       {
 628 # if defined(HAVE_MY_WIN32_SETENV)
 629          streng *strvalue = Str_dupstrTSD( value );
 630
 631          TSD->OS->setenv(name->value, strvalue->value );
 632          Free_stringTSD( strvalue );
 633 # elif defined(HAVE_SETENV)
 634          streng *strvalue = Str_dupstrTSD( value );
 635
 636          setenv(name->value, strvalue->value, 1 );
 637          Free_stringTSD( strvalue );
 638 # elif defined(HAVE_PUTENV)
 639          /*
 640           * Note: we don't release the allocated memory, because the runtime
 641           * system might use the pointer itself, not the content.
 642           * (See glibc's documentation)
 643           */
 644          streng *newstr = Str_makeTSD( Str_len( name ) + Str_len( value ) + 2 );
 645
 646          Str_catTSD( newstr, name );
 647          Str_catstrTSD( newstr, "=" );
 648          Str_catTSD( newstr, value );
 649          newstr->value[Str_len(newstr)] = '\0';
 650
 651          putenv( newstr->value );
 652 #  ifdef TRACEMEM
 653          add_new_env( TSD, newstr );
 654 #  endif
 655 # else
 656          exiterror( ERR_SYSTEM_FAILURE, 1, "No support for setting an environment variable" );
 657 # endif /* HAVE_PUTENV */
 658       }
 659    }
 660
 661    return retval;
 662 #endif /* !VMS */
 663 }
 664
 665 /*
 666  * FGC, 07.04.2005
 667  * FIXME: We are not throwing 40.36, but I'm not sure we should at all.
 668  */
 669 streng *std_value( tsd_t *TSD, cparamboxptr parms )
 670 {
 671    streng *name,*retval;
 672    streng *value=NULL,*env=NULL;
 673    int i,err,pool=-1;
 674
 675    checkparam(  parms, 1, 3 , "VALUE" );
 676    name = Str_dupstrTSD( parms->value );
 677
 678    if ( parms->next )
 679    {
 680       value = parms->next->value;
 681       if ( parms->next->next )
 682          env = parms->next->next->value;
 683    }
 684
 685    if ( env )
 686    {
 687       i = Str_len( env );
 688       if ( ( ( i == 6  ) && ( memcmp( env->value, "SYSTEM", 6 ) == 0 ) )
 689       ||   ( ( i == 14 ) && ( memcmp( env->value, "OS2ENVIRONMENT", 14 ) == 0 ) )
 690       ||   ( ( i == 11 ) && ( memcmp( env->value, "ENVIRONMENT", 11 ) == 0 ) ) )
 691       {
 692          retval = ext_pool_value( TSD, name, value, env );
 693          Free_stringTSD( name );
 694          if ( retval == NULL )
 695             retval = nullstringptr();
 696
 697          return retval;
 698       }
 699
 700       pool = streng_to_int( TSD, env, &err );
 701
 702       /*
 703        * Accept a builtin pool if it is a number >= 0.
 704        */
 705       if ( pool < 0 )
 706          err = 1;
 707       if ( pool > TSD->currlevel->pool )
 708          err = 1;
 709       if ( err )
 710          exiterror( ERR_INCORRECT_CALL, 37, "VALUE", tmpstr_of( TSD, env ) );
 711    }
 712
 713    /*
 714     * Internal variable pool; ie Rexx variables. According to ANSI standard
 715     * need to uppercase the variable name first.
 716     */
 717    if ( !valid_var_symbol( name ) )
 718    {
 719       Free_stringTSD( name );
 720       exiterror( ERR_INCORRECT_CALL, 26, "VALUE", tmpstr_of( TSD, parms->value ) );
 721    }
 722
 723    Str_upper( name );
 724    retval = Str_dupTSD( get_it_anyway( TSD, name, pool ) );
 725    if ( value )
 726       setvalue( TSD, name, Str_dupTSD( value ), pool );
 727    Free_stringTSD( name );
 728
 729    return retval;
 730 }
 731
 732
 733 streng *std_abs( tsd_t *TSD, cparamboxptr parms )
 734 {
 735    checkparam(  parms, 1, 1 , "ABS" ) ;
 736    return str_abs( TSD, parms->value ) ;
 737 }
 738
 739
 740 streng *std_condition( tsd_t *TSD, cparamboxptr parms )
 741 {
 742    char opt='I' ;
 743    streng *result=NULL ;
 744    sigtype *sig=NULL ;
 745    trap *traps=NULL ;
 746    char buf[20];
 747
 748    checkparam(  parms,  0,  1 , "CONDITION" ) ;
 749
 750    if (parms&&parms->value)
 751       opt = getoptionchar( TSD, parms->value, "CONDITION", 1, "CEIDS", "" ) ;
 752
 753    result = NULL ;
 754    sig = getsigs(TSD->currlevel) ;
 755    if (sig)
 756       switch (opt)
 757       {
 758          case 'C':
 759             result = Str_creTSD( signalnames[sig->type] ) ;
 760             break ;
 761
 762          case 'I':
 763             result = Str_creTSD( (sig->invoke) ? "SIGNAL" : "CALL" ) ;
 764             break ;
 765
 766          case 'D':
 767             if (sig->descr)
 768                result = Str_dupTSD( sig->descr ) ;
 769             break ;
 770
 771          case 'E':
 772             if (sig->subrc)
 773                sprintf(buf, "%d.%d", sig->rc, sig->subrc );
 774             else
 775                sprintf(buf, "%d", sig->rc );
 776             result = Str_creTSD( buf ) ;
 777             break ;
 778
 779          case 'S':
 780             traps = gettraps( TSD, TSD->currlevel ) ;
 781             if (traps[sig->type].delayed)
 782                result = Str_creTSD( "DELAY" ) ;
 783             else
 784                result = Str_creTSD( (traps[sig->type].on_off) ? "ON" : "OFF" ) ;
 785             break ;
 786
 787          default:
 788             /* should not get here */
 789             break;
 790       }
 791
 792    if (!result)
 793        result = nullstringptr() ;
 794
 795    return result ;
 796 }
 797
 798
 799 streng *std_format( tsd_t *TSD, cparamboxptr parms )
 800 {
 801    streng *number=NULL ;
 802    int before=(-1), after=(-1) ;
 803    int esize=(-1), trigger=(-1) ;
 804    cparamboxptr ptr ;
 805
 806    checkparam( parms, 1, 5, "FORMAT" ) ;
 807    number = (ptr=parms)->value ;
 808
 809    if ((ptr) && ((ptr=ptr->next)!=NULL) && (ptr->value))
 810       before = atozpos( TSD, ptr->value, "FORMAT", 2 ) ;
 811
 812    if ((ptr) && ((ptr=ptr->next)!=NULL) && (ptr->value))
 813       after = atozpos( TSD, ptr->value, "FORMAT", 3 ) ;
 814
 815    if ((ptr) && ((ptr=ptr->next)!=NULL) && (ptr->value))
 816       esize = atozpos( TSD, ptr->value, "FORMAT", 4 ) ;
 817
 818    if ((ptr) && ((ptr=ptr->next)!=NULL) && (ptr->value))
 819       trigger = atozpos( TSD, ptr->value, "FORMAT", 5 ) ;
 820
 821    return str_format( TSD, number, before, after, esize, trigger ) ;
 822 }
 823
 824
 825
 826 streng *std_overlay( tsd_t *TSD, cparamboxptr parms )
 827 {
 828    streng *newstr=NULL, *oldstr=NULL, *retval=NULL ;
 829    char padch=' ' ;
 830    int length=0, spot=0, oldlen=0, i=0, j=0, k=0 ;
 831    paramboxptr tmpptr=NULL ;
 832
 833    checkparam( parms, 2, 5, "OVERLAY" ) ;
 834    newstr = parms->value ;
 835    oldstr = parms->next->value ;
 836    length = Str_len(newstr) ;
 837    oldlen = Str_len(oldstr) ;
 838    if (parms->next->next)
 839    {
 840       tmpptr = parms->next->next ;
 841       if (parms->next->next->value)
 842          spot = atopos( TSD, tmpptr->value, "OVERLAY", 3 ) ;
 843
 844       if (tmpptr->next)
 845       {
 846          tmpptr = tmpptr->next ;
 847          if (tmpptr->value)
 848             length = atozpos( TSD, tmpptr->value, "OVERLAY", 4 ) ;
 849          if ((tmpptr->next)&&(tmpptr->next->value))
 850             padch = getonechar( TSD, tmpptr->next->value, "OVERLAY", 5 ) ;
 851       }
 852    }
 853
 854    retval = Str_makeTSD(((spot+length-1>oldlen)?spot+length-1:oldlen)) ;
 855    for (j=i=0;(i<spot-1)&&(i<oldlen);retval->value[j++]=oldstr->value[i++]) ;
 856    for (;j<spot-1;retval->value[j++]=padch) ;
 857    for (k=0;(k<length)&&(Str_in(newstr,k));retval->value[j++]=newstr->value[k++])
 858       if (i<oldlen) i++ ;
 859
 860    for (;k++<length;retval->value[j++]=padch) if (oldlen>i) i++ ;
 861    for (;oldlen>i;retval->value[j++]=oldstr->value[i++]) ;
 862
 863    retval->len = j ;
 864    return retval ;
 865 }
 866
 867 streng *std_insert( tsd_t *TSD, cparamboxptr parms )
 868 {
 869    streng *newstr=NULL, *oldstr=NULL, *retval=NULL ;
 870    char padch=' ' ;
 871    int length=0, spot=0, oldlen=0, i=0, j=0, k=0 ;
 872    paramboxptr tmpptr=NULL ;
 873
 874    checkparam( parms, 2, 5, "INSERT" ) ;
 875    newstr = parms->value ;
 876    oldstr = parms->next->value ;
 877    length = Str_len(newstr) ;
 878    oldlen = Str_len(oldstr) ;
 879    if (parms->next->next)
 880    {
 881       tmpptr = parms->next->next ;
 882       if (parms->next->next->value)
 883          spot = atozpos( TSD, tmpptr->value, "INSERT", 3 ) ;
 884
 885       if (tmpptr->next)
 886       {
 887          tmpptr = tmpptr->next ;
 888          if (tmpptr->value)
 889             length = atozpos( TSD, tmpptr->value, "INSERT", 4 ) ;
 890          if ((tmpptr->next)&&(tmpptr->next->value))
 891             padch = getonechar( TSD, tmpptr->next->value, "INSERT", 5) ;
 892       }
 893    }
 894
 895    retval = Str_makeTSD(length+((spot>oldlen)?spot:oldlen)) ;
 896    for (j=i=0;(i<spot)&&(oldlen>i);retval->value[j++]=oldstr->value[i++]) ;
 897    for (;j<spot;retval->value[j++]=padch) ;
 898    for (k=0;(k<length)&&(Str_in(newstr,k));retval->value[j++]=newstr->value[k++]) ;
 899    for (;k++<length;retval->value[j++]=padch) ;
 900    for (;oldlen>i;retval->value[j++]=oldstr->value[i++]) ;
 901    retval->len = j ;
 902    return retval ;
 903 }
 904
 905
 906
 907 streng *std_time( tsd_t *TSD, cparamboxptr parms )
 908 {
 909    int hour=0 ;
 910    time_t unow=0, now=0, rnow=0 ;
 911    long usec=0L, sec=0L, timediff=0L ;
 912    char *ampm=NULL ;
 913    char format='N' ;
 914 #ifdef __CHECKER__
 915    /* Fix a bug by checker: */
 916    streng *answer=Str_makeTSD( 64 ) ;
 917 #else
 918    streng *answer=Str_makeTSD( 50 ) ;
 919 #endif
 920    streng *supptime=NULL;
 921    streng *str_suppformat=NULL;
 922    char suppformat = 'N' ;
 923    paramboxptr tmpptr=NULL;
 924    struct tm tmdata, *tmptr ;
 925
 926    checkparam(  parms,  0,  3 , "TIME" ) ;
 927    if ((parms)&&(parms->value))
 928       format = getoptionchar( TSD, parms->value, "TIME", 1, "CEHLMNORS", "JT" ) ;
 929
 930    if (parms->next)
 931    {
 932       tmpptr = parms->next ;
 933       if (parms->next->value)
 934          supptime = tmpptr->value ;
 935
 936       if (tmpptr->next)
 937       {
 938          tmpptr = tmpptr->next ;
 939          if (tmpptr->value)
 940          {
 941             str_suppformat = tmpptr->value;
 942             suppformat = getoptionchar( TSD, tmpptr->value, "TIME", 3, "CHLMNS", "T" ) ;
 943          }
 944       }
 945       else
 946       {
 947          suppformat = 'N';
 948       }
 949    }
 950
 951    if (TSD->currentnode->now)
 952    {
 953       now = TSD->currentnode->now->sec ;
 954       unow = TSD->currentnode->now->usec ;
 955    }
 956    else
 957    {
 958       getsecs(&now, &unow) ;
 959       TSD->currentnode->now = (rexx_time *)MallocTSD( sizeof( rexx_time ) ) ;
 960       TSD->currentnode->now->sec = now ;
 961       TSD->currentnode->now->usec = unow ;
 962    }
 963
 964    rnow = now ;
 965
 966    if (unow>=(500*1000)
 967    &&  format != 'L')
 968       now ++ ;
 969
 970
 971    if ((tmptr = localtime(&now)) != NULL)
 972       tmdata = *tmptr;
 973    else
 974       memset(&tmdata,0,sizeof(tmdata)); /* what shall we do in this case? */
 975
 976    if (supptime) /* time conversion required */
 977    {
 978       if (convert_time(TSD,supptime,suppformat,&tmdata,&unow))
 979       {
 980          char *p1, *p2;
 981          if (supptime && supptime->value)
 982             p1 = (char *) tmpstr_of( TSD, supptime ) ;
 983          else
 984             p1 = "";
 985          if (str_suppformat && str_suppformat->value)
 986             p2 = (char *) tmpstr_of( TSD, str_suppformat ) ;
 987          else
 988             p2 = "N";
 989          exiterror( ERR_INCORRECT_CALL, 19, "TIME", p1, p2 )  ;
 990       }
 991    }
 992
 993    switch (format)
 994    {
 995       case 'C':
 996          hour = tmdata.tm_hour ;
 997          ampm = (char *)( ( hour > 11 ) ? "pm" : "am" ) ;
 998          if ((hour=hour%12)==0)
 999             hour = 12 ;
1000          sprintf(answer->value, "%d:%02d%s", hour, tmdata.tm_min, ampm) ;
1001          answer->len = strlen(answer->value);
1002          break ;
1003
1004       case 'E':
1005       case 'R':
1006          sec = (long)((TSD->currlevel->rx_time.sec) ? rnow-TSD->currlevel->rx_time.sec : 0) ;
1007          usec = (long)((TSD->currlevel->rx_time.sec) ? unow-TSD->currlevel->rx_time.usec : 0) ;
1008
1009          if (usec<0)
1010          {
1011             usec += 1000000 ;
1012             sec-- ;
1013          }
1014
1015 /*         assert( usec>=0 && sec>=0 ) ; */
1016          if (!TSD->currlevel->rx_time.sec || format=='R')
1017          {
1018             TSD->currlevel->rx_time.sec = rnow ;
1019             TSD->currlevel->rx_time.usec = unow ;
1020          }
1021
1022          /*
1023           * We have to cast these since time_t can be 'any' type, and
1024           * the format specifier can not be set to correspond with time_t,
1025           * then be have to convert it. Besides, we use unsigned format
1026           * in order not to generate any illegal numbers
1027           */
1028          if (sec)
1029             sprintf(answer->value,"%ld.%06lu", (long)sec, (unsigned long)usec ) ;
1030          else
1031             sprintf(answer->value,".%06lu", (unsigned long)usec ) ;
1032          answer->len = strlen(answer->value);
1033          break ;
1034
1035       case 'H':
1036          sprintf(answer->value, "%d", tmdata.tm_hour) ;
1037          answer->len = strlen(answer->value);
1038          break ;
1039
1040       case 'J':
1041          sprintf(answer->value, "%.06f", cpu_time()) ;
1042          answer->len = strlen(answer->value);
1043          break ;
1044
1045       case 'L':
1046          sprintf(answer->value, "%02d:%02d:%02d.%06ld", tmdata.tm_hour,
1047                   tmdata.tm_min, tmdata.tm_sec, (long)unow ) ;
1048          answer->len = strlen(answer->value);
1049          break ;
1050
1051       case 'M':
1052          sprintf(answer->value, "%d", tmdata.tm_hour*60 + tmdata.tm_min) ;
1053          answer->len = strlen(answer->value);
1054          break ;
1055
1056       case 'N':
1057          sprintf(answer->value, "%02d:%02d:%02d", tmdata.tm_hour,
1058                       tmdata.tm_min, tmdata.tm_sec ) ;
1059          answer->len = strlen(answer->value);
1060          break ;
1061
1062       case 'O':
1063 #ifdef VMS
1064          timediff = mktime(localtime(&now));
1065 #else
1066          timediff = (long)(mktime(localtime(&now))-mktime(gmtime(&now)));
1067          tmptr = localtime(&now);
1068          if ( tmptr->tm_isdst )
1069             timediff += 3600;
1070 #endif
1071          sprintf(answer->value, "%ld%s",
1072                  timediff,(timediff)?"000000":"");
1073          answer->len = strlen(answer->value);
1074          break ;
1075
1076       case 'S':
1077          sprintf(answer->value, "%d", ((tmdata.tm_hour*60)+tmdata.tm_min)
1078                     *60 + tmdata.tm_sec) ;
1079          answer->len = strlen(answer->value);
1080          break ;
1081
1082       case 'T':
1083          rnow = mktime( &tmdata );
1084          sprintf(answer->value, "%ld", (long)rnow );
1085          answer->len = strlen(answer->value);
1086          break ;
1087
1088       default:
1089          /* should not get here */
1090          break;
1091    }
1092    return answer ;
1093 }
1094
1095 streng *std_date( tsd_t *TSD, cparamboxptr parms )
1096 {
1097    static const char *fmt = "%02d/%02d/%02d" ;
1098    static const char *sdate = "%04d%02d%02d" ;
1099    // static const char *iso = "%04d-%02d-%02d" ; // Unused
1100    char format = 'N' ;
1101    char suppformat = 'N' ;
1102    int length=0 ;
1103    const char *chptr=NULL ;
1104    streng *answer=Str_makeTSD( 50 ) ;
1105    paramboxptr tmpptr=NULL;
1106    streng *suppdate=NULL;
1107    streng *str_suppformat=NULL;
1108    struct tm tmdata, *tmptr ;
1109    time_t now=0, unow=0, rnow=0 ;
1110
1111    checkparam(  parms,  0,  3 , "DATE" ) ;
1112    if ((parms)&&(parms->value))
1113       format = getoptionchar( TSD, parms->value, "DATE", 1, "BDEMNOSUW", "CIJT" ) ;
1114
1115    if (parms->next)
1116    {
1117       tmpptr = parms->next ;
1118       if (parms->next->value)
1119          suppdate = tmpptr->value ;
1120
1121       if (tmpptr->next)
1122       {
1123          tmpptr = tmpptr->next ;
1124          if (tmpptr->value)
1125          {
1126             str_suppformat = tmpptr->value;
1127             suppformat = getoptionchar( TSD, tmpptr->value, "DATE", 3, "BDENOSU", "IT" ) ;
1128          }
1129       }
1130       else
1131       {
1132          suppformat = 'N';
1133       }
1134    }
1135
1136    if (TSD->currentnode->now)
1137    {
1138       now = TSD->currentnode->now->sec ;
1139       unow = TSD->currentnode->now->usec ;
1140    }
1141    else
1142    {
1143       getsecs(&now, &unow) ;
1144       TSD->currentnode->now = (rexx_time *)MallocTSD( sizeof( rexx_time ) ) ;
1145       TSD->currentnode->now->sec = now ;
1146       TSD->currentnode->now->usec = unow ;
1147    }
1148
1149    /*
1150     * MH - 3/3/2000
1151     * This should not be rounded up for dates. If this were
1152     * run at 11:59:59.500001 on 10 Jun, DATE would report back
1153     * 11 Jun!
1154    if (unow>=(500*1000))
1155       now ++ ;
1156    */
1157
1158    if ( ( tmptr = localtime( &now ) ) != NULL )
1159       tmdata = *tmptr;
1160    else
1161       memset( &tmdata, 0, sizeof( tmdata ) ); /* what shall we do in this case? */
1162    tmdata.tm_year += 1900;
1163
1164    if ( suppdate ) /* date conversion required */
1165    {
1166       if ( convert_date( TSD, suppdate, suppformat, &tmdata ) )
1167       {
1168          char *p1, *p2;
1169          if (suppdate && suppdate->value)
1170             p1 = (char *) tmpstr_of( TSD, suppdate ) ;
1171          else
1172             p1 = "";
1173          if (str_suppformat && str_suppformat->value)
1174             p2 = (char *) tmpstr_of( TSD, str_suppformat ) ;
1175          else
1176             p2 = "N";
1177          exiterror( ERR_INCORRECT_CALL, 19, "DATE", p1, p2 )  ;
1178       }
1179       /*
1180        * Check for crazy years...
1181        */
1182       if ( tmdata.tm_year < 0 || tmdata.tm_year > 9999 )
1183          exiterror( ERR_INCORRECT_CALL, 18, "DATE" )  ;
1184    }
1185
1186    switch (format)
1187    {
1188       case 'B':
1189          answer->len = sprintf( answer->value, "%d", tmdata.tm_yday + basedays( tmdata.tm_year ) );
1190          break ;
1191
1192       case 'C':
1193          length = tmdata.tm_yday + basedays(tmdata.tm_year); /* was +1 */
1194          answer->len = sprintf( answer->value, "%d", length-basedays( (tmdata.tm_year/100)*100)+1 ); /* bja */
1195          break ;
1196       case 'D':
1197          answer->len = sprintf( answer->value, "%d", tmdata.tm_yday + 1 );
1198          break ;
1199
1200       case 'E':
1201          answer->len = sprintf( answer->value, fmt, tmdata.tm_mday, tmdata.tm_mon+1, tmdata.tm_year%100 );
1202          break ;
1203
1204       case 'I':
1205          sprintf(answer->value, "%d", tmdata.tm_yday + (basedays(tmdata.tm_year)-basedays(1978)) + 1);
1206          answer->len = strlen(answer->value);
1207          break ;
1208
1209       case 'J':
1210          sprintf(answer->value, "%02d%d", tmdata.tm_year%100, tmdata.tm_yday + 1);
1211          answer->len = strlen(answer->value);
1212          break ;
1213
1214       case 'M':
1215          chptr = months[tmdata.tm_mon] ;
1216          answer->len = strlen( chptr );
1217          memcpy( answer->value, chptr, answer->len ) ;
1218          break ;
1219
1220       case 'N':
1221          chptr = months[tmdata.tm_mon] ;
1222          answer->len = sprintf( answer->value, "%d %c%c%c %4d", tmdata.tm_mday, chptr[0], chptr[1], chptr[2], tmdata.tm_year );
1223          break ;
1224
1225       case 'O':
1226          answer->len = sprintf( answer->value, fmt, tmdata.tm_year%100, tmdata.tm_mon+1, tmdata.tm_mday );
1227          break ;
1228
1229       case 'S':
1230          answer->len = sprintf(answer->value, sdate, tmdata.tm_year, tmdata.tm_mon+1, tmdata.tm_mday );
1231          break ;
1232
1233       case 'T':
1234          tmdata.tm_year -= 1900;
1235          rnow = mktime( &tmdata );
1236          answer->len = sprintf(answer->value, "%ld", (long)rnow );
1237          break ;
1238
1239       case 'U':
1240          answer->len = sprintf( answer->value, fmt, tmdata.tm_mon+1, tmdata.tm_mday, tmdata.tm_year%100 );
1241          break ;
1242
1243       case 'W':
1244          chptr = WeekDays[tmdata.tm_wday] ;
1245          answer->len = strlen(chptr);
1246          memcpy(answer->value, chptr, answer->len) ;
1247          break ;
1248
1249       default:
1250          /* should not get here */
1251          break;
1252    }
1253
1254    return ( answer );
1255 }
1256
1257
1258 streng *std_words( tsd_t *TSD, cparamboxptr parms )
1259 {
1260    int space=0, i=0, j=0 ;
1261    streng *string=NULL ;
1262    int send=0 ;
1263
1264    checkparam(  parms,  1,  1 , "WORDS" ) ;
1265    string = parms->value ;
1266
1267    send = Str_len(string) ;
1268    space = 1 ;
1269    for (i=j=0;send>i;i++) {
1270       if ((!space)&&(rx_isspace(string->value[i]))) j++ ;
1271       space = (rx_isspace(string->value[i])) ; }
1272
1273    if ((!space)&&(i>0)) j++ ;
1274    return( int_to_streng( TSD, j ) ) ;
1275 }
1276
1277
1278 streng *std_word( tsd_t *TSD, cparamboxptr parms )
1279 {
1280    streng *string=NULL, *result=NULL ;
1281    int i=0, j=0, finished=0, start=0, stop=0, number=0, space=0, slen=0 ;
1282
1283    checkparam(  parms,  2,  2 , "WORD" ) ;
1284    string = parms->value ;
1285    number = atopos( TSD, parms->next->value, "WORD", 2 ) ;
1286
1287    start = 0 ;
1288    stop = 0 ;
1289    finished = 0 ;
1290    space = 1 ;
1291    slen = Str_len(string) ;
1292    for (i=j=0;(slen>i)&&(!finished);i++)
1293    {
1294       if ((space)&&(!rx_isspace(string->value[i])))
1295          start = i ;
1296       if ((!space)&&(rx_isspace(string->value[i])))
1297       {
1298          stop = i ;
1299          finished = (++j==number) ;
1300       }
1301       space = (rx_isspace(string->value[i])) ;
1302    }
1303
1304    if ((!finished)&&(((number==j+1)&&(!space)) || ((number==j)&&(space))))
1305    {
1306       stop = i ;
1307       finished = 1 ;
1308    }
1309
1310    if (finished)
1311    {
1312       result = Str_makeTSD(stop-start) ; /* problems with length */
1313       result = Str_nocatTSD( result, string, stop-start, start) ;
1314       result->len = stop-start ;
1315    }
1316    else
1317       result = nullstringptr() ;
1318
1319    return result ;
1320 }
1321
1322
1323
1324
1325
1326 streng *std_address( tsd_t *TSD, cparamboxptr parms )
1327 {
1328    char opt = 'N';
1329
1330    checkparam(  parms,  0,  1 , "ADDRESS" ) ;
1331
1332    if ( parms && parms->value )
1333       opt = getoptionchar( TSD, parms->value, "ADDRESS", 1, "EINO", "" ) ;
1334
1335    update_envirs( TSD, TSD->currlevel ) ;
1336    if ( opt == 'N' )
1337       return Str_dupTSD( TSD->currlevel->environment ) ;
1338    else
1339    {
1340       return get_envir_details( TSD, opt, TSD->currlevel->environment );
1341    }
1342 }
1343
1344
1345 streng *std_digits( tsd_t *TSD, cparamboxptr parms )
1346 {
1347    checkparam(  parms,  0,  0 , "DIGITS" ) ;
1348    return int_to_streng( TSD, TSD->currlevel->currnumsize ) ;
1349 }
1350
1351
1352 streng *std_form( tsd_t *TSD, cparamboxptr parms )
1353 {
1354    checkparam(  parms,  0,  0 , "FORM" ) ;
1355    return Str_creTSD( numeric_forms[TSD->currlevel->numform] ) ;
1356 }
1357
1358
1359 streng *std_fuzz( tsd_t *TSD, cparamboxptr parms )
1360 {
1361    checkparam(  parms,  0,  0 , "FUZZ" ) ;
1362    return int_to_streng( TSD, TSD->currlevel->numfuzz ) ;
1363 }
1364
1365
1366 streng *std_abbrev( tsd_t *TSD, cparamboxptr parms )
1367 {
1368    int length=0, answer=0, i=0 ;
1369    streng *longstr=NULL, *shortstr=NULL ;
1370
1371    checkparam(  parms,  2,  3 , "ABBREV" ) ;
1372    longstr = parms->value ;
1373    shortstr = parms->next->value ;
1374
1375    if ((parms->next->next)&&(parms->next->next->value))
1376       length = atozpos( TSD, parms->next->next->value, "ABBREV", 3 ) ;
1377    else
1378       length = Str_len(shortstr) ;
1379
1380    answer = (Str_ncmp(shortstr,longstr,length)) ? 0 : 1 ;
1381
1382    if ((length>Str_len(shortstr))||(Str_len(shortstr)>Str_len(longstr)))
1383       answer = 0 ;
1384    else
1385    {
1386       for (i=length; i<Str_len(shortstr); i++)
1387          if (shortstr->value[i] != longstr->value[i])
1388             answer = 0 ;
1389    }
1390
1391    return int_to_streng( TSD, answer ) ;
1392 }
1393
1394
1395 streng *std_qualify( tsd_t *TSD, cparamboxptr parms )
1396 {
1397    streng *ret=NULL;
1398
1399    checkparam(  parms,  1,  1 , "QUALIFY" ) ;
1400    ret = ConfigStreamQualified( TSD, parms->value );
1401    /*
1402     * Returned streng is always MAX_PATH long, so it should be safe
1403     * to Nul terminate the ret->value
1404     */
1405    ret->value[ret->len] = '\0';
1406    return (ret) ;
1407 }
1408
1409 streng *std_queued( tsd_t *TSD, cparamboxptr parms )
1410 {
1411    int rc;
1412
1413    checkparam(  parms,  0,  0 , "QUEUED" );
1414    rc = lines_in_stack( TSD, NULL);
1415    return int_to_streng( TSD, ( rc < 0 ) ? 0 : rc );
1416 }
1417
1418
1419
1420 streng *std_strip( tsd_t *TSD, cparamboxptr parms )
1421 {
1422 #if defined(_AMIGA) || defined(__AROS__)
1423    char option='B', *padstr=" ", alloc=0;
1424 #else
1425    char option='B', padch=' ' ;
1426 #endif
1427    streng *input=NULL ;
1428    int leading=0, trailing=0, start=0, stop=0 ;
1429
1430    checkparam(  parms,  1,  3 , "STRIP" ) ;
1431    if ( ( parms->next )
1432    && ( parms->next->value ) )
1433       option = getoptionchar( TSD, parms->next->value, "STRIP", 2, "LTB", "" );
1434
1435    if ( ( parms->next )
1436    && ( parms->next->next )
1437    && ( parms->next->next->value ) )
1438 #if defined(_AMIGA) || defined(__AROS__)
1439    {
1440       padstr = str_of( TSD, parms->next->next->value ) ;
1441       alloc = 1;
1442    }
1443 #else
1444       padch = getonechar( TSD, parms->next->next->value, "STRIP", 3 ) ;
1445 #endif
1446
1447    input = parms->value ;
1448    leading = ((option=='B')||(option=='L')) ;
1449    trailing = ((option=='B')||(option=='T')) ;
1450
1451 #if defined(_AMIGA) || defined(__AROS__)
1452    for (start=0;(start<Str_len(input))&&strchr(padstr,input->value[start])&&(leading);start++) ;
1453    for (stop=Str_len(input)-1;(stop >=start)&&strchr(padstr,input->value[stop])&&(trailing);stop--) ;
1454 #else
1455    for (start=0;(start<Str_len(input))&&(input->value[start]==padch)&&(leading);start++) ;
1456    for (stop=Str_len(input)-1;(stop >=start)&&(input->value[stop]==padch)&&(trailing);stop--) ;
1457 #endif
1458    if (stop<start)
1459       stop = start - 1 ; /* FGC: If this happens, it will crash */
1460
1461 #if defined(_AMIGA) || defined(__AROS__)
1462    if (alloc)
1463       FreeTSD( padstr );
1464 #endif
1465    return Str_nocatTSD(Str_makeTSD(stop-start+2),input,stop-start+1, start) ;
1466 }
1467
1468
1469
1470 streng *std_space( tsd_t *TSD, cparamboxptr parms )
1471 {
1472    streng *retval=NULL, *string=NULL ;
1473    char padch=' ' ;
1474    int i=0, j=0, k=0, l=0, space=1, length=1, hole=0 ;
1475
1476    checkparam(  parms,  1,  3 , "SPACE" ) ;
1477    if ( ( parms->next )
1478    && ( parms->next->value ) )
1479       length = atozpos( TSD, parms->next->value, "SPACE", 2 ) ;
1480
1481    if ( ( parms->next )
1482    && ( parms->next->next )
1483    && ( parms->next->next->value ) )
1484       padch = getonechar( TSD, parms->next->next->value, "SPACE", 3 ) ;
1485
1486    string = parms->value ;
1487    for ( i = 0; Str_in( string, i ); i++ )
1488    {
1489       if ((space)&&(string->value[i]!=' ')) hole++ ;
1490       space = (string->value[i]==' ') ;
1491    }
1492
1493    space = 1 ;
1494    retval = Str_makeTSD(i + hole*length ) ;
1495    for (j=l=i=0;Str_in(string,i);i++)
1496    {
1497       if (!((space)&&(string->value[i]==' ')))
1498       {
1499          if ((space=(string->value[i]==' '))!=0)
1500             for (l=j,k=0;k<length;k++)
1501                retval->value[j++] = padch ;
1502          else
1503             retval->value[j++] = string->value[i] ;
1504       }
1505    }
1506
1507    retval->len = j ;
1508    if ((space)&&(j))
1509       retval->len -= length ;
1510
1511    return retval ;
1512 }
1513
1514
1515 streng *std_arg( tsd_t *TSD, cparamboxptr parms )
1516 {
1517    int number=0, retval=0, tmpval=0 ;
1518    char flag='N' ;
1519    streng *value=NULL ;
1520    paramboxptr ptr=NULL ;
1521
1522    checkparam(  parms,  0,  2 , "ARG" ) ;
1523    if ( ( parms )
1524    && ( parms->value ) )
1525    {
1526       number = atopos( TSD, parms->value, "ARG", 1 ) ;
1527       if ( parms->next )
1528          flag = getoptionchar( TSD, parms->next->value, "ARG", 2, "ENO", "" ) ;
1529    }
1530
1531    ptr = TSD->currlevel->args ;
1532    if (number==0)
1533    {
1534       for (retval=0,tmpval=1; ptr; ptr=ptr->next, tmpval++)
1535          if (ptr->value)
1536             retval = tmpval ;
1537
1538       value = int_to_streng( TSD, retval ) ;
1539    }
1540
1541    else
1542    {
1543       for (retval=1;(retval<number)&&(ptr)&&((ptr=ptr->next)!=NULL);retval++) ;
1544       switch (flag)
1545       {
1546          case 'E':
1547             retval = ((ptr)&&(ptr->value)) ;
1548             value = int_to_streng( TSD, retval ? 1 : 0 ) ;
1549             break;
1550          case 'O':
1551             retval = ((ptr)&&(ptr->value)) ;
1552             value = int_to_streng( TSD, retval ? 0 : 1 ) ;
1553             break;
1554          case 'N':
1555             if ((ptr)&&(ptr->value))
1556                value = Str_dupTSD(ptr->value) ;
1557             else
1558                value = nullstringptr() ;
1559             break;
1560       }
1561    }
1562
1563    return value ;
1564 }
1565
1566
1567 #define LOGIC_AND 0
1568 #define LOGIC_OR  1
1569 #define LOGIC_XOR 2
1570
1571
1572 static char logic( char first, char second, int ltype )
1573 {
1574    switch (ltype)
1575    {
1576       case ( LOGIC_AND ) : return (char)( first & second ) ;
1577       case ( LOGIC_OR  ) : return (char)( first | second ) ;
1578       case ( LOGIC_XOR ) : return (char)( first ^ second ) ;
1579       default :
1580          exiterror( ERR_INTERPRETER_FAILURE, 1, __FILE__, __LINE__, "" )  ;
1581    }
1582    /* not reached, next line only to satisfy compiler */
1583    return 'X' ;
1584 }
1585
1586
1587 static streng *misc_logic( tsd_t *TSD, int ltype, cparamboxptr parms, const char *bif, int argnum )
1588 {
1589    int length1=0, length2=0, i=0 ;
1590    char padch=' ' ;
1591    streng *kill=NULL ;
1592    streng *pad=NULL, *outstr=NULL, *str1=NULL, *str2=NULL ;
1593
1594    checkparam(  parms,  1,  3 , bif ) ;
1595    str1 = parms->value ;
1596
1597    str2 = (parms->next) ? (parms->next->value) : NULL ;
1598    if (str2 == NULL)
1599       kill = str2 = nullstringptr() ;
1600    else
1601       kill = NULL ;
1602
1603    if ((parms->next)&&(parms->next->next))
1604       pad = parms->next->next->value ;
1605    else
1606       pad = NULL ;
1607
1608    if (pad)
1609       padch = getonechar( TSD, pad, bif, argnum ) ;
1610 #ifdef lint
1611    else
1612       padch = ' ' ;
1613 #endif
1614
1615    length1 = Str_len(str1) ;
1616    length2 = Str_len(str2) ;
1617    if (length2 > length1 )
1618    {
1619       streng *tmp ;
1620       tmp = str2 ;
1621       str2 = str1 ;
1622       str1 = tmp ;
1623    }
1624
1625    outstr = Str_makeTSD( Str_len(str1) ) ;
1626
1627    for (i=0; Str_in(str2,i); i++)
1628       outstr->value[i] = logic( str1->value[i], str2->value[i], ltype ) ;
1629
1630    if (pad)
1631       for (; Str_in(str1,i); i++)
1632          outstr->value[i] = logic( str1->value[i], padch, ltype ) ;
1633    else
1634       for (; Str_in(str1,i); i++)
1635          outstr->value[i] = str1->value[i] ;
1636
1637    if (kill)
1638       Free_stringTSD( kill ) ;
1639    outstr->len = i ;
1640    return outstr ;
1641 }
1642
1643
1644 streng *std_bitand( tsd_t *TSD, cparamboxptr parms )
1645 {
1646    return misc_logic( TSD, LOGIC_AND, parms, "BITAND", 3 ) ;
1647 }
1648
1649 streng *std_bitor( tsd_t *TSD, cparamboxptr parms )
1650 {
1651    return misc_logic( TSD, LOGIC_OR, parms, "BITOR", 3 ) ;
1652 }
1653
1654 streng *std_bitxor( tsd_t *TSD, cparamboxptr parms )
1655 {
1656    return misc_logic( TSD, LOGIC_XOR, parms, "BITXOR", 3 ) ;
1657 }
1658
1659
1660 streng *std_center( tsd_t *TSD, cparamboxptr parms )
1661 {
1662    int length=0, i=0, j=0, start=0, stop=0, chars=0 ;
1663    char padch=' ' ;
1664    streng *pad=NULL, *str=NULL, *ptr=NULL ;
1665
1666    checkparam(  parms,  2,  3 , "CENTER" ) ;
1667    length = atozpos( TSD, parms->next->value, "CENTER", 2 ) ;
1668    str = parms->value ;
1669    if (parms->next->next!=NULL)
1670       pad = parms->next->next->value ;
1671    else
1672       pad = NULL ;
1673
1674    chars = Str_len(str) ;
1675    if (pad==NULL)
1676       padch = ' ' ;
1677    else
1678       padch = getonechar( TSD, pad, "CENTER", 3 ) ;
1679
1680    start = (chars>length) ? ((chars-length)/2) : 0 ;
1681    stop = (chars>length) ? (chars-(chars-length+1)/2) : chars ;
1682
1683    ptr = Str_makeTSD( length ) ;
1684    for (j=0;j<((length-chars)/2);ptr->value[j++]=padch) ;
1685    for (i=start;i<stop;ptr->value[j++]=str->value[i++]) ;
1686    for (;j<length;ptr->value[j++]=padch) ;
1687
1688    ptr->len = j ;
1689    assert((ptr->len<=ptr->max) && (j==length));
1690
1691    return ptr ;
1692 }
1693
1694 static unsigned num_sourcelines(const internal_parser_type *ipt)
1695 {
1696    const otree *otp;
1697
1698    if (ipt->first_source_line != NULL)
1699       return ipt->last_source_line->lineno ;
1700
1701    /* must be incore_source but that value may be NULL because of a failed
1702     * instore[0] of RexxStart!
1703     */
1704    if ((otp = ipt->srclines) == NULL)
1705       return 0; /* May happen if the user doesn't provides the true
1706                  * source. If you set it to 1 you must return anything
1707                  * below for that line.
1708                  */
1709    while (otp->next)
1710       otp = otp->next;
1711    return otp->sum + otp->num;
1712 }
1713
1714 streng *std_sourceline( tsd_t *TSD, cparamboxptr parms )
1715 {
1716    int line, i ;
1717    bui_tsd_t *bt;
1718    const internal_parser_type *ipt = &TSD->systeminfo->tree ;
1719    const otree *otp;
1720    streng *retval;
1721
1722    bt = (bui_tsd_t *)TSD->bui_tsd;
1723    checkparam(  parms,  0,  1 , "SOURCELINE" ) ;
1724    if (!parms->value)
1725       return int_to_streng( TSD, num_sourcelines( ipt ) ) ;
1726
1727    line = atopos( TSD, parms->value, "SOURCELINE", 1 ) ;
1728
1729    if (ipt->first_source_line == NULL)
1730    { /* must be incore_source but that value may be NULL because of a failed
1731       * instore[0] of RexxStart!
1732       */
1733       otp = ipt->srclines; /* NULL if incore_source==NULL */
1734       if (line > 0)
1735       {
1736          while (otp && ((int) otp->num < line))
1737          {
1738             line -= otp->num;
1739             otp = otp->next;
1740          }
1741       }
1742       if ((otp == NULL) || /* line not found or error */
1743           (line < 1))
1744       {
1745          exiterror( ERR_INCORRECT_CALL, 34, "SOURCELINE", 1, line, num_sourcelines( ipt ) )  ;
1746       }
1747
1748       line--;
1749       i = otp->elems[line].length ;
1750       retval = Str_makeTSD( i ) ;
1751       retval->len = i ;
1752       memcpy( retval->value, ipt->incore_source + otp->elems[line].offset, i ) ;
1753       return(retval);
1754    }
1755    if (bt->srcline_first != ipt->first_source_line)
1756    {
1757       bt->srcline_lineno = 1 ;
1758       bt->srcline_first =
1759       bt->srcline_ptr =
1760       ipt->first_source_line ;
1761    }
1762    for (;(bt->srcline_lineno<line);)
1763    {
1764       if ((bt->srcline_ptr=bt->srcline_ptr->next)==NULL)
1765       {
1766          exiterror( ERR_INCORRECT_CALL, 34, "SOURCELINE", 1, line, num_sourcelines( ipt ) )  ;
1767       }
1768       bt->srcline_lineno = bt->srcline_ptr->lineno ;
1769    }
1770    for (;(bt->srcline_lineno>line);)
1771    {
1772       if ((bt->srcline_ptr=bt->srcline_ptr->prev)==NULL)
1773          exiterror( ERR_INCORRECT_CALL, 0 )  ;
1774       bt->srcline_lineno = bt->srcline_ptr->lineno ;
1775    }
1776
1777    return Str_dupTSD(bt->srcline_ptr->line) ;
1778 }
1779
1780
1781 streng *std_compare( tsd_t *TSD, cparamboxptr parms )
1782 {
1783    char padch=' ' ;
1784    streng *pad=NULL, *str1=NULL, *str2=NULL ;
1785    int i=0, j=0, value=0 ;
1786
1787    checkparam(  parms,  2,  3 , "COMPARE" ) ;
1788    str1 = parms->value ;
1789    str2 = parms->next->value ;
1790    if (parms->next->next)
1791       pad = parms->next->next->value ;
1792    else
1793       pad = NULL ;
1794
1795    if (!pad)
1796       padch = ' ' ;
1797    else
1798       padch = getonechar( TSD, pad, "COMPARE", 3) ;
1799
1800    value=i=j=0 ;
1801    while ((Str_in(str1,i))||(Str_in(str2,j))) {
1802       if (((Str_in(str1,i))?(str1->value[i]):(padch))!=
1803           ((Str_in(str2,j))?(str2->value[j]):(padch))) {
1804          value = (i>j) ? i : j ;
1805          break ; }
1806       if (Str_in(str1,i)) i++ ;
1807       if (Str_in(str2,j)) j++ ; }
1808
1809    if ((!Str_in(str1,i))&&(!Str_in(str2,j)))
1810       value = 0 ;
1811    else
1812       value++ ;
1813
1814    return int_to_streng( TSD, value ) ;
1815 }
1816
1817
1818 streng *std_errortext( tsd_t *TSD, cparamboxptr parms )
1819 {
1820    char opt = 'N';
1821    streng *tmp,*tmp1,*tmp2;
1822    int numdec=0, errnum, suberrnum, pos=0, i;
1823 #if 0
1824    const char *err=NULL;
1825 #endif
1826
1827    checkparam(  parms,  1,  2 , "ERRORTEXT" ) ;
1828
1829    if (parms&&parms->next&&parms->next->value)
1830       opt = getoptionchar( TSD, parms->next->value, "ERRORTEXT", 2, "NS", "" ) ;
1831    tmp = Str_dupTSD( parms->value );
1832    for (i=0; i<Str_len( tmp); i++ )
1833    {
1834       if ( *( tmp->value+i ) == '.' )
1835       {
1836          numdec++;
1837          *( tmp->value+i) = '\0';
1838          pos = i;
1839       }
1840    }
1841    if ( numdec > 1 )
1842       exiterror( ERR_INCORRECT_CALL, 11, 1, tmpstr_of( TSD, parms->value ) )  ;
1843
1844    if ( numdec == 1 )
1845    {
1846       tmp1 = Str_ncreTSD( tmp->value, pos );
1847       tmp2 = Str_ncreTSD( tmp->value+pos+1, Str_len( tmp ) - pos - 1 );
1848       errnum = atoposorzero( TSD, tmp1, "ERRORTEXT", 1  );
1849       suberrnum = atoposorzero( TSD, tmp2, "ERRORTEXT", 1 );
1850       Free_stringTSD( tmp1 ) ;
1851       Free_stringTSD( tmp2 ) ;
1852    }
1853    else
1854    {
1855       errnum = atoposorzero( TSD, tmp, "ERRORTEXT", 1  );
1856       suberrnum = 0;
1857    }
1858    /*
1859     * Only restrict the error number passed if STRICT_ANSI is in effect.
1860     */
1861    if ( get_options_flag( TSD->currlevel, EXT_STRICT_ANSI )
1862    &&   ( errnum > 90 || suberrnum > 900 ) )
1863       exiterror( ERR_INCORRECT_CALL, 17, "ERRORTEXT", tmpstr_of( TSD, parms->value ) )  ;
1864
1865    Free_stringTSD( tmp ) ;
1866
1867    return Str_dupTSD( errortext( TSD, errnum, suberrnum, (opt=='S')?1:0, 1 ) ) ;
1868 }
1869
1870
1871 streng *std_length( tsd_t *TSD, cparamboxptr parms )
1872 {
1873    checkparam(  parms,  1,  1 , "LENGTH" ) ;
1874    return int_to_streng( TSD, Str_len( parms->value )) ;
1875 }
1876
1877
1878 streng *std_left( tsd_t *TSD, cparamboxptr parms )
1879 {
1880    int length=0, i=0 ;
1881    char padch=' ' ;
1882    streng *pad=NULL, *str=NULL, *ptr=NULL ;
1883
1884    checkparam(  parms,  2,  3 , "LEFT" ) ;
1885    length = atozpos( TSD, parms->next->value, "LEFT", 2 ) ;
1886    str = parms->value ;
1887    if (parms->next->next!=NULL)
1888       pad = parms->next->next->value ;
1889    else
1890       pad = NULL ;
1891
1892    if (pad==NULL)
1893       padch = ' ' ;
1894    else
1895       padch = getonechar( TSD, pad, "LEFT", 3) ;
1896
1897    ptr = Str_makeTSD( length ) ;
1898    for (i=0;(i<length)&&(Str_in(str,i));i++)
1899       ptr->value[i] = str->value[i] ;
1900
1901    for (;i<length;ptr->value[i++]=padch) ;
1902    ptr->len = length ;
1903
1904    return ptr ;
1905 }
1906
1907 streng *std_right( tsd_t *TSD, cparamboxptr parms )
1908 {
1909    int length=0, i=0, j=0 ;
1910    char padch=' ' ;
1911    streng *pad=NULL, *str=NULL, *ptr=NULL ;
1912
1913    checkparam(  parms,  2,  3 , "RIGHT" ) ;
1914    length = atozpos( TSD, parms->next->value, "RIGHT", 2 ) ;
1915    str = parms->value ;
1916    if (parms->next->next!=NULL)
1917       pad = parms->next->next->value ;
1918    else
1919       pad = NULL ;
1920
1921    if (pad==NULL)
1922       padch = ' ' ;
1923    else
1924       padch = getonechar( TSD, pad, "RIGHT", 3 ) ;
1925
1926    ptr = Str_makeTSD( length ) ;
1927    for (j=0;Str_in(str,j);j++) ;
1928    for (i=length-1,j--;(i>=0)&&(j>=0);ptr->value[i--]=str->value[j--]) ;
1929
1930    for (;i>=0;ptr->value[i--]=padch) ;
1931    ptr->len = length ;
1932
1933    return ptr ;
1934 }
1935
1936
1937 streng *std_verify( tsd_t *TSD, cparamboxptr parms )
1938 {
1939    char tab[256], ch=' ' ;
1940    streng *str=NULL, *ref=NULL ;
1941    int inv=0, start=0, res=0, i=0 ;
1942
1943    checkparam(  parms, 2, 4 , "VERIFY" ) ;
1944
1945    str = parms->value ;
1946    ref = parms->next->value ;
1947    if ( parms->next->next )
1948    {
1949       if ( parms->next->next->value )
1950       {
1951          ch = getoptionchar( TSD, parms->next->next->value, "VERIFY", 3, "MN", "" ) ;
1952          if ( ch == 'M' )
1953             inv = 1 ;
1954       }
1955       if (parms->next->next->next)
1956          start = atopos( TSD, parms->next->next->next->value, "VERIFY", 4 ) - 1 ;
1957    }
1958
1959    for (i=0;i<256;tab[i++]=0) ;
1960    for (i=0;Str_in(ref,i);tab[(unsigned char)(ref->value[i++])]=1) ;
1961    for (i=start;(Str_in(str,i))&&(!res);i++)
1962    {
1963       if (inv==(tab[(unsigned char)(str->value[i])]))
1964          res = i+1 ;
1965    }
1966
1967    return int_to_streng( TSD, res ) ;
1968 }
1969
1970
1971
1972 streng *std_substr( tsd_t *TSD, cparamboxptr parms )
1973 {
1974    int rlength=0, length=0, start=0, i=0 ;
1975    int available, copycount;
1976    char padch=' ' ;
1977    streng *pad=NULL, *str=NULL, *ptr=NULL ;
1978    paramboxptr bptr=NULL ;
1979
1980    checkparam(  parms,  2,  4 , "SUBSTR" ) ;
1981    str = parms->value ;
1982    rlength = Str_len( str ) ;
1983    start = atopos( TSD, parms->next->value, "SUBSTR", 2 ) ;
1984    if ( ( (bptr = parms->next->next) != NULL )
1985    && ( parms->next->next->value ) )
1986       length = atozpos( TSD, parms->next->next->value, "SUBSTR", 3 ) ;
1987    else
1988       length = ( rlength >= start ) ? rlength - start + 1 : 0;
1989
1990    if ( (bptr )
1991    && ( bptr->next )
1992    && ( bptr->next->value ) )
1993       pad = parms->next->next->next->value ;
1994
1995    if ( pad == NULL )
1996       padch = ' ' ;
1997    else
1998       padch = getonechar( TSD, pad, "SUBSTR", 4) ;
1999
2000    ptr = Str_makeTSD( length ) ;
2001    i = ((rlength>=start)?start-1:rlength) ;
2002    /*
2003     * New algorithm by Julian Onions speeds up substr() by 50%
2004     */
2005    available = Str_len(str) - i;
2006    copycount = length > available ? available : length;
2007    memcpy(ptr->value, &str->value[i], copycount);
2008    if (copycount < length)
2009       memset(&ptr->value[copycount], padch, length - copycount);
2010    ptr->len = length;
2011    return ptr ;
2012 }
2013
2014
2015 static streng *minmax( tsd_t *TSD, cparamboxptr parms, const char *name,
2016                        int sign )
2017 {
2018    /*
2019     * fixes bug 677645
2020     */
2021    streng *retval;
2022    num_descr *m,*test;
2023    int ccns,fuzz,StrictAnsi,result,required,argno;
2024
2025    StrictAnsi = get_options_flag( TSD->currlevel, EXT_STRICT_ANSI );
2026    /*
2027     * Round the number according to NUMERIC DIGITS. This is rule 9.2.1.
2028     * Don't set DIGITS or FUZZ where it's possible to raise a condition.
2029     * We don't have a chance to set it back to the original value.
2030     */
2031    ccns = TSD->currlevel->currnumsize;
2032    fuzz = TSD->currlevel->numfuzz;
2033
2034    required = count_params(parms, PARAM_TYPE_HARD);
2035    if ( !parms->value )
2036       exiterror( ERR_INCORRECT_CALL, 3, name, required );
2037    m = get_a_descr( TSD, name, 1, parms->value );
2038    if ( StrictAnsi )
2039    {
2040       str_round_lostdigits( TSD, m, ccns );
2041    }
2042
2043    parms = parms->next;
2044    argno = 1;
2045    while ( parms )
2046    {
2047       argno++;
2048       if ( !parms->value )
2049          exiterror( ERR_INCORRECT_CALL, 3, name, required ); /* fixes bug 1109296 */
2050
2051       test = get_a_descr( TSD, name, argno, parms->value );
2052       if ( StrictAnsi )
2053       {
2054          str_round_lostdigits( TSD, test, ccns );
2055       }
2056
2057       if ( ( TSD->currlevel->currnumsize = test->size ) < m->size )
2058          TSD->currlevel->currnumsize = m->size;
2059       TSD->currlevel->numfuzz = 0;
2060       result = string_test( TSD, test, m ) * sign;
2061       TSD->currlevel->currnumsize = ccns;
2062       TSD->currlevel->numfuzz = fuzz;
2063
2064       if ( result <= 0 )
2065       {
2066          free_a_descr( TSD, test );
2067       }
2068       else
2069       {
2070          free_a_descr( TSD, m );
2071          m = test;
2072       }
2073       parms = parms->next;
2074    }
2075
2076    m->used_digits = m->size;
2077    retval = str_norm( TSD, m, NULL );
2078    free_a_descr( TSD, m );
2079    return retval;
2080
2081 }
2082 streng *std_max( tsd_t *TSD, cparamboxptr parms )
2083 {
2084    return minmax( TSD, parms, "MAX", 1 );
2085 }
2086
2087
2088
2089 streng *std_min( tsd_t *TSD, cparamboxptr parms )
2090 {
2091    return minmax( TSD, parms, "MIN", -1 );
2092 }
2093
2094
2095
2096 streng *std_reverse( tsd_t *TSD, cparamboxptr parms )
2097 {
2098    streng *ptr=NULL ;
2099    int i=0, j=0 ;
2100
2101    checkparam(  parms,  1,  1 , "REVERSE" ) ;
2102
2103    ptr = Str_makeTSD(j=Str_len(parms->value)) ;
2104    ptr->len = j--  ;
2105    for (i=0;j>=0;ptr->value[i++]=parms->value->value[j--]) ;
2106
2107    return ptr ;
2108 }
2109
2110 streng *std_random( tsd_t *TSD, cparamboxptr parms )
2111 {
2112    int min=0, max=999, result=0 ;
2113 #if defined(HAVE_RANDOM)
2114    int seed;
2115 #else
2116    unsigned seed;
2117 #endif
2118
2119    checkparam(  parms,  0,  3 , "RANDOM" ) ;
2120    if (parms!=NULL)
2121    {
2122       if (parms->value)
2123       {
2124          if (parms->next)
2125             min = atozpos( TSD, parms->value, "RANDOM", 1 ) ;
2126          else
2127          {
2128             max = atozpos( TSD, parms->value, "RANDOM", 1 ) ;
2129             if ( max > 100000 )
2130                exiterror( ERR_INCORRECT_CALL, 31, "RANDOM", max )  ;
2131          }
2132       }
2133       if (parms->next!=NULL)
2134       {
2135          if (parms->next->value!=NULL)
2136             max = atozpos( TSD, parms->next->value, "RANDOM", 2 ) ;
2137
2138          if (parms->next->next!=NULL&&parms->next->next->value!=NULL)
2139          {
2140             seed = atozpos( TSD, parms->next->next->value, "RANDOM", 3 ) ;
2141 #if defined(HAVE_RANDOM)
2142             srandom( seed ) ;
2143 #else
2144             srand( seed ) ;
2145 #endif
2146          }
2147       }
2148    }
2149
2150    if (min>max)
2151       exiterror( ERR_INCORRECT_CALL, 33, "RANDOM", min, max )  ;
2152    if (max-min > 100000)
2153       exiterror( ERR_INCORRECT_CALL, 32, "RANDOM", min, max )  ;
2154
2155 #if defined(HAVE_RANDOM)
2156    result = (random() % (max-min+1)) + min ;
2157 #else
2158 # if RAND_MAX < 100000
2159 /*   result = (((rand() * 100) + (clock() % 100)) % (max-min+1)) + min ; */
2160    result = (((rand() * RAND_MAX) + rand() ) % (max-min+1)) + min ; /* pgb */
2161 # else
2162    result = (rand() % (max-min+1)) + min ;
2163 # endif
2164 #endif
2165    return int_to_streng( TSD, result ) ;
2166 }
2167
2168
2169 streng *std_copies( tsd_t *TSD, cparamboxptr parms )
2170 {
2171    streng *ptr=NULL ;
2172    int copies=0, i=0, length=0 ;
2173
2174    checkparam(  parms,  2,  2 , "COPIES" ) ;
2175
2176    length = Str_len(parms->value) ;
2177    copies = atozpos( TSD, parms->next->value, "COPIES", 2 ) * length ;
2178    ptr = Str_makeTSD( copies ) ;
2179    for (i=0;i<copies;i+=length)
2180       memcpy(ptr->value+i,parms->value->value,length) ;
2181
2182    ptr->len = i ;
2183    return ptr ;
2184 }
2185
2186
2187 streng *std_sign( tsd_t *TSD, cparamboxptr parms )
2188 {
2189    checkparam(  parms,  1,  1 , "SIGN" );
2190
2191    return str_sign( TSD, parms->value );
2192 }
2193
2194
2195 streng *std_trunc( tsd_t *TSD, cparamboxptr parms )
2196 {
2197    int decimals=0;
2198
2199    checkparam(  parms,  1,  2 , "TRUNC" );
2200    if ( parms->next && parms->next->value )
2201       decimals = atozpos( TSD, parms->next->value, "TRUNC", 2 );
2202
2203    return str_trunc( TSD, parms->value, decimals );
2204 }
2205
2206
2207 streng *std_translate( tsd_t *TSD, cparamboxptr parms )
2208 {
2209    streng *iptr=NULL, *optr=NULL ;
2210    char padch=' ' ;
2211    streng *string=NULL, *result=NULL ;
2212    paramboxptr ptr=NULL ;
2213    int olength=0, i=0, ii=0 ;
2214
2215    checkparam(  parms,  1,  4 , "TRANSLATE" ) ;
2216
2217    string = parms->value ;
2218    if ( ( (ptr = parms->next) != NULL )
2219    && ( parms->next->value ) )
2220    {
2221       optr = parms->next->value ;
2222       olength = Str_len( optr ) ;
2223    }
2224
2225    if ( ( ptr )
2226    && ( (ptr = ptr->next) != NULL )
2227    && ( ptr->value ) )
2228    {
2229       iptr = ptr->value ;
2230    }
2231
2232    if ( ( ptr )
2233    && ( (ptr = ptr->next) != NULL )
2234    && ( ptr->value ) )
2235       padch = getonechar( TSD, ptr->value, "TRANSLATE", 4 ) ;
2236
2237    result = Str_makeTSD( Str_len(string) ) ;
2238    for (i=0; Str_in(string,i); i++)
2239    {
2240       if ((!iptr)&&(!optr))
2241          result->value[i] = (char) rx_toupper(string->value[i]) ;
2242       else
2243       {
2244          if (iptr)
2245          {
2246             for (ii=0; Str_in(iptr,ii); ii++)
2247                if (iptr->value[ii]==string->value[i])
2248                   break ;
2249
2250             if (ii==Str_len(iptr))
2251             {
2252                result->value[i] = string->value[i] ;
2253                continue ;
2254             }
2255          }
2256          else
2257             ii = ((unsigned char*)string->value)[i] ;
2258
2259          if ((optr)&&(ii<olength))
2260             result->value[i] = optr->value[ii] ;
2261          else
2262             result->value[i] = padch ;
2263       }
2264    }
2265
2266    result->len = i ;
2267    return result ;
2268 }
2269
2270
2271 streng *std_delstr( tsd_t *TSD, cparamboxptr parms )
2272 {
2273    int i=0, j=0, length=0, sleng=0, start=0 ;
2274    streng *string=NULL, *result=NULL ;
2275
2276    checkparam(  parms,  2,  3 , "DELSTR" ) ;
2277
2278    sleng = Str_len((string = parms->value)) ;
2279    /*
2280     * found while fixing bug 1108868, but fast-finding Walter will create
2281     * a new bug item before releasing the fix I suppose ;-)   (was atozpos)
2282     */
2283    start = atopos( TSD, parms->next->value, "DELSTR", 2 ) ;
2284
2285    if ((parms->next->next)&&(parms->next->next->value))
2286       length = atozpos( TSD, parms->next->next->value, "DELSTR", 3 ) ;
2287    else
2288       length = Str_len( string ) - start + 1 ;
2289
2290    if (length<0)
2291       length = 0 ;
2292
2293    result = Str_makeTSD( (start+length>sleng) ? start : sleng-length ) ;
2294
2295    for (i=j=0; (Str_in(string,i))&&(i<start-1); result->value[i++] = string->value[j++]) ;
2296    j += length ;
2297    for (; (j<=sleng)&&(Str_in(string,j)); result->value[i++] = string->value[j++] ) ;
2298
2299    result->len = i ;
2300    return result ;
2301 }
2302
2303
2304
2305
2306
2307 static int valid_hex_const( const streng *str )
2308 {
2309    const char *ptr=NULL, *end_ptr=NULL ;
2310    int space_stat=0 ;
2311
2312    ptr = str->value ;
2313    end_ptr = ptr + str->len ;
2314
2315    if ((end_ptr>ptr) && ((rx_isspace(*ptr)) || (rx_isspace(*(end_ptr-1)))))
2316    {
2317          return 0 ; /* leading or trailing space */
2318    }
2319
2320    space_stat = 0 ;
2321    for (; ptr<end_ptr; ptr++)
2322    {
2323       if (rx_isspace(*ptr))
2324       {
2325          if (space_stat==0)
2326          {
2327             space_stat = 2 ;
2328          }
2329          else if (space_stat==1)
2330          {
2331             /* non-even number of hex digits in non-first group */
2332             return 0 ;
2333          }
2334       }
2335       else if (rx_isxdigit(*ptr))
2336       {
2337          if (space_stat)
2338            space_stat = ((space_stat==1) ? 2 : 1) ;
2339       }
2340       else
2341       {
2342          return 0 ; /* neither space nor hex digit */
2343       }
2344    }
2345
2346    if (space_stat==1)
2347    {
2348       /* non-even number of digits in last grp, which not also first grp */
2349       return 0 ;
2350    }
2351
2352    /* note: the nullstring is a valid hexstring */
2353    return 1 ;  /* a valid hex string */
2354 }
2355
2356 static int valid_binary_const( const streng *str)
2357 /* check for valid binary streng. returns 1 for TRUE, 0 for FALSE */
2358 {
2359    char c;
2360    const char *ptr;
2361    int len,digits;
2362
2363    ptr = str->value;
2364    if ((len = Str_len(str))==0)
2365       return(1); /* ANSI */
2366    len--; /* on last char */
2367
2368    if (rx_isspace(ptr[0]) || rx_isspace(ptr[len]))
2369       return(0); /* leading or trailing space */
2370    /* ptr must consist of 0 1nd 1. After a blank follows a blank or a block
2371     * of four digits. Since the first block of binary digits may contain
2372     * less than four digits, we casn parse backwards and check only filled
2373     * block till we reach the start.  Thanks to ANSI testing program. */
2374    for (digits = 0; len >= 0; len--)
2375    {
2376       c = ptr[len];
2377       if (rx_isspace(c))
2378       {
2379          if ((digits % 4) != 0)
2380             return(0);
2381       }
2382       else if ((c != '0') && (c != '1'))
2383          return(0);
2384       digits++;
2385    }
2386
2387    return(1);
2388 }
2389
2390 streng *std_datatype( tsd_t *TSD, cparamboxptr parms )
2391 {
2392    streng *string=NULL, *result=NULL ;
2393    char option=' ', *cptr=NULL ;
2394    int res;
2395    parambox parms_for_symbol;
2396
2397    checkparam(  parms,  1,  2 , "DATATYPE" ) ;
2398
2399    string = parms->value ;
2400
2401    if ((parms->next)&&(parms->next->value))
2402    {
2403       option = getoptionchar( TSD, parms->next->value, "DATATYPE", 2, "ABLMNSUWX", "" ) ;
2404       res = 1 ;
2405       cptr = string->value ;
2406       if ((Str_len(string)==0)&&(option!='X')&&(option!='B'))
2407          res = 0 ;
2408
2409       switch ( option )
2410       {
2411          case 'A':
2412             for (; cptr<Str_end(string); res = rx_isalnum(*cptr++) && res) ;
2413             res = ( res ) ? 1 : 0;
2414             break ;
2415
2416          case 'B':
2417             res = valid_binary_const( string );
2418             break ;
2419
2420          case 'L':
2421             for (; cptr<Str_end(string); res = rx_islower(*cptr++) && res ) ;
2422             res = ( res ) ? 1 : 0;
2423             break ;
2424
2425          case 'M':
2426             for (; cptr<Str_end(string); res = rx_isalpha(*cptr++) && res ) ;
2427             res = ( res ) ? 1 : 0;
2428             break ;
2429
2430          case 'N':
2431             res = myisnumber(TSD, string) ;
2432             break ;
2433
2434          case 'S':
2435             /*
2436              * According to ANSI 9.3.8, this should return the result of:
2437              * Symbol( string ) \= 'BAD'
2438              * Fixes bug #737151
2439              */
2440             parms_for_symbol.next = NULL;
2441             parms_for_symbol.dealloc = 0;
2442             parms_for_symbol.value = string;
2443             result = std_symbol( TSD, &parms_for_symbol );
2444             if ( result->len == 3 && memcmp( result->value, "BAD", 3 ) == 0 )
2445                res = 0;
2446             else
2447                res = 1;
2448             Free_string_TSD( TSD,result );
2449             break ;
2450
2451          case 'U':
2452             for (; cptr<Str_end(string); res = rx_isupper(*cptr++) && res ) ;
2453             res = ( res ) ? 1 : 0;
2454             break ;
2455
2456          case 'W':
2457             res = myiswnumber( TSD, string, NULL, 0 );
2458             break ;
2459
2460          case 'X':
2461             res = valid_hex_const( string ) ;
2462             break ;
2463
2464          default:
2465             /* shouldn't get here */
2466             break;
2467       }
2468       result = int_to_streng( TSD, res ) ;
2469    }
2470    else
2471    {
2472       cptr = (char *)( ( ( string->len ) && ( myisnumber( TSD, string ) ) ) ? "NUM" : "CHAR" ) ;
2473       result = Str_creTSD( cptr ) ;
2474    }
2475
2476    return result ;
2477 }
2478
2479
2480 streng *std_trace( tsd_t *TSD, cparamboxptr parms )
2481 {
2482    streng *result=NULL, *string=NULL ;
2483    int i=0 ;
2484    char tc;
2485
2486    checkparam(  parms,  0,  1 , "TRACE" ) ;
2487
2488    result = Str_makeTSD( 3 ) ;
2489    if (TSD->systeminfo->interactive)
2490       result->value[i++] = '?' ;
2491
2492    result->value[i++] = (char) TSD->trace_stat ;
2493    result->len = i ;
2494
2495    if ( parms->value )
2496    {
2497       string = Str_dupTSD( parms->value );
2498       for (i = 0; i < string->len; i++ )
2499       {
2500          if ( string->value[ i ] == '?' )
2501             set_trace_char( TSD, '?' );
2502          else
2503             break;
2504       }
2505       /*
2506        * In opposite to ANSI this throws 40.21, too.
2507        * I assume this to be OK although "trace ?" throws 40.21.
2508        */
2509       tc = getoptionchar( TSD, Str_strp( string, '?', STRIP_LEADING ),
2510                                                  "TRACE",
2511                                                  1,
2512                                                  "ACEFILNOR", "" ) ;
2513       set_trace_char( TSD, tc );
2514       Free_stringTSD( string );
2515    }
2516
2517    return result ;
2518 }
2519
2520 streng *std_changestr( tsd_t *TSD, cparamboxptr parms )
2521 {
2522    streng *needle=NULL, *heystack=NULL, *new_needle=NULL, *retval=NULL ;
2523    int neelen=0, heylen=0, newlen=0, newneelen=0, cnt=0, start=0, i=0, heypos=0, retpos=0 ;
2524
2525    checkparam( parms, 3, 3, "CHANGESTR" ) ;
2526    needle = parms->value ;
2527    heystack = parms->next->value ;
2528    new_needle = parms->next->next->value ;
2529
2530    neelen = Str_len(needle) ;
2531    heylen = Str_len(heystack) ;
2532    newneelen = Str_len(new_needle) ;
2533
2534    /* find number of occurrences of needle in heystack */
2535    if ((!needle->len)||(!heystack->len)||(needle->len>heystack->len))
2536       cnt = 0 ;
2537    else
2538    {
2539       for(;;)
2540       {
2541         start = bmstrstr(heystack, start, needle, 0);
2542         if (start == (-1))
2543            break;
2544         cnt++;
2545         start += needle->len;
2546       }
2547    }
2548    newlen = 1 + heylen + ((newneelen-neelen) * cnt);
2549    retval = Str_makeTSD(newlen) ;
2550
2551    if (!cnt)
2552       return (Str_ncpyTSD(retval,heystack,heylen));
2553
2554    start=heypos=retpos=0;
2555    for(;;)
2556    {
2557      start = bmstrstr(heystack, start, needle, 0);
2558      if (start == (-1))
2559        {
2560         cnt = heylen-heypos;
2561         for(i=0;i<cnt;retval->value[retpos++]=heystack->value[heypos++],i++) ;
2562         break;
2563        }
2564      cnt = start-heypos;
2565      for(i=0;i<cnt;retval->value[retpos++]=heystack->value[heypos++],i++) ;
2566      for(i=0;i<neelen;heypos++,i++) ;
2567      for(i=0;i<newneelen;retval->value[retpos++]=new_needle->value[i++]) ;
2568      start = heypos;
2569    }
2570
2571    retval->value[retpos] = '\0';
2572    retval->len=retpos;
2573    return retval ;
2574 }
2575
2576 streng *std_countstr( tsd_t *TSD, cparamboxptr parms )
2577 {
2578    int start=0, cnt=0 ;
2579    streng *needle=NULL, *heystack=NULL ;
2580    checkparam(  parms,  2,  2 , "COUNTSTR" ) ;
2581
2582    needle = parms->value ;
2583    heystack = parms->next->value ;
2584
2585    if ((!needle->len)||(!heystack->len))
2586       cnt = 0 ;
2587    else
2588    {
2589       for(;;)
2590       {
2591         start = bmstrstr(heystack, start, needle, 0);
2592         if (start == (-1))
2593            break;
2594         cnt++;
2595         start += needle->len;
2596       }
2597    }
2598
2599    return (int_to_streng( TSD, cnt ) ) ;
2600 }
2601
2602 streng *rex_poolid( tsd_t *TSD, cparamboxptr parms )
2603 {
2604    checkparam(  parms,  0,  0 , "POOLID" );
2605
2606    return ( int_to_streng( TSD, TSD->currlevel->pool ) );
2607 }
2608
2609 streng *rex_lower( tsd_t *TSD, cparamboxptr parms )
2610 {
2611    int rlength=0, length=0, start=1, i=0 ;
2612    int changecount;
2613    char padch=' ' ;
2614    streng *str=NULL, *ptr=NULL ;
2615    paramboxptr bptr=NULL ;
2616
2617    /*
2618     * Check that we have between 1 and 4 args
2619     * ( str [,start[,length[,pad]]] )
2620     */
2621    checkparam(  parms,  1,  4 , "LOWER" ) ;
2622    str = parms->value ;
2623    rlength = Str_len( str ) ;
2624    /*
2625     * Get starting position, if supplied...
2626     */
2627    if ( parms->next != NULL
2628    &&   parms->next->value )
2629       start = atopos( TSD, parms->next->value, "LOWER", 2 ) ;
2630    /*
2631     * Get length, if supplied...
2632     */
2633    if ( parms->next != NULL
2634    && ( (bptr = parms->next->next) != NULL )
2635    && ( parms->next->next->value ) )
2636       length = atozpos( TSD, parms->next->next->value, "LOWER", 3 ) ;
2637    else
2638       length = ( rlength >= start ) ? rlength - start + 1 : 0;
2639    /*
2640     * Get pad character, if supplied...
2641     */
2642    if ( (bptr )
2643    && ( bptr->next )
2644    && ( bptr->next->value ) )
2645       padch = getonechar( TSD, parms->next->next->next->value, "LOWER", 4) ;
2646    /*
2647     * Create our new starting; duplicate of input string
2648     */
2649    ptr = Str_makeTSD( length );
2650    memcpy( Str_val( ptr ), Str_val( str ), Str_len( str ) );
2651    /*
2652     * Determine where to start changing case...
2653     */
2654    i = ((rlength>=start)?start-1:rlength) ;
2655    /*
2656     * Determine how many characters to change case...
2657     */
2658    changecount = length > rlength ? rlength : length;
2659    /*
2660     * Change them
2661     */
2662    mem_lower( &ptr->value[i], changecount );
2663    /*
2664     * Append pad characters if required...
2665     */
2666    if (changecount < length)
2667       memset(&ptr->value[changecount], padch, length - changecount);
2668    /*
2669     * Determine length of return string...
2670     */
2671    ptr->len = (length > rlength) ? length : rlength ;
2672    return ptr ;
2673 }