[Sciviews-commits] r293 - in pkg/svSocket: . R inst
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mon Sep 6 18:32:12 CEST 2010
Author: phgrosjean
Date: 2010-09-06 18:32:12 +0200 (Mon, 06 Sep 2010)
New Revision: 293
Modified:
pkg/svSocket/DESCRIPTION
pkg/svSocket/NEWS
pkg/svSocket/R/closeSocketClients.R
pkg/svSocket/R/evalServer.R
pkg/svSocket/R/getSocket.R
pkg/svSocket/R/parSocket.R
pkg/svSocket/R/processSocket.R
pkg/svSocket/R/sendSocketClients.R
pkg/svSocket/R/startSocketServer.R
pkg/svSocket/R/stopSocketServer.R
pkg/svSocket/R/svSocket-Internal.R
pkg/svSocket/R/svTaskCallbackManager.R
pkg/svSocket/TODO
pkg/svSocket/inst/CITATION
Log:
Bug correction in the .Tcl.callback mechanism
Modified: pkg/svSocket/DESCRIPTION
===================================================================
--- pkg/svSocket/DESCRIPTION 2010-09-06 16:31:06 UTC (rev 292)
+++ pkg/svSocket/DESCRIPTION 2010-09-06 16:32:12 UTC (rev 293)
@@ -4,8 +4,8 @@
Depends: R (>= 2.6.0)
Imports: tcltk, svMisc
Description: Implements a simple socket server allowing to connect GUI clients to R
-Version: 0.9-48
-Date: 2009-09-17
+Version: 0.9-49
+Date: 2010-08-31
Author: Philippe Grosjean, Matthew Dowle
Maintainer: Philippe Grosjean <phgrosjean at sciviews.org>
License: GPL-2
Modified: pkg/svSocket/NEWS
===================================================================
--- pkg/svSocket/NEWS 2010-09-06 16:31:06 UTC (rev 292)
+++ pkg/svSocket/NEWS 2010-09-06 16:32:12 UTC (rev 293)
@@ -1,5 +1,11 @@
= svSocket News
+== Changes in svSocket 0.9-49
+
+* Small change in startSocketServer(): the Tcl/Tk callback function now calls
+ a closure located in TempEnv (SocketServerProc).
+
+
== Changes in svSocket 0.9-48
* svTaskCallbackManager() added to allow callbacks to be executed after each
Modified: pkg/svSocket/R/closeSocketClients.R
===================================================================
--- pkg/svSocket/R/closeSocketClients.R 2010-09-06 16:31:06 UTC (rev 292)
+++ pkg/svSocket/R/closeSocketClients.R 2010-09-06 16:32:12 UTC (rev 293)
@@ -1,5 +1,4 @@
-"closeSocketClients" <-
-function (sockets = "all", serverport = 8888)
+closeSocketClients <- function (sockets = "all", serverport = 8888)
{
# Nicely close socket client(s) by sending "\f"
# To be interpreted by a compatible client that manages to close connection
Modified: pkg/svSocket/R/evalServer.R
===================================================================
--- pkg/svSocket/R/evalServer.R 2010-09-06 16:31:06 UTC (rev 292)
+++ pkg/svSocket/R/evalServer.R 2010-09-06 16:32:12 UTC (rev 293)
@@ -14,7 +14,8 @@
readLines(con) # flush input stream just incase previous call failed to clean up.
if (missing(send)) {
- cat('..Last.value <- try(eval(parse(text = "',x,'"))); .f <- file(); dump("..Last.value", file = .f); flush(.f); seek(.f, 0); cat("\\n<<<startflag>>>", readLines(.f), "<<<endflag>>>\\n", sep = "\\n"); close(.f); rm(.f, ..Last.value); flush.console()\n',
+ cat('..Last.value <- try(eval(parse(text = "', x,
+ '"))); .f <- file(); dump("..Last.value", file = .f); flush(.f); seek(.f, 0); cat("\\n<<<startflag>>>", readLines(.f), "<<<endflag>>>\\n", sep = "\\n"); close(.f); rm(.f, ..Last.value); flush.console()\n',
file = con, sep = "")
# It is important that one line only is written, so that other clients
# don't mix in with these lines.
@@ -28,14 +29,15 @@
dump("..Last.value", file <- .f)
flush(.f)
seek(.f, 0)
- cat(readLines(.f), ';', x, ' <- ..Last.value; rm(..Last.value); cat("\\n<<<endflag>>>\\n"); flush.console()\n',
+ cat(readLines(.f), ';', x,
+ ' <- ..Last.value; rm(..Last.value); cat("\\n<<<endflag>>>\\n"); flush.console()\n',
file = con, sep = "")
}
objdump <- ""
endloc <- NULL
while (!length(endloc)) {
obj <- readLines(con, n = 1000, warn = FALSE)
- # wait for data to come back. Without this sleep, you get 20-30 calls
+ # Wait for data to come back. Without this sleep, you get 20-30 calls
# to readLines before data arrives.
if (!length(obj)) {
Sys.sleep(0.01)
@@ -54,7 +56,7 @@
start <- grep("<<<startflag>>>", objdump)
if (length(start) != 1)
stop("Unable to find <<<startflag>>>")
- # the startflag is because sometimes (strangely rarely) seek, flush and dump
+ # The startflag is because sometimes (strangely rarely) seek, flush and dump
# can write return value to stdout which do not source.
objdump <- objdump[-(1:start)]
# Fix any output buffer wrap issues. There are line breaks mid number
@@ -63,7 +65,7 @@
# warns about these noncomplete lines otherwise.
nospace <- grep("[^ ]$", objdump)
nospace <- nospace[nospace < length(objdump)]
- for (i in rev(nospace)) { #robust to consecutive lines to be joined
+ for (i in rev(nospace)) { # Robust to consecutive lines to be joined
objdump[i] <- paste(objdump[i], objdump[i + 1], sep = "")
objdump[i + 1] <- ""
}
Modified: pkg/svSocket/R/getSocket.R
===================================================================
--- pkg/svSocket/R/getSocket.R 2010-09-06 16:31:06 UTC (rev 292)
+++ pkg/svSocket/R/getSocket.R 2010-09-06 16:32:12 UTC (rev 293)
@@ -1,12 +1,10 @@
-"getSocketServers" <-
-function ()
+getSocketServers <- function ()
{
# Get the list of currently running socket servers
return(TempEnv()$SocketServers)
}
-"getSocketClients" <-
-function (port = 8888)
+getSocketClients <- function (port = 8888)
{
if (!is.numeric(port[1]) || port[1] < 1)
stop("'port' must be a positive integer!")
@@ -37,12 +35,10 @@
return(addresses)
}
-"getSocketClientsNames" <-
-function (port = 8888)
+getSocketClientsNames <- function (port = 8888)
names(getSocketClients(port = port))
-"getSocketServerName" <-
-function (port = 8888)
+getSocketServerName <- function (port = 8888)
{
if (!is.numeric(port[1]) || port[1] < 1)
stop("'port' must be a positive integer!")
Modified: pkg/svSocket/R/parSocket.R
===================================================================
--- pkg/svSocket/R/parSocket.R 2010-09-06 16:31:06 UTC (rev 292)
+++ pkg/svSocket/R/parSocket.R 2010-09-06 16:32:12 UTC (rev 293)
@@ -1,26 +1,24 @@
-"parSocket" <-
-function (client, serverport = 8888, ...)
+parSocket <- function (client, serverport = 8888, ...)
{
# Set or get parameters for a given socket client
# No attempt is made to make sure this client exists
sc <- paste("SocketClient", client, sep = "_")
- if (!exists(sc, envir = TempEnv
- (), inherits = FALSE,
+ if (!exists(sc, envir = TempEnv(), inherits = FALSE,
mode = "environment")) {
# Create a new environment with default values
e <- new.env(parent = TempEnv())
e$client <- client
e$serverport <- serverport
- e$prompt <- "> " # Default prompt
- e$continue <- "+ " # Default continuation prompt
- e$code <- "" # Current partial code for multiline mode
- e$last <- "" # String to add at the end of evaluations
- e$echo <- FALSE # Don't echo commands to the console
- e$flag <- FALSE # Do not flag pieces of code (not used yet!)
- e$multiline <- TRUE # Allow for multiline code
- e$bare <- TRUE # Always start in "bare" mode
+ e$prompt <- ":> " # Default prompt
+ e$continue <- ":+ " # Default continuation prompt
+ e$code <- "" # Current partial code for multiline mode
+ e$last <- "" # String to add at the end of evaluations
+ e$echo <- FALSE # Don't echo commands to the console
+ e$flag <- FALSE # Do not flag pieces of code (not used yet!)
+ e$multiline <- TRUE # Allow for multiline code
+ e$bare <- TRUE # Always start in "bare" mode
# Note: in bare mode, all other parameters are inactive!
- # And assign it to TempEnv
+ # and assign it to TempEnv
assign(sc, e, envir = TempEnv())
} else e <- get(sc, envir = TempEnv(), mode = "environment")
# Change or add parameters if they are provided
Modified: pkg/svSocket/R/processSocket.R
===================================================================
--- pkg/svSocket/R/processSocket.R 2010-09-06 16:31:06 UTC (rev 292)
+++ pkg/svSocket/R/processSocket.R 2010-09-06 16:32:12 UTC (rev 293)
@@ -1,5 +1,4 @@
-"processSocket" <-
-function (msg, socket, serverport, ...)
+processSocket <- function (msg, socket, serverport, ...)
{
# This is the default R function that processes a command send by a socket
# client. 'msg' is assumed to be R code contained in a string
@@ -65,7 +64,8 @@
parSocket(client, serverport, bare = TRUE)
} else if (startmsg == "<<<u>>>") {
msg <- substr(msg, 8, 1000000)
- # Silent execution, nothing is returned to the client (but still echoed to the server)
+ # Silent execution, nothing is returned to the client
+ # (but still echoed to the server)
hiddenMode <- FALSE
returnResults <- FALSE
parSocket(client, serverport, bare = TRUE)
Modified: pkg/svSocket/R/sendSocketClients.R
===================================================================
--- pkg/svSocket/R/sendSocketClients.R 2010-09-06 16:31:06 UTC (rev 292)
+++ pkg/svSocket/R/sendSocketClients.R 2010-09-06 16:32:12 UTC (rev 293)
@@ -1,5 +1,4 @@
-"sendSocketClients" <-
-function (text, sockets = "all", serverport = 8888)
+sendSocketClients <- function (text, sockets = "all", serverport = 8888)
{
# Note that 'real' clients should manage to print this BEFORE the current
# command line, something that 'SimpleClient.Tcl' cannot do!
Modified: pkg/svSocket/R/startSocketServer.R
===================================================================
--- pkg/svSocket/R/startSocketServer.R 2010-09-06 16:31:06 UTC (rev 292)
+++ pkg/svSocket/R/startSocketServer.R 2010-09-06 16:32:12 UTC (rev 293)
@@ -1,6 +1,5 @@
-"startSocketServer" <-
-function (port = 8888, server.name = "Rserver", procfun = processSocket,
-secure = FALSE, local = !secure)
+startSocketServer <- function (port = 8888, server.name = "Rserver",
+procfun = processSocket, secure = FALSE, local = !secure)
{
# OK, could be port = 80 to emulate a simple HTML server
# This is the main function that starts the server
@@ -13,14 +12,16 @@
# Secure server requires the tcl-tls package!
if (isTRUE(secure)) {
- # On Mac with AquaTclTk installed, I need: addTclPath("/System/Library/Tcl")
+ # TODO: On Mac with AquaTclTk installed, I need: addTclPath("/System/Library/Tcl")
res <- tclRequire("tls")
if (!inherits(res, "tclObj"))
stop("You must install the tcl-tls package for using a secure server!")
}
- is.function (procfun) || stop("'procfun' must be a function!")
- # Note: the data send by the client is in the Tcl $::sockMsg variable
+ if (!is.function(procfun))
+ stop("'procfun' must be a function!")
+
+ # Note: the data send by the client is in the Tcl $::sockMsg variable
# Could a clash happen here if multiple clients send data at the
# same time to the R socket server???
if (!is.numeric(port[1]) || port[1] < 1)
@@ -28,8 +29,9 @@
portnum <- round(port[1])
port <- as.character(portnum)
- if (!is.character(server.name)) stop("'server.name' must be a string!")
- server.name <- server.name[1]
+ if (!is.character(server.name))
+ stop("'server.name' must be a string!")
+ server.name <- as.character(server.name)[1]
# Check if the port is not open yet
servers <- getSocketServers()
@@ -43,42 +45,29 @@
if (!tclProcExists("SocketServerProc")) {
# Create the callback when a client sends data
- "SocketServerProc" <- function ()
- {
- #require(tcltk)
+ "SocketServerFun" <- function () {
# Note: I don't know how to pass arguments here.
# So, I use Tcl global variables instead:
# - the server port from $::sockPort,
# - the socket client from $::sockClient,
# - and the message from $::sockMsg
- "tclGetValue_" <- function (name) {
+ "tclGetValue_" <- function (name) {
# Get the value stored in a plain Tcl variable
if (!is.character(name)) stop("'name' must be a character!")
-
+
# Create a temporary dual variable with tclVar()
Temp <- tclVar(init = "")
# Copy the content of the var of interest to it
.Tcl(paste("catch {set ", as.character(Temp), " $", name, "}",
- sep = ""))
+ sep = ""))
# Get the content of the temporary variable
Res <- tclvalue(Temp) # Temp is destroyed when function exists
return(Res)
}
-
- port <- tclGetValue_("::sockPort")
- if (port == "") return(FALSE) # The server is closed
- client <- tclGetValue_("::sockClient")
- if (client == "") return(FALSE) # The socket client is unknown!
- msg <- tclGetValue_("::sockMsg")
- if (msg == "") return(FALSE) # No message!
-
- # Make sure this message is not processed twice
- .Tcl("set ::sockMsg {}")
-
- "TempEnv_" <- function ()
- {
+
+ "TempEnv_" <- function () {
pos <- match("TempEnv", search())
if (is.na(pos)) { # Must create it
TempEnv <- list()
@@ -89,8 +78,7 @@
return(pos.to.env(pos))
}
- "getTemp_" <- function (x, default = NULL, mode = "any")
- {
+ "getTemp_" <- function (x, default = NULL, mode = "any") {
if (exists(x, envir = TempEnv_(), mode = mode,
inherits = FALSE)) {
return(get(x, envir = TempEnv_(), mode = mode,
@@ -100,65 +88,52 @@
}
}
- # Do we have to debug socket transactions
- Debug <- getOption("debug.Socket")
- if (is.null(Debug) || Debug != TRUE) Debug <- FALSE else
- Debug <- TRUE
- if (Debug) cat(client, " > ", port, ": ", msg, "\n", sep = "")
+ "process" <- function () {
+ port <- tclGetValue_("::sockPort")
+ if (port == "") return(FALSE) # The server is closed
+ client <- tclGetValue_("::sockClient")
+ if (client == "") return(FALSE) # The socket client is unknown!
+ msg <- tclGetValue_("::sockMsg")
+ if (msg == "") return(FALSE) # No message!
- # Function to process the client request: SocketServerProc_<port>
+ # Make sure this message is not processed twice
+ .Tcl("set ::sockMsg {}")
+
+ # Do we have to debug socket transactions
+ Debug <- isTRUE(getOption("debug.Socket"))
+ if (Debug) cat(client, " > ", port, ": ", msg, "\n", sep = "")
+
+ # Function to process the client request: SocketServerProc_<port>
proc <- getTemp_(paste("SocketServerProc", port, sep = "_"),
mode = "function")
- if (is.null(proc)) return(FALSE) # The server should be closed
- # Call this function
- res <- proc(msg, client, port)
- # Return result to the client
- if (res != "") {
- if (Debug) cat(port, " > ", client, ": ", res, "\n", sep = "")
- chk <- try(tcl("puts", client, res), silent = TRUE)
- if (inherits(chk, "try-error")) {
- warning("Impossible to return results to a disconnected client.")
- return(FALSE)
+ if (is.null(proc) || !is.function(proc))
+ return(FALSE) # The server should be closed
+ # Call this function
+ res <- proc(msg, client, port)
+ # Return result to the client
+ if (res != "") {
+ if (Debug) cat(port, " > ", client, ": ", res, "\n", sep = "")
+ chk <- try(tcl("puts", client, res), silent = TRUE)
+ if (inherits(chk, "try-error")) {
+ warning("Impossible to return results to a disconnected client.")
+ return(FALSE)
+ }
}
+ return(TRUE) # The command is processed
}
- return(TRUE) # The command is processed
+ return(process) # Create the closure function for .Tcl.callback()
}
- # This is a copy of tclFun from tcltk2, to avoid a Depends: tcltk2
- "tclFun_" <- function (f, name = deparse(substitute(f)))
- {
- # Register a simple R function (no arguments) as a callback in Tcl,
- # and give it the same name)
- # Indeed, .Tcl.callback(f) in tcltk package does the job...
- # but it gives cryptic names like R_call 0x13c7168
- # Done in NAMESPACE
- #require(tcltk) || stop("Package 'tcltk' is needed!")
-
- # Check that 'f' is a function with no arguments (not supported)
- 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.args(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 (?!)
- }
- tclFun_(SocketServerProc)
+ assignTemp("SocketServerProc", SocketServerFun())
+ # Create a Tcl proc that calls this function back
+ res <- .Tcl.callback(getTemp("SocketServerProc"), TempEnv())
+ if (length(grep("R_call ", res) > 0)) {
+ # Create a proc with the same name in Tcl
+ .Tcl(paste("proc SocketServerProc {} {", res, "}", sep = ""))
+ } else stop("Cannot create the SciViews socket server callback function")
}
# Copy procfun into TempEnv as SocketServerProc_<port>
- assign(paste("SocketServerProc", port, sep ="_"), procfun,
- envir = TempEnv())
+ assign(paste("SocketServerProc", port, sep ="_"), procfun, envir = TempEnv())
# Create the Tcl function that retrieves data from the socket
# (command send by the client), call the processing R function
Modified: pkg/svSocket/R/stopSocketServer.R
===================================================================
--- pkg/svSocket/R/stopSocketServer.R 2010-09-06 16:31:06 UTC (rev 292)
+++ pkg/svSocket/R/stopSocketServer.R 2010-09-06 16:32:12 UTC (rev 293)
@@ -1,5 +1,4 @@
-"stopSocketServer" <-
-function (port = 8888)
+stopSocketServer <- function (port = 8888)
{
# Stop one or more running socket server(s)
if (port == "all") {
Modified: pkg/svSocket/R/svSocket-Internal.R
===================================================================
--- pkg/svSocket/R/svSocket-Internal.R 2010-09-06 16:31:06 UTC (rev 292)
+++ pkg/svSocket/R/svSocket-Internal.R 2010-09-06 16:32:12 UTC (rev 293)
@@ -1,19 +1,16 @@
-".onLoad" <-
-function (lib, pkg)
+.onLoad <- function (lib, pkg)
{
# Create our SciViews task callback manager
assignTemp(".svTaskCallbackManager", svTaskCallbackManager())
}
-".onUnload" <-
-function (libpath)
+.onUnload <- function (libpath)
{
removeTaskCallback("SV-taskCallbackManager")
rmTemp(".svTaskCallbackManager")
}
-".Last.lib" <-
-function (libpath)
+.Last.lib <- function (libpath)
{
# Make sure that all clients are disconnected
# and all servers are closed
Modified: pkg/svSocket/R/svTaskCallbackManager.R
===================================================================
--- pkg/svSocket/R/svTaskCallbackManager.R 2010-09-06 16:31:06 UTC (rev 292)
+++ pkg/svSocket/R/svTaskCallbackManager.R 2010-09-06 16:32:12 UTC (rev 293)
@@ -1,5 +1,5 @@
-svTaskCallbackManager <-
-function (handlers = list(), registered = FALSE, verbose = FALSE)
+svTaskCallbackManager <- function (handlers = list(), registered = FALSE,
+verbose = FALSE)
{
suspended <- FALSE
.verbose <- verbose
Modified: pkg/svSocket/TODO
===================================================================
--- pkg/svSocket/TODO 2010-09-06 16:31:06 UTC (rev 292)
+++ pkg/svSocket/TODO 2010-09-06 16:32:12 UTC (rev 293)
@@ -2,8 +2,6 @@
* Rework the mechanism to add history item to R from within Komodo
-* Eliminate the need to poll R regularly (for menu items activating/deactivating)
-
* svSocket-package.Rd man page
* Easy redefinition of options(width = ...) to adjust width of output to the
@@ -55,7 +53,7 @@
* Correct handling of the prompt when several lines of code are pasted at once!
-* Currently, code send through the socket server cannt be interrupted
+* Currently, code send through the socket server cannot be interrupted
* Implement a way to interrupt from the remote console + correct <<<esc>>>
Modified: pkg/svSocket/inst/CITATION
===================================================================
--- pkg/svSocket/inst/CITATION 2010-09-06 16:31:06 UTC (rev 292)
+++ pkg/svSocket/inst/CITATION 2010-09-06 16:32:12 UTC (rev 293)
@@ -3,7 +3,7 @@
citEntry(entry="Manual",
title = "SciViews-R: A GUI API for R",
author = "Philippe Grosjean",
- organization = "UMons",
+ organization = "UMONS",
address = "Mons, Belgium",
year = version$year,
url = "http://www.sciviews.org/SciViews-R",
@@ -11,7 +11,7 @@
textVersion =
paste("Grosjean, Ph. (", version$year, "). ",
"SciViews: A GUI API for R. ",
- "UMons, Mons, Belgium. ",
+ "UMONS, Mons, Belgium. ",
"URL http://www.sciviews.org/SciViews-R.",
sep="")
)
More information about the Sciviews-commits
mailing list