bool gvcmx_get(mval *v)
{
mval temp;
temp.mvtype = 0;
gvcmz_doop(CMMS_Q_GET, CMMS_R_GET, &temp);
if (MV_DEFINED(&temp))
*v = temp;
return MV_DEFINED(&temp);
}
void iosocket_iocontrol(mstr *mn, int4 argcnt, va_list args)
{
char action[MAX_DEVCTL_LENGTH];
unsigned short depth;
int length, n, timeout;
pid_t pid;
mval *arg, *handlesvar = NULL;
#ifdef GTM_TLS
mval *option, *tlsid, *password, *extraarg;
#endif
if (0 == mn->len)
return;
assert(MAX_DEVCTL_LENGTH > mn->len);
lower_to_upper((uchar_ptr_t)action, (uchar_ptr_t)mn->addr, mn->len);
length = mn->len;
if (0 == memcmp(action, "LISTEN", length))
{
if (1 > argcnt)
depth = DEFAULT_LISTEN_DEPTH;
else
{
arg = va_arg(args, mval *);
if ((NULL == arg) || M_ARG_SKIPPED(arg) || !MV_DEFINED(arg))
{
rts_error_csa(CSA_ARG(NULL) VARLSTCNT(1) ERR_EXPR);
return;
}
depth = MV_FORCE_INTD(arg);
}
iosocket_listen(io_curr_device.in, depth);
} else if (0 == memcmp(action, "WAIT", length))
void op_indglvn(mval *v,mval *dst)
{
bool rval;
mstr *obj, object;
oprtype x;
lv_val *a;
icode_str indir_src;
lv_val *lv;
var_tabent targ_key;
ht_ent_mname *tabent;
error_def(ERR_INDMAXNEST);
error_def(ERR_UNDEF);
MV_FORCE_STR(v);
indir_src.str = v->str;
indir_src.code = indir_glvn;
if (NULL == (obj = cache_get(&indir_src)))
{
if (valid_mname(&v->str))
{
targ_key.var_name = v->str;
COMPUTE_HASH_MNAME(&targ_key);
tabent = lookup_hashtab_mname(&curr_symval->h_symtab, &targ_key);
assert(NULL == tabent || NULL != tabent->value);
if (!tabent || !MV_DEFINED(&((lv_val *)tabent->value)->v))
{
if (undef_inhibit)
{
*dst = literal_null;
return;
}
else
rts_error(VARLSTCNT(4) ERR_UNDEF, 2, v->str.len, v->str.addr);
}
a = (lv_val *)tabent->value;
*dst = a->v;
return;
}
comp_init(&v->str);
rval = glvn(&x);
if (comp_fini(rval, &object, OC_IRETMVAL, &x, v->str.len))
{
indir_src.str.addr = v->str.addr;
cache_put(&indir_src, &object);
*ind_result_sp++ = dst;
if (ind_result_sp >= ind_result_top)
rts_error(VARLSTCNT(1) ERR_INDMAXNEST);
comp_indr(&object);
}
}
else
{
*ind_result_sp++ = dst;
if (ind_result_sp >= ind_result_top)
rts_error(VARLSTCNT(1) ERR_INDMAXNEST);
comp_indr(obj);
}
}
int op_fngvget2(mval *res, mval *val, mval *optional)
{
MV_FORCE_DEFINED(optional);
if (MV_DEFINED(val))
*res = *val;
else
*res = *optional;
assert(0 == (res->mvtype & MV_ALIASCONT)); /* Should be no alias container flag in this global */
return TRUE;
}
/* This code is similar in function to opp_fnget (assembler) except, if src is undefined, this returns an undefined value to signal
* op_fnget2, which, in turn, returns a specified "default" value; this slight of hand deals with order of evaluation issues.
*/
void op_fnget1(mval *src, mval *dst)
{
if (src && MV_DEFINED(src))
{
*dst = *src;
dst->mvtype &= ~MV_ALIASCONT; /* Make sure alias container property does not pass */
}
else
dst->mvtype = 0;
return;
}
void open_list_file(void)
{
char charspace;
uint4 status;
char *p, list_name[MAX_MIDENT_LEN + STR_LIT_LEN(LISTEXT)], fname[MAX_FBUFF + 1];
mval parms;
mval file;
mstr fstr;
parse_blk pblk;
time_t clock;
lst_param.list_line = 1;
lst_param.page = 0;
memset(&pblk, 0, sizeof(pblk));
assert(module_name.len <= MAX_MIDENT_LEN);
pblk.def1_size = module_name.len;
memcpy(&list_name[0], module_name.addr, pblk.def1_size);
MEMCPY_LIT(&list_name[pblk.def1_size], LISTEXT);
pblk.def1_size += STR_LIT_LEN(LISTEXT);
pblk.def1_buf = list_name;
pblk.buffer = &fname[0];
pblk.buff_size = MAX_FBUFF;
pblk.fop = F_SYNTAXO;
fstr.len = (MV_DEFINED(&cmd_qlf.list_file) ? cmd_qlf.list_file.str.len : 0);
fstr.addr = cmd_qlf.list_file.str.addr;
if (!(status = parse_file(&fstr, &pblk)) & 1)
rts_error(VARLSTCNT(1) status);
file.mvtype = parms.mvtype = MV_STR;
file.str.len = pblk.b_esl;
file.str.addr = &fname[0];
parms.str.len = sizeof(open_params_list);
parms.str.addr = (char *)&open_params_list;
(*op_open_ptr)(&file, &parms, 30, 0);
parms.str.len = 1;
charspace = (char)iop_eol;
parms.str.addr = &charspace;
dev_in_use = io_curr_device;
op_use(&file,&parms);
clock = time(0);
p = GTM_CTIME(&clock);
memcpy (print_time_buf, p + 4, sizeof(print_time_buf));
list_head(0);
return;
}
void op_gvincr(mval *increment, mval *result)
{
unsigned char buff[MAX_ZWR_KEY_SZ], *end;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
/* If specified var name is global ^%Y*, the name is illegal to use in a SET or KILL command, only GETs are allowed */
if ((RESERVED_NAMESPACE_LEN <= gv_currkey->end) && (0 == MEMCMP_LIT(gv_currkey->base, RESERVED_NAMESPACE)))
rts_error_csa(CSA_ARG(NULL) VARLSTCNT(1) ERR_PCTYRESERVED);
if (gv_cur_region->read_only)
rts_error_csa(CSA_ARG(NULL) VARLSTCNT(4) ERR_DBPRIVERR, 2, DB_LEN_STR(gv_cur_region));
if ((TREF(gv_last_subsc_null) || TREF(gv_some_subsc_null)) && (ALWAYS != gv_cur_region->null_subs))
sgnl_gvnulsubsc();
assert(gv_currkey->end + 1 <= gv_cur_region->max_key_size);
MV_FORCE_NUM(increment);
switch (gv_cur_region->dyn.addr->acc_meth)
{
case dba_bg:
case dba_mm:
gvcst_incr(increment, result);
break;
case dba_cm:
gvcmx_increment(increment, result);
break;
case dba_usr:
/* $INCR not supported for DDP/USR access method */
if (0 == (end = format_targ_key(buff, MAX_ZWR_KEY_SZ, gv_currkey, TRUE)))
end = &buff[MAX_ZWR_KEY_SZ - 1];
rts_error_csa(CSA_ARG(NULL) VARLSTCNT(10) ERR_UNIMPLOP, 0,
ERR_TEXT, 2, LEN_AND_LIT("GTCM DDP server does not support $INCREMENT"),
ERR_GVIS, 2, end - buff, buff,
ERR_TEXT, 2, REG_LEN_STR(gv_cur_region));
break;
default:
assertpro(FALSE);
}
assert(MV_DEFINED(result));
}
void op_zlink(mval *v, mval *quals)
{
struct FAB srcfab;
struct NAM srcnam, objnam;
struct XABDAT srcxab, objxab;
boolean_t compile, expdir, libr, obj_found, src_found;
short flen;
unsigned short type;
unsigned char srccom[MAX_FN_LEN], srcnamebuf[MAX_FN_LEN], objnamebuf[MAX_FN_LEN], objnamelen, srcnamelen,ver[6];
unsigned char objcom[MAX_FN_LEN], list_file[MAX_FN_LEN], ceprep_file[MAX_FN_LEN], *fname;
zro_ent *srcdir, *objdir;
mstr srcstr, objstr, version;
mval qualifier;
unsigned status, srcfnb;
uint4 lcnt, librindx, qlf;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
MV_FORCE_STR(v);
if (MAX_FN_LEN < v->str.len)
rts_error(VARLSTCNT(5) ERR_ZLINKFILE, 2, MIN(UCHAR_MAX, v->str.len), v->str.addr, ERR_FILENAMETOOLONG);
version.len = 0;
srcdir = objdir = 0;
version.addr = ver;
libr = FALSE;
obj_fab = cc$rms_fab;
if (quals)
{
MV_FORCE_STR(quals);
srcfab = cc$rms_fab;
srcfab.fab$l_fna = v->str.addr;
srcfab.fab$b_fns = v->str.len;
srcfab.fab$l_nam = &srcnam;
srcnam = cc$rms_nam;
srcnam.nam$l_esa = srcnamebuf;
srcnam.nam$b_ess = SIZEOF(srcnamebuf);
srcnam.nam$b_nop = NAM$M_SYNCHK;
status = sys$parse(&srcfab);
if (!(status & 1))
rts_error(VARLSTCNT(9) ERR_ZLINKFILE, 2, v->str.len, v->str.addr,
ERR_FILEPARSE, 2, v->str.len, v->str.addr, status);
if (srcnam.nam$l_fnb & NAM$M_WILDCARD)
rts_error(VARLSTCNT(8) ERR_ZLINKFILE, 2, v->str.len, v->str.addr,
ERR_WILDCARD, 2, v->str.len, v->str.addr);
srcfnb = srcnam.nam$l_fnb;
expdir = (srcfnb & (NAM$M_NODE | NAM$M_EXP_DEV | NAM$M_EXP_DIR));
if (srcfnb & NAM$M_EXP_VER)
{
memcpy(version.addr, srcnam.nam$l_ver, srcnam.nam$b_ver);
version.len = srcnam.nam$b_ver;
}
if (expdir)
{
if (version.len)
flen = srcnam.nam$b_esl - srcnam.nam$b_type - version.len;
else
flen = srcnam.nam$b_esl - srcnam.nam$b_type - 1; /* semicolon is put in by default */
fname = srcnam.nam$l_esa;
} else
{
flen = srcnam.nam$b_name;
fname = srcnam.nam$l_name;
}
ENSURE_STP_FREE_SPACE(flen);
memcpy(stringpool.free, fname, flen);
dollar_zsource.str.addr = stringpool.free;
dollar_zsource.str.len = flen;
stringpool.free += flen;
if (srcfnb & NAM$M_EXP_TYPE)
{
if ((SIZEOF(DOTOBJ) - 1 == srcnam.nam$b_type) &&
!MEMCMP_LIT(srcnam.nam$l_type, DOTOBJ))
{
type = OBJ;
objstr.addr = srcnam.nam$l_esa;
objstr.len = srcnam.nam$b_esl;
} else
{
type = SRC;
memcpy(srcnamebuf, dollar_zsource.str.addr, flen);
memcpy(&srcnamebuf[flen], srcnam.nam$l_type, srcnam.nam$b_type);
memcpy(&srcnamebuf[flen + srcnam.nam$b_type],
version.addr, version.len);
srcnamelen = flen + srcnam.nam$b_type + version.len;
srcnamebuf[srcnamelen] = 0;
srcstr.addr = srcnamebuf;
srcstr.len = srcnamelen;
memcpy(objnamebuf, dollar_zsource.str.addr, flen);
memcpy(&objnamebuf[flen], DOTOBJ, SIZEOF(DOTOBJ));
objnamelen = flen + SIZEOF(DOTOBJ) - 1;
objstr.addr = objnamebuf;
objstr.len = objnamelen;
}
} else
{
type = NOTYPE;
memcpy(srcnamebuf, dollar_zsource.str.addr, flen);
memcpy(&srcnamebuf[flen], DOTM, SIZEOF(DOTM));
srcnamelen = flen + SIZEOF(DOTM) - 1;
memcpy(objnamebuf, dollar_zsource.str.addr, flen);
MEMCPY_LIT(&objnamebuf[flen], DOTOBJ);
memcpy(&objnamebuf[flen + SIZEOF(DOTOBJ) - 1], version.addr, version.len);
objnamelen = flen + SIZEOF(DOTOBJ) + version.len - 1;
objnamebuf[objnamelen] = 0;
srcstr.addr = srcnamebuf;
srcstr.len = srcnamelen;
objstr.addr = objnamebuf;
objstr.len = objnamelen;
}
if (!expdir)
{
if (OBJ == type)
{
zro_search(&objstr, &objdir, 0, 0);
if (!objdir)
rts_error(VARLSTCNT(8) ERR_ZLINKFILE, 2, dollar_zsource.str.len, dollar_zsource.str.addr,
ERR_FILENOTFND, 2, dollar_zsource.str.len, dollar_zsource.str.addr);
} else if (SRC == type)
{
zro_search(&objstr, &objdir, &srcstr, &srcdir);
if (!srcdir)
rts_error(VARLSTCNT(8) ERR_ZLINKFILE, 2, srcnamelen, srcnamebuf,
ERR_FILENOTFND, 2, srcnamelen, srcnamebuf);
} else
{
zro_search(&objstr, &objdir, &srcstr, &srcdir);
if (!objdir && !srcdir)
rts_error(VARLSTCNT(8) ERR_ZLINKFILE, 2, dollar_zsource.str.len, dollar_zsource.str.addr,
ERR_FILENOTFND, 2, dollar_zsource.str.len, dollar_zsource.str.addr);
}
}
} else
{
expdir = FALSE;
type = NOTYPE;
flen = v->str.len;
memcpy(srcnamebuf, v->str.addr, flen);
MEMCPY_LIT(&srcnamebuf[flen], DOTM);
srcnamelen = flen + SIZEOF(DOTM) - 1;
if ('%' == srcnamebuf[0])
srcnamebuf[0] = '_';
memcpy(objnamebuf, srcnamebuf, flen);
MEMCPY_LIT(&objnamebuf[flen], DOTOBJ);
objnamelen = flen + SIZEOF(DOTOBJ) - 1;
srcstr.addr = srcnamebuf;
srcstr.len = srcnamelen;
objstr.addr = objnamebuf;
objstr.len = objnamelen;
zro_search(&objstr, &objdir, &srcstr, &srcdir);
if (!objdir && !srcdir)
rts_error(VARLSTCNT(8) ERR_ZLINKFILE, 2, v->str.len, v->str.addr,
ERR_FILENOTFND, 2, v->str.len, v->str.addr);
qualifier.mvtype = MV_STR;
qualifier.str = TREF(dollar_zcompile);
quals = &qualifier;
}
if (OBJ == type)
{
obj_fab.fab$b_fac = FAB$M_GET;
obj_fab.fab$b_shr = FAB$M_SHRGET;
if (NULL != objdir)
{
if (ZRO_TYPE_OBJLIB == objdir->type)
libr = TRUE;
else
{
srcfab.fab$l_dna = objdir->str.addr;
srcfab.fab$b_dns = objdir->str.len;
}
}
for (lcnt = 0; lcnt < MAX_FILE_OPEN_TRIES; lcnt++)
{
status = (FALSE == libr) ? sys$open(&srcfab): zl_olb(&objdir->str, &objstr, &librindx);
if (RMS$_FLK != status)
break;
hiber_start(WAIT_FOR_FILE_TIME);
}
if (FALSE == (status & 1))
rts_error(VARLSTCNT(5) ERR_ZLINKFILE, 2, dollar_zsource.str.len, dollar_zsource.str.addr, status);
if (FALSE == ((FALSE == libr) ? incr_link(&srcfab, libr) : incr_link(&librindx, libr)))
rts_error(VARLSTCNT(5) ERR_ZLINKFILE, 2, dollar_zsource.str.len, dollar_zsource.str.addr, ERR_VERSION);
status = (FALSE == libr) ? sys$close(&srcfab) : lbr$close(&librindx);
if (FALSE == (status & 1))
rts_error(VARLSTCNT(5) ERR_ZLINKFILE, 2, dollar_zsource.str.len, dollar_zsource.str.addr, status);
} else /* either NO type or SOURCE type */
{
src_found = obj_found = compile = FALSE;
srcfab = obj_fab = cc$rms_fab;
obj_fab.fab$l_xab = &objxab;
srcxab = objxab = cc$rms_xabdat;
obj_fab.fab$l_nam = &objnam;
srcnam = objnam = cc$rms_nam;
obj_fab.fab$l_fna = objnamebuf;
obj_fab.fab$b_fns = objnamelen;
obj_fab.fab$b_fac = FAB$M_GET;
obj_fab.fab$b_shr = FAB$M_SHRGET;
objnam.nam$l_esa = objcom;
objnam.nam$b_ess = SIZEOF(objcom);
srcfab.fab$l_nam = &srcnam;
srcfab.fab$l_xab = &srcxab;
srcfab.fab$l_fna = srcnamebuf;
srcfab.fab$b_fns = srcnamelen;
srcfab.fab$b_fac = FAB$M_GET;
srcfab.fab$b_shr = FAB$M_SHRGET;
srcnam.nam$l_esa = srccom;
srcnam.nam$b_ess = SIZEOF(srccom);
cmd_qlf.object_file.str.addr = objcom;
cmd_qlf.object_file.str.len = 255;
cmd_qlf.list_file.str.addr = list_file;
cmd_qlf.list_file.str.len = 255;
cmd_qlf.ceprep_file.str.addr = ceprep_file;
cmd_qlf.ceprep_file.str.len = 255;
if (srcdir && srcdir->str.len)
{
srcfab.fab$l_dna = srcdir->str.addr;
srcfab.fab$b_dns = srcdir->str.len;
}
if (objdir && objdir->str.len)
{
if (ZRO_TYPE_OBJLIB == objdir->type)
libr = TRUE;
else
{
obj_fab.fab$l_dna = objdir->str.addr;
obj_fab.fab$b_dns = objdir->str.len;
}
}
if (SRC != type)
{
if (!expdir && !objdir)
obj_found = FALSE;
else if (!libr)
{
for (lcnt = 0; lcnt < MAX_FILE_OPEN_TRIES; lcnt++)
{
status = sys$open(&obj_fab);
if (RMS$_FLK != status)
break;
hiber_start(WAIT_FOR_FILE_TIME);
}
if (!(status & 1))
{
if (RMS$_FNF == status)
obj_found = FALSE;
else
rts_error(VARLSTCNT(5) ERR_ZLINKFILE, 2, objnamelen, objnamebuf, status);
} else
obj_found = TRUE;
} else
{
status = zl_olb(&objdir->str, &objstr, &librindx);
if (status)
obj_found = TRUE;
}
} else
compile = TRUE;
if (!expdir && !srcdir)
src_found = FALSE;
else
{
for (lcnt = 0; lcnt < MAX_FILE_OPEN_TRIES; lcnt++)
{
status = sys$open(&srcfab);
if (RMS$_FLK != status)
break;
hiber_start(WAIT_FOR_FILE_TIME);
}
if (!(status & 1))
{
if ((RMS$_FNF == status) && (SRC != type))
src_found = FALSE;
else
rts_error(VARLSTCNT(5) ERR_ZLINKFILE, 2, srcnamelen, srcnamebuf, status);
} else
{
src_found = TRUE;
if (SRC == type)
{
status = sys$close(&srcfab);
if (!(status & 1))
rts_error(VARLSTCNT(5) ERR_ZLINKFILE, 2, srcnamelen, srcnamebuf, status);
}
}
}
if (SRC != type)
{
if (src_found)
{
if (obj_found)
{
if (QUADCMP(&srcxab.xab$q_rdt, &objxab.xab$q_rdt))
{
status = sys$close(&obj_fab);
obj_fab = cc$rms_fab;
if (!(status & 1))
rts_error(VARLSTCNT(5) ERR_ZLINKFILE, 2, objnamelen, objnamebuf, status);
compile = TRUE;
}
} else
compile = TRUE;
status = sys$close(&srcfab);
if (!(status & 1))
rts_error(VARLSTCNT(5) ERR_ZLINKFILE, 2, srcnamelen, srcnamebuf, status);
} else if (!obj_found)
rts_error(VARLSTCNT(8) ERR_ZLINKFILE, 2, objnamelen, objnamebuf,
ERR_FILENOTFND, 2, objnamelen, objnamebuf);
}
if (compile)
{
zl_cmd_qlf(&quals->str, &cmd_qlf);
if (!MV_DEFINED(&cmd_qlf.object_file))
{
objnam.nam$b_nop = NAM$M_SYNCHK;
status = sys$parse(&obj_fab);
if (!(status & 1))
rts_error(VARLSTCNT(4) ERR_FILEPARSE, 2, obj_fab.fab$b_fns, obj_fab.fab$l_fna);
cmd_qlf.object_file.mvtype = MV_STR;
cmd_qlf.object_file.str.len = objnam.nam$b_esl - objnam.nam$b_ver;
}
qlf = cmd_qlf.qlf;
if (!(cmd_qlf.qlf & CQ_OBJECT) && (SRC != type))
{
cmd_qlf.qlf = glb_cmd_qlf.qlf;
rts_error(VARLSTCNT(5) ERR_ZLINKFILE, 2, srcnamelen, srcnamebuf, ERR_ZLNOOBJECT);
}
zlcompile(srcnam.nam$b_esl, srcnam.nam$l_esa);
if ((SRC == type) && !(qlf & CQ_OBJECT))
return;
}
status = libr ? incr_link(&librindx, libr) : incr_link(&obj_fab, libr);
if (!status) /* due only to version mismatch, so recompile */
{
if (!libr)
{
status = sys$close(&obj_fab);
obj_fab = cc$rms_fab;
} else
status = lbr$close(&librindx);
if (!(status & 1))
rts_error(VARLSTCNT(5) ERR_ZLINKFILE, 2, objstr.len, objstr.addr, status);
if (compile)
GTMASSERT;
if (!src_found)
rts_error(VARLSTCNT(5) ERR_ZLINKFILE, 2, srcnamelen, srcnamebuf, ERR_VERSION);
zl_cmd_qlf(&quals->str, &cmd_qlf);
if (!MV_DEFINED(&cmd_qlf.object_file))
{
objnam.nam$b_nop = NAM$M_SYNCHK;
status = sys$parse(&obj_fab);
if (!(status & 1))
rts_error(VARLSTCNT(4) ERR_FILEPARSE, 2, obj_fab.fab$b_fns, obj_fab.fab$l_fna);
cmd_qlf.object_file.mvtype = MV_STR;
cmd_qlf.object_file.str.len = objnam.nam$b_esl - objnam.nam$b_ver;
}
if (!(cmd_qlf.qlf & CQ_OBJECT) && (SRC != type))
{
cmd_qlf.qlf = glb_cmd_qlf.qlf;
rts_error(VARLSTCNT(5) ERR_ZLINKFILE, 2, srcnamelen, srcnamebuf, ERR_ZLNOOBJECT);
}
zlcompile(srcnam.nam$b_esl, srcnam.nam$l_esa);
if (!incr_link(&obj_fab, libr))
GTMASSERT;
}
if (!libr)
{
status = sys$close(&obj_fab);
obj_fab = cc$rms_fab;
} else
status = lbr$close(&librindx);
if (!(status & 1))
rts_error(VARLSTCNT(5) ERR_ZLINKFILE, 2, objstr.len, objstr.addr, status);
}
return;
}
/*
* ----------------------------------------------------------
* Set $zpiece procedure.
* Set pieces first through last to expr.
*
* Arguments:
* src - source mval
* del - delimiter string mval
* expr - expression string mval
* first - starting index in source mval to be set
* last - last index
* dst - destination mval where the result is saved.
*
* Return:
* none
* ----------------------------------------------------------
*/
void op_setzpiece(mval *src, mval *del, mval *expr, int4 first, int4 last, mval *dst)
{
size_t str_len, delim_cnt;
int match_res, len, src_len, first_src_ind, second_src_ind, numpcs;
unsigned char *match_ptr, *src_str, *str_addr, *tmp_str;
delimfmt unichar;
if (0 > --first)
first = 0;
assert(last >= first);
second_src_ind = last - first;
MV_FORCE_STR(del);
/* Null delimiter */
if (0 == del->str.len)
{
if (first && src->mvtype)
{
/* concat src & expr to dst */
op_cat(VARLSTCNT(3) dst, src, expr);
return;
}
MV_FORCE_STR(expr);
*dst = *expr;
return;
}
MV_FORCE_STR(expr);
if (!MV_DEFINED(src))
{
first_src_ind = 0;
second_src_ind = -1;
} else
{
/* Valid delimiter - See if we can take a short cut to op_fnzp1. If so, delimiter value needs to be reformated */
if ((1 == second_src_ind) && (1 == del->str.len))
{ /* Count of pieces to retrieve is 1 so see what we can do quickly */
unichar.unichar_val = 0;
unichar.unibytes_val[0] = *del->str.addr;
op_setzp1(src, unichar.unichar_val, expr, last, dst); /* Use "last" since it has not been modified */
return;
}
/* We have a valid src with something in it */
MV_FORCE_STR(src);
src_str = (unsigned char *)src->str.addr;
src_len = src->str.len;
/* skip all pieces until start one */
if (first)
{
numpcs = first; /* copy int4 type "first" into "int" type numpcs for passing to matchc */
match_ptr = matchb(del->str.len, (uchar_ptr_t)del->str.addr, src_len, src_str, &match_res, &numpcs);
/* Note: "numpcs" is modified above by the function "matchb" to reflect the # of unmatched pieces */
first = numpcs; /* copy updated "numpcs" value back into "first" */
} else
{
match_ptr = src_str;
match_res = 1;
}
first_src_ind = INTCAST(match_ptr - (unsigned char *)src->str.addr);
if (0 == match_res) /* if match not found */
second_src_ind = -1;
else
{
src_len -= INTCAST(match_ptr - src_str);
src_str = match_ptr;
/* skip # delimiters this piece will replace, e.g. if we are setting
* pieces 2 - 4, then the pieces 2-4 will be replaced by one piece - expr.
*/
match_ptr = matchb(del->str.len, (uchar_ptr_t)del->str.addr, src_len, src_str, &match_res, &second_src_ind);
second_src_ind = (0 == match_res) ? -1 : INTCAST(match_ptr - (unsigned char *)src->str.addr - del->str.len);
}
}
delim_cnt = (size_t)first;
/* Calculate total string len. */
str_len = (size_t)expr->str.len + ((size_t)first_src_ind + ((size_t)del->str.len * delim_cnt));
/* add len. of trailing chars past insertion point */
if (0 <= second_src_ind)
str_len += (size_t)(src->str.len - second_src_ind);
if (MAX_STRLEN < str_len)
{
rts_error_csa(CSA_ARG(NULL) VARLSTCNT(1) ERR_MAXSTRLEN);
return;
}
ENSURE_STP_FREE_SPACE((int)str_len);
str_addr = stringpool.free;
/* copy prefix */
if (first_src_ind)
{
memcpy(str_addr, src->str.addr, first_src_ind);
str_addr += first_src_ind;
}
/* copy delimiters */
while (0 < delim_cnt--)
{
memcpy(str_addr, del->str.addr, del->str.len);
str_addr += del->str.len;
}
/* copy expression */
memcpy(str_addr, expr->str.addr, expr->str.len);
str_addr += expr->str.len;
/* copy trailing pieces */
if (0 <= second_src_ind)
{
len = src->str.len - second_src_ind;
tmp_str = (unsigned char *)src->str.addr + second_src_ind;
memcpy(str_addr, tmp_str, len);
str_addr += len;
}
assert(IS_AT_END_OF_STRINGPOOL(str_addr, -str_len));
dst->mvtype = MV_STR;
dst->str.len = INTCAST(str_addr - stringpool.free);
dst->str.addr = (char *)stringpool.free;
stringpool.free = str_addr;
return;
}
void open_ceprep_file(void)
{
#ifdef VMS
/* stub except for VMS */
#ifdef __ALPHA
# pragma member_alignment save
# pragma nomember_alignment
#endif
static readonly struct
{
unsigned char newversion;
unsigned char wrap;
unsigned char width;
int4 v_width;
unsigned char eol;
} open_params_list =
{
(unsigned char) iop_newversion,
(unsigned char) iop_wrap,
(unsigned char) iop_recordsize,
(int4) MAX_SRCLINE,
(unsigned char) iop_eol
};
#ifdef __ALPHA
# pragma member_alignment restore
#endif
int mname_len;
uint4 status;
char charspace, ceprep_name_buff[sizeof(mident) + sizeof(".MCI") - 1], fname[255];
mval file, params;
struct NAM ceprep_nam; /* name block for file access block for compiler escape preprocessor output */
/* Create cepreprocessor output file. */
ceprep_fab = cc$rms_fab;
ceprep_fab.fab$l_dna = ceprep_name_buff;
mname_len = mid_len(module_name);
assert(mname_len <= sizeof(mident));
if (0 == mname_len)
{
memcpy(ceprep_name_buff, "MDEFAULT.MCI", sizeof("MDEFAULT.MCI") - 1);
ceprep_fab.fab$b_dns = sizeof("MDEFAULT.MCI") - 1;
} else
{
memcpy(ceprep_name_buff, module_name, mname_len);
memcpy(&ceprep_name_buff[mname_len], ".MCI", sizeof(".MCI") - 1);
ceprep_fab.fab$b_dns = mname_len + sizeof(".MCI") - 1;
}
if (MV_DEFINED(&cmd_qlf.ceprep_file))
{
ceprep_fab.fab$b_fns = cmd_qlf.ceprep_file.str.len;
ceprep_fab.fab$l_fna = cmd_qlf.ceprep_file.str.addr;
}
ceprep_nam = cc$rms_nam;
ceprep_nam.nam$l_esa = fname;
ceprep_nam.nam$b_ess = sizeof(fname);
ceprep_nam.nam$b_nop = (NAM$M_SYNCHK);
ceprep_fab.fab$l_nam = &ceprep_nam;
ceprep_fab.fab$l_fop = FAB$M_NAM;
if (RMS$_NORMAL != (status = sys$parse(&ceprep_fab, 0, 0)))
rts_error(VARLSTCNT(1) status);
file.mvtype = params.mvtype = MV_STR;
file.str.len = ceprep_nam.nam$b_esl;
file.str.addr = fname;
params.str.len = sizeof(open_params_list);
params.str.addr = &open_params_list;
op_open(&file, ¶ms, CEPREP_OPEN_TIMEOUT, 0);
params.str.len = 1;
charspace = (char)iop_eol;
params.str.addr = &charspace;
dev_in_use = io_curr_device;
op_use(&file, ¶ms);
#endif
return;
}
/*
* ----------------------------------------------------------
* Fast path setpiece when delimiter is one (lit) char replacing
* a single piece (last is same as first).
*
* Arguments:
* src - source mval
* delim - delimiter char
* expr - expression string mval
* ind - index in source mval to be set
* dst - destination mval where the result is saved.
*
* Return:
* none
* ----------------------------------------------------------
*/
void op_setp1(mval *src, int delim, mval *expr, int ind, mval *dst)
{
int len, pfx_str_len, sfx_start_offset, sfx_str_len, rep_str_len, str_len, delim_cnt, pfx_scan_offset;
int cpy_cache_lines;
unsigned char ldelim, lc, *start_sfx, *str_addr, *end_pfx, *end_src, *start_pfx;
boolean_t do_scan;
mval dummymval; /* It's value is not used but is part of the call to op_fnp1() */
fnpc *cfnpc, *pfnpc;
error_def(ERR_MAXSTRLEN);
ldelim = delim; /* Local copy (in unsigned char format) */
do_scan = FALSE;
cpy_cache_lines = -1;
MV_FORCE_STR(expr); /* Expression to put into piece place */
if (MV_DEFINED(src))
{
/* We have 3 possible scenarios:
1) If length of src is too small to cause cacheing by op_fnp1, then just do
the work ourselves with no cacheing.
2) If the requested piece is larger than can be cached by op_fnp1, call fnp1
for the maximum piece possible, use the cache info to "prime the pump" and
then process the rest of the string ourselves.
3) If the requested piece can be obtained from the cache, call op_fnp1 to validate
and rebuild the cache if necessary and then retrieve the necessary info from
the fnpc cache.
*/
MV_FORCE_STR(src); /* Make sure is string prior to length check */
if (FNPC_STRLEN_MIN < src->str.len && FNPC_ELEM_MAX >= ind)
{ /* 3) Best of all possible cases. The op_fnp1 can do most of our work for us
and we can preload the cache on the new string to help its subsequent
uses along as well.
*/
SETWON;
op_fnp1(src, delim, ind, &dummymval, FALSE);
SETWOFF;
cfnpc = &fnpca.fnpcs[src->fnpc_indx - 1];
assert(cfnpc->last_str.addr == src->str.addr);
assert(cfnpc->last_str.len == src->str.len);
assert(cfnpc->delim == delim);
assert(0 < cfnpc->npcs);
/* Three more scenarios: #1 piece all in cache, #2 piece would be in cache but ran
out of text or #3 piece is beyond what can be cached
*/
if (cfnpc->npcs >= ind)
{ /* #1 The piece we want is totally within the cache which is good news */
pfx_str_len = cfnpc->pstart[ind - 1];
delim_cnt = 0;
sfx_start_offset = cfnpc->pstart[ind] - 1; /* Include delimiter */
rep_str_len = cfnpc->pstart[ind] - cfnpc->pstart[ind - 1] - 1; /* Replace string length */
sfx_str_len = src->str.len - pfx_str_len - rep_str_len;
cpy_cache_lines = ind - 1;
} else
{ /* #2 The string was too short so the cache does not contain our string. This means
that the prefix becomes any text that IS in the cache and we set the delim_cnt
to be the number of missing pieces so the delimiters can be put in as part of the
prefix when we build the new string.
*/
pfx_str_len = cfnpc->pstart[cfnpc->npcs] - 1;
delim_cnt = ind - cfnpc->npcs;
sfx_start_offset = 0;
sfx_str_len = 0;
cpy_cache_lines = cfnpc->npcs;
}
} else if (FNPC_STRLEN_MIN < src->str.len)
{ /* 2) We have a element that would not be able to be in the fnpc cache. Go ahead
and call op_fnp1 to get cache info up to the maximum and then we will continue
the scan on our own.
*/
SETWON;
op_fnp1(src, delim, FNPC_ELEM_MAX, &dummymval, FALSE);
SETWOFF;
cfnpc = &fnpca.fnpcs[src->fnpc_indx - 1];
assert(cfnpc->last_str.addr == src->str.addr);
assert(cfnpc->last_str.len == src->str.len);
assert(cfnpc->delim == delim);
assert(0 < cfnpc->npcs);
if (FNPC_ELEM_MAX > cfnpc->npcs)
{ /* We ran out of text so the scan is complete. This is basically the same
as case #2 above.
*/
pfx_str_len = cfnpc->pstart[cfnpc->npcs] - 1;
delim_cnt = ind - cfnpc->npcs;
sfx_start_offset = 0;
sfx_str_len = 0;
cpy_cache_lines = cfnpc->npcs;
} else
{ /* We have a case where the piece we want cannot be kept in cache. In the special
case where there is no more text to handle, we don't need to scan further. Otherwise
we prime the pump and continue the scan where the cache left off.
*/
if ((pfx_scan_offset = cfnpc->pstart[FNPC_ELEM_MAX]) < src->str.len)
{ /* Normal case where we prime the pump */
do_scan = TRUE;
} else
{ /* Special case -- no more text to scan */
pfx_str_len = cfnpc->pstart[FNPC_ELEM_MAX] - 1;
sfx_start_offset = 0;
sfx_str_len = 0;
}
delim_cnt = ind - FNPC_ELEM_MAX;
cpy_cache_lines = FNPC_ELEM_MAX;
}
} else
{ /* 1) We have a short string where no cacheing happens. Do the scanning work ourselves */
MV_FORCE_STR(src);
do_scan = TRUE;
pfx_scan_offset = 0;
delim_cnt = ind;
}
} else
{ /* Source is not defined -- treat as a null string */
pfx_str_len = sfx_str_len = sfx_start_offset = 0;
delim_cnt = ind - 1;
}
/* If we have been forced to do our own scan, do that here. Note the variable pfx_scan_offset has been
set to where the scan should begin in the src string and delim_cnt has been set to how many delimiters
still need to be processed.
*/
if (do_scan)
{ /* Scan the line isolating prefix piece, and end of the
piece being replaced
*/
COUNT_EVENT(cs_small);
end_pfx = start_sfx = (unsigned char *)src->str.addr + pfx_scan_offset;
end_src = (unsigned char *)src->str.addr + src->str.len;
/* The compiler would unroll this loop this way anyway but we want to
adjust the start_sfx pointer after the loop but only if we have gone
into it at least once.
*/
if (0 < delim_cnt && start_sfx < end_src)
{
do
{
end_pfx = start_sfx;
while (start_sfx < end_src && (lc = *start_sfx) != ldelim) start_sfx++;
start_sfx++;
delim_cnt--;
} while (0 < delim_cnt && start_sfx < end_src);
/* We have to backup up the suffix start pointer except under the condition
that the last character in the buffer is the last delimiter we were looking
for.
*/
if (0 == delim_cnt || start_sfx < end_src || lc != ldelim)
--start_sfx; /* Back up suffix to include delimiter char */
/* If we scanned to the end (no text left) and still have delimiters to
find, the entire src text should be part of the prefix */
if (start_sfx >= end_src && 0 < delim_cnt)
{
end_pfx = start_sfx;
if (lc == ldelim) /* if last char was delim, reduce delim cnt */
--delim_cnt;
}
} else
{
/* If not doing any token finding, then this count becomes the number
of tokens to output. Adjust accordingly.
*/
if (0 > --delim_cnt)
delim_cnt = 0;
}
INCR_COUNT(cs_small_pcs, ind - delim_cnt);
/* Now having the following situation:
end_pfx -> end of the prefix piece including delimiter
start_sfx -> start of suffix piece (with delimiter) or = end_pfx/src->str.addr if none
*/
pfx_str_len = end_pfx - (unsigned char *)src->str.addr;
if (0 > pfx_str_len)
pfx_str_len = 0;
sfx_start_offset = start_sfx - (unsigned char *)src->str.addr;
sfx_str_len = src->str.len - sfx_start_offset;
if (0 > sfx_str_len)
sfx_str_len = 0;
}
/* Calculate total string len. delim_cnt has needed padding delimiters for null fields */
str_len = expr->str.len + pfx_str_len + delim_cnt + sfx_str_len;
if (str_len > MAX_STRLEN)
rts_error(VARLSTCNT(1) ERR_MAXSTRLEN);
if (str_len > (stringpool.top - stringpool.free))
stp_gcol(str_len);
str_addr = stringpool.free;
start_pfx = (unsigned char *)src->str.addr;
/* copy prefix */
if (0 < pfx_str_len)
{
memcpy(str_addr, src->str.addr, pfx_str_len);
str_addr += pfx_str_len;
}
/* copy delimiters */
while (delim_cnt-- > 0)
*str_addr++ = ldelim;
/* copy expression */
if (0 < expr->str.len)
{
memcpy(str_addr, expr->str.addr, expr->str.len);
str_addr += expr->str.len;
}
/* copy suffix */
if (0 < sfx_str_len)
{
memcpy(str_addr, start_pfx + sfx_start_offset, sfx_str_len);
str_addr += sfx_str_len;
}
assert(str_addr - stringpool.free == str_len);
dst->mvtype = MV_STR;
dst->str.len = str_addr - stringpool.free;
dst->str.addr = (char *)stringpool.free;
stringpool.free = str_addr;
/* If available, update the cache information for this newly created mval to hopefully
give it a head start on its next usage. Note that we can only copy over the cache info
for the prefix. We cannot include information for the 'expression' except where it starts
because the expression could itself contain delimiters that would be found on a rescan.
*/
if (0 < cpy_cache_lines)
{
pfnpc = cfnpc; /* pointer for src mval's cache */
do
{
cfnpc = fnpca.fnpcsteal; /* Next cache element to steal */
if (fnpca.fnpcmax < cfnpc)
cfnpc = &fnpca.fnpcs[0];
fnpca.fnpcsteal = cfnpc + 1; /* -> next element to steal */
} while (cfnpc == pfnpc); /* Make sure we don't step on ourselves */
cfnpc->last_str = dst->str; /* Save validation info */
cfnpc->delim = delim;
cfnpc->npcs = cpy_cache_lines;
dst->fnpc_indx = cfnpc->indx + 1; /* Save where we are putting this element
(1 based index in mval so 0 isn't so common) */
memcpy(&cfnpc->pstart[0], &pfnpc->pstart[0], (cfnpc->npcs + 1) * sizeof(unsigned int));
} else
{ /* No cache available -- just reset index pointer to get fastest cache validation failure */
dst->fnpc_indx = -1;
}
}
void op_fnfnumber(mval *src, mval *fmt, boolean_t use_fract, int fract, mval *dst)
{
boolean_t comma, paren;
int ct, x, xx, y, z;
unsigned char *ch, *cp, *ff, *ff_top, fncode, sign, *t;
if (!MV_DEFINED(fmt)) /* catch this up front so noundef mode can't cause trouble - so fmt no empty context */
rts_error_csa(CSA_ARG(NULL) VARLSTCNT(2) ERR_FNUMARG, 0);
/* if the dst will be different than the src we'll build the new value in the string pool and repoint dst there,
* otherwise, dst will anyway become the same as src, therefore we can safely use dst as a "temporary" copy of src
*/
*dst = *src;
if (use_fract)
op_fnj3(dst, 0, fract, dst);
else
{
MV_FORCE_NUM(dst);
MV_FORCE_CANONICAL(dst); /* if the source operand is not a canonical number, force conversion */
}
assert (stringpool.free >= stringpool.base);
assert (stringpool.free <= stringpool.top);
/* assure there is adequate space for two string forms of a number as a local
* version of the src must be operated upon in order to get a canonical number
*/
MV_FORCE_STR(fmt);
MV_FORCE_STR(dst);
if (0 == fmt->str.len)
return;
ENSURE_STP_FREE_SPACE(MAX_NUM_SIZE * 2);
ch = (unsigned char *)dst->str.addr;
ct = dst->str.len;
cp = stringpool.free;
fncode = 0;
for (ff = (unsigned char *)fmt->str.addr, ff_top = ff + fmt->str.len; ff < ff_top;)
{
switch(*ff++)
{
case '+':
fncode |= PLUS;
break;
case '-':
fncode |= MINUS;
break;
case ',':
fncode |= COMMA;
break;
case 'T':
case 't':
fncode |= TRAIL;
break;
case 'P':
case 'p':
fncode |= PAREN;
break;
default:
rts_error_csa(CSA_ARG(NULL) VARLSTCNT(6) ERR_FNUMARG, 4, fmt->str.len, fmt->str.addr, 1, --ff);
break;
}
}
if ((0 != (fncode & PAREN)) && (0 != (fncode & FNERROR)))
rts_error_csa(CSA_ARG(NULL) VARLSTCNT(4) ERR_FNARGINC, 2, fmt->str.len, fmt->str.addr);
else
{
sign = 0;
paren = FALSE;
if ('-' == *ch)
{
sign = '-';
ch++;
ct--;
}
if (0 != (fncode & PAREN))
{
if ('-' == sign)
{
*cp++ = '(';
sign = 0;
paren = TRUE;
}
else *cp++ = ' ';
}
/* Only add '+' if > 0 */
if ((0 != (fncode & PLUS)) && (0 == sign))
{ /* Need to make into num and check for int 0 in case was preprocessed by op_fnj3() */
MV_FORCE_NUM(dst);
if ((0 == (dst->mvtype & MV_INT)) || (0 != dst->m[1]))
sign = '+';
}
if ((0 != (fncode & MINUS)) && ('-' == sign))
sign = 0;
if ((0 == (fncode & TRAIL)) && (0 != sign))
*cp++ = sign;
if (0 != (fncode & COMMA))
{
comma = FALSE;
for (x = 0, t = ch; (('.' != *t) && (++x < ct)); t++)
;
z = x;
if ((y = x % 3) > 0)
{
while (y-- > 0)
*cp++ = *ch++;
comma = TRUE;
}
for ( ; (0 != (x / 3)); x -= 3, cp += 3, ch +=3)
{
if (comma)
*cp++ = ',';
else
comma = TRUE;
memcpy(cp, ch, 3);
}
if (z < ct)
{
xx = ct - z;
memcpy(cp, ch, xx);
cp += xx;
}
} else
{
memcpy(cp, ch, ct);
cp += ct;
}
if (0 != (fncode & TRAIL))
{
if (sign != 0) *cp++ = sign;
else *cp++ = ' ';
}
if (0 != (fncode & PAREN))
{
if (paren)*cp++ = ')';
else *cp++ = ' ';
}
dst->mvtype = MV_STR;
dst->str.addr = (char *)stringpool.free;
dst->str.len = INTCAST(cp - stringpool.free);
stringpool.free = cp;
return;
}
assertpro(FALSE);
}
int gtm_trigger(gv_trigger_t *trigdsc, gtm_trigger_parms *trigprm)
{
mval *lvvalue;
lnr_tabent *lbl_offset_p;
uchar_ptr_t transfer_addr;
lv_val *lvval;
mname_entry *mne_p;
uint4 *indx_p;
ht_ent_mname *tabent;
boolean_t added;
int clrlen, rc, i, unwinds;
mval **lvvalarray;
mv_stent *mv_st_ent;
symval *new_symval;
uint4 dollar_tlevel_start;
stack_frame *fp, *fpprev;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
assert(!skip_dbtriggers); /* should not come here if triggers are not supposed to be invoked */
assert(trigdsc);
assert(trigprm);
assert((NULL != trigdsc->rtn_desc.rt_adr) || ((MV_STR & trigdsc->xecute_str.mvtype)
&& (0 != trigdsc->xecute_str.str.len)
&& (NULL != trigdsc->xecute_str.str.addr)));
assert(dollar_tlevel);
/* Determine if trigger needs to be compiled */
if (NULL == trigdsc->rtn_desc.rt_adr)
{ /* No routine hdr addr exists. Need to do compile */
if (0 != gtm_trigger_complink(trigdsc, TRUE))
{
PRN_ERROR; /* Leave record of what error caused the compilation failure if any */
rts_error(VARLSTCNT(4) ERR_TRIGCOMPFAIL, 2, trigdsc->rtn_desc.rt_name.len, trigdsc->rtn_desc.rt_name.addr);
}
}
assert(trigdsc->rtn_desc.rt_adr);
assert(trigdsc->rtn_desc.rt_adr == CURRENT_RHEAD_ADR(trigdsc->rtn_desc.rt_adr));
/* Setup trigger environment stack frame(s) for execution */
if (!(frame_pointer->type & SFT_TRIGR))
{ /* Create new trigger base frame first that back-stops stack unrolling and return to us */
if (GTM_TRIGGER_DEPTH_MAX < (gtm_trigger_depth + 1)) /* Verify we won't nest too deep */
rts_error(VARLSTCNT(3) ERR_MAXTRIGNEST, 1, GTM_TRIGGER_DEPTH_MAX);
DBGTRIGR((stderr, "gtm_trigger: PUSH: frame_pointer 0x%016lx ctxt value: 0x%016lx\n", frame_pointer, ctxt));
/* Protect against interrupts while we have only a trigger base frame on the stack */
DEFER_INTERRUPTS(INTRPT_IN_TRIGGER_NOMANS_LAND);
/* The current frame invoked a trigger. We cannot return to it for a TP restart or other reason unless
* either the total operation (including trigger) succeeds and we unwind normally or unless the mpc is reset
* (like what happens in various error or restart conditions) because right now it returns to where a database
* command (KILL, SET or ZTRIGGER) was entered. Set flag in the frame to prevent MUM_TSTART unless the frame gets
* reset.
*/
frame_pointer->flags |= SFF_TRIGR_CALLD; /* Do not return to this frame via MUM_TSTART */
DBGTRIGR((stderr, "gtm_trigger: Setting SFF_TRIGR_CALLD in frame 0x"lvaddr"\n", frame_pointer));
base_frame(trigdsc->rtn_desc.rt_adr);
/* Finish base frame initialization - reset mpc/context to return to us without unwinding base frame */
frame_pointer->type |= SFT_TRIGR;
# if defined(__hpux) && defined(__hppa)
/* For HPUX-HPPA (PA-RISC), we use longjmp() to return to gtm_trigger() to avoid some some space register
* corruption issues. Use call-ins already existing mechanism for doing this. Although we no longer support
* HPUX-HPPA for triggers due to some unlocated space register error, this code (effectively always ifdef'd
* out) left in in case it gets resurrected in the future (01/2010 SE).
*/
frame_pointer->mpc = CODE_ADDRESS(ci_ret_code);
frame_pointer->ctxt = GTM_CONTEXT(ci_ret_code);
# else
frame_pointer->mpc = CODE_ADDRESS(gtm_levl_ret_code);
frame_pointer->ctxt = GTM_CONTEXT(gtm_levl_ret_code);
# endif
/* This base stack frame is also where we save environmental info for all triggers invoked at this stack level.
* Subsequent triggers fired at this level in this trigger invocation need only reinitialize a few things but
* can avoid "the big save".
*/
if (NULL == trigr_symval_list)
{ /* No available symvals for use with this trigger, create one */
symbinit(); /* Initialize a symbol table the trigger will use */
curr_symval->trigr_symval = TRUE; /* Mark as trigger symval so will be saved not decommissioned */
} else
{ /* Trigger symval is available for reuse */
new_symval = trigr_symval_list;
assert(new_symval->trigr_symval);
trigr_symval_list = new_symval->last_tab; /* dequeue new curr_symval from list */
REINIT_SYMVAL_BLK(new_symval, curr_symval);
curr_symval = new_symval;
PUSH_MV_STENT(MVST_STAB);
mv_chain->mv_st_cont.mvs_stab = new_symval; /* So unw_mv_ent() can requeue it for later use */
}
/* Push our trigger environment save mv_stent onto the chain */
PUSH_MV_STENT(MVST_TRIGR);
mv_st_ent = mv_chain;
/* Initialize the mv_stent elements processed by stp_gcol which can be called by either op_gvsavtarg() or
* by the extnam saving code below. This initialization keeps stp_gcol - should it be called - from attempting
* to process unset fields filled with garbage in them as valid mstr address/length pairs.
*/
mv_st_ent->mv_st_cont.mvs_trigr.savtarg.str.len = 0;
mv_st_ent->mv_st_cont.mvs_trigr.savextref.len = 0;
mv_st_ent->mv_st_cont.mvs_trigr.dollar_etrap_save.str.len = 0;
mv_st_ent->mv_st_cont.mvs_trigr.dollar_ztrap_save.str.len = 0;
mv_st_ent->mv_st_cont.mvs_trigr.saved_dollar_truth = dollar_truth;
op_gvsavtarg(&mv_st_ent->mv_st_cont.mvs_trigr.savtarg);
if (extnam_str.len)
{
ENSURE_STP_FREE_SPACE(extnam_str.len);
mv_st_ent->mv_st_cont.mvs_trigr.savextref.addr = (char *)stringpool.free;
memcpy(mv_st_ent->mv_st_cont.mvs_trigr.savextref.addr, extnam_str.addr, extnam_str.len);
stringpool.free += extnam_str.len;
assert(stringpool.free <= stringpool.top);
}
mv_st_ent->mv_st_cont.mvs_trigr.savextref.len = extnam_str.len;
mv_st_ent->mv_st_cont.mvs_trigr.ztname_save = dollar_ztname;
mv_st_ent->mv_st_cont.mvs_trigr.ztdata_save = dollar_ztdata;
mv_st_ent->mv_st_cont.mvs_trigr.ztoldval_save = dollar_ztoldval;
mv_st_ent->mv_st_cont.mvs_trigr.ztriggerop_save = dollar_ztriggerop;
mv_st_ent->mv_st_cont.mvs_trigr.ztupdate_save = dollar_ztupdate;
mv_st_ent->mv_st_cont.mvs_trigr.ztvalue_save = dollar_ztvalue;
mv_st_ent->mv_st_cont.mvs_trigr.ztvalue_changed_ptr = ztvalue_changed_ptr;
# ifdef DEBUG
/* In a debug process, these fields give clues of what trigger we are working on */
mv_st_ent->mv_st_cont.mvs_trigr.gtm_trigdsc_last_save = trigdsc;
mv_st_ent->mv_st_cont.mvs_trigr.gtm_trigprm_last_save = trigprm;
# endif
assert(((0 == gtm_trigger_depth) && (ch_at_trigger_init == ctxt->ch))
|| ((0 < gtm_trigger_depth) && (&mdb_condition_handler == ctxt->ch)));
mv_st_ent->mv_st_cont.mvs_trigr.ctxt_save = ctxt;
mv_st_ent->mv_st_cont.mvs_trigr.gtm_trigger_depth_save = gtm_trigger_depth;
if (0 == gtm_trigger_depth)
{ /* Only back up $*trap settings when initiating the first trigger level */
mv_st_ent->mv_st_cont.mvs_trigr.dollar_etrap_save = dollar_etrap;
mv_st_ent->mv_st_cont.mvs_trigr.dollar_ztrap_save = dollar_ztrap;
mv_st_ent->mv_st_cont.mvs_trigr.ztrap_explicit_null_save = ztrap_explicit_null;
dollar_ztrap.str.len = 0;
ztrap_explicit_null = FALSE;
if (NULL != gtm_trigger_etrap.str.addr)
/* An etrap was defined for the trigger environment - Else existing $etrap persists */
dollar_etrap = gtm_trigger_etrap;
}
mv_st_ent->mv_st_cont.mvs_trigr.mumps_status_save = mumps_status;
mv_st_ent->mv_st_cont.mvs_trigr.run_time_save = run_time;
/* See if a MERGE launched the trigger. If yes, save some state so ZWRITE, ZSHOW and/or MERGE can be
* run in the trigger we dispatch. */
if ((0 != merge_args) || TREF(in_zwrite))
PUSH_MVST_MRGZWRSV;
mumps_status = 0;
run_time = TRUE; /* Previous value saved just above restored when frame pops */
} else
{ /* Trigger base frame exists so reinitialize the symbol table for new trigger invocation */
REINIT_SYMVAL_BLK(curr_symval, curr_symval->last_tab);
/* Locate the MVST_TRIGR mv_stent containing the backed up values. Some of those values need
* to be restored so the 2nd trigger has the same environment as the previous trigger at this level
*/
for (mv_st_ent = mv_chain;
(NULL != mv_st_ent) && (MVST_TRIGR != mv_st_ent->mv_st_type);
mv_st_ent = (mv_stent *)(mv_st_ent->mv_st_next + (char *)mv_st_ent))
;
assert(NULL != mv_st_ent);
assert((char *)mv_st_ent < (char *)frame_pointer); /* Ensure mv_stent associated this trigger frame */
/* Reinit backed up values from the trigger environment backup */
dollar_truth = mv_st_ent->mv_st_cont.mvs_trigr.saved_dollar_truth;
op_gvrectarg(&mv_st_ent->mv_st_cont.mvs_trigr.savtarg);
extnam_str.len = mv_st_ent->mv_st_cont.mvs_trigr.savextref.len;
if (extnam_str.len)
memcpy(extnam_str.addr, mv_st_ent->mv_st_cont.mvs_trigr.savextref.addr, extnam_str.len);
mumps_status = 0;
assert(run_time);
/* Note we do not reset the handlers for parallel triggers - set one time only when enter first level
* trigger. After that, whatever happens in trigger world, stays in trigger world.
*/
}
assert(frame_pointer->type & SFT_TRIGR);
# ifdef DEBUG
gtm_trigdsc_last = trigdsc;
gtm_trigprm_last = trigprm;
# endif
/* Set new value of trigger ISVs. Previous values already saved in trigger base frame */
dollar_ztname = &trigdsc->rtn_desc.rt_name;
dollar_ztdata = (mval *)trigprm->ztdata_new;
dollar_ztoldval = trigprm->ztoldval_new;
dollar_ztriggerop = (mval *)trigprm->ztriggerop_new;
dollar_ztupdate = trigprm->ztupdate_new;
dollar_ztvalue = trigprm->ztvalue_new;
ztvalue_changed_ptr = &trigprm->ztvalue_changed;
/* Set values associated with trigger into symbol table */
lvvalarray = trigprm->lvvalarray;
for (i = 0, mne_p = trigdsc->lvnamearray, indx_p = trigdsc->lvindexarray;
i < trigdsc->numlvsubs; ++i, ++mne_p, ++indx_p)
{ /* Once thru for each subscript we are to set */
lvvalue = lvvalarray[*indx_p]; /* Locate mval that contains value */
assert(NULL != lvvalue);
assert(MV_DEFINED(lvvalue)); /* No sense in defining the undefined */
lvval = lv_getslot(curr_symval); /* Allocate an lvval to put into symbol table */
LVVAL_INIT(lvval, curr_symval);
lvval->v = *lvvalue; /* Copy mval into lvval */
added = add_hashtab_mname_symval(&curr_symval->h_symtab, mne_p, lvval, &tabent);
assert(added);
assert(NULL != tabent);
}
/* While the routine header is available in trigdsc, we also need the <null> label address associated with
* the first (and only) line of code.
*/
lbl_offset_p = LNRTAB_ADR(trigdsc->rtn_desc.rt_adr);
transfer_addr = (uchar_ptr_t)LINE_NUMBER_ADDR(trigdsc->rtn_desc.rt_adr, lbl_offset_p);
/* Create new stack frame for invoked trigger in same fashion as gtm_init_env() creates its 2ndary frame */
# ifdef HAS_LITERAL_SECT
new_stack_frame(trigdsc->rtn_desc.rt_adr, (unsigned char *)LINKAGE_ADR(trigdsc->rtn_desc.rt_adr), transfer_addr);
# else
/* Any platform that does not follow pv-based linkage model either
* (1) uses the following calculation to determine the context pointer value, or
* (2) doesn't need a context pointer
*/
new_stack_frame(trigdsc->rtn_desc.rt_adr, PTEXT_ADR(trigdsc->rtn_desc.rt_adr), transfer_addr);
# endif
dollar_tlevel_start = dollar_tlevel;
assert(gv_target->gd_csa == cs_addrs);
gv_target->trig_local_tn = local_tn; /* Record trigger being driven for this global */
/* Invoke trigger generated code */
rc = gtm_trigger_invoke();
if (1 == rc)
{ /* Normal return code (from dm_start). Check if TP has been unwound or not */
assert(dollar_tlevel <= dollar_tlevel_start); /* Bigger would be quite the surprise */
if (dollar_tlevel < dollar_tlevel_start)
{ /* Our TP level was unwound during the trigger so throw an error */
DBGTRIGR((stderr, "gtm_trigger: $TLEVEL less than at start - throwing TRIGTLVLCHNG\n"));
gtm_trigger_fini(TRUE, FALSE); /* dump this trigger level */
rts_error(VARLSTCNT(4) ERR_TRIGTLVLCHNG, 2, trigdsc->rtn_desc.rt_name.len,
trigdsc->rtn_desc.rt_name.addr);
}
rc = 0; /* Be polite and return 0 for the (hopefully common) success case */
} else if (ERR_TPRETRY == rc)
{ /* We are restarting the entire transaction. There are two possibilities here:
* 1) This is a nested trigger level in which case we need to unwind further or
* the outer trigger level was created by M code. If either is true, just
* rethrow the TPRETRY error.
* 2) This is the outer trigger and the call to op_tstart() was done by our caller.
* In this case, we just return to our caller with a code signifying they need
* to restart the implied transaction.
*/
assert(dollar_tlevel && (tstart_trigger_depth <= gtm_trigger_depth));
if ((tstart_trigger_depth < gtm_trigger_depth) || !tp_pointer->implicit_tstart || !tp_pointer->implicit_trigger)
{ /* Unwind a trigger level to restart level or to next trigger boundary */
gtm_trigger_fini(FALSE, FALSE); /* Get rid of this trigger level - we won't be returning */
DBGTRIGR((stderr, "gtm_trigger: dm_start returned rethrow code - rethrowing ERR_TPRETRY\n"));
INVOKE_RESTART;
} else
{ /* It is possible we are restarting a transaction that never got around to creating a base
* frame yet the implicit TStart was done. So if there is no trigger base frame, do not
* run gtm_trigger_fini() but instead do the one piece of cleanup it does that we still need.
*/
assert(donot_INVOKE_MUMTSTART);
if (SFT_TRIGR & frame_pointer->type)
{ /* Normal case when TP restart unwinding back to implicit beginning */
gtm_trigger_fini(FALSE, FALSE);
DBGTRIGR((stderr, "gtm_trigger: dm_start returned rethrow code - returning to gvcst_<caller>\n"));
} else
{ /* Unusual case of trigger that died in no-mans-land before trigger base frame established.
* Remove the "do not return to me" flag only on non-error unwinds */
assert(tp_pointer->implicit_tstart);
assert(SFF_TRIGR_CALLD & frame_pointer->flags);
frame_pointer->flags &= SFF_TRIGR_CALLD_OFF;
DBGTRIGR((stderr, "gtm_trigger: turning off SFF_TRIGR_CALLD (1) in frame 0x"lvaddr"\n",
frame_pointer));
DBGTRIGR((stderr, "gtm_trigger: unwinding no-base-frame trigger for TP restart\n"));
}
}
/* Fall out and return ERR_TPRETRY to caller */
} else if (0 == rc)
/* We should never get a return code of 0. This would be out-of-design and a signal that something
* is quite broken. We cannot "rethrow" outside the trigger because it was not initially an error so
* mdb_condition_handler would have no record of it (rethrown errors must have originally occurred in
* or to be RE-thrown) and assert fail at best.
*/
GTMASSERT;
else
{ /* We have an unexpected return code due to some error during execution of the trigger that tripped
* gtm_trigger's safety handler (i.e. an error occurred in mdb_condition_handler() established by
* dm_start(). Since we are going to unwind the trigger frame and rethrow the error, we also have
* to unwind all the stack frames on top of the trigger frame. Figure out how many frames that is,
* unwind them all plus the trigger base frame before rethrowing the error.
*/
for (unwinds = 0, fp = frame_pointer; (NULL != fp) && !(SFT_TRIGR & fp->type); fp = fp->old_frame_pointer)
unwinds++;
assert((NULL != fp) && (SFT_TRIGR & fp->type));
GOFRAMES(unwinds, TRUE, FALSE);
assert((NULL != frame_pointer) && !(SFT_TRIGR & frame_pointer->type));
DBGTRIGR((stderr, "gtm_trigger: Unsupported return code (%d) - unwound %d frames and now rethrowing error\n",
rc, unwinds));
rts_error(VARLSTCNT(1) ERR_REPEATERROR);
}
return rc;
}
void op_svget(int varnum, mval *v)
{
io_log_name *tl;
int count;
gtm_uint64_t ucount;
char *c1, *c2;
mval *mvp;
# ifdef UNIX
d_rm_struct *d_rm;
# endif
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
# if defined(UNIX) && defined(DEBUG)
if (gtm_white_box_test_case_enabled && (WBTEST_HUGE_ALLOC == gtm_white_box_test_case_number))
{
if (1 == gtm_white_box_test_case_count)
totalAlloc = totalAllocGta = totalRmalloc = totalRallocGta = totalUsed = totalUsedGta = 0xffff;
else if (2 == gtm_white_box_test_case_count)
totalAlloc = totalAllocGta = totalRmalloc = totalRallocGta = totalUsed = totalUsedGta = 0xfffffff;
else if (3 == gtm_white_box_test_case_count)
{
# ifdef GTM64
if (8 == SIZEOF(size_t))
totalAlloc = totalAllocGta = totalRmalloc = totalRallocGta
= totalUsed = totalUsedGta = 0xfffffffffffffff;
else
# endif
totalAlloc = totalAllocGta = totalRmalloc = totalRallocGta = totalUsed = totalUsedGta = 0xfffffff;
} else
totalAlloc = totalAllocGta = totalRmalloc = totalRallocGta = totalUsed
= totalUsedGta = GTM64_ONLY(SIZEOF(size_t)) NON_GTM64_ONLY(SIZEOF(size_t) > 4 ? 4 : SIZEOF(size_t));
}
# endif
switch (varnum)
{
case SV_HOROLOG:
op_horolog(v);
break;
case SV_ZGBLDIR:
v->mvtype = MV_STR;
v->str = dollar_zgbldir.str;
break;
case SV_PRINCIPAL:
tl = dollar_principal ? dollar_principal : io_root_log_name->iod->trans_name;
v->str.addr = tl->dollar_io;
v->str.len = tl->len;
/*** The following should be in the I/O code ***/
if (ESC == *v->str.addr)
{
if (5 > v->str.len)
v->str.len = 0;
else
{
v->str.addr += ESC_OFFSET;
v->str.len -= ESC_OFFSET;
}
}
s2pool(&(v->str));
v->mvtype = MV_STR;
break;
case SV_ZIO:
v->mvtype = MV_STR;
/* NOTE: This is **NOT** equivalent to :
* io_curr_log_name->dollar_io
*/
v->str.addr = io_curr_device.in->trans_name->dollar_io;
v->str.len = io_curr_device.in->trans_name->len;
if (ESC == *v->str.addr)
{
if (5 > v->str.len)
v->str.len = 0;
else
{
v->str.addr += ESC_OFFSET;
v->str.len -= ESC_OFFSET;
}
}
s2pool(&(v->str));
break;
case SV_JOB:
*v = dollar_job;
break;
case SV_REFERENCE:
get_reference(v);
break;
case SV_SYSTEM:
*v = dollar_system;
break;
case SV_STORAGE:
/* double2mval(v, getstorage()); Causes issues with unaligned stack on x86_64 - remove until fixed */
i2mval(v, getstorage());
break;
case SV_TLEVEL:
count = (int)dollar_tlevel;
MV_FORCE_MVAL(v, count);
break;
case SV_TRESTART:
MV_FORCE_MVAL(v, (int)((MAX_VISIBLE_TRESTART < dollar_trestart) ? MAX_VISIBLE_TRESTART : dollar_trestart));
break;
case SV_X:
count = (int)io_curr_device.out->dollar.x;
MV_FORCE_MVAL(v, count);
break;
case SV_Y:
count = (int)io_curr_device.out->dollar.y;
MV_FORCE_MVAL(v, count);
break;
case SV_ZA:
count = (int)io_curr_device.in->dollar.za;
MV_FORCE_MVAL(v, count);
break;
case SV_ZB:
c1 = (char *)io_curr_device.in->dollar.zb;
c2 = c1 + SIZEOF(io_curr_device.in->dollar.zb);
ENSURE_STP_FREE_SPACE(SIZEOF(io_curr_device.in->dollar.zb));
v->mvtype = MV_STR;
v->str.addr = (char *)stringpool.free;
while (c1 < c2 && *c1)
*stringpool.free++ = *c1++;
v->str.len = INTCAST((char *)stringpool.free - v->str.addr);
break;
case SV_ZC: /****THESE ARE DUMMY VALUES ONLY!!!!!!!!!!!!!!!!!****/
MV_FORCE_MVAL(v, 0);
break;
case SV_ZCMDLINE:
get_command_line(v, TRUE); /* TRUE to indicate we want $ZCMDLINE
(i.e. processed not actual command line) */
break;
case SV_ZEOF:
# ifdef UNIX
if (rm == io_curr_device.in->type)
{
d_rm = (d_rm_struct *)io_curr_device.in->dev_sp;
if (RM_READ != d_rm->lastop)
{
*v = literal_zero;
break;
}
}
# endif
*v = io_curr_device.in->dollar.zeof ? literal_one : literal_zero;
break;
case SV_ZQUIT:
*v = dollar_zquit_anyway ? literal_one : literal_zero;
break;
case SV_IO:
v->str.addr = io_curr_device.in->name->dollar_io;
v->str.len = io_curr_device.in->name->len;
/*** The following should be in the I/O code ***/
if (ESC == *v->str.addr)
{
if (5 > v->str.len)
v->str.len = 0;
else
{
v->str.addr += ESC_OFFSET;
v->str.len -= ESC_OFFSET;
}
}
s2pool(&(v->str));
v->mvtype = MV_STR;
break;
case SV_PROMPT:
v->mvtype = MV_STR;
v->str.addr = (TREF(gtmprompt)).addr;
v->str.len = (TREF(gtmprompt)).len;
s2pool(&v->str);
break;
case SV_ZCOMPILE:
v->mvtype = MV_STR;
v->str = TREF(dollar_zcompile);
s2pool(&(v->str));
break;
case SV_ZDIR:
setzdir(NULL, v);
if (v->str.len != dollar_zdir.str.len || 0 != memcmp(v->str.addr, dollar_zdir.str.addr, v->str.len))
gtm_putmsg_csa(CSA_ARG(NULL) VARLSTCNT(6) ERR_ZDIROUTOFSYNC, 4, v->str.len, v->str.addr,
dollar_zdir.str.len, dollar_zdir.str.addr);
SKIP_DEVICE_IF_NOT_NEEDED(v);
s2pool(&(v->str));
break;
case SV_ZSTEP:
*v = dollar_zstep;
break;
case SV_ZMODE:
*v = TREF(dollar_zmode);
break;
case SV_ZMAXTPTIME:
i2mval(v, TREF(dollar_zmaxtptime));
break;
case SV_ZPOS:
getzposition(v);
break;
case SV_ZPROC:
getzprocess();
*v = dollar_zproc;
break;
case SV_ZLEVEL:
count = dollar_zlevel();
MV_FORCE_MVAL(v, count);
break;
case SV_ZROUTINES:
if (!TREF(zro_root))
zro_init();
v->mvtype = MV_STR;
v->str = TREF(dollar_zroutines);
s2pool(&(v->str));
break;
case SV_ZSOURCE:
v->mvtype = MV_STR;
v->str = dollar_zsource.str;
break;
case SV_ZSTATUS:
*v = dollar_zstatus;
s2pool(&(v->str));
break;
case SV_ZTRAP:
v->mvtype = MV_STR;
v->str = dollar_ztrap.str;
assert(!v->str.len || !ztrap_explicit_null);
s2pool(&(v->str));
break;
case SV_DEVICE:
get_dlr_device(v);
break;
case SV_KEY:
get_dlr_key(v);
break;
case SV_ZVERSION:
v->mvtype = MV_STR;
v->str.addr = (char *)gtm_release_name;
v->str.len = gtm_release_name_len;
break;
case SV_ZSYSTEM:
MV_FORCE_MVAL(v, dollar_zsystem);
break;
case SV_ZCSTATUS:
/* Maintain the external $ZCSTATUS == 1 for SUCCESS on UNIX while internal good is 0 */
MV_FORCE_MVAL(v, UNIX_ONLY((0 == TREF(dollar_zcstatus)) ? 1 : ) TREF(dollar_zcstatus));
break;
case SV_ZEDITOR:
MV_FORCE_MVAL(v, dollar_zeditor);
break;
case SV_QUIT:
MV_FORCE_MVAL(v, dollar_quit());
break;
case SV_ECODE:
ecode_get(-1, v);
break;
case SV_ESTACK:
count = (dollar_zlevel() - 1) - dollar_estack_delta.m[0];
MV_FORCE_MVAL(v, count);
break;
case SV_ETRAP:
v->mvtype = MV_STR;
v->str = dollar_etrap.str;
assert(!v->str.len || !ztrap_explicit_null);
s2pool(&(v->str));
break;
case SV_STACK:
count = (dollar_zlevel() - 1);
MV_FORCE_MVAL(v, count);
break;
case SV_ZERROR:
v->mvtype = MV_STR;
v->str = dollar_zerror.str;
s2pool(&(v->str));
break;
case SV_ZYERROR:
v->mvtype = MV_STR;
v->str = dollar_zyerror.str;
s2pool(&(v->str));
break;
case SV_ZINTERRUPT:
v->mvtype = MV_STR;
v->str = dollar_zinterrupt.str;
s2pool(&(v->str));
break;
case SV_ZININTERRUPT:
MV_FORCE_MVAL(v, dollar_zininterrupt);
break;
case SV_ZJOB:
MV_FORCE_UMVAL(v, dollar_zjob);
break;
case SV_ZDATE_FORM:
MV_FORCE_MVAL(v, TREF(zdate_form));
break;
case SV_ZTEXIT:
*v = dollar_ztexit;
break;
case SV_ZALLOCSTOR:
ucount = (gtm_uint64_t)totalAlloc + (gtm_uint64_t)totalAllocGta;
ui82mval(v, ucount);
break;
case SV_ZREALSTOR:
ucount = (gtm_uint64_t)totalRmalloc + (gtm_uint64_t)totalRallocGta;
ui82mval(v, ucount);
break;
case SV_ZUSEDSTOR:
ucount = (gtm_uint64_t)totalUsed + (gtm_uint64_t)totalUsedGta;
ui82mval(v, ucount);
break;
case SV_ZCHSET:
v->mvtype = MV_STR;
v->str = dollar_zchset;
break;
case SV_ZPATNUMERIC:
v->mvtype = MV_STR;
v->str = dollar_zpatnumeric;
break;
case SV_ZTNAME:
case SV_ZTCODE: /* deprecated */
# ifdef GTM_TRIGGER
if (NULL == dollar_ztname)
memcpy(v, &literal_null, SIZEOF(mval));
else
{
v->mvtype = MV_STR;
v->str.addr = dollar_ztname->addr;
v->str.len = dollar_ztname->len;
}
break;
# else
rts_error_csa(CSA_ARG(NULL) VARLSTCNT(1) ERR_UNIMPLOP);
# endif
case SV_ZTDATA:
# ifdef GTM_TRIGGER
/* Value comes from GT.M, but it might be numeric and need conversion to a string */
assert(!dollar_ztdata || MV_DEFINED(dollar_ztdata));
if (NULL != dollar_ztdata)
MV_FORCE_STR(dollar_ztdata);
memcpy(v, (NULL != dollar_ztdata) ? dollar_ztdata : &literal_null, SIZEOF(mval));
break;
# else
rts_error_csa(CSA_ARG(NULL) VARLSTCNT(1) ERR_UNIMPLOP);
# endif
case SV_ZTDELIM:
# ifdef GTM_TRIGGER
assert(!dollar_ztdelim || MV_DEFINED(dollar_ztdelim));
if (NULL == dollar_ztdelim || !(MV_STR & dollar_ztdelim->mvtype) || (0 == dollar_ztdelim->str.len))
memcpy(v, &literal_null, SIZEOF(mval));
else
memcpy(v, dollar_ztdelim, SIZEOF(mval));
break;
# else
rts_error_csa(CSA_ARG(NULL) VARLSTCNT(1) ERR_UNIMPLOP);
# endif
case SV_ZTOLDVAL:
# ifdef GTM_TRIGGER
/* Value comes from GT.M, but it might be numeric and need conversion to a string */
assert(!dollar_ztoldval || MV_DEFINED(dollar_ztoldval));
if (NULL != dollar_ztoldval)
MV_FORCE_STR(dollar_ztoldval);
memcpy(v, (NULL != dollar_ztoldval) ? dollar_ztoldval : &literal_null, SIZEOF(mval));
break;
# else
rts_error_csa(CSA_ARG(NULL) VARLSTCNT(1) ERR_UNIMPLOP);
# endif
case SV_ZTRIGGEROP:
# ifdef GTM_TRIGGER
/* Value comes from GT.M, but assert it's a string */
assert(!dollar_ztriggerop || (MV_STR & dollar_ztriggerop->mvtype));
memcpy(v, (NULL != dollar_ztriggerop) ? dollar_ztriggerop : &literal_null, SIZEOF(mval));
break;
# else
rts_error_csa(CSA_ARG(NULL) VARLSTCNT(1) ERR_UNIMPLOP);
# endif
case SV_ZTUPDATE:
# ifdef GTM_TRIGGER
/* Value comes from GT.M, but if there were no delims involved, the value will be undefined, and
* we return a "literal_null".
*/
memcpy(v, ((NULL != dollar_ztupdate && (MV_STR & dollar_ztupdate->mvtype)) ? dollar_ztupdate
: &literal_null), SIZEOF(mval));
break;
# else
rts_error_csa(CSA_ARG(NULL) VARLSTCNT(1) ERR_UNIMPLOP);
# endif
case SV_ZTVALUE:
# ifdef GTM_TRIGGER
/* Value comes from user-land so make sure things are proper */
assert(!dollar_ztvalue || MV_DEFINED(dollar_ztvalue));
if (NULL != dollar_ztvalue)
MV_FORCE_STR(dollar_ztvalue);
memcpy(v, (NULL != dollar_ztvalue) ? dollar_ztvalue : &literal_null, SIZEOF(mval));
break;
# else
rts_error_csa(CSA_ARG(NULL) VARLSTCNT(1) ERR_UNIMPLOP);
# endif
case SV_ZTWORMHOLE:
# ifdef GTM_TRIGGER
/* Value comes from user-land so make sure things are proper */
mvp = &dollar_ztwormhole;
if (MV_DEFINED(mvp))
{
MV_FORCE_STR(mvp);
memcpy(v, mvp, SIZEOF(mval));
} else
memcpy(v, &literal_null, SIZEOF(mval));
ztwormhole_used = TRUE;
break;
# else
rts_error_csa(CSA_ARG(NULL) VARLSTCNT(1) ERR_UNIMPLOP);
# endif
case SV_ZTSLATE:
# ifdef GTM_TRIGGER
/* Value comes from user-land so make sure things are proper */
assert(MV_DEFINED((&dollar_ztslate)));
mvp = &dollar_ztslate;
MV_FORCE_STR(mvp);
memcpy(v, mvp, SIZEOF(mval));
break;
# else
rts_error_csa(CSA_ARG(NULL) VARLSTCNT(1) ERR_UNIMPLOP);
# endif
case SV_ZTLEVEL:
# ifdef GTM_TRIGGER
MV_FORCE_MVAL(v, gtm_trigger_depth);
break;
# else
rts_error_csa(CSA_ARG(NULL) VARLSTCNT(1) ERR_UNIMPLOP);
# endif
case SV_ZONLNRLBK:
# ifdef UNIX
count = TREF(dollar_zonlnrlbk);
MV_FORCE_MVAL(v, count);
break;
# else
rts_error_csa(CSA_ARG(NULL) VARLSTCNT(1) ERR_UNIMPLOP);
# endif
case SV_ZCLOSE:
# ifdef UNIX
count = TREF(dollar_zclose);
MV_FORCE_MVAL(v, count);
break;
# else
rts_error_csa(CSA_ARG(NULL) VARLSTCNT(1) ERR_UNIMPLOP);
# endif
case SV_ZKEY:
get_dlr_zkey(v);
break;
default:
assertpro(FALSE);
}
}
bool gtcmtr_increment(void)
{
cm_region_list *reg_ref;
mval incr_delta, post_incr;
unsigned char buff[MAX_ZWR_KEY_SZ], *end;
unsigned char *ptr, regnum;
short n;
unsigned short top, len, temp_short;
static readonly gds_file_id file;
error_def(ERR_KEY2BIG);
error_def(ERR_GVIS);
error_def(ERR_DBPRIVERR);
ptr = curr_entry->clb_ptr->mbf;
assert(*ptr == CMMS_Q_INCREMENT);
ptr++;
GET_USHORT(len, ptr);
ptr += SIZEOF(unsigned short);
regnum = *ptr++;
reg_ref = gtcm_find_region(curr_entry,regnum);
len--; /* subtract size of regnum */
CM_GET_GVCURRKEY(ptr, len);
gtcm_bind_name(reg_ref->reghead, TRUE);
if (gv_cur_region->read_only)
rts_error(VARLSTCNT(4) ERR_DBPRIVERR, 2, DB_LEN_STR(gv_cur_region));
if (JNL_ALLOWED(cs_addrs))
{ /* we need to copy client's specific prc_vec into the global variable in order that the gvcst* routines
* do the right job. actually we need to do this only if JNL_ENABLED(cs_addrs), but since it is not
* easy to re-execute the following two assignments in case gvcst_incr's call to t_end encounters a
* cdb_sc_jnlstatemod retry code, we choose the easier approach of executing the following segment
* if JNL_ALLOWED(cs_addrs) is TRUE instead of checking for JNL_ENABLED(cs_addrs) to be TRUE.
* this approach has the overhead that we will be doing the following assignments even though JNL_ENABLED
* might not be TRUE but since the following two are just pointer copies, it is not considered a big overhead.
* this approach ensures that the jnl_put_jrt_pini gets the appropriate prc_vec for writing into the
* journal record in case JNL_ENABLED turns out to be TRUE in t_end time.
* note that the value of JNL_ALLOWED(cs_addrs) cannot be changed on the fly without obtaining standalone access
* and hence the correctness of prc_vec (whenever it turns out necessary) is guaranteed.
*/
originator_prc_vec = curr_entry->pvec;
cs_addrs->jnl->pini_addr = reg_ref->pini_addr;
}
GET_USHORT(len, ptr);
ptr += SIZEOF(unsigned short);
incr_delta.mvtype = MV_STR;
incr_delta.str.len = len;
incr_delta.str.addr = (char *)ptr;
if ((n = gv_currkey->end + 1) > gv_cur_region->max_key_size)
{
if ((end = format_targ_key(&buff[0], MAX_ZWR_KEY_SZ, gv_currkey, TRUE)) == 0)
end = &buff[MAX_ZWR_KEY_SZ - 1];
rts_error(VARLSTCNT(11) ERR_KEY2BIG, 4, n, (int4)gv_cur_region->max_key_size,
REG_LEN_STR(gv_cur_region), 0, ERR_GVIS, 2, end - buff, buff);
}
MV_FORCE_NUMD(&incr_delta);
gvcst_incr(&incr_delta, &post_incr);
if (JNL_ALLOWED(cs_addrs))
reg_ref->pini_addr = cs_addrs->jnl->pini_addr; /* In case journal switch occurred */
ptr = curr_entry->clb_ptr->mbf;
if (MV_DEFINED(&post_incr))
{
temp_short = (unsigned short)post_incr.str.len;
assert((int4)temp_short == post_incr.str.len); /* ushort <- int4 assignment lossy? */
if (curr_entry->clb_ptr->mbl < 1 + /* msg header */
SIZEOF(temp_short) + /* size of length of $INCR return value */
temp_short) /* length of $INCR return value */
{ /* resize buffer */
cmi_realloc_mbf(curr_entry->clb_ptr, 1 + SIZEOF(temp_short) + temp_short);
ptr = curr_entry->clb_ptr->mbf;
}
*ptr++ = CMMS_R_INCREMENT;
PUT_USHORT(ptr, temp_short);
ptr += SIZEOF(unsigned short);
memcpy(ptr, post_incr.str.addr, temp_short);
ptr += temp_short;
} else
unsigned char *n2s(mval *mv_ptr)
{
unsigned char *start, *cp, *cp1;
int4 exp, n0, m1, m0, tmp;
unsigned char lcl_buf[MAX_DIGITS_IN_INT];
if (!MV_DEFINED(mv_ptr))
GTMASSERT;
ENSURE_STP_FREE_SPACE(MAX_NUM_SIZE);
start = stringpool.free;
cp = start;
m1 = mv_ptr->m[1];
if (m1 == 0) /* SHOULD THIS BE UNDER THE MV_INT TEST? */
*cp++ = '0';
else if (mv_ptr->mvtype & MV_INT)
{
if (m1 < 0)
{
*cp++ = '-';
m1 = -m1;
}
cp1 = ARRAYTOP(lcl_buf);
/* m0 is the integer part */
m0 = m1 / MV_BIAS;
/* m1 will become the fractional part */
m1 = m1 - (m0 * MV_BIAS);
if (m1 > 0)
{
for (n0 = 0; n0 < MV_BIAS_PWR; n0++)
{
tmp = m1;
m1 /= 10;
tmp -= (m1 * 10);
if (tmp)
break;
}
*--cp1 = tmp + '0';
for (n0++; n0 < MV_BIAS_PWR; n0++)
{
tmp = m1;
m1 /= 10;
*--cp1 = tmp - (m1 * 10) + '0';
}
*--cp1 = '.';
}
while (m0 > 0)
{
tmp = m0;
m0 /= 10;
*--cp1 = tmp - (m0 * 10) + '0';
}
n0 = (int4)(ARRAYTOP(lcl_buf) - cp1);
memcpy(cp, cp1, n0);
cp += n0;
} else
{
exp = (int4)mv_ptr->e - MV_XBIAS;
if (mv_ptr->sgn)
*cp++ = '-';
m0 = mv_ptr->m[0];
if (exp < 0)
{
*cp++ = '.';
for (n0 = exp; n0 < 0; n0++)
*cp++ = '0';
}
for (; m1; m1 = m0, m0 = 0)
{
for (n0 = 0; n0 < PACKED_DIGITS; n0++)
{
if (exp-- == 0)
{
if (m0 == 0 && m1 == 0)
break;
*cp++ = '.';
} else if (exp < 0 && m0 == 0 && m1 == 0)
break;
tmp = m1 / MANT_LO;
m1 = (m1 - tmp * MANT_LO) * 10;
*cp++ = tmp + '0';
}
}
while (exp-- > 0)
*cp++ = '0';
}
mv_ptr->mvtype |= MV_STR;
mv_ptr->mvtype &= ~MV_NUM_APPROX;
mv_ptr->str.addr = (char *)start;
NON_UNICODE_ONLY(mv_ptr->str.len = cp - start);
#ifdef UNICODE_SUPPORTED
/* Numerics are not unicode so cheaply set "unicode" length same as ascii length */
mv_ptr->str.len = mv_ptr->str.char_len = INTCAST(cp - start);
mv_ptr->mvtype |= MV_UTF_LEN;
#endif
stringpool.free = cp;
assert(mv_ptr->str.len);
return cp;
}
void lvzwr_out(lv_val *lvp)
{
char buff;
uchar_ptr_t lastc;
int n, nsubs, sbs_depth;
lv_val *dst_lv, *res_lv, *lvpc;
mstr one;
mval *subscp, *val, outindx;
ht_ent_addr *tabent_addr;
ht_ent_mname *tabent_mname;
boolean_t htent_added, dump_container;
zwr_alias_var *newzav, *zav;
mident_fixed zwrt_varname;
lvzwrite_datablk *newzwrb;
gparam_list param_list; /* for op_putindx call through callg */
gvnh_reg_t *gvnh_reg;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
val = &lvp->v;
assert(lvzwrite_block);
if (!merge_args)
{ /* The cases that exist here are:
* 1) This is a container variable. If the lv_val it refers to has been printed, show that association.
* Else, "create" a $ZWRTACxxx var/index that will define the value. Then before returning, cause
* that container var to be dumped with the appropriate $ZWRTACxxx index as the var name.
* 2) This is an alias base variable. If first time seen, we print normally but record it and put a
* ";#" tag on the end to signify it is an alias var (doesn't affect value). If we look it up and it
* is not the first time this lv_val has been printed, then we instead print the statement needed to
* alias it to the first seen var.
* 3) This is just a normal var needing to be printed normally.
*/
htent_added = FALSE;
one.addr = &buff;
one.len = 1;
lvzwrite_block->zav_added = FALSE;
if (lvp->v.mvtype & MV_ALIASCONT)
{ /* Case 1 -- have an alias container */
assert(curr_symval->alias_activity);
assert(!LV_IS_BASE_VAR(lvp)); /* verify is subscripted var */
lvpc = (lv_val *)lvp->v.str.addr;
assert(lvpc);
assert(LV_IS_BASE_VAR(lvpc)); /* Verify base var lv_val */
if (tabent_addr = (ht_ent_addr *)lookup_hashtab_addr(&zwrhtab->h_zwrtab, (char **)&lvpc))
{ /* The value was found, we have a reference we can print now */
assert(HTENT_VALID_ADDR(tabent_addr, zwr_alias_var, zav));
*one.addr = '*';
zshow_output(zwr_output, &one);
lvzwr_out_targkey(&one);
*one.addr = '=';
zshow_output(zwr_output, &one);
zav = (zwr_alias_var *)tabent_addr->value;
assert(0 < zav->zwr_var.len);
zwr_output->flush = TRUE;
zshow_output(zwr_output, (const mstr *)&zav->zwr_var);
return;
}
/* This lv_val isn't known to us yet. Scan the hash curr_symval hash table to see if it is known as a
* base variable as we could have a "forward reference" here.
*/
tabent_mname = als_lookup_base_lvval(lvpc);
/* note even though both paths below add a zav, not bothering to set zav_added because that flag is
* really only (currently) cared about in reference to processing a basevar so we wouldn't
* be in this code path anyway. Comment here to record potential usage if that changes.
*/
if (tabent_mname)
{ /* Found a base var it can reference -- create a zwrhtab entry for it */
assert(tabent_mname->key.var_name.len);
newzav = als_getzavslot();
newzav->zwr_var = tabent_mname->key.var_name;
htent_added = add_hashtab_addr(&zwrhtab->h_zwrtab, (char **)&lvpc, newzav, &tabent_addr);
assert(htent_added);
dump_container = FALSE;
} else
{ /* Unable to find lv_val .. must be "orphaned" so we generate a new $ZWRTAC var for it. The first
* check however is if this is the first $ZWRTAC var being generated for this $ZWR. If yes, generate
* a $ZWRTAC="" line to preceed it. This will be a flag to load to clear out all existing $ZWRTAC
* temp vars so there is no pollution between loads of ZWRitten data.
*/
if (0 == zwrtacindx++)
{ /* Put out "dummy" statement that will clear all the $ZWRTAC vars for a clean slate */
zwr_output->flush = TRUE;
zshow_output(zwr_output, &dzwrtac_clean);
}
MEMCPY_LIT(zwrt_varname.c, DOLLAR_ZWRTAC);
lastc = i2asc((uchar_ptr_t)zwrt_varname.c + STR_LIT_LEN(DOLLAR_ZWRTAC), zwrtacindx);
newzav = als_getzavslot();
newzav->zwr_var.addr = zwrt_varname.c;
newzav->zwr_var.len = INTCAST(((char *)lastc - &zwrt_varname.c[0]));
s2pool(&newzav->zwr_var);
htent_added = add_hashtab_addr(&zwrhtab->h_zwrtab, (char **)&lvpc, newzav, &tabent_addr);
assert(htent_added);
dump_container = TRUE;
}
/* Note value_printed flag in newzav not set since we are NOT dumping the value at this point
* but only the association. Since the flag is not set, we *will* dump it when we get to that
* actual variable.
*/
*one.addr = '*';
zshow_output(zwr_output, &one);
lvzwr_out_targkey(&one);
*one.addr = '=';
zshow_output(zwr_output, &one);
zwr_output->flush = TRUE;
zshow_output(zwr_output, (const mstr *)&newzav->zwr_var);
if (dump_container)
{ /* We want to dump the entire container variable but the name doesn't match the var we are
* currently dumping so push a new lvzwrite_block onto the stack, fill it in for the current var
* and call lvzwr_var() to handle it. When done, dismantle the temp lvzwrite_block.
*/
newzwrb = (lvzwrite_datablk *)malloc(SIZEOF(lvzwrite_datablk));
memset(newzwrb, 0, SIZEOF(lvzwrite_datablk));
newzwrb->sub = (zwr_sub_lst *)malloc(SIZEOF(zwr_sub_lst) * MAX_LVSUBSCRIPTS);
newzwrb->curr_name = &newzav->zwr_var;
newzwrb->prev = lvzwrite_block;
lvzwrite_block = newzwrb;
lvzwr_var(lvpc, 0);
assert(newzav->value_printed);
assert(newzwrb == lvzwrite_block);
free(newzwrb->sub);
lvzwrite_block = newzwrb->prev;
free(newzwrb);
}
return;
} else if (LV_IS_BASE_VAR(lvp) && IS_ALIASLV(lvp))
{ /* Case 2 -- alias base variable (only base vars have reference counts). Note this can occur with
* TP save/restore vars since we increment both trefcnt and crefcnt for these hidden copied references.
* Because of that, we can't assert alias_activity but otherwise it shouldn't affect processing.
*/
if (!(htent_added = add_hashtab_addr(&zwrhtab->h_zwrtab, (char **)&lvp, NULL, &tabent_addr)))
{ /* Entry already existed -- need to output association rather than values */
assert(tabent_addr);
zav = (zwr_alias_var *)tabent_addr->value;
assert(zav);
if (zav->value_printed)
{ /* Value has already been output -- print association this time */
*one.addr = '*'; /* Flag as creating an alias */
zshow_output(zwr_output, &one);
/* Now for (new) variable name */
zshow_output(zwr_output, lvzwrite_block->curr_name);
*one.addr = '=';
zshow_output(zwr_output, &one);
/* .. and the var name aliasing to (the first seen with this lv_val) */
assert(zav->zwr_var.len);
zwr_output->flush = TRUE;
zshow_output(zwr_output, &zav->zwr_var);
return;
}
/* Else the value for this entry has not yet been printed so let us fall into case 3
* and get that done. Also set the flag so we mark it as an alias. Note this can happen if
* a container value for a name is encountered before the base var it points to. We will
* properly resolve the entry but its value won't have been printed until we actually encounter
* it in the tree.
*/
htent_added = TRUE; /* to force the ;# tag at end of value printing */
zav->value_printed = TRUE; /* value will be output shortly below */
} else
{ /* Entry was added so is first appearance -- give it a value to hold onto and print it */
newzav = als_getzavslot();
newzav->zwr_var = *lvzwrite_block->curr_name;
newzav->value_printed = TRUE; /* or rather it will be shortly.. */
tabent_addr->value = (void *)newzav;
lvzwrite_block->zav_added = TRUE;
/* Note fall into case 3 to print var and value if exists */
}
}
/* Case 3 - everything else */
if (!MV_DEFINED(val))
return;
MV_FORCE_STR(val);
lvzwr_out_targkey(&one);
*one.addr = '=';
zshow_output(zwr_output, &one);
mval_write(zwr_output, val, !htent_added);
if (htent_added)
{ /* output the ";#" tag to indicate this is an alias output */
zwr_output->flush = TRUE;
zshow_output(zwr_output, &semi_star);
}
} else
{ /* MERGE assignment from local variable */
nsubs = lvzwrite_block->curr_subsc;
if (MARG1_IS_GBL(merge_args))
{ /* Target is a global var : i.e. MERGE ^gvn1=lcl1.
* In this case, mglvnp->gblp[IND1]->gvkey_nsubs would have been initialized in op_merge.c already.
* Use that to check if the target node in ^gvn1 exceeds max # of subscripts.
*/
if (MAX_GVSUBSCRIPTS <= (mglvnp->gblp[IND1]->gvkey_nsubs + nsubs))
rts_error_csa(CSA_ARG(NULL) VARLSTCNT(3) ERR_MERGEINCOMPL, 0, ERR_MAXNRSUBSCRIPTS);
memcpy(gv_currkey->base, mglvnp->gblp[IND1]->s_gv_currkey->base, mglvnp->gblp[IND1]->s_gv_currkey->end + 1);
gv_currkey->end = mglvnp->gblp[IND1]->s_gv_currkey->end;
for (n = 0; n < nsubs; n++)
{
subscp = ((zwr_sub_lst *)lvzwrite_block->sub)->subsc_list[n].actual;
MV_FORCE_STR(subscp);
mval2subsc(subscp, gv_currkey, gv_cur_region->std_null_coll);
if (!subscp->str.len && (ALWAYS != gv_cur_region->null_subs))
sgnl_gvnulsubsc();
}
MV_FORCE_STR(val);
gvnh_reg = TREF(gd_targ_gvnh_reg); /* set by op_gvname/op_gvextnam/op_gvnaked done before op_merge */
/* If gvnh_reg corresponds to a spanning global, then determine
* gv_cur_region/gv_target/gd_targ_* variables based on updated gv_currkey.
*/
GV_BIND_SUBSNAME_FROM_GVNH_REG_IF_GVSPAN(gvnh_reg, (TREF(gd_targ_addr)), gv_currkey);
/* For spanning globals, "gv_cur_region" points to the target region for ^gvn1 only now.
* So do the GVSUBOFLOW check (both for spanning and non-spanning globals) now.
*/
if (gv_currkey->end >= gv_cur_region->max_key_size)
ISSUE_GVSUBOFLOW_ERROR(gv_currkey, KEY_COMPLETE_TRUE);
op_gvput(val);
} else
{ /* Target is a local var : pre-process target in case it is a container */
assert(MARG1_IS_LCL(merge_args));
dst_lv = mglvnp->lclp[IND1];
if (!LV_IS_BASE_VAR(dst_lv))
{
LV_SBS_DEPTH(dst_lv, FALSE, sbs_depth);
if (MAX_LVSUBSCRIPTS < (sbs_depth + nsubs))
rts_error_csa(CSA_ARG(NULL) VARLSTCNT(3) ERR_MERGEINCOMPL, 0, ERR_MAXNRSUBSCRIPTS);
}
param_list.arg[0] = dst_lv; /* this is already protected from stp_gcol by op_merge so no need to
* push this into the stack for stp_gcol protection. */
for (n = 0 ; n < nsubs; n++)
{ /* Note: no need to do push these mvals on the stack before calling op_putindx
* as lvzwrite_block->sub is already protected by stp_gcol_src.h.
*/
param_list.arg[n+1] = ((zwr_sub_lst *)lvzwrite_block->sub)->subsc_list[n].actual;
}
param_list.n = n + 1;
dst_lv = (lv_val *)callg((callgfnptr)op_putindx, ¶m_list);
MV_FORCE_STR(val);
assert(!(MV_ALIASCONT & dst_lv->v.mvtype)); /* op_putindx would have already done DECR_AC_REF for us */
dst_lv->v = *val;
dst_lv->v.mvtype &= ~MV_ALIASCONT; /* Make sure alias container property does not pass */
}
}
}
void open_list_file(void)
{
char charspace;
uint4 status;
unsigned char list_name[MAX_MIDENT_LEN + STR_LIT_LEN(LISTEXT)], fname[255];
struct FAB fab;
struct NAM nam;
#ifdef __ALPHA
# pragma member_alignment save
# pragma nomember_alignment
#endif
static readonly struct{
unsigned char newversion;
unsigned char wrap;
unsigned char width;
int4 v_width;
unsigned char eol;
}open_params_list = {
(unsigned char)iop_newversion, (unsigned char)iop_wrap,
(unsigned char)iop_recordsize, (int4)132,
(unsigned char)iop_eol
};
#ifdef __ALPHA
# pragma member_alignment restore
#endif
mval params;
mval file;
struct dsc$descriptor_s print_time_d
= { SIZEOF(print_time_buf), DSC$K_DTYPE_T, DSC$K_CLASS_S, print_time_buf };
lst_param.list_line = 1;
lst_param.page = 0;
fab = cc$rms_fab;
nam = cc$rms_nam;
fab.fab$l_dna = &list_name[0];
assert(module_name.len <= MAX_MIDENT_LEN);
fab.fab$b_dns = module_name.len;
memcpy(&list_name[0], module_name.addr, fab.fab$b_dns);
MEMCPY_LIT(&list_name[fab.fab$b_dns], LISTEXT);
fab.fab$b_dns += STR_LIT_LEN(LISTEXT);
if (MV_DEFINED(&cmd_qlf.list_file))
{
fab.fab$b_fns = cmd_qlf.list_file.str.len;
fab.fab$l_fna = cmd_qlf.list_file.str.addr;
}
nam.nam$l_esa = &fname[0];
nam.nam$b_ess = SIZEOF(fname);
nam.nam$b_nop = (NAM$M_SYNCHK);
fab.fab$l_nam = &nam;
fab.fab$l_fop = FAB$M_NAM;
if ((status = sys$parse(&fab,0,0)) != RMS$_NORMAL)
{ rts_error(VARLSTCNT(1) status);
}
file.mvtype = params.mvtype = MV_STR;
file.str.len = nam.nam$b_esl;
file.str.addr = &fname[0];
params.str.len = SIZEOF(open_params_list);
params.str.addr = &open_params_list;
(*op_open_ptr)(&file, ¶ms, 30, 0);
params.str.len = 1;
charspace = (char) iop_eol;
params.str.addr = &charspace;
dev_in_use = io_curr_device;
op_use(&file,¶ms);
lib$date_time(&print_time_d);
list_head(0);
return;
}
/*
* ----------------------------------------------------------
* Fast path setpiece when delimiter is one (lit) char replacing
* a single piece (last is same as first). Unicode flavor.
*
* Arguments:
* src - source mval
* delim - delimiter char
* expr - expression string mval
* ind - index in source mval to be set
* dst - destination mval where the result is saved.
*
* Return:
* none
* ----------------------------------------------------------
*/
void op_setp1(mval *src, int delim, mval *expr, int ind, mval *dst)
{
size_t str_len, delim_cnt;
int len, pfx_str_len, sfx_start_offset, sfx_str_len, rep_str_len, pfx_scan_offset;
int dlmlen, cpy_cache_lines, mblen;
unsigned char *start_sfx, *str_addr, *end_pfx, *end_src, *start_pfx;
boolean_t do_scan, delim_last_scan, valid_char;
mval dummymval; /* It's value is not used but is part of the call to op_fnp1() */
fnpc *cfnpc, *pfnpc;
delimfmt ldelim;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
assert(gtm_utf8_mode);
do_scan = FALSE;
cpy_cache_lines = -1;
ldelim.unichar_val = delim;
if (!UTF8_VALID(ldelim.unibytes_val, (ldelim.unibytes_val + SIZEOF(ldelim.unibytes_val)), dlmlen)
&& !badchar_inhibit)
{ /* The delimiter is a bad character so error out if badchar not inhibited */
UTF8_BADCHAR(0, ldelim.unibytes_val, ldelim.unibytes_val + SIZEOF(ldelim.unibytes_val), 0, NULL);
}
MV_FORCE_STR(expr); /* Expression to put into piece place */
if (MV_DEFINED(src))
{
/* We have 3 possible scenarios:
* 1) The source string is null. Nothing to do but proceed to building output.
* 2) If the requested piece is larger than can be cached by op_fnp1, call fnp1
* for the maximum piece possible, use the cache info to "prime the pump" and
* then process the rest of the string ourselves.
* 3) If the requested piece can be obtained from the cache, call op_fnp1 to validate
* and rebuild the cache if necessary and then retrieve the necessary info from
* the fnpc cache.
*/
MV_FORCE_STR(src); /* Make sure is string prior to length check */
if (0 == src->str.len)
{ /* We have a null source string */
pfx_str_len = sfx_str_len = sfx_start_offset = 0;
delim_cnt = (0 < ind) ? (size_t)ind - 1 : 0;
} else if (FNPC_ELEM_MAX >= ind)
{ /* 3) Best of all possible cases. The op_fnp1 can do most of our work for us
* and we can preload the cache on the new string to help its subsequent
* uses along as well.
*/
SETWON;
op_fnp1(src, delim, ind, &dummymval);
SETWOFF;
cfnpc = &(TREF(fnpca)).fnpcs[src->fnpc_indx - 1];
assert(cfnpc->last_str.addr == src->str.addr);
assert(cfnpc->last_str.len == src->str.len);
assert(cfnpc->delim == delim);
assert(0 < cfnpc->npcs);
/* Three more scenarios: #1 piece all in cache, #2 piece would be in cache but ran
* out of text or #3 piece is beyond what can be cached
*/
if (cfnpc->npcs >= ind)
{ /* #1 The piece we want is totally within the cache which is good news */
pfx_str_len = cfnpc->pstart[ind - 1];
delim_cnt = 0;
sfx_start_offset = cfnpc->pstart[ind] - dlmlen; /* Include delimiter */
rep_str_len = cfnpc->pstart[ind] - cfnpc->pstart[ind - 1] - dlmlen; /* Replace string length */
sfx_str_len = src->str.len - pfx_str_len - rep_str_len;
cpy_cache_lines = ind - 1;
} else
{ /* #2 The string was too short so the cache does not contain our string. This means
* that the prefix becomes any text that IS in the cache and we set the delim_cnt
* to be the number of missing pieces so the delimiters can be put in as part of the
* prefix when we build the new string.
*/
pfx_str_len = cfnpc->pstart[cfnpc->npcs] - dlmlen;
delim_cnt = (size_t)(ind - cfnpc->npcs);
sfx_start_offset = 0;
sfx_str_len = 0;
cpy_cache_lines = cfnpc->npcs;
}
} else
{ /* 2) We have a element that would not be able to be in the fnpc cache. Go ahead
* and call op_fnp1 to get cache info up to the maximum and then we will continue
* the scan on our own.
*/
SETWON;
op_fnp1(src, delim, FNPC_ELEM_MAX, &dummymval);
SETWOFF;
cfnpc = &(TREF(fnpca)).fnpcs[src->fnpc_indx - 1];
assert(cfnpc->last_str.addr == src->str.addr);
assert(cfnpc->last_str.len == src->str.len);
assert(cfnpc->delim == delim);
assert(0 < cfnpc->npcs);
if (FNPC_ELEM_MAX > cfnpc->npcs)
{ /* We ran out of text so the scan is complete. This is basically the same
* as case #2 above.
*/
pfx_str_len = cfnpc->pstart[cfnpc->npcs] - dlmlen;
delim_cnt = (size_t)(ind - cfnpc->npcs);
sfx_start_offset = 0;
sfx_str_len = 0;
cpy_cache_lines = cfnpc->npcs;
} else
{ /* We have a case where the piece we want cannot be kept in cache. In the special
* case where there is no more text to handle, we don't need to scan further. Otherwise
* we prime the pump and continue the scan where the cache left off.
*/
if ((pfx_scan_offset = cfnpc->pstart[FNPC_ELEM_MAX]) < src->str.len) /* Note assignment */
/* Normal case where we prime the pump */
do_scan = TRUE;
else
{ /* Special case -- no more text to scan */
pfx_str_len = cfnpc->pstart[FNPC_ELEM_MAX] - dlmlen;
sfx_start_offset = 0;
sfx_str_len = 0;
}
delim_cnt = (size_t)ind - FNPC_ELEM_MAX;
cpy_cache_lines = FNPC_ELEM_MAX;
}
}
} else
{ /* Source is not defined -- treat as a null string */
pfx_str_len = sfx_str_len = sfx_start_offset = 0;
delim_cnt = (size_t)ind - 1;
}
/* If we have been forced to do our own scan, do that here. Note the variable pfx_scan_offset has been
* set to where the scan should begin in the src string and delim_cnt has been set to how many delimiters
* still need to be processed.
*/
if (do_scan)
{ /* Scan the line isolating prefix piece, and end of the
* piece being replaced
*/
COUNT_EVENT(small);
end_pfx = start_sfx = (unsigned char *)src->str.addr + pfx_scan_offset;
end_src = (unsigned char *)src->str.addr + src->str.len;
/* The compiler would unroll this loop this way anyway but we want to
* adjust the start_sfx pointer after the loop but only if we have gone
* into it at least once.
*/
if ((0 < delim_cnt) && (start_sfx < end_src))
{
do
{
end_pfx = start_sfx;
delim_last_scan = FALSE; /* Whether delimiter is last character scanned */
while (start_sfx < end_src)
{
valid_char = UTF8_VALID(start_sfx, end_src, mblen); /* Length of next char */
if (!valid_char)
{ /* Next character is not valid unicode. If badchar error is not inhibited,
* signal it now. If it is inhibited, just treat the character as a single
* character and continue.
*/
if (!badchar_inhibit)
utf8_badchar(0, start_sfx, end_src, 0, NULL);
assert(1 == mblen);
}
/* Getting mblen first allows us to do quick length compare before the
* heavier weight memcmp call.
*/
assert(0 < mblen);
if (mblen == dlmlen && 0 == memcmp(start_sfx, ldelim.unibytes_val, dlmlen))
{
delim_last_scan = TRUE;
break;
}
/* Increment ptrs by size of found char */
start_sfx += mblen;
}
start_sfx += dlmlen;
delim_cnt--;
} while ((0 < delim_cnt) && (start_sfx < end_src));
/* We have to backup up the suffix start pointer except under the condition
* that the last character in the buffer is the last delimiter we were looking
* for.
*/
if ((0 == delim_cnt) || (start_sfx < end_src) || !delim_last_scan)
start_sfx -= dlmlen; /* Back up suffix to include delimiter char */
/* If we scanned to the end (no text left) and still have delimiters to
* find, the entire src text should be part of the prefix
*/
if ((start_sfx >= end_src) && (0 < delim_cnt))
{
end_pfx = start_sfx;
if (delim_last_scan) /* if last char was delim, reduce delim cnt */
--delim_cnt;
}
} else
{
/* If not doing any token finding, then this count becomes the number
* of tokens to output. Adjust accordingly.
*/
if (0 < delim_cnt)
--delim_cnt;
}
INCR_COUNT(small_pcs, (int)((size_t)ind - delim_cnt));
/* Now having the following situation:
* end_pfx -> end of the prefix piece including delimiter
* start_sfx -> start of suffix piece (with delimiter) or = end_pfx/src->str.addr if none
*/
pfx_str_len = (int)(end_pfx - (unsigned char *)src->str.addr);
if (0 > pfx_str_len)
pfx_str_len = 0;
sfx_start_offset = (int)(start_sfx - (unsigned char *)src->str.addr);
sfx_str_len = src->str.len - sfx_start_offset;
if (0 > sfx_str_len)
sfx_str_len = 0;
}
/* Calculate total string len. delim_cnt has needed padding delimiters for null fields */
str_len = (size_t)expr->str.len + (size_t)pfx_str_len + (delim_cnt * (size_t)dlmlen) + (size_t)sfx_str_len;
if (MAX_STRLEN < str_len)
rts_error_csa(CSA_ARG(NULL) VARLSTCNT(1) ERR_MAXSTRLEN);
ENSURE_STP_FREE_SPACE((int)str_len);
str_addr = stringpool.free;
start_pfx = (unsigned char *)src->str.addr;
/* copy prefix */
if (0 < pfx_str_len)
{
memcpy(str_addr, src->str.addr, pfx_str_len);
str_addr += pfx_str_len;
}
/* copy delimiters */
while (0 < delim_cnt--)
{
memcpy(str_addr, ldelim.unibytes_val, dlmlen);
str_addr += dlmlen;
}
/* copy expression */
if (0 < expr->str.len)
{
memcpy(str_addr, expr->str.addr, expr->str.len);
str_addr += expr->str.len;
}
/* copy suffix */
if (0 < sfx_str_len)
{
memcpy(str_addr, start_pfx + sfx_start_offset, sfx_str_len);
str_addr += sfx_str_len;
}
assert(IS_AT_END_OF_STRINGPOOL(str_addr, -str_len));
dst->mvtype = MV_STR;
dst->str.len = INTCAST(str_addr - stringpool.free);
dst->str.addr = (char *)stringpool.free;
stringpool.free = str_addr;
/* If available, update the cache information for this newly created mval to hopefully
* give it a head start on its next usage. Note that we can only copy over the cache info
* for the prefix. We cannot include information for the 'expression' except where it starts
* because the expression could itself contain delimiters that would be found on a rescan.
*/
if (0 < cpy_cache_lines)
{
pfnpc = cfnpc; /* pointer for src mval's cache */
do
{
cfnpc = (TREF(fnpca)).fnpcsteal; /* Next cache element to steal */
if ((TREF(fnpca)).fnpcmax < cfnpc)
cfnpc = &(TREF(fnpca)).fnpcs[0];
(TREF(fnpca)).fnpcsteal = cfnpc + 1; /* -> next element to steal */
} while (cfnpc == pfnpc); /* Make sure we don't step on ourselves */
cfnpc->last_str = dst->str; /* Save validation info */
cfnpc->delim = delim;
cfnpc->npcs = cpy_cache_lines;
dst->fnpc_indx = cfnpc->indx + 1; /* Save where we are putting this element
* (1 based index in mval so 0 isn't so common)
*/
memcpy(&cfnpc->pstart[0], &pfnpc->pstart[0], (cfnpc->npcs + 1) * SIZEOF(unsigned int));
} else
unsigned char *n2s(mval *mv_ptr)
{
unsigned char *start, *cp, *cp1;
int4 exp, n0, m1, m0, tmp;
unsigned char lcl_buf[MAX_DIGITS_IN_INT];
if (!MV_DEFINED(mv_ptr))
{
underr(mv_ptr);
return NULL;
}
start = stringpool.free;
if (start + MAX_NUM_SIZE > stringpool.top)
{
stp_gcol(MAX_NUM_SIZE);
start = stringpool.free;
}
cp = start;
m1 = mv_ptr->m[1];
if (m1 == 0) /* SHOULD THIS BE UNDER THE MV_INT TEST? */
*cp++ = '0';
else if (mv_ptr->mvtype & MV_INT)
{
if (m1 < 0)
{
*cp++ = '-';
m1 = -m1;
}
cp1 = lcl_buf + sizeof(lcl_buf);
/* m0 is the integer part */
m0 = m1 / MV_BIAS;
/* m1 will become the fractional part */
m1 = m1 - (m0 * MV_BIAS);
if (m1 > 0)
{
for (n0 = 0; n0 < MV_BIAS_PWR; n0++)
{
tmp = m1;
m1 /= 10;
tmp -= (m1 * 10);
if (tmp)
break;
}
*--cp1 = tmp + '0';
for (n0++; n0 < MV_BIAS_PWR; n0++)
{
tmp = m1;
m1 /= 10;
*--cp1 = tmp - (m1 * 10) + '0';
}
*--cp1 = '.';
}
while (m0 > 0)
{
tmp = m0;
m0 /= 10;
*--cp1 = tmp - (m0 * 10) + '0';
}
n0 = &lcl_buf[sizeof(lcl_buf)] - cp1;
memcpy(cp, cp1, n0);
cp += n0;
} else
{
exp = (int4)mv_ptr->e - MV_XBIAS;
if (mv_ptr->sgn)
*cp++ = '-';
m0 = mv_ptr->m[0];
if (exp < 0)
{
*cp++ = '.';
for (n0 = exp; n0 < 0; n0++)
*cp++ = '0';
}
for (; m1; m1 = m0, m0 = 0)
{
for (n0 = 0; n0 < PACKED_DIGITS; n0++)
{
if (exp-- == 0)
{
if (m0 == 0 && m1 == 0)
break;
*cp++ = '.';
} else if (exp < 0 && m0 == 0 && m1 == 0)
break;
tmp = m1 / MANT_LO;
m1 = (m1 - tmp * MANT_LO) * 10;
*cp++ = tmp + '0';
}
}
while (exp-- > 0)
*cp++ = '0';
}
mv_ptr->mvtype |= MV_STR;
mv_ptr->mvtype &= ~MV_NUM_APPROX;
mv_ptr->str.addr = (char *)start;
mv_ptr->str.len = cp - start;
stringpool.free = cp;
return cp;
}
/*
* ----------------------------------------------------------
* Set version of $extract
*
* Arguments:
* src - source mval
* expr - expression string mval to be inserted into source
* schar - starting character index to be replaced
* echar - ending character index to be replaced
* dst - destination mval where the result is saved.
*
* Return:
* none
* ----------------------------------------------------------
*/
void op_setextract(mval *src, mval *expr, int schar, int echar, mval *dst)
{
int srclen, padlen, pfxlen, sfxoff, sfxlen, dstlen, bytelen, skip, char_len;
unsigned char *srcptr, *srcbase, *srctop, *straddr;
error_def(ERR_MAXSTRLEN);
padlen = pfxlen = sfxlen = 0;
MV_FORCE_STR(expr); /* Expression to put into piece place */
if (MV_DEFINED(src))
{
MV_FORCE_STR(src); /* Make sure is string prior to length check */
srclen = src->str.len;
} else /* Source is not defined -- treat as a null string */
srclen = 0;
schar = MAX(schar, 1); /* schar starts at 1 at a minimum */
/* There are four cases in the spec:
1) schar > echar or echar < 1 -- glvn and naked indicator are not changed. This is
handled by generated code in m_set
2) echar >= schar-1 > $L(src) -- dst = src_$J("",schar-1-$L(src))_expr
3) schar-1 <= $L(src) < echar -- dst = $E(src,1,schar-1)_expr
4) All others -- dst = $E(src,1,schar-1)_expr_$E(src,echar+1,$L(src))
*/
srcbase = (unsigned char *)src->str.addr;
srctop = srcbase + srclen;
for (srcptr = srcbase, skip = schar - 1; (skip > 0 && srcptr < srctop); --skip)
{ /* skip the first schar - 1 characters */
if (!UTF8_VALID(srcptr, srctop, bytelen) && !badchar_inhibit)
utf8_badchar(0, srcptr, srctop, 0, NULL);
srcptr += bytelen;
}
pfxlen = (int)(srcptr - srcbase);
if (skip > 0)
{ /* Case #2: schar is past the string length. echar test handled in generated code.
Should be padded with as many spaces as characters remained to be skipped */
padlen = skip;
}
for (skip = echar - schar + 1; (skip > 0 && srcptr < srctop); --skip)
{ /* skip up to the character position echar */
if (!UTF8_VALID(srcptr, srctop, bytelen) && !badchar_inhibit)
utf8_badchar(0, srcptr, srctop, 0, NULL);
srcptr += bytelen;
}
char_len = 0;
if (skip <= 0)
{ /* Case #4: echar is within the string length, suffix to be added */
sfxoff = (int)(srcptr - srcbase);
sfxlen = (int)(srctop - srcptr);
if (!badchar_inhibit && sfxlen > 0)
{ /* validate the suffix, and we can compute char_len as well */
for (; (srcptr < srctop); ++char_len)
{
if (!UTF8_VALID(srcptr, srctop, bytelen))
utf8_badchar(0, srcptr, srctop, 0, NULL);
srcptr += bytelen;
}
MV_FORCE_LEN(expr);
char_len += schar - 1 + expr->str.char_len;
}
}
/* Calculate total string len */
dstlen = pfxlen + padlen + expr->str.len + sfxlen;
if (dstlen > MAX_STRLEN)
rts_error(VARLSTCNT(1) ERR_MAXSTRLEN);
ENSURE_STP_FREE_SPACE(dstlen);
srcbase = (unsigned char *)src->str.addr;
straddr = stringpool.free;
if (0 < pfxlen)
{ /* copy prefix */
memcpy(straddr, srcbase, pfxlen);
straddr += pfxlen;
}
if (0 < padlen)
{ /* insert padding */
memset(straddr, ' ', padlen);
straddr += padlen;
}
if (0 < expr->str.len)
{ /* copy expression */
memcpy(straddr, expr->str.addr, expr->str.len);
straddr += expr->str.len;
}
if (0 < sfxlen)
{ /* copy suffix */
memcpy(straddr, srcbase + sfxoff, sfxlen);
straddr += sfxlen;
}
assert(straddr - stringpool.free == dstlen);
MV_INIT_STRING(dst, straddr - stringpool.free, (char *)stringpool.free);
if (0 < char_len)
{
dst->mvtype |= MV_UTF_LEN;
dst->str.char_len = char_len;
}
stringpool.free = straddr;
}