/*===========================================================================
  Copyright (C) 1987-2010 European Southern Observatory (ESO)
 
  This program is free software; you can redistribute it and/or 
  modify it under the terms of the GNU General Public License as 
  published by the Free Software Foundation; either version 2 of 
  the License, or (at your option) any later version.
 
  This program is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.
 
  You should have received a copy of the GNU General Public 
  License along with this program; if not, write to the Free 
  Software Foundation, Inc., 675 Massachusetts Ave, Cambridge, 
  MA 02139, USA.
 
  Correspondence concerning ESO-MIDAS should be addressed as follows:
	Internet e-mail: midas@eso.org
	Postal address: European Southern Observatory
			Data Management Division 
			Karl-Schwarzschild-Strasse 2
			D 85748 Garching bei Muenchen 
			GERMANY
===========================================================================*/

/*+++++++++++++++   MIDAS monitor source prepj  +++++++++++++++++++++++++
.LANGUAGE    C
.IDENTIFICATION  Module prepj.c
.AUTHOR  K. Banse 		ESO - Garching
.KEYWORDS
  MIDAS monitor
.COMMENTS
  holds PREPERR, TABLE_ACCESS, build_prg, SYNCHRO,
        DYNA_COM, STORE_FR, WAIT_SECS, WRITE_QU
        (StatProc)
.ENVIRONMENT  VMS and UNIX

.VERSION  [1.00] 870723:  from FORTRAN version 2.30 as of  861105

 101022		last modif
------------------------------------------------------------------------*/
 
#include <fileexts.h>

#include <stdio.h>
#include <stdlib.h>
#include <string.h>


#include <osyparms.h>
#include <monitdef.h>
#include <midback.h>
#include <commdef.h>
#include <fsydef.h>
 
/*

*/
 
void PREPERR(source,message,err_str)
 
/*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  provide controlled error handling in the monitor
.ALGORITHM
  depending upon the source display various explanatory error messages
.RETURNS
  nothing
----------------------------------------------------------------*/
 
char	*source   /* IN: FSY or OSY or MIDAS  */;
char	*message  /* IN: error message (if not '\0')
			 for display + MID$ERRMESS keyword
			 if 1. char = ' ', only into MID$ERRMESS */;
char	*err_str  /* IN: text causing the error,            \
                         if = ' ', ignore that parameter  */;
 
{
int   nn, n, usr_levl;

char  errlabel[4], prefix[8], tmp[120];
 


 

KIWORDS[OFF_PRSTAT] = ERRORS.SYS;		/* update keyword PROGSTAT */
KIWORDS[OFF_PRSTAT+1] = 10;
 
(void) SCKWRC("LASTINPUT",1,LINE.STR,1,40,&nn);	/* save 1st part of LINE */

if (KIWORDS[OFF_ERROR+3] == 0) return;		/* test error display flag */
 
if ((MONIT.ENV == 'P') && (ERRORS.SYS == 56))
   {
   (void) SCKWRC("MID$ERRMESS",1,tmp,1,80,&n);
   KIWORDS[OFF_OUTFLG] = nn;
   return;
   }
 
/*  display user provided message  */
 
if ((*message != '\0') && (*message != ' '))
   {
   if (MONIT.LEVEL > 0) SCTSYS(2,message);

   if (*err_str != ' ')
      {
      char   workline[MAX_LINE];

      nn = CGN_INDEXS(message,err_str);		/* find `err_str' in message */
      if (nn >= 0)
         {
         if (MONIT.LEVEL < 1) nn += ERRORS.OFFSET;
         memset((void *)workline,32,(size_t)nn);
         workline[nn] = '^';
         workline[nn+1] = '^';
         workline[nn+2] = '^';
         if (err_str[1] == '\0')
            nn -= 2;
         else if (err_str[2] == '\0')
            nn --;
         workline[nn+3] = '\0';
         SCTSYS(2,workline);
         }
      }
   }


/*  branch according to 'source'   */
 
if ((*source == 'F') || (*source == 'O'))	/* look for FSY,OSY errors */
   {
   OSY_MESSAGE(ERRORS.SYS,tmp);
   SCTSYS(2,tmp);
   }
 
else						/* now the MIDAS errors ...  */
   {
   if (ERRORS.STATUS != 0)
      {
      ERRORS.STATUS = 0;

      if (ERRO_INDX >= 0)
         {
         int e1, e2;

         e1 = KIWORDS[OFF_ERROR];
         e2 = ERRO_DISP;
         ERRO_DISP = 1;			/* enable error display  */
         KIWORDS[OFF_ERROR] = 0;
         MID_DSPERR();			/* display low level error */
         KIWORDS[OFF_ERROR] = e1;
         ERRO_DISP = e2;
         return;
         }
      }

   nn = KIWORDS[OFF_OUTFLG];			/* avoid output redirection */
   KIWORDS[OFF_OUTFLG] = 99;

   if (ERRORS.SYS < 0) 
      {
      if (*message == '\0')
         (void) sprintf(tmp,"Error no. %d",ERRORS.SYS);
      else
         {
         if (*message == ' ')
            (void) strncpy(tmp,&message[1],80);	/* use provided message */
         else
            (void) strncpy(tmp,message,80);	/* use provided message */
         }
      }

   else					/* for monitor error, find the */
      {					/* corresponding text in system file */
      usr_levl = KIWORDS[OFF_ERROR+1];
      if (usr_levl >= 2)
         (void) strcpy(prefix,"EXPERT.");
      else
         (void) strcpy(prefix,"NOVICE.");
      (void) sprintf(errlabel,"%3.3d",ERRORS.SYS);

      /*  now display related section in the MIDAS error file */

      if (CGN_DISPFIL(2,"MID_MONIT:syserr.dat",prefix,errlabel) == -1)
         {
         switch (ERRORS.SYS)
            {
           case 22:
           case 44:
           case 47:
           case 79:
            SCTPUT("problems opening error_message_file...  it looks as if");
            SCTPUT
            ("the max. no. of simultaneously opened files has been reached ");
            break;
           default:
            SCTPUT
         ("problems opening error_message_file or error_section not found...");
            }
         (void) sprintf(tmp,"problems with error no. = %d",ERRORS.SYS);
         SCTPUT(tmp);
         }
      else
         CGN_GETLIN("MID_MONIT:syserr.dat","EXPERT.",errlabel,tmp);
      }
   (void) SCKWRC("MID$ERRMESS",1,tmp,1,80,&n);

   KIWORDS[OFF_OUTFLG] = nn;
   }
}
/*

*/
 
int TABLE_ACCESS(flag,string,ival,rval,cval,dval,type,size)
 
/*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  replace string TABLE,COLUMN,ROW with the contents of the element in 
  column COLUMN and row ROW of table TABLE
.ALGORITHM
  use TCE_ACCESS
.RETURNS
  nothing
----------------------------------------------------------------------*/
 
int   flag    /* IN: = 0, read table element    
		          = 1, write table element  
		          = 2, get necessary table info        */;
char	*string    /* IN: table,col,row terminated by \0 */;
int   *ival   /* IO: integer value to be read or written  */;
float	*rval	   /* IN/OUT: real value to be read or written  */;
char	*cval	   /* IO: character value to be read or written  
			  or keyword name if flag=1 and nonchar. data */;
double	*dval	   /* IO: double prec. value to be read or written  */;
char	*type	   /* OUT: type of element: I,R,CHAR*..,D   
		           = ' ', if something wrong     */;
int   *size   /* OUT: length of value returned (for 'flag' = 0)  */;
	
{
int  tid, column, irow, nlo, nlon, inull, idum, iav, nullo;
int  dtyp, nw;
int  unit, stat, n, nn;

float     rnull, rdum;

double    ddum;

char  frame[200], cbuf[20];
	


/*  split input string into: table, column, row    */

*type = ' ';
n = 0;
nn = (int)strlen(string);
stat = CGN_EXTRSS(string,nn,',',&n,frame,200);
if (stat > 0)
   {
   stat = CGN_EXTRSS(string,nn,',',&n,cbuf,20);
   if (stat > 0)
      {
      if (string[n] == '@') n++;		/* take care of @row  */
      stat = CGN_CNVT(&string[n],1,1,&irow,&rdum,&ddum);
      if ((stat > 0) && (irow > 0)) goto open_table;
      }
   }
ERRORS.SYS = 86;				/* something wrong... */
return (-1);

open_table:
(void) FRAMACC('O',frame,2,&tid);		/* open table */
if (tid < 0) 
   {
   ERRORS.SYS = 47;
   return (-1);
   }

/* check row no.  if reading */
if (flag  == 0) 
   {
   stat = TCIGET(tid,&column,&nlo,&nlon,&nlon,&nlon);
   if (stat != ERR_NORMAL)			/* nlo = actual no of rows */
      {
      ERRORS.SYS = 48;
      goto table_error;
      }

   if (irow > nlo)		/* non-existing row no. */
      {
      ERRORS.SYS = 49;
      goto table_error;
      }
   }


if (((cbuf[0] == 's') || (cbuf[0] == 'S')) && 
    ((cbuf[1] == 'e') || (cbuf[1] == 'E')) &&  
    ((cbuf[2] == 'l') || (cbuf[2] == 'L')))
   {					/* was: if (stuindx(cbuf,sel) == 0) */
   *type = 'I';
   (void) TCSGET(tid,irow,ival);
   return 11;
   }
    
stat = TCCSER(tid,cbuf,&column);
if ((stat != ERR_NORMAL) || (column < 0))
   {
   if ((cbuf[0] >= '0') && (cbuf[0] <= '9'))
      {				/* insert the # sign for columns */
      frame[0] = '#';			/* and try once more ...  */
      (void) strcpy(&frame[1],cbuf);
      stat = TCCSER(tid,frame,&column);
      if ((stat == ERR_NORMAL) && (column >= 0)) goto tblget;
      }
   ERRORS.SYS = 48;
   goto table_error;
   }

tblget:				/* now get the column data type */
stat = TCBGET(tid,column,&dtyp,&nlo,&nlon);
if (stat != ERR_NORMAL)
   {
   ERRORS.SYS = 48;
   goto table_error;
   }

switch (dtyp)
   {
   case D_I1_FORMAT:
   case D_I2_FORMAT:
   case D_I4_FORMAT:
     *type = 'I';
     break;
   case D_R4_FORMAT:
     *type = 'R';
     break;
   case D_R8_FORMAT:
     *type = 'D';
     break;
   default:
     *type = 'C';
   }

if (flag == 2) return 2;




/* read table element */

if (flag == 0) 
   {
   (void) SCKRDR("NULL",2,1,&iav,&rnull,&unit,&nullo);

   switch (dtyp)
      {
      case D_I1_FORMAT:
      case D_I2_FORMAT:
      case D_I4_FORMAT:
         *type = 'I';
         stat = TCERDI(tid,irow,column,ival,&inull);
          if (inull == 1) *ival = (int) rnull;
         break;
      case D_R4_FORMAT:
         *type = 'R';
         stat = TCERDR(tid,irow,column,rval,&inull);
          if (inull == 1) *rval = rnull;
         break;
      case D_R8_FORMAT:
         *type = 'D';
         stat = TCERDD(tid,irow,column,dval,&inull);
          if (inull == 1) *dval = (double ) rnull;
         break;
      default:
         *type = 'C';
         stat = TCERDC(tid,irow,column,cval,&inull);
         if (inull == 1)
            {
            nw = 1;
            cval[0] = ' ';
            }
         else
            {
            nw = nlon;
            for (n=0; n<nw; n++)
               {
               if (cval[n] == '\0')
                  {
                  nw = n;
                  break;
                  }
               }
            }
         *size = nw;
         cval[nw] = '\0';
      }

   if (inull == 1) 			/* MID$INFO(8) reflects that's NULL */
      {
      nw = KIWORDS[OFF_INFO+7];		/* 0/34 for VALUE() or TNULL() */
      if (nw == 0)
         SCTPUT("Accessing NULL value in table - replaced by keyword NULL!!");
      KIWORDS[OFF_INFO+7] = 1;
      }
   else
      KIWORDS[OFF_INFO+7] = 0;
   }


/*  write table element */

else  
   {                      
   stat = TCMNUL(&idum,&rdum,&ddum);		/* read already null vals */
   if (stat != ERR_NORMAL)
      {
      ERRORS.SYS = 86;
      goto table_error;
      }

   switch (dtyp)
      {
      case D_I1_FORMAT:
      case D_I2_FORMAT:
      case D_I4_FORMAT:
         if (cval[0] != 'N') 
            (void) SCKRDI(cval,1,1,&iav,&idum,&unit,&nullo);

         stat = TCEWRI(tid,irow,column,&idum);
         *type = 'I';
         break;

      case D_R4_FORMAT:
         if (cval[0] != 'N') 
            (void) SCKRDR(cval,1,1,&iav,&rdum,&unit,&nullo);

         stat = TCEWRR(tid,irow,column,&rdum);
         *type = 'R';
         break;

      case D_R8_FORMAT:
         if (cval[0] != 'N') 
            (void) SCKRDD(cval,1,1,&iav,&ddum,&unit,&nullo);

         stat = TCEWRD(tid,irow,column,&ddum);
         *type = 'D';
         break;

      default: 
         nn = (int)strlen(cval) - 1;
         if ((cval[0] == '"') && (cval[nn] == '"'))
            {
            nw = nn;
            nn = 1;
            cval[nw] = '\0';
            }
         else
            nn = 0;
         
         stat = TCEWRC(tid,irow,column,&cval[nn]);
         *type = 'C';
      }
   }

if (stat != ERR_NORMAL)
   {
   ERRORS.SYS = 55;
   goto table_error;
   }
return 0;


table_error:
(void) FRAMACC('C',KAUX.OUT,0,&tid);
return (-1);
}
/*

*/

int build_prg(flag,spec_flg)

/*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  build a procedure from the rows of table stored in TOKEN[1].STR
  use columns #1 - #10  if not given in TOKEN[2].STR
.ALGORITHM
  use table interfaces
.RETURNS
  = 0, if all o.k.
----------------------------------------------------------------------*/

int   flag;    /* IN = 1 for building procedure from table 
		     = 2 for building procedure from ASCII file 
		     = 3 for building procedure for: inmidas -j "..." */
int   spec_flg;  /* IN = 0 for building a procedure
		       = 1 for building single command line */

{
int  fid, tid, icol, irow, findx;
int  stat, iav, m, n, nn, quote_flag;
static int first=0, indxadd=2;			/* index for addchar below */

char  *poff;
char  frame[100], mybuff[164], cbuf[24];
static char  *prline, *buff;
static char  addchar[4] = " ab";		/* for switching 'a' <-> 'b' */



if (first == 0)
   {
   first = 1;
   n = 2*MAX_LINE;		/* twice the max. size of command line */
   prline = (char *) malloc((size_t)n);
   buff = (char *) malloc((size_t)n);
   if ((prline == (char *)NULL) || (buff == (char *)NULL))
      {
      (void) printf("build_prg: could not allocate %d bytes...\n",n);
      return 80;
      }
   }


if (flag == 3)			/* here we handle the inmidas -j "..."  stuff */
   {
   (void) strcpy(frame,"MID_WORK:midjob  .prg");	/* new `midjobXY.prg */
   frame[15] = FRONT.DAZUNIT[0];
   frame[16] = FRONT.DAZUNIT[1];

   fid = CGN_OPEN(frame,1);
   if (fid < 0) return(81);

   (void) osawrite(fid,KAUX.STR,(int)strlen(KAUX.STR));
   (void) osaclose(fid);
   return 0;
   }


 
poff = prline;
if (flag == 1)
   (void) strcpy(frame,"MID_WORK:midtab   .prg");	/* new `midtabXYa.prg */
else 
   (void) strcpy(frame,"MID_WORK:midlis   .prg");	/* new `midlisXYa.prg */
 
m = 3 - indxadd; indxadd = m;
frame[17] = addchar[m];				/* toggle 'a' <-> 'b' */
frame[15] = FRONT.DAZUNIT[0];
frame[16] = FRONT.DAZUNIT[1];

fid = CGN_OPEN(frame,1);
if (fid < 0) return(81);


/*  here we handle the ASCII file stuff */

if (flag == 2)
   {
   quote_flag = 0;
   findx = MONIT.COUNT - 1;

   if (strcmp(TOKEN[0].STR,"WRITE/KEYW") == 0)	/* look for WRITE/KEYW */
      {
      n = CGN_INDEXC(TOKEN[1].STR,'/');		/* test, if char key */
      if (n > 0)
         {
         (void) memcpy(cbuf,TOKEN[1].STR,(size_t)n);
         cbuf[n] = '\0';
         n = MID_FNDKEY(cbuf,mybuff,&nn,&m,&stat);
         }
      else
         n = MID_FNDKEY(TOKEN[1].STR,mybuff,&nn,&m,&stat);

      if ((n >= 0) && (mybuff[0] == 'C')) quote_flag = 1;
      }

   for (m=0; m<findx; m++)
      {
      nn = CGN_COPY(poff,TOKEN[m].STR);
      poff += nn;
      *poff++ = ' ';
      }
   (void) strcpy(mybuff,&TOKEN[findx].STR[1]);
 
   tid = osaopen(mybuff,0);		/* open for reading */
   if (tid <= 0) 
      {
      nn = 22;
      goto closing;
      }
   icol = 0;				/* serves as line counter */

   if (quote_flag == 1) 
      mybuff[0] = '"';
   else
      mybuff[0] = ' ';

rd_loop:
   nn = osaread(tid,&mybuff[1],160);                /* get a file record */

   if (nn == 0)
      goto rd_loop;
   else if (nn < 0)
      goto eof_found;                              /*  EOF encountered  */

   icol++;
   if (quote_flag == 1)
      {
      nn++;					/* add '"' in the end */
      mybuff[nn++] = '"';
      mybuff[nn] = '\0';
      }
   nn = CGN_COPY(poff,mybuff);
   (void) osawrite(fid,prline,(int)strlen(prline));
   goto rd_loop;


eof_found:
   (void) osaclose(tid);
   if (icol == 0) 				/* empty file */
      {
      nn = 39;
      goto closing;
      }

   /* finally build up the command line */

   if ((spec_flg == 1) && (icol == 1)) 			/* single line */
      LINE.LEN = CGN_COPY(LINE.STR,prline);
   else
      {
      (void) strcpy(LINE.STR,"@@ ");
      (void) strcpy(&LINE.STR[3],&frame[9]);
      LINE.LEN = (int) strlen(LINE.STR);
      }
   }


/*  here we handle the table stuff */

else 
   {
   (void) strcpy(mybuff,TOKEN[1].STR);		/* save table name */
   tid = -1;
   stat = TCTOPN(mybuff,F_I_MODE,&tid);
   if (stat != ERR_NORMAL) goto err_open;
   stat = TCIGET(tid,&icol,&irow,&iav,&iav,&iav);  /* no. of columns +  rows */
   TCTCLO(tid);
   if (stat != ERR_NORMAL) goto err_tab;

   (void) sprintf(prline,"define/local loop/i/1/2 0,%d",irow);
   (void) osawrite(fid,prline,(int)strlen(prline));
   (void) strcpy(prline,"do loop = 1 loop(2)");
   (void) osawrite(fid,prline,(int)strlen(prline));


   /* now massage the command line */

   LINE.LEN = TOKBLD(2,LINE.STR,MAX_LINE,1,MONIT.COUNT);

   iav = CGN_INDEXS(LINE.STR,"[:");		/* look for first [:xyz] */
   if (iav < 0) goto bad_syntax;

   if (iav == 0)
      prline[0] = '\0';
   else
      {
      (void) memcpy(prline,LINE.STR,(size_t)iav);
      prline[iav] = '\0';
      }
  
   nn = iav;
   (void) memcpy(cbuf,&LINE.STR[iav+2],(size_t)20);
   cbuf[20] = '\0';
   iav = CGN_INDEXC(cbuf,']');		/* look for closing ']' */
   if (iav < 0) goto bad_syntax;
   cbuf[iav] = '\0';
   nn += (iav + 3);			/* skip the 3 ':' */

   (void) sprintf(buff,"{%s,:%s,@{loop}}",mybuff,cbuf);
   (void) strcat(prline,buff);
   (void) strcat(prline,&LINE.STR[nn]);
   (void) strcpy(LINE.STR,prline);		/* copy back to LINE.STR */

loop_again:
   iav = CGN_INDEXS(LINE.STR,"[:");		/* look for more [:xyz] */
   if (iav >= 0)
      {
      (void) memcpy(prline,LINE.STR,(size_t)iav);
      prline[iav] = '\0';
      nn = iav;
      (void) memcpy(cbuf,&LINE.STR[iav+2],(size_t)20);
      cbuf[20] = '\0';
      iav = CGN_INDEXC(cbuf,']');		/* look for closing ']' */
      if (iav < 0) goto bad_syntax;
      cbuf[iav] = '\0';
      nn += (iav + 3);			/* skip the 3 ':' */

      (void) sprintf(buff,"{%s,:%s,@{loop}}",mybuff,cbuf);
      (void) strcat(prline,buff);
      (void) strcat(prline,&LINE.STR[nn]);
      (void) strcpy(LINE.STR,prline);		/* copy back to LINE.STR */
      goto loop_again;
      }
   (void) osawrite(fid,prline,(int)strlen(prline));
 
   (void) strcpy(prline,"enddo");
   (void) osawrite(fid,prline,(int)strlen(prline));

   /* finally build up the command line */

   (void) strcpy(LINE.STR,"@@ ");
   (void) strcpy(&LINE.STR[3],&frame[9]);
   LINE.LEN = (int) strlen(LINE.STR);
   }


(void) osaclose(fid);				/* close file */
return (0);


bad_syntax:
nn = 5;
goto closing;

err_open:
nn = 47;
goto closing;

err_tab:
nn = 48;

closing:
(void) osaclose(fid);
return (nn);
}
/*

*/

int SYNCHRO(qualf)

/*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  handle the SYNCHRONIZE commands

 SYNCHRONIZE/MIDAS 
 SYNCHRONIZE/TIME 

----------------------------------------------------------------------*/
char *qualf;           /* IN: the qualifier string of SYNCHRONIZE/ */

{
char  str[200];

int  mm;



if (*qualf == 'M')			/* SYNC/MIDAS */
   {
   (void) MID_MOVKEY("O",str);             /* close keyfile */
   mm = CGN_COPY(str,FRONT.STARTUP);
   (void) strcpy(&str[mm],"FORGR  .KEY");
   str[mm+5] = FRONT.DAZUNIT[0];
   str[mm+6] = FRONT.DAZUNIT[1];
   (void) MID_MOVKEY("IM",str);             /* open keyfile again*/
   }

else					/* SYNC/TIME */
   {
   mm = MONIT.MXT[MONIT.LEVEL];     /* so get current timeout */
   if (mm > 0)
      {
      mm = (int) (MONIT.ENDT[MONIT.LEVEL] - oshtime());
      if (mm < 1)
         {
         (void)
         sprintf(str,"(ERR) Midas procedure %s timed out (%d seconds)",
                 PROC.FNAME,MONIT.MAXTIME);
         SCTPUT(str);
         KIWORDS[OFF_PRSTAT] = 998;
         KIWORDS[OFF_PRSTAT+1] = 10;
         return (1);
         }
      }
   }

return (0);
}
/*

*/

int DYNA_COM(qualf)

/*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  handle the CREATE/COMMAND, CREATE/D_COMMAND commands
  as well as DELETE/COMMAND

 CREATE/COMMAND [D_COMMAND)  user_command command LINE.STR ... 

----------------------------------------------------------------------*/
char *qualf;           /* IN: the qualifier string of CREATE/ */

{
int  iwa, jj, mm, kk, cpid;
register int nr, mr;
static int first = 0;

char  myquali, origq, save[20], command[8], qualif[4], *cpntra;
char  midwork[80];
register char  cc;
static char cname[160];





myquali = *qualf;

/* extract command + qualifier, convert to upper case and
   look for it (also obtain full length com_qualif string */
 
EXTRACOM(TOKEN[1].STR,command,qualif);
origq = qualif[0];		/* save original qualifier (1st char) */
iwa = 
FINDCOM(command,qualif,save,&kk,&mm,&cpntra,&jj);	/* qualif is I/O par. */



/* check, if command deletion */

if (myquali == 'X')			/* delete the command? */
   {
   (void) DELCOM(command,qualif);            /* try to delete...  */

   if (first != 0)
      {
      jj = 1;
      cpid = osaopen(cname,READ);
      if (cpid >= 0) 
         {
         while (jj == 1)
            {
            kk = osaread(cpid,midwork,80);
            if (kk < 0) break;
             
            if ( (strncmp(midwork,command,6) == 0) &&
                 (strncmp(midwork+6,qualif,4) == 0) )
               {
               kk = osaread(cpid,LINE.STR,80);		/* get old comm def */
               if (kk < 0) break;

               mm = 0;				/* offset now at beginning */
               myquali = midwork[11];		/* was it D_COMM before? */
               (void) osaclose(cpid);
               goto after_TOK1;
               }
           
            kk = osaread(cpid,LINE.STR,80);
            if (kk < 0) break;
            }

         (void) osaclose(cpid);
         }
      }
   return 0;
   }


/* here for creating new command defs */

if ( (MONIT.COUNT < 3) ||  		/* not enough parameters */
     (TOKEN[1].STR[1] == ',') )		/* no 'x,' in the beginning */
   return (5);

if (iwa < 2)				/* command already there */
   {
   if ((origq == ' ') && (qualif[0] != ' '))
      {					/* reset qualifier to blanks */
      qualif[0] = qualif[1] = qualif[2] = qualif[3] = ' ';
      }
   else if (mm >= 0)		/* no primitive command, saving possible */
      {
      if (first == 0)
         {
         first = 1;
         (void) OSY_TRNLOG("MID_WORK",midwork,80,&kk);
         (void) sprintf(cname,"%smidsav%c%c.coms",midwork,
                        FRONT.DAZUNIT[0],FRONT.DAZUNIT[1]);
         (void) osfdelete(cname);
         cpid = osaopen(cname,WRITE); 
         }
      else
         cpid = osaopen(cname,APPEND);

      if (cpid >= 0) 
         {
         (void) strncpy(save,command,6);
         (void) strncpy(save+6,qualif,4);
         save[10] = ' ', save[11] = myquali, save[12] = '\0';
         (void) osawrite(cpid,save,12);
         (void) osawrite(cpid,cpntra,(int)strlen(cpntra));
         (void) osaclose(cpid);

         jj = CGN_INDEXC(LINE.STR,' ');
         mm = CGN_INDEXC(&LINE.STR[jj+1],' ');
         mm += (jj + 2);
         goto after_TOK1;
         }
      }
   }


/*  check new command name against
                       a) commands of MIDAS programming language
                       b) special commands                             */

cc = command[0];
if ((cc < 'A') || (cc > 'Z')) return (11);	/* must begin with alpha */

save[0] = cc;
jj = 6;
for (nr=1; nr<6; nr++)
   {
   cc = command[nr];
   if (cc == ' ')
      {
      jj = nr;
      break;
      }
   save[nr] = cc;
   }
save[jj] = '\0';

for (nr=0; nr<MAX_BATCH; nr++)
   {
   if (strcmp(save,BATCH[nr].CMND) == 0) return (11);
   }


/*  isolate actual commline */

for (nr=jj; ;nr++)			/* we can start here in LINE.STR */
   {
   if (LINE.STR[nr] == ' ')
      {
      jj += (nr+1);
      for (mr=jj; ;mr++)
         {
         if (LINE.STR[mr] == ' ') 
            {
            mm = mr + 1;
            while(LINE.STR[mm] == ' ') mm++;
            goto after_TOK1;
            }
         }
      }
   }


/*  all o.k.  -   add the command dynamically   */

after_TOK1:
jj = 0;                          /* default: commands added out of a context */
if (CONTXT.STACK > 0)
   {
   for (nr=0; nr<MAX_CONTXT; nr++)           /* search for base context */
      {
      if (CONTXT.QUEUE[nr] == CONTXT.BASE)
         {
         jj = CONTXT.QUEUE[nr+CONTXT.STACK-1];       /* get current one */
         break;
         }
      }
   }


if ((LINE.STR[mm] == '"') &&
    (LINE.STR[LINE.LEN-1] == '"'))           /* remove surrounding '"' */
   {
   mm ++;
   LINE.LEN -- ;
   LINE.STR[LINE.LEN] = '\0';
   }

if (myquali == 'D')			/* check D_commands */
   {
   iwa = LINE.LEN - 1;				/* point to last char. */
   if (LINE.STR[iwa] != FSY_DIREND)
      {
      LINE.STR[++iwa] = FSY_DIREND;
      LINE.STR[++iwa] = '\0';
      LINE.LEN ++;
      }
   iwa = 0;
   }
else
   iwa = 1;

return(ADDCOM(command,qualif,jj,iwa,&LINE.STR[mm]));
}
/*

*/

int STORE_FR(wk_flag)

/*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  handle the STORE/FRAME command

 STORE/FRAME key input element_no exit_label     

----------------------------------------------------------------------*/
int  *wk_flag;		/* OUT: 1 if simple write/keyword,
			        0 if not                      */

{
int  stat, catalkey[8], lcatal, unit, nullo, iwa, iav, nb, m, felm;

char  *cpntr, save[120];




*wk_flag = 0;

stat = SCKRDI("CATAL",1,8,&iav,catalkey,&unit,&nullo);  /* read 8 values */
if (stat != ERR_NORMAL)
   {
   SCTSYS(2,"problems with keyword CATAL ");
   goto catal_out;
   }

if (TOKEN[3].STR[0] == '?')		/* get index into key CATAL   */
   felm = 0;				/* default is 1. element  */

else
   {
   float  rwa;
   double dwa;

   stat = CGN_CNVT(TOKEN[3].STR,1,1,&iwa,&rwa,&dwa);
   if ( (stat < 1) || (iwa < 1) || (iwa > iav) ) return (5);
          
   felm = iwa - 1;			/* move `felm' to C indexing */
   }

lcatal = catalkey[felm];
cpntr = FSY_DEFPNTR[6];
nb = CGN_INDEXS(TOKEN[2].STR,cpntr);
if (nb <= 0)
   {
   cpntr = FSY_DEFPNTR[15];                  /* look also for upper case */
   nb = CGN_INDEXS(TOKEN[2].STR,cpntr);
   if (nb <= 0)                              /* it's a simple WRITE/KEY  */
      {
      if (lcatal < 0)
         {
         for (m=0; m<iav; m++)     /* go on if other catalog still there */
            {
            if (catalkey[m] > 0) 
               {			/* continue like WRITE/KEY */
               *wk_flag = 1;
               return (0);
               }
            }
         goto catal_out;             /* No. This is really the end  */
         }

      catalkey[felm] = -1;
      (void) SCKWRI("CATAL",catalkey,1,iav,&unit);
      *wk_flag = 1;
      return (0);
      }
   }
       
/*  now handle the catalog stuff  */

if (lcatal < 0)
   {
   (void) sprintf(save,"catalog: %s already processed...",TOKEN[2].STR);
   SCTSYS(0,save);
   TOKEN[2].LEN = CGN_COPY(TOKEN[2].STR,"   ");
   goto catal_out;
   }


/*  get catalog info  */

(void) strcpy(TOKEN[9].STR,TOKEN[2].STR);
stat = SCCGET(TOKEN[9].STR,0,TOKEN[2].STR,save,&lcatal);
       
if (stat != ERR_NORMAL)                      /* check return from SCCGET  */
   {
   (void) sprintf(save,"problems with catalog %s",TOKEN[2].STR);
   SCTSYS(2,save);
   goto catal_out;
   }

catalkey[felm] = lcatal;
(void) SCKWRI("CATAL",catalkey,1,iav,&unit);  /* save current entry no.   */

TOKEN[2].LEN = (int) strlen(TOKEN[2].STR);     /* size of name in catalog */
if (TOKEN[2].STR[0] != ' ')
   {						/* continue like WRITE/KEY */
   *wk_flag = 1;
   return (0);
   }
       

/* get out of loop  */

catal_out:
(void) MID_CKLO(TOKEN[9].STR);

TOKEN[0].STR[0] = '*';		/* prepare command string for MYBATCH  */
TOKEN[0].STR[3] = '\0';
TOKEN[0].LEN = 3;
if (TOKEN[4].STR[0] == '?')
   {
   TOKEN[0].STR[1] = 'R';		/* RETURN statement  */
   TOKEN[0].STR[2] = 'E';
   }
else
   {
   TOKEN[0].STR[1] = 'G';		/* GOTO statement    */
   TOKEN[0].STR[2] = 'O';
   (void) strcpy(TOKEN[1].STR,TOKEN[4].STR);
   TOKEN[1].LEN = TOKEN[4].LEN;
   }

return (0);
}
/*

*/

int WAIT_SECS(string)

/*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  handle the WAIT/SECS commands

 WAIT/SECS    no_of_secs 	NOOP_flag ('x')

----------------------------------------------------------------------*/
char *string;		/* IN: the no. of seconds to wait */

{
int   iwa, iav;
unsigned int milsecs;

float  rwa;

double dwa;



if (KIWORDS[OFF_AUX+7] == 1) 		/* WAIT/SECS => NOOP */
   return 0;


if (MONIT.COUNT < 2)
   rwa = 1.0;				/* default to 1 sec */
else
   {
   if (TOKEN[2].STR[0] == 'x')		/* ignore the given time, just NoOp ... */
      iav = -1;
   else
      iav = CGN_CNVT(string,2,1,&iwa,&rwa,&dwa);
   if (iav < 1) rwa = 0.0;		/* bad no. string */
   }

if (rwa > 0.001)			/* WAIT 0 is a NOOP */
   {
   milsecs = (unsigned int) (rwa*1000.0);	/* units are millisecs */

   iav = MONIT.MXT[MONIT.LEVEL];	/* current timeout */
   if (iav > 0)
      {
      if (MONIT.LEVEL > 0)
         {
         iav = (int) (MONIT.ENDT[MONIT.LEVEL] - oshtime());
         if (iav < 1) return (0);		/* already timed out... */
         }
      iav *= 1000;                              /* `iav' was in seconds */
      if (milsecs > iav) milsecs = iav;         /* minimize with time left */
      }

   OSY_SLEEP(milsecs,1);
   }

return (0);
}
/*

*/

void WRITE_QU(qualif,retval)

/*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  handle the WRITE commands

 WRITE/OUT  text  or  file.txt section label    
 WRITE/_OUT  file section label   (no special file type required)

 WRITE/ERROR      error no.  [text ... ]   

----------------------------------------------------------------------*/
char *qualif;		/* IN: the qualifier string of WRITE */
int  *retval;		/* OUT: for WRITE/ERROR we return the error_source
				value (10 = Monitor, 100 = Application */
{
int   n, iwa, iav, from, kk, stat; 
register int nr;

char  *cpntr, save[120];
register char  cc;




if (*qualif == 'E')			/* WRITE/ERROR part */
   {
   int  no_display_flag=0;
   float  rwa;
   double dwa;


   *retval = 10;			/* default to Monitor error */

   n = CGN_INDEXC(TOKEN[1].STR,',');
   if (n > 0)
      {
      TOKEN[1].STR[n++] = '\0';
      cc = TOKEN[1].STR[n];
      if ((cc == 'A') || (cc == 'a'))
         {
         char cb[40];

         *retval = 100;			/* application error */
         (void) strcpy(cb,&TOKEN[1].STR[n]);
         n = CGN_INDEXC(cb,',') + 1;
         if (n > 0) 
            {
            cc = cb[n];
            if ((cc == 'N') || (cc == 'n'))
               no_display_flag = 1;	/* no display, just -> MID$ERRMESS */
            }
         }
      }

   iav = CGN_CNVT(TOKEN[1].STR,1,1,&iwa,&rwa,&dwa);
   if (iav <= 0)
      {
      ERRORS.SYS = 5;		/* set ERRORS.SYS to "wrong syntax..." */
      *retval = 10;			/* and force to monitor error */
      }
   else
      ERRORS.SYS = iwa;

   iav = 0;
   if (no_display_flag == 1) KAUX.OUT[iav++] = ' ';

   if (MONIT.COUNT > 2)			/* construct special message */
      {
      for (n=2; n<MONIT.COUNT; n++)
         {
         if (TOKEN[n].STR[0] == '"')
            kk = 1;
         else
            kk = 0;
         (void) strcpy(&KAUX.OUT[iav],&TOKEN[n].STR[kk]);
         iav += (TOKEN[n].LEN - kk - kk);
         KAUX.OUT[iav++] = ' ';
         }
      KAUX.OUT[iav] = '\0';
      }
   else
      {
      if (*retval == 100)
         (void) sprintf(&KAUX.OUT[iav],"Error no. %d",ERRORS.SYS);
      else
         KAUX.OUT[0] = '\0';
      }

   LINE.STR[0] = '\0';			/* invalidate command line itself */
   return;
   }


/* from here on WRITE/OUT stuff */

if (*qualif == '_') goto file_section;     /* display a file (section) */

iwa = MONIT.COUNT - 1;
if ((TOKEN[iwa].STR[0] == '\\') && (TOKEN[iwa].STR[1] == '<'))
   {
   CGN_strcpy(TOKEN[iwa].STR,&TOKEN[iwa].STR[1]);
   TOKEN[1].LEN --;
   }

iav = TOKEN[1].LEN;
if (iav < 5) goto single_line;

iav -= 4;
CGN_LOWCOPY(save,&TOKEN[1].STR[iav],5);
if (strcmp(save,".txt") != 0) goto single_line;


                        /*  o.k. we want to display a file (no processing) */
file_section:
if (TOKEN[2].STR[0] == '?') TOKEN[2].STR[0] = '\0';
stat = CGN_DISPFIL(0,TOKEN[1].STR,TOKEN[2].STR,TOKEN[3].STR);
if (stat != 0)
   {
   (void) sprintf(save,"file %s or given section not found",TOKEN[1].STR);
   SCTSYS(2,save);
   }
return;


/*  clean + write the LINE.STR to the terminal  */

single_line:
if (MONIT.COUNT >= 2)
   {
   cpntr = LINE.STR;
   for (n=1; n<MONIT.COUNT; n++)
      {
      from = 0;
      iav = TOKEN[n].LEN;
      if (TOKEN[n].STR[0] == '"')
         {
         if ((iav > 2) && (TOKEN[n].STR[iav-1] == '"'))
            {
            from = 1;
            iav -= 2;
            }
         }
      kk = 0;
      for (nr=from; nr<=iav; nr++)	/*  \{ and \}  ->  { and }  */
         {
         cc = TOKEN[n].STR[nr];
         KAUX.OUT[kk++] = cc;
         if (cc == '\\')
            {
            cc = TOKEN[n].STR[nr+1];
            if ((cc == '{') || (cc == '}')) kk --;
            }
         }
      KAUX.OUT[kk] = '\0';
      iav = CGN_COPY(cpntr,KAUX.OUT);
      cpntr += iav;
      *cpntr++ = ' ';			/* overwrite \0 with ' '  */
      }
   *(cpntr-1) = '\0';			/* avoid last added blank */
   }
else
   {
   LINE.STR[0] = ' ';
   LINE.STR[1] = '\0';
   }

n = KIWORDS[OFF_LOG + 1];                        /* color wanted ? */
if (n > 0)
   SCTMES(n,LINE.STR);
else
   SCTPUT(LINE.STR);
}
/*

*/

/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  do statistics on Midas procedures

to switch on change the two \\s to `star' and /`star' respectively

the same has to be done also in `prepx' with the line
ProcStat()

to print the statistics you must create a procedure named StatProc.prg
with any valid Midas command in it, e.g.:
WRITE/OUT This is StatProc...
and do @@ StatProc






void StatProc()

{
int  k, m;
int  *ipntr, lowlim;
register int  nr;
static int  *procstat, procinit = 0, procno = 0, omit = 0;

char  *cpntr, *kpntr;
static char  *procpntr, *compntr;

#define  PROCMAX   300


if (procinit == 0)
   {
   procinit = 1;
   m = 24 * PROCMAX;
   procpntr = malloc((size_t)m);
   m = 4 * PROCMAX;
   compntr = malloc((size_t)m);
   m = sizeof(int) * PROCMAX;
   procstat = (int *) malloc((size_t)m);
   }

if (strcmp(TOKEN[1].STR,"StatProc") == 0)
   {
   char  output[80];

   if (MONIT.COUNT > 2)
      lowlim = atoi(TOKEN[2].STR);
   else
      lowlim = 0;			
   cpntr = procpntr;
   kpntr = compntr;
   ipntr = procstat;
   for (nr=0; nr<procno; nr++)
      {
      m = *ipntr++;
      if (m > lowlim)
         {
         (void) sprintf(output,"(%s) %s: %d",kpntr,cpntr,m);
         SCTPUT(output);
         }
      cpntr += 24;
      kpntr += 4;
      }
   SCTPUT("   ");
   (void) sprintf(output,"lowlim used = %d",lowlim);
   SCTPUT(output);
   if (omit > 0)
      {
      (void) sprintf(output,"%d procedures omitted...",omit);
      SCTPUT(output);
      }
   return;
   }


cpntr = procpntr;
for (nr=0; nr<procno; nr++)
   {
   k = strcmp(TOKEN[1].STR,cpntr);
   if (k == 0)
      {
      ipntr = procstat + nr;
      *ipntr += 1;
      return;
      }
   cpntr += 24;
   }

if (procno < PROCMAX)
   {
   kpntr = compntr + (procno*4);
   cpntr = procpntr + (procno*24);
   if (TOKEN[1].LEN > 23)
      {
      (void) memcpy(cpntr,TOKEN[1].STR,(size_t)23);
      *(cpntr+23) = '\0';
      }
   else
      (void) memcpy(cpntr,TOKEN[1].STR,(size_t)(TOKEN[1].LEN+1));
   (void) strcpy(kpntr,TOKEN[0].STR);
   ipntr = procstat + procno;
   *ipntr = 1;
   procno ++;
   }
else
   {
   if (omit == 0) (void) printf
      ("StatProc: max. no. of procedures (%d) reached...\n",PROCMAX);
   omit ++;
   }
}

----------------------------------------------------------------------*/

