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_AT(val);
if (VAL_BYTE_SIZE(val)) {
REBYTE *bp = VAL_BIN_AT(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_AT(val);
for (; len > 0; len--, up++)
if (*up > limit) return R_FALSE;
}
return R_TRUE;
}
static void reverse_string(REBVAL *value, REBCNT len)
{
REBCNT n;
REBCNT m;
REBUNI c;
if (VAL_BYTE_SIZE(value)) {
REBYTE *bp = VAL_BIN_AT(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_AT(value);
for (n = 0, m = len-1; n < len / 2; n++, m--) {
c = up[n];
up[n] = up[m];
up[m] = c;
}
}
}
//
// Cloak: C
//
// 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).
//
REBOOL Cloak(REBOOL decode, REBYTE *cp, REBCNT dlen, REBYTE *kp, REBCNT klen, REBOOL as_is)
{
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_AT(val);
klen = VAL_LEN_AT(val);
break;
case REB_STRING:
ser = Temp_Bin_Str_Managed(val, &i, &klen);
kp = BIN_AT(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;
}
//
// Complement_Binary: C
//
// Only valid for BINARY data.
//
REBSER *Complement_Binary(REBVAL *value)
{
const REBYTE *bp = VAL_BIN_AT(value);
REBCNT len = VAL_LEN_AT(value);
REBSER *bin = Make_Binary(len);
TERM_SEQUENCE_LEN(bin, len);
REBYTE *dp = BIN_HEAD(bin);
for (; len > 0; len--, ++bp, ++dp)
*dp = ~(*bp);
return bin;
}
//
// Bin_To_Money_May_Fail: C
//
// Will successfully convert or fail (longjmp) with an error.
//
void Bin_To_Money_May_Fail(REBVAL *result, REBVAL *val)
{
REBCNT len;
REBYTE buf[MAX_HEX_LEN+4] = {0}; // binary to convert
if (IS_BINARY(val)) {
len = VAL_LEN_AT(val);
if (len > 12) len = 12;
memcpy(buf, VAL_BIN_AT(val), len);
}
else
fail (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);
}
//
// Complement_Binary: C
//
// Only valid for BINARY data.
//
REBSER *Complement_Binary(REBVAL *value)
{
REBSER *series;
REBYTE *str = VAL_BIN_AT(value);
REBINT len = VAL_LEN_AT(value);
REBYTE *out;
series = Make_Binary(len);
SET_SERIES_LEN(series, len);
out = BIN_HEAD(series);
for (; len > 0; len--) {
*out++ = ~(*str);
++str;
}
return series;
}
static REBSER *MAKE_TO_String_Common(const REBVAL *arg)
{
REBSER *ser = 0;
// MAKE/TO <type> <binary!>
if (IS_BINARY(arg)) {
REBYTE *bp = VAL_BIN_AT(arg);
REBCNT len = VAL_LEN_AT(arg);
switch (What_UTF(bp, len)) {
case 0:
break;
case 8: // UTF-8 encoded
bp += 3;
len -= 3;
break;
default:
fail (Error(RE_BAD_UTF8));
}
ser = Decode_UTF_String(bp, len, 8); // UTF-8
}
// MAKE/TO <type> <any-string>
else if (ANY_BINSTR(arg)) {
ser = Copy_String_Slimming(VAL_SERIES(arg), VAL_INDEX(arg), VAL_LEN_AT(arg));
}
// MAKE/TO <type> <any-word>
else if (ANY_WORD(arg)) {
ser = Copy_Mold_Value(arg, 0 /* opts... MOPT_0? */);
}
// MAKE/TO <type> #"A"
else if (IS_CHAR(arg)) {
ser = (VAL_CHAR(arg) > 0xff) ? Make_Unicode(2) : Make_Binary(2);
Append_Codepoint_Raw(ser, VAL_CHAR(arg));
}
else
ser = Copy_Form_Value(arg, 1 << MOPT_TIGHT);
return ser;
}
void Set_Vector_Row(REBSER *ser, REBVAL *blk)
{
REBCNT idx = VAL_INDEX(blk);
REBCNT len = VAL_LEN_AT(blk);
RELVAL *val;
REBCNT n = 0;
REBCNT bits = VECT_TYPE(ser);
REBI64 i = 0;
REBDEC f = 0;
if (IS_BLOCK(blk)) {
val = VAL_ARRAY_AT(blk);
for (; NOT_END(val); val++) {
if (IS_INTEGER(val)) {
i = VAL_INT64(val);
if (bits > VTUI64) f = (REBDEC)(i);
}
else if (IS_DECIMAL(val)) {
f = VAL_DECIMAL(val);
if (bits <= VTUI64) i = (REBINT)(f);
}
else fail (Error_Invalid_Arg_Core(val, VAL_SPECIFIER(blk)));
//if (n >= ser->tail) Expand_Vector(ser);
set_vect(bits, SER_DATA_RAW(ser), n++, i, f);
}
}
else {
REBYTE *data = VAL_BIN_AT(blk);
for (; len > 0; len--, idx++) {
set_vect(
bits, SER_DATA_RAW(ser), n++, cast(REBI64, data[idx]), f
);
}
}
}
//
// MAKE_Tuple: C
//
REB_R MAKE_Tuple(
REBVAL *out,
enum Reb_Kind kind,
const REBVAL *opt_parent,
const REBVAL *arg
){
assert(kind == REB_TUPLE);
if (opt_parent)
fail (Error_Bad_Make_Parent(kind, opt_parent));
if (IS_TUPLE(arg))
return Move_Value(out, arg);
RESET_CELL(out, REB_TUPLE, CELL_MASK_NONE);
REBYTE *vp = VAL_TUPLE(out);
// !!! Net lookup parses IP addresses out of `tcp://93.184.216.34` or
// similar URL!s. In Rebol3 these captures come back the same type
// as the input instead of as STRING!, which was a latent bug in the
// network code of the 12-Dec-2012 release:
//
// https://github.com/rebol/rebol/blob/master/src/mezz/sys-ports.r#L110
//
// All attempts to convert a URL!-flavored IP address failed. Taking
// URL! here fixes it, though there are still open questions.
//
if (IS_TEXT(arg) or IS_URL(arg)) {
REBSIZ size;
const REBYTE *bp
= Analyze_String_For_Scan(&size, arg, MAX_SCAN_TUPLE);
if (Scan_Tuple(out, bp, size) == nullptr)
fail (arg);
return out;
}
if (ANY_ARRAY(arg)) {
REBCNT len = 0;
REBINT n;
RELVAL *item = VAL_ARRAY_AT(arg);
for (; NOT_END(item); ++item, ++vp, ++len) {
if (len >= MAX_TUPLE)
goto bad_make;
if (IS_INTEGER(item)) {
n = Int32(item);
}
else if (IS_CHAR(item)) {
n = VAL_CHAR(item);
}
else
goto bad_make;
if (n > 255 || n < 0)
goto bad_make;
*vp = n;
}
VAL_TUPLE_LEN(out) = len;
for (; len < MAX_TUPLE; len++) *vp++ = 0;
return out;
}
REBCNT alen;
if (IS_ISSUE(arg)) {
REBSTR *spelling = VAL_STRING(arg);
const REBYTE *ap = STR_HEAD(spelling);
size_t size = STR_SIZE(spelling); // UTF-8 len
if (size & 1)
fail (arg); // must have even # of chars
size /= 2;
if (size > MAX_TUPLE)
fail (arg); // valid even for UTF-8
VAL_TUPLE_LEN(out) = size;
for (alen = 0; alen < size; alen++) {
REBYTE decoded;
if ((ap = Scan_Hex2(&decoded, ap)) == NULL)
fail (arg);
*vp++ = decoded;
}
}
else if (IS_BINARY(arg)) {
REBYTE *ap = VAL_BIN_AT(arg);
REBCNT len = VAL_LEN_AT(arg);
if (len > MAX_TUPLE) len = MAX_TUPLE;
VAL_TUPLE_LEN(out) = len;
for (alen = 0; alen < len; alen++) *vp++ = *ap++;
}
else
fail (arg);
for (; alen < MAX_TUPLE; alen++) *vp++ = 0;
return out;
bad_make:
fail (Error_Bad_Make(REB_TUPLE, arg));
}
//
// Xandor_Binary: C
//
// Only valid for BINARY data.
//
REBSER *Xandor_Binary(REBCNT action, REBVAL *value, REBVAL *arg)
{
REBSER *series;
REBYTE *p0 = VAL_BIN_AT(value);
REBYTE *p1 = VAL_BIN_AT(arg);
REBYTE *p2;
REBCNT i;
REBCNT mt, t1, t0, t2;
t0 = VAL_LEN_AT(value);
t1 = VAL_LEN_AT(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);
if (IS_BITSET(value)) {
//
// Although bitsets and binaries share some implementation here,
// they have distinct allocation functions...and bitsets need
// to set the REBSER.misc.negated union field (BITS_NOT) as
// it would be illegal to read it if it were cleared via another
// element of the union.
//
assert(IS_BITSET(arg));
series = Make_Bitset(t2 * 8);
}
else {
// Ordinary binary
//
series = Make_Binary(t2);
SET_SERIES_LEN(series, t2);
}
p2 = BIN_HEAD(series);
switch (action) {
case SYM_AND_T: // and~
for (i = 0; i < mt; i++) *p2++ = *p0++ & *p1++;
CLEAR(p2, t2 - mt);
return series;
case SYM_OR_T: // or~
for (i = 0; i < mt; i++) *p2++ = *p0++ | *p1++;
break;
case SYM_XOR_T: // 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;
}
//
// Temp_Bin_Str_Managed: C
//
// Determines if UTF8 conversion is needed for a series before it
// is used with a byte-oriented function.
//
// If conversion is needed, a UTF8 series will be created. Otherwise,
// the source series is returned as-is.
//
// Note: This routine should only be used to generate a value used
// for temporary purposes, because it has a "surprising variance"
// regarding its input. If the value's series can be reused, it is--
// and this depends on an implementation detail of internal encoding
// that the user should not be aware of (they need not know if the
// internal representation of an ASCII string uses 1, 2, or however
// many bytes). But copying vs. non-copying means the resulting
// data might or might not have previous values available to step
// back into from the originating series!
//
// !!! Should performance dictate it, the callsites could be
// adapted to know whether this produced a new series or not, and
// instead of managing a created result they could be responsible
// for freeing it if so.
//
REBSER *Temp_Bin_Str_Managed(const REBVAL *val, REBCNT *index, REBCNT *length)
{
REBCNT len = (length && *length) ? *length : VAL_LEN_AT(val);
REBSER *series;
assert(IS_BINARY(val) || ANY_STRING(val));
// !!! This used to check `len == 0` and reuse a zero length string.
// However, the zero length string could have the wrong width. We are
// expected to be returning a BYTE_SIZE() string, and that confused
// things. It's not a good idea to mutate the source string (e.g.
// reallocate under a new width) so consider having an EMPTY_BYTE_STRING
// like EMPTY_ARRAY which is protected to hand back.
//
if (
IS_BINARY(val)
|| (
VAL_BYTE_SIZE(val)
&& All_Bytes_ASCII(VAL_BIN_AT(val), VAL_LEN_AT(val))
)
){
//
// It's BINARY!, or an ANY-STRING! whose codepoints are all values in
// ASCII (0x00 => 0x7F), hence not needing any UTF-8 encoding.
//
series = VAL_SERIES(val);
ASSERT_SERIES_MANAGED(series);
if (index)
*index = VAL_INDEX(val);
if (length)
*length = len;
}
else {
// UTF-8 conversion is required, and we manage the result.
series = Make_UTF8_From_Any_String(val, len, OPT_ENC_CRLF_MAYBE);
MANAGE_SERIES(series);
#if !defined(NDEBUG)
//
// Also, PROTECT the result in the debug build...because since the
// caller doesn't know if a new series was created or if the initial
// data is being used, they should not be modifying it! (We don't
// want to protect the original data, because we wouldn't know when
// we were allowed to unlock it...there's no later call in this
// model to clean up the series.)
{
REBVAL protect;
Val_Init_String(&protect, series);
Protect_Value(&protect, FLAGIT(PROT_SET));
// just a string...not /DEEP...shouldn't need to Unmark()
}
#endif
if (index)
*index = 0;
if (length)
*length = SER_LEN(series);
}
assert(BYTE_SIZE(series));
return series;
}
//
// MAKE_Tuple: C
//
void MAKE_Tuple(REBVAL *out, enum Reb_Kind type, const REBVAL *arg)
{
if (IS_TUPLE(arg)) {
*out = *arg;
return;
}
VAL_RESET_HEADER(out, REB_TUPLE);
REBYTE *vp = VAL_TUPLE(out);
// !!! Net lookup parses IP addresses out of `tcp://93.184.216.34` or
// similar URL!s. In Rebol3 these captures come back the same type
// as the input instead of as STRING!, which was a latent bug in the
// network code of the 12-Dec-2012 release:
//
// https://github.com/rebol/rebol/blob/master/src/mezz/sys-ports.r#L110
//
// All attempts to convert a URL!-flavored IP address failed. Taking
// URL! here fixes it, though there are still open questions.
//
if (IS_STRING(arg) || IS_URL(arg)) {
REBCNT len;
REBYTE *ap = Temp_Byte_Chars_May_Fail(arg, MAX_SCAN_TUPLE, &len, FALSE);
if (Scan_Tuple(ap, len, out))
return;
goto bad_arg;
}
if (ANY_ARRAY(arg)) {
REBCNT len = 0;
REBINT n;
RELVAL *item = VAL_ARRAY_AT(arg);
for (; NOT_END(item); ++item, ++vp, ++len) {
if (len >= MAX_TUPLE) goto bad_make;
if (IS_INTEGER(item)) {
n = Int32(item);
}
else if (IS_CHAR(item)) {
n = VAL_CHAR(item);
}
else
goto bad_make;
if (n > 255 || n < 0) goto bad_make;
*vp = n;
}
VAL_TUPLE_LEN(out) = len;
for (; len < MAX_TUPLE; len++) *vp++ = 0;
return;
}
REBCNT alen;
if (IS_ISSUE(arg)) {
REBUNI c;
const REBYTE *ap = VAL_WORD_HEAD(arg);
REBCNT len = LEN_BYTES(ap); // UTF-8 len
if (len & 1) goto bad_arg; // must have even # of chars
len /= 2;
if (len > MAX_TUPLE) goto bad_arg; // valid even for UTF-8
VAL_TUPLE_LEN(out) = len;
for (alen = 0; alen < len; alen++) {
const REBOOL unicode = FALSE;
if (!Scan_Hex2(ap, &c, unicode)) goto bad_arg;
*vp++ = cast(REBYTE, c);
ap += 2;
}
}
else if (IS_BINARY(arg)) {
REBYTE *ap = VAL_BIN_AT(arg);
REBCNT len = VAL_LEN_AT(arg);
if (len > MAX_TUPLE) len = MAX_TUPLE;
VAL_TUPLE_LEN(out) = len;
for (alen = 0; alen < len; alen++) *vp++ = *ap++;
}
else goto bad_arg;
for (; alen < MAX_TUPLE; alen++) *vp++ = 0;
return;
bad_arg:
fail (Error_Invalid_Arg(arg));
bad_make:
fail (Error_Bad_Make(REB_TUPLE, arg));
}
//
// Xandor_Binary: C
//
// Only valid for BINARY data.
//
REBSER *Xandor_Binary(const REBVAL *verb, REBVAL *value, REBVAL *arg)
{
REBYTE *p0 = VAL_BIN_AT(value);
REBYTE *p1 = VAL_BIN_AT(arg);
REBCNT t0 = VAL_LEN_AT(value);
REBCNT t1 = VAL_LEN_AT(arg);
REBCNT mt = MIN(t0, t1); // smaller array size
// !!! This used to say "For AND - result is size of shortest input:" but
// the code was commented out
/*
if (verb == A_AND || (verb == 0 && t1 >= t0))
t2 = mt;
else
t2 = MAX(t0, t1);
*/
REBCNT t2 = MAX(t0, t1);
REBSER *series;
if (IS_BITSET(value)) {
//
// Although bitsets and binaries share some implementation here,
// they have distinct allocation functions...and bitsets need
// to set the REBSER.misc.negated union field (BITS_NOT) as
// it would be illegal to read it if it were cleared via another
// element of the union.
//
assert(IS_BITSET(arg));
series = Make_Bitset(t2 * 8);
}
else {
// Ordinary binary
//
series = Make_Binary(t2);
TERM_SEQUENCE_LEN(series, t2);
}
REBYTE *p2 = BIN_HEAD(series);
switch (VAL_WORD_SYM(verb)) {
case SYM_INTERSECT: { // and
REBCNT i;
for (i = 0; i < mt; i++)
*p2++ = *p0++ & *p1++;
CLEAR(p2, t2 - mt);
return series; }
case SYM_UNION: { // or
REBCNT i;
for (i = 0; i < mt; i++)
*p2++ = *p0++ | *p1++;
break; }
case SYM_DIFFERENCE: { // xor
REBCNT i;
for (i = 0; i < mt; i++)
*p2++ = *p0++ ^ *p1++;
break; }
case SYM_EXCLUDE: { // !!! not a "type action", word manually in %words.r
REBCNT i;
for (i = 0; i < mt; i++)
*p2++ = *p0++ & ~*p1++;
if (t0 > t1)
memcpy(p2, p0, t0 - t1); // residual from first only
return series; }
default:
fail (Error_Cannot_Use_Raw(verb, Datatype_From_Kind(REB_BINARY)));
}
// Copy the residual
//
memcpy(p2, ((t0 > t1) ? p0 : p1), t2 - mt);
return series;
}
//
// Serial_Actor: C
//
static REB_R Serial_Actor(REBFRM *frame_, REBCTX *port, REBSYM action)
{
REBREQ *req; // 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
REBVAL *path;
Validate_Port(port, action);
*D_OUT = *D_ARG(1);
// Validate PORT fields:
spec = CTX_VAR(port, STD_PORT_SPEC);
if (!IS_OBJECT(spec)) fail (Error(RE_INVALID_PORT));
path = Obj_Value(spec, STD_PORT_SPEC_HEAD_REF);
if (!path) fail (Error(RE_INVALID_SPEC, spec));
//if (!IS_FILE(path)) fail (Error(RE_INVALID_SPEC, path));
req = cast(REBREQ*, Use_Port_State(port, RDI_SERIAL, sizeof(*req)));
// Actions for an unopened serial port:
if (!IS_OPEN(req)) {
switch (action) {
case SYM_OPEN:
arg = Obj_Value(spec, STD_PORT_SPEC_SERIAL_PATH);
if (! (IS_FILE(arg) || IS_STRING(arg) || IS_BINARY(arg)))
fail (Error(RE_INVALID_PORT_ARG, arg));
req->special.serial.path = ALLOC_N(REBCHR, MAX_SERIAL_DEV_PATH);
OS_STRNCPY(
req->special.serial.path,
//
// !!! This is assuming VAL_DATA contains native chars.
// Should it? (2 bytes on windows, 1 byte on linux/mac)
//
SER_AT(REBCHR, VAL_SERIES(arg), VAL_INDEX(arg)),
MAX_SERIAL_DEV_PATH
);
arg = Obj_Value(spec, STD_PORT_SPEC_SERIAL_SPEED);
if (! IS_INTEGER(arg))
fail (Error(RE_INVALID_PORT_ARG, arg));
req->special.serial.baud = VAL_INT32(arg);
//Secure_Port(SYM_SERIAL, ???, path, ser);
arg = Obj_Value(spec, STD_PORT_SPEC_SERIAL_DATA_SIZE);
if (!IS_INTEGER(arg)
|| VAL_INT64(arg) < 5
|| VAL_INT64(arg) > 8
) {
fail (Error(RE_INVALID_PORT_ARG, arg));
}
req->special.serial.data_bits = VAL_INT32(arg);
arg = Obj_Value(spec, STD_PORT_SPEC_SERIAL_STOP_BITS);
if (!IS_INTEGER(arg)
|| VAL_INT64(arg) < 1
|| VAL_INT64(arg) > 2
) {
fail (Error(RE_INVALID_PORT_ARG, arg));
}
req->special.serial.stop_bits = VAL_INT32(arg);
arg = Obj_Value(spec, STD_PORT_SPEC_SERIAL_PARITY);
if (IS_BLANK(arg)) {
req->special.serial.parity = SERIAL_PARITY_NONE;
} else {
if (!IS_WORD(arg))
fail (Error(RE_INVALID_PORT_ARG, arg));
switch (VAL_WORD_SYM(arg)) {
case SYM_ODD:
req->special.serial.parity = SERIAL_PARITY_ODD;
break;
case SYM_EVEN:
req->special.serial.parity = SERIAL_PARITY_EVEN;
break;
default:
fail (Error(RE_INVALID_PORT_ARG, arg));
}
}
arg = Obj_Value(spec, STD_PORT_SPEC_SERIAL_FLOW_CONTROL);
if (IS_BLANK(arg)) {
req->special.serial.flow_control = SERIAL_FLOW_CONTROL_NONE;
} else {
if (!IS_WORD(arg))
fail (Error(RE_INVALID_PORT_ARG, arg));
switch (VAL_WORD_SYM(arg)) {
case SYM_HARDWARE:
req->special.serial.flow_control = SERIAL_FLOW_CONTROL_HARDWARE;
break;
case SYM_SOFTWARE:
req->special.serial.flow_control = SERIAL_FLOW_CONTROL_SOFTWARE;
break;
default:
fail (Error(RE_INVALID_PORT_ARG, arg));
}
}
if (OS_DO_DEVICE(req, RDC_OPEN))
fail (Error_On_Port(RE_CANNOT_OPEN, port, -12));
SET_OPEN(req);
return R_OUT;
case SYM_CLOSE:
return R_OUT;
case SYM_OPEN_Q:
return R_FALSE;
default:
fail (Error_On_Port(RE_NOT_OPEN, port, -12));
}
}
// Actions for an open socket:
switch (action) {
case SYM_READ:
refs = Find_Refines(frame_, ALL_READ_REFS);
// Setup the read buffer (allocate a buffer if needed):
arg = CTX_VAR(port, STD_PORT_DATA);
if (!IS_STRING(arg) && !IS_BINARY(arg)) {
Val_Init_Binary(arg, Make_Binary(32000));
}
ser = VAL_SERIES(arg);
req->length = SER_AVAIL(ser); // space available
if (req->length < 32000/2) Extend_Series(ser, 32000);
req->length = SER_AVAIL(ser);
// This used STR_TAIL (obsolete, equivalent to BIN_TAIL) but was it
// sure the series was byte sized? Added in a check.
assert(BYTE_SIZE(ser));
req->common.data = BIN_TAIL(ser); // write at tail
//if (SER_LEN(ser) == 0)
req->actual = 0; // Actual for THIS read, not for total.
#ifdef DEBUG_SERIAL
printf("(max read length %d)", req->length);
#endif
result = OS_DO_DEVICE(req, RDC_READ); // recv can happen immediately
if (result < 0) fail (Error_On_Port(RE_READ_ERROR, port, req->error));
#ifdef DEBUG_SERIAL
for (len = 0; len < req->actual; len++) {
if (len % 16 == 0) printf("\n");
printf("%02x ", req->common.data[len]);
}
printf("\n");
#endif
*D_OUT = *arg;
return R_OUT;
case SYM_WRITE:
refs = Find_Refines(frame_, ALL_WRITE_REFS);
// Determine length. Clip /PART to size of string if needed.
spec = D_ARG(2);
len = VAL_LEN_AT(spec);
if (refs & AM_WRITE_PART) {
REBCNT n = Int32s(D_ARG(ARG_WRITE_LIMIT), 0);
if (n <= len) len = n;
}
// Setup the write:
*CTX_VAR(port, STD_PORT_DATA) = *spec; // keep it GC safe
req->length = len;
req->common.data = VAL_BIN_AT(spec);
req->actual = 0;
//Print("(write length %d)", len);
result = OS_DO_DEVICE(req, RDC_WRITE); // send can happen immediately
if (result < 0) fail (Error_On_Port(RE_WRITE_ERROR, port, req->error));
break;
case SYM_UPDATE:
// Update the port object after a READ or WRITE operation.
// This is normally called by the WAKE-UP function.
arg = CTX_VAR(port, STD_PORT_DATA);
if (req->command == RDC_READ) {
if (ANY_BINSTR(arg)) {
SET_SERIES_LEN(
VAL_SERIES(arg),
VAL_LEN_HEAD(arg) + req->actual
);
}
}
else if (req->command == RDC_WRITE) {
SET_BLANK(arg); // Write is done.
}
return R_BLANK;
case SYM_OPEN_Q:
return R_TRUE;
case SYM_CLOSE:
if (IS_OPEN(req)) {
OS_DO_DEVICE(req, RDC_CLOSE);
SET_CLOSED(req);
}
break;
default:
fail (Error_Illegal_Action(REB_PORT, action));
}
return R_OUT;
}
static REBSER *make_binary(const 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_AT(arg), VAL_LEN_AT(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 = Make_UTF8_From_Any_String(arg, VAL_LEN_AT(arg), 0);
break;
case REB_BLOCK:
// Join_Binary returns a shared buffer, so produce a copy:
ser = Copy_Sequence(Join_Binary(arg, -1));
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);
TERM_SEQUENCE_LEN(ser, Encode_UTF8_Char(BIN_HEAD(ser), VAL_CHAR(arg)));
break;
// MAKE/TO BINARY! <bitset!>
case REB_BITSET:
ser = Copy_Bytes(VAL_BIN(arg), VAL_LEN_HEAD(arg));
break;
// MAKE/TO BINARY! <image!>
case REB_IMAGE:
ser = Make_Image_Binary(arg);
break;
case REB_MONEY:
ser = Make_Binary(12);
deci_to_binary(BIN_HEAD(ser), VAL_MONEY_AMOUNT(arg));
TERM_SEQUENCE_LEN(ser, 12);
break;
default:
ser = 0;
}
return ser;
}
static REBCNT find_string(
REBSER *series,
REBCNT index,
REBCNT end,
REBVAL *target,
REBCNT target_len,
REBCNT flags,
REBINT skip
) {
assert(end >= index);
if (target_len > end - index) // series not long enough to have target
return NOT_FOUND;
REBCNT start = index;
if (flags & (AM_FIND_REVERSE | AM_FIND_LAST)) {
skip = -1;
start = 0;
if (flags & AM_FIND_LAST) index = end - target_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_AT(target),
target_len,
NOT(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),
target_len,
flags & (AM_FIND_MATCH|AM_FIND_CASE)
);
}
}
else if (IS_BINARY(target)) {
const REBOOL uncase = FALSE;
return Find_Byte_Str(
series,
start,
VAL_BIN_AT(target),
target_len,
uncase, // "don't treat case insensitively"
GET_FLAG(flags, ARG_FIND_MATCH - 1)
);
}
else if (IS_CHAR(target)) {
return Find_Str_Char(
VAL_CHAR(target),
series,
start,
index,
end,
skip,
flags
);
}
else if (IS_INTEGER(target)) {
return Find_Str_Char(
cast(REBUNI, VAL_INT32(target)),
series,
start,
index,
end,
skip,
flags
);
}
else if (IS_BITSET(target)) {
return Find_Str_Bitset(
series,
start,
index,
end,
skip,
VAL_SERIES(target),
flags
);
}
return NOT_FOUND;
}
