1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
|
### tclVarFun.R - A series of additional function to manipulate Tcl variables
### and functions from within R and vice versa
### Copyright (c), Philippe Grosjean (phgrosjean@sciviews.org)
### Licensed under LGPL 3 or above
###
### Changes:
### - 2007-01-01: fisrt version (for tcltk2_1.0-0)
###
### To do:
### - Add a catch {} in tclFun and handle it
### - A tclFunDispose() function to delete the Tcl equivalent of a function
### - Add a try construct in tclVarExists and tclVarFind
### - better manage catch{} in tclVarName
makeTclNames <- function (names, unique = FALSE)
{
## Make valid Tcl variable names (allow_ = TRUE by default in R >= 2.0.0)
names <- make.names(names, unique = unique)
## There is a problem if the variable starts with a dot => prepend it with 'X'
.names <- grep("^\\.", names)
names[.names] <- paste("X", names[.names], sep = "")
## Although it is accepted, there could be problems with variable names
## containing dots, so, replace them with '_'
names <- gsub("\\.", "_", names)
return(names)
}
### TODO: change this to use closure functions instead!!!
tclFun <- function (f, name = deparse(substitute(f)))
{
## Register a simple R function (without arguments) as a callback in Tcl,
## and give it the same name under Tcl)
## Indeed, .Tcl.callback(f) does the job... but it gives criptic names
## like R_call 0x13c7168
## Check that 'f' is a function with no arguments (cannot handle them yet)
if (!is.function(f)) stop("'f' must be a function!")
if (!is.null(formals(f))) stop("The function used cannot (yet) have arguments!")
## Make sure the name of the function is valid
if (!is.character(name)) stop("'name' must be a character string!") else
name <- make.names(name[1])
res <- .Tcl.callback(f)
## Make sure this is correct (R_call XXXXXXXX)
if (length(grep("R_call ", res) > 0)) {
## Create a proc with the same name in Tcl
.Tcl(paste("proc ", name, " {} {", res, "}", sep = ""))
}
## Return the R_call XXXXXXXX string, as .Tcl.callback() does
return(res)
## Rem: if you delete the R 'f' function, the Tcl 'f' function still works!
## You have to explicitly delete the Tcl function
}
tclGetValue <- function (name)
{
## Get the value stored in a plain Tcl variable
if (!is.character(name))
stop("'name' must be a character!")
name <- makeTclNames(name[1]) # The usual name conversion
## Create a temporary dual variable with tclVar() (name does not mather)
Temp <- tclVar(init = "")
## Copy the content of the var of interest to it
res <- tclvalue(.Tcl(paste("catch {set ", as.character(Temp), " $", name,
"}", sep = ""))) # Return "0" if OK, "1" otherwise
if (res != "0")
stop(gettextf("Error when getting the value in the '%s' Tcl variable",
name))
## Get the content of the temporary variable
return(tclvalue(Temp)) # (Temp will be destroyed when the function exits)
}
tclSetValue <- function (name, value)
{
## This is the opposite of tclGetValue() and it is a wrapper
## for 'set name value' Tcl command
if (!is.character(name))
stop("'name' must be a character!")
name <- makeTclNames(name[1]) # The usual name conversion
## Create a temporary dual variable with tclVar() (name does not mather)
Temp <- tclVar(init = value)
## Copy the content of this variable to the tcl variable 'name'
res <- tclvalue(.Tcl(paste("catch {set ", name, " $", as.character(Temp),
"}", sep = "")))
if (res != "0")
stop(gettextf("Error when changing the value of the '%s' Tcl variable",
name))
## (Temp is destroyed when the function exits)
return(invisible(name)) # Return the name of the Tcl variable invisibly
}
tclVarExists <- function (name)
as.integer(tcl("info", "exists", name)) == 1
tclVarFind <- function (pattern)
as.character(tcl("info", "vars", pattern))
tclVarName <- function (name, init = "", keep.existing = TRUE)
{
## tclVar gives names like ::RtclX automatically...
## We need to define names ourselve. This is what tclVarName does
## If keep existing == TRUE and the variable is already defined, then
## we keep its content, instead of initializing it with "init"
if (!is.character(name)) stop("'name' must be a character!")
name <- makeTclNames(name[1]) # Make sure the name is correct
## Temporary save potential content of the Tcl variable elsewhere
## (catch in case the variable does not exist)
if (isTRUE(keep.existing))
.Tcl(paste("catch {set ZZZTempRvariable $", name, "}", sep = ""))
## Create the new dual Tcl-R variable
l <- list(env = new.env())
assign(name, NULL, envir = l$env)
reg.finalizer(l$env, function(env) tcl("unset", ls(env)))
class(l) <- "tclVar"
tclvalue(l) <- init
## Possibly restore the content of the variable, if keep.existing == TRUE
if (isTRUE(keep.existing)) {
.Tcl(paste("catch {set", name, "$ZZZTempRvariable}"))
## Remove the temporary variable
.Tcl("unset -nocomplain ZZZTempRvariable")
}
return(l)
}
|
