*/ REBSER *Form_Reduce(REBSER *block, REBCNT index)
/*
** Reduce a block and then form each value into a string. Return the
** string or NULL if an unwind triggered while reducing.
**
***********************************************************************/
{
REBINT start = DSP + 1;
REBINT n;
REB_MOLD mo;
while (index < BLK_LEN(block)) {
index = Do_Next(block, index, 0);
if (THROWN(DS_TOP)) {
*DS_VALUE(start) = *DS_TOP;
DSP = start;
return NULL;
}
}
CLEARS(&mo);
Reset_Mold(&mo);
for (n = start; n <= DSP; n++)
Mold_Value(&mo, &DS_Base[n], 0);
DSP = start;
return Copy_String(mo.series, 0, -1);
}
*/ DEVICE_CMD Accept_Socket(REBREQ *sock)
/*
** Accept an inbound connection on a TCP listen socket.
**
** The function will return:
** =0: succeeded
** >0: in-progress, still trying
** <0: error occurred, no longer trying
**
** Before usage:
** Open_Socket();
** Set local_port to desired port number.
** Listen_Socket();
**
***********************************************************************/
{
SOCKAI sa;
REBREQ *news;
int len = sizeof(sa);
int result;
extern void Attach_Request(REBREQ **prior, REBREQ *req);
// Accept a new socket, if there is one:
result = accept(sock->socket, (struct sockaddr *)&sa, &len);
if (result == BAD_SOCKET) {
result = GET_ERROR;
if (result == NE_WOULDBLOCK) return DR_PEND;
sock->error = result;
//Signal_Device(sock, EVT_ERROR);
return DR_ERROR;
}
// To report the new socket, the code here creates a temporary
// request and copies the listen request to it. Then, it stores
// the new values for IP and ports and links this request to the
// original via the sock->data.
news = MAKE_NEW(*news); // Be sure to deallocate it
CLEARS(news);
// *news = *sock;
news->device = sock->device;
SET_OPEN(news);
SET_FLAG(news->state, RSM_OPEN);
SET_FLAG(news->state, RSM_CONNECT);
news->socket = result;
news->net.remote_ip = sa.sin_addr.s_addr; //htonl(ip); NOTE: REBOL stays in network byte order
news->net.remote_port = ntohs(sa.sin_port);
Get_Local_IP(news);
//Nonblocking_Mode(news->socket); ???Needed?
Attach_Request((REBREQ**)&sock->data, news);
Signal_Device(sock, EVT_ACCEPT);
// Even though we signalled, we keep the listen pending to
// accept additional connections.
return DR_PEND;
}
*/ static void Write_File_Port(REBREQ *file, REBVAL *data, REBCNT len, REBCNT args)
/*
***********************************************************************/
{
REBSER *ser;
if (IS_BLOCK(data)) {
// Form the values of the block
// !! Could be made more efficient if we broke the FORM
// into 32K chunks for writing.
REB_MOLD mo;
CLEARS(&mo);
Reset_Mold(&mo);
if (args & AM_WRITE_LINES) {
mo.opts = 1 << MOPT_LINES;
}
Mold_Value(&mo, data, 0);
Set_String(data, mo.series); // fall into next section
len = SERIES_TAIL(mo.series);
}
// Auto convert string to UTF-8
if (IS_STRING(data)) {
ser = Encode_UTF8_Value(data, len, ENCF_OS_CRLF);
file->common.data = ser? BIN_HEAD(ser) : VAL_BIN_DATA(data); // No encoding may be needed
len = SERIES_TAIL(ser);
}
else {
file->common.data = VAL_BIN_DATA(data);
}
file->length = len;
OS_DO_DEVICE(file, RDC_WRITE);
}
*/ void Init_Obj_Value(REBVAL *value, REBSER *frame)
/*
***********************************************************************/
{
assert(frame);
CLEARS(value);
Val_Init_Object(value, frame);
}
*/ void Init_Obj_Value(REBVAL *value, REBSER *frame)
/*
***********************************************************************/
{
ASSERT(frame, RP_BAD_SET_CONTEXT);
CLEARS(value);
SET_OBJECT(value, frame);
}
*/ REBINT Do_Dialect(REBSER *dialect, REBSER *block, REBCNT *index, REBSER **out)
/*
** Format for dialect is:
** CMD arg1 arg2 arg3 CMD arg1 arg2 ...
**
** Returns:
** cmd value or error as result (or zero for end)
** index is updated
** if *out is zero, then we create a new output block
**
** The arg sequence is terminated by:
** 1. Maximum # of args for command
** 2. An arg that is not of a specified datatype for CMD
** 3. Encountering a new CMD
** 4. End of the dialect block
**
***********************************************************************/
{
REBDIA dia;
REBINT n;
REBINT dsp = DSP; // Save stack position
CLEARS(&dia);
if (*index >= SERIES_TAIL(block)) return 0; // end of block
DISABLE_GC; // Avoid GC during Dialect (prevents unknown crash problem)
if (!*out) *out = Make_Block(25);
dia.dialect = dialect;
dia.args = block;
dia.argi = *index;
dia.out = *out;
SET_FLAG(dia.flags, RDIA_NO_CMD);
//Print("DSP: %d Dinp: %r - %m", DSP, BLK_SKIP(block, *index), block);
n = Do_Dia(&dia);
//Print("DSP: %d Dout: CMD: %d %m", DSP, dia.cmd, *out);
DSP = dsp; // pop any temp values used above
if (Delect_Debug > 0) {
Total_Missed += dia.missed;
// !!!! debug
if (dia.missed) Debug_Fmt(Dia_Fmt, Get_Field_Name(dia.dialect, dia.cmd), dia.out->tail, dia.missed, Total_Missed);
}
if (n < 0) return n; //error
*index = dia.argi;
ENABLE_GC;
return dia.cmd;
}
*/ REBCNT Week_Day(REBDAT date)
/*
** Return the day of the week for a specific date.
**
***********************************************************************/
{
REBDAT year1;
CLEARS(&year1);
year1.date.day = 1;
year1.date.month = 1;
return ((Diff_Date(date, year1) + 5) % 7) + 1;
}
*/ REBSER *Form_Tight_Block(REBVAL *blk)
/*
***********************************************************************/
{
REBVAL *val;
REB_MOLD mo;
CLEARS(&mo);
Reset_Mold(&mo);
for (val = VAL_BLK_DATA(blk); NOT_END(val); val++)
Mold_Value(&mo, val, 0);
return Copy_String(mo.series, 0, -1);
}
*/ REBSER *Copy_Mold_Value(const REBVAL *value, REBCNT opts)
/*
** Form a value based on the mold opts provided.
**
***********************************************************************/
{
REB_MOLD mo;
CLEARS(&mo);
mo.opts = opts;
Reset_Mold(&mo);
Mold_Value(&mo, value, TRUE);
return Copy_String(mo.series, 0, -1);
}
//
// Entab_Unicode: C
//
// Entab a string and return a new series.
//
REBSER *Entab_Unicode(REBUNI *bp, REBCNT index, REBCNT len, REBINT tabsize)
{
REBINT n = 0;
REBUNI *dp;
REBUNI c;
REB_MOLD mo;
CLEARS(&mo);
mo.opts = MOPT_RESERVE;
mo.reserve = len;
Push_Mold(&mo);
dp = UNI_AT(mo.series, mo.start);
for (; index < len; index++) {
c = bp[index];
// Count leading spaces, insert TAB for each tabsize:
if (c == ' ') {
if (++n >= tabsize) {
*dp++ = '\t';
n = 0;
}
continue;
}
// Hitting a leading TAB resets space counter:
if (c == '\t') {
*dp++ = (REBYTE)c;
n = 0;
}
else {
// Incomplete tab space, pad with spaces:
for (; n > 0; n--) *dp++ = ' ';
// Copy chars thru end-of-line (or end of buffer):
while (index < len) {
if ((*dp++ = bp[index++]) == '\n') break;
}
}
}
SET_SERIES_LEN(mo.series, mo.start + cast(REBCNT, dp - UNI_AT(mo.series, mo.start)));
UNI_TERM(mo.series);
return Pop_Molded_String(&mo);
}
*/ void Signal_Device(REBREQ *req, REBINT type)
/*
** Generate a device event to awake a port on REBOL.
**
***********************************************************************/
{
REBEVT evt;
CLEARS(&evt);
evt.type = (REBYTE)type;
evt.model = EVM_DEVICE;
evt.req = req;
if (type == EVT_ERROR) evt.data = req->error;
RL_Event(&evt); // (returns 0 if queue is full, ignored)
}
*/ static int Read_Dir(REBREQ *dir, REBSER *files)
/*
** Provide option to get file info too.
** Provide option to prepend dir path.
** Provide option to use wildcards.
**
***********************************************************************/
{
REBINT result;
REBCNT len;
REBSER *fname;
REBSER *name;
REBREQ file;
RESET_TAIL(files);
CLEARS(&file);
// Temporary filename storage:
fname = BUF_OS_STR;
file.special.file.path = cast(REBCHR*, Reset_Buffer(fname, MAX_FILE_NAME));
SET_FLAG(dir->modes, RFM_DIR);
dir->common.data = cast(REBYTE*, &file);
while ((result = OS_DO_DEVICE(dir, RDC_READ)) == 0 && !GET_FLAG(dir->flags, RRF_DONE)) {
len = OS_STRLEN(file.special.file.path);
if (GET_FLAG(file.modes, RFM_DIR)) len++;
name = Copy_OS_Str(file.special.file.path, len);
if (GET_FLAG(file.modes, RFM_DIR))
SET_ANY_CHAR(name, name->tail-1, '/');
Val_Init_File(Alloc_Tail_Array(files), name);
}
if (result < 0 && dir->error != -RFE_OPEN_FAIL
&& (
OS_STRCHR(dir->special.file.path, '*')
|| OS_STRCHR(dir->special.file.path, '?')
)
) {
result = 0; // no matches found, but not an error
}
return result;
}
*/ REBINT OS_Wait(REBCNT millisec, REBCNT res)
/*
** Check if devices need attention, and if not, then wait.
** The wait can be interrupted by a GUI event, otherwise
** the timeout will wake it.
**
** Res specifies resolution. (No wait if less than this.)
**
** Returns:
** -1: Devices have changed state.
** 0: past given millsecs
** 1: wait in timer
**
** The time it takes for the devices to be scanned is
** subtracted from the timer value.
**
***********************************************************************/
{
REBREQ req; // OK: QUERY below does not store it
REBCNT delta;
i64 base;
// printf("OS_Wait %d\n", millisec);
base = OS_Delta_Time(0, 0); // start timing
// Setup for timing:
CLEARS(&req);
req.device = RDI_EVENT;
// Let any pending device I/O have a chance to run:
if (OS_Poll_Devices()) return -1;
// Nothing, so wait for period of time
delta = (REBCNT)OS_Delta_Time(base, 0)/1000 + res;
if (delta >= millisec) return 0;
millisec -= delta; // account for time lost above
req.length = millisec;
// printf("Wait: %d ms\n", millisec);
OS_Do_Device(&req, RDC_QUERY); // wait for timer or other event
return 1; // layer above should check delta again
}
static bool check_allocs(void)
{
DCHECK;
bool ret = false;
struct __a *p = NULL;
int const n = 4;
TALLOCS(p, n, goto error);
ASSERT(p != NULL, goto error);
int i,j;
for(i = 0; i < n; ++i) {
for(j = 0; j < 100; ++j) {
p[i].dummy[j] = -1;
}
}
CLEARS(p, n);
DUMPZ(sizeof(*p) * n);
for(i = 0; i < n; ++i) {
for(j = 0; j < 100; ++j) {
MASSERT(p[i].dummy[j] == 0, goto error,
"(%d,%d) = %d\n", i, j, p[i].dummy[j]);
}
}
REALLOC(p,1, goto error);
REALLOC(p,2, goto error);
ret = true;
error:
FREE(p);
ASSERT(p == NULL, return false);
return ret;
}
//
// Detab_Unicode: C
//
// Detab a unicode string and return a new series.
//
REBSER *Detab_Unicode(REBUNI *bp, REBCNT index, REBCNT len, REBINT tabsize)
{
REBCNT cnt = 0;
REBCNT n;
REBUNI *dp;
REBUNI c;
REB_MOLD mo;
CLEARS(&mo);
// Estimate new length based on tab expansion:
for (n = index; n < len; n++)
if (bp[n] == TAB) cnt++;
mo.opts = MOPT_RESERVE;
mo.reserve = len + (cnt * (tabsize - 1));
Push_Mold(&mo);
dp = UNI_AT(mo.series, mo.start);
n = 0;
while (index < len) {
c = bp[index++];
if (c == '\t') {
*dp++ = ' ';
n++;
for (; n % tabsize != 0; n++) *dp++ = ' ';
continue;
}
if (c == '\n') n = 0;
else n++;
*dp++ = c;
}
SET_SERIES_LEN(mo.series, mo.start + cast(REBCNT, dp - UNI_AT(mo.series, mo.start)));
UNI_TERM(mo.series);
return Pop_Molded_String(&mo);
}
*/ REBREQ *OS_Make_Devreq(int device)
/*
***********************************************************************/
{
REBDEV *dev;
REBREQ *req;
int size;
// Validate device:
if (device >= RDI_MAX || !(dev = Devices[device]))
return 0;
size = dev->req_size ? dev->req_size : sizeof(REBREQ);
req = OS_Make(size);
CLEARS(req);
SET_FLAG(req->flags, RRF_ALLOC);
req->clen = size;
req->device = device;
return req;
}
*/ RL_API int RL_Set_Field(REBSER *obj, u32 word, RXIARG val, int type)
/*
** Set a field (context variable) of an object.
**
** Returns:
** The type arg, or zero if word not found in object or if field is protected.
** Arguments:
** obj - object pointer (e.g. from RXA_OBJECT)
** word - global word identifier (integer)
** val - new value for field
** type - datatype of value
**
***********************************************************************/
{
REBVAL value;
CLEARS(&value);
if (!(word = Find_Word_Index(obj, word, FALSE))) return 0;
if (VAL_GET_EXT(FRM_KEYS(obj) + word, EXT_WORD_LOCK)) return 0;
RXI_To_Value(FRM_VALUES(obj)+word, val, type);
return type;
}
*/ REBSER *Mold_Print_Value(const REBVAL *value, REBCNT limit, REBFLG mold)
/*
** Basis function for print. Can do a form or a mold based
** on the mold flag setting. Can limit string output to a
** specified size to prevent long console garbage output.
**
***********************************************************************/
{
REB_MOLD mo;
CLEARS(&mo);
Reset_Mold(&mo);
Mold_Value(&mo, value, mold);
if (limit != 0 && STR_LEN(mo.series) > limit) {
SERIES_TAIL(mo.series) = limit;
Append_Unencoded(mo.series, "..."); // adds a null at the tail
}
return mo.series;
}
*/ void Open_StdIO(void)
/*
** Open REBOL's standard IO device. This same device is used
** by both the host code and the R3 DLL itself.
**
** This must be done before any other initialization is done
** in order to output banners or errors.
**
***********************************************************************/
{
CLEARS(&Std_IO_Req);
Std_IO_Req.clen = sizeof(Std_IO_Req);
Std_IO_Req.device = RDI_STDIO;
OS_Do_Device(&Std_IO_Req, RDC_OPEN);
if (Std_IO_Req.error) Host_Crash("stdio open");
inbuf = OS_ALLOC_ARRAY(REBYTE, inbuf_len);
inbuf[0] = 0;
}
*/ RL_API int RL_Callback(RXICBI *cbi)
/*
** Evaluate a REBOL callback function, either synchronous or asynchronous.
**
** Returns:
** Sync callback: type of the result; async callback: true if queued
** Arguments:
** cbi - callback information including special option flags,
** object pointer (where function is located), function name
** as global word identifier (within above object), argument list
** passed to callback (see notes below), and result value.
** Notes:
** The flag value will determine the type of callback. It can be either
** synchronous, where the code will re-enter the interpreter environment
** and call the specified function, or asynchronous where an EVT_CALLBACK
** event is queued, and the callback will be evaluated later when events
** are processed within the interpreter's environment.
** For asynchronous callbacks, the cbi and the args array must be managed
** because the data isn't processed until the callback event is
** handled. Therefore, these cannot be allocated locally on
** the C stack; they should be dynamic (or global if so desired.)
** See c:extensions-callbacks
**
***********************************************************************/
{
REBEVT evt;
// Synchronous callback?
if (!GET_FLAG(cbi->flags, RXC_ASYNC)) {
return Do_Callback(cbi->obj, cbi->word, cbi->args, &(cbi->result));
}
CLEARS(&evt);
evt.type = EVT_CALLBACK;
evt.model = EVM_CALLBACK;
evt.eventee.ser = cbi;
SET_FLAG(cbi->flags, RXC_QUEUED);
return RL_Event(&evt); // (returns 0 if queue is full, ignored)
}
*/ static int Read_Dir(REBREQ *dir, REBSER *files)
/*
** Provide option to get file info too.
** Provide option to prepend dir path.
** Provide option to use wildcards.
**
***********************************************************************/
{
REBINT result;
REBCNT len;
REBSER *fname;
REBSER *name;
REBREQ file;
RESET_TAIL(files);
CLEARS(&file);
// Temporary filename storage:
fname = BUF_OS_STR;
file.file.path = (REBCHR*)Reset_Buffer(fname, MAX_FILE_NAME);
SET_FLAG(dir->modes, RFM_DIR);
dir->data = (REBYTE*)(&file);
while ((result = OS_DO_DEVICE(dir, RDC_READ)) == 0 && !GET_FLAG(dir->flags, RRF_DONE)) {
len = LEN_STR(file.file.path);
if (GET_FLAG(file.modes, RFM_DIR)) len++;
name = Copy_OS_Str(file.file.path, len);
if (GET_FLAG(file.modes, RFM_DIR))
SET_ANY_CHAR(name, name->tail-1, '/');
Set_Series(REB_FILE, Append_Value(files), name);
}
if (result < 0 && dir->error != -RFE_OPEN_FAIL
&& (FIND_CHR(dir->file.path, '*') || FIND_CHR(dir->file.path, '?')))
result = 0; // no matches found, but not an error
return result;
}
*/ RL_API int RL_Set_Value(REBSER *series, u32 index, RXIARG val, int type)
/*
** Set a value in a block.
**
** Returns:
** TRUE if index past end and value was appended to tail of block.
** Arguments:
** series - block series pointer
** index - index of the value in the block (zero based)
** val - new value for field
** type - datatype of value
**
***********************************************************************/
{
REBVAL value;
CLEARS(&value);
RXI_To_Value(&value, val, type);
if (index >= series->tail) {
Append_Value(series, &value);
return TRUE;
}
*BLK_SKIP(series, index) = value;
return FALSE;
}
*/ static REB_R Dir_Actor(struct Reb_Call *call_, REBSER *port, REBCNT action)
/*
** Internal port handler for file directories.
**
***********************************************************************/
{
REBVAL *spec;
REBVAL *path;
REBVAL *state;
REBREQ dir;
REBCNT args = 0;
REBINT result;
REBCNT len;
//REBYTE *flags;
Validate_Port(port, action);
*D_OUT = *D_ARG(1);
CLEARS(&dir);
// Validate and fetch relevant PORT fields:
spec = BLK_SKIP(port, STD_PORT_SPEC);
if (!IS_OBJECT(spec)) raise Error_1(RE_INVALID_SPEC, spec);
path = Obj_Value(spec, STD_PORT_SPEC_HEAD_REF);
if (!path) raise Error_1(RE_INVALID_SPEC, spec);
if (IS_URL(path)) path = Obj_Value(spec, STD_PORT_SPEC_HEAD_PATH);
else if (!IS_FILE(path)) raise Error_1(RE_INVALID_SPEC, path);
state = BLK_SKIP(port, STD_PORT_STATE); // if block, then port is open.
//flags = Security_Policy(SYM_FILE, path);
// Get or setup internal state data:
dir.port = port;
dir.device = RDI_FILE;
switch (action) {
case A_READ:
//Trap_Security(flags[POL_READ], POL_READ, path);
args = Find_Refines(call_, ALL_READ_REFS);
if (!IS_BLOCK(state)) { // !!! ignores /SKIP and /PART, for now
Init_Dir_Path(&dir, path, 1, POL_READ);
Val_Init_Block(state, Make_Array(7)); // initial guess
result = Read_Dir(&dir, VAL_SERIES(state));
///OS_FREE(dir.file.path);
if (result < 0)
raise Error_On_Port(RE_CANNOT_OPEN, port, dir.error);
*D_OUT = *state;
SET_NONE(state);
}
else {
// !!! This copies the strings in the block, shallowly. What is
// the purpose of doing this? Why copy at all?
Val_Init_Block(
D_OUT,
Copy_Array_Core_Managed(
VAL_SERIES(state),
0,
VAL_BLK_LEN(state),
FALSE, // !deep
TS_STRING
)
);
}
break;
case A_CREATE:
//Trap_Security(flags[POL_WRITE], POL_WRITE, path);
if (IS_BLOCK(state)) raise Error_1(RE_ALREADY_OPEN, path);
create:
Init_Dir_Path(&dir, path, 0, POL_WRITE | REMOVE_TAIL_SLASH); // Sets RFM_DIR too
result = OS_DO_DEVICE(&dir, RDC_CREATE);
///OS_FREE(dir.file.path);
if (result < 0) raise Error_1(RE_NO_CREATE, path);
if (action == A_CREATE) {
// !!! Used to return R_ARG2, but create is single arity. :-/
return R_ARG1;
}
SET_NONE(state);
break;
case A_RENAME:
if (IS_BLOCK(state)) raise Error_1(RE_ALREADY_OPEN, path);
else {
REBSER *target;
Init_Dir_Path(&dir, path, 0, POL_WRITE | REMOVE_TAIL_SLASH); // Sets RFM_DIR too
// Convert file name to OS format:
if (!(target = Value_To_OS_Path(D_ARG(2), TRUE)))
raise Error_1(RE_BAD_FILE_PATH, D_ARG(2));
dir.common.data = BIN_DATA(target);
OS_DO_DEVICE(&dir, RDC_RENAME);
Free_Series(target);
if (dir.error) raise Error_1(RE_NO_RENAME, path);
}
break;
case A_DELETE:
//Trap_Security(flags[POL_WRITE], POL_WRITE, path);
SET_NONE(state);
Init_Dir_Path(&dir, path, 0, POL_WRITE);
// !!! add *.r deletion
// !!! add recursive delete (?)
result = OS_DO_DEVICE(&dir, RDC_DELETE);
///OS_FREE(dir.file.path);
if (result < 0) raise Error_1(RE_NO_DELETE, path);
// !!! Returned R_ARG2 before, but there is no second argument :-/
return R_ARG1;
case A_OPEN:
// !! If open fails, what if user does a READ w/o checking for error?
if (IS_BLOCK(state)) raise Error_1(RE_ALREADY_OPEN, path);
//Trap_Security(flags[POL_READ], POL_READ, path);
args = Find_Refines(call_, ALL_OPEN_REFS);
if (args & AM_OPEN_NEW) goto create;
//if (args & ~AM_OPEN_READ) raise Error_1(RE_INVALID_SPEC, path);
Val_Init_Block(state, Make_Array(7));
Init_Dir_Path(&dir, path, 1, POL_READ);
result = Read_Dir(&dir, VAL_SERIES(state));
///OS_FREE(dir.file.path);
if (result < 0) raise Error_On_Port(RE_CANNOT_OPEN, port, dir.error);
break;
case A_OPENQ:
if (IS_BLOCK(state)) return R_TRUE;
return R_FALSE;
case A_CLOSE:
SET_NONE(state);
break;
case A_QUERY:
//Trap_Security(flags[POL_READ], POL_READ, path);
SET_NONE(state);
Init_Dir_Path(&dir, path, -1, REMOVE_TAIL_SLASH | POL_READ);
if (OS_DO_DEVICE(&dir, RDC_QUERY) < 0) return R_NONE;
Ret_Query_File(port, &dir, D_OUT);
///OS_FREE(dir.file.path);
break;
//-- Port Series Actions (only called if opened as a port)
case A_LENGTH:
len = IS_BLOCK(state) ? VAL_BLK_LEN(state) : 0;
SET_INTEGER(D_OUT, len);
break;
default:
raise Error_Illegal_Action(REB_PORT, action);
}
return R_OUT;
}
static void Mold_String_Series(const REBVAL *value, REB_MOLD *mold)
{
REBCNT len = VAL_LEN(value);
REBSER *ser = VAL_SERIES(value);
REBCNT idx = VAL_INDEX(value);
REBYTE *bp;
REBUNI *up;
REBUNI *dp;
REBOOL uni = !BYTE_SIZE(ser);
REBCNT n;
REBUNI c;
REB_STRF sf;
CLEARS(&sf);
// Empty string:
if (idx >= VAL_TAIL(value)) {
Append_Unencoded(mold->series, "\"\""); //Trap_DEAD_END(RE_PAST_END);
return;
}
Sniff_String(ser, idx, &sf);
if (!GET_MOPT(mold, MOPT_ANSI_ONLY)) sf.paren = 0;
// Source can be 8 or 16 bits:
if (uni) up = UNI_HEAD(ser);
else bp = STR_HEAD(ser);
// If it is a short quoted string, emit it as "string":
if (len <= MAX_QUOTED_STR && sf.quote == 0 && sf.newline < 3) {
dp = Prep_Uni_Series(mold, len + sf.newline + sf.escape + sf.paren + sf.chr1e + 2);
*dp++ = '"';
for (n = idx; n < VAL_TAIL(value); n++) {
c = uni ? up[n] : cast(REBUNI, bp[n]);
dp = Emit_Uni_Char(dp, c, (REBOOL)GET_MOPT(mold, MOPT_ANSI_ONLY)); // parened
}
*dp++ = '"';
*dp = 0;
return;
}
// It is a braced string, emit it as {string}:
if (!sf.malign) sf.brace_in = sf.brace_out = 0;
dp = Prep_Uni_Series(mold, len + sf.brace_in + sf.brace_out + sf.escape + sf.paren + sf.chr1e + 2);
*dp++ = '{';
for (n = idx; n < VAL_TAIL(value); n++) {
c = uni ? up[n] : cast(REBUNI, bp[n]);
switch (c) {
case '{':
case '}':
if (sf.malign) {
*dp++ = '^';
*dp++ = c;
break;
}
case '\n':
case '"':
*dp++ = c;
break;
default:
dp = Emit_Uni_Char(dp, c, (REBOOL)GET_MOPT(mold, MOPT_ANSI_ONLY)); // parened
}
}
*dp++ = '}';
*dp = 0;
}
*/ void Parse_Args(int argc, REBCHR **argv, REBARGS *rargs)
/*
** Parse REBOL's command line arguments, setting options
** and values in the provided args structure.
**
***********************************************************************/
{
REBCHR *arg;
REBCHR *args = 0; // holds trailing args
int flag;
int i;
CLEARS(rargs);
// First arg is path to execuable (on most systems):
if (argc > 0) rargs->exe_path = *argv;
OS_Get_Current_Dir(&rargs->home_dir);
// Parse each argument:
for (i = 1; i < argc ; i++) {
arg = argv[i];
if (arg == 0) continue; // shell bug
if (*arg == '-') {
if (arg[1] == '-') {
// --option words
flag = find_option_word(arg+2);
if (flag & RO_EXT) {
flag = Get_Ext_Arg(flag, rargs, (i+1 >= argc) ? 0 : argv[i+1]);
if ((flag & RO_EXT) == 0) i++; // used it
else flag &= ~RO_EXT;
}
if (!flag) flag = RO_HELP;
rargs->options |= flag;
}
else {
// -x option chars
while (*++arg) {
flag = find_option_char(*arg, arg_chars);
if (flag & RO_EXT) {
flag = Get_Ext_Arg(flag, rargs, (i+1 >= argc) ? 0 : argv[i+1]);
if ((flag & RO_EXT) == 0) i++; // used it
else flag &= ~RO_EXT;
}
if (!flag) flag = RO_HELP;
rargs->options |= flag;
}
}
}
else if (*arg == '+') {
// +x option chars
while (*++arg) {
flag = find_option_char(*arg, arg_chars2);
if (flag & RO_EXT) {
flag = Get_Ext_Arg(flag, rargs, (i+1 >= argc) ? 0 : argv[i+1]);
if ((flag & RO_EXT) == 0) i++; // used it
else flag &= ~RO_EXT;
}
if (!flag) flag = RO_HELP;
rargs->options |= flag;
}
}
else {
// script filename
if (!rargs->script)
rargs->script = arg;
else {
int len;
if (!args) {
args = MAKE_STR(ARG_BUF_SIZE);
args[0] = 0;
}
len = ARG_BUF_SIZE - LEN_STR(args) - 2; // space remaining
JOIN_STR(args, arg, len);
JOIN_STR(args, TXT(" "), 1);
}
}
}
if (args) {
args[LEN_STR(args)-1] = 0; // remove trailing space
Get_Ext_Arg(RO_ARGS, rargs, args);
}
}
*/ static int Dir_Actor(REBVAL *ds, REBSER *port, REBCNT action)
/*
** Internal port handler for file directories.
**
***********************************************************************/
{
REBVAL *spec;
REBVAL *path;
REBVAL *state;
REBREQ dir;
REBCNT args = 0;
REBINT result;
REBCNT len;
//REBYTE *flags;
Validate_Port(port, action);
*D_RET = *D_ARG(1);
CLEARS(&dir);
// Validate and fetch relevant PORT fields:
spec = BLK_SKIP(port, STD_PORT_SPEC);
if (!IS_OBJECT(spec)) Trap1(RE_INVALID_SPEC, spec);
path = Obj_Value(spec, STD_PORT_SPEC_HEAD_REF);
if (!path) Trap1(RE_INVALID_SPEC, spec);
if (IS_URL(path)) path = Obj_Value(spec, STD_PORT_SPEC_HEAD_PATH);
else if (!IS_FILE(path)) Trap1(RE_INVALID_SPEC, path);
state = BLK_SKIP(port, STD_PORT_STATE); // if block, then port is open.
//flags = Security_Policy(SYM_FILE, path);
// Get or setup internal state data:
dir.port = port;
dir.device = RDI_FILE;
switch (action) {
case A_READ:
//Trap_Security(flags[POL_READ], POL_READ, path);
args = Find_Refines(ds, ALL_READ_REFS);
if (!IS_BLOCK(state)) { // !!! ignores /SKIP and /PART, for now
Init_Dir_Path(&dir, path, 1, POL_READ);
Set_Block(state, Make_Block(7)); // initial guess
result = Read_Dir(&dir, VAL_SERIES(state));
///OS_FREE(dir.file.path);
if (result < 0) Trap_Port(RE_CANNOT_OPEN, port, dir.error);
*D_RET = *state;
SET_NONE(state);
} else {
len = VAL_BLK_LEN(state);
// !!? Why does this need to copy the block??
Set_Block(D_RET, Copy_Block_Values(VAL_SERIES(state), 0, len, TS_STRING));
}
break;
case A_CREATE:
//Trap_Security(flags[POL_WRITE], POL_WRITE, path);
if (IS_BLOCK(state)) Trap1(RE_ALREADY_OPEN, path); // already open
create:
Init_Dir_Path(&dir, path, 0, POL_WRITE | REMOVE_TAIL_SLASH); // Sets RFM_DIR too
result = OS_DO_DEVICE(&dir, RDC_CREATE);
///OS_FREE(dir.file.path);
if (result < 0) Trap1(RE_NO_CREATE, path);
if (action == A_CREATE) return R_ARG2;
SET_NONE(state);
break;
case A_RENAME:
if (IS_BLOCK(state)) Trap1(RE_ALREADY_OPEN, path); // already open
else {
REBSER *target;
Init_Dir_Path(&dir, path, 0, POL_WRITE | REMOVE_TAIL_SLASH); // Sets RFM_DIR too
// Convert file name to OS format:
if (!(target = Value_To_OS_Path(D_ARG(2)))) Trap1(RE_BAD_FILE_PATH, D_ARG(2));
dir.data = BIN_DATA(target);
OS_DO_DEVICE(&dir, RDC_RENAME);
Free_Series(target);
if (dir.error) Trap1(RE_NO_RENAME, path);
}
break;
case A_DELETE:
//Trap_Security(flags[POL_WRITE], POL_WRITE, path);
SET_NONE(state);
Init_Dir_Path(&dir, path, 0, POL_WRITE);
// !!! add *.r deletion
// !!! add recursive delete (?)
result = OS_DO_DEVICE(&dir, RDC_DELETE);
///OS_FREE(dir.file.path);
if (result < 0) Trap1(RE_NO_DELETE, path);
return R_ARG2;
case A_OPEN:
// !! If open fails, what if user does a READ w/o checking for error?
if (IS_BLOCK(state)) Trap1(RE_ALREADY_OPEN, path); // already open
//Trap_Security(flags[POL_READ], POL_READ, path);
args = Find_Refines(ds, ALL_OPEN_REFS);
if (args & AM_OPEN_NEW) goto create;
//if (args & ~AM_OPEN_READ) Trap1(RE_INVALID_SPEC, path);
Set_Block(state, Make_Block(7));
Init_Dir_Path(&dir, path, 1, POL_READ);
result = Read_Dir(&dir, VAL_SERIES(state));
///OS_FREE(dir.file.path);
if (result < 0) Trap_Port(RE_CANNOT_OPEN, port, dir.error);
break;
case A_OPENQ:
if (IS_BLOCK(state)) return R_TRUE;
return R_FALSE;
case A_CLOSE:
SET_NONE(state);
break;
case A_QUERY:
//Trap_Security(flags[POL_READ], POL_READ, path);
SET_NONE(state);
Init_Dir_Path(&dir, path, -1, REMOVE_TAIL_SLASH | POL_READ);
if (OS_DO_DEVICE(&dir, RDC_QUERY) < 0) return R_NONE;
Ret_Query_File(port, &dir, D_RET);
///OS_FREE(dir.file.path);
break;
//-- Port Series Actions (only called if opened as a port)
case A_LENGTHQ:
len = IS_BLOCK(state) ? VAL_BLK_LEN(state) : 0;
SET_INTEGER(D_RET, len);
break;
default:
Trap_Action(REB_PORT, action);
}
return R_RET;
}
//
// Make_Set_Operation_Series: C
//
// Do set operations on a series. Case-sensitive if `cased` is TRUE.
// `skip` is the record size.
//
static REBSER *Make_Set_Operation_Series(
const REBVAL *val1,
const REBVAL *val2,
REBFLGS flags,
REBOOL cased,
REBCNT skip
) {
REBCNT i;
REBINT h = 1; // used for both logic true/false and hash check
REBOOL first_pass = TRUE; // are we in the first pass over the series?
REBSER *out_ser;
assert(ANY_SERIES(val1));
if (val2) {
assert(ANY_SERIES(val2));
if (ANY_ARRAY(val1)) {
if (!ANY_ARRAY(val2))
fail (Error_Unexpected_Type(VAL_TYPE(val1), VAL_TYPE(val2)));
// As long as they're both arrays, we're willing to do:
//
// >> union quote (a b c) 'b/d/e
// (a b c d e)
//
// The type of the result will match the first value.
}
else if (!IS_BINARY(val1)) {
// We will similarly do any two ANY-STRING! types:
//
// >> union <abc> "bde"
// <abcde>
if (IS_BINARY(val2))
fail (Error_Unexpected_Type(VAL_TYPE(val1), VAL_TYPE(val2)));
}
else {
// Binaries only operate with other binaries
if (!IS_BINARY(val2))
fail (Error_Unexpected_Type(VAL_TYPE(val1), VAL_TYPE(val2)));
}
}
// Calculate `i` as maximum length of result block. The temporary buffer
// will be allocated at this size, but copied out at the exact size of
// the actual result.
//
i = VAL_LEN_AT(val1);
if (flags & SOP_FLAG_BOTH) i += VAL_LEN_AT(val2);
if (ANY_ARRAY(val1)) {
REBSER *hser = 0; // hash table for series
REBSER *hret; // hash table for return series
// The buffer used for building the return series. Currently it
// reuses BUF_EMIT, because that buffer is not likely to be in
// use (emit doesn't call set operations, nor vice versa). However,
// other routines may get the same idea and start recursing so it
// may be better to use something more similar to the mold stack
// approach of marking off successive ranges in the array.
//
REBSER *buffer = ARR_SERIES(BUF_EMIT);
Resize_Series(buffer, i);
hret = Make_Hash_Sequence(i); // allocated
// Optimization note: !!
// This code could be optimized for small blocks by not hashing them
// and extending Find_Key to FIND on the value itself w/o the hash.
do {
REBARR *array1 = VAL_ARRAY(val1); // val1 and val2 swapped 2nd pass!
// Check what is in series1 but not in series2
//
if (flags & SOP_FLAG_CHECK)
hser = Hash_Block(val2, skip, cased);
// Iterate over first series
//
i = VAL_INDEX(val1);
for (; i < ARR_LEN(array1); i += skip) {
RELVAL *item = ARR_AT(array1, i);
if (flags & SOP_FLAG_CHECK) {
h = Find_Key_Hashed(
VAL_ARRAY(val2),
hser,
item,
VAL_SPECIFIER(val1),
skip,
cased,
1
);
h = (h >= 0);
if (flags & SOP_FLAG_INVERT) h = !h;
}
if (h) {
Find_Key_Hashed(
AS_ARRAY(buffer),
hret,
item,
VAL_SPECIFIER(val1),
skip,
cased,
2
);
}
}
if (i != ARR_LEN(array1)) {
//
// In the current philosophy, the semantics of what to do
// with things like `intersect/skip [1 2 3] [7] 2` is too
// shaky to deal with, so an error is reported if it does
// not work out evenly to the skip size.
//
fail (Error(RE_BLOCK_SKIP_WRONG));
}
if (flags & SOP_FLAG_CHECK)
Free_Series(hser);
if (!first_pass) break;
first_pass = FALSE;
// Iterate over second series?
//
if ((i = ((flags & SOP_FLAG_BOTH) != 0))) {
const REBVAL *temp = val1;
val1 = val2;
val2 = temp;
}
} while (i);
if (hret)
Free_Series(hret);
out_ser = ARR_SERIES(Copy_Array_Shallow(AS_ARRAY(buffer), SPECIFIED));
SET_SERIES_LEN(buffer, 0); // required - allow reuse
}
else {
REB_MOLD mo;
CLEARS(&mo);
if (IS_BINARY(val1)) {
//
// All binaries use "case-sensitive" comparison (e.g. each byte
// is treated distinctly)
//
cased = TRUE;
}
// ask mo.series to have at least `i` capacity beyond mo.start
//
mo.opts = MOPT_RESERVE;
mo.reserve = i;
Push_Mold(&mo);
do {
REBSER *ser = VAL_SERIES(val1); // val1 and val2 swapped 2nd pass!
REBUNI uc;
// Iterate over first series
//
i = VAL_INDEX(val1);
for (; i < SER_LEN(ser); i += skip) {
uc = GET_ANY_CHAR(ser, i);
if (flags & SOP_FLAG_CHECK) {
h = (NOT_FOUND != Find_Str_Char(
uc,
VAL_SERIES(val2),
0,
VAL_INDEX(val2),
VAL_LEN_HEAD(val2),
skip,
cased ? AM_FIND_CASE : 0
));
if (flags & SOP_FLAG_INVERT) h = !h;
}
if (!h) continue;
if (
NOT_FOUND == Find_Str_Char(
uc, // c2 (the character to find)
mo.series, // ser
mo.start, // head
mo.start, // index
SER_LEN(mo.series), // tail
skip, // skip
cased ? AM_FIND_CASE : 0 // flags
)
) {
Append_String(mo.series, ser, i, skip);
}
}
if (!first_pass) break;
first_pass = FALSE;
// Iterate over second series?
//
if ((i = ((flags & SOP_FLAG_BOTH) != 0))) {
const REBVAL *temp = val1;
val1 = val2;
val2 = temp;
}
} while (i);
out_ser = Pop_Molded_String(&mo);
}
return out_ser;
}
