regina/arxfuncs.c

   1 /*
   2  *  ARexx functions for regina
   3  *  Copyright © 2002, Staf Verhaegen
   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 /* This files contains functions that are implemented in ARexx
  21  * but that are not standard REXX functions. This file contains
  22  * the functions that can be used on all platforms. amifuncs.c
  23  * contains the ARexx functions that are only usable on the
  24  * amiga platform or compatibles. (not implemented yet)
  25  */
  26 #include "rexx.h"
  27 #include <stdio.h>
  28 #include <ctype.h>
  29 #include <stdlib.h>
  30 #include <assert.h>
  31
  32 #if !defined(HAVE_DRAND48)
  33 #include "rand48.c"
  34 #endif
  35
  36 static const streng _fname = {1, 1, "F"}, _fstem = {4, 4, {'F', 'I', '.', 'F'}};
  37
  38 typedef struct _arexx_tsd_t {
  39   proclevel amilevel;
  40 } arexx_tsd_t;
  41
  42
  43
  44 /* Init thread data for arexx functions
  45  */
  46 int init_arexxf ( tsd_t *TSD )
  47 {
  48   arexx_tsd_t *atsd = (arexx_tsd_t *)malloc( sizeof(arexx_tsd_t) );
  49
  50   if (atsd==NULL) return 0;
  51
  52   TSD->arx_tsd = (void *)atsd;
  53
  54   /* Allocate later because systeminfo is not initialized at the moment */
  55   atsd->amilevel = NULL;
  56
  57   return 1;
  58 }
  59
  60
  61 /*
  62  * Support functions for the ARexx IO functions
  63  */
  64 /* setamilevel will change the environment to the variables used for open files */
  65 static proclevel setamilevel( tsd_t *TSD )
  66 {
  67   arexx_tsd_t *atsd = (arexx_tsd_t *)TSD->arx_tsd;
  68   proclevel oldlevel = TSD->currlevel;
  69
  70   if (atsd->amilevel!=NULL)
  71     TSD->currlevel = atsd->amilevel;
  72   else
  73   {
  74     char txt[20];
  75
  76     atsd->amilevel = newlevel( TSD, NULL );
  77
  78     TSD->currlevel = atsd->amilevel;
  79
  80     setvalue( TSD, &_fname, Str_cre_TSD( TSD, "STDIN" ) );
  81     sprintf( txt, "%p", stdin );
  82     setvalue( TSD, &_fstem, Str_cre_TSD( TSD, txt ) );
  83
  84     setvalue( TSD, &_fname, Str_cre_TSD( TSD, "STDOUT" ) );
  85     sprintf( txt, "%p", stdout );
  86     setvalue( TSD, &_fstem, Str_cre_TSD( TSD, txt ) );
  87
  88     setvalue( TSD, &_fname, Str_cre_TSD( TSD, "STDERR" ) );
  89     sprintf( txt, "%p", stderr );
  90     setvalue( TSD, &_fstem, Str_cre_TSD( TSD, txt ) );
  91   }
  92
  93   return oldlevel;
  94 }
  95
  96
  97 /* getfile will return the FILE pointer of given name */
  98 static FILE *getfile( tsd_t *TSD, const streng *name )
  99 {
 100   proclevel oldlevel = setamilevel( TSD );
 101   const streng *s;
 102   char *txt;
 103   FILE *file=NULL;
 104
 105   setvalue( TSD, &_fname, Str_dup_TSD( TSD, name ) );
 106   if ( isvariable( TSD, &_fstem ) )
 107   {
 108     s = getvalue( TSD, &_fstem, 0 );
 109     txt = str_of( TSD, s );
 110     sscanf( txt, "%p", &file );
 111     FreeTSD( txt );
 112   }
 113
 114   TSD->currlevel = oldlevel;
 115
 116   return file;
 117 }
 118
 119
 120 /* getfilenames will return a list of all opened files */
 121 static streng *getfilenames( tsd_t *TSD, const streng *sep )
 122 {
 123   proclevel oldlevel = setamilevel( TSD );
 124   streng *retval, *tmpstr;
 125   int first = 1;
 126   variableptr var;
 127
 128   get_next_variable( TSD, 1 );
 129   for ( var = get_next_variable( TSD, 0);
 130        var != NULL;
 131        var = get_next_variable( TSD, 0) )
 132   {
 133     while ( var != NULL && var->realbox != NULL )
 134       var = var->realbox;
 135
 136     if ( var != NULL && ( (var->flag & (VFLAG_STR | VFLAG_NUM)) || var->stem ) )
 137     {
 138       if ( first )
 139       {
 140         retval = Str_dup_TSD( TSD, var->name );
 141         first = 0;
 142       }
 143       else
 144       {
 145         tmpstr = Str_cat_TSD( TSD, retval, sep );
 146         if ( tmpstr != retval )
 147         {
 148           Free_string_TSD( TSD, retval );
 149           retval = tmpstr;
 150         }
 151         tmpstr = Str_cat_TSD( TSD, retval, var->name );
 152         if ( tmpstr != retval )
 153         {
 154           Free_string_TSD( TSD, retval );
 155           retval = tmpstr;
 156         }
 157       }
 158     }
 159   }
 160
 161   TSD->currlevel = oldlevel;
 162
 163   /* If no variable present return NULL string */
 164   if (first)
 165     retval = nullstringptr();
 166
 167   return retval;
 168 }
 169
 170 /* addfile: store the FILE pointer in a given name */
 171 static void addfile( tsd_t *TSD, const streng *name, FILE *file )
 172 {
 173   proclevel oldlevel = setamilevel( TSD );
 174   char txt[20];
 175   streng *s;
 176
 177   sprintf( txt, "%p", (void *)file );
 178   s = Str_cre_TSD( TSD, txt );
 179   setvalue( TSD, &_fname, Str_dup_TSD( TSD, name ) );
 180   setvalue( TSD, &_fstem, s );
 181
 182   TSD->currlevel = oldlevel;
 183 }
 184
 185
 186 /* rmfile: remove a given of open files list */
 187 static void rmfile( tsd_t *TSD, const streng *name )
 188 {
 189   arexx_tsd_t *atsd = (arexx_tsd_t *)TSD->arx_tsd;
 190   proclevel oldlevel = setamilevel( TSD );
 191
 192   TSD->currlevel = atsd->amilevel;
 193
 194   drop_var( TSD, name );
 195
 196   TSD->currlevel = oldlevel;
 197 }
 198
 199
 200
 201 /*
 202  * Implementation of the ARexx IO functions
 203  * See general documentation for more information
 204  * Functions implemented: OPEN, CLOSE, READCH, READLN, WRITECH, WRITELN, EOF, SEEK
 205  */
 206 streng *arexx_open( tsd_t *TSD, cparamboxptr parm1 )
 207 {
 208   cparamboxptr parm2, parm3;
 209   char *filename;
 210   FILE *file;
 211   int mode;
 212   static const char* modestrings[] = {
 213     "w",
 214     "r+",
 215     "a"
 216   };
 217
 218   checkparam( parm1, 2, 3, "OPEN" );
 219   parm2 = parm1->next;
 220   parm3 = parm2->next;
 221
 222   file = getfile( TSD, parm1->value );
 223   if ( file!=NULL )
 224   {
 225     return int_to_streng( TSD, 0 );
 226   }
 227
 228   filename = str_of( TSD, parm2->value );
 229
 230   if ( parm3==NULL
 231        || parm3->value==NULL
 232        || parm3->value->len==0 )
 233     mode=0;
 234   else switch( getoptionchar( TSD, parm3->value, "OPEN", 3, "", "WRA" ) )
 235   {
 236     case 'W':
 237       mode=0;
 238       break;
 239
 240     case 'R':
 241       mode=1;
 242       break;
 243
 244     case 'A':
 245       mode=2;
 246       break;
 247
 248     default:
 249       mode=0;
 250       assert(0);
 251       break;
 252   }
 253
 254   file = fopen( filename, modestrings[mode] );
 255   FreeTSD( filename );
 256
 257   if ( file==NULL )
 258   {
 259     return int_to_streng( TSD, 0 );
 260   }
 261
 262   addfile( TSD, parm1->value, file );
 263   return int_to_streng( TSD, 1);
 264 }
 265
 266
 267 streng *arexx_close( tsd_t *TSD, cparamboxptr parm1 )
 268 {
 269   FILE *file;
 270
 271   checkparam( parm1, 1, 1, "CLOSE" );
 272
 273   file = getfile( TSD, parm1->value );
 274   if ( file==NULL )
 275     return int_to_streng( TSD, 0 );
 276
 277   fclose( file );
 278   rmfile( TSD, parm1->value );
 279
 280   return int_to_streng( TSD, 1 );
 281 }
 282
 283
 284 streng *arexx_writech( tsd_t *TSD, cparamboxptr parm1 )
 285 {
 286   cparamboxptr parm2;
 287   char *txt;
 288   FILE *file;
 289   int count;
 290
 291   checkparam( parm1, 2, 2, "WRITECH" );
 292   parm2 = parm1->next;
 293
 294   file = getfile( TSD, parm1->value );
 295   if ( file==NULL )
 296     exiterror( ERR_INCORRECT_CALL, 27, "WRITECH", tmpstr_of( TSD, parm1->value ));
 297
 298   txt = str_of( TSD, parm2->value );
 299   count = fprintf( file, "%s", txt );
 300   FreeTSD( txt );
 301
 302   return int_to_streng( TSD, count );
 303 }
 304
 305
 306 streng *arexx_writeln( tsd_t *TSD, cparamboxptr parm1 )
 307 {
 308   cparamboxptr parm2;
 309   char *txt;
 310   FILE *file;
 311   int count;
 312
 313   checkparam( parm1, 2, 2, "WRITELN" );
 314   parm2 = parm1->next;
 315
 316   file = getfile( TSD, parm1->value );
 317   if ( file==NULL )
 318     exiterror( ERR_INCORRECT_CALL, 27, "WRITELN", tmpstr_of( TSD, parm1->value ) );
 319
 320   txt = str_of( TSD, parm2->value );
 321   count = fprintf(file, "%s\n", txt);
 322   FreeTSD( txt );
 323
 324   return int_to_streng( TSD, count );
 325 }
 326
 327
 328 streng *arexx_seek( tsd_t *TSD, cparamboxptr parm1 )
 329 {
 330   cparamboxptr parm2, parm3;
 331   FILE *file;
 332   int pos, error, wench;
 333   long offset;
 334
 335   checkparam( parm1, 2, 3, "SEEK" );
 336   parm2 = parm1->next;
 337   parm3 = parm2->next;
 338
 339   file = getfile( TSD, parm1->value );
 340   if ( file==NULL )
 341     exiterror( ERR_INCORRECT_CALL, 27, "SEEK", tmpstr_of( TSD, parm1->value ) );
 342
 343   offset = streng_to_int( TSD, parm2->value, &error );
 344   if (error)
 345     exiterror( ERR_INCORRECT_CALL, 11, "SEEK", 2, tmpstr_of( TSD, parm2->value ) );
 346
 347   if ( parm3==NULL
 348        || parm3->value==NULL
 349        || parm3->value->len == 0 )
 350     wench = SEEK_CUR;
 351   else switch( getoptionchar( TSD, parm3->value, "SEEK", 3, "", "CBE" ) )
 352   {
 353     case 'C':
 354       wench = SEEK_CUR;
 355       break;
 356
 357     case 'B':
 358       wench = SEEK_SET;
 359       break;
 360
 361     case 'E':
 362       wench = SEEK_END;
 363       break;
 364
 365     default:
 366       wench = SEEK_CUR;
 367       assert(0);
 368       break;
 369   }
 370
 371   pos = fseek( file, offset, wench );
 372   return int_to_streng( TSD, pos );
 373 }
 374
 375
 376 streng *arexx_readch( tsd_t *TSD, cparamboxptr parm1 )
 377 {
 378   cparamboxptr parm2;
 379   FILE *file;
 380
 381   checkparam( parm1, 1, 2, "READCH");
 382   parm2 = parm1->next;
 383
 384   file = getfile( TSD, parm1->value );
 385   if ( file==NULL )
 386     exiterror( ERR_INCORRECT_CALL, 27, "READCH", tmpstr_of( TSD, parm1->value ) );
 387
 388   if ( parm2==NULL )
 389   {
 390     char buffer[2] = { 0, 0 };
 391
 392     buffer[0] = (char)getc( file );
 393
 394     return Str_cre_TSD( TSD, buffer );
 395   }
 396   else
 397   {
 398     int count, error;
 399     char *buffer;
 400     streng *ret;
 401
 402     count = streng_to_int( TSD, parm2->value, &error );
 403
 404     if ( error )
 405       exiterror( ERR_INCORRECT_CALL, 11, "READCH", 2, tmpstr_of( TSD, parm2->value ) );
 406     if ( count<=0 )
 407       exiterror( ERR_INCORRECT_CALL, 14, "READCH", 2, tmpstr_of( TSD, parm2->value ) );
 408
 409     buffer = malloc( count + 1 );
 410
 411     count = fread( buffer, 1, count, file );
 412     buffer[count + 1] = 0;
 413
 414     ret = Str_cre_TSD( TSD, buffer );
 415     free(buffer);
 416     return ret;
 417   }
 418 }
 419
 420
 421 streng *arexx_readln( tsd_t *TSD, cparamboxptr parm )
 422 {
 423   FILE *file;
 424   char buffer[1001];
 425
 426   checkparam( parm, 1, 1, "READLN");
 427
 428   file = getfile( TSD, parm->value );
 429   if ( file==NULL )
 430     exiterror( ERR_INCORRECT_CALL, 27, "READLN", tmpstr_of( TSD, parm->value ) );
 431
 432   fgets( buffer, 1001, file );
 433   if ( buffer[strlen(buffer)-1]=='\n' )
 434     buffer[strlen(buffer)-1]=0;
 435
 436   return Str_cre_TSD( TSD, buffer );
 437 }
 438
 439
 440 streng *arexx_eof( tsd_t *TSD, cparamboxptr parm )
 441 {
 442   FILE *file;
 443
 444   checkparam( parm, 1, 1, "EOF" );
 445
 446   file = getfile( TSD, parm->value );
 447   if ( file==NULL )
 448     exiterror( ERR_INCORRECT_CALL, 27, "EOF", tmpstr_of( TSD, parm->value ) );
 449
 450   return int_to_streng( TSD, feof( file )!=0 );
 451 }
 452
 453
 454 /*
 455  * Implementation of the additional conversion functions from ARexx
 456  * Functions: B2C, C2B
 457  */
 458 streng *arexx_b2c( tsd_t *TSD, cparamboxptr parm )
 459 {
 460   parambox parm2;
 461   streng *ret;
 462
 463   checkparam( parm, 1, 1, "B2C" );
 464
 465   parm2.next = NULL;
 466   parm2.value = std_b2x( TSD, parm );
 467
 468   ret = std_x2c( TSD, &parm2 );
 469   Free_string_TSD( TSD, parm2.value );
 470
 471   return ret;
 472 }
 473
 474
 475 streng *arexx_c2b( tsd_t *TSD, cparamboxptr parm )
 476 {
 477   parambox parm2;
 478   streng *ret;
 479
 480   checkparam( parm, 1, 1, "B2C" );
 481
 482   parm2.next = NULL;
 483   parm2.value = std_c2x( TSD, parm );
 484
 485   ret = std_x2b( TSD, &parm2 );
 486   Free_string_TSD( TSD, parm2.value );
 487
 488   return ret;
 489 }
 490
 491
 492 /*
 493  * Implementation of the bitwise function from ARexx
 494  * Functions: BITCHG, BITCLR, BITSET, BITTST, BITCOMP
 495  */
 496 streng *arexx_bitchg( tsd_t *TSD, cparamboxptr parm1 )
 497 {
 498   cparamboxptr parm2;
 499   streng *ret;
 500   int bit, error, byte;
 501   div_t dt;
 502
 503   checkparam( parm1, 2, 2, "BITCHG" );
 504   parm2 = parm1->next;
 505
 506   bit = streng_to_int( TSD, parm2->value, &error );
 507   if ( error )
 508     exiterror( ERR_INCORRECT_CALL, 11, "BITCHG", 2, tmpstr_of( TSD, parm2->value ) );
 509   if ( bit<0 )
 510     exiterror( ERR_INCORRECT_CALL, 13, "BITCHG", 2, tmpstr_of( TSD, parm2->value ) );
 511
 512   dt = div( bit, 8 );
 513
 514   byte = parm1->value->len-dt.quot-1;
 515   if ( byte<0 )
 516     exiterror( ERR_INCORRECT_CALL, 0 );
 517
 518   ret = Str_dup_TSD( TSD, parm1->value );
 519   ret->value[byte]^=(char)(1<<dt.rem);
 520   return ret;
 521 }
 522
 523
 524 streng *arexx_bitclr( tsd_t *TSD, cparamboxptr parm1 )
 525 {
 526   cparamboxptr parm2;
 527   streng *ret;
 528   int bit, error, byte;
 529   div_t dt;
 530
 531   checkparam( parm1, 2, 2, "BITCLR" );
 532   parm2 = parm1->next;
 533
 534   bit = streng_to_int( TSD, parm2->value, &error );
 535   if ( error )
 536     exiterror( ERR_INCORRECT_CALL, 11, "BITCLR", 2, tmpstr_of( TSD, parm2->value ) );
 537   if ( bit<0 )
 538     exiterror( ERR_INCORRECT_CALL, 13, "BITCLR", 2, tmpstr_of( TSD, parm2->value ) );
 539
 540   dt = div( bit, 8 );
 541
 542   byte = parm1->value->len-dt.quot-1;
 543   if ( byte<0 )
 544     exiterror( ERR_INCORRECT_CALL, 0 );
 545
 546   ret = Str_dup_TSD( TSD, parm1->value );
 547   ret->value[byte]&=~(char)(1<<dt.rem);
 548   return ret;
 549 }
 550
 551
 552 streng *arexx_bitset( tsd_t *TSD, cparamboxptr parm1 )
 553 {
 554   cparamboxptr parm2;
 555   streng *ret;
 556   int bit, error, byte;
 557   div_t dt;
 558
 559   checkparam( parm1, 2, 2, "BITSET" );
 560   parm2 = parm1->next;
 561
 562   bit = streng_to_int( TSD, parm2->value, &error );
 563   if ( error )
 564     exiterror( ERR_INCORRECT_CALL, 11, "BITSET", 2, tmpstr_of( TSD, parm2->value ) );
 565   if ( bit<0 )
 566     exiterror( ERR_INCORRECT_CALL, 13, "BITSET", 2, tmpstr_of( TSD, parm2->value ) );
 567
 568   dt = div( bit, 8 );
 569
 570   byte = parm1->value->len-dt.quot-1;
 571   if ( byte<0 )
 572     exiterror( ERR_INCORRECT_CALL, 0 );
 573
 574   ret = Str_dup_TSD( TSD, parm1->value );
 575   ret->value[byte]|=(char)(1<<dt.rem);
 576   return ret;
 577 }
 578
 579
 580 streng *arexx_bittst( tsd_t *TSD, cparamboxptr parm1 )
 581 {
 582   cparamboxptr parm2;
 583   streng *ret;
 584   int bit, error, byte;
 585   div_t dt;
 586
 587   checkparam( parm1, 2, 2, "BITTST" );
 588   parm2 = parm1->next;
 589
 590   bit = streng_to_int( TSD, parm2->value, &error );
 591   if ( error )
 592     exiterror( ERR_INCORRECT_CALL, 11, "BITTST", 2, tmpstr_of( TSD, parm2->value ) );
 593   if ( bit<0 )
 594     exiterror( ERR_INCORRECT_CALL, 13, "BITTST", 2, tmpstr_of( TSD, parm2->value ) );
 595
 596   dt = div( bit, 8 );
 597
 598   byte = parm1->value->len-dt.quot-1;
 599   if ( byte<0 )
 600     exiterror( ERR_INCORRECT_CALL, 0 );
 601
 602   ret = int_to_streng( TSD, (parm1->value->value[byte] & (char)(1<<dt.rem))!=0 );
 603   return ret;
 604 }
 605
 606
 607 /* Help function for arexx_bitcomp */
 608 static int firstbit(char c)
 609 {
 610   int i;
 611   assert(c!=0);
 612
 613   for ( i=0; i<8; i++)
 614   {
 615     if (c & 1)
 616       return i;
 617     else
 618       c = c >> 1;
 619   }
 620
 621   return 8;
 622 }
 623
 624 /* This ARexx function has very weird usage of the pad byte,
 625  * the shortest string is padded on the left with this byte
 626  */
 627 streng *arexx_bitcomp( tsd_t *TSD, cparamboxptr parm1 )
 628 {
 629   cparamboxptr parm2, parm3;
 630   const streng *s1, *s2;
 631   const char *cp1, *cp2;
 632   char pad;
 633   int i;
 634
 635   checkparam( parm1, 2, 3, "BITCOMP" );
 636   parm2 = parm1->next;
 637
 638   /* Make s2 always shorter or equal to s1 */
 639   if ( parm1->value->len < parm2->value->len )
 640   {
 641     s1 = parm2->value;
 642     s2 = parm1->value;
 643   } else {
 644     s1 = parm1->value;
 645     s2 = parm2->value;
 646   }
 647
 648   for ( cp1=s1->value+s1->len-1, cp2=s2->value+s2->len-1, i=0;
 649        cp2 >= s2->value;
 650        cp1--, cp2--, i++ )
 651   {
 652     if ( *cp1 != *cp2 )
 653       return int_to_streng( TSD, i*8 + firstbit( *cp1 ^ *cp2 ) );
 654   }
 655
 656   parm3 = parm2->next;
 657   if ( parm3==NULL || parm3->value==NULL || parm3->value->len==0 )
 658     pad = 0;
 659   else
 660     pad = parm3->value->value[0];
 661
 662   for ( ;
 663   cp1 >= s1->value;
 664   cp1--, i++ )
 665   {
 666     if ( *cp1 != pad )
 667       return int_to_streng( TSD, i*8 + firstbit( *cp1 ^ pad ) );
 668   }
 669
 670   return int_to_streng( TSD, -1 );
 671 }
 672
 673
 674 /*
 675  * Some more misc. ARexx functions
 676  * Functions: COMPRESS, HASH, RANDU, TRIM, UPPER
 677  */
 678 streng *arexx_hash( tsd_t *TSD, cparamboxptr parm1 )
 679 {
 680   unsigned char *uc;
 681   int i, sum=0;
 682
 683   checkparam( parm1, 1, 1, "HASH" );
 684
 685   uc = (unsigned char *)parm1->value->value;
 686   for ( i=0; i<parm1->value->len; i++)
 687   {
 688     sum = (sum + uc[i]) & 255;
 689   }
 690
 691   return int_to_streng( TSD, sum );
 692 }
 693
 694
 695 streng *arexx_compress( tsd_t *TSD, cparamboxptr parm1 )
 696 {
 697   const char *match;
 698   int i, start;
 699   streng *ret;
 700
 701   checkparam( parm1, 1, 2, "COMPRESS" );
 702
 703   match = ( parm1->next!=NULL ) ? str_of( TSD, parm1->next->value ) : " ";
 704
 705   ret = Str_dup_TSD( TSD, parm1->value );
 706   for ( i=start=0; i<ret->len; i++ )
 707   {
 708     /* Copy char if not found */
 709     if ( strchr( match, ret->value[i] )==NULL )
 710     {
 711       ret->value[start] = ret->value[i];
 712       start++;
 713     }
 714   }
 715   ret->len = start;
 716
 717   if ( parm1->next!=NULL )
 718     FreeTSD( (char *)match );
 719
 720   return ret;
 721 }
 722
 723
 724 static const streng T_str = { 1, 1, "T" };
 725 static const parambox T_parm = { NULL, 0, (streng *)&T_str };
 726
 727 streng *arexx_trim( tsd_t *TSD, cparamboxptr parm1 )
 728 {
 729   parambox parm;
 730
 731   checkparam( parm1, 1, 1, "TRIM" );
 732
 733   parm = *parm1;
 734   parm.next = (paramboxptr)&T_parm;
 735
 736   return std_strip( TSD, parm1 );
 737 }
 738
 739
 740 streng *arexx_upper( tsd_t *TSD, cparamboxptr parm1 )
 741 {
 742   streng *ret;
 743
 744   checkparam( parm1, 1, 1, "UPPER" );
 745
 746   ret = Str_dup_TSD( TSD, parm1->value );
 747
 748   return Str_upper( ret );
 749 }
 750
 751
 752 streng *arexx_randu( tsd_t *TSD, cparamboxptr parm1 )
 753 {
 754    int error, seed;
 755    char text[30];
 756    streng *s, *retval;
 757
 758    checkparam( parm1, 0, 1, "RANDU" );
 759
 760    if ( parm1!=NULL && parm1->value!=NULL )
 761    {
 762       seed = streng_to_int( TSD, parm1->value, &error );
 763       if ( error )
 764          exiterror( ERR_INCORRECT_CALL, 11, "RANDU", 1, tmpstr_of( TSD, parm1->value ) );
 765
 766       srand48( (long int)seed );
 767    }
 768
 769    sprintf( text, "%.20f", drand48() );
 770    s = Str_cre_TSD( TSD, text );
 771    retval = str_format( TSD, s, -1, -1, -1, -1);
 772    FreeTSD( s );
 773
 774    return retval;
 775 }
 776
 777
 778
 779 /*
 780  * Two memory allocation/deallocation functions: getspace and freespace
 781  */
 782 streng *arexx_getspace( tsd_t *TSD, cparamboxptr parm1 )
 783 {
 784   int length, error;
 785   void *ptr;
 786
 787   checkparam( parm1, 1, 1, "GETSPACE" );
 788
 789   length = streng_to_int( TSD, parm1->value, &error);
 790   if ( error )
 791     exiterror( ERR_INCORRECT_CALL, 11, "GETSPACE", 1, tmpstr_of( TSD, parm1->value ) );
 792   if ( length<=0 )
 793     exiterror( ERR_INCORRECT_CALL, 14, "GETSPACE", 1, tmpstr_of( TSD, parm1->value ) );
 794
 795   ptr = Malloc_TSD( TSD, length );
 796   memset( ptr, 0, length );
 797   if ( ptr == NULL )
 798     exiterror( ERR_STORAGE_EXHAUSTED, 0 );
 799
 800   return Str_ncre_TSD( TSD, (char *)&ptr, sizeof(void *) );
 801 }
 802
 803
 804 #if defined(_AMIGA) || defined(__AROS__)
 805 #include <exec/memory.h>
 806 #include <proto/exec.h>
 807 #endif
 808
 809 streng *arexx_freespace( tsd_t *TSD, cparamboxptr parm1 )
 810 {
 811   /* For backwards compatibility there may be two arguments
 812      But the second argument is ignored in regina */
 813   checkparam( parm1, 0, 2, "FREESPACE" );
 814
 815   if ( parm1 == NULL || parm1->value == NULL || parm1->value->len == 0 )
 816 #if defined(_AMIGA) || defined(__AROS__)
 817     return int_to_streng( TSD, AvailMem( MEMF_ANY ) );
 818 #else
 819     return int_to_streng( TSD, -1 );
 820 #endif
 821
 822   if ( parm1->value->len != sizeof(void *) )
 823     exiterror( ERR_INCORRECT_CALL, 0 );
 824
 825   Free_TSD( TSD, *((void **)parm1->value->value) );
 826
 827   return nullstringptr();
 828 }
 829
 830
 831
 832
 833 /*
 834  * ARexx memory <-> string conversion routines: IMPORT, EXPORT, STORAGE
 835  */
 836 streng *arexx_import( tsd_t *TSD, cparamboxptr parm1 )
 837 {
 838   void *memptr;
 839   cparamboxptr parm2;
 840   int len, error;
 841
 842   checkparam( parm1, 1, 2, "IMPORT" );
 843
 844   if ( parm1->value->len != sizeof(void *) )
 845     exiterror( ERR_INCORRECT_CALL, 0 );
 846
 847   memptr = *((void **)parm1->value->value);
 848
 849   parm2 = parm1->next;
 850   if ( parm2 == NULL || parm2->value == NULL || parm2->value->len == 0 )
 851     len = strlen((char *)memptr);
 852   else
 853   {
 854     len = streng_to_int( TSD, parm2->value, &error );
 855     if ( error )
 856       exiterror( ERR_INCORRECT_CALL, 11, "IMPORT", 2, tmpstr_of( TSD, parm2->value ) );
 857     if ( len<=0 )
 858       exiterror( ERR_INCORRECT_CALL, 14, "IMPORT", 2, tmpstr_of( TSD, parm2->value ) );
 859   }
 860
 861   return Str_ncre_TSD( TSD, memptr, len );
 862 }
 863
 864
 865 streng *arexx_export( tsd_t *TSD, cparamboxptr parm1 )
 866 {
 867   void *memptr;
 868   cparamboxptr parm2 = NULL, parm3 = NULL, parm4 = NULL;
 869   int len, error;
 870   char fill;
 871   streng *src;
 872
 873   checkparam( parm1, 1, 4, "EXPORT" );
 874
 875   if ( parm1->value == NULL || parm1->value->len == 0 )
 876     exiterror( ERR_INCORRECT_CALL, 21, "EXPORT", 1 );
 877   memptr = *((void **)parm1->value->value);
 878
 879   parm2 = parm1->next;
 880   if ( parm2 != NULL )
 881     parm3 = parm2->next;
 882   if ( parm3 != NULL )
 883     parm4 = parm3->next;
 884
 885   if ( parm2 == NULL || parm2->value == NULL || parm2->value->len == 0 )
 886     src = nullstringptr();
 887   else
 888     src = Str_dup_TSD( TSD, parm2->value );
 889
 890   if ( parm3 == NULL || parm3->value == NULL || parm3->value->len == 0 )
 891     len = src->len;
 892   else
 893   {
 894     len = streng_to_int( TSD, parm3->value, &error );
 895     if ( error )
 896       exiterror( ERR_INCORRECT_CALL, 11, "EXPORT", 3, tmpstr_of( TSD, parm3->value ) );
 897     if ( len<0 )
 898       exiterror( ERR_INCORRECT_CALL, 13, "EXPORT", 3, tmpstr_of( TSD, parm3->value ) );
 899   }
 900
 901   if ( parm4 == NULL || parm4->value == NULL || parm4->value->len == 0 )
 902     fill = 0;
 903   else
 904     fill = parm4->value->value[0];
 905
 906   if (len > src->len)
 907   {
 908     memcpy( memptr, src->value, src->len );
 909     memset( ((char *)memptr)+src->len, fill, len - src->len );
 910   }
 911   else
 912     memcpy( memptr, src->value, len );
 913
 914   Free_string_TSD( TSD, src );
 915
 916   return int_to_streng( TSD, len );
 917 }
 918
 919
 920 streng *arexx_storage( tsd_t *TSD, cparamboxptr parm1 )
 921 {
 922   void *memptr;
 923   cparamboxptr parm2 = NULL, parm3 = NULL, parm4 = NULL;
 924   int len, error;
 925   char fill;
 926   streng *src, *retval;
 927
 928   checkparam( parm1, 0, 4, "STORAGE" );
 929
 930   if ( parm1 == NULL )
 931     return arexx_getspace( TSD, NULL );
 932
 933   if ( parm1->value == NULL || parm1->value->len == 0 )
 934     exiterror( ERR_INCORRECT_CALL, 21, "STORAGE", 1 );
 935   memptr = *((void **)parm1->value->value);
 936
 937   parm2 = parm1->next;
 938   if ( parm2 != NULL )
 939     parm3 = parm2->next;
 940   if ( parm3 != NULL )
 941     parm4 = parm3->next;
 942
 943   if ( parm2 == NULL || parm2->value == NULL || parm2->value->len == 0 )
 944     src = nullstringptr();
 945   else
 946     src = Str_dup_TSD( TSD, parm2->value );
 947
 948   if ( parm3 == NULL || parm3->value == NULL || parm3->value->len == 0 )
 949     len = src->len;
 950   else
 951   {
 952     len = streng_to_int( TSD, parm3->value, &error );
 953     if ( error )
 954       exiterror( ERR_INCORRECT_CALL, 11, "STORAGE", 3, tmpstr_of( TSD, parm3->value ) );
 955     if ( len<0 )
 956       exiterror( ERR_INCORRECT_CALL, 13, "STORAGE", 3, tmpstr_of( TSD, parm3->value ) );
 957   }
 958
 959   if ( parm4 == NULL || parm4->value == NULL || parm4->value->len == 0 )
 960     fill = 0;
 961   else
 962     fill = parm4->value->value[0];
 963
 964   retval = Str_ncre_TSD( TSD, memptr, len );
 965
 966   if (len > src->len)
 967   {
 968     memcpy( memptr, src->value, src->len );
 969     memset( ((char *)memptr)+src->len, fill, len - src->len );
 970   }
 971   else
 972     memcpy( memptr, src->value, len );
 973
 974   Free_string_TSD( TSD, src );
 975
 976   return retval;
 977 }
 978
 979
 980
 981 /*
 982  * SHOW a function the names available in different resource lists
 983  */
 984 streng *arexx_show( tsd_t *TSD, cparamboxptr parm1 )
 985 {
 986    cparamboxptr parm2 = NULL, parm3 = NULL;
 987    streng *name = NULL, *sep, *retval;
 988
 989    checkparam( parm1, 1, 3, "SHOW" );
 990    parm2 = parm1->next;
 991    if ( parm2 != NULL )
 992       parm3 = parm2->next;
 993
 994    if ( parm2 != NULL && parm2->value != NULL && parm2->value->len != 0 )
 995       name = parm2->value;
 996
 997    if ( parm3 == NULL || parm3->value == NULL || parm3->value->len == 0 )
 998       sep = Str_cre_TSD( TSD, " " );
 999    else
1000       sep = Str_dup_TSD( TSD, parm3->value );
1001
1002    switch( getoptionchar( TSD, parm1->value, "SHOW", 1, "", "F" ) )
1003    {
1004       case 'F':
1005          if ( name == NULL )
1006             retval = getfilenames( TSD, sep );
1007          else
1008          {
1009             FILE *f = getfile( TSD, name );
1010             retval = int_to_streng( TSD, f != NULL );
1011          }
1012          break;
1013    }
1014    Free_string_TSD( TSD, sep );
1015
1016    return retval;
1017 }