*/ RL_API REBYTE *RL_Word_String(u32 word)
/*
** Return a string related to a given global word identifier.
**
** Returns:
** A copy of the word string, null terminated.
** Arguments:
** word - a global word identifier
** Notes:
** The result is a null terminated copy of the name for your own use.
** The string is always UTF-8 encoded (chars > 127 are encoded.)
** In this API, word identifiers are always canonical. Therefore,
** the returned string may have different spelling/casing than expected.
** The string is allocated with OS_ALLOC and you can OS_FREE it any time.
**
***********************************************************************/
{
REBYTE *s1, *s2;
// !!This code should use a function from c-words.c (but nothing perfect yet.)
if (word == 0 || word >= PG_Word_Table.series->tail) return 0;
s1 = VAL_SYM_NAME(BLK_SKIP(PG_Word_Table.series, word));
s2 = OS_ALLOC_ARRAY(REBYTE, LEN_BYTES(s1) + 1);
COPY_BYTES(s2, s1, LEN_BYTES(s1) + 1);
return s2;
}
//
// RL_Word_String: C
//
// Return a string related to a given global word identifier.
//
// Returns:
// A copy of the word string, null terminated.
// Arguments:
// word - a global word identifier
// Notes:
// The result is a null terminated copy of the name for your own use.
// The string is always UTF-8 encoded (chars > 127 are encoded.)
// In this API, word identifiers are always canonical. Therefore,
// the returned string may have different spelling/casing than expected.
// The string is allocated with OS_ALLOC and you can OS_FREE it any time.
//
RL_API REBYTE *RL_Word_String(u32 word)
{
REBYTE *s1, *s2;
// !!This code should use a function from c-words.c (but nothing perfect yet.)
if (word == 0 || word >= ARR_LEN(PG_Word_Table.array)) return 0;
s1 = VAL_SYM_NAME(ARR_AT(PG_Word_Table.array, word));
s2 = OS_ALLOC_N(REBYTE, LEN_BYTES(s1) + 1);
COPY_BYTES(s2, s1, LEN_BYTES(s1) + 1);
return s2;
}
*/ REBINT Emit_Integer(REBYTE *buf, REBI64 val)
/*
***********************************************************************/
{
INT_TO_STR(val, buf);
return LEN_BYTES(buf);
}
*/ void Put_Str(REBYTE *buf)
/*
** Outputs a null terminated UTF-8 string.
** If buf is larger than StdIO Device allows, error out.
** OS dependent line termination must be done prior to call.
**
** !!! A request should ideally have a way to enforce that it is not
** going to modify the data. We currently require the caller to
** pass us data that could be written to, but "promise not to"
** since it is a RDC_WRITE operation. To stay on the right side
** of the compiler, use a strdup()/free() instead of an m_cast.
**
***********************************************************************/
{
/* This function could be called by signal handler and inside of Fetch_Buf */
REBREQ req;
memcpy(&req, &Std_IO_Req, sizeof(req));
req.length = LEN_BYTES(buf);
req.common.data = buf;
req.actual = 0;
OS_Do_Device(&req, RDC_WRITE);
if (req.error) Host_Crash("stdio write");
}
static int Fetch_Buf()
{
REBCNT len = LEN_BYTES(inbuf);
Std_IO_Req.common.data = inbuf + len;
Std_IO_Req.length = inbuf_len - len - 1;
Std_IO_Req.actual = 0;
OS_Do_Device(&Std_IO_Req, RDC_READ);
// If error, don't crash, just ignore it:
if (Std_IO_Req.error) return 0; //Host_Crash("stdio read");
// Terminate (LF) last line?
if (len > 0 && Std_IO_Req.actual == 0) {
inbuf[len++] = LF;
inbuf[len] = 0;
return TRUE;
}
// Null terminate buffer:
len = Std_IO_Req.actual;
Std_IO_Req.common.data[len] = 0;
return len > 0;
}
//
// RL_Do_Binary: C
//
// Evaluate an encoded binary script such as compressed text.
//
// Returns:
// The datatype of the result or zero if error in the encoding.
// Arguments:
// bin - by default, a REBOL compressed UTF-8 (or ASCII) script.
// length - the length of the data.
// flags - special flags (set to zero at this time).
// key - encoding, encryption, or signature key.
// result - value returned from evaluation.
// Notes:
// As of A104, only compressed scripts are supported, however,
// rebin, cloaked, signed, and encrypted formats will be supported.
//
RL_API int RL_Do_Binary(
int *exit_status,
const REBYTE *bin,
REBINT length,
REBCNT flags,
REBCNT key,
RXIARG *out
) {
REBSER *text;
#ifdef DUMP_INIT_SCRIPT
int f;
#endif
int maybe_rxt; // could be REBRXT, or negative number for error :-/
text = Decompress(bin, length, -1, FALSE, FALSE);
if (!text) return 0;
Append_Codepoint_Raw(text, 0);
#ifdef DUMP_INIT_SCRIPT
f = _open("host-boot.r", _O_CREAT | _O_RDWR, _S_IREAD | _S_IWRITE );
_write(f, BIN_HEAD(text), LEN_BYTES(BIN_HEAD(text)));
_close(f);
#endif
PUSH_GUARD_SERIES(text);
maybe_rxt = RL_Do_String(exit_status, BIN_HEAD(text), flags, out);
DROP_GUARD_SERIES(text);
Free_Series(text);
return maybe_rxt;
}
*/ void Init_Mold(REBCNT size)
/*
***********************************************************************/
{
REBYTE *cp;
REBYTE c;
const REBYTE *dc;
Set_Root_Series(TASK_MOLD_LOOP, Make_Block(size/10), "mold loop");
Set_Root_Series(TASK_BUF_MOLD, Make_Unicode(size), "mold buffer");
// Create quoted char escape table:
Char_Escapes = cp = ALLOC_ARRAY_ZEROFILL(REBYTE, MAX_ESC_CHAR + 1);
for (c = '@'; c <= '_'; c++) *cp++ = c;
Char_Escapes[cast(REBYTE, TAB)] = '-';
Char_Escapes[cast(REBYTE, LF)] = '/';
Char_Escapes[cast(REBYTE, '"')] = '"';
Char_Escapes[cast(REBYTE, '^')] = '^';
URL_Escapes = cp = ALLOC_ARRAY_ZEROFILL(REBYTE, MAX_URL_CHAR + 1);
//for (c = 0; c <= MAX_URL_CHAR; c++) if (IS_LEX_DELIMIT(c)) cp[c] = ESC_URL;
for (c = 0; c <= ' '; c++) cp[c] = ESC_URL | ESC_FILE;
dc = cb_cast(";%\"()[]{}<>");
for (c = LEN_BYTES(dc); c > 0; c--) URL_Escapes[*dc++] = ESC_URL | ESC_FILE;
}
*/ void Debug_String(const void *p, REBCNT len, REBOOL uni, REBINT lines)
/*
***********************************************************************/
{
REBUNI uc;
const REBYTE *bp = uni ? NULL : cast(const REBYTE *, p);
const REBUNI *up = uni ? cast(const REBUNI *, p) : NULL;
if (Trace_Limit > 0) {
if (Trace_Buffer->tail >= Trace_Limit)
Remove_Series(Trace_Buffer, 0, 2000);
if (len == UNKNOWN) len = uni ? Strlen_Uni(up) : LEN_BYTES(bp);
// !!! account for unicode!
for (; len > 0; len--) {
uc = uni ? *up++ : *bp++;
Append_Byte(Trace_Buffer, uc);
}
//Append_Unencoded_Len(Trace_Buffer, bp, len);
for (; lines > 0; lines--) Append_Byte(Trace_Buffer, LF);
}
else {
Prin_OS_String(p, len, uni);
for (; lines > 0; lines--) Print_OS_Line();
}
}
*/ void Init_Mold(REBCNT size)
/*
***********************************************************************/
{
REBYTE *cp;
REBYTE c;
REBYTE *dc;
Set_Root_Series(TASK_MOLD_LOOP, Make_Block(size/10), "mold loop");
Set_Root_Series(TASK_BUF_MOLD, Make_Unicode(size), "mold buffer");
// Create quoted char escape table:
Char_Escapes = cp = Make_Mem(MAX_ESC_CHAR+1); // cleared
for (c = '@'; c <= '_'; c++) *cp++ = c;
Char_Escapes[TAB] = '-';
Char_Escapes[LF] = '/';
Char_Escapes['"'] = '"';
Char_Escapes['^'] = '^';
URL_Escapes = cp = Make_Mem(MAX_URL_CHAR+1); // cleared
//for (c = 0; c <= MAX_URL_CHAR; c++) if (IS_LEX_DELIMIT(c)) cp[c] = ESC_URL;
for (c = 0; c <= ' '; c++) cp[c] = ESC_URL | ESC_FILE;
dc = ";%\"()[]{}<>";
for (c = LEN_BYTES(dc); c > 0; c--) URL_Escapes[*dc++] = ESC_URL | ESC_FILE;
}
*/ 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;
}
*/ REBYTE *Form_Integer(REBYTE *buf, REBI64 val)
/*
** Form standard REBOL integer value (32 or 64).
** Make sure you have room in your buffer before calling this!
**
***********************************************************************/
{
INT_TO_STR(val, buf);
return buf+LEN_BYTES(buf);
}
*/ REBCNT Encode_UTF8(REBYTE *dst, REBINT max, void *src, REBCNT *len, REBFLG uni, REBFLG ccr)
/*
** Encode the unicode into UTF8 byte string.
**
** Source string can be byte or unichar sized (uni = TRUE);
** Max is the maximum size of the result (UTF8).
** Returns number of source chars used.
** Updates len for dst bytes used.
** Does not add a terminator.
**
***********************************************************************/
{
REBUNI c;
REBINT n;
REBYTE buf[8];
REBYTE *bs = dst; // save start
REBYTE *bp = (REBYTE*)src;
REBUNI *up = (REBUNI*)src;
REBCNT cnt;
if (len) cnt = *len;
else {
cnt = (REBCNT)(uni ? wcslen((const wchar_t*)bp) : LEN_BYTES((REBYTE*)bp));
}
for (; max > 0 && cnt > 0; cnt--) {
c = uni ? *up++ : *bp++;
if (c < 0x80) {
#if defined(TO_WINDOWS)
if (ccr && c == LF) {
// If there's not room, don't try to output CRLF
if (2 > max) {up--; break;}
*dst++ = CR;
max--;
c = LF;
}
#endif
*dst++ = (REBYTE)c;
max--;
}
else {
n = Encode_UTF8_Char(buf, c);
if (n > max) {up--; break;}
memcpy(dst, buf, n);
dst += n;
max -= n;
}
}
if (len) *len = dst - bs;
return uni ? up - (REBUNI*)src : bp - (REBYTE*)src;
}
int main() {
time_t t;
srand((unsigned) time(&t));
unsigned int id = rand(), i;
char cname[CNAME_MAX_SIZE], time[TIME_BUFFER_SIZE], valid[TIME_BUFFER_SIZE], csr[CSR_MAX_SIZE], csr_cpy[CSR_MAX_SIZE], certificate[CERTIFICATE_MAX_SIZE], certificate_cpy[CERTIFICATE_MAX_SIZE];
unsigned char auth_key[SMQV_PKEY_SIZE], token_keypair[MSS_SKEY_SIZE + MSS_PKEY_SIZE], token_skey[MSS_SKEY_SIZE], token_pkey[MSS_PKEY_SIZE], csr_signature[MSS_SIGNATURE_SIZE], signature[ECDSA_SIGNATURE_SIZE];
// valid: 3333XXXXXXXXXX
now(&valid);
valid[0] = '3';
valid[1] = '3';
valid[2] = '3';
valid[3] = '3';
sprintf(cname, "TESTE do CERTIFICATE");
unsigned char seed[LEN_BYTES(MSS_SEC_LVL)] = {0x30,0x31,0x32,0x33,0x34,0x35,0x36,0x37,0x38,0x39,0x3A,0x3B,0x3C,0x3D,0x3E,0x3F};
memcpy(token_keypair, mss_keygen(seed), MSS_SKEY_SIZE + MSS_PKEY_SIZE);
memcpy(token_skey, token_keypair, MSS_SKEY_SIZE);
memcpy(token_pkey, token_keypair + MSS_SKEY_SIZE, MSS_PKEY_SIZE);
for(i = 0; i < SMQV_PKEY_SIZE; i++)
auth_key[i] = rand();
/**
* CSR
*/
generate_csr(id, cname, auth_key, token_pkey, token_skey, csr);
if(read_csr(&id, cname, time, auth_key, token_pkey, csr_signature, csr))
printf("CSR generation/read - OK\n");
else
printf("CSR generation/read - Fail\n");
printf("\n");
/**
* CERTIFICATE
*/
unsigned char ca_skey[ECDSA_SKEY_SIZE], ca_pkey[ECDSA_PKEY_SIZE];
ecdsa_keygen(ca_skey, ca_pkey);
generate_certificate(csr, valid, ca_skey, certificate);
if(read_certificate(&id, cname, time, valid, auth_key, token_pkey, signature, ca_pkey, certificate))
printf("CERTIFICATE generation/read - OK\n");
else
printf("CERTIFICATE generation/read - Fail\n");
printf("\n");
return 0;
}
//
// 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;
}
*/ static void Prin_OS_String(const void *p, REBCNT len, REBOOL uni)
/*
** Print a string, but no line terminator or space.
**
** The width of the input is specified by UNI.
**
***********************************************************************/
{
#define BUF_SIZE 1024
REBYTE buffer[BUF_SIZE]; // on stack
REBYTE *buf = &buffer[0];
REBINT n;
REBCNT len2;
const REBYTE *bp = uni ? NULL : cast(const REBYTE *, p);
const REBUNI *up = uni ? cast(const REBUNI *, p) : NULL;
if (!p) Panic(RP_NO_PRINT_PTR);
// Determine length if not provided:
if (len == UNKNOWN) len = uni ? Strlen_Uni(up) : LEN_BYTES(bp);
SET_FLAG(Req_SIO->flags, RRF_FLUSH);
Req_SIO->actual = 0;
Req_SIO->common.data = buf;
buffer[0] = 0; // for debug tracing
while ((len2 = len) > 0) {
Do_Signals();
// returns # of chars, size returns buf bytes output
n = Encode_UTF8(
buf,
BUF_SIZE-4,
uni ? cast(const void *, up) : cast(const void *, bp),
&len2,
uni,
OS_CRLF
);
if (n == 0) break;
Req_SIO->length = len2; // byte size of buffer
if (uni) up += n; else bp += n;
len -= n;
OS_DO_DEVICE(Req_SIO, RDC_WRITE);
if (Req_SIO->error) Panic(RP_IO_ERROR);
}
}
*/ RL_API int RL_Do_Binary(REBYTE *bin, REBINT length, REBCNT flags, REBCNT key, RXIARG *result)
/*
** Evaluate an encoded binary script such as compressed text.
**
** Returns:
** The datatype of the result or zero if error in the encoding.
** Arguments:
** bin - by default, a REBOL compressed UTF-8 (or ASCII) script.
** length - the length of the data.
** flags - special flags (set to zero at this time).
** key - encoding, encryption, or signature key.
** result - value returned from evaluation.
** Notes:
** As of A104, only compressed scripts are supported, however,
** rebin, cloaked, signed, and encrypted formats will be supported.
**
***********************************************************************/
{
REBSER spec = {0};
REBSER *text;
REBVAL *val;
#ifdef DUMP_INIT_SCRIPT
int f;
#endif
//Cloak(TRUE, code, NAT_SPEC_SIZE, &key[0], 20, TRUE);
spec.data = bin;
spec.tail = length;
text = Decompress(&spec, 0, -1, 10000000, 0);
if (!text) return FALSE;
Append_Byte(text, 0);
#ifdef DUMP_INIT_SCRIPT
f = _open("host-boot.r", _O_CREAT | _O_RDWR, _S_IREAD | _S_IWRITE );
_write(f, STR_HEAD(text), LEN_BYTES(STR_HEAD(text)));
_close(f);
#endif
SAVE_SERIES(text);
val = Do_String(text->data, flags);
UNSAVE_SERIES(text);
if (IS_ERROR(val)) // && (VAL_ERR_NUM(val) != RE_QUIT)) {
Print_Value(val, 1000, FALSE);
if (result) {
*result = Value_To_RXI(val);
return Reb_To_RXT[VAL_TYPE(val)];
}
return 0;
}
*/ RL_API u32 RL_Map_Word(REBYTE *string)
/*
** Given a word as a string, return its global word identifier.
**
** Returns:
** The word identifier that matches the string.
** Arguments:
** string - a valid word as a UTF-8 encoded string.
** Notes:
** Word identifiers are persistent, and you can use them anytime.
** If the word is new (not found in master symbol table)
** it will be added and the new word identifier is returned.
**
***********************************************************************/
{
return Make_Word(string, LEN_BYTES(string));
}
*/ REBSER *Copy_Bytes(const REBYTE *src, REBINT len)
/*
** Create a string series from the given bytes.
** Source is always latin-1 valid. Result is always 8bit.
**
***********************************************************************/
{
REBSER *dst;
if (len < 0) len = LEN_BYTES(src);
dst = Make_Binary(len);
memcpy(STR_DATA(dst), src, len);
SERIES_TAIL(dst) = len;
STR_TERM(dst);
return dst;
}
*/ REBINT Compare_UTF8(REBYTE *s1, REBYTE *s2, REBCNT l2)
/*
** Compare two UTF8 strings.
**
** It is necessary to decode the strings to check if the match
** case-insensitively.
**
** Returns:
** -3: no match, s2 > s1
** -1: no match, s1 > s2
** 0: exact match
** 1: non-case match, s2 > s1
** 3: non-case match, s1 > s2
**
** So, result + 2 for no-match gives proper sort order.
** And, result - 2 for non-case match gives sort order.
**
** Used for: WORD comparison.
**
***********************************************************************/
{
REBINT c1, c2;
REBCNT l1 = LEN_BYTES(s1);
REBINT result = 0;
for (; l1 > 0 && l2 > 0; s1++, s2++, l1--, l2--) {
c1 = (REBYTE)*s1;
c2 = (REBYTE)*s2;
if (c1 > 127) c1 = Decode_UTF8_Char(&s1, &l1); //!!! can return 0 on error!
if (c2 > 127) c2 = Decode_UTF8_Char(&s2, &l2);
if (c1 != c2) {
if (c1 >= UNICODE_CASES || c2 >= UNICODE_CASES ||
LO_CASE(c1) != LO_CASE(c2)) {
return (c1 > c2) ? -1 : -3;
}
if (!result) result = (c1 > c2) ? 3 : 1;
}
}
if (l1 != l2) result = (l1 > l2) ? -1 : -3;
return result;
}
*/ REBINT Compare_Word(REBVAL *s, REBVAL *t, REBFLG is_case)
/*
** Compare the names of two words and return the difference.
** Note that words are kept UTF8 encoded.
** Positive result if s > t and negative if s < t.
**
***********************************************************************/
{
REBYTE *sp = VAL_WORD_NAME(s);
REBYTE *tp = VAL_WORD_NAME(t);
// Use a more strict comparison than normal:
if (is_case) return CMP_BYTES(sp, tp);
// They are the equivalent words:
if (VAL_WORD_CANON(s) == VAL_WORD_CANON(t)) return 0;
// They must be differ by case:
return Compare_UTF8(sp, tp, LEN_BYTES(tp)) + 2;
}
*/ RL_API int RL_Do_Binary(int *exit_status, const REBYTE *bin, REBINT length, REBCNT flags, REBCNT key, RXIARG *result)
/*
** Evaluate an encoded binary script such as compressed text.
**
** Returns:
** The datatype of the result or zero if error in the encoding.
** Arguments:
** bin - by default, a REBOL compressed UTF-8 (or ASCII) script.
** length - the length of the data.
** flags - special flags (set to zero at this time).
** key - encoding, encryption, or signature key.
** result - value returned from evaluation.
** Notes:
** As of A104, only compressed scripts are supported, however,
** rebin, cloaked, signed, and encrypted formats will be supported.
**
***********************************************************************/
{
REBSER *text;
#ifdef DUMP_INIT_SCRIPT
int f;
#endif
int do_result;
text = Decompress(bin, length, -1, FALSE, FALSE);
if (!text) return FALSE;
Append_Codepoint_Raw(text, 0);
#ifdef DUMP_INIT_SCRIPT
f = _open("host-boot.r", _O_CREAT | _O_RDWR, _S_IREAD | _S_IWRITE );
_write(f, STR_HEAD(text), LEN_BYTES(STR_HEAD(text)));
_close(f);
#endif
PUSH_GUARD_SERIES(text);
do_result = RL_Do_String(exit_status, text->data, flags, result);
DROP_GUARD_SERIES(text);
Free_Series(text);
return do_result;
}
static REBYTE *Get_Next_Line()
{
REBYTE *bp = inbuf;
REBYTE *out;
REBCNT len;
// Scan for line terminator or end:
for (bp = inbuf; *bp != CR && *bp != LF && *bp != 0; bp++);
// If found, copy the line and remove it from buffer:
if (*bp) {
if (*bp == CR && bp[1] == LF) bp++;
len = bp - inbuf;
out = OS_ALLOC_ARRAY(REBYTE, len + 2);
COPY_BYTES(out, inbuf, len+1);
out[len+1] = 0;
memmove(inbuf, bp + 1, 1 + LEN_BYTES(bp + 1));
return out;
}
return 0; // more input needed
}
*/ 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;
}
//
// RL_Map_Word: C
//
// Given a word as a string, return its global word identifier.
//
// Returns:
// The word identifier that matches the string.
// Arguments:
// string - a valid word as a UTF-8 encoded string.
// Notes:
// Word identifiers are persistent, and you can use them anytime.
// If the word is new (not found in master symbol table)
// it will be added and the new word identifier is returned.
//
RL_API u32 RL_Map_Word(REBYTE *string)
{
return Make_Word(string, LEN_BYTES(string));
}
*/ REBCNT Make_Word(REBYTE *str, REBCNT len)
/*
** Given a string and its length, compute its hash value,
** search for a match, and if not found, add it to the table.
** Length of zero indicates you provided a zero terminated string.
** Return the table index for the word (whether found or new).
**
***********************************************************************/
{
REBINT hash;
REBINT size;
REBINT skip;
REBINT n;
REBCNT h;
REBCNT *hashes;
REBVAL *words;
REBVAL *w;
//REBYTE *sss = Get_Sym_Name(1); // (Debugging method)
if (len == 0) len = LEN_BYTES(str);
// If hash part of word table is too dense, expand it:
if (PG_Word_Table.series->tail > PG_Word_Table.hashes->tail/2)
Expand_Word_Table();
ASSERT((SERIES_TAIL(PG_Word_Table.series) == SERIES_TAIL(Bind_Table)), RP_BIND_TABLE_SIZE);
// If word symbol part of word table is full, expand it:
if (SERIES_FULL(PG_Word_Table.series)) {
Extend_Series(PG_Word_Table.series, 256);
}
if (SERIES_FULL(Bind_Table)) {
Extend_Series(Bind_Table, 256);
CLEAR_SERIES(Bind_Table);
}
size = (REBINT)PG_Word_Table.hashes->tail;
words = BLK_HEAD(PG_Word_Table.series);
hashes = (REBCNT *)PG_Word_Table.hashes->data;
// Hash the word, including a skip factor for lookup:
hash = Hash_Word(str, len);
skip = (hash & 0x0000FFFF) % size;
if (skip == 0) skip = 1;
hash = (hash & 0x00FFFF00) % size;
//Debug_Fmt("%s hash %d skip %d", str, hash, skip);
// Search hash table for word match:
while (NZ(h = hashes[hash])) {
while ((n = Compare_UTF8(VAL_SYM_NAME(words+h), str, len)) >= 0) {
//if (Match_String("script", str, len))
// Debug_Fmt("---- %s %d %d\n", VAL_SYM_NAME(&words[h]), n, h);
if (n == 0) return h; // direct hit
if (VAL_SYM_ALIAS(words+h)) h = VAL_SYM_ALIAS(words+h);
else goto make_sym; // Create new alias for word
}
hash += skip;
if (hash >= size) hash -= size;
}
make_sym:
n = PG_Word_Table.series->tail;
w = words + n;
if (h) {
// Alias word (h = canon word)
VAL_SYM_ALIAS(words+h) = n;
VAL_SYM_CANON(w) = VAL_SYM_CANON(words+h);
} else {
// Canon (base version of) word (h == 0)
hashes[hash] = n;
VAL_SYM_CANON(w) = n;
}
VAL_SYM_ALIAS(w) = 0;
VAL_SYM_NINDEX(w) = Make_Word_Name(str, len);
VAL_SET(w, REB_HANDLE);
// These are allowed because of the SERIES_FULL checks above which
// add one extra to the TAIL check comparision. However, their
// termination values (nulls) will be missing.
PG_Word_Table.series->tail++;
Bind_Table->tail++;
return n;
}
*/ REBINT Emit_Decimal(REBYTE *cp, REBDEC d, REBFLG percent, REBYTE point, REBINT digits)
/*
***********************************************************************/
{
REBYTE out[MAX_NUMCHR];
REBINT len;
REBINT n;
REBINT i;
REBI64 sig;
REBINT pt;
REBFLG neg;
REBYTE *start = cp;
*cp = out[0] = 0;
// Deal with 0 as special case:
if (d == 0.0 || d == -0.0) {
*cp++ = '0';
if (!percent) {
*cp++ = '.';
*cp++ = '0';
}
}
else {
if (percent) d *= 100.0;
if (NZ(neg = (d < 0))) d = -d;
if (Convert_Decimal(d, &sig, &pt)) {
// Not exp format.
len = Form_Integer(out, sig) - out;
if (neg) *cp++ = '-';
// Trim un-needed trailing zeros:
for (len--; len > 0 && len >= pt; len--) {
if (out[len] == '0') out[len] = 0;
else break;
}
// Leading zero, as in 0.1
if (pt <= 0) *cp++ = '0';
// Other leading digits:
for (n = 0; out[n] && n < pt; n++) *cp++ = out[n];
if (!percent || n <= len) {
// Decimal point:
*cp++ = point;
// Zeros before first significant digit:
for (i = 0; i > pt; i--) *cp++ = '0';
// All remaining digits:
for (; n <= len; n++) *cp++ = out[n];
// Force extra zero in 1.0 cases:
if (cp[-1] == point) *cp++ = '0';
}
}
else {
REBYTE *pp;
// Requires exp format:
if (percent) Trap0(RE_OVERFLOW);
len = Get_System_Int(SYS_OPTIONS, OPTIONS_DECIMAL_DIGITS, MAX_DIGITS);
if (len > MAX_DIGITS) len = MAX_DIGITS;
gcvt(d, len, cp); // returns 1.2e123 (also 1e123)
pp = strchr(cp, '.');
if (pp && (pp[1] == 'e' || pp[1] == 'E')) {
memcpy(pp, pp+1, strlen(pp));
}
if (point != '.' && pp) {
cp = strchr(cp, '.');
if (cp) *cp = point;
}
cp = start + LEN_BYTES(start);
}
}
if (percent) *cp++ = '%';
*cp = 0;
return cp - start;
}
//
// Form_Integer: C
//
// Form standard REBOL integer value (32 or 64).
// Make sure you have room in your buffer before calling this!
//
REBYTE *Form_Integer(REBYTE *buf, REBI64 val)
{
INT_TO_STR(val, buf);
return buf+LEN_BYTES(buf);
}
//
// 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));
}
*/ void Crash(REBINT id, ...)
/*
** Print a failure message and abort.
**
** LATIN1 ONLY!! (For now)
**
** The error is identified by id number, which can reference an
** error message string in the boot strings block.
**
** Note that lower level error messages should not attempt to
** use the %r (mold value) format (uses higher level functions).
**
** See panics.h for list of crash errors.
**
***********************************************************************/
{
va_list args;
REBYTE buf[CRASH_BUF_SIZE];
REBYTE *msg;
REBINT n = 0;
va_start(args, id);
DISABLE_GC;
if (Reb_Opts->crash_dump) {
Dump_Info();
Dump_Stack(0, 0);
}
// "REBOL PANIC #nnn:"
COPY_BYTES(buf, Crash_Msgs[CM_ERROR], CRASH_BUF_SIZE);
APPEND_BYTES(buf, " #", CRASH_BUF_SIZE);
Form_Int(buf + LEN_BYTES(buf), id);
APPEND_BYTES(buf, ": ", CRASH_BUF_SIZE);
// "REBOL PANIC #nnn: put error message here"
// The first few error types only print general error message.
// Those errors > RP_STR_BASE have specific error messages (from boot.r).
if (id < RP_BOOT_DATA) n = CM_DEBUG;
else if (id < RP_INTERNAL) n = CM_BOOT;
else if (id < RP_ASSERTS) n = CM_INTERNAL;
else if (id < RP_DATATYPE) n = CM_ASSERT;
else if (id < RP_STR_BASE) n = CM_DATATYPE;
else if (id > RP_STR_BASE + RS_MAX - RS_ERROR) n = CM_DEBUG;
// Use the above string or the boot string for the error (in boot.r):
msg = (REBYTE*)(n >= 0 ? Crash_Msgs[n] : BOOT_STR(RS_ERROR, id - RP_STR_BASE - 1));
Form_Var_Args(buf + LEN_BYTES(buf), CRASH_BUF_SIZE - 1 - LEN_BYTES(buf), msg, args);
n = LEN_BYTES(Crash_Msgs[CM_CONTACT]);
if ((LEN_BYTES(buf) + n) < (CRASH_BUF_SIZE - 1))
APPEND_BYTES(buf, Crash_Msgs[CM_CONTACT], n);
// Convert to OS-specific char-type:
#ifdef disable_for_now //OS_WIDE_CHAR /// win98 does not support it
{
REBCHR s1[512];
REBCHR s2[2000];
n = TO_OS_STR(s1, Crash_Msgs[CM_ERROR], LEN_BYTES(Crash_Msgs[CM_ERROR]));
if (n > 0) s1[n] = 0; // terminate
else OS_EXIT(200); // bad conversion
n = TO_OS_STR(s2, buf, LEN_BYTES(buf));
if (n > 0) s2[n] = 0;
else OS_EXIT(200);
OS_CRASH(s1, s2);
}
#else
OS_CRASH(Crash_Msgs[CM_ERROR], buf);
#endif
}
*/ RL_API int RL_Do_String(int *exit_status, const REBYTE *text, REBCNT flags, RXIARG *result)
/*
** Load a string and evaluate the resulting block.
**
** Returns:
** The datatype of the result if a positive number (or 0 if the
** type has no representation in the "RXT" API). An error code
** if it's a negative number. Two negative numbers are reserved
** for non-error conditions: -1 for halting (e.g. Escape), and
** -2 is reserved for exiting with exit_status set.
**
** Arguments:
** text - A null terminated UTF-8 (or ASCII) string to transcode
** into a block and evaluate.
** flags - set to zero for now
** result - value returned from evaluation, if NULL then result
** will be returned on the top of the stack
**
** Notes:
** This API was from before Rebol's open sourcing and had little
** vetting and few clients. The one client it did have was the
** "sample" console code (which wound up being the "only"
** console code for quite some time).
**
***********************************************************************/
{
REBSER *code;
REBVAL out;
REBOL_STATE state;
const REBVAL *error;
// assumes it can only be run at the topmost level where
// the data stack is completely empty.
assert(DSP == -1);
PUSH_UNHALTABLE_TRAP(&error, &state);
// The first time through the following code 'error' will be NULL, but...
// `raise Error` can longjmp here, so 'error' won't be NULL *if* that happens!
if (error) {
if (VAL_ERR_NUM(error) == RE_HALT)
return -1; // !!! Revisit hardcoded #
// Save error for WHY?
*Get_System(SYS_STATE, STATE_LAST_ERROR) = *error;
if (result)
*result = Value_To_RXI(error);
else
DS_PUSH(error);
return -VAL_ERR_NUM(error);
}
code = Scan_Source(text, LEN_BYTES(text));
PUSH_GUARD_SERIES(code);
// Bind into lib or user spaces?
if (flags) {
// Top words will be added to lib:
Bind_Values_Set_Forward_Shallow(BLK_HEAD(code), Lib_Context);
Bind_Values_Deep(BLK_HEAD(code), Lib_Context);
} else {
REBCNT len;
REBVAL vali;
REBSER *user = VAL_OBJ_FRAME(Get_System(SYS_CONTEXTS, CTX_USER));
len = user->tail;
Bind_Values_All_Deep(BLK_HEAD(code), user);
SET_INTEGER(&vali, len);
Resolve_Context(user, Lib_Context, &vali, FALSE, 0);
}
if (Do_At_Throws(&out, code, 0)) {
DROP_GUARD_SERIES(code);
if (
IS_NATIVE(&out) && (
VAL_FUNC_CODE(&out) == VAL_FUNC_CODE(ROOT_QUIT_NATIVE)
|| VAL_FUNC_CODE(&out) == VAL_FUNC_CODE(ROOT_EXIT_NATIVE)
)
) {
CATCH_THROWN(&out, &out);
DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state);
*exit_status = Exit_Status_From_Value(&out);
return -2; // Revisit hardcoded #
}
raise Error_No_Catch_For_Throw(&out);
}
DROP_GUARD_SERIES(code);
DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state);
if (result)
*result = Value_To_RXI(&out);
else
DS_PUSH(&out);
return Reb_To_RXT[VAL_TYPE(&out)];
}
