regina/amifuncs.c

   1 /*
   2  *  Amiga REXX 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 are only to be used on amiga or compatibles.
  23  * arxfuncs.c contains the ARexx functions that are usable on all
  24  * platforms.
  25  */
  26 #include "rexx.h"
  27 #include <stdio.h>
  28 #include <ctype.h>
  29 #include <stdlib.h>
  30 #include <assert.h>
  31
  32 #include "envir.h"
  33 #include <dos/dos.h>
  34 #include <exec/lists.h>
  35 #include <exec/ports.h>
  36 #include <exec/memory.h>
  37 #include <exec/execbase.h>
  38 #include <rexx/rxslib.h>
  39 #include <rexx/storage.h>
  40 #include <rexx/errors.h>
  41 #include <rexx/rexxcall.h>
  42
  43 #include <proto/alib.h>
  44 #include <proto/dos.h>
  45 #include <proto/exec.h>
  46 #include <proto/rexxsyslib.h>
  47
  48 #include "rxiface.h"
  49
  50 /* We can't use AROS_LC1NR, since 'offset'
  51  * is not constant.
  52  */
  53 #define CallRsrcFunc(libbase, offset, rsrc) \
  54   ({ \
  55     int _offset=abs(offset)/6; \
  56     AROS_LVO_CALL1NR(VOID, \
  57              AROS_LCA(struct RexxRsrc *, rsrc, A0), \
  58              struct Library *, libbase, _offset, rexxcall); \
  59   })
  60
  61 struct amiga_envir {
  62   struct envir envir;
  63   struct MsgPort *port;
  64 };
  65
  66 typedef struct _amiga_tsd_t {
  67   struct amiga_envir portenvir;
  68   struct RxsLib *rexxsysbase;
  69   BPTR startlock;
  70   struct List resources; /* List to store resources to clean up at the end */
  71   struct MsgPort *listenport, *replyport;
  72   BYTE maintasksignal, subtasksignal;
  73   struct Task *parent, *child;
  74   UBYTE *value; /* Here a temporary argstring will be stored for RXGETVAR */
  75 } amiga_tsd_t;
  76
  77
  78 GLOBAL_PROTECTION_VAR(createtask)
  79 tsd_t *subtask_tsd;
  80
  81 #define RexxSysBase (((amiga_tsd_t *)TSD->ami_tsd)->rexxsysbase)
  82
  83 /* On AROS delete the allocated resources that are not recycled by the
  84  * normal C exit handling
  85  */
  86 static void exit_amigaf( int dummy, void *ptr )
  87 {
  88   amiga_tsd_t *atsd = (amiga_tsd_t *)ptr;
  89   struct RexxRsrc *rsrc;
  90
  91   ForeachNode( &atsd->resources, rsrc )
  92     CallRsrcFunc( rsrc->rr_Base, rsrc->rr_Func, rsrc );
  93
  94   DeleteMsgPort( atsd->replyport );
  95   Signal( atsd->child, 1<<atsd->subtasksignal );
  96   if ( atsd->rexxsysbase != NULL )
  97     CloseLibrary( (struct Library *)atsd->rexxsysbase );
  98   UnLock( CurrentDir( atsd->startlock ) );
  99
 100   free(ptr);
 101 }
 102
 103 streng *createstreng( tsd_t *TSD, char *value, int length )
 104 {
 105   streng *retval;
 106
 107 #ifdef CHECK_MEMORY
 108   retval = TSD->MTMalloc( TSD, sizeof(streng) );
 109   if ( retval != NULL )
 110   {
 111     retval->value = TSD->MTMalloc( TSD, length );
 112     if ( retval->value == NULL )
 113     {
 114       TSD->MTFree( retval );
 115       retval = NULL;
 116     }
 117     else
 118       memcpy( retval->value, value, length );
 119   }
 120 #else
 121   retval = TSD->MTMalloc( TSD, sizeof(streng)-4*sizeof(char)+length );
 122   if ( retval != NULL )
 123     memcpy( retval->value, value, length );
 124 #endif
 125   retval->len = length;
 126   retval->max = length;
 127
 128   return retval;
 129 }
 130
 131 /* ReginaHandleMessages will be executed in a subtask and will be
 132  * able to handle messages send to it asynchronously
 133  */
 134 void ReginaHandleMessages(void)
 135 {
 136   tsd_t *TSD = subtask_tsd;
 137   amiga_tsd_t *atsd = (amiga_tsd_t *)TSD->ami_tsd;
 138   BOOL done;
 139   ULONG mask, signals;
 140   struct RexxMsg *msg;
 141   struct MsgPort *listenport;
 142
 143   listenport = CreateMsgPort();
 144   atsd->listenport = listenport;
 145   if ( listenport == NULL )
 146     atsd->child = NULL;
 147   else
 148     atsd->subtasksignal = AllocSignal( -1 );
 149   Signal( atsd->parent, 1<<atsd->maintasksignal );
 150
 151   mask = 1<<atsd->subtasksignal | 1<<atsd->listenport->mp_SigBit;
 152   done = listenport == NULL;
 153   while ( !done )
 154   {
 155     signals = Wait( mask );
 156
 157     done = (signals & 1<<atsd->subtasksignal) != 0;
 158
 159     while ( (msg = (struct RexxMsg *)GetMsg( atsd->listenport )) != NULL )
 160     {
 161       if ( IsRexxMsg( msg ) )
 162         switch ( msg->rm_Action & RXCODEMASK )
 163         {
 164         case RXADDRSRC:
 165           AddTail( &atsd->resources, (struct Node *)ARG0( msg ) );
 166           msg->rm_Result1 = RC_OK;
 167           break;
 168
 169         case RXREMRSRC:
 170           Remove( (struct Node *)ARG0( msg ) );
 171           msg->rm_Result1 = RC_OK;
 172           break;
 173
 174         case RXSETVAR:
 175         {
 176           if ( ( msg->rm_Action & RXARGMASK ) != 2 )
 177           {
 178             msg->rm_Result1 = RC_ERROR;
 179             msg->rm_Result2 = (IPTR)ERR10_017;
 180           }
 181           else
 182           {
 183             streng *name, *value;
 184
 185             /* Using own allocation so I can get a NULL return value when allocation
 186              * and not Exiterror is called
 187              */
 188             name = createstreng( TSD, (char *)msg->rm_Args[0], LengthArgstring( (UBYTE *)msg->rm_Args[0] ) );
 189             value = createstreng( TSD, (UBYTE *)msg->rm_Args[1], LengthArgstring( (UBYTE *)msg->rm_Args[1] ) );
 190
 191             if ( name == NULL || value == NULL )
 192             {
 193               if ( name != NULL ) Free_stringTSD( name );
 194               if ( value != NULL ) Free_stringTSD( value );
 195               msg->rm_Result1 = RC_ERROR;
 196               msg->rm_Result2 = ERR10_003;
 197             }
 198             else
 199             {
 200               setvalue( TSD, name, value );
 201               Free_stringTSD( name );
 202               msg->rm_Result1 = RC_OK;
 203               msg->rm_Result2 = (IPTR)NULL;
 204             }
 205           }
 206         }
 207         break;
 208
 209         case RXGETVAR:
 210         {
 211           if ( ( msg->rm_Action & RXARGMASK ) != 1 )
 212           {
 213             msg->rm_Result1 = RC_ERROR;
 214             msg->rm_Result2 = (IPTR)ERR10_017;
 215           }
 216           else
 217           {
 218             amiga_tsd_t *atsd = (amiga_tsd_t *)TSD->ami_tsd;
 219             streng *name;
 220             const streng *value;
 221
 222             name = createstreng( TSD, (char *)msg->rm_Args[0], LengthArgstring( (UBYTE *)msg->rm_Args[0] ) );
 223             if ( name == NULL )
 224             {
 225               msg->rm_Result1 = RC_ERROR;
 226               msg->rm_Result2 = (IPTR)ERR10_003;
 227             }
 228             else
 229             {
 230               value = isvariable( TSD, name );
 231               Free_stringTSD( name );
 232
 233               if ( value != NULL )
 234               {
 235                 if ( atsd->value != NULL) DeleteArgstring( (UBYTE *)atsd->value );
 236                 atsd->value = CreateArgstring( (STRPTR)value->value, value->len );
 237
 238                 msg->rm_Result1 = RC_OK;
 239                 msg->rm_Result2 = (IPTR)atsd->value;
 240               }
 241               else
 242               {
 243                 msg->rm_Result1 = RC_ERROR;
 244                 msg->rm_Result2 = (IPTR)ERR10_039;
 245               }
 246             }
 247           }
 248         }
 249         break;
 250
 251         default:
 252           msg->rm_Result1 = RC_ERROR;
 253           msg->rm_Result2 = ERR10_010;
 254           break;
 255         }
 256       ReplyMsg( (struct Message *)msg );
 257     }
 258   }
 259
 260   FreeSignal(atsd->subtasksignal);
 261   if ( listenport != NULL )
 262     DeletePort( listenport );
 263 }
 264
 265 /* Init amiga specific thread data, this function is called during initialisation
 266  * of the thread specific data
 267  */
 268 int init_amigaf ( tsd_t *TSD )
 269 {
 270   amiga_tsd_t *atsd = (amiga_tsd_t *)malloc( sizeof(amiga_tsd_t) );
 271   BPTR old;
 272
 273   if (atsd==NULL) return 0;
 274
 275   TSD->ami_tsd = (void *)atsd;
 276
 277   atsd->portenvir.envir.e.name = NULL;
 278   atsd->portenvir.envir.type = ENVIR_AMIGA;
 279   atsd->rexxsysbase = (struct RxsLib *)OpenLibrary( "rexxsyslib.library", 44 );
 280   if ( atsd->rexxsysbase == NULL )
 281     return 0;
 282   old = CurrentDir(NULL);
 283   atsd->startlock = DupLock( old );
 284   CurrentDir(old);
 285   if (on_exit( exit_amigaf, atsd ) == -1)
 286     return 0;
 287   NewList( &atsd->resources );
 288   atsd->replyport = CreatePort( NULL, 0 );
 289   atsd->maintasksignal = AllocSignal( -1 );
 290   atsd->parent = FindTask( NULL );
 291
 292   atsd->value = NULL;
 293
 294   THREAD_PROTECT(createtask)
 295   subtask_tsd = TSD;
 296   atsd->child = CreateTask( "Regina Helper", 0, (APTR)ReginaHandleMessages, 8192 );
 297   if ( atsd->child != NULL )
 298     Wait(1<<atsd->maintasksignal);
 299   THREAD_UNPROTECT(createtask)
 300   FreeSignal(atsd->maintasksignal);
 301
 302   if ( atsd->child == NULL )
 303     return 0;
 304
 305   return 1;
 306 }
 307
 308
 309 /*
 310  * Support function for exec lists
 311  */
 312 static streng *getlistnames( tsd_t *TSD, struct List *list, const streng *sep )
 313 {
 314   int first = 1;
 315   struct Node *ln;
 316   streng *retval, *tmpstr;
 317
 318   retval = Str_cre_TSD( TSD, "" );
 319   ForeachNode( list, ln )
 320   {
 321     if ( !first )
 322     {
 323       tmpstr = Str_cat_TSD( TSD, retval, sep );
 324       if ( tmpstr != retval )
 325       {
 326         Free_string_TSD( TSD, retval );
 327         retval = tmpstr;
 328       }
 329     }
 330     else
 331     {
 332       first = 0;
 333     }
 334     tmpstr = Str_catstr_TSD( TSD, retval, ln->ln_Name );
 335     if ( tmpstr != retval )
 336     {
 337       Free_string_TSD( TSD, retval );
 338       retval = tmpstr;
 339     }
 340   }
 341
 342   return retval;
 343 }
 344
 345
 346 /*
 347  * SHOW a function the names available in different resource lists
 348  */
 349 streng *amiga_show( tsd_t *TSD, cparamboxptr parm1 )
 350 {
 351   cparamboxptr parm2 = NULL, parm3 = NULL;
 352   streng *name = NULL, *sep, *retval;
 353
 354   checkparam( parm1, 1, 3, "SHOW" );
 355   parm2 = parm1->next;
 356   if ( parm2 != NULL )
 357     parm3 = parm2->next;
 358
 359   if ( parm2 != NULL && parm2->value != NULL && parm2->value->len != 0 )
 360     name = parm2->value;
 361
 362   if ( parm3 == NULL || parm3->value == NULL || parm3->value->len == 0 )
 363     sep = Str_cre_TSD( TSD, " " );
 364   else
 365     sep = Str_dup_TSD( TSD, parm3->value );
 366
 367   switch( getoptionchar( TSD, parm1->value, "SHOW", 1, "", "CFLP" ) )
 368   {
 369   case 'F':
 370     retval = arexx_show( TSD, parm1 );
 371     break;
 372
 373   case 'C':
 374     LockRexxBase( 0 );
 375     if ( name == NULL )
 376       retval = getlistnames( TSD, &RexxSysBase->rl_ClipList, sep );
 377     else
 378     {
 379       char *s = str_of( TSD, name );
 380       struct Node *ln = FindName( &RexxSysBase->rl_ClipList, s );
 381       retval = int_to_streng( TSD, ln != NULL );
 382       Free_TSD( TSD, s );
 383     }
 384     UnlockRexxBase( 0 );
 385     break;
 386
 387   case 'L':
 388     LockRexxBase( 0 );
 389     if ( name == NULL )
 390       retval = getlistnames( TSD, &RexxSysBase->rl_LibList, sep );
 391     else
 392     {
 393       char *s = str_of( TSD, name );
 394       struct Node *ln = FindName( &RexxSysBase->rl_LibList, s );
 395       retval = int_to_streng( TSD, ln != NULL );
 396       Free_TSD( TSD, s );
 397     }
 398     UnlockRexxBase( 0 );
 399     break;
 400
 401   case 'P':
 402     Forbid();
 403     if ( name == NULL )
 404       retval = getlistnames( TSD, &SysBase->PortList, sep );
 405     else
 406     {
 407       char *s = str_of( TSD, name );
 408       struct Node *ln = FindName( &SysBase->PortList, s );
 409       retval = int_to_streng( TSD, ln != NULL );
 410       Free_TSD( TSD, s );
 411     }
 412     Permit();
 413     break;
 414   }
 415   Free_string_TSD( TSD, sep );
 416
 417   return retval;
 418 }
 419
 420
 421 /* amiga_find_envir will try to find the port with the given and
 422  * create an envir function for that
 423  */
 424 struct envir *amiga_find_envir( const tsd_t *TSD, const streng *name )
 425 {
 426   amiga_tsd_t *atsd = (amiga_tsd_t *)TSD->ami_tsd;
 427   char *s;
 428   struct MsgPort *port;
 429
 430   s = str_of( TSD, name );
 431   port = FindPort( s );
 432   FreeTSD( s );
 433
 434   if (port == NULL)
 435     return NULL;
 436
 437   if ( atsd->portenvir.envir.e.name != NULL )
 438     Free_stringTSD( atsd->portenvir.envir.e.name );
 439
 440   atsd->portenvir.envir.e.name = Str_dupTSD( name );
 441   atsd->portenvir.port = port;
 442
 443   return (struct envir *)&(atsd->portenvir);
 444 }
 445
 446 /* createreginamessage will create a RexxMsg filled with the necessary fields
 447  * for regina specific things
 448  */
 449 struct RexxMsg *createreginamessage( const tsd_t *TSD )
 450 {
 451   amiga_tsd_t *atsd = (amiga_tsd_t *)TSD->ami_tsd;
 452   struct RexxMsg *msg;
 453
 454   msg = CreateRexxMsg( atsd->replyport, NULL, NULL );
 455   if ( msg != NULL )
 456   {
 457     msg->rm_Private1 = (IPTR)atsd->listenport;
 458     msg->rm_Private2 = (IPTR)TSD;
 459   }
 460   return msg;
 461 }
 462
 463 /* The function sendandwait will send a rexx message to a certain
 464  * port and wait till it returns. It the mean time also other
 465  * message (like variable can be handled
 466  * The replyport of the msg has to be atsd->listenport
 467  */
 468 void sendandwait( const tsd_t *TSD, struct MsgPort *port, struct RexxMsg *msg )
 469 {
 470   amiga_tsd_t *atsd = (amiga_tsd_t *)TSD->ami_tsd;
 471   struct RexxMsg *msg2;
 472
 473   PutMsg( port, (struct Message *)msg );
 474
 475   msg2 = NULL;
 476   while ( msg2 != msg )
 477   {
 478     WaitPort( atsd->replyport );
 479     msg2 = (struct RexxMsg *)GetMsg( atsd->replyport );
 480     if ( msg2 != msg )
 481       ReplyMsg( (struct Message *)msg2 );
 482   }
 483 }
 484
 485
 486
 487 streng *AmigaSubCom( const tsd_t *TSD, const streng *command, struct envir *envir, int *rc )
 488 {
 489   struct RexxMsg *msg;
 490   struct MsgPort *port = ((struct amiga_envir *)envir)->port;
 491   streng *retval = NULL;
 492
 493   msg = createreginamessage( TSD );
 494   msg->rm_Action = RXCOMM;
 495   msg->rm_Args[0] = (IPTR)CreateArgstring( (STRPTR)command->value, command->len );
 496   fflush(stdout);
 497   msg->rm_Stdin = Input();
 498   msg->rm_Stdout = Output();
 499
 500   sendandwait( TSD, port, msg );
 501
 502   *rc = msg->rm_Result1;
 503   if (msg->rm_Result1 == 0)
 504   {
 505     if (msg->rm_Result2 == NULL)
 506       retval = Str_crestrTSD( "" );
 507     else
 508     {
 509       retval = Str_ncre_TSD( TSD, (UBYTE *)msg->rm_Result2, LengthArgstring( (UBYTE *)msg->rm_Result2 ) );
 510       DeleteArgstring( (UBYTE *)msg->rm_Result2 );
 511     }
 512   }
 513   else
 514     retval = Str_crestrTSD( "" );
 515
 516   DeleteArgstring( (UBYTE *)msg->rm_Args[0]);
 517   DeleteRexxMsg( msg );
 518
 519   return retval;
 520 }
 521
 522
 523 /*
 524  * Here follows now the support function for ARexx style function hosts and libraries:
 525  * addlib and remlib.
 526  * Also here the try_func_amiga is defined which is called when a function is called
 527  * in an ARexx script.
 528  */
 529
 530 /* When addlib is called with two arguments the first argument is considered as a function
 531  * host name. When it is called with three or four arguments a function library is assumed
 532  */
 533 streng *amiga_addlib( tsd_t *TSD, cparamboxptr parm1 )
 534 {
 535   cparamboxptr parm2 = NULL, parm3 = NULL, parm4 = NULL;
 536   struct MsgPort *rexxport;
 537   struct RexxMsg *msg;
 538   int pri, offset, version, error, count;
 539   char *name;
 540   streng *retval;
 541
 542   checkparam( parm1, 2, 4, "ADDLIB" );
 543   parm2 = parm1->next;
 544   pri = streng_to_int( TSD, parm2->value, &error );
 545   if (error || abs(pri) > 100 )
 546     exiterror( ERR_INCORRECT_CALL, 11, "ADDLIB", 2, tmpstr_of( TSD, parm2->value ) );
 547
 548   parm3 = parm2->next;
 549   if ( parm3 != NULL && parm3->value != NULL && parm3->value->len == 0 )
 550     exiterror( ERR_INCORRECT_CALL, 21, "ADDLIB", 3 );
 551   if ( parm3 == NULL || parm3->value == NULL )
 552     offset = -30;
 553   else
 554   {
 555     offset = streng_to_int( TSD, parm3->value, &error );
 556     if ( error || offset >= 0 )
 557       exiterror( ERR_INCORRECT_CALL, 11, "ADDLIB", 3, tmpstr_of( TSD, parm3->value ) );
 558   }
 559
 560   if ( parm3 != NULL )
 561     parm4 = parm3->next;
 562   if ( parm4 == NULL || parm4->value == NULL || parm4->value->len == 0 )
 563     version = 0;
 564   else
 565   {
 566     version = streng_to_int( TSD, parm4->value, &error );
 567     if ( error )
 568       exiterror( ERR_INCORRECT_CALL, 11, "ADDLIB", 4, tmpstr_of( TSD, parm4->value ) );
 569     if ( version < 0 )
 570       exiterror( ERR_INCORRECT_CALL, 13, "ADDLIB", 4, tmpstr_of( TSD, parm4->value ) );
 571   }
 572
 573   name = str_of( TSD, parm1->value );
 574   msg = createreginamessage( TSD );
 575   if ( msg == NULL )
 576   {
 577     Free_TSD( TSD, name );
 578     exiterror( ERR_STORAGE_EXHAUSTED, 0 );
 579   }
 580   if ( parm3 == NULL || parm3->value == NULL || parm3->value->len == 0 )
 581   {
 582     msg->rm_Action = RXADDFH;
 583     msg->rm_Args[0] = (IPTR)name;
 584     msg->rm_Args[1] = (IPTR)pri;
 585     count = 2;
 586     if ( !FillRexxMsg( msg, 2, 1<<1 ) )
 587     {
 588       Free_TSD( TSD, name );
 589       DeleteRexxMsg( msg );
 590       exiterror( ERR_STORAGE_EXHAUSTED, 0 );
 591     }
 592   }
 593   else
 594   {
 595     msg->rm_Action = RXADDLIB;
 596     msg->rm_Args[0] = (IPTR)name;
 597     msg->rm_Args[1] = (IPTR)pri;
 598     msg->rm_Args[2] = (IPTR)offset;
 599     msg->rm_Args[3] = (IPTR)version;
 600     count = 4;
 601     if ( !FillRexxMsg( msg, 4, 1<<1 | 1<<2 | 1<<3 ) )
 602     {
 603       Free_TSD( TSD, name );
 604       DeleteRexxMsg( msg );
 605       exiterror( ERR_STORAGE_EXHAUSTED, 0 );
 606     }
 607   }
 608
 609   rexxport = FindPort( "REXX" );
 610   if (rexxport == NULL)
 611   {
 612     Free_TSD( TSD, name );
 613     DeleteRexxMsg( msg );
 614     exiterror( ERR_EXTERNAL_QUEUE, 0 );
 615   }
 616   sendandwait( TSD, rexxport, msg );
 617
 618   Free_TSD( TSD, name );
 619   ClearRexxMsg( msg, count );
 620
 621   retval = ( msg->rm_Result1 == 0 ) ? Str_cre_TSD( TSD, "1" ) : Str_cre_TSD( TSD, "0" );
 622
 623   DeleteRexxMsg( msg );
 624
 625   return retval;
 626 }
 627
 628 streng *amiga_remlib( tsd_t *TSD, cparamboxptr parm1 )
 629 {
 630   struct MsgPort *rexxport;
 631   struct RexxMsg *msg;
 632   streng *retval;
 633
 634   checkparam( parm1, 1, 1, "REMLIB" );
 635
 636   msg = createreginamessage( TSD );
 637   if ( msg == NULL )
 638     exiterror( ERR_STORAGE_EXHAUSTED, 0 );
 639
 640   msg->rm_Action = RXREMLIB;
 641   msg->rm_Args[0] = (IPTR)CreateArgstring( parm1->value->value, parm1->value->len );
 642
 643   rexxport = FindPort( "REXX" );
 644   if (rexxport == NULL )
 645   {
 646     DeleteArgstring( (UBYTE *)msg->rm_Args[0] );
 647     DeleteRexxMsg( msg );
 648     exiterror( ERR_EXTERNAL_QUEUE, 0 );
 649   }
 650   sendandwait( TSD, rexxport, msg );
 651
 652   retval = ( msg->rm_Result1 == 0 ) ? Str_cre_TSD( TSD, "1" ) : Str_cre_TSD( TSD, "0" );
 653
 654   DeleteArgstring( (UBYTE *)msg->rm_Args[0] );
 655   DeleteRexxMsg( msg );
 656
 657   return retval;
 658 }
 659
 660 streng *try_func_amiga( tsd_t *TSD, const streng *name, cparamboxptr parms, char called )
 661 {
 662   struct MsgPort *port;
 663   struct RexxMsg *msg;
 664   struct RexxRsrc *rsrc;
 665   struct Library *lib;
 666   ULONG result1;
 667   IPTR result2;
 668   UBYTE *retstring;
 669   unsigned int parmcount;
 670   cparamboxptr parmit;
 671   streng *retval;
 672
 673   msg = createreginamessage( TSD );
 674   if ( msg == NULL )
 675     exiterror( ERR_STORAGE_EXHAUSTED, 0 );
 676
 677   msg->rm_Action = RXFUNC | RXFF_RESULT;
 678   msg->rm_Args[0] = (IPTR)CreateArgstring( (char *)name->value, name->len );
 679
 680   for (parmit = parms, parmcount = 0; parmit != NULL; parmit = parmit->next)
 681   {
 682     if ( parmit->value != NULL && parmit->value->len > 0 )
 683     {
 684       parmcount++;
 685       msg->rm_Args[parmcount] = (IPTR)CreateArgstring( parmit->value->value, parmit->value->len );
 686     }
 687   }
 688   msg->rm_Action |= parmcount;
 689   msg->rm_Stdin = Input( );
 690   msg->rm_Stdout = Output( );
 691
 692   LockRexxBase(0);
 693
 694   for (rsrc = (struct RexxRsrc *)GetHead(&RexxSysBase->rl_LibList), result1 = 1;
 695        rsrc != NULL && result1 == 1;
 696        rsrc = (struct RexxRsrc *)GetSucc(rsrc))
 697   {
 698     switch (rsrc->rr_Node.ln_Type)
 699     {
 700     case RRT_LIB:
 701       lib = OpenLibrary(rsrc->rr_Node.ln_Name, rsrc->rr_Arg2);
 702       if (lib == NULL)
 703       {
 704         UnlockRexxBase(0);
 705         ClearRexxMsg( msg, parmcount + 1 );
 706         DeleteRexxMsg( msg );
 707         exiterror( ERR_EXTERNAL_QUEUE, 0 );
 708       }
 709       /* Can not pass &result2 directly because on systems where
 710        * sizeof(IPTR)>sizeof(UBYTE *) this goes wrong
 711        */
 712       result1 = RexxCallQueryLibFunc(msg, lib, rsrc->rr_Arg1, &retstring);
 713       CloseLibrary(lib);
 714       result2 = (IPTR)retstring;
 715       break;
 716
 717     case RRT_HOST:
 718       port = FindPort(rsrc->rr_Node.ln_Name);
 719       if (port == NULL)
 720       {
 721         UnlockRexxBase(0);
 722         ClearRexxMsg( msg, parmcount + 1 );
 723         DeleteRexxMsg( msg );
 724         exiterror( ERR_EXTERNAL_QUEUE, 0 );
 725       }
 726       sendandwait( TSD, port, msg);
 727
 728       result1 = (ULONG)msg->rm_Result1;
 729       result2 = msg->rm_Result2;
 730
 731     default:
 732       assert(FALSE);
 733     }
 734   }
 735
 736   UnlockRexxBase(0);
 737   ClearRexxMsg( msg, parmcount + 1 );
 738   DeleteRexxMsg( msg );
 739
 740   if ( result1 == 0 )
 741   {
 742     if ( (UBYTE *)result2 == NULL )
 743       retval = nullstringptr();
 744     else
 745     {
 746       retval = Str_ncre_TSD( TSD, (const char *)result2, LengthArgstring( (UBYTE *)result2 ) );
 747       DeleteArgstring( (UBYTE *)result2 );
 748     }
 749   }
 750   else if ( result1 == 1 )
 751     retval = NULL;
 752   else
 753     exiterror( ERR_EXTERNAL_QUEUE, 0 );
 754
 755   return retval;
 756 };
 757
 758
 759
 760 /* The clip handling functions for AROS/amiga: setclip, getclip */
 761
 762 streng *amiga_setclip( tsd_t *TSD, cparamboxptr parm1 )
 763 {
 764   cparamboxptr parm2;
 765   struct MsgPort *rexxport;
 766   struct RexxMsg *msg;
 767   streng *retval;
 768
 769   checkparam( parm1, 1, 2, "SETCLIP" );
 770   parm2 = parm1->next;
 771
 772   msg = createreginamessage( TSD );
 773   if ( msg == NULL )
 774     exiterror( ERR_STORAGE_EXHAUSTED, 0 );
 775
 776   if ( parm2 == NULL || parm2->value == NULL || parm2->value->len == 0 )
 777   {
 778     msg->rm_Action = RXREMCON;
 779     msg->rm_Args[0] = (IPTR)str_of( TSD, parm1->value );
 780   }
 781   else
 782   {
 783     msg->rm_Action = RXADDCON;
 784     msg->rm_Args[0] = (IPTR)str_of( TSD, parm1->value );
 785     msg->rm_Args[1] = (IPTR)parm2->value->value;
 786     msg->rm_Args[2] = (IPTR)parm2->value->len;
 787   }
 788
 789   rexxport = FindPort( "REXX" );
 790   if ( rexxport == NULL )
 791   {
 792     Free_TSD( TSD, (void *)msg->rm_Args[0] );
 793     DeleteRexxMsg( msg );
 794     exiterror( ERR_EXTERNAL_QUEUE, 0 );
 795   }
 796   sendandwait( TSD, rexxport, msg );
 797
 798   Free_TSD( TSD, (void *)msg->rm_Args[0] );
 799
 800   retval = ( msg->rm_Result1 == 0 ) ? Str_cre_TSD( TSD, "1" ) : Str_cre_TSD( TSD, "0" );
 801   DeleteRexxMsg( msg );
 802
 803   return retval;
 804 }
 805
 806 streng *amiga_getclip( tsd_t *TSD, cparamboxptr parm1 )
 807 {
 808   struct RexxRsrc *rsrc;
 809   char *name;
 810
 811   checkparam( parm1, 1, 1, "GETCLIP" );
 812
 813   name = str_of( TSD, parm1->value );
 814
 815   LockRexxBase(0);
 816   rsrc = (struct RexxRsrc *)FindName( &RexxSysBase->rl_ClipList, name );
 817   UnlockRexxBase(0);
 818
 819   Free_TSD( TSD, name );
 820
 821   if ( rsrc == NULL )
 822     return nullstringptr();
 823   else
 824     return Str_ncre_TSD( TSD, (const char *)rsrc->rr_Arg1, LengthArgstring( (UBYTE *)rsrc->rr_Arg1 ) );
 825 }
 826
 827 streng *amiga_pragma( tsd_t *TSD, cparamboxptr parm1 )
 828 {
 829   cparamboxptr parm2;
 830   streng *retval;
 831   static char buf[1024];
 832
 833   checkparam( parm1, 1, 2, "PRAGMA" );
 834   parm2 = parm1->next;
 835
 836   switch( getoptionchar( TSD, parm1->value, "PRAGMA", 1, "", "DPIS" ) )
 837   {
 838   case 'D':
 839     {
 840       BPTR lock = CurrentDir( NULL );
 841
 842       NameFromLock( lock, buf, 1023 );
 843       CurrentDir( lock );
 844       retval = Str_cre_TSD( TSD, buf );
 845       if ( parm2 != NULL && parm2->value != NULL && parm2->value->len != 0 )
 846       {
 847         struct FileInfoBlock *fib;
 848         char *name = str_of( TSD, parm2->value );
 849
 850         lock = Lock( name, ACCESS_READ );
 851
 852         Free_TSD( TSD, name );
 853
 854         fib = AllocDosObject( DOS_FIB, NULL );
 855         if ( fib == NULL )
 856         {
 857           if ( lock != NULL )
 858             UnLock( (BPTR)lock );
 859           exiterror( ERR_STORAGE_EXHAUSTED, 0 );
 860         }
 861
 862         if ( lock != NULL )
 863           Examine( lock, fib );
 864
 865         if ( lock == NULL || fib->fib_DirEntryType <= 0 )
 866         {
 867           FreeDosObject( DOS_FIB, fib );
 868           Free_string_TSD( TSD, retval );
 869           retval = nullstringptr();
 870         }
 871         else
 872         {
 873           UnLock( CurrentDir( lock ) );
 874           FreeDosObject( DOS_FIB, fib );
 875         }
 876       }
 877     }
 878     break;
 879
 880   case 'P':
 881     {
 882       struct Task *task = FindTask( NULL );
 883       retval = int_to_streng( TSD, (int)task->tc_Node.ln_Pri );
 884       if ( parm2 != NULL && parm2->value != NULL && parm2->value->len != 0 )
 885       {
 886         int pri, error;
 887         pri = streng_to_int( TSD, parm2->value, &error );
 888         if ( error )
 889           exiterror( ERR_INCORRECT_CALL, 11, "PRAGMA", 2, tmpstr_of( TSD, parm2->value ) );
 890         if ( abs(pri) > 127 )
 891           exiterror( ERR_INCORRECT_CALL, 0 );
 892         SetTaskPri( task, pri );
 893       }
 894     }
 895     break;
 896
 897   case 'I':
 898     {
 899       char s[10];
 900       sprintf(s, "%8X", (int)FindTask( NULL ) );
 901       if ( parm2 != NULL && parm2->value != NULL )
 902         exiterror( ERR_INCORRECT_CALL, 4, "PRAGMA", 1 );
 903       retval = Str_cre_TSD( TSD, s );
 904     }
 905     break;
 906
 907   case 'S':
 908     {
 909       struct Process *process = (struct Process *)FindTask( NULL );
 910       ULONG size = (ULONG)((char *)process->pr_Task.tc_SPUpper - (char *)process->pr_Task.tc_SPLower);
 911       retval = int_to_streng( TSD, size );
 912 #warning second argument ignored because stack size increase is not implemented
 913     }
 914     break;
 915   }
 916
 917   return retval;
 918 }
 919