short DB_Data(mvar *var, u_char *buf) // get $DATA()
{ short s; // for returns
int i; // a handy int
s = Copy2local(var); // get local copy
if (s < 0)
{ return s; // exit on error
}
systab->vol[volnum-1]->stats.dbdat++; // update stats
s = Get_data(0); // attempt to get it
i = 1; // assume data found
if (s == -ERRM7) // undefined global?
{ i = 0; // yes - no data
if (level == 0) // check for global
{ if (curr_lock) // if locked
{ SemOp( SEM_GLOBAL, -curr_lock); // release global lock
}
buf[0] = '0'; // zero to return
buf[1] = '\0'; // null terminated
return 1; // and exit
}
}
else if (s < 0) // if it failed
{ if (curr_lock) // if locked
{ SemOp( SEM_GLOBAL, -curr_lock); // release global lock
}
return s; // and exit
}
if ((!db_var.slen) && (!i)) // pointing at 1st
{ Index++;
}
if ((i) || (Index > blk[level]->mem->last_idx)) // found or passed end
{ s = Locate_next(); // get next record
if (s == -ERRM7) // any more?
{ if (curr_lock) // if locked
{ SemOp( SEM_GLOBAL, -curr_lock); // release global lock
}
return itocstring(buf, i); // return result
}
else if (s < 0) // error?
{ if (curr_lock) // if locked
{ SemOp( SEM_GLOBAL, -curr_lock); // release global lock
}
return s; // and exit
}
} // got next record
if (((db_var.slen < keybuf[0]) && // if smaller key and
(bcmp(&keybuf[1], db_var.key, db_var.slen) == 0)) || // a descendant?
(!db_var.slen))
{ i += 10; // add 10 to result
}
if (curr_lock) // if locked
{ SemOp( SEM_GLOBAL, -curr_lock); // release global lock
}
return itocstring(buf, i); // return result
}
short Dascii2(u_char *ret_buffer, cstring *expr, int posn)
{ int asc = -1; // default to -1
int i; // for loops
if ((posn > 0)&&(posn <= (int)expr->len)) // if within range
asc = (int)expr->buf[posn-1]; // get from string
i = itocstring( ret_buffer, asc); // convert answer to string
return i; // return the count
}
//***********************************************************************
// $VIEW(channel#,location[,size[,value]])
//
short Dview(u_char *ret_buffer, int chan, int loc,
int size, cstring *value)
{ int i; // a handy int
u_char *vb; // view buffer address
if (chan > -1) return -(ERRMLAST+ERRZ63); // must be negative for now
chan = (-chan) - 1; // negate it and 0 base
if (partab.jobtab->view[chan] == NULL) // got a block
return -(ERRMLAST+ERRZ63); // no - die
vb = (u_char *) partab.jobtab->view[chan]->mem; // get block mem address
if ((loc < 0) ||
(size < 1) ||
((loc + size) > systab->vol[chan]->vollab->block_size))
return -(ERRMLAST+ERRZ63); // out of range - die
vb = vb + loc; // offset to locn
if (value == NULL) // a read?
{ if (size == 1)
return itocstring(ret_buffer, *vb); // one byte
if (size == 2)
return itocstring(ret_buffer, *((u_short *) vb)); // two bytes
if (size == 4)
return itocstring(ret_buffer, *((u_int *) vb)); // four bytes
return mcopy(vb, ret_buffer, size); // return the string
}
ret_buffer[0] = '\0'; // null terminate
if ((size == 1) || (size == 2) || (size == 4)) // int type?
{ i = cstringtoi(value); // make int of it
if (size == 1) *vb = (u_char) i;
else if (size == 2) *((u_short *) vb) = (u_short) i;
else *((u_int *) vb) = i; // set some int type
}
else
{ if (size != value->len) return -(ERRMLAST+ERRZ63); // junk
bcopy(value->buf, vb, size); // copy whatever
}
return 0; // return OK
}
short DB_Get(mvar *var, u_char *buf) // get global data
{ short s; // for returns
s = Copy2local(var); // get local copy
if (s < 0)
{ return s; // exit on error
}
systab->vol[volnum-1]->stats.dbget++; // update stats
s = Get_data(0); // attempt to get it
if (s >= 0) // if worked
{ if (bcmp("$GLOBAL\0", &db_var.name.var_cu[0], 8) == 0) // if ^$G
{ s = itocstring(buf, *(u_int *) record); // block number
}
else
{ s = mcopy(record->buf, buf, record->len); // copy the data
}
}
if (curr_lock) // if locked
{ SemOp( SEM_GLOBAL, -curr_lock); // release global lock
}
return s; // return the count
}
short Dstack1x(u_char *ret_buffer, int level, int job)
{ int i; // a usefull int
ret_buffer[0] = '\0'; // null terminate
if (level < -1) return 0; // junk
i = systab->jobtab[job].cur_do; // default
if (systab->jobtab[job].error_frame > systab->jobtab[job].cur_do)
i = systab->jobtab[job].error_frame; // ensure we have the error bit
if (level > i) return 0; // nothing there
if (level == -1)
return itocstring(ret_buffer, i); // return the number
if (level == 0)
{ if (systab->jobtab[job].dostk[0].type == TYPE_JOB)
return mcopy((u_char *) "JOB", ret_buffer, 3); // for a JOB command
return mcopy((u_char *) "RUN", ret_buffer, 3); // normal run
}
if (level == systab->jobtab[job].error_frame) level = STM1_FRAME; // err frame
i = systab->jobtab[job].dostk[level].type & 127; // get the type
if (i == TYPE_RUN) return mcopy((u_char *) "BREAK", ret_buffer, 5);
if (i == TYPE_DO) return mcopy((u_char *) "DO", ret_buffer, 2);
if (i == TYPE_EXTRINSIC) return mcopy((u_char *) "$$", ret_buffer, 2);
if (i == TYPE_XECUTE) return mcopy((u_char *) "XECUTE", ret_buffer, 6);
ret_buffer[0] = '\0';
return 0; // else nothing
}
//***********************************************************************
// $TEXT(entryref)
//
// the entire string "entryref" is passed in one variable, eval it here
//
short Dtext(u_char *ret_buffer, cstring *str) // $TEXT()
{ int i = 0; // a handy int
int j = 0; // and another
u_char slen; // saved length
short s; // for functions
int off = 1; // line offset
u_char rou[4+MAX_NAME_BYTES]; // routine name
u_char tag[4+MAX_NAME_BYTES]; // the tag
cstring *cr; // the rou
cstring *ct; // and the tag
ret_buffer[0] = '\0'; // JIC
ct = (cstring *) &tag[0]; // use it this way
cr = (cstring *) &rou[0]; // ditto
ct->len = 0; // assume no tag
cr->len = 0; // no routine for now
if (bcmp("+0\0", str->buf, 3) == 0) // $T(+0) ?
{ for (i = 0; i < MAX_NAME_BYTES; i++) // copy rou name
{ if (!partab.jobtab->dostk[partab.jobtab->cur_do].rounam.var_cu[i])
break; // quit when done
ret_buffer[i] =
partab.jobtab->dostk[partab.jobtab->cur_do].rounam.var_cu[i]; // copy
}
ret_buffer[i] = '\0'; // null terminate
return (short) i; // and exit
}
if ((str->buf[i] != '+') && (str->buf[i] != '^')) // is there a tag
{ while (j < MAX_NAME_BYTES)
{ if ((i == 0) && (str->buf[i] == '%')) // leading %
{ ct->buf[j++] = str->buf[i++]; // copy it
continue; // and go for more
}
if (isalnum(str->buf[i]) == 0) break; // done
ct->buf[j++] = str->buf[i++]; // copy it
}
ct->buf[j] = '\0'; // null terminate tag
ct->len = j; // save the length
off = 0; // change offset to zero
while ((str->buf[i] != '+') &&
(str->buf[i] != '^') &&
(str->buf[i] != '\0')) i++; // skip to + ^ or null
} // end tag processing
if (str->buf[i] == '+') // if we have a plus
{ off = 0; // clear offset
i++; // skip the +
while (isdigit(str->buf[i]) != 0) // for all digits
off = (off * 10) + (str->buf[i++] - '0'); // extract the offset
} // end offset stuf
if ((str->buf[i] != '^') && (str->buf[i] != '\0'))
return -(ERRMLAST + ERRZ12); // complain
j = 0; // clear rou ptr
if (str->buf[i] == '^') // routine name
{ i++; // skip the ^
while (j < MAX_NAME_BYTES)
{ if ((j == 0) && (str->buf[i] == '%')) // leading %
{ cr->buf[j++] = str->buf[i++]; // copy it
continue; // and go for more
}
if (isalnum(str->buf[i]) == 0) break; // done
cr->buf[j++] = str->buf[i++]; // copy it
}
cr->buf[j] = '\0'; // null terminate rou
cr->len = j; // save the length
}
else // we need the current routine
{ for (j = 0; j < MAX_NAME_BYTES; j++)
if ((cr->buf[j] =
partab.jobtab->dostk[partab.jobtab->cur_do].rounam.var_cu[j])
== '\0') break; // copy till done
cr->buf[j] = '\0'; // null terminate rou
cr->len = j; // save the length
}
if (cr->len == 0) return 0; // no routine supplied -> null
if ((ct->len == 0) && (!off)) // just the name reqd?
return mcopy(cr->buf, ret_buffer, cr->len); // return the name
X_set("$ROUTINE", &partab.src_var.name.var_cu[0], 8); // setup for DB_Get
partab.src_var.volset = partab.jobtab->rvol; // vol
partab.src_var.uci = partab.jobtab->ruci; // uci
if (cr->buf[0] == '%') // manager routine?
partab.src_var.uci = 1; // point there
partab.src_var.slen = 0; // init key size
s = UTIL_Key_Build(cr, &partab.src_var.key[0]); // first key
if (s < 0) return s; // die on error
slen = s; // save key size
if (ct->len == 0) // no tag?
{ ct->len = itocstring(ct->buf, off); // cstring off
s = UTIL_Key_Build(ct,
&partab.src_var.key[slen]); // next key
if (s < 0) return s; // die on error
partab.src_var.slen = s + slen; // save key size
s = DB_Get(&partab.src_var, ret_buffer); // get it
if (s < 0)
{ ret_buffer[0] = '\0'; // nothing
s = 0; // zero length
}
return s; // and return it
}
for (j = 1; ; j++) // need to read all lines
{ cr->len = itocstring(cr->buf, j); // cstring j
s = UTIL_Key_Build(cr,
&partab.src_var.key[slen]); // next key
if (s < 0) return s; // die on error
partab.src_var.slen = s + slen; // save key size
s = DB_Get(&partab.src_var, ret_buffer); // get it
if (s < 0)
{ ret_buffer[0] = '\0'; // nothing
return 0; // zero length
}
for (i = 0; i < ct->len; i++) // check the tag
if (ret_buffer[i] != ct->buf[i]) break; // quit if different
if (i < ct->len) continue; // go for next if no match
if ((ret_buffer[i] != ' ') && // must be space
(ret_buffer[i] != '(') && // or (
(ret_buffer[i] != '\0')) continue; // or null
if (off == 0) return s; // no offset - all done
j = j + off; // add the offset
cr->len = itocstring(cr->buf, j); // cstring j
s = UTIL_Key_Build(cr,
&partab.src_var.key[slen]); // next key
if (s < 0) return s; // die on error
partab.src_var.slen = s + slen; // save key size
s = DB_Get(&partab.src_var, ret_buffer); // get it
if (s < 0)
{ ret_buffer[0] = '\0'; // nothing
s = 0; // zero length
}
return s; // done
}
}
short Dstack2x(u_char *ret_buffer, int level, cstring *code, int job)
{ int arg2 = 0; // arg 2 1 = ECODE
// 2 = MCODE
// 3 = PLACE
var_u *rounam; // routine name
int line; // line number
int i; // a handy int
u_char *p; // a handy pointer
mvar *var; // for ^$R()
u_char temp[3*MAX_NAME_BYTES]; // ditto
cstring *cptr; // ditto
short s; // ditto
ret_buffer[0] = '\0'; // null terminate
if (level < 0) return 0; // junk
i = systab->jobtab[job].cur_do; // default
if (systab->jobtab[job].error_frame > systab->jobtab[job].cur_do)
i = systab->jobtab[job].error_frame; // ensure we have the error bit
if (level > i) return 0; // nothing there
if (strncasecmp((const char *) code->buf, "ecode\0", 6) == 0) arg2 = 1;
else if (strncasecmp((const char *) code->buf, "mcode\0", 6) == 0) arg2 = 2;
else if (strncasecmp((const char *) code->buf, "place\0", 6) == 0) arg2 = 3;
else return (-(ERRZ50+ERRMLAST)); // junk
if (arg2 == 1) // "ECODE"
{ ret_buffer[0] = '\0'; // assume nothing
if (job != (partab.jobtab - systab->jobtab)) return (0); // can't find
var = (mvar *) ret_buffer; // use same space for mvar
X_set("$ECODE\0\0", &var->name.var_cu[0], 8);// copy in $ECODE
var->volset = 0;
var->uci = UCI_IS_LOCALVAR;
cptr = (cstring *) temp; // some spare space
cptr->len = itocstring(cptr->buf, level); // setup for subscript
var->slen = UTIL_Key_Build(cptr, &var->key[0]);
s = ST_Get(var, ret_buffer); // get and return
if (s == -ERRM6) s = 0; // allow for not there
return s;
}
if ((level == systab->jobtab[job].error_frame) &&
(level)) level = STM1_FRAME; // err frame adjust
if ((((systab->jobtab[job].dostk[level].type & 127) == TYPE_XECUTE) ||
((systab->jobtab[job].dostk[level].type & 127) == TYPE_RUN) ||
((systab->jobtab[job].dostk[level].type & 127) == TYPE_JOB)) &&
//(systab->jobtab[job].dostk[level].rounam.var_qu == 0))
(X_Empty(systab->jobtab[job].dostk[level].rounam.var_xu)))
{ if (arg2 == 2) // "MCODE"
{ ret_buffer[0] = '\0'; // JIC
if (systab->jobtab[job].cur_do < level) return 0; // no can do
if (job != (partab.jobtab - systab->jobtab)) return (0); // can't find
p = (u_char *)systab->jobtab[job].dostk[level].routine;
if (p == NULL) return 0; // nothing there
for (i = 0; ((ret_buffer[i] = p[i])); i++); // copy it
return i; // return the count
}
return mcopy((u_char *) "XECUTE", ret_buffer, 6); // "PLACE"
}
rounam = &(systab->jobtab[job].dostk[level].rounam); // point at routine name
line = systab->jobtab[job].dostk[level].line_num; // get line number
if (arg2 == 2) // "MCODE"
{ var = (mvar *) ret_buffer; // use same space for mvar
X_set("$ROUTINE", &var->name.var_cu[0], 8); // copy in $ROUTINE
var->volset = systab->jobtab[job].rvol; // vol number
var->uci = systab->jobtab[job].ruci; // uci number
if (rounam->var_cu[0] == '%') var->uci = 1; // check for a percent rou
cptr = (cstring *) temp; // some spare space
for (i = 0; i < MAX_NAME_BYTES; i++) // copy name
{ if (rounam->var_cu[i] == 0) break; // quit when done
cptr->buf[i] = rounam->var_cu[i]; // copy
}
cptr->buf[i] = '\0'; // null terminate
cptr->len = i; // save the length
s = UTIL_Key_Build(cptr, &var->key[0]); // make a key from it
if (s < 0) return s; // die on error
var->slen = (u_char) s; // save the length
cptr->len = itocstring(cptr->buf, line); // make a string from int
s = UTIL_Key_Build(cptr, &var->key[var->slen]); // make a key from it
if (s < 0) return s; // die on error
var->slen = (u_char) s + var->slen; // save the length
s = Dget1(ret_buffer, var); // get data
if (s < 0) s = 0; // ignore errors
ret_buffer[s] = '\0'; // null terminate
return s; // and return
}
i = 0; // the start
ret_buffer[i++] = '+'; // add plus
i = i + itocstring(&ret_buffer[i], line); // add the line number
ret_buffer[i++] = '^'; // the name indicator
for (arg2 = 0; arg2 < MAX_NAME_BYTES; arg2++) // copy name
if ((ret_buffer[i++] = rounam->var_cu[arg2]) == 0) break;
if (ret_buffer[i-1] == '\0') i--; // back up over null
ret_buffer[i] = '\0'; // null terminate
return i; // return length
}
//***********************************************************************
// $RANDOM(int)
//
short Drandom(u_char *ret_buffer, int seed)
{ if (seed < 1) return (-ERRM3); // an error
seed = random() % seed; // get a random number
return itocstring( ret_buffer, seed); // convert answer to string
}
short Dlength2(u_char *ret_buffer, cstring *expr, cstring *delim)
{ return itocstring( ret_buffer,
Dlength2x(expr, delim)); // copy to buf and ret len
}
//***********************************************************************
// $LENGTH(expr1[,expr2])
//
short Dlength1(u_char *ret_buffer, cstring *expr)
{ return itocstring( ret_buffer, expr->len); // just do it
}
short Dfind3(u_char *ret_buffer, cstring *expr1, cstring *expr2, int start)
{ int ret = 0; // return value
ret = itocstring( ret_buffer,
Dfind3x(expr1, expr2, start)); // eval into buffer
return (short) ret; // and return length
}
// Set data into $ECODE
// Returns 0 if no previous error at this level
short Set_Error(int err, cstring *user, cstring *space)
{ short t; // for function calls
int j; // a handy int
int flag; // to remember
mvar *var; // a handy mvar
cstring *tmp; // spare cstring ptr
char temp[3*MAX_NAME_BYTES]; // and some space
var = &partab.src_var; // a spare mvar
var->slen = 0; // no subs
// note - the uci and volset were setup by the caller
X_set("$ECODE\0\0", &var->name.var_cu[0], 8); // get the name
t = ST_Get(var, space->buf); // get it
if (t < 0) t = 0; // ignore undefined
flag = t; // remember if some there
if (t < MAX_ECODE) // if not too big
{ if ((t == 0) || (space->buf[t-1] != ','))
space->buf[t++] = ','; // for new $EC
j = -err; // copy the error (-ve)
if (err == USRERR) // was it a SET $EC
{ bcopy(user->buf, &space->buf[t], user->len); // copy the error
t += user->len; // add the length
}
else // not user error
{ if (j > ERRMLAST) // implementation error?
{ space->buf[t++] = 'Z'; // yes, Z type
j -= ERRMLAST; // subtract it
}
else
space->buf[t++] = 'M'; // MDC error
t += itocstring(&space->buf[t], j); // convert the number
} // end 'not user error'
space->buf[t++] = ','; // trailing comma
space->buf[t] = '\0'; // null terminate
space->len = t;
t = ST_Set(var, space); // set it
tmp = (cstring *) temp; // temp space
tmp->len = itocstring(tmp->buf, partab.jobtab->cur_do);
var->slen = UTIL_Key_Build(tmp, var->key);
if (flag) // if not first one
{ t = ST_Get(var, space->buf); // get it
if (t < 0) t = 0; // ignore undefined
flag = t; // remember for the return
if ((t == 0) || (space->buf[t-1] != ','))
space->buf[t++] = ','; // for new $EC
j = -err; // copy the error (-ve)
if (err == USRERR) // was it a SET $EC
{ bcopy(user->buf, &space->buf[t], user->len); // copy the error
t += user->len; // add the length
}
else // not user error
{ if (j > ERRMLAST) // implementation error?
{ space->buf[t++] = 'Z'; // yes, Z type
j -= ERRMLAST; // subtract it
}
else
space->buf[t++] = 'M'; // MDC error
t += itocstring(&space->buf[t], j); // convert the number
}
space->buf[t++] = ','; // trailing comma
space->buf[t] = '\0'; // null terminate
space->len = t;
}
t = ST_Set(var, space); // set it
} // end "TOO BIG" test
return (short) flag; // done
}
