The R Project SVN R

Rev

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

Rev 45528 Rev 46038
Line 33... Line 33...
33 
#include <wchar.h>
 33 
#include <wchar.h>
34 
#include <R_ext/rlocale.h>
 34 
#include <R_ext/rlocale.h>
35 
 
 35 
 
36 
#include "Defn.h"
 36 
#include "Defn.h"
37 
#include "Print.h"
 37 
#include "Print.h"
- 
 
 38 
#include <Rinternals.h>
- 
 
 39 
#include <R_ext/Parse.h>  /* parsing is used in handling escape codes */
38 
 
 40 
 
39 
#include "graphapp/ga.h"
 41 
#include "graphapp/ga.h"
40 
#include "console.h"
 42 
#include "console.h"
41 
#include "consolestructs.h"
 43 
#include "consolestructs.h"
42 
#include "rui.h"
 44 
#include "rui.h"
Line 772... Line 774...
772 
	SET_VECTOR_ELT(DE->work, wcol - 1, tmp2);
 774 
	SET_VECTOR_ELT(DE->work, wcol - 1, tmp2);
773 
    }
 775 
    }
774 
    return newcol;
 776 
    return newcol;
775 
}
 777 
}
776 
 
 778 
 
- 
 
 779 
static SEXP lang5(SEXP s, SEXP t, SEXP u, SEXP v, SEXP w)
- 
 
 780 
{
- 
 
 781 
    PROTECT(s);
- 
 
 782 
    s = LCONS(s, list4(t, u, v, w));
- 
 
 783 
    UNPROTECT(1);
- 
 
 784 
    return s;
- 
 
 785 
}
- 
 
 786 
 
- 
 
 787 
static SEXP processEscapes(SEXP x)
- 
 
 788 
{
- 
 
 789 
    SEXP newval, pattern, replacement, expr;
- 
 
 790 
    ParseStatus status;
- 
 
 791
- 
 
 792 
    /* We process escape sequences in a scalar string by escaping
- 
 
 793 
       unescaped quotes, then quoting the whole thing and parsing it.  This
- 
 
 794 
       is supposed to be equivalent to the R code
- 
 
 795 
 
- 
 
 796 
       newval <- gsub(perl=TRUE, "(?<!\\\\)((\\\\\\\\)*)\"", "\\1\\\\\"", x)
- 
 
 797 
       newval <- sub('(^.*$)', '"\1"', newval)
- 
 
 798 
       newval <- eval(parse(text=newval))
- 
 
 799 
 
- 
 
 800 
       We do it this way to avoid extracting the escape handling
- 
 
 801 
       code from the parser.  We need it in C code because this may be executed
- 
 
 802 
       numerous times from C in dataentry.c */
- 
 
 803
- 
 
 804 
    PROTECT( pattern = mkString("(?<!\\\\)((\\\\\\\\)*)\"") );
- 
 
 805 
    PROTECT( replacement = mkString("\\1\\\\\"") );
- 
 
 806 
    PROTECT( expr = lang5(install("gsub"), ScalarLogical(1), pattern, replacement, x) );
- 
 
 807 
    SET_TAG( CDR(expr), install("perl") );
- 
 
 808 
 
- 
 
 809 
    PROTECT( newval = eval(expr, R_BaseEnv) );
- 
 
 810 
    PROTECT( pattern = mkString("(^.*$)") );
- 
 
 811 
    PROTECT( replacement = mkString("\"\\1\"") );
- 
 
 812 
    PROTECT( expr = lang4(install("sub"), pattern, replacement, newval) );
- 
 
 813 
    PROTECT( newval = eval(expr, R_BaseEnv) );
- 
 
 814 
    PROTECT( expr = R_ParseVector( newval, 1, &status, R_NilValue) );
- 
 
 815
- 
 
 816 
    /* We only handle the first entry. If this were available more generally,
- 
 
 817 
       we'd probably want to loop over all of expr */
- 
 
 818
- 
 
 819 
    if (status == PARSE_OK && length(expr))
- 
 
 820 
	PROTECT( newval = eval(VECTOR_ELT(expr, 0), R_BaseEnv) );
- 
 
 821 
    else
- 
 
 822 
	PROTECT( newval = R_NilValue );  /* protect just so the count doesn't change */
- 
 
 823 
    UNPROTECT(10);
- 
 
 824 
    return newval;
- 
 
 825 
}
- 
 
 826 
 
777 
/* close up the entry to a cell, put the value that has been entered
 827 
/* close up the entry to a cell, put the value that has been entered
778 
   into the correct place and as the correct type */
 828 
   into the correct place and as the correct type */
779 
 
 829 
 
780 
static void closerect(DEstruct DE)
 830 
static void closerect(DEstruct DE)
781 
{
 831 
{
Line 801... Line 851...
801 
	if (DE->clength != 0) {
 851 
	if (DE->clength != 0) {
802 
	    /* do it this way to ensure NA, Inf, ...  can get set */
 852 
	    /* do it this way to ensure NA, Inf, ...  can get set */
803 
	    char *endp;
 853 
	    char *endp;
804 
	    double new = R_strtod(DE->buf, &endp);
 854 
	    double new = R_strtod(DE->buf, &endp);
805 
	    int warn = !isBlankString(endp);
 855 
	    int warn = !isBlankString(endp);
806 
	    if (TYPEOF(cvec) == STRSXP)
 856 
	    if (TYPEOF(cvec) == STRSXP) {
- 
 
 857 
	    	SEXP newval;
- 
 
 858 
	    	PROTECT( newval = mkString(DE->buf) );
- 
 
 859 
	    	PROTECT( newval = processEscapes(newval) );
- 
 
 860 
	    	if (TYPEOF(newval) == STRSXP && length(newval) == 1)
807 
		SET_STRING_ELT(cvec, wrow - 1, mkChar(DE->buf));
 861 
		    SET_STRING_ELT(cvec, wrow - 1, STRING_ELT(newval, 0));
- 
 
 862 
		else
- 
 
 863 
		    warning(G_("dataentry: parse error on string"));
- 
 
 864 
		UNPROTECT(2);
808 
	    else
 865 
	    } else
809 
		REAL(cvec)[wrow - 1] = new;
 866 
		REAL(cvec)[wrow - 1] = new;
810 
	    if (newcol && warn) {
 867 
	    if (newcol && warn) {
811 
		/* change mode to character */
 868 
		/* change mode to character */
812 
		SEXP tmp = coerceVector(cvec, STRSXP);
 869 
		SEXP tmp = coerceVector(cvec, STRSXP);
813 
		SET_STRING_ELT(tmp, wrow - 1, mkChar(DE->buf));
 870 
		SET_STRING_ELT(tmp, wrow - 1, mkChar(DE->buf));