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); }