From 25243fc7af8c4791e3c75ca316376f6e3f9934d4 Mon Sep 17 00:00:00 2001 From: hyung-hwan Date: Thu, 2 Aug 2018 17:09:32 +0000 Subject: [PATCH] added experimental code to execute an external command --- lib/comp.c | 37 +++++++------ lib/dic.c | 17 +++--- lib/exec.c | 157 +++++++++++++++++++++++++++++++++++++++++++++++++++++ lib/hcl.h | 7 +++ 4 files changed, 191 insertions(+), 27 deletions(-) diff --git a/lib/comp.c b/lib/comp.c index 76a5e17..e5d6c8d 100644 --- a/lib/comp.c +++ b/lib/comp.c @@ -1435,7 +1435,7 @@ static int compile_cons_xlist_expression (hcl_t* hcl, hcl_oop_t obj) return -1; } } - else if (HCL_IS_SYMBOL(hcl,car) || HCL_IS_CONS_XLIST(hcl,car)) + else if (HCL_IS_SYMBOL(hcl,car) || HCL_IS_CONS_XLIST(hcl,car) || ((hcl->option.trait & HCL_CLI_MODE) && HCL_IS_STRING(hcl, car))) { /* normal function call * ( ...) */ @@ -1449,7 +1449,7 @@ static int compile_cons_xlist_expression (hcl_t* hcl, hcl_oop_t obj) * many operations can be performed without taking GC into account */ /* store the position of COP_EMIT_CALL to be produced with - * SWITCH_TOP_CFRAM() in oldtop for argument count patching + * SWITCH_TOP_CFRAME() in oldtop for argument count patching * further down */ oldtop = GET_TOP_CFRAME_INDEX(hcl); HCL_ASSERT (hcl, oldtop >= 0); @@ -1483,21 +1483,24 @@ static int compile_cons_xlist_expression (hcl_t* hcl, hcl_oop_t obj) } } - sdc = hcl_getatsysdic(hcl, car); - if (sdc) + if (HCL_IS_SYMBOL(hcl, car)) { - hcl_oop_word_t sdv; - sdv = (hcl_oop_word_t)HCL_CONS_CDR(sdc); - if (HCL_IS_PRIM(hcl, sdv)) + sdc = hcl_getatsysdic(hcl, car); + if (sdc) { - if (nargs < sdv->slot[1] || nargs > sdv->slot[2]) + hcl_oop_word_t sdv; + sdv = (hcl_oop_word_t)HCL_CONS_CDR(sdc); + if (HCL_IS_PRIM(hcl, sdv)) { - hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGCOUNT, HCL_NULL, HCL_NULL, - "parameters count(%zd) mismatch in function call - %O - expecting %zu-%zu parameters", nargs, obj, sdv->slot[1], sdv->slot[2]); - return -1; + if (nargs < sdv->slot[1] || nargs > sdv->slot[2]) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGCOUNT, HCL_NULL, HCL_NULL, + "parameters count(%zd) mismatch in function call - %O - expecting %zu-%zu parameters", nargs, obj, sdv->slot[1], sdv->slot[2]); + return -1; + } } } - }; + } /* redundant cdr check is performed inside compile_object_list() */ PUSH_SUBCFRAME (hcl, COP_COMPILE_ARGUMENT_LIST, cdr); @@ -1564,27 +1567,27 @@ static HCL_INLINE int compile_symbol (hcl_t* hcl, hcl_oop_t obj) } /* check if a symbol is a local variable */ - if (find_temporary_variable_backward (hcl, obj, &index) <= -1) + if (find_temporary_variable_backward(hcl, obj, &index) <= -1) { hcl_oop_t cons; /* TODO: if i require all variables to be declared, this part is not needed and should handle it as an error */ /* TODO: change the scheme... allow declaration??? */ /* global variable */ - cons = (hcl_oop_t)hcl_getatsysdic (hcl, obj); + cons = (hcl_oop_t)hcl_getatsysdic(hcl, obj); if (!cons) { - cons = (hcl_oop_t)hcl_putatsysdic (hcl, obj, hcl->_nil); + cons = (hcl_oop_t)hcl_putatsysdic(hcl, obj, hcl->_nil); if (!cons) return -1; } if (add_literal(hcl, cons, &index) <= -1 || - emit_single_param_instruction (hcl, HCL_CODE_PUSH_OBJECT_0, index) <= -1) return -1; + emit_single_param_instruction(hcl, HCL_CODE_PUSH_OBJECT_0, index) <= -1) return -1; return 0; } else { - return emit_indexed_variable_access (hcl, index, HCL_CODE_PUSH_CTXTEMPVAR_0, HCL_CODE_PUSH_TEMPVAR_0); + return emit_indexed_variable_access(hcl, index, HCL_CODE_PUSH_CTXTEMPVAR_0, HCL_CODE_PUSH_TEMPVAR_0); } } diff --git a/lib/dic.c b/lib/dic.c index 9198cd0..4cda830 100644 --- a/lib/dic.c +++ b/lib/dic.c @@ -26,7 +26,7 @@ #include "hcl-prv.h" -/*#define SYMBOL_ONLY_KEY */ +#define SYMBOL_ONLY_KEY static hcl_oop_oop_t expand_bucket (hcl_t* hcl, hcl_oop_oop_t oldbuc) { @@ -73,6 +73,7 @@ static hcl_oop_oop_t expand_bucket (hcl_t* hcl, hcl_oop_oop_t oldbuc) if ((hcl_oop_t)ass != hcl->_nil) { #if defined(SYMBOL_ONLY_KEY) + hcl_oop_char_t key; HCL_ASSERT (hcl, HCL_IS_CONS(hcl,ass)); key = (hcl_oop_char_t)ass->car; HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,key)); @@ -81,7 +82,7 @@ static hcl_oop_oop_t expand_bucket (hcl_t* hcl, hcl_oop_oop_t oldbuc) int n; HCL_ASSERT (hcl, HCL_IS_CONS(hcl,ass)); n = hcl_hashobj(hcl, ass->car, &index); - HCL_ASSERT (hcl, n == 0); /* since it's expanding, the existing in the bucket should always be hashable */ + HCL_ASSERT (hcl, n == 0); /* since it's expanding, the existing one in the bucket should always be hashable */ index %= newsz; #endif while (newbuc->slot[index] != hcl->_nil) index = (index + 1) % newsz; @@ -92,11 +93,7 @@ static hcl_oop_oop_t expand_bucket (hcl_t* hcl, hcl_oop_oop_t oldbuc) return newbuc; } -#if defined(SYMBOL_ONLY_KEY) -static hcl_oop_cons_t find_or_upsert (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_char_t key, hcl_oop_t value) -#else static hcl_oop_cons_t find_or_upsert (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_t key, hcl_oop_t value) -#endif { hcl_ooi_t tally; hcl_oow_t index; @@ -112,7 +109,7 @@ static hcl_oop_cons_t find_or_upsert (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_t k HCL_ASSERT (hcl, HCL_IS_ARRAY(hcl,dic->bucket)); #if defined(SYMBOL_ONLY_KEY) - index = hcl_hashoochars(key->slot, HCL_OBJ_GET_SIZE(key)) % HCL_OBJ_GET_SIZE(dic->bucket); + index = hcl_hashoochars(HCL_OBJ_GET_CHAR_SLOT(key), HCL_OBJ_GET_SIZE(key)) % HCL_OBJ_GET_SIZE(dic->bucket); #else if (hcl_hashobj(hcl, key, &index) <= -1) return HCL_NULL; index %= HCL_OBJ_GET_SIZE(dic->bucket); @@ -127,7 +124,7 @@ static hcl_oop_cons_t find_or_upsert (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_t k HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,ass->car)); if (HCL_OBJ_GET_SIZE(key) == HCL_OBJ_GET_SIZE(ass->car) && - hcl_equal_oochars(key->slot, ((hcl_oop_char_t)ass->car)->slot, HCL_OBJ_GET_SIZE(key))) + hcl_equal_oochars(HCL_OBJ_GET_CHAR_SLOT(key), ((hcl_oop_char_t)ass->car)->slot, HCL_OBJ_GET_SIZE(key))) { /* the value of HCL_NULL indicates no insertion or update. */ if (value) ass->cdr = value; /* update */ @@ -198,7 +195,7 @@ static hcl_oop_cons_t find_or_upsert (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_t k #if defined(SYMBOL_ONLY_KEY) /* recalculate the index for the expanded bucket */ - index = hcl_hashoochars(key->slot, HCL_OBJ_GET_SIZE(key)) % HCL_OBJ_GET_SIZE(dic->bucket); + index = hcl_hashoochars(HCL_OBJ_GET_CHAR_SLOT(key), HCL_OBJ_GET_SIZE(key)) % HCL_OBJ_GET_SIZE(dic->bucket); #else hcl_hashobj(hcl, key, &index); /* this must succeed as i know 'key' is hashable */ index %= HCL_OBJ_GET_SIZE(dic->bucket); @@ -285,7 +282,7 @@ int hcl_zapatdic (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_t key) HCL_ASSERT (hcl, HCL_IS_ARRAY(hcl,dic->bucket)); #if defined(SYMBOL_ONLY_KEY) - index = hcl_hashoochars(key->slot, HCL_OBJ_GET_SIZE(key)) % bs; + index = hcl_hashoochars(HCL_OBJ_GET_CHAR_SLOT(key), HCL_OBJ_GET_SIZE(key)) % bs; #else if (hcl_hashobj(hcl, key, &index) <= -1) return -1; index %= bs; diff --git a/lib/exec.c b/lib/exec.c index 4d83385..81645a5 100644 --- a/lib/exec.c +++ b/lib/exec.c @@ -1000,6 +1000,160 @@ static HCL_INLINE int call_primitive (hcl_t* hcl, hcl_ooi_t nargs) return ((hcl_pfimpl_t)rcv->slot[0]) (hcl, (hcl_mod_t*)rcv->slot[3], nargs); } + +#include +#include +#include +#include +#include +#include +#include + +extern char **environ; + +#define _PATH_DEFPATH "/usr/bin:/bin" + +static int is_regular_executable_file_by_me(const char *path) +{ + struct stat path_stat; + stat(path, &path_stat); + return S_ISREG(path_stat.st_mode) && access(path, X_OK) == 0; //? use eaccess instead?? +} + +static char* find_exec (hcl_t* hcl, const char *name) +{ + size_t lp, ln; + char buf[PATH_MAX]; + const char *bp, *path, *p; + + bp = buf; + + /* Get the path we're searching. */ + if (!(path = getenv("PATH"))) path = _PATH_DEFPATH; + + ln = strlen(name); + do + { + /* Find the end of this path element. */ + for (p = path; *path != 0 && *path != ':'; path++) ; + + /* + * It's a SHELL path -- double, leading and trailing colons + * mean the current directory. + */ + if (p == path) + { + p = "."; + lp = 1; + } + else + { + lp = path - p; + } + + /* + * If the path is too long complain. This is a possible + * security issue; given a way to make the path too long + * the user may execute the wrong program. + */ + if (lp + ln + 2 > sizeof(buf)) continue; + + memcpy(buf, p, lp); + buf[lp] = '/'; + memcpy(buf + lp + 1, name, ln); + buf[lp + ln + 1] = '\0'; + + if (is_regular_executable_file_by_me(bp)) return strdup(bp); + + } + while (*path++ == ':'); /* Otherwise, *path was NUL */ + + +done: + hcl_seterrbfmt (hcl, HCL_ENOENT, "callable %hs not found", name); + return HCL_NULL; +} + + +static HCL_INLINE int exec_syscmd (hcl_t* hcl, hcl_ooi_t nargs) +{ + hcl_oop_word_t rcv; + hcl_bch_t* cmd, * xcmd; + + rcv = (hcl_oop_word_t)HCL_STACK_GETRCV(hcl, nargs); + /*HCL_ASSERT (hcl, HCL_IS_STRING(hcl, rcv) || HCL_IS_SYMBOL(hcl, rcv));*/ + HCL_ASSERT (hcl, HCL_OBJ_IS_CHAR_POINTER(rcv)); + + if (HCL_OBJ_GET_SIZE(rcv) == 0 || hcl_count_oocstr(HCL_OBJ_GET_CHAR_SLOT(rcv)) != HCL_OBJ_GET_SIZE(rcv)) + { + /* '\0' is contained in the middle */ + hcl_seterrbfmt (hcl, HCL_EINVAL, "invalid callable %O", rcv); + return -1; + } + + cmd = hcl_dupootobcstr(hcl, HCL_OBJ_GET_CHAR_SLOT(rcv), HCL_NULL); + if (!cmd) return -1; + + if (hcl_find_bchar_in_bcstr(cmd, '/')) + { + if (!is_regular_executable_file_by_me(cmd)) + { + hcl_seterrbfmt (hcl, HCL_ECALL, "cannot execute %O", rcv); + return -1; + } + + xcmd = cmd; + } + else + { + xcmd = find_exec(hcl, cmd); + if (!xcmd) return -1; + } + +{ /* TODO: make it a callback ... */ + pid_t pid; + int status; + + pid = fork(); + if (pid == -1) return -1; + +/* TODO: set a new process group / session leader??? */ + + if (pid == 0) + { + + hcl_bch_t** argv; + hcl_ooi_t i; + + /* TODO: close file descriptors??? */ + argv = (hcl_bch_t**)hcl_allocmem(hcl, (nargs + 2) * HCL_SIZEOF(*argv)); + if (argv) + { + argv[0] = cmd; + for (i = 0; i < nargs; i++) + { + hcl_oop_t ta; + + ta = HCL_STACK_GETARG(hcl, nargs, i); +/* TODO: check if an argument is a string or a symbol */ + argv[i + 1] = hcl_dupootobchars (hcl, HCL_OBJ_GET_CHAR_SLOT(ta), HCL_OBJ_GET_SIZE(ta), HCL_NULL); + } + argv[nargs + 1] = HCL_NULL; + execvp (xcmd, argv); + } + _exit (255); + } + + waitpid (pid, &status, 0); + + HCL_STACK_SETRET (hcl, nargs, HCL_SMOOI_TO_OOP(WEXITSTATUS(status))); +} + + hcl_freemem (hcl, cmd); + if (xcmd != cmd) hcl_freemem (hcl, xcmd); + return 0; +} + /* ------------------------------------------------------------------------- */ static hcl_oop_process_t start_initial_process (hcl_t* hcl, hcl_oop_context_t ctx) { @@ -1584,6 +1738,9 @@ static int execute (hcl_t* hcl) case HCL_BRAND_PRIM: if (call_primitive(hcl, b1) <= -1) goto oops; break; + case HCL_BRAND_STRING: + if ((hcl->option.trait & HCL_CLI_MODE) && exec_syscmd(hcl, b1) >= 0) break; + /* fall thru */ default: goto cannot_call; } diff --git a/lib/hcl.h b/lib/hcl.h index 5e9ab3c..f22d672 100644 --- a/lib/hcl.h +++ b/lib/hcl.h @@ -476,6 +476,13 @@ typedef enum hcl_obj_type_t hcl_obj_type_t; /* [NOTE] this macro doesn't include the size of the trailer */ #define HCL_OBJ_BYTESOF(oop) ((HCL_OBJ_GET_SIZE(oop) + HCL_OBJ_GET_FLAGS_EXTRA(oop)) * HCL_OBJ_GET_FLAGS_UNIT(oop)) +#define HCL_OBJ_IS_OOP_POINTER(oop) (HCL_OOP_IS_POINTER(oop) && (HCL_OBJ_GET_FLAGS_TYPE(oop) == HCL_OBJ_TYPE_OOP)) +#define HCL_OBJ_IS_CHAR_POINTER(oop) (HCL_OOP_IS_POINTER(oop) && (HCL_OBJ_GET_FLAGS_TYPE(oop) == HCL_OBJ_TYPE_CHAR)) +#define HCL_OBJ_IS_BYTE_POINTER(oop) (HCL_OOP_IS_POINTER(oop) && (HCL_OBJ_GET_FLAGS_TYPE(oop) == HCL_OBJ_TYPE_BYTE)) +#define HCL_OBJ_IS_HALFWORD_POINTER(oop) (HCL_OOP_IS_POINTER(oop) && (HCL_OBJ_GET_FLAGS_TYPE(oop) == HCL_OBJ_TYPE_HALFWORD)) +#define HCL_OBJ_IS_WORD_POINTER(oop) (HCL_OOP_IS_POINTER(oop) && (HCL_OBJ_GET_FLAGS_TYPE(oop) == HCL_OBJ_TYPE_WORD)) + + /* [NOTE] this macro doesn't check the range of the actual value. * make sure that the value of each bit fields given falls within the * possible range of the defined bits */