/* @(#)prepd.c 17.1.1.2 (ESO-DMD) 02/25/02 17:53:07 */ /*=========================================================================== Copyright (C) 1995 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 routines PREPD +++++++++++++++++++++++ .LANGUAGE C .IDENTIFICATION Module PREPD .AUTHOR K. Banse ESO - Garching .ENVIRONMENT VMS and UNIX .KEYWORDS MIDAS monitor, processing of operands .COMMENTS holds EVALU, KEYFUNC, Replace_it, REPLACE, REPFORM, KEY_ACCESS, GETOP .VERSION [1.00] 870720: from FORTRAN version as of 870414 020222 last modif ---------------------------------------------------------------------------*/ #include #include #include #include #include #include #include #define BIT_0 0x1 extern char DATA_PATH[328]; /* */ int EVALU(nt) /*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ .PURPOSE Evaluate the logical expression stored in TOKEN[nt] - [nt+2] and return with 0 = .false. and 1 = .true. or -1 if something went wrong... TOKEN[nt] - [nt+2]: A op B, where op = == , != , > , >= , < or <= TOKEN[nt],[nt+2] consist of variables (ASCII string, ASCII constants - i.e. 1 or numerical constants of type integer or real .ALGORITHM cumbersome, but straight forward .RETURNS 0, if false - 1, if true -1, if something wrong -----------------------------------------------------------------*/ int nt /* IN: no. of token, where expression starts */; { int ibuf1, ibuf2, iop1, iop2; int retval, n, nnt, noff; register int nr; float rop1, rop2, rbuf1, rbuf2; double dop1, dop2, dbuf1, dbuf2; char *cop1, *cop2; char type[10], typ1, typ2, restype; char wbuf[2048]; register char cc; static char opcode[13] = "EQNEGTGELTLE" ; static char invcode[13] = "NEEQLELTGEGT"; cop1 = wbuf; /* handle 1. operand */ if ( (TOKEN[nt].STR[1] == '$') && /* check for MIDAS function */ ((TOKEN[nt].STR[0] == 'm') || (TOKEN[nt].STR[0] == 'M')) ) { n = TOKEN[nt].LEN - 2; noff = 1024; KEYFUNC(&TOKEN[nt].STR[2],n,&ibuf1,&rbuf1,cop1,&dbuf1,&noff,type); if (type[0] == ' ') /* try to compute ... */ { if (KEYCOMP(1,nt,type) != 0) type[0] = ' '; if (type[0] == 'I') ibuf1 = KAUX.IVAL; else if (type[0] == 'R') rbuf1 = KAUX.RVAL; else if (type[0] == 'D') dbuf1 = KAUX.DVAL; } } else GETOP(TOKEN[nt].STR,TOKEN[nt].LEN,&ibuf1,&rbuf1,cop1,&dbuf1,type,1024); if (type[0] == ' ') { ERRORS.INDEX = nt; goto badeval; } typ1 = type[0]; cop2 = &wbuf[1024]; /* handle 2. operand */ nnt = nt + 2; if ( (TOKEN[nnt].STR[1] == '$') && /* check for MIDAS function */ ((TOKEN[nnt].STR[0] == 'm') || (TOKEN[nnt].STR[0] == 'M')) ) { n = TOKEN[nnt].LEN - 2; noff = 1024; KEYFUNC(&TOKEN[nnt].STR[2],n,&ibuf2,&rbuf2,cop2,&dbuf2,&noff,type); if (type[0] == ' ') /* try to compute ... */ { if (KEYCOMP(1,nnt,type) != 0) type[0] = ' '; if (type[0] == 'I') ibuf2 = KAUX.IVAL; else if (type[0] == 'R') rbuf2 = KAUX.RVAL; else if (type[0] == 'D') dbuf2 = KAUX.DVAL; } } else GETOP(TOKEN[nnt].STR,TOKEN[nnt].LEN,&ibuf2,&rbuf2,cop2,&dbuf2,type,1024); if (type[0] == ' ') { ERRORS.INDEX = nnt; goto badeval; } typ2 = type[0]; /* maximize type + adjust operands to highest type */ if ((typ1 == 'C') || (typ2 == 'C')) { if (typ1 != typ2) { ERRORS.INDEX = nnt; goto badeval; /* we only allow typ1//typ2 = CC */ } restype = 'C'; CGN_UPSTR(cop1); /* convert to upper case */ CGN_UPSTR(cop2); goto sect_3500; /* character stuff is handled elsewhere */ } /* 1. operand = integer */ if (typ1 == 'I') { if (typ2 == 'R') { rop1 = (float) ibuf1; rop2 = rbuf2; } else if (typ2 == 'D') { dop1 = (double) ibuf1; dop2 = dbuf2; } else { iop1 = ibuf1; iop2 = ibuf2; } restype = typ2; } /* 1. operand = real */ else if (typ1 == 'R') { if (typ2 == 'I') { rop1 = rbuf1; rop2 = (float) ibuf2; restype = typ1; } else if (typ2 == 'D') { dop1 = (double) rbuf1; dop2 = dbuf2; restype = typ2; } else { rop1 = rbuf1; rop2 = rbuf2; restype = typ1; } } /* 1. operand = double prec. */ else { dop1 = dbuf1; /* double prec. is highest type... */ restype = 'D'; if (typ2 == 'I') dop2 = (double) ibuf2; else if (typ2 == 'R') dop2 = (double) rbuf2; else dop2 = dbuf2; } /* now do the actual operation */ sect_3500: noff = 0; /* default to .EQ. */ retval = 1; nnt = nt + 1; cc = TOKEN[nnt].STR[1]; if (cc == 'G') { noff = 1; if (TOKEN[nnt].STR[2] == 'E') noff = 2; } else if (cc == 'L') { retval = 0; noff = 1; if (TOKEN[nnt].STR[2] == 'T') noff = 2; } else if (cc == 'N') retval = 0; /* now handle the different cases (switched via 'noff') */ switch(noff) { case 0: /* handle .EQ. + .NE. */ if (restype == 'I') { if (iop1 == iop2) return (retval); } else if (restype == 'R') { if (rop1 == rop2) return (retval); } else if (restype == 'D') { if (dop1 == dop2) return (retval); } else if (strcmp(cop1,cop2) == 0) return (retval); break; case 1: /* handle .GT. + .LE. */ if (restype == 'I') { if (iop1 > iop2) return (retval); } else if (restype == 'R') { if (rop1 > rop2) return (retval); } else if (restype == 'D') { if (dop1 > dop2) return (retval); } else if (strcmp(cop1,cop2) > 0) return (retval); break; case 2: /* handle .GE. + .LT. */ if (restype == 'I') { if (iop1 >= iop2) return (retval); } else if (restype == 'R') { if (rop1 >= rop2) return (retval); } else if (restype == 'D') { if (dop1 >= dop2) return (retval); } else if (strcmp(cop1,cop2) >= 0) return (retval); break; default: break; } return (1-retval); /* 1/0 => 0/1 */ badeval: (void) strcpy(LINE.STR,"IF "); /* rebuild original command */ (void) strcat(LINE.STR,TOKEN[nt].STR); n = (int)strlen(LINE.STR); LINE.STR[n++] = ' '; nnt = nt + 1; for (nr=0; nr<12; nr+=2) /* loop through possible codes */ { if ((TOKEN[nnt].STR[1] == opcode[nr])&&(TOKEN[nnt].STR[2] == opcode[nr+1])) { TOKEN[nnt].STR[1] = invcode[nr++]; TOKEN[nnt].STR[2] = invcode[nr]; break; } } (void) strcpy(&LINE.STR[n],TOKEN[nnt++].STR); n = (int)strlen(LINE.STR); LINE.STR[n++] = ' '; (void) strcpy(&LINE.STR[n],TOKEN[nnt].STR); return (-1); } /* */ void KEYFUNC(parm,lparm,ires,rres,cres,dres,crlen,restype) /*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ .PURPOSE calculate functions of the form M$FUNC(OPA,OPB,...) Note, that all 2-args functions have also to be added to KEXP_CLEAN !! .ALGORITHM test function, extract operands + evaluate function, determine type of result currently support functions are: M$ABS(op1) - op1 either integer or real value, result same type M$AGL(op1) - op1 char., result will be character string from agldevs.dat M$EXIST(op1) - op1 char., result integer, test if file 'op1' exists or not M$EXISTK(op1) - op1 char., result integer, test if key 'op1' exists or not M$EXISTD(op1,op2) - op1 char., op2 char., result integer, test if descriptor 'op2' of file 'op1' exists or not M$EXISTC(op1,op2) - op1 char., op2 char., result integer, test if column 'op2' of table 'op1' exists or not M$FILTYP(op1,op2) - op1 ch., op2 ch. = default file type if op1 without it; result integer, = 1, if p1 is an image = 2, if p1 is a table = 0, else M$FTSET(op1) - op1 char. - result integer: 1 if filetype given, else 0 M$INDEX(op1,op2) - op1, op2 either char. key or char. constant (i.e. "abcd") result will be integer, emulates the FORTRAN INDEX function M$INDEXB(op1,op2) - as M$INDEX but starting from the back of the string M$ISODATE() - result is current time in ISO 8601 format M$LEN(op1) - op1 char., result integer, get length of op1 using a blank as delimiter M$LN, EXP, LOG10, EXP10, SIN, COS, TAN, SQRT, ASIN, ACOS, ATAN(op1) - the usual mathematical functions... M$LOWER(op1) - op1 char., result will be op1 in lowercase M$NINT(op1) - op1 real or double, result integer M$PARSE(op1,op2) - op1 char., op2 char. parse 'op1' and fill keys 'op2'01,'op2'02,.. and 'op2'no M$SECS() - result will be seconds since 1. Jan 1970 (as long int) M$STRLEN(op1) - op1 char., result integer, get string length of op1 including blanks M$SYMBOL(op1) - op1 char., result char., get DCL symbol M$SYSTEM(op1) - op1 char., execute host command `op1' result is integer status of host system M$UPPER(op1) - op1 char., result will be op1 in uppercase M$TIME() - result is char. string containing current time M$TIME(op1) - op1 = 1, result contains current date as yyyy-mm-dd op1 = -1, result contains yesterday's date as yyyy-mm-dd M$TSTNO(op1) - op1 char., result integer, test if op1 is a number or not ----------------------------------------------------------------*/ char *parm; /* IN: points to function leading M$ already stripped off */ int lparm; /* IN: length of 'parm' */ int *ires; /* OUT: integer result */ float *rres; /* OUT: real result */ char *cres; /* OUT: char. result */ double *dres; /* OUT: double prec. result */ int *crlen; /* IN/OUT: max. length of `cres' (IN) actual length of cres (OUT) */ char *restype; /* OUT: type of result = I, R, C or D or ' ' = bad! */ { #define MAX_FUNCT 33 long int mytime, oshtime(); int imno, stat, l1, l2, m, n, n1, n2, nbra, fno; int fp, ibuf[5], unit; register int nr; char savchar, gettype[10], func[7], *c1, *c2, *tp; char wbuf[2048], htext[72]; /* 2-arg functions have to be synchronized with KEXP_CLEAN (prepg.c) */ static char *midfunc[MAX_FUNCT] = { "VALUE", "INDEX", "TIME", "ABS", "NINT", "TSTNO", "EXIST", "LEN", "SYMBO", "LN", "LOG10", "EXP", "EXP10", "SIN", "COS", "TAN", "SQRT", "ASIN", "ACOS", "ATAN", "LOG", "UPPER", "LOWER", "SECS", "AGL", "FILTY","PARSE","FTSET","STRLE", "ISODA", "TRIM", "REPLA", "SYSTE" }; struct FCB_STRUCT *fcbp; struct FCT_STRUCT *fctpntr; *restype = ' '; /* init to failure... */ c1 = wbuf; c2 = &wbuf[1024]; m = CGN_INDEXC(parm,'('); if ( (m <= 0) || (m > 7) ) return; if (m > 5) m = 5; CGN_UPCOPY(func,parm,m); /* isolate function name */ func[m] = '\0'; /* compare with existing functions */ for (nbra=0; nbra<9; nbra++) { if (strcmp(func,midfunc[nbra]) == 0) goto sect_1000; } for (nbra=9; nbra<21; nbra++) { if (strcmp(func,midfunc[nbra]) == 0) goto sect_2000; } m = MAX_FUNCT - 1; for (nbra=21; nbra TIME(-1.), so it's double.. */ else n = 0; } if (n != 0) { if (n > 0) n--; /* remove the offset for positive n again */ *crlen = CGN_DATE(0,n,cres); } else { OSY_ASCTIM(cres); /* get date + time */ *crlen = (int) strlen(cres); } *restype = 'C'; return; case 3: /* handle ABS(operand) */ n1 = lparm - 5; GETOP(parm+4,n1,ires,rres,cres,dres,gettype,1); if (gettype[0] == 'I') { if (*ires < 0) *ires = -(*ires); } else if (gettype[0] == 'R') { if (*rres < 0.0) *rres = -(*rres); } else if (gettype[0] == 'D') { if (*dres < 0.0) *dres = -(*dres); } else return; /* wrong data type... */ *restype = gettype[0]; return; case 4: /* handle NINT(operand), result will be integer */ n1 = lparm - 6; GETOP(parm+5,n1,ires,rres,c1,dres,gettype,60); if ((gettype[0] == ' ') || (gettype[0] == 'C')) return; /* invalid option */ else if (gettype[0] == 'R') *ires = CGN_NINT(*rres); else if (gettype[0] == 'D') *ires = CGN_DNINT(*dres); *restype = 'I'; return; case 5: /* handle TSTNO(operand), result will be 1 or 0 */ n1 = lparm - 7; GETOP(parm+6,n1,ires,rres,c1,dres,gettype,MAX_TOKEN); if (gettype[0] != 'C') *ires = 1; /* it's a number already... */ else { if (CGN_NUMBER(c1) == 1) *ires = 1; /* it's a number */ else *ires = 0; /* simple character string */ } *restype = 'I'; return; case 6: /* handle EXISTz(operand), result will be integer no. */ *ires = 0; /* default to failure */ if ((parm[5] == 'D') || (parm[5] == 'd')) goto sect_6600; /* M$EXISTD */ else if ((parm[5] == 'C') || (parm[5] == 'c')) goto sect_6500; /* M$EXISTC */ else if ((parm[5] == 'K') || (parm[5] == 'k')) n2 = 7; /* M$EXISTK */ else n2 = 6; /* M$EXIST */ n1 = lparm - n2 - 1; GETOP(parm+n2,n1,ires,rres,c1,dres,gettype,MAX_TOKEN); if (gettype[0] != 'C') return; /* we need a char. keyword */ *ires = 0; /* default to failure... */ if (n2 == 6) /* look for file */ { CGN_LOGNAM(c1,c2,200); /* translate logical name */ #if vms FSY_OPEN(c2,(int)strlen(c2),&n,&stat); if (stat & BIT_0) { *ires = 1; stat = SYS$DASSGN(n); } else if (stat == 98954) /* 1828a (hex) - file locked (FRAMACC) */ *ires = 1; else /* try once more after Midas-cleaning */ { m = CGN_singleframe(c2,1,c1); /* assume image type */ if (m == 1) { FSY_OPEN(c1,(int)strlen(c1),&n,&stat); if (stat & BIT_0) { *ires = 1; stat = SYS$DASSGN(n); } else if (stat == 98954) /* 1828a (hex) - file locked (FRAMACC) */ *ires = 1; } } #else fp = open(c2,O_RDONLY); /* read only */ if (fp >= 0) { *ires = 1; close(fp); } else /* try once more after Midas-cleaning */ { m = CGN_singleframe(c2,1,c1); /* assume image type */ if (m == 1) { fp = open(c1,O_RDONLY); /* read only */ if (fp >= 0) { *ires = 1; close(fp); } } if (*ires != 1) /* if not found, try the DPATH option */ { char work[168]; for (m=0; m<4; m++) { n = m*80; if (DATA_PATH[n] != '^') { (void) memcpy(work,&DATA_PATH[n],(size_t)80); work[80] = ' '; n = CGN_INDEXC(work,' '); (void) strcpy(&work[n],c1); /* use new path */ fp = open(work,O_RDONLY); /* open - read only */ if (fp >= 0) { *ires = 1; close(fp); break; } } } } } #endif } else /* look for keyword */ { if ( MID_FNDKEY(c1,gettype,&l2,&l2,&mytime,&unit) >= 0 ) *ires = 1; } *restype = 'I'; return; /* handle EXISTC(table,label), result will be column no. */ sect_6500: *ires = -2; m = CGN_INDEXC(parm,','); /* isolate 1. operand */ n1 = m - 7; GETOP(parm+7,n1,ires,rres,c1,dres,gettype,MAX_TOKEN); /* get 1. op */ if (gettype[0] != 'C') return; FRAMACC('O',c1,2,&imno); /* open table */ if (imno >= 0) { n2 = lparm - m - 2; GETOP(parm+m+1,n2,ires,rres,c2,dres,gettype,MAX_TOKEN); /* get 2. op */ *ires = -1; if (gettype[0] == 'C') { /* c2 = " " returns 0 (sequence no.)... */ if (*c2 != ' ') stat = TCCSER(imno,c2,ires); } } *restype = 'I'; return; /* handle EXISTD(oper1,oper2), result will be integer no. */ sect_6600: m = CGN_INDEXC(parm,','); /* isolate 1. operand */ n1 = m - 7; GETOP(parm+7,n1,ires,rres,c1,dres,gettype,MAX_TOKEN); /* get 1. op */ if (gettype[0] != 'C') return; FRAMACC('O',c1,0,&imno); if (imno >= 0) { n2 = lparm - m - 2; GETOP(parm+m+1,n2,ires,rres,c2,dres,gettype,MAX_TOKEN); /* get 2. op */ if (gettype[0] == 'C') { int dsclen; char realdescr[52]; c1[0] = ' '; fctpntr = FCT.ENTRIES + imno; fcbp = fctpntr->FZP; dsclen = CGN_UPCOPY(realdescr,c2,49); /* -> uppercase name */ if (fcbp->DSCFLAG == 'Y') m = MID_YDSCDIR(imno,'F',realdescr,c1,&n,&n,&unit,&l1,&l2,htext); else if (fcbp->DSCFLAG == 'Z') m = MID_ZDSCDIR(imno,'F',realdescr,dsclen,c1,&n,&n,&unit,&l1,&l2); else m = MID_DSCDIR(imno,'F',c2,c1,&n,&n,&unit,&l1,&l2); if (m != ERR_NORMAL) KIWORDS[OFF_PRSTAT] = 0; else *ires = 1; } } *restype = 'I'; return; case 7: /* handle LEN(operand), result will be integer no. */ n1 = lparm - 5; GETOP(parm+4,n1,ires,rres,c1,dres,gettype,1024); if (gettype[0] != 'C') return; n1 = (int)strlen(c1) - 1; if ((wbuf[0] == '"') && (wbuf[n1] == '"')) m = n1 + 1; else { m = CGN_INDEXC(c1,' '); if (m < 0) m = n1 + 1; } *ires = m; *restype = 'I'; return; case 8: /* handle SYMBOL(operand) */ n1 = lparm - 8; /* and get its length */ GETOP(parm+7,n1,ires,rres,c1,dres,gettype,MAX_TOKEN); /* get 1. op */ if (gettype[0] == 'C') { n2 = *crlen - 1; /* max length of result string */ OSY_GETSYMB(c1,cres,n2); *crlen = (int)strlen(cres); *restype = 'C'; } return; } sect_2000: switch(nbra) { /* handle LN, LOG10, EXP, EXP10, SIN, COS, TAN, SQRT, ASIN, ACOS, ATAN(operand) */ case 9: n2 = 4; goto sect_10010; case 10: n2 = 7; goto sect_10010; case 11: n2 = 5; /* EXP */ goto sect_10010; case 12: n2 = 7; /* EXP10 */ goto sect_10010; case 13: /* SIN, COS, TAN */ case 14: case 15: n2 = 5; goto sect_10010; case 16: /* SQRT, ASIN, ACOS, ATAN */ case 17: case 18: case 19: n2 = 6; goto sect_10010; case 20: nbra = 10; /* old LOG function */ n2 = 5; sect_10010: fno = nbra - 8; n1 = lparm - n2; GETOP(parm+n2-1,n1,ires,rres,c1,dres,gettype,60); if (gettype[0] == 'C') /* we don't like that!! */ return; else if (gettype[0] == 'R') *dres = *rres; else if (gettype[0] == 'I') *dres = *ires; CGN_FUNC(fno,dres); *restype = 'D'; return; } sect_3000: switch(nbra) { case 21: /* UPPER(operand), LOWER(operand) */ case 22: n1 = lparm - 7; GETOP(parm+6,n1,ires,rres,cres,dres,gettype,*crlen); if (gettype[0] == 'C') { if (nbra == 21) CGN_UPSTR(cres); else CGN_LOWSTR(cres); *crlen = (int)strlen(cres); *restype = 'C'; } return; case 23: /* SECS() */ *ires = (int) oshtime(); *restype = 'I'; return; case 24: /* handle AGL(operand) */ n1 = lparm - 5; GETOP(parm+4,n1,ires,rres,c1,dres,gettype,20); if (gettype[0] != 'C') return; CGN_FILL(cres,' ',20); /* clean result string first */ cres[20] = '\0'; *crlen = 20; *restype = 'C'; (void) OSY_TRNLOG("AGL3CONFIG",c2,200,&m); #if vms if (c2[m-1] != FSY_DISKEND) { if (c2[m-1] != FSY_DIREND) c2[m++] = FSY_DIREND; } #else if (c2[m-1] != FSY_DIREND) c2[m++] = FSY_DIREND; #endif (void) strcpy(&c2[m],"agldevs.dat"); fp = osaopen(c2,0); /* only for reading */ if (fp < 0) return; read_agl: n1 = osaread(fp,c2,40); if (n1 < 0) goto eof_agl; if ((n1 == 0) || (c2[0] == '#')) goto read_agl; l1 = CGN_INDEXC(c1,'.'); n2 = CGN_INDEXC(c2,':'); if (n2 > 0) { /* handle pc2usr1.c:pscript.c ... */ if ((l1 < 1 ) && (c2[n2-2] == '.')) { savchar = '.'; n2 -= 2; } else savchar = ':'; c2[n2] = '\0'; #if vms if (strcmp(c1,c2) != 0) { /* try with uppercase */ CGN_UPSTR(c2); if (strcmp(c1,c2) != 0) goto read_agl; } #else if (strcmp(c1,c2) != 0) goto read_agl; #endif c2[n2] = savchar; for (nr=n2; nr n1) /* so the `.' was in a directory */ { if (n == 1) (void) strcat(c1,c2); /* append given type */ } stat = strcmp(&c1[n1],".cat"); if (stat == 0) /* it's a catalog */ { fp = osaopen(c1,0); if (fp > -1) { *ires = 9; osaclose(fp); } return; } } stat = SCFINF(c1,9,ibuf); if (stat == ERR_NORMAL) { if (ibuf[1] == F_IMA_TYPE) *ires = 1; else if (ibuf[1] == F_TBL_TYPE) *ires = 2; else *ires = 3; } return; case 26: /* handle PARSE(op1,op2), result will be no. of subparms */ m = CGN_JNDEXC(parm,','); /* isolate 1. operand (avoid commas) */ n1 = m - 6; GETOP(parm+6,n1,ires,rres,c1,dres,gettype,MAX_TOKEN); /* get 1. op */ if (gettype[0] != 'C') return; n2 = lparm - m - 2; GETOP(parm+m+1,n2,ires,rres,c2,dres,gettype,MAX_TOKEN); if (gettype[0] != 'C') return; /* not good... */ n1 = 1; /* param counter */ n2 = 0; /* offset within c1 */ m = (int)strlen(c1); TOKEN[3].STR[0] = '?'; /* that's checked in DO_KEYS ... */ MONIT.COUNT = 3; tp = &wbuf[800]; while ((nr = CGN_EXTRSS(c1,m,',',&n2,TOKEN[2].STR,MAX_TOKEN)) > 0) { /* work on keyword `op2'`n1' */ (void) sprintf(tp,"%s%2.2d",c2,n1); TOKEN[2].LEN = nr; n = MID_FNDKEY(tp,gettype,&l1,&l2,&mytime,&unit); if (n > -1) /* keyword already there */ { if ((gettype[0] != 'C') || (l1 != 1) || (l2 < nr)) return; /* bad keyword */ TOKEN[1].LEN = CGN_COPY(TOKEN[1].STR,tp); n = DO_KEYS('W',wbuf); /* update existing keyword */ } else { if (nr < 80) nr = 80; /* at least 80 chars */ (void) sprintf(TOKEN[1].STR,"%s/C/1/%d",tp,nr); TOKEN[1].LEN = (int) strlen(TOKEN[1].STR); n = DO_KEYS('L',wbuf); /* create local keyword `op2'no */ } if (n != 0) return; n1 ++; } *ires = n1 - 1; *restype = 'I'; return; case 27: /* handle M$FTSET(operand) 1 or 0, if filetype given in `op1' */ n1 = lparm - 7; GETOP(parm+6,n1,ires,rres,c1,dres,gettype,MAX_TOKEN); if (gettype[0] != 'C') return; *restype = 'I'; *ires = 0; m = (int) strlen(c1); for (nr=m; nr>0; nr--) { if (wbuf[nr] == FSY_DIREND) return; else if (wbuf[nr] == FSY_TYPMARK) { *ires = 1; return; } } return; case 28: /* handle M$STRLEN(operand) */ if ((parm[5] != 'N') && (parm[5] == 'n')) return; n1 = lparm - 8; GETOP(parm+7,n1,ires,rres,c1,dres,gettype,1024); if (gettype[0] == 'C') { *ires = (int)strlen(c1); for (nr=0; nr<*ires; nr++) { if (*c1++ != ' ') goto not_empty; } *ires = 0; not_empty: *restype = 'I'; } return; case 29: /* handle ISODATE() */ *crlen = CGN_DATE(1,0,cres); /* get date as ISO 8601 string */ *restype = 'C'; return; case 30: /* handle M$TRIM(operand) */ n1 = lparm - 6; GETOP(parm+5,n1,ires,rres,c1,dres,gettype,MAX_TOKEN); if (gettype[0] == 'C') { *restype = 'C'; m = (int) strlen(c1); n1 = m; for (nr=0; nr 0) { int m1; char *cp1, *cp2; cp1 = c1+500; cp2 = c2+500; GETOP(c1,n2,ires,rres,cp1,dres,gettype,500); if (gettype[0] != 'C') return; (void) strcpy(cres,cp1); n2 = CGN_EXTRSS(parm,lparm,',',&n1,c1,500); GETOP(c1,n2,ires,rres,cp1,dres,gettype,500); if (gettype[0] != 'C') return; m1 = CGN_COPY(c1,cp1); n2 = CGN_EXTRSS(parm,lparm,')',&n1,c2,500); GETOP(c2,n2,ires,rres,cp2,dres,gettype,500); if (gettype[0] != 'C') return; n1 = 0; while ((n = CGN_INDEXS(cres+n1,c1)) > -1) { (void) strcpy(c2,cres+n1+n+m1); /* save part after pattern */ (void) strcpy(cres+n1+n,cp2); /* replace pattern */ n1 = (int) strlen(cres); (void) strcpy(cres+n1,c2); /* repaste saved part */ } *crlen = (int)strlen(cres); *restype = 'C'; } return; case 32: /* handle M$SYSTEM(op1) - execute HostSystem command `op1' */ n1 = lparm - 8; /* strip name and (,) */ GETOP(parm+7,n1,ires,rres,c1,dres,gettype,512); if (gettype[0] != 'C') return; *restype = 'I'; n1 = 0; while ((c1[n1] == ' ') || (c1[n1] == '\t')) n1++; #if vms c2[0] = '$'; /* make sure, we begin with $ */ (void) strcpy(&c2[1],c1+n1); RUN_IT(c2); /* don't know if VMS also has `system()' */ *ires = KIWORDS[OFF_AUX+16]; /* here the hostsys status was saved */ #else *ires = system(c1); #endif } } /* */ void Replace_it(parm,lparm,maxout,ibuf,rbuf,dbuf,datatype) /*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ .PURPOSE replace string "KEY(...)" with the contents of keyword KEY(...) and the same for string "FILE,DESCR(...)" and the same for string "FILE[x,y,z]" and the same for string "TABLE,COL,ROW" .ALGORITHM read relevant element of keyword (descr) + convert it to ASCII if necessary or get relevant pixel element .RETURNS int value < 0: error = 0: o.k., no expansion (no blanks inside TOKEN[].STR) > 0: o.k., yes expansion (blanks inside TOKEN[].STR) ------------------------------------------------------------------*/ char *parm; /* IO: parameter to be replaced */ int *lparm; /* IO: length of 'parm' */ int maxout; /* I: max length of 'parm' (for character stuff) */ int *ibuf; /* O: integer data */ float *rbuf; /* O: real data */ double *dbuf; /* O: double data */ char *datatype; /* O: data type, if = ' ', bad data */ { int n, nval; register int lr; char type[16], *ccp, *pntr; char wbuf[2048]; n = *lparm; (void) strncpy(wbuf,parm,n); /* *lparm not always length of parm */ wbuf[n] = '\0'; /* check, if image pixel access */ nval = -1; for (lr=1; lr,>],descr */ m++; if (wbuf[m] != ',') /* it's A[..] */ { if (PIXEL_ACCESS(0,wbuf,rbuf) == 0) *datatype = 'R'; /* o.k., handle like real data */ return; /* all done */ } else /* we have A[<,<:>,>],descr */ { nval = m; goto next_step; } } else if (wbuf[lr] == ',') /* it's a descr or a table */ { nval = lr; break; } } next_step: if (nval < 1) /* must be keyword... */ { /* for P1, P2, ..., P8 do a fast replacement */ if ( (wbuf[0] == 'P') && (lr == 2) && (wbuf[1] >= '0') && (wbuf[1] < '9') ) { n = wbuf[1] - 49; /* 'm' => m-1 */ pntr = &KCWORDS[MONIT.POFF[n]]; ccp = pntr + MAX_TOKEN - 1; /* point to last elem of Pi */ for (lr=MAX_TOKEN; lr>1; lr--) /* cut off trailing blanks */ { if ((*ccp != ' ') && (*ccp != '\0')) { nval = lr; goto copy_it; } ccp --; } nval = 1; copy_it: type[0] = 'C'; (void) strncpy(parm,pntr,nval); } else /* `normal' keyword */ { nval = maxout + 1; KEY_ACCESS(wbuf,ibuf,rbuf,parm,dbuf,type,nval); nval = (int)strlen(parm); /* set to length of returned parm */ } } else { /* second comma will decide between descr and table option */ if (CGN_INDEXC(&wbuf[nval+1],',') < 1) { nval = maxout; DESCR_ACCESS(0,wbuf,ibuf,rbuf,parm,dbuf,type,&n,&nval); } else TABLE_ACCESS(0,wbuf,ibuf,rbuf,parm,dbuf,type,&nval); } if (type[0] == 'C') *lparm = nval; *datatype = type[0]; } /* */ int REPLACE(parm,lparm,maxout) /*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ .PURPOSE replace string "KEY(...)" with the contents of keyword KEY(...) and the same for string "FILE,DESCR(...)" and the same for string "FILE[x,y,z]" and the same for string "TABLE,COL,ROW" .ALGORITHM read relevant element of keyword (descr) + convert it to ASCII if necessary or get relevant pixel element .RETURNS int value < 0: error = 0: o.k., no expansion (no blanks inside TOKEN[].STR) > 0: o.k., yes expansion (blanks inside TOKEN[].STR) ------------------------------------------------------------------*/ char *parm /* IO: parameter to be replaced */; int *lparm /* IO: length of 'parm' */; int maxout /* I: max length of 'parm' (for character stuff) */; { int ibuf; register int loop, lr; float rbuf; double dbuf; char datatype; lr = *lparm; if ((lr < 1) || (lr > 2047)) return (-2); /* bad string size */ Replace_it(parm,lparm,maxout,&ibuf,&rbuf,&dbuf,&datatype); if (datatype == 'C') /* character data */ { for (loop=0; loop<(*lparm); loop++) /* look if interspersed blanks .... */ { if (parm[loop] == ' ') { for (lr=loop+1; lr<(*lparm); lr++) { if (parm[lr] != ' ') return (1); } } } } else /* numeric data */ { if (datatype == ' ') return (-1); /* could not replace... */ REPFORM(datatype,&ibuf,&rbuf,&dbuf,1,parm,lparm); /* convert one value */ } return (0); } /* */ #ifdef __STDC__ void REPFORM(char type, int *ival, float *rval, double *dval, int lv, char *string, int *lstr) #else void REPFORM(type,ival,rval,dval,lv,string,lstr) /*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ .PURPOSE write binary values to ASCII string using currently active format .ALGORITHM get format from PROC.FORMAT and apply it .RETURNS nothing ----------------------------------------------------------------*/ char type /* IN: I or R or D, type of input values */; int *ival /* IN: integer input */; float *rval /* IN: real input */; double *dval /* IN: double prec. input */; int lv /* IN: number of input values */; char *string /* OUT: output string */; int *lstr /* OUT: length of 'string' */; #endif { int fyes, m, n, off_form, length, off; register int nr; char wbuf[256]; static char fmt[12] = "% "; off_form = MONIT.LEVEL * 15; /* use level for getting offset */ fmt[7] = ' '; /* make sure, there will be a blank */ fyes = 0; /* get currently used format + convert data accodingly */ if (type == 'I') /* integer data */ { fmt[1] = '0'; (void) strncpy(&fmt[2],&PROC.FORMAT[off_form],5); for (nr=3; nr<7; nr++) { if (fmt[nr] == ',') { fyes = -1; (void) strncpy(&fmt[1],&fmt[2],3); nr -- ; break; } else if (fmt[nr] == ' ') break; } fmt[nr++] = 'd'; fmt[nr++] = ' '; fmt[nr] = '\0'; if (lv == 1) /* single value */ { if (*ival < 0) { n = - (*ival); (void) sprintf(string+1,fmt,n); /* take care of minus sign */ *string = '-'; } else (void) sprintf(string,fmt,*ival); if (fyes == -1) *lstr = (int) strlen(string); else *lstr = CGN_INDEXC(string,' '); } else /* we work on an integer array */ { off = 0; for (nr=0; nr= '0') && (fmt[mr] <= '9')) mr ++; if (fmt[mr] == ';') /* xx;yy is F format without trailing 0's */ { fmt[mr] = '.'; if (fmt[mr+1] != '0') fyes = 1; } else if (fmt[mr] == ',') /* xx,yy is F format with trailing 0's */ { fyes = -1; fmt[mr] = '.'; (void) strncpy(&fmt[1],&fmt[2],5); /* get rid of `-' */ mr --; } else /* xx.yy is E format */ fc = 'E'; mr += 2; if ((fmt[mr] >= '0') && (fmt[mr] <= '9')) mr ++; fmt[mr++] = fc; fmt[mr] = '\0'; if (lv == 1) /* single value */ { if (type == 'R') (void) sprintf(string,fmt,*rval); else (void) sprintf(string,fmt,*dval); *lstr = (int) strlen(string); if (fyes != -1) { for (mr=*lstr-1; mr>=0; mr--) /* remove trailing blanks */ { if (string[mr] != ' ') { *lstr = mr + 1; break; } } if (fyes == 1) { mr = (*lstr) - 1; while ((string[mr] == '0') && (string[mr-1] != '.')) string[mr--] = ' '; *lstr = mr + 1; } } } else /* we work on a real/doubl. prec. array */ { off = 0; for (nr=0; nr=0; mr--) /* remove trailing blanks */ { if (string[mr] != ' ') { length = mr + 1; break; } } if (fyes == 1) { mr = length - 1; while ((wbuf[mr] == '0') && (wbuf[mr-1] != '.')) wbuf[mr--] = ' '; length = mr + 1; } } (void) strncpy(string+off,wbuf,length); *(string+off+length) = ','; off += (length + 1); /* point to position after the comma */ } *lstr = off - 1; } } } /* */ int KEY_ACCESS(parm,ibuf,rbuf,cbuf,dbuf,type,csiz) /*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ .PURPOSE return a key operand for REPLACE .ALGORITHM read relevant element(s) of keyword .RETURNS return status from SCKRDx calls -----------------------------------------------------------------*/ char *parm; /* IN: keyname with \0 ... */ int *ibuf; /* OUT: operand if integer */ float *rbuf; /* OUT: operand if real */ char *cbuf; /* OUT: operand if character */ double *dbuf; /* OUT: operand if double prec. */ char *type; /* OUT: type of operand, I, R, CHAR*n,D = ' ', if something wrong */ int csiz; /* IN: max. size of 'cbuf', including \0 ... */ { int last, stat, kk, ccsiz, lc; int iav, bytelem, first, selem, sfirst, unit, nullo; int *ipntr; static int work_size = 0; register int nr; static char *cpntr; char key[18], *tmppntr1; float *rpntr; double *dpntr; /* equivalence the pointers to work_space */ if (work_size == 0) { work_size = 400;; cpntr = malloc((unsigned int)work_size); } dpntr = (double *) cpntr; ipntr = (int *) cpntr; rpntr = (float *) cpntr; tmppntr1 = cpntr; /* parse keyword string */ KEY_PARSE(parm,key,type,&bytelem,&selem,&sfirst,&last); if (*type == ' ') { ERRORS.SYS = 84; return (-99); /* no match - return with 'type' = ' ' */ } /* get operand from keywords */ if (*type == 'I') { if (selem != -1) stat = SCKRDI(key,selem,1,&iav,ibuf,&unit,&nullo); else { kk = last - sfirst + 1; stat = SCKRDI(key,sfirst,kk,&iav,ipntr,&unit,&nullo); REPFORM('I',ipntr,rbuf,dbuf,kk,cbuf,&ccsiz); *type = 'C'; /* we now return a character string... */ } } else if (*type == 'R') { if (selem != -1) stat = SCKRDR(key,selem,1,&iav,rbuf,&unit,&nullo); else { kk = last - sfirst + 1; stat = SCKRDR(key,sfirst,kk,&iav,rpntr,&unit,&nullo); REPFORM('R',ibuf,rpntr,dbuf,kk,cbuf,&ccsiz); *type = 'C'; /* we now return a character string... */ } } else if (*type == 'D') { if (selem != -1) stat = SCKRDD(key,selem,1,&iav,dbuf,&unit,&nullo); else { kk = last - sfirst + 1; stat = SCKRDD(key,sfirst,kk,&iav,dpntr,&unit,&nullo); REPFORM('D',ibuf,rbuf,dpntr,kk,cbuf,&ccsiz); *type = 'C'; /* we now return a character string... */ } } else /* handle character keys specially */ { first = sfirst--; /* first is original `sfirst' */ if (last < 0) lc = -last; else lc = last; lc -= sfirst; csiz --; /* we need last character for '\0' */ if (lc > csiz) lc = csiz; /* minimize... */ if (bytelem == 1) /* flat string */ { stat = SCKRDC(key,1,first,lc,&iav,cbuf,&unit,&nullo); lc = iav; } else { if (lc+sfirst > bytelem) lc = bytelem - sfirst; stat = SCKRDC(key,bytelem,selem,1,&iav,tmppntr1,&unit,&nullo); (void) strncpy(cbuf,tmppntr1+sfirst,lc); } if (stat != ERR_NORMAL) return stat; cbuf[lc] = '\0'; if (last < 0) /* if no specific last index given, */ { for (nr=lc-1; nr>=0; nr--) /* cut off trailing blanks */ { if (cbuf[nr] != ' ') { cbuf[nr+1] = '\0'; return stat; } } /* cbuf[0] = '\0'; if we get here: all blanks */ } } return stat; /* return status from SCKRx calls */ } /* */ int GETOP(parm,lparm,ibuf,rbuf,cbuf,dbuf,type,csiz) /*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ .PURPOSE return an operand for COMPUTE/KEY or if commands .ALGORITHM read relevant element of keyword or convert ASCII string to constant .RETURNS return status from SCDRDx calls --------------------------------------------------------------------*/ char *parm /* IN: "abcd" (ASCII constant) or 123.456 \ or any string (+ keyname) */; int lparm /* IN: length of above */; int *ibuf /* OUT: operand if integer */; float *rbuf /* OUT: operand if real */; char *cbuf /* OUT: operand if character */; double *dbuf /* OUT: operand if double prec. */; char *type /* OUT: type of operand, I, R, CHAR*n,D \ = ' ', if something wrong */; int csiz /* IN: max. size of 'cbuf', including \0 ... */; { int last, it, lc, iav, unit, nullo, bytelem, first, stat; int sbytelem, selem, sfirst; register int nr; char test, key[18], *tmppntr1, *tpp; register char cr; tmppntr1 = (char *) &CODE.WORK[455]; /* use 160 chars, WORK[3640-3800] */ *type = ' '; /* init to failure... */ test = *parm; if (test == ' ') return (-99); /* test for character constants */ if (test == '"') /* character constant "xxxxx" */ { lc = lparm - 2; if ( (lc < 1) || (csiz <= lc ) ) return (-99); (void) strncpy(cbuf,parm+1,lc); cbuf[lc] = '\0'; *type = 'C'; return (0); } /* check, if plus/minus sign is first character */ if ((test == '-') || (test == '+')) /* skip plus/minus sign, if present */ { if (lparm > 1) test = *(parm+1); else return(0); /* syntax error... */ } /* make sure we have an end marker */ (void) strncpy(tmppntr1,parm,lparm); *(tmppntr1+lparm) = '\0'; /* test for numerical constants - we'll only split into integer / double */ if (test < 'A') /* numeric constant */ { it = 1; /* default to integer type. */ *type = 'I'; tpp = tmppntr1; if ((*tpp == '-') || (*tpp == '+')) tpp++; while((cr=*tpp++) != '\0') /* scan no. string */ { if ((cr == 'e') || (cr == 'E') || (cr == 'd') || (cr == 'D')) { it = 4; /* double prec. no. */ *type = 'D'; } else if (cr == '.') it = 2; else if ((cr == '+') || (cr == '-')) { if (it != 4) /* only o.k. for double */ { *type = ' '; return(0); } } } if (it == 2) { it = 4; *type = 'D'; } iav = CGN_CNVT(tmppntr1,it,1,ibuf,rbuf,dbuf); if (iav < 1) *type = ' '; /* return with 'type' = ' ' */ return(0); } /* so it's a keyword */ KEY_PARSE(tmppntr1,key,type,&sbytelem,&selem,&sfirst,&last); if (*type == ' ') return (-99); /* no match - return with 'type' = ' ' */ /* get operand from keywords */ if (*type == 'I') stat = SCKRDI(key,selem,1,&iav,ibuf,&unit,&nullo); else if (*type == 'R') stat = SCKRDR(key,selem,1,&iav,rbuf,&unit,&nullo); else if (*type == 'D') stat = SCKRDD(key,selem,1,&iav,dbuf,&unit,&nullo); else /* handle character keys specially */ { bytelem = sbytelem; first = sfirst--; /* first is original `sfirst' */ if (last < 0) lc = -last; else lc = last; lc -= sfirst; csiz --; /* we need last character for '\0' */ if (lc > csiz) lc = csiz; /* minimize... */ if (sbytelem == 1) /* flat string */ { stat = SCKRDC(key,1,first,lc,&iav,cbuf,&unit,&nullo); lc = iav; } else { if (lc+sfirst > sbytelem) lc = sbytelem - sfirst; stat = SCKRDC(key,bytelem,selem,1,&iav,tmppntr1,&unit,&nullo); (void) strncpy(cbuf,tmppntr1+sfirst,lc); } if (stat == ERR_NORMAL) { cbuf[lc] = '\0'; if (last < 0) { for (nr=lc-1; nr>=0; nr--) /* cut off trailing blanks */ { if (cbuf[nr] != ' ') { cbuf[nr+1] = '\0'; return stat; } } } } } return stat; } int KGN_INDEXS(s,t) /*++++++++++++++++++++++++++++++++++++++++++++++++++ .PURPOSE find position of substring in input string. .RETURN returns index of substring in input string (= 0,1,2,...), -1 if not there --------------------------------------------------*/ char *s; /* input string */ char *t; /* substring */ { register int nr; register char *cp, *cq, *qq, *t2; cp = s; t2 = t + 1; for (nr=0; *cp != '\0'; nr++) { if (*cp++ == *t) /* first char. has to match */ { qq = cp; /* points to 2. char in input string */ for (cq=t2; *cq != '\0'; ) { if (*cq++ != *qq++) goto no_match; } return (nr); } no_match: ; } return (-1); /* substring not found */ }