/*
 * This is a ".mus-file" to link Wafe with perl to create 
 * wafeperl or mofeperl.
 * 
 * The following user subroutines for Perl
 *  are defined here:
 *   &wafe_cmd("....wafe command....")
 *   &wafe_set("varname","value")
 *   &wafe_process_events();
 *
 * Additionally, a tcl function named perl is defined
 * that allows to call perl from Wafe (tcl)
 * 
 * Gustaf Neumann,     Mon Oct 18 01:08:24 GMT 1993
 */

#include "EXTERN.h"
#define MAIN
#include <wafe.h>
#include "perl.h"

extern int Perl_callback(
#if NeedFunctionPrototypes
    char *, int, int, int, int
#endif
);

extern SUBR * make_usub(
#if NeedFunctionPrototypes
    char *, int, int (*)(), char *
#endif
);

/*
static enum uservars {
    UV_curscr
};
*/

enum usersubs {
    US_wafe_cmd,
    US_wafe_set,
    US_process_events,
};

static int usersub();
static int userset();
static int userval();
static int wafe_last_sp;

static int
process_events()
    {
#ifdef RDD
    rddAppMainLoop(wafeAppContext);
#else
    XtAppMainLoop(wafeAppContext);
#endif
    return 0;
    }

  
static int
com_perl(clientData, comInterpreter, argc, argv)
ClientData    clientData;
Tcl_Interp   *comInterpreter;
int           argc;
char        **argv;
     {
     STR **st = stack->ary_array + wafe_last_sp;
     int sp=wafe_last_sp;
     int ret_sp;
     int i;

     DBUG_ENTER("perl");  
 
     if (argc < 2) 
	 {
	 wafeArgcError("perl","at least",1,argc);
	 DBUG_RETURN (TCL_ERROR);
         }
/*
     fprintf(stderr,"perl subroutine &%s will be called with %d args, sp=%d\n",
	     argv[1],argc-2,sp);
 */
     astore(stack, ++sp, Nullstr);	/* reserve spot for 1st return arg */
     for (i=2; i < argc; i++) 
	 astore(stack, ++sp, str_2mortal(str_make(argv[i],0)));
     
     ret_sp = Perl_callback(argv[1], sp, 0, 1, argc-2);
/*
     fprintf(stderr,"funcname=&%s, result=<%s>, ret_sp=%d\n",
         argv[1], str_get(st[1]), ret_sp);
*/
     Tcl_SetResult(comInterpreter, str_get(st[1]), TCL_VOLATILE);
     DBUG_RETURN (TCL_OK);
     }

void
init_wafe()
{
    int argc;
    char **argv;
    char *wafeAppClass;
    char *filename = "wafesub.c";

    int i;
    char *p;

    wafeScriptName = "perl";

    argc = origargc-1;
    argv = (char**) XtMalloc(sizeof(char*)*argc);
    
    for(i=0;i<origargc;i++) 
	{
	/* fprintf(stderr,"i=%d: <%s>\n",i,origargv[i]);*/
	if (i>0) argv[i-1] = origargv[i];
	}

    wafeAppClass = XtNewString(argv[0]);
    if ((p = strrchr(wafeAppClass, '/')))
	wafeAppClass = ++p;
    while((p = strrchr(wafeAppClass, '.')))
	*p = '-';
    *wafeAppClass = toupper(*wafeAppClass);


    /* setup Xt and Wafe */
    wafeTopLevel = XtVaAppInitialize(&wafeAppContext, wafeAppClass, NULL, 0, 
				 &argc, argv, NULL, NULL); 
    MOTIF_EDITRES_HANDLER(wafeTopLevel);

    wafeInit(argc,argv, 
	     False /* inputMode */,  
	     False /* promptMode */
	     );

/*    DBUG_PUSH("d:t"); */

    Tcl_CreateCommand(wafeInterpreter, "perl", com_perl, NULL, NULL);

/*
   no magic vars yet....
#define MAGICVAR(name, ix) uf.uf_index = ix, magicname(name, &uf, sizeof uf)

    MAGICVAR("curscr",	UV_curscr);
    MAGICVAR("stdscr",	UV_stdscr);
*/

    make_usub("wafe_cmd",	     US_wafe_cmd,	usersub, filename);
    make_usub("wafe_set",	     US_wafe_set,	usersub, filename);
    make_usub("wafe_process_events", US_process_events, usersub, filename);
  };


static int
usersub(ix, sp, items)
int ix;
register int sp;
register int items;
{
    STR **st = stack->ary_array + sp;
    register STR *Str;		/* used in str_get and str_gnum macros */
/*
    register int i;
    register char *tmps;
 */

    switch (ix) {
    case US_wafe_cmd:
        if (items != 1)
	    fatal("Usage: &wafe_set($cmd)");
	else {
	    int prev_sp = wafe_last_sp;
	    wafe_last_sp = sp;
	    wafeEval(wafeInterpreter,str_get(st[1]),"perl");
	    str_set(st[0], wafeInterpreter->result);
	    wafe_last_sp = prev_sp;
	}
	return sp;
    case US_wafe_set:
        if (items != 2)
	    fatal("Usage: &wafe_set($var,$value)");
	else {
	  Tcl_SetVar(wafeInterpreter, str_get(st[1]), str_get(st[2]), 
		     TCL_GLOBAL_ONLY);
	}
	return sp;

CASE int process_events
END

    default:
	fatal("Unimplemented user-defined subroutine");
    }
    return sp;
}

static int
userval(ix, str)
int ix;
STR *str;
{
/*
    switch (ix) {
    case UV_COLS:
	str_numset(str, (double)COLS);
	break;
    case UV_curscr:
	str_nset(str, &curscr, sizeof(WINDOW*));
	break;
    case UV_ttytype:
	str_set(str, ttytype);
	break;
    }
*/
    return 0;
}

static int
userset(ix, str)
int ix;
STR *str;
{
/*
    switch (ix) {
    case UV_COLS:
	COLS = (int)str_gnum(str);
	break;
    case UV_ttytype:
	strcpy(ttytype, str_get(str));
	break;
    case UV_Def_term:
	Def_term = savestr(str_get(str));
	break;
    case UV_My_term:
	My_term = (bool)str_gnum(str);
	break;
    }
*/
    return 0;
}
