SEXP writetable(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP x, sep, rnames, eol, na, dec, quote, xj;
int nr, nc, i, j, qmethod;
Rboolean wasopen, quote_rn = FALSE, *quote_col;
Rconnection con;
const char *csep, *ceol, *cna, *sdec, *tmp=NULL /* -Wall */;
char cdec;
SEXP *levels;
R_StringBuffer strBuf = {NULL, 0, MAXELTSIZE};
wt_info wi;
RCNTXT cntxt;
args = CDR(args);
x = CAR(args); args = CDR(args);
/* this is going to be a connection open or openable for writing */
if(!inherits(CAR(args), "connection"))
error(_("'file' is not a connection"));
con = getConnection(asInteger(CAR(args))); args = CDR(args);
if(!con->canwrite)
error(_("cannot write to this connection"));
wasopen = con->isopen;
if(!wasopen) {
strcpy(con->mode, "wt");
if(!con->open(con)) error(_("cannot open the connection"));
}
nr = asInteger(CAR(args)); args = CDR(args);
nc = asInteger(CAR(args)); args = CDR(args);
rnames = CAR(args); args = CDR(args);
sep = CAR(args); args = CDR(args);
eol = CAR(args); args = CDR(args);
na = CAR(args); args = CDR(args);
dec = CAR(args); args = CDR(args);
quote = CAR(args); args = CDR(args);
qmethod = asLogical(CAR(args));
if(nr == NA_INTEGER) error(_("invalid '%s' argument"), "nr");
if(nc == NA_INTEGER) error(_("invalid '%s' argument"), "nc");
if(!isNull(rnames) && !isString(rnames))
error(_("invalid '%s' argument"), "rnames");
if(!isString(sep)) error(_("invalid '%s' argument"), "sep");
if(!isString(eol)) error(_("invalid '%s' argument"), "eol");
if(!isString(na)) error(_("invalid '%s' argument"), "na");
if(!isString(dec)) error(_("invalid '%s' argument"), "dec");
if(qmethod == NA_LOGICAL) error(_("invalid '%s' argument"), "qmethod");
csep = translateChar(STRING_ELT(sep, 0));
ceol = translateChar(STRING_ELT(eol, 0));
cna = translateChar(STRING_ELT(na, 0));
sdec = translateChar(STRING_ELT(dec, 0));
if(strlen(sdec) != 1)
error(_("'dec' must be a single character"));
cdec = sdec[0];
quote_col = (Rboolean *) R_alloc(nc, sizeof(Rboolean));
for(j = 0; j < nc; j++) quote_col[j] = FALSE;
for(i = 0; i < length(quote); i++) { /* NB, quote might be NULL */
int this = INTEGER(quote)[i];
if(this == 0) quote_rn = TRUE;
if(this > 0) quote_col[this - 1] = TRUE;
}
R_AllocStringBuffer(0, &strBuf);
PrintDefaults();
wi.savedigits = R_print.digits; R_print.digits = DBL_DIG;/* MAX precision */
wi.con = con;
wi.wasopen = wasopen;
wi.buf = &strBuf;
begincontext(&cntxt, CTXT_CCODE, call, R_BaseEnv, R_BaseEnv,
R_NilValue, R_NilValue);
cntxt.cend = &wt_cleanup;
cntxt.cenddata = &wi;
if(isVectorList(x)) { /* A data frame */
/* handle factors internally, check integrity */
levels = (SEXP *) R_alloc(nc, sizeof(SEXP));
for(j = 0; j < nc; j++) {
xj = VECTOR_ELT(x, j);
if(LENGTH(xj) != nr)
error(_("corrupt data frame -- length of column %d does not not match nrows"), j+1);
if(inherits(xj, "factor")) {
levels[j] = getAttrib(xj, R_LevelsSymbol);
} else levels[j] = R_NilValue;
}
for(i = 0; i < nr; i++) {
if(i % 1000 == 999) R_CheckUserInterrupt();
if(!isNull(rnames))
Rconn_printf(con, "%s%s",
EncodeElement2(rnames, i, quote_rn, qmethod,
&strBuf, cdec), csep);
for(j = 0; j < nc; j++) {
xj = VECTOR_ELT(x, j);
if(j > 0) Rconn_printf(con, "%s", csep);
if(isna(xj, i)) tmp = cna;
else {
if(!isNull(levels[j])) {
/* We do not assume factors have integer levels,
although they should. */
if(TYPEOF(xj) == INTSXP)
tmp = EncodeElement2(levels[j], INTEGER(xj)[i] - 1,
quote_col[j], qmethod,
&strBuf, cdec);
else if(TYPEOF(xj) == REALSXP)
tmp = EncodeElement2(levels[j],
(int) (REAL(xj)[i] - 1),
quote_col[j], qmethod,
&strBuf, cdec);
else
error("column %s claims to be a factor but does not have numeric codes", j+1);
} else {
tmp = EncodeElement2(xj, i, quote_col[j], qmethod,
&strBuf, cdec);
}
/* if(cdec) change_dec(tmp, cdec, TYPEOF(xj)); */
}
Rconn_printf(con, "%s", tmp);
}
Rconn_printf(con, "%s", ceol);
}
} else { /* A matrix */
if(!isVectorAtomic(x))
UNIMPLEMENTED_TYPE("write.table, matrix method", x);
/* quick integrity check */
if(LENGTH(x) != nr * nc)
error(_("corrupt matrix -- dims not not match length"));
for(i = 0; i < nr; i++) {
if(i % 1000 == 999) R_CheckUserInterrupt();
if(!isNull(rnames))
Rconn_printf(con, "%s%s",
EncodeElement2(rnames, i, quote_rn, qmethod,
&strBuf, cdec), csep);
for(j = 0; j < nc; j++) {
if(j > 0) Rconn_printf(con, "%s", csep);
if(isna(x, i + j*nr)) tmp = cna;
else {
tmp = EncodeElement2(x, i + j*nr, quote_col[j], qmethod,
&strBuf, cdec);
/* if(cdec) change_dec(tmp, cdec, TYPEOF(x)); */
}
Rconn_printf(con, "%s", tmp);
}
Rconn_printf(con, "%s", ceol);
}
}
endcontext(&cntxt);
wt_cleanup(&wi);
return R_NilValue;
}
int main(int argc, const char **argv) {
wi_mutable_array_t *arguments;
wi_pool_t *pool;
wi_string_t *string, *root_path;
int ch, facility;
wi_boolean_t test_config, daemonize, change_directory, switch_user;
/* init libwired */
wi_initialize();
wi_load(argc, argv);
pool = wi_pool_init(wi_pool_alloc());
wi_log_syslog = true;
wi_log_syslog_facility = LOG_DAEMON;
/* init core systems */
wt_version_init();
wt_status_lock = wi_lock_init(wi_lock_alloc());
wt_start_date = wi_date_init(wi_date_alloc());
/* set defaults */
root_path = WI_STR(WT_ROOT);
wi_settings_config_path = wi_string_init_with_cstring(wi_string_alloc(), WT_CONFIG_PATH);
test_config = false;
daemonize = true;
change_directory = true;
switch_user = true;
/* init reexec argument list */
arguments = wi_array_init(wi_mutable_array_alloc());
/* parse command line switches */
while((ch = getopt(argc, (char * const *) argv, "46Dd:f:hi:L:ls:tuVvXx")) != -1) {
switch(ch) {
case '4':
wt_address_family = WI_ADDRESS_IPV4;
break;
case '6':
wt_address_family = WI_ADDRESS_IPV6;
break;
case 'D':
daemonize = false;
wi_log_stderr = true;
break;
case 'd':
root_path = wi_string_with_cstring(optarg);
break;
case 'f':
wi_release(wi_settings_config_path);
wi_settings_config_path = wi_string_init_with_cstring(wi_string_alloc(), optarg);
break;
case 'i':
wi_log_limit = wi_string_uint32(wi_string_with_cstring(optarg));
break;
case 'L':
wi_log_syslog = false;
wi_log_file = true;
wi_release(wi_log_path);
wi_log_path = wi_string_init_with_cstring(wi_string_alloc(), optarg);
break;
case 'l':
wi_log_level++;
break;
case 's':
string = wi_string_with_cstring(optarg);
facility = wi_log_syslog_facility_with_name(string);
if(facility < 0)
wi_log_fatal(WI_STR("Could not find syslog facility \"%@\": %m"), string);
wi_log_syslog_facility = facility;
break;
case 't':
test_config = true;
break;
case 'u':
break;
case 'V':
case 'v':
wt_version();
break;
case 'X':
daemonize = false;
break;
case 'x':
daemonize = false;
change_directory = false;
switch_user = false;
break;
case '?':
case 'h':
default:
wt_usage();
break;
}
wi_mutable_array_add_data(arguments, wi_string_with_format(WI_STR("-%c"), ch));
if(optarg)
wi_mutable_array_add_data(arguments, wi_string_with_cstring(optarg));
}
/* detach */
if(daemonize) {
wi_mutable_array_add_data(arguments, WI_STR("-X"));
switch(wi_fork()) {
case -1:
wi_log_fatal(WI_STR("Could not fork: %m"));
break;
case 0:
if(!wi_execv(wi_string_with_cstring(argv[0]), arguments))
wi_log_fatal(WI_STR("Could not execute %s: %m"), argv[0]);
break;
default:
_exit(0);
break;
}
}
wi_release(arguments);
/* change directory */
if(change_directory) {
if(!wi_fs_change_directory(root_path))
wi_log_error(WI_STR("Could not change directory to %@: %m"), root_path);
}
/* open log */
wi_log_open();
/* init subsystems */
wt_ssl_init();
wt_clients_init();
wt_servers_init();
/* read the config file */
wt_settings_init();
if(!wt_settings_read_config())
exit(1);
/* apply settings */
wt_settings_apply_settings();
if(test_config) {
printf("Config OK\n");
exit(0);
}
/* dump command line */
wi_log_info(WI_STR("Started as %@ %@"),
wi_process_path(wi_process()),
wi_array_components_joined_by_string(wi_process_arguments(wi_process()), WI_STR(" ")));
/* init tracker */
wi_log_info(WI_STR("Starting Wired Tracker version %@"), wt_version_string);
wt_tracker_init();
/* switch user/group */
if(switch_user)
wi_switch_user(wt_settings.user, wt_settings.group);
/* create tracker threads after privilege drop */
wt_signals_init();
wt_block_signals();
wt_servers_schedule();
wt_tracker_create_threads();
wt_write_pid();
wt_write_status(true);
/* clean up pool after startup */
wi_pool_drain(pool);
/* enter the signal handling thread in the main thread */
wt_signal_thread(NULL);
/* dropped out */
wt_cleanup();
wi_log_close();
wi_release(pool);
return 0;
}
int main(int argc, const char **argv) {
wi_pool_t *pool;
wi_string_t *string;
int ch, facility;
wi_boolean_t no_chroot, test_config;
/* init libwired */
wi_initialize();
wi_load(argc, argv);
pool = wi_pool_init(wi_pool_alloc());
wi_log_startup = true;
wi_log_syslog = true;
wi_log_syslog_facility = LOG_DAEMON;
/* init core systems */
wt_init_version();
wt_status_lock = wi_lock_init(wi_lock_alloc());
wt_start_date = wi_date_init(wi_date_alloc());
/* set defaults */
wi_root_path = wi_string_init_with_cstring(wi_string_alloc(), WT_ROOT);
wi_settings_config_path = wi_string_init_with_cstring(wi_string_alloc(), WT_CONFIG_PATH);
no_chroot = false;
test_config = false;
/* parse command line switches */
while((ch = getopt(argc, (char * const *) argv, "46Dd:f:hi:L:ls:tuVv")) != -1) {
switch(ch) {
case '4':
wt_address_family = WI_ADDRESS_IPV4;
break;
case '6':
wt_address_family = WI_ADDRESS_IPV6;
break;
case 'D':
wt_daemonize = false;
wi_log_stderr = true;
break;
case 'd':
wi_release(wi_root_path);
wi_root_path = wi_string_init_with_cstring(wi_string_alloc(), optarg);
break;
case 'f':
wi_release(wi_settings_config_path);
wi_settings_config_path = wi_string_init_with_cstring(wi_string_alloc(), optarg);
break;
case 'i':
wi_log_limit = wi_string_uint32(wi_string_with_cstring(optarg));
break;
case 'L':
wi_log_syslog = false;
wi_log_file = true;
wi_release(wi_log_path);
wi_log_path = wi_string_init_with_cstring(wi_string_alloc(), optarg);
break;
case 'l':
wi_log_level++;
break;
case 's':
string = wi_string_with_cstring(optarg);
facility = wi_log_syslog_facility_with_name(string);
if(facility < 0) {
wi_log_err(WI_STR("Could not find syslog facility \"%@\": %m"),
string);
}
wi_log_syslog_facility = facility;
break;
case 't':
test_config = true;
break;
case 'u':
no_chroot = true;
break;
case 'V':
case 'v':
wt_version();
break;
case '?':
case 'h':
default:
wt_usage();
break;
}
}
/* open log */
wi_log_open();
/* init subsystems */
wt_init_ssl();
wt_init_clients();
wt_init_servers();
/* read the config file */
wt_settings_chroot = !no_chroot;
wt_init_settings();
if(!wt_read_config())
exit(1);
/* change root directory */
if(!no_chroot) {
if(!wi_change_root())
wi_log_err(WI_STR("Could not change root to %@: %m"), wi_root_path);
}
/* apply config */
wt_apply_config();
if(test_config) {
printf("Config OK\n");
exit(0);
}
/* dump command line */
if(wi_log_level >= WI_LOG_DEBUG) {
wi_log_debug(WI_STR("Started as %@ %@"),
wi_process_path(wi_process()),
wi_array_components_joined_by_string(wi_process_arguments(wi_process()), WI_STR(" ")));
}
/* init tracker */
wi_log_info(WI_STR("Starting Wired Tracker version %@"), wt_version_string);
wt_init_tracker();
/* detach (don't chdir, don't close i/o channels) */
if(wt_daemonize) {
if(!wi_daemon())
wi_log_err(WI_STR("Could not become a daemon: %m"));
}
/* switch user/group */
wi_switch_user(wt_settings.user, wt_settings.group);
/* create tracker threads after privilege drop */
wt_init_signals();
wt_block_signals();
wt_schedule_servers();
wt_fork_tracker();
wt_write_pid();
wt_write_status(true);
wi_log_startup = false;
wi_release(pool);
pool = wi_pool_init(wi_pool_alloc());
/* enter the signal handling thread in the main thread */
wt_signal_thread(NULL);
/* dropped out */
wt_cleanup();
wi_log_close();
wi_release(pool);
return 0;
}
