*/ REBINT Compare_String_Vals(REBVAL *v1, REBVAL *v2, REBOOL uncase)
/*
** Compare two string values. Either can be byte or unicode wide.
**
** Uncase: compare is case-insensitive.
**
** Used for: general string comparions (various places)
**
***********************************************************************/
{
REBCNT l1 = VAL_LEN(v1);
REBCNT l2 = VAL_LEN(v2);
REBCNT len = MIN(l1, l2);
REBINT n;
if (IS_BINARY(v1) || IS_BINARY(v2)) uncase = FALSE;
if (VAL_BYTE_SIZE(v1)) { // v1 is 8
if (VAL_BYTE_SIZE(v2))
n = Compare_Bytes(VAL_BIN_DATA(v1), VAL_BIN_DATA(v2), len, uncase);
else
n = -Compare_Uni_Byte(VAL_UNI_DATA(v2), VAL_BIN_DATA(v1), len, uncase);
}
else { // v1 is 16
if (VAL_BYTE_SIZE(v2))
n = Compare_Uni_Byte(VAL_UNI_DATA(v1), VAL_BIN_DATA(v2), len, uncase);
else
n = Compare_Uni_Str(VAL_UNI_DATA(v1), VAL_UNI_DATA(v2), len, uncase);
}
if (n != 0) return n;
return l1 - l2;
}
static REBCNT find_string(REBSER *series, REBCNT index, REBCNT end, REBVAL *target, REBCNT len, REBCNT flags, REBINT skip)
{
REBCNT start = index;
if (flags & (AM_FIND_REVERSE | AM_FIND_LAST)) {
skip = -1;
start = 0;
if (flags & AM_FIND_LAST) index = end - len;
else index--;
}
if (ANY_BINSTR(target)) {
// Do the optimal search or the general search?
if (BYTE_SIZE(series) && VAL_BYTE_SIZE(target) && !(flags & ~(AM_FIND_CASE|AM_FIND_MATCH)))
return Find_Byte_Str(series, start, VAL_BIN_DATA(target), len, !GET_FLAG(flags, ARG_FIND_CASE-1), GET_FLAG(flags, ARG_FIND_MATCH-1));
else
return Find_Str_Str(series, start, index, end, skip, VAL_SERIES(target), VAL_INDEX(target), len, flags & (AM_FIND_MATCH|AM_FIND_CASE));
}
else if (IS_BINARY(target)) {
return Find_Byte_Str(series, start, VAL_BIN_DATA(target), len, 0, GET_FLAG(flags, ARG_FIND_MATCH-1));
}
else if (IS_CHAR(target)) {
return Find_Str_Char(series, start, index, end, skip, VAL_CHAR(target), flags);
}
else if (IS_INTEGER(target)) {
return Find_Str_Char(series, start, index, end, skip, (REBUNI)VAL_INT32(target), flags);
}
else if (IS_BITSET(target)) {
return Find_Str_Bitset(series, start, index, end, skip, VAL_SERIES(target), flags);
}
return NOT_FOUND;
}
*/ 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 Set_Port_Open(REBSER *port, REBFLG flag)
/*
** Standard method for setting a port open/closed.
** A convention. Not all ports use this method.
**
***********************************************************************/
{
REBVAL *state = BLK_SKIP(port, STD_PORT_STATE);
if (IS_BINARY(state)) {
if (flag) SET_OPEN(VAL_BIN_DATA(state));
else SET_CLOSED(VAL_BIN_DATA(state));
}
}
*/ REBSER *Xandor_Binary(REBCNT action, REBVAL *value, REBVAL *arg)
/*
** Only valid for BINARY data.
**
***********************************************************************/
{
REBSER *series;
REBYTE *p0 = VAL_BIN_DATA(value);
REBYTE *p1 = VAL_BIN_DATA(arg);
REBYTE *p2;
REBCNT i;
REBCNT mt, t1, t0, t2;
t0 = VAL_LEN(value);
t1 = VAL_LEN(arg);
mt = MIN(t0, t1); // smaller array size
// For AND - result is size of shortest input:
// if (action == A_AND || (action == 0 && t1 >= t0))
// t2 = mt;
// else
t2 = MAX(t0, t1);
series = Make_Binary(t2);
SERIES_TAIL(series) = t2;
p2 = BIN_HEAD(series);
switch (action) {
case A_AND:
for (i = 0; i < mt; i++) *p2++ = *p0++ & *p1++;
CLEAR(p2, t2 - mt);
return series;
case A_OR:
for (i = 0; i < mt; i++) *p2++ = *p0++ | *p1++;
break;
case A_XOR:
for (i = 0; i < mt; i++) *p2++ = *p0++ ^ *p1++;
break;
default:
// special bit set case EXCLUDE:
for (i = 0; i < mt; i++) *p2++ = *p0++ & ~*p1++;
if (t0 > t1) memcpy(p2, p0, t0 - t1); // residual from first only
return series;
}
// Copy the residual:
memcpy(p2, ((t0 > t1) ? p0 : p1), t2 - mt);
return series;
}
static void reverse_string(REBVAL *value, REBCNT len)
{
REBCNT n;
REBCNT m;
REBUNI c;
if (VAL_BYTE_SIZE(value)) {
REBYTE *bp = VAL_BIN_DATA(value);
for (n = 0, m = len-1; n < len / 2; n++, m--) {
c = bp[n];
bp[n] = bp[m];
bp[m] = (REBYTE)c;
}
}
else {
REBUNI *up = VAL_UNI_DATA(value);
for (n = 0, m = len-1; n < len / 2; n++, m--) {
c = up[n];
up[n] = up[m];
up[m] = c;
}
}
}
static int Check_Char_Range(REBVAL *val, REBINT limit)
{
REBCNT len;
if (IS_CHAR(val)) {
if (VAL_CHAR(val) > limit) return R_FALSE;
return R_TRUE;
}
if (IS_INTEGER(val)) {
if (VAL_INT64(val) > limit) return R_FALSE;
return R_TRUE;
}
len = VAL_LEN(val);
if (VAL_BYTE_SIZE(val)) {
REBYTE *bp = VAL_BIN_DATA(val);
if (limit == 0xff) return R_TRUE; // by definition
for (; len > 0; len--, bp++)
if (*bp > limit) return R_FALSE;
} else {
REBUNI *up = VAL_UNI_DATA(val);
for (; len > 0; len--, up++)
if (*up > limit) return R_FALSE;
}
return R_TRUE;
}
*/ REBOOL Cloak(REBOOL decode, REBYTE *cp, REBCNT dlen, REBYTE *kp, REBCNT klen, REBFLG as_is)
/*
** Simple data scrambler. Quality depends on the key length.
** Result is made in place (data string).
**
** The key (kp) is passed as a REBVAL or REBYTE (when klen is !0).
**
***********************************************************************/
{
REBCNT i, n;
REBYTE src[20];
REBYTE dst[20];
if (dlen == 0) return TRUE;
// Decode KEY as VALUE field (binary, string, or integer)
if (klen == 0) {
REBVAL *val = (REBVAL*)kp;
REBSER *ser;
switch (VAL_TYPE(val)) {
case REB_BINARY:
kp = VAL_BIN_DATA(val);
klen = VAL_LEN(val);
break;
case REB_STRING:
ser = Temp_Bin_Str_Managed(val, &i, &klen);
kp = BIN_SKIP(ser, i);
break;
case REB_INTEGER:
INT_TO_STR(VAL_INT64(val), dst);
klen = LEN_BYTES(dst);
as_is = FALSE;
break;
}
if (klen == 0) return FALSE;
}
if (!as_is) {
for (i = 0; i < 20; i++) src[i] = kp[i % klen];
SHA1(src, 20, dst);
klen = 20;
kp = dst;
}
if (decode)
for (i = dlen-1; i > 0; i--) cp[i] ^= cp[i-1] ^ kp[i % klen];
// Change starting byte based all other bytes.
n = 0xa5;
for (i = 1; i < dlen; i++) n += cp[i];
cp[0] ^= (REBYTE)n;
if (!decode)
for (i = 1; i < dlen; i++) cp[i] ^= cp[i-1] ^ kp[i % klen];
return TRUE;
}
*/ static void replace_with(REBSER *ser, REBCNT index, REBCNT tail, REBVAL *with)
/*
** Replace whitespace chars that match WITH string.
**
** Resulting string is always smaller than it was to start.
**
***********************************************************************/
{
#define MAX_WITH 32
REBCNT wlen;
REBUNI with_chars[MAX_WITH]; // chars to be trimmed
REBUNI *up = with_chars;
REBYTE *bp;
REBCNT n;
REBUNI uc;
// Setup WITH array from arg or the default:
n = 0;
if (IS_NONE(with)) {
bp = "\n \r\t";
wlen = n = 4;
}
else if (IS_CHAR(with)) {
wlen = 1;
*up++ = VAL_CHAR(with);
}
else if (IS_INTEGER(with)) {
wlen = 1;
*up++ = Int32s(with, 0);
}
else if (ANY_BINSTR(with)) {
n = VAL_LEN(with);
if (n >= MAX_WITH) n = MAX_WITH-1;
wlen = n;
if (VAL_BYTE_SIZE(with)) {
bp = VAL_BIN_DATA(with);
} else {
memcpy(up, VAL_UNI_DATA(with), n * sizeof(REBUNI));
n = 0;
}
}
for (; n > 0; n--) *up++ = (REBUNI)*bp++;
// Remove all occurances of chars found in WITH string:
for (n = index; index < tail; index++) {
uc = GET_ANY_CHAR(ser, index);
if (!find_in_uni(with_chars, wlen, uc)) {
SET_ANY_CHAR(ser, n, uc);
n++;
}
}
SET_ANY_CHAR(ser, n, 0);
SERIES_TAIL(ser) = n;
}
*/ REBFLG Is_Port_Open(REBSER *port)
/*
** Standard method for checking if port is open.
** A convention. Not all ports use this method.
**
***********************************************************************/
{
REBVAL *state = BLK_SKIP(port, STD_PORT_STATE);
if (!IS_BINARY(state)) return FALSE;
return IS_OPEN(VAL_BIN_DATA(state));
}
*/ REBINT Compare_Binary_Vals(REBVAL *v1, REBVAL *v2)
/*
** Compare two binary values.
**
** Compares bytes, not chars. Return the difference.
**
** Used for: Binary comparision function
**
***********************************************************************/
{
REBCNT l1 = VAL_LEN(v1);
REBCNT l2 = VAL_LEN(v2);
REBCNT len = MIN(l1, l2);
REBINT n;
if (IS_IMAGE(v1)) len *= 4;
n = memcmp(VAL_BIN_DATA(v1), VAL_BIN_DATA(v2), len);
if (n != 0) return n;
return l1 - l2;
}
*/ REBSER *Encode_UTF8_Value(REBVAL *arg, REBCNT len, REBFLG opts)
/*
** Do all the details to encode a string as UTF8.
** No_copy means do not make a copy.
** Result can be a shared buffer!
**
***********************************************************************/
{
REBSER * ser;
if (VAL_BYTE_SIZE(arg)) {
ser = Encode_UTF8_String(VAL_BIN_DATA(arg), len, FALSE, opts);
} else {
ser = Encode_UTF8_String(VAL_UNI_DATA(arg), len, TRUE, opts);
}
return ser;
}
static REBSER *make_string(REBVAL *arg, REBOOL make)
{
REBSER *ser = 0;
// MAKE <type> 123
if (make && (IS_INTEGER(arg) || IS_DECIMAL(arg))) {
ser = Make_Binary(Int32s(arg, 0));
}
// MAKE/TO <type> <binary!>
else if (IS_BINARY(arg)) {
REBYTE *bp = VAL_BIN_DATA(arg);
REBCNT len = VAL_LEN(arg);
switch (What_UTF(bp, len)) {
case 0:
break;
case 8: // UTF-8 encoded
bp += 3;
len -= 3;
break;
default:
Trap0(RE_BAD_DECODE);
}
ser = Decode_UTF_String(bp, len, 8); // UTF-8
}
// MAKE/TO <type> <any-string>
else if (ANY_BINSTR(arg)) {
ser = Copy_String(VAL_SERIES(arg), VAL_INDEX(arg), VAL_LEN(arg));
}
// MAKE/TO <type> <any-word>
else if (ANY_WORD(arg)) {
ser = Copy_Mold_Value(arg, TRUE);
//ser = Append_UTF8(0, Get_Word_Name(arg), -1);
}
// MAKE/TO <type> #"A"
else if (IS_CHAR(arg)) {
ser = (VAL_CHAR(arg) > 0xff) ? Make_Unicode(2) : Make_Binary(2);
Append_Byte(ser, VAL_CHAR(arg));
}
// MAKE/TO <type> <any-value>
// else if (IS_NONE(arg)) {
// ser = Make_Binary(0);
// }
else
ser = Copy_Form_Value(arg, 1<<MOPT_TIGHT);
return ser;
}
*/ REBSER *Complement_Binary(REBVAL *value)
/*
** Only valid for BINARY data.
**
***********************************************************************/
{
REBSER *series;
REBYTE *str = VAL_BIN_DATA(value);
REBINT len = VAL_LEN(value);
REBYTE *out;
series = Make_Binary(len);
SERIES_TAIL(series) = len;
out = BIN_HEAD(series);
for (; len > 0; len--)
*out++ = ~ *str++;
return series;
}
*/ REBCHR *Val_Str_To_OS_Managed(REBSER **out, REBVAL *val)
/*
** This is used to pass a REBOL value string to an OS API.
**
** The REBOL (input) string can be byte or wide sized.
** The OS (output) string is in the native OS format.
** On Windows, its a wide-char, but on Linux, its UTF-8.
**
** If we know that the string can be used directly as-is,
** (because it's in the OS size format), we can used it
** like that.
**
** !!! The series is created but just let up to the garbage
** collector to free. This is a "leaky" approach. You may
** optionally request to have the series returned if it is
** important for you to protect it from GC, but you cannot
** currently get a "freeable" series out of this.
**
***********************************************************************/
{
#ifdef OS_WIDE_CHAR
if (VAL_BYTE_SIZE(val)) {
// On windows, we need to convert byte to wide:
REBINT n = VAL_LEN(val);
REBSER *up = Make_Unicode(n);
// !!!"Leaks" in the sense that the GC has to take care of this
MANAGE_SERIES(up);
n = Decode_UTF8(UNI_HEAD(up), VAL_BIN_DATA(val), n, FALSE);
SERIES_TAIL(up) = abs(n);
UNI_TERM(up);
if (out) *out = up;
return cast(REBCHR*, UNI_HEAD(up));
}
else {
// Already wide, we can use it as-is:
// !Assumes the OS uses same wide format!
if (out) *out = VAL_SERIES(val);
*/ REBINT Bin_To_Money(REBVAL *result, REBVAL *val)
/*
***********************************************************************/
{
REBCNT len;
REBYTE buf[MAX_HEX_LEN+4] = {0}; // binary to convert
if (IS_BINARY(val)) {
len = VAL_LEN(val);
if (len > 12) len = 12;
memcpy(buf, VAL_BIN_DATA(val), len);
}
#ifdef removed
else if (IS_ISSUE(val)) {
//if (!(len = Scan_Hex_Bytes(val, 24, buf))) return FALSE;
REBYTE *ap = Get_Word_Name(val);
REBYTE *bp = &buf[0];
REBCNT alen;
REBUNI c;
len = LEN_BYTES(ap); // UTF-8 len
if (len & 1) return FALSE; // must have even # of chars
len /= 2;
if (len > 12) return FALSE; // valid even for UTF-8
for (alen = 0; alen < len; alen++) {
if (!Scan_Hex2(ap, &c, 0)) return FALSE;
*bp++ = (REBYTE)c;
ap += 2;
}
}
#endif
else
raise Error_Invalid_Arg(val);
memcpy(buf + 12 - len, buf, len); // shift to right side
memset(buf, 0, 12 - len);
VAL_MONEY_AMOUNT(result) = binary_to_deci(buf);
return TRUE;
}
*/ void Make_Block_Type(REBFLG make, REBVAL *value, REBVAL *arg)
/*
** Value can be:
** 1. a datatype (e.g. BLOCK!)
** 2. a value (e.g. [...])
**
** Arg can be:
** 1. integer (length of block)
** 2. block (copy it)
** 3. value (convert to a block)
**
***********************************************************************/
{
REBCNT type;
REBCNT len;
REBSER *ser;
// make block! ...
if (IS_DATATYPE(value))
type = VAL_DATATYPE(value);
else // make [...] ....
type = VAL_TYPE(value);
// make block! [1 2 3]
if (ANY_BLOCK(arg)) {
len = VAL_BLK_LEN(arg);
if (len > 0 && type >= REB_PATH && type <= REB_LIT_PATH)
No_Nones(arg);
ser = Copy_Values(VAL_BLK_DATA(arg), len);
goto done;
}
if (IS_STRING(arg)) {
REBCNT index, len = 0;
VAL_SERIES(arg) = Prep_Bin_Str(arg, &index, &len); // (keeps safe)
ser = Scan_Source(VAL_BIN(arg), VAL_LEN(arg));
goto done;
}
if (IS_BINARY(arg)) {
ser = Scan_Source(VAL_BIN_DATA(arg), VAL_LEN(arg));
goto done;
}
if (IS_MAP(arg)) {
ser = Map_To_Block(VAL_SERIES(arg), 0);
goto done;
}
if (ANY_OBJECT(arg)) {
ser = Make_Object_Block(VAL_OBJ_FRAME(arg), 3);
goto done;
}
if (IS_VECTOR(arg)) {
ser = Make_Vector_Block(arg);
goto done;
}
// if (make && IS_NONE(arg)) {
// ser = Make_Block(0);
// goto done;
// }
// to block! typset
if (!make && IS_TYPESET(arg) && type == REB_BLOCK) {
Set_Block(value, Typeset_To_Block(arg));
return;
}
if (make) {
// make block! 10
if (IS_INTEGER(arg) || IS_DECIMAL(arg)) {
len = Int32s(arg, 0);
Set_Series(type, value, Make_Block(len));
return;
}
Trap_Arg(arg);
}
ser = Copy_Values(arg, 1);
done:
Set_Series(type, value, ser);
return;
}
//
// Clipboard_Actor: C
//
static REB_R Clipboard_Actor(struct Reb_Call *call_, REBSER *port, REBCNT action)
{
REBREQ *req;
REBINT result;
REBVAL *arg;
REBCNT refs; // refinement argument flags
REBINT len;
REBSER *ser;
Validate_Port(port, action);
arg = DS_ARGC > 1 ? D_ARG(2) : NULL;
req = cast(REBREQ*, Use_Port_State(port, RDI_CLIPBOARD, sizeof(REBREQ)));
switch (action) {
case A_UPDATE:
// Update the port object after a READ or WRITE operation.
// This is normally called by the WAKE-UP function.
arg = OFV(port, STD_PORT_DATA);
if (req->command == RDC_READ) {
// this could be executed twice:
// once for an event READ, once for the CLOSE following the READ
if (!req->common.data) return R_NONE;
len = req->actual;
if (GET_FLAG(req->flags, RRF_WIDE)) {
// convert to UTF8, so that it can be converted back to string!
Val_Init_Binary(arg, Make_UTF8_Binary(
req->common.data,
len / sizeof(REBUNI),
0,
OPT_ENC_UNISRC
));
}
else {
REBSER *ser = Make_Binary(len);
memcpy(BIN_HEAD(ser), req->common.data, len);
SERIES_TAIL(ser) = len;
Val_Init_Binary(arg, ser);
}
OS_FREE(req->common.data); // release the copy buffer
req->common.data = 0;
}
else if (req->command == RDC_WRITE) {
SET_NONE(arg); // Write is done.
}
return R_NONE;
case A_READ:
// This device is opened on the READ:
if (!IS_OPEN(req)) {
if (OS_DO_DEVICE(req, RDC_OPEN))
fail (Error_On_Port(RE_CANNOT_OPEN, port, req->error));
}
// Issue the read request:
CLR_FLAG(req->flags, RRF_WIDE); // allow byte or wide chars
result = OS_DO_DEVICE(req, RDC_READ);
if (result < 0) fail (Error_On_Port(RE_READ_ERROR, port, req->error));
if (result > 0) return R_NONE; /* pending */
// Copy and set the string result:
arg = OFV(port, STD_PORT_DATA);
len = req->actual;
if (GET_FLAG(req->flags, RRF_WIDE)) {
// convert to UTF8, so that it can be converted back to string!
Val_Init_Binary(arg, Make_UTF8_Binary(
req->common.data,
len / sizeof(REBUNI),
0,
OPT_ENC_UNISRC
));
}
else {
REBSER *ser = Make_Binary(len);
memcpy(BIN_HEAD(ser), req->common.data, len);
SERIES_TAIL(ser) = len;
Val_Init_Binary(arg, ser);
}
*D_OUT = *arg;
return R_OUT;
case A_WRITE:
if (!IS_STRING(arg) && !IS_BINARY(arg))
fail (Error(RE_INVALID_PORT_ARG, arg));
// This device is opened on the WRITE:
if (!IS_OPEN(req)) {
if (OS_DO_DEVICE(req, RDC_OPEN))
fail (Error_On_Port(RE_CANNOT_OPEN, port, req->error));
}
refs = Find_Refines(call_, ALL_WRITE_REFS);
// Handle /part refinement:
len = VAL_LEN(arg);
if (refs & AM_WRITE_PART && VAL_INT32(D_ARG(ARG_WRITE_LIMIT)) < len)
len = VAL_INT32(D_ARG(ARG_WRITE_LIMIT));
// If bytes, see if we can fit it:
if (SERIES_WIDE(VAL_SERIES(arg)) == 1) {
#ifdef ARG_STRINGS_ALLOWED
if (!All_Bytes_ASCII(VAL_BIN_DATA(arg), len)) {
Val_Init_String(
arg, Copy_Bytes_To_Unicode(VAL_BIN_DATA(arg), len)
);
} else
req->common.data = VAL_BIN_DATA(arg);
#endif
// Temp conversion:!!!
ser = Make_Unicode(len);
len = Decode_UTF8(UNI_HEAD(ser), VAL_BIN_DATA(arg), len, FALSE);
SERIES_TAIL(ser) = len = abs(len);
UNI_TERM(ser);
Val_Init_String(arg, ser);
req->common.data = cast(REBYTE*, UNI_HEAD(ser));
SET_FLAG(req->flags, RRF_WIDE);
}
else
// If unicode (may be from above conversion), handle it:
if (SERIES_WIDE(VAL_SERIES(arg)) == sizeof(REBUNI)) {
req->common.data = cast(REBYTE *, VAL_UNI_DATA(arg));
SET_FLAG(req->flags, RRF_WIDE);
}
static REBSER *make_binary(REBVAL *arg, REBOOL make)
{
REBSER *ser;
// MAKE BINARY! 123
switch (VAL_TYPE(arg)) {
case REB_INTEGER:
case REB_DECIMAL:
if (make) ser = Make_Binary(Int32s(arg, 0));
else ser = Make_Binary_BE64(arg);
break;
// MAKE/TO BINARY! BINARY!
case REB_BINARY:
ser = Copy_Bytes(VAL_BIN_DATA(arg), VAL_LEN(arg));
break;
// MAKE/TO BINARY! <any-string>
case REB_STRING:
case REB_FILE:
case REB_EMAIL:
case REB_URL:
case REB_TAG:
// case REB_ISSUE:
ser = Encode_UTF8_Value(arg, VAL_LEN(arg), 0);
break;
case REB_BLOCK:
ser = Join_Binary(arg);
break;
// MAKE/TO BINARY! <tuple!>
case REB_TUPLE:
ser = Copy_Bytes(VAL_TUPLE(arg), VAL_TUPLE_LEN(arg));
break;
// MAKE/TO BINARY! <char!>
case REB_CHAR:
ser = Make_Binary(6);
ser->tail = Encode_UTF8_Char(BIN_HEAD(ser), VAL_CHAR(arg));
break;
// MAKE/TO BINARY! <bitset!>
case REB_BITSET:
ser = Copy_Bytes(VAL_BIN(arg), VAL_TAIL(arg));
break;
// MAKE/TO BINARY! <image!>
case REB_IMAGE:
ser = Make_Image_Binary(arg);
break;
case REB_MONEY:
ser = Make_Binary(12);
ser->tail = 12;
deci_to_binary(ser->data, VAL_DECI(arg));
ser->data[12] = 0;
break;
default:
ser = 0;
}
return ser;
}
*/ static To_Thru(REBPARSE *parse, REBCNT index, REBVAL *block, REBFLG is_thru)
/*
***********************************************************************/
{
REBSER *series = parse->series;
REBCNT type = parse->type;
REBVAL *blk;
REBVAL *item;
REBCNT cmd;
REBCNT i;
REBCNT len;
for (; index <= series->tail; index++) {
for (blk = VAL_BLK(block); NOT_END(blk); blk++) {
item = blk;
// Deal with words and commands
if (IS_WORD(item)) {
if (cmd = VAL_CMD(item)) {
if (cmd == SYM_END) {
if (index >= series->tail) {
index = series->tail;
goto found;
}
goto next;
}
else if (cmd == SYM_QUOTE) {
item = ++blk; // next item is the quoted value
if (IS_END(item)) goto bad_target;
if (IS_PAREN(item)) {
item = Do_Block_Value_Throw(item); // might GC
}
}
else goto bad_target;
}
else {
item = Get_Var(item);
}
}
else if (IS_PATH(item)) {
item = Get_Parse_Value(item);
}
// Try to match it:
if (type >= REB_BLOCK) {
if (ANY_BLOCK(item)) goto bad_target;
i = Parse_Next_Block(parse, index, item, 0);
if (i != NOT_FOUND) {
if (!is_thru) i--;
index = i;
goto found;
}
}
else if (type == REB_BINARY) {
REBYTE ch1 = *BIN_SKIP(series, index);
// Handle special string types:
if (IS_CHAR(item)) {
if (VAL_CHAR(item) > 0xff) goto bad_target;
if (ch1 == VAL_CHAR(item)) goto found1;
}
else if (IS_BINARY(item)) {
if (ch1 == *VAL_BIN_DATA(item)) {
len = VAL_LEN(item);
if (len == 1) goto found1;
if (0 == Compare_Bytes(BIN_SKIP(series, index), VAL_BIN_DATA(item), len, 0)) {
if (is_thru) index += len;
goto found;
}
}
}
else if (IS_INTEGER(item)) {
if (VAL_INT64(item) > 0xff) goto bad_target;
if (ch1 == VAL_INT32(item)) goto found1;
}
else goto bad_target;
}
else { // String
REBCNT ch1 = GET_ANY_CHAR(series, index);
REBCNT ch2;
if (!HAS_CASE(parse)) ch1 = UP_CASE(ch1);
// Handle special string types:
if (IS_CHAR(item)) {
ch2 = VAL_CHAR(item);
if (!HAS_CASE(parse)) ch2 = UP_CASE(ch2);
if (ch1 == ch2) goto found1;
}
else if (ANY_STR(item)) {
ch2 = VAL_ANY_CHAR(item);
if (!HAS_CASE(parse)) ch2 = UP_CASE(ch2);
if (ch1 == ch2) {
len = VAL_LEN(item);
if (len == 1) goto found1;
i = Find_Str_Str(series, 0, index, SERIES_TAIL(series), 1, VAL_SERIES(item), VAL_INDEX(item), len, AM_FIND_MATCH | parse->flags);
if (i != NOT_FOUND) {
if (is_thru) i += len;
index = i;
goto found;
}
}
}
else if (IS_INTEGER(item)) {
ch1 = GET_ANY_CHAR(series, index); // No casing!
if (ch1 == (REBCNT)VAL_INT32(item)) goto found1;
}
else goto bad_target;
}
next: // Check for | (required if not end)
blk++;
if (IS_PAREN(blk)) blk++;
if (IS_END(blk)) break;
if (!IS_OR_BAR(blk)) {
item = blk;
goto bad_target;
}
}
}
return NOT_FOUND;
found:
if (IS_PAREN(blk+1)) Do_Block_Value_Throw(blk+1);
return index;
found1:
if (IS_PAREN(blk+1)) Do_Block_Value_Throw(blk+1);
return index + (is_thru ? 1 : 0);
bad_target:
Trap1(RE_PARSE_RULE, item);
return 0;
}
//
// Transport_Actor: C
//
static REB_R Transport_Actor(struct Reb_Call *call_, REBSER *port, REBCNT action, enum Transport_Types proto)
{
REBREQ *sock; // IO request
REBVAL *spec; // port spec
REBVAL *arg; // action argument value
REBVAL *val; // e.g. port number value
REBINT result; // IO result
REBCNT refs; // refinement argument flags
REBCNT len; // generic length
REBSER *ser; // simplifier
Validate_Port(port, action);
*D_OUT = *D_ARG(1);
arg = DS_ARGC > 1 ? D_ARG(2) : NULL;
sock = cast(REBREQ*, Use_Port_State(port, RDI_NET, sizeof(*sock)));
if (proto == TRANSPORT_UDP) {
SET_FLAG(sock->modes, RST_UDP);
}
//Debug_Fmt("Sock: %x", sock);
spec = OFV(port, STD_PORT_SPEC);
if (!IS_OBJECT(spec)) fail (Error(RE_INVALID_PORT));
// sock->timeout = 4000; // where does this go? !!!
// HOW TO PREVENT OVERWRITE DURING BUSY OPERATION!!!
// Should it just ignore it or cause an error?
// Actions for an unopened socket:
if (!IS_OPEN(sock)) {
switch (action) { // Ordered by frequency
case A_OPEN:
arg = Obj_Value(spec, STD_PORT_SPEC_NET_HOST);
val = Obj_Value(spec, STD_PORT_SPEC_NET_PORT_ID);
if (OS_DO_DEVICE(sock, RDC_OPEN))
fail (Error_On_Port(RE_CANNOT_OPEN, port, -12));
SET_OPEN(sock);
// Lookup host name (an extra TCP device step):
if (IS_STRING(arg)) {
sock->common.data = VAL_BIN(arg);
sock->special.net.remote_port = IS_INTEGER(val) ? VAL_INT32(val) : 80;
result = OS_DO_DEVICE(sock, RDC_LOOKUP); // sets remote_ip field
if (result < 0)
fail (Error_On_Port(RE_NO_CONNECT, port, sock->error));
return R_OUT;
}
// Host IP specified:
else if (IS_TUPLE(arg)) {
sock->special.net.remote_port = IS_INTEGER(val) ? VAL_INT32(val) : 80;
memcpy(&sock->special.net.remote_ip, VAL_TUPLE(arg), 4);
break;
}
// No host, must be a LISTEN socket:
else if (IS_NONE(arg)) {
SET_FLAG(sock->modes, RST_LISTEN);
sock->common.data = 0; // where ACCEPT requests are queued
sock->special.net.local_port = IS_INTEGER(val) ? VAL_INT32(val) : 8000;
break;
}
else
fail (Error_On_Port(RE_INVALID_SPEC, port, -10));
case A_CLOSE:
return R_OUT;
case A_OPENQ:
return R_FALSE;
case A_UPDATE: // allowed after a close
break;
default:
fail (Error_On_Port(RE_NOT_OPEN, port, -12));
}
}
// Actions for an open socket:
switch (action) { // Ordered by frequency
case A_UPDATE:
// Update the port object after a READ or WRITE operation.
// This is normally called by the WAKE-UP function.
arg = OFV(port, STD_PORT_DATA);
if (sock->command == RDC_READ) {
if (ANY_BINSTR(arg)) VAL_TAIL(arg) += sock->actual;
}
else if (sock->command == RDC_WRITE) {
SET_NONE(arg); // Write is done.
}
return R_NONE;
case A_READ:
// Read data into a buffer, expanding the buffer if needed.
// If no length is given, program must stop it at some point.
refs = Find_Refines(call_, ALL_READ_REFS);
if (
!GET_FLAG(sock->modes, RST_UDP)
&& !GET_FLAG(sock->state, RSM_CONNECT)
) {
fail (Error_On_Port(RE_NOT_CONNECTED, port, -15));
}
// Setup the read buffer (allocate a buffer if needed):
arg = OFV(port, STD_PORT_DATA);
if (!IS_STRING(arg) && !IS_BINARY(arg)) {
Val_Init_Binary(arg, Make_Binary(NET_BUF_SIZE));
}
ser = VAL_SERIES(arg);
sock->length = SERIES_AVAIL(ser); // space available
if (sock->length < NET_BUF_SIZE/2) Extend_Series(ser, NET_BUF_SIZE);
sock->length = SERIES_AVAIL(ser);
sock->common.data = STR_TAIL(ser); // write at tail
//if (SERIES_TAIL(ser) == 0)
sock->actual = 0; // Actual for THIS read, not for total.
//Print("(max read length %d)", sock->length);
result = OS_DO_DEVICE(sock, RDC_READ); // recv can happen immediately
if (result < 0) fail (Error_On_Port(RE_READ_ERROR, port, sock->error));
break;
case A_WRITE:
// Write the entire argument string to the network.
// The lower level write code continues until done.
refs = Find_Refines(call_, ALL_WRITE_REFS);
if (!GET_FLAG(sock->modes, RST_UDP)
&& !GET_FLAG(sock->state, RSM_CONNECT))
fail (Error_On_Port(RE_NOT_CONNECTED, port, -15));
// Determine length. Clip /PART to size of string if needed.
spec = D_ARG(2);
len = VAL_LEN(spec);
if (refs & AM_WRITE_PART) {
REBCNT n = Int32s(D_ARG(ARG_WRITE_LIMIT), 0);
if (n <= len) len = n;
}
// Setup the write:
*OFV(port, STD_PORT_DATA) = *spec; // keep it GC safe
sock->length = len;
sock->common.data = VAL_BIN_DATA(spec);
sock->actual = 0;
//Print("(write length %d)", len);
result = OS_DO_DEVICE(sock, RDC_WRITE); // send can happen immediately
if (result < 0) fail (Error_On_Port(RE_WRITE_ERROR, port, sock->error));
if (result == DR_DONE) SET_NONE(OFV(port, STD_PORT_DATA));
break;
case A_PICK:
// FIRST server-port returns new port connection.
len = Get_Num_Arg(arg); // Position
if (len == 1 && GET_FLAG(sock->modes, RST_LISTEN) && sock->common.data)
Accept_New_Port(D_OUT, port, sock); // sets D_OUT
else
fail (Error_Out_Of_Range(arg));
break;
case A_QUERY:
// Get specific information - the scheme's info object.
// Special notation allows just getting part of the info.
Ret_Query_Net(port, sock, D_OUT);
break;
case A_OPENQ:
// Connect for clients, bind for servers:
if (sock->state & ((1<<RSM_CONNECT) | (1<<RSM_BIND))) return R_TRUE;
return R_FALSE;
case A_CLOSE:
if (IS_OPEN(sock)) {
OS_DO_DEVICE(sock, RDC_CLOSE);
SET_CLOSED(sock);
}
break;
case A_LENGTH:
arg = OFV(port, STD_PORT_DATA);
len = ANY_SERIES(arg) ? VAL_TAIL(arg) : 0;
SET_INTEGER(D_OUT, len);
break;
case A_OPEN:
result = OS_DO_DEVICE(sock, RDC_CONNECT);
if (result < 0)
fail (Error_On_Port(RE_NO_CONNECT, port, sock->error));
break;
case A_DELETE: // Temporary to TEST error handler!
{
REBVAL *event = Append_Event(); // sets signal
VAL_SET(event, REB_EVENT); // (has more space, if we need it)
VAL_EVENT_TYPE(event) = EVT_ERROR;
VAL_EVENT_DATA(event) = 101;
VAL_EVENT_REQ(event) = sock;
}
break;
default:
fail (Error_Illegal_Action(REB_PORT, action));
}
return R_OUT;
}
static REBFLG Print_Native_Modifying_Throws(
REBVAL *value, // Value may be modified. Contents must be GC-safe!
REBOOL newline
) {
if (IS_UNSET(value)) {
#if !defined(NDEBUG)
if (LEGACY(OPTIONS_PRINT_FORMS_EVERYTHING))
goto form_it;
#endif
// No effect (not even a newline). Previously this also was the
// behavior for NONE, but now that none is considered "reified" it
// does not opt out from rendering.
}
else if (IS_BINARY(value)) {
#if !defined(NDEBUG)
if (LEGACY(OPTIONS_PRINT_FORMS_EVERYTHING))
goto form_it;
#endif
// Send raw bytes to the console. CGI+ANSI+VT100 etc. require it
// for full 8-bit byte transport (UTF-8 is by definition not good
// enough...some bytes are illegal to occur in UTF-8 at all).
//
// Given that PRINT is not a general-purpose PROBE tool (it has
// never output values purely "as is", evaluating blocks for
// instance) it's worth doing a "strange" thing (though no stranger
// than WRITE) to be able to access the facility.
Prin_OS_String(VAL_BIN_DATA(value), VAL_LEN(value), OPT_ENC_RAW);
// !!! Binary print should never output a newline. This would seem
// more natural if PRINT's decision to output newlines was guided
// by whether it was given a block or not (under consideration).
}
else if (IS_BLOCK(value)) {
// !!! Pending plan for PRINT of BLOCK! is to do something like
// COMBINE where NONE! is elided, single characters are not spaced out,
// nested blocks are recursed, etc. So:
//
// print ["A" newline "B" if 1 > 2 [newline] if 1 < 2 ["C"]]]
//
// Would output the following (where _ is space):
//
// A
// B_C
//
// As opposed to historical output, which is:
//
// A_
// B_none_C
//
// Currently it effectively FORM REDUCEs the output.
if (Reduce_Block_Throws(
value, VAL_SERIES(value), VAL_INDEX(value), FALSE
)) {
return TRUE;
}
Prin_Value(value, 0, 0);
if (newline)
Print_OS_Line();
}
else {
#if !defined(NDEBUG)
form_it: // used only by OPTIONS_PRINT_FORMS_EVERYTHING
#endif
// !!! Full behavior review needed for all types.
Prin_Value(value, 0, 0);
if (newline)
Print_OS_Line();
}
return FALSE;
}
