regina/builtin.c

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