*/ REBVAL *Find_Error_Info(ERROR_OBJ *error, REBINT *num)
/*
** Return the error message needed to print an error.
** Must scan the error catalog and its error lists.
** Note that the error type and id words no longer need
** to be bound to the error catalog context.
** If the message is not found, return null.
**
***********************************************************************/
{
REBSER *frame;
REBVAL *obj1;
REBVAL *obj2;
if (!IS_WORD(&error->type) || !IS_WORD(&error->id)) return 0;
// Find the correct error type object in the catalog:
frame = VAL_OBJ_FRAME(Get_System(SYS_CATALOG, CAT_ERRORS));
obj1 = Find_Word_Value(frame, VAL_WORD_SYM(&error->type));
if (!obj1) return 0;
// Now find the correct error message for that type:
frame = VAL_OBJ_FRAME(obj1);
obj2 = Find_Word_Value(frame, VAL_WORD_SYM(&error->id));
if (!obj2) return 0;
if (num) {
obj1 = Find_Word_Value(frame, SYM_CODE);
*num = VAL_INT32(obj1)
+ Find_Word_Index(frame, VAL_WORD_SYM(&error->id), FALSE)
- Find_Word_Index(frame, SYM_TYPE, FALSE) - 1;
}
return obj2;
}
*/ REBVAL *Find_In_Contexts(REBCNT sym, REBVAL *where)
/*
** Search a block of objects for a given word symbol and
** return the value for the word. NULL if not found.
**
***********************************************************************/
{
REBVAL *val;
for (; NOT_END(where); where++) {
if (IS_WORD(where)) {
val = Get_Var(where);
}
else if (IS_PATH(where)) {
Do_Path(&where, 0);
val = DS_TOP; // only safe for short time!
}
else
val = where;
if (IS_OBJECT(val)) {
val = Find_Word_Value(VAL_OBJ_FRAME(val), sym);
if (val) return val;
}
}
return 0;
}
STOID Form_Block_Series(REBSER *blk, REBCNT index, REB_MOLD *mold, REBSER *frame)
{
// Form a series (part_mold means mold non-string values):
REBINT n;
REBINT len = SERIES_TAIL(blk) - index;
REBVAL *val;
REBVAL *wval;
if (len < 0) len = 0;
for (n = 0; n < len;) {
val = BLK_SKIP(blk, index+n);
wval = 0;
if (frame && (IS_WORD(val) || IS_GET_WORD(val))) {
wval = Find_Word_Value(frame, VAL_WORD_SYM(val));
if (wval) val = wval;
}
Mold_Value(mold, val, wval != 0);
n++;
if (GET_MOPT(mold, MOPT_LINES)) {
Append_Byte(mold->series, LF);
}
else {
// Add a space if needed:
if (n < len && mold->series->tail
&& *UNI_LAST(mold->series) != LF
&& !GET_MOPT(mold, MOPT_TIGHT)
)
Append_Byte(mold->series, ' ');
}
}
}
x*/ REBRXT Do_Callback(REBSER *obj, u32 name, RXIARG *rxis, RXIARG *result)
/*
** Given an object and a word id, call a REBOL function.
** The arguments are converted from extension format directly
** to the data stack. The result is passed back in ext format,
** with the datatype returned or zero if there was a problem.
**
***********************************************************************/
{
REBVAL *val;
struct Reb_Call *call;
REBCNT len;
REBCNT n;
REBVAL label;
REBVAL out;
// Find word in object, verify it is a function.
if (!(val = Find_Word_Value(obj, name))) {
SET_EXT_ERROR(result, RXE_NO_WORD);
return 0;
}
if (!ANY_FUNC(val)) {
SET_EXT_ERROR(result, RXE_NOT_FUNC);
return 0;
}
// Create stack frame (use prior stack frame for location info):
SET_TRASH_SAFE(&out); // OUT slot for function eval result
Val_Init_Word_Unbound(&label, REB_WORD, name);
call = Make_Call(
&out,
VAL_SERIES(DSF_WHERE(PRIOR_DSF(DSF))),
VAL_INDEX(DSF_WHERE(PRIOR_DSF(DSF))),
&label,
val
);
obj = VAL_FUNC_PARAMLIST(val); // func words
len = SERIES_TAIL(obj)-1; // number of args (may include locals)
// Push args. Too short or too long arg frames are handled W/O error.
// Note that refinements args can be set to anything.
for (n = 1; n <= len; n++) {
REBVAL *arg = DSF_ARG(call, n);
if (n <= RXI_COUNT(rxis))
RXI_To_Value(arg, rxis[n], RXI_TYPE(rxis, n));
else
SET_NONE(arg);
// Check type for word at the given offset:
if (!TYPE_CHECK(BLK_SKIP(obj, n), VAL_TYPE(arg))) {
result->i2.int32b = n;
SET_EXT_ERROR(result, RXE_BAD_ARGS);
Free_Call(call);
return 0;
}
}
// Evaluate the function:
if (Dispatch_Call_Throws(call)) {
// !!! Does this need handling such that there is a way for the thrown
// value to "bubble up" out of the callback, or is an error sufficient?
fail (Error_No_Catch_For_Throw(DSF_OUT(call)));
}
// Return resulting value from output
*result = Value_To_RXI(&out);
return Reb_To_RXT[VAL_TYPE(&out)];
}
x*/ int Do_Callback(REBSER *obj, u32 name, RXIARG *args, RXIARG *result)
/*
** Given an object and a word id, call a REBOL function.
** The arguments are converted from extension format directly
** to the data stack. The result is passed back in ext format,
** with the datatype returned or zero if there was a problem.
**
***********************************************************************/
{
REBVAL *val;
REBCNT dsf;
REBCNT len;
REBCNT n;
REBCNT dsp = DSP; // to restore stack on errors
// Find word in object, verify it is a function.
if (!(val = Find_Word_Value(obj, name))) {
SET_EXT_ERROR(result, RXE_NO_WORD);
return 0;
}
if (!ANY_FUNC(val)) {
SET_EXT_ERROR(result, RXE_NOT_FUNC);
return 0;
}
// Get block and index from prior function stack frame:
dsf = PRIOR_DSF(DSF);
// Create stack frame (use prior stack frame for location info):
dsf = Push_Func(0, VAL_SERIES(DSF_BACK(dsf)), VAL_INDEX(DSF_BACK(dsf)), name, val);
val = DSF_FUNC(dsf); // for safety from GC
obj = VAL_FUNC_WORDS(val); // func words
len = SERIES_TAIL(obj)-1; // number of args (may include locals)
// Push args. Too short or too long arg frames are handled W/O error.
// Note that refinements args can be set to anything.
for (n = 1; n <= len && n <= RXI_COUNT(args); n++) {
DS_SKIP;
RXI_To_Value(DS_TOP, args[n], RXI_TYPE(args, n));
// Check type for word at the given offset:
if (!TYPE_CHECK(BLK_SKIP(obj, n), VAL_TYPE(DS_TOP))) {
result->int32b = n;
SET_EXT_ERROR(result, RXE_BAD_ARGS);
DSP = dsp;
return 0;
}
}
// Fill with NONE if necessary:
for (; n <= len; n++) {
DS_SKIP;
SET_NONE(DS_TOP);
if (!TYPE_CHECK(BLK_SKIP(obj, n), VAL_TYPE(DS_TOP))) {
result->int32b = n;
SET_EXT_ERROR(result, RXE_BAD_ARGS);
DSP = dsp;
return 0;
}
}
// Evaluate the function:
DSF = dsf;
Func_Dispatch[VAL_TYPE(val) - REB_NATIVE](val);
DSF = PRIOR_DSF(dsf);
DSP = dsf-1;
// Return resulting value from TOS1 (volatile location):
*result = Value_To_RXI(DS_VALUE(dsf));
return Reb_To_RXT[VAL_TYPE(DS_VALUE(dsf))];
}
*/ REBYTE *Security_Policy(REBCNT sym, REBVAL *name)
/*
** Given a security symbol (like FILE) and a value (like the file
** path) returns the security policy (RWX) allowed for it.
**
** Args:
**
** sym: word that represents the type ['file 'net]
** name: file or path value
**
** Returns BTYE array of flags for the policy class:
**
** flags: [rrrr wwww xxxx ----]
**
** Where each byte is:
** 0: SEC_ALLOW
** 1: SEC_ASK
** 2: SEC_THROW
** 3: SEC_QUIT
**
** The secuity is defined by the system/state/policies object, that
** is of the form:
**
** [
** file: [%file1 tuple-flags %file2 ... default tuple-flags]
** net: [...]
** call: tuple-flags
** stack: tuple-flags
** eval: integer (limit)
** ]
**
***********************************************************************/
{
REBVAL *policy = Get_System(SYS_STATE, STATE_POLICIES);
REBYTE *flags;
REBCNT len;
REBCNT errcode = RE_SECURITY_ERROR;
if (!IS_OBJECT(policy)) goto error;
// Find the security class in the block: (file net call...)
policy = Find_Word_Value(VAL_OBJ_FRAME(policy), sym);
if (!policy) goto error;
// Obtain the policies for it:
// Check for a master tuple: [file rrrr.wwww.xxxx]
if (IS_TUPLE(policy)) return VAL_TUPLE(policy); // non-aligned
// removed A90: if (IS_INTEGER(policy)) return (REBYTE*)VAL_INT64(policy); // probably not used
// Only other form is detailed block:
if (!IS_BLOCK(policy)) goto error;
// Scan block of policies for the class: [file [allow read quit write]]
len = 0; // file or url length
flags = 0; // policy flags
for (policy = VAL_BLK(policy); NOT_END(policy); policy += 2) {
// Must be a policy tuple:
if (!IS_TUPLE(policy+1)) goto error;
// Is it a policy word:
if (IS_WORD(policy)) { // any word works here
// If no strings found, use the default:
if (len == 0) flags = VAL_TUPLE(policy+1); // non-aligned
}
// Is it a string (file or URL):
else if (ANY_BINSTR(policy) && name) {
//Debug_Fmt("sec: %r %r", policy, name);
if (Match_Sub_Path(VAL_SERIES(policy), VAL_SERIES(name))) {
// Is the match adequate?
if (VAL_TAIL(name) >= len) {
len = VAL_TAIL(name);
flags = VAL_TUPLE(policy+1); // non-aligned
}
}
}
else goto error;
}
if (!flags) {
errcode = RE_SECURITY;
policy = name ? name : 0;
error:
if (!policy) {
Init_Word(DS_TOP, sym);
policy = DS_TOP;
}
Trap1(errcode, policy);
}
return flags;
}