The R Project SVN R

Rev

Rev 80917 | Rev 81042 | Go to most recent revision | Show entire file | Ignore whitespace | Details | Blame | Last modification | View Log | RSS feed

Rev 80917 Rev 80997
Line 1089... Line 1089...
1089 
 
 1089 
 
1090 
/* #define DEBUG_GETTEXT 1 */
 1090 
/* #define DEBUG_GETTEXT 1 */
1091 
 
 1091 
 
1092 
 
 1092 
 
1093 
/* Called from do_gettext() and do_ngettext() */
 1093 
/* Called from do_gettext() and do_ngettext() */
1094 
static char * determine_domain_gettext(SEXP domain_, SEXP rho)
 1094 
static char * determine_domain_gettext(SEXP domain_)
1095 
{
 1095 
{
1096 
    const char *domain = "";
 1096 
    const char *domain = "";
1097 
    char *buf; // will be returned
 1097 
    char *buf; // will be returned
1098 
 
 1098 
 
- 
 
 1099 
    /* If cptr->cloenv is not R_GlobalEnv,
1099 
    /* The passed rho is ignored because (n)gettext is called through a
 1100 
     * ENCLOS(cptr->cloenv) is CLOENV(cptr->callfun) */
1100 
     * helper function in stop.R. And the context is more useful anyhow */
 1101 
    /* R_findParentContext(cptr, 1)->cloenv == cptr->sysparent */
1101 
    if(isNull(domain_)) {
 1102 
    if(isNull(domain_)) {
1102 
	RCNTXT *cptr;
 1103 
	RCNTXT *cptr = R_findParentContext(R_GlobalContext, 1);
1103 
	for (cptr = R_GlobalContext; cptr != NULL && cptr->callflag != CTXT_TOPLEVEL;
 1104 
	SEXP rho = cptr ? CLOENV(cptr->callfun) : R_EmptyEnv;
- 
 
 1105 
 
1104 
	     cptr = cptr->nextcontext)
 1106 
	/* stop() etc have internal call to .makeMessage */
1105 
	    if (cptr->callflag & CTXT_FUNCTION) {
 1107 
	/* gettextf calls gettext */
1106 
		/* stop() etc have internal call to .makeMessage */
 1108 
	if (rho == R_BaseNamespace) {
1107 
		const char *cfn = CHAR(STRING_ELT(deparse1s(CAR(cptr->call)), 0));
 1109 
	    SEXP call = getCurrentCall(), cfn = CAR(call);
1108 
 
 - 
 
1109 
		if(streql(cfn, "stop") || streql(cfn, "warning") || streql(cfn, "message"))
 1110 
	    if (TYPEOF(cfn) == SYMSXP && !streql(CHAR(PRINTNAME(cfn)), "ngettext") &&
1110 
		    continue;
 1111 
		TYPEOF(CADR(call)) == SYMSXP) {
1111 
		else
 1112 
		cptr = R_findParentContext(cptr, 1);
1112 
		    break;
 1113 
		rho = cptr ? CLOENV(cptr->callfun) : R_EmptyEnv;
1113 
	    }
 1114 
	    }
- 
 
 1115 
	}
1114 
 
 1116 
 
1115 
	/* First we try to see if sysparent leads us to a namespace, because gettext
 - 
 
1116 
	   might have a different environment due to being called from (in?) a closure.
 - 
 
1117 
	   If that fails we try cloenv, as the original code did. */
 - 
 
1118 
	/* FIXME: should we only do this search when cptr->callflag & CTXT_FUNCTION? */
 - 
 
1119 
	SEXP ns = R_NilValue;
 1117 
	SEXP ns = R_NilValue;
1120 
	for(size_t attempt = 0; attempt < 2 && isNull(ns); attempt++) {
 - 
 
1121 
	    rho = (cptr == NULL) ?
 - 
 
1122 
		R_EmptyEnv :
 - 
 
1123 
		attempt == 0 ? cptr->sysparent : cptr->cloenv;
 - 
 
1124 
	    while(rho != R_EmptyEnv) {
 1118 
	    while(rho != R_EmptyEnv) {
1125 
		if (rho == R_GlobalEnv) break;
 1119 
		if (rho == R_GlobalEnv) break;
1126 
		else if (R_IsNamespaceEnv(rho)) {
 1120 
		else if (R_IsNamespaceEnv(rho)) {
1127 
		    ns = R_NamespaceEnvSpec(rho);
 1121 
		    ns = R_NamespaceEnvSpec(rho);
1128 
		    break;
 1122 
		    break;
1129 
		}
 1123 
		}
- 
 
 1124 
		if(rho == ENCLOS(rho)) break; // *does* happen
1130 
		rho = ENCLOS(rho);
 1125 
		rho = ENCLOS(rho);
1131 
	    }
 1126 
	    }
1132 
	}
 - 
 
1133 
	if (!isNull(ns)) {
 1127 
	if (!isNull(ns)) {
1134 
	    PROTECT(ns);
 1128 
	    PROTECT(ns);
1135 
	    domain = translateChar(STRING_ELT(ns, 0));
 1129 
	    domain = translateChar(STRING_ELT(ns, 0));
1136 
	    if (strlen(domain)) {
 1130 
	    if (strlen(domain)) {
1137 
		size_t len = strlen(domain)+3;
 1131 
		size_t len = strlen(domain)+3;
Line 1171... Line 1165...
1171 
 
 1165 
 
1172 
    if(isNull(string) || !n) return string;
 1166 
    if(isNull(string) || !n) return string;
1173 
 
 1167 
 
1174 
    if(!isString(string)) error(_("invalid '%s' value"), "string");
 1168 
    if(!isString(string)) error(_("invalid '%s' value"), "string");
1175 
 
 1169 
 
1176 
    char * domain = determine_domain_gettext(CAR(args), rho);
 1170 
    char * domain = determine_domain_gettext(CAR(args));
1177 
 
 1171 
 
1178 
    if(domain && strlen(domain)) {
 1172 
    if(domain && strlen(domain)) {
1179 
	SEXP ans = PROTECT(allocVector(STRSXP, n));
 1173 
	SEXP ans = PROTECT(allocVector(STRSXP, n));
1180 
	for(int i = 0; i < n; i++) {
 1174 
	for(int i = 0; i < n; i++) {
1181 
	    int ihead = 0, itail = 0;
 1175 
	    int ihead = 0, itail = 0;
Line 1245... Line 1239...
1245 
	error(_("'%s' must be a character string"), "msg1");
 1239 
	error(_("'%s' must be a character string"), "msg1");
1246 
    if(!isString(msg2) || LENGTH(msg2) != 1)
 1240 
    if(!isString(msg2) || LENGTH(msg2) != 1)
1247 
	error(_("'%s' must be a character string"), "msg2");
 1241 
	error(_("'%s' must be a character string"), "msg2");
1248 
 
 1242 
 
1249 
#ifdef ENABLE_NLS
 1243 
#ifdef ENABLE_NLS
1250 
    SEXP sdom = CADDDR(args);
 - 
 
1251 
    char * domain = determine_domain_gettext(sdom, rho);
 1244 
    char * domain = determine_domain_gettext(CADDDR(args));
1252 
 
 1245 
 
1253 
    if(domain && strlen(domain)) {
 1246 
    if(domain && strlen(domain)) {
1254 
	/* libintl seems to malfunction if given a message of "" */
 1247 
	/* libintl seems to malfunction if given a message of "" */
1255 
	if(length(STRING_ELT(msg1, 0))) {
 1248 
	if(length(STRING_ELT(msg1, 0))) {
1256 
	    char *fmt = dngettext(domain,
 1249 
	    char *fmt = dngettext(domain,