USER_OBJECT_
RS_GGOBI(setDisplayOptions)(USER_OBJECT_ which, USER_OBJECT_ values)
{
gint i;
DisplayOptions *options;
displayd *display = NULL;
int apply = 0;
g_return_val_if_fail(GET_LENGTH(values) == 8, NULL_USER_OBJECT);
if(GET_LENGTH(which) == 0) {
options = GGOBI(getDefaultDisplayOptions)();
} else {
display = toDisplay(which);
g_return_val_if_fail(GGOBI_IS_DISPLAY(display), NULL_USER_OBJECT);
options = &(display->options);
g_return_val_if_fail(options != NULL, NULL_USER_OBJECT);
apply = 1;
}
i = 0;
options->points_show_p = LOGICAL_DATA(values)[i++];
options->axes_show_p = LOGICAL_DATA(values)[i++];
options->axes_label_p = LOGICAL_DATA(values)[i++];
options->axes_values_p = LOGICAL_DATA(values)[i++];
options->edges_undirected_show_p = LOGICAL_DATA(values)[i++];
options->edges_arrowheads_show_p = LOGICAL_DATA(values)[i++];
options->edges_directed_show_p = LOGICAL_DATA(values)[i++];
options->whiskers_show_p = LOGICAL_DATA(values)[i++];
/* unused
options->missings_show_p = LOGICAL_DATA(values)[i++];
options->axes_center_p = LOGICAL_DATA(values)[i++];
options->double_buffer_p = LOGICAL_DATA(values)[i++];
options->link_p = LOGICAL_DATA(values)[i++];
*/
if(apply) {
set_display_options(display, display->ggobi);
}
return (NULL_USER_OBJECT);
}
USER_OBJECT_
RGnumeric_setCellAlign(USER_OBJECT_ scell, USER_OBJECT_ value, USER_OBJECT_ horizontal)
{
MStyle *style;
Cell *cell;
cell = RGnumeric_resolveCellReference(scell);
style = cell_get_mstyle(cell);
if(LOGICAL_DATA(horizontal)[0])
mstyle_set_align_h(style, INTEGER_DATA(value)[0]) ;
else
mstyle_set_align_v(style, INTEGER_DATA(value)[0]);
updateSCell(cell, scell, style);
return(value);
}
USER_OBJECT_
RS_remove(USER_OBJECT_ ids, USER_OBJECT_ interpreter)
{
HV *table;
USER_OBJECT_ ans;
const char *key;
dTHX;
PROTECT(ans = NEW_LOGICAL(1));
table = gv_stashpv("main", FALSE);
key = CHAR_DEREF(STRING_ELT(ids,0));
hv_delete(table, key, strlen(key), G_DISCARD);
LOGICAL_DATA(ans)[0] = TRUE;
UNPROTECT(1);
return(ans);
}
USER_OBJECT_
RS_GGOBI(closeDisplay)(USER_OBJECT_ ref, USER_OBJECT_ ggobiId)
{
ggobid *gg = toGGobi(ggobiId);
USER_OBJECT_ ans = NEW_LOGICAL(1);
displayd *display;
g_return_val_if_fail(GGOBI_IS_GGOBI(gg), NULL_USER_OBJECT);
if(!gg)
return(ans);
display = (displayd *) R_ExternalPtrAddr(ref);
display = ValidateDisplayRef(display, gg, false);
if(display) {
display_free(display, true, gg);
LOGICAL_DATA(ans)[0] = TRUE;
gdk_flush();
}
return(ans);
}
USER_OBJECT_
RGnumeric_setCellForeground(USER_OBJECT_ cellRef, USER_OBJECT_ val, USER_OBJECT_ isFg)
{
MStyle *style;
Cell *cell;
enum _MStyleElementType attr;
int *v = INTEGER_DATA(val);
attr = LOGICAL_DATA(isFg)[0] ? MSTYLE_COLOR_FORE : MSTYLE_COLOR_BACK;
cell = RGnumeric_resolveCellReference(cellRef);
style = cell_get_mstyle(cell);
style = mstyle_copy(style);
mstyle_set_color(style, attr,
style_color_new(v[0], v[1], v[2]));
updateSCell(cell, cellRef, style);
return(NULL_USER_OBJECT);
}
/* Sets a plot as the active plot given a display and a plot index */
USER_OBJECT_
RS_GGOBI(setActivePlot)(USER_OBJECT_ s_display, USER_OBJECT_ s_plot)
{
USER_OBJECT_ ans = NEW_LOGICAL(1);
displayd *display;
splotd *sp;
display = toDisplay(s_display);
g_return_val_if_fail(GGOBI_IS_DISPLAY(display), NULL_USER_OBJECT);
display_set_current(display, display->ggobi);
sp = GGOBI(getPlot)(display, INTEGER_DATA(s_plot)[0]);
g_return_val_if_fail(sp != NULL, NULL_USER_OBJECT);
GGOBI(splot_set_current_full)(display, sp, display->ggobi);
LOGICAL_DATA(ans)[0] = 1;
gdk_flush();
return (ans);
}
USER_OBJECT_
R_flushRegKey(USER_OBJECT_ hkey, USER_OBJECT_ path, USER_OBJECT_ subKey)
{
USER_OBJECT_ ans;
HKEY lkey;
DWORD status;
lkey = getOpenRegKey(hkey, path);
status = RegFlushKey(lkey);
if(status != ERROR_SUCCESS) {
char errBuf[1000];
FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, NULL, GetLastError(),
MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
errBuf, sizeof(errBuf)/sizeof(errBuf[0]), NULL);
PROBLEM "Error flushing key: %s", errBuf
ERROR;
}
ans = NEW_LOGICAL(1);
LOGICAL_DATA(ans)[0] = TRUE;
return(ans);
}
static SEXP php_zval_to_r(zval **value) /* {{{ */
{
SEXP result = NULL_USER_OBJECT;
switch (Z_TYPE_PP(value)) {
case IS_LONG:
PROTECT(result = NEW_INTEGER(1));
INTEGER_DATA(result)[0] = Z_LVAL_PP(value);
UNPROTECT(1);
break;
case IS_DOUBLE:
PROTECT(result = NEW_NUMERIC(1));
NUMERIC_DATA(result)[0] = Z_DVAL_PP(value);
UNPROTECT(1);
break;
case IS_STRING:
PROTECT(result = NEW_CHARACTER(1));
SET_STRING_ELT(result, 0, COPY_TO_USER_STRING(Z_STRVAL_PP(value)));
UNPROTECT(1);
break;
case IS_BOOL:
PROTECT(result = NEW_LOGICAL(1));
LOGICAL_DATA(result)[0] = Z_BVAL_PP(value);
UNPROTECT(1);
break;
case IS_ARRAY:
result = php_hash_to_r(Z_ARRVAL_PP(value));
break;
default:
convert_to_string_ex(value);
PROTECT(result = NEW_CHARACTER(1));
SET_STRING_ELT(result, 0, COPY_TO_USER_STRING(Z_STRVAL_PP(value)));
UNPROTECT(1);
break;
}
return result;
}
USER_OBJECT_
R_createRegistryKey(USER_OBJECT_ hkey, USER_OBJECT_ subKey)
{
HKEY lkey, key;
DWORD created;
USER_OBJECT_ ans;
char *name;
LONG status = ERROR_SUCCESS;
lkey = getOpenRegKey(hkey, subKey);
name = CHAR_DEREF(STRING_ELT(subKey, 1));
status = RegCreateKeyEx(lkey, name, 0, (char *) NULL,
REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, NULL, &key, &created);
if(status != ERROR_SUCCESS) {
char errBuf[1000];
FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, NULL, GetLastError(),
MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
errBuf, sizeof(errBuf)/sizeof(errBuf[0]), NULL);
RegCloseKey(lkey);
PROBLEM "Can't create key %s: %s", name, errBuf
ERROR;
}
ans = NEW_LOGICAL(1);
if(created == REG_OPENED_EXISTING_KEY ) {
RegCloseKey(key);
} else {
RegFlushKey(key);
LOGICAL_DATA(ans)[0] = TRUE;
}
RegCloseKey(lkey);
return(ans);
}
USER_OBJECT_
R_getRegistryKeys(USER_OBJECT_ hkey, USER_OBJECT_ subKey, USER_OBJECT_ sgetInfo)
{
LONG status;
USER_OBJECT_ ans, names;
int getInfo = LOGICAL_DATA(sgetInfo)[0];
HKEY lkey;
DWORD i, maxSize, numKeys = 0, next = 0, count = 0;
char buf[1024], className[1024];
DWORD classNameSize = 1024, bufSize = 1024;
BYTE data[4000];
DWORD dataSize = 4000, type;
int numProtects = 2;
lkey = getOpenRegKey(hkey, subKey);
status = RegQueryInfoKey(lkey, className, &classNameSize, NULL, &maxSize,
NULL, NULL, &numKeys, NULL, NULL, NULL, NULL);
if(status != ERROR_SUCCESS) {
char errBuf[1000];
FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, NULL, GetLastError(),
MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
errBuf, sizeof(errBuf)/sizeof(errBuf[0]), NULL);
RegCloseKey(lkey);
PROBLEM "Error in get keys: %s", errBuf
ERROR;
}
count = getInfo ? maxSize : numKeys;
i = next = 0;
if(getInfo)
PROTECT(ans = NEW_CHARACTER(count));
else
PROTECT(ans = NEW_LIST(count));
PROTECT(names = NEW_CHARACTER(count));
while(1) {
/* Need to reset these since the previous call will have set them to the actual values. */
bufSize = 1024; classNameSize = 1024, dataSize = 4000;
if(getInfo) {
FILETIME ftime;
status = RegEnumKeyEx(lkey, next, buf, &bufSize, (LPDWORD) NULL, className, &classNameSize, &ftime);
} else
status = RegEnumValue(lkey, next, buf, &bufSize, (LPDWORD) NULL, &type, data, &dataSize);
if(status == ERROR_SUCCESS) {
SET_STRING_ELT(names, i, COPY_TO_USER_STRING(buf));
if(getInfo)
SET_STRING_ELT(ans, i, COPY_TO_USER_STRING(className));
else {
USER_OBJECT_ tmpVal = convertRegistryValueToS(data, dataSize, type);
if(tmpVal != R_NilValue)
SET_VECTOR_ELT(ans, i, tmpVal);
}
} else if(status == ERROR_NO_MORE_ITEMS) {
break;
} else if(status == ERROR_MORE_DATA) {
PROBLEM "More data error when fetching key value (%d) %s", (int) next, buf
WARN;
} else {
char errBuf[1000];
FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, NULL, GetLastError(),
MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
errBuf, sizeof(errBuf)/sizeof(errBuf[0]), NULL);
RegCloseKey(lkey);
PROBLEM "Error in RegEnumKeyEx (%d): %s %s", (int) next, buf, errBuf
ERROR;
}
next++;
i++;
}
RegCloseKey(lkey);
SET_NAMES(ans, names);
UNPROTECT(numProtects);
return(ans);
}
/* {{{ proto mixed R::__call(string function_name, array arguments)
*/
static PHP_METHOD(R, __call)
{
char *func;
int func_len, error_occurred = 0, num_args;
zval *args;
SEXP e, fun, val, arg, next;
HashPosition pos;
zval **element;
SEXPTYPE type;
if (zend_parse_parameters(ZEND_NUM_ARGS() TSRMLS_CC, "sa", &func, &func_len, &args) == FAILURE) {
return;
}
fun = Rf_install(func);
if (!fun) {
RETURN_FALSE;
}
num_args = zend_hash_num_elements(Z_ARRVAL_P(args));
PROTECT(fun);
PROTECT(e = allocVector(LANGSXP, num_args + 1));
SETCAR(e, fun);
next = CDR(e);
for(zend_hash_internal_pointer_reset_ex(Z_ARRVAL_P(args), &pos);
zend_hash_get_current_data_ex(Z_ARRVAL_P(args), (void **)&element, &pos) == SUCCESS;
zend_hash_move_forward_ex(Z_ARRVAL_P(args), &pos)
) {
arg = php_zval_to_r(element);
SETCAR(next, arg);
next = CDR(next);
}
val = R_tryEval(e, R_GlobalEnv, &error_occurred);
if (error_occurred) {
UNPROTECT(2);
RETURN_FALSE;
}
/* okay, the call succeeded */
PROTECT(val);
if (val == NULL_USER_OBJECT || GET_LENGTH(val) == 0) {
/* ignore the return value */
} else if (php_is_r_primitive(val, &type)) {
int i;
array_init(return_value);
for (i = 0; i < GET_LENGTH(val); i++) {
switch (type) {
case STRSXP:
add_next_index_string(return_value, CHAR(STRING_ELT(val, 0)), 1);
break;
case LGLSXP:
add_next_index_bool(return_value, LOGICAL_DATA(val)[0] ? 1 : 0);
break;
case INTSXP:
add_next_index_long(return_value, INTEGER_DATA(val)[0]);
break;
case REALSXP:
add_next_index_double(return_value, NUMERIC_DATA(val)[0]);
break;
default:
add_next_index_null(return_value);
break;
}
}
UNPROTECT(3);
return;
}
UNPROTECT(3);
RETURN_TRUE;
}
SV *
toPerl(USER_OBJECT_ val, Rboolean perlOwned)
{
int n = GET_LENGTH(val);
dTHX;
SV *sv = &sv_undef;
if(val == NULL_USER_OBJECT)
return(sv);
if(isRSReferenceObject(val)){
return(getForeignPerlReference(val));
}
if(GET_LENGTH(GET_CLASS(val))) {
SV *o = userLevelConversionToPerl(val);
if(!o)
return(o);
}
if(n == 1) {
if(IS_CHARACTER(val))
sv = newSVpv(CHAR_DEREF(STRING_ELT(val, 0)), 0);
else if(IS_LOGICAL(val))
sv = newSViv(LOGICAL_DATA(val)[0]);
else if(IS_INTEGER(val))
sv = newSViv(INTEGER_DATA(val)[0]);
else if(IS_NUMERIC(val))
sv = newSVnv(NUMERIC_DATA(val)[0]);
else if(IS_FUNCTION(val))
sv = RPerl_createRProxy(val);
} else {
AV *arr;
int i;
arr = newAV();
SvREFCNT_inc(arr);
if(n > 0)
av_extend(arr, n);
/* Did try using av_make() and storing the SVs in an array first, but didn't fix the problem
of bizarre array.
*/
for(i = 0; i < n ; i++) {
if(IS_CHARACTER(val))
sv = newSVpv(CHAR_DEREF(STRING_ELT(val, i)), 0);
else if(IS_LOGICAL(val))
sv = newSViv(LOGICAL_DATA(val)[i]);
else if(IS_INTEGER(val))
sv = newSViv(INTEGER_DATA(val)[i]);
else if(IS_NUMERIC(val))
sv = newSVnv(NUMERIC_DATA(val)[i]);
SvREFCNT_inc(sv);
av_push(arr, sv);
}
sv = (SV *) arr;
SvREFCNT_dec(arr);
#if 0
{SV *rv = newSVrv(arr, NULL);
sv = rv;
}
#endif
}
if(perlOwned)
#if 0 /*XXX Just experimenting */
sv = sv_2mortal(sv);
#else
sv = SvREFCNT_inc(sv);
#endif
return(sv);
}
