1# File src/library/tcltk/R/Tk.R 2# Part of the R package, https://www.R-project.org 3# 4# Copyright (C) 1995-2019 The R Core Team 5# 6# This program is free software; you can redistribute it and/or modify 7# it under the terms of the GNU General Public License as published by 8# the Free Software Foundation; either version 2 of the License, or 9# (at your option) any later version. 10# 11# This program is distributed in the hope that it will be useful, 12# but WITHOUT ANY WARRANTY; without even the implied warranty of 13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14# GNU General Public License for more details. 15# 16# A copy of the GNU General Public License is available at 17# https://www.R-project.org/Licenses/ 18 19### ------ Basics ------ 20 21 22.Tcl <- function(...) 23 structure(.External(.C_dotTcl, ...), class = "tclObj") 24.Tcl.objv <- function(objv) 25 structure(.External(.C_dotTclObjv, objv), class = "tclObj") 26 27.Tcl.callback <- function(...) 28 .External(.C_dotTclcallback, ...) 29 30.Tcl.args <- function(...) { 31 ## Eek! (See .Tcl.args.objv for explanation) 32 pframe <- parent.frame(3) 33 ## Convert argument tags to option names (i.e. stick "-" in front) 34 name2opt <- function(x) if ( x != "") paste0("-", x) else "" 35 36 isCallback <- function(x) 37 is.function(x) || is.call(x) || is.expression(x) 38 39 makeAtomicCallback <- function(x, e) { 40 if (is.name(x)) 41 x <- eval(x, e) 42 if (is.call(x)){ 43 if(identical(x[[1L]], as.name("break"))) 44 return("break") 45 if(identical(x[[1L]], as.name("function"))) 46 x <- eval(x, e) 47 } 48 .Tcl.callback(x, e) 49 } 50 51 makeCallback <- function(x, e) { 52 if (is.expression(x)) 53 paste(lapply(x, makeAtomicCallback, e), collapse = ";") 54 else 55 makeAtomicCallback(x, e) 56 } 57 58 ## Convert arguments. Callbacks and windows require special treatment 59 ## everything else is converted to strings 60 val2string <- function(x) { 61 if (is.null(x)) return("") 62 if (is.tkwin(x)){ current.win <<- x ; return (.Tk.ID(x)) } 63 if (inherits(x,"tclVar")) return(names(unclass(x)$env)) 64 if (isCallback(x)){ 65 # Jump through some hoops to protect from GC... 66 ref <- local({value <- x; envir <- pframe; environment()}) 67 callback <- makeCallback(get("value", envir = ref), 68 get("envir", envir = ref)) 69 callback <- paste("{", callback, "}") 70 assign(callback, ref, envir = current.win$env) 71 return(callback) 72 } 73 ## quoting/escaping hell (much less, since using fixed=TRUE): 74 x <- gsub("\\", "\\\\", as.character(x), fixed=TRUE) 75 x <- gsub("\"", "\\\"", x, fixed=TRUE) 76 x <- gsub("[", "\\[", x, fixed=TRUE) 77 x <- gsub("$", "\\$", x, fixed=TRUE) 78 paste0("\"", x, "\"", collapse = " ") 79 } 80 81 val <- list(...) 82 nm <- names(val) 83 84 if (!length(val)) return("") 85 nm <- if (is.null(nm)) rep("", length(val)) else sapply(nm, name2opt) 86 87 ## This is a bit dodgy: we need to ensure that callbacks don't get 88 ## garbage collected, so we try registering them with the relevant 89 ## window, which is assumed to be the last preceding window 90 ## argument during val2string processing if one occurs, or the 91 ## "win" variable of the caller (tkwidget calls) or as a last 92 ## resort .TkRoot. What a mess! 93 94 current.win <- 95 if (exists("win", envir = parent.frame())) 96 get("win", envir = parent.frame()) 97 else .TkRoot 98 99 val <- sapply(val, val2string) 100 paste(as.vector(rbind(nm, val)), collapse = " ") 101} 102 103.Tcl.args.objv <- function(...) { 104 105 ## Eek! This is broken by design... 106 ## The issue is that if a callback is given in the form of an expression, 107 ## then we need to ensure that it is evaluated in the proper environment 108 ## The typical case is that tkbind() calls tcl() calls .Tcl.args.objv() 109 ## so we grab 3 levels back. This will break direct calls to tcl(), though. 110 111 pframe <- parent.frame(3) 112 113 isCallback <- function(x) 114 is.function(x) || is.call(x) || is.expression(x) 115 116 makeAtomicCallback <- function(x, e) { 117 if (is.name(x)) 118 x <- eval(x, e) 119 if (is.call(x)){ 120 if(identical(x[[1L]], as.name("break"))) 121 return("break") 122 if(identical(x[[1L]], as.name("function"))) 123 x <- eval(x, e) 124 } 125 .Tcl.callback(x, e) 126 } 127 128 makeCallback <- function(x, e) { 129 if (is.expression(x)) 130 paste(lapply(x, makeAtomicCallback, e), collapse = ";") 131 else 132 makeAtomicCallback(x, e) 133 } 134 135 ## Convert arguments. Callbacks and windows require special treatment 136 ## everything else is converted to strings 137 val2obj <- function(x) { 138 if (is.null(x)) return(NULL) 139 if (is.tkwin(x)){current.win <<- x ; return(as.tclObj(.Tk.ID(x)))} 140 if (inherits(x,"tclVar")) return(as.tclObj(names(unclass(x)$env))) 141 if (isCallback(x)){ 142 # Jump through some hoops to protect from GC... 143 ref <- local({value <- x; envir <- pframe; environment()}) 144 callback <- makeCallback(get("value", envir = ref), 145 get("envir", envir = ref)) 146 assign(callback, ref, envir = current.win$env) 147 return(as.tclObj(callback, drop = TRUE)) 148 } 149 as.tclObj(x, drop = TRUE) 150 } 151 152 val <- list(...) 153 154 ## This is a bit dodgy: we need to ensure that callbacks don't get 155 ## garbage collected, so we try registering them with the relevant 156 ## window, which is assumed to be the last preceding window 157 ## argument during val2string processing if one occurs, 158 ## or as a last resort .TkRoot. What a mess! 159 160 current.win <- .TkRoot 161 162 lapply(val, val2obj) 163} 164 165 166.Tk.ID <- function(win) win$ID 167 168.Tk.newwin <- function(ID) { 169 win <- list(ID = ID, env = new.env(parent = emptyenv())) 170 win$env$num.subwin <- 0 171 class(win) <- "tkwin" 172 win 173} 174 175.Tk.subwin <- function(parent) { 176 ID <- paste(parent$ID, parent$env$num.subwin <- parent$env$num.subwin + 1, 177 sep = ".") 178 win <- .Tk.newwin(ID) 179 assign(ID, win, envir = parent$env) 180 assign("parent", parent, envir = win$env) 181 win 182} 183 184tkdestroy <- function(win) { 185 tcl("destroy", win) 186 ID <- .Tk.ID(win) 187 env <- get("parent", envir = win$env)$env 188 if (exists(ID, envir = env, inherits = FALSE)) 189 rm(list = ID, envir = env) 190} 191 192is.tkwin <- function(x) inherits(x, "tkwin") 193 194tclVar <- function(init = "") { 195 n <- .TkRoot$env$TclVarCount <- .TkRoot$env$TclVarCount + 1L 196 name <- paste0("::RTcl", n) 197 l <- list(env = new.env()) 198 assign(name, NULL, envir = l$env) 199 reg.finalizer(l$env, function(env) tcl("unset", names(env))) 200 class(l) <- "tclVar" 201 tclvalue(l) <- init 202 l 203} 204 205tclObj <- function(x) UseMethod("tclObj") 206"tclObj<-" <- function(x, value) UseMethod("tclObj<-") 207 208tclObj.tclVar <- function(x){ 209 z <- .External(.C_RTcl_ObjFromVar, names(x$env)) 210 class(z) <- "tclObj" 211 z 212} 213 214"tclObj<-.tclVar" <- function(x, value){ 215 value <- as.tclObj(value) 216 .External(.C_RTcl_AssignObjToVar, names(x$env), value) 217 x 218} 219 220tclvalue <- function(x) UseMethod("tclvalue") 221"tclvalue<-" <- function(x, value) UseMethod("tclvalue<-") 222 223tclvalue.tclVar <- function(x) tclvalue(tclObj(x)) 224tclvalue.tclObj <- function(x) .External(.C_RTcl_StringFromObj, x) 225print.tclObj <- function(x,...) { 226 z <- tclvalue(x) 227 if (length(z)) cat("<Tcl>", z, "\n") 228 invisible(x) 229} 230 231"tclvalue<-.tclVar" <- function(x, value) { 232 name <- names(unclass(x)$env) 233 tcl("set", name, value) 234 x 235} 236 237tclvalue.default <- function(x) tclvalue(tcl("set", as.character(x))) 238 239"tclvalue<-.default" <- function(x, value) { 240 name <- as.character(x) 241 tcl("set", name, value) 242 x 243} 244 245as.character.tclVar <- function(x, ...) names(unclass(x)$env) 246 247as.character.tclObj <- function(x, ...) 248 .External(.C_RTcl_ObjAsCharVector, x) 249as.double.tclObj <- function(x, ...) 250 .External(.C_RTcl_ObjAsDoubleVector, x) 251as.integer.tclObj <- function(x, ...) 252 .External(.C_RTcl_ObjAsIntVector, x) 253as.logical.tclObj <- function(x, ...) 254 as.logical(.External(.C_RTcl_ObjAsIntVector, x)) 255as.raw.tclObj <- function(x, ...) 256 .External(.C_RTcl_ObjAsRawVector, x) 257 258is.tclObj <- function(x) inherits(x, "tclObj") 259 260as.tclObj <- function(x, drop = FALSE) { 261 if (is.tclObj(x)) return(x) 262 z <- switch(storage.mode(x), 263 character = .External(.C_RTcl_ObjFromCharVector, x, drop), 264 double = .External(.C_RTcl_ObjFromDoubleVector, x,drop), 265 integer = .External(.C_RTcl_ObjFromIntVector, x, drop), 266 logical = .External(.C_RTcl_ObjFromIntVector, as.integer(x), drop), 267 raw = .External(.C_RTcl_ObjFromRawVector, x), 268 stop(gettextf("cannot handle object of mode '%s'", 269 storage.mode(x)), domain = NA) 270 ) 271 class(z) <- "tclObj" 272 z 273} 274# Actually makes .default and .tclVar methods equivalent, the latter 275# just saves a level of function dispatching 276 277tclServiceMode <- function(on = NULL) 278 .External(.C_RTcl_ServiceMode, as.logical(on)) 279 280#---- 281 282.TkRoot <- .Tk.newwin("") 283tclvar <- structure(list(), class = "tclvar") 284.TkRoot$env$TclVarCount <- 0 285 286 287# ------ Widgets ------ 288 289tkwidget <- function (parent, type, ...) # generic 290{ 291 win <- .Tk.subwin(parent) 292 # older version had .Tk.ID(win) here, but this makes for easier 293 # current.win handling 294 tcl(type, win, ...) 295 win 296} 297 298tkbutton <- function(parent, ...) tkwidget(parent, "button", ...) 299tkcanvas <- function(parent, ...) tkwidget(parent, "canvas", ...) 300tkcheckbutton <- function(parent, ...) tkwidget(parent, "checkbutton", ...) 301tkentry <- function(parent, ...) tkwidget(parent, "entry", ...) 302tkframe <- function(parent, ...) tkwidget(parent, "frame", ...) 303tklabel <- function(parent, ...) tkwidget(parent, "label", ...) 304tklistbox <- function(parent, ...) tkwidget(parent, "listbox", ...) 305tkmenu <- function(parent, ...) tkwidget(parent, "menu", ...) 306tkmenubutton <- function(parent, ...) tkwidget(parent, "menubutton", ...) 307tkmessage <- function(parent, ...) tkwidget(parent, "message", ...) 308tkradiobutton <- function(parent, ...) tkwidget(parent, "radiobutton", ...) 309tkscale <- function(parent, ...) tkwidget(parent, "scale", ...) 310tkscrollbar <- function(parent, ...) tkwidget(parent, "scrollbar", ...) 311tktext <- function(parent, ...) tkwidget(parent, "text", ...) 312 313ttkbutton <- function(parent, ...) tkwidget(parent, "ttk::button", ...) 314ttkcheckbutton <- function(parent, ...) tkwidget(parent, "ttk::checkbutton", ...) 315ttkcombobox <- function(parent, ...) tkwidget(parent, "ttk::combobox", ...) 316ttkentry <- function(parent, ...) tkwidget(parent, "ttk::entry", ...) 317ttkframe <- function(parent, ...) tkwidget(parent, "ttk::frame", ...) 318ttklabel <- function(parent, ...) tkwidget(parent, "ttk::label", ...) 319ttklabelframe <- function(parent, ...) tkwidget(parent, "ttk::labelframe", ...) 320ttkmenubutton <- function(parent, ...) tkwidget(parent, "ttk::menubutton", ...) 321ttknotebook <- function(parent, ...) tkwidget(parent, "ttk::notebook", ...) 322ttkpanedwindow <- function(parent, ...) tkwidget(parent, "ttk::panedwindow", ...) 323ttkprogressbar <- function(parent, ...) tkwidget(parent, "ttk::progressbar", ...) 324ttkradiobutton <- function(parent, ...) tkwidget(parent, "ttk::radiobutton", ...) 325ttkscale <- function(parent, ...) tkwidget(parent, "ttk::scale", ...) 326ttkscrollbar <- function(parent, ...) tkwidget(parent, "ttk::scrollbar", ...) 327ttkseparator <- function(parent, ...) tkwidget(parent, "ttk::separator", ...) 328ttksizegrip <- function(parent, ...) tkwidget(parent, "ttk::sizegrip", ...) 329ttkspinbox <- function(parent, ...) tkwidget(parent, "ttk::spinbox", ...) 330ttktreeview <- function(parent, ...) tkwidget(parent, "ttk::treeview", ...) 331 332 333tktoplevel <- function(parent = .TkRoot,...) { 334 w <- tkwidget(parent,"toplevel",...) 335 ID <- .Tk.ID(w) 336 tkbind(w, "<Destroy>", 337 function() { 338 if (exists(ID, envir = parent$env, inherits = FALSE)) 339 rm(list = ID, envir = parent$env) 340 tkbind(w, "<Destroy>","") 341 }) 342 utils::process.events() 343 w 344} 345### ------ Window & Geometry managers, widget commands &c ------ 346 347tcl <- function(...) .Tcl.objv(.Tcl.args.objv(...)) 348 349tktitle <- function(x) tcl("wm", "title", x) 350 351"tktitle<-" <- function(x, value) { 352 tcl("wm", "title", x, value) 353 x 354} 355 356tkbell <- function(...) tcl("bell", ...) 357tkbind <- function(...) tcl("bind", ...) 358tkbindtags <- function(...) tcl("bindtags", ...) 359tkfocus <- function(...) tcl("focus", ...) 360tklower <- function(...) tcl("lower", ...) 361tkraise <- function(...) tcl("raise", ...) 362 363 364tkclipboard.append <- function(...) tcl("clipboard", "append", ...) 365tkclipboard.clear <- function(...) tcl("clipboard", "clear", ...) 366 367 368tkevent.add <- function(...) tcl("event", "add", ...) 369tkevent.delete <- function(...) tcl("event", "delete", ...) 370tkevent.generate <- function(...) tcl("event", "generate", ...) 371tkevent.info <- function(...) tcl("event", "info", ...) 372 373 374tkfont.actual <- function(...) tcl("font", "actual", ...) 375tkfont.configure <- function(...) tcl("font", "configure", ...) 376tkfont.create <- function(...) tcl("font", "create", ...) 377tkfont.delete <- function(...) tcl("font", "delete", ...) 378tkfont.families <- function(...) tcl("font", "families", ...) 379tkfont.measure <- function(...) tcl("font", "measure", ...) 380tkfont.metrics <- function(...) tcl("font", "metrics", ...) 381tkfont.names <- function(...) tcl("font", "names", ...) 382 383tkgrab <- function(...) tcl("grab", ...) 384tkgrab.current <- function(...) tcl("grab", "current", ...) 385tkgrab.release <- function(...) tcl("grab", "release", ...) 386tkgrab.set <- function(...) tcl("grab", "set", ...) 387tkgrab.status <- function(...) tcl("grab", "status", ...) 388 389tkimage.create <- function(...) tcl("image", "create", ...) 390tkimage.delete <- function(...) tcl("image", "delete", ...) 391tkimage.height <- function(...) tcl("image", "height", ...) 392tkimage.inuse <- function(...) tcl("image", "inuse", ...) 393tkimage.names <- function(...) tcl("image", "names", ...) 394tkimage.type <- function(...) tcl("image", "type", ...) 395tkimage.types <- function(...) tcl("image", "types", ...) 396tkimage.width <- function(...) tcl("image", "width", ...) 397 398 399## NB: some widgets also have a selection.clear command, hence the "X". 400## tkselection.clear might be made a generic function instead. 401tkXselection.clear <- function(...) tcl("selection", "clear", ...) 402tkXselection.get <- function(...) tcl("selection", "get", ...) 403tkXselection.handle <- function(...) tcl("selection", "handle", ...) 404tkXselection.own <- function(...) tcl("selection", "own", ...) 405 406tkwait.variable <- function(...) tcl("tkwait", "variable", ...) 407tkwait.visibility <- function(...) tcl("tkwait", "visibility", ...) 408tkwait.window <- function(...) tcl("tkwait", "window", ...) 409 410## Standard dialogs 411tkgetOpenFile <- function(...) tcl("tk_getOpenFile", ...) 412tkgetSaveFile <- function(...) tcl("tk_getSaveFile", ...) 413tkchooseDirectory <- function(...) tcl("tk_chooseDirectory", ...) 414tkmessageBox <- function(...) tcl("tk_messageBox", ...) 415tkdialog <- function(...) tcl("tk_dialog", ...) 416tkpopup <- function(...) tcl("tk_popup", ...) 417 418 419## File handling functions 420 421tclfile.tail <- function(...) tcl("file", "tail", ...) 422tclfile.dir <- function(...) tcl("file", "dir", ...) 423tclopen <- function(...) tcl("open", ...) 424tclclose <- function(...) tcl("close", ...) 425tclputs <- function(...) tcl("puts", ...) 426tclread <- function(...) tcl("read", ...) 427 428## Tkwinfo actually has a bazillion subcommands, but it's rarely 429## used, so let's be lazy 430 431tkwinfo <- function(...) tcl("winfo", ...) 432 433## Not so with tkwm. 434 435tkwm.aspect <- function(...) tcl("wm", "aspect", ...) 436tkwm.client <- function(...) tcl("wm", "client", ...) 437tkwm.colormapwindows <- function(...) tcl("wm", "colormapwindows", ...) 438tkwm.command <- function(...) tcl("wm", "command", ...) 439tkwm.deiconify <- function(...) tcl("wm", "deiconify", ...) 440tkwm.focusmodel <- function(...) tcl("wm", "focusmodel", ...) 441tkwm.frame <- function(...) tcl("wm", "frame", ...) 442tkwm.geometry <- function(...) tcl("wm", "geometry", ...) 443tkwm.grid <- function(...) tcl("wm", "grid", ...) 444tkwm.group <- function(...) tcl("wm", "group", ...) 445tkwm.iconbitmap <- function(...) tcl("wm", "iconbitmap", ...) 446tkwm.iconify <- function(...) tcl("wm", "iconify", ...) 447tkwm.iconmask <- function(...) tcl("wm", "iconmask", ...) 448tkwm.iconname <- function(...) tcl("wm", "iconname ", ...) 449tkwm.iconposition <- function(...) tcl("wm", "iconposition", ...) 450tkwm.iconwindow <- function(...) tcl("wm", "iconwindow ", ...) 451tkwm.maxsize <- function(...) tcl("wm", "maxsize", ...) 452tkwm.minsize <- function(...) tcl("wm", "minsize", ...) 453tkwm.overrideredirect <- function(...) tcl("wm", "overrideredirect", ...) 454tkwm.positionfrom <- function(...) tcl("wm", "positionfrom", ...) 455tkwm.protocol <- function(...) tcl("wm", "protocol", ...) 456tkwm.resizable <- function(...) tcl("wm", "resizable", ...) 457tkwm.sizefrom <- function(...) tcl("wm", "sizefrom", ...) 458tkwm.state <- function(...) tcl("wm", "state", ...) 459tkwm.title <- function(...) tcl("wm", "title", ...) 460tkwm.transient <- function(...) tcl("wm", "transient", ...) 461tkwm.withdraw <- function(...) tcl("wm", "withdraw", ...) 462 463 464### Geometry managers 465 466tkgrid <- function(...) tcl("grid", ...) 467tkgrid.bbox <- function(...) tcl("grid", "bbox", ...) 468tkgrid.columnconfigure <- function(...) tcl("grid", "columnconfigure", ...) 469tkgrid.configure <- function(...) tcl("grid", "configure", ...) 470tkgrid.forget <- function(...) tcl("grid", "forget", ...) 471tkgrid.info <- function(...) tcl("grid", "info", ...) 472tkgrid.location <- function(...) tcl("grid", "location", ...) 473tkgrid.propagate <- function(...) tcl("grid", "propagate", ...) 474tkgrid.rowconfigure <- function(...) tcl("grid", "rowconfigure", ...) 475tkgrid.remove <- function(...) tcl("grid", "remove", ...) 476tkgrid.size <- function(...) tcl("grid", "size", ...) 477tkgrid.slaves <- function(...) tcl("grid", "slaves", ...) 478 479tkpack <- function(...) tcl("pack", ...) 480tkpack.configure <- function(...) tcl("pack", "configure", ...) 481tkpack.forget <- function(...) tcl("pack", "forget", ...) 482tkpack.info <- function(...) tcl("pack", "info", ...) 483tkpack.propagate <- function(...) tcl("pack", "propagate", ...) 484tkpack.slaves <- function(...) tcl("pack", "slaves", ...) 485 486tkplace <- function(...) tcl("place", ...) 487tkplace.configure <- function(...) tcl("place", "configure", ...) 488tkplace.forget <- function(...) tcl("place", "forget", ...) 489tkplace.info <- function(...) tcl("place", "info", ...) 490tkplace.slaves <- function(...) tcl("place", "slaves", ...) 491 492 493 494### Widgets commands 495 496tkactivate <- function(widget, ...) tcl(widget, "activate", ...) 497tkadd <- function(widget, ...) tcl(widget, "add", ...) 498tkaddtag <- function(widget, ...) tcl(widget, "addtag", ...) 499tkbbox <- function(widget, ...) tcl(widget, "bbox", ...) 500tkcanvasx <- function(widget, ...) tcl(widget, "canvasx", ...) 501tkcanvasy <- function(widget, ...) tcl(widget, "canvasy", ...) 502tkcget <- function(widget, ...) tcl(widget, "cget", ...) 503tkcompare <- function(widget, ...) tcl(widget, "compare", ...) 504tkconfigure <- function(widget, ...) tcl(widget, "configure", ...) 505tkcoords <- function(widget, ...) tcl(widget, "coords", ...) 506tkcreate <- function(widget, ...) tcl(widget, "create", ...) 507tkcurselection <- function(widget, ...) tcl(widget, "curselection", ...) 508tkdchars <- function(widget, ...) tcl(widget, "dchars", ...) 509tkdebug <- function(widget, ...) tcl(widget, "debug", ...) 510tkdelete <- function(widget, ...) tcl(widget, "delete", ...) 511tkdelta <- function(widget, ...) tcl(widget, "delta", ...) 512tkdeselect <- function(widget, ...) tcl(widget, "deselect", ...) 513tkdlineinfo <- function(widget, ...) tcl(widget, "dlineinfo", ...) 514tkdtag <- function(widget, ...) tcl(widget, "dtag", ...) 515tkdump <- function(widget, ...) tcl(widget, "dump", ...) 516tkentrycget <- function(widget, ...) tcl(widget, "entrycget", ...) 517tkentryconfigure <- function(widget, ...) tcl(widget, "entryconfigure", ...) 518tkfind <- function(widget, ...) tcl(widget, "find", ...) 519tkflash <- function(widget, ...) tcl(widget, "flash", ...) 520tkfraction <- function(widget, ...) tcl(widget, "fraction", ...) 521tkget <- function(widget, ...) tcl(widget, "get", ...) 522tkgettags <- function(widget, ...) tcl(widget, "gettags", ...) 523tkicursor <- function(widget, ...) tcl(widget, "icursor", ...) 524tkidentify <- function(widget, ...) tcl(widget, "identify", ...) 525tkindex <- function(widget, ...) tcl(widget, "index", ...) 526tkinsert <- function(widget, ...) tcl(widget, "insert", ...) 527tkinvoke <- function(widget, ...) tcl(widget, "invoke", ...) 528tkitembind <- function(widget, ...) tcl(widget, "bind", ...) 529tkitemcget <- function(widget, ...) tcl(widget, "itemcget", ...) 530tkitemconfigure <- function(widget, ...) tcl(widget, "itemconfigure", ...) 531tkitemfocus <- function(widget, ...) tcl(widget, "focus", ...) 532tkitemlower <- function(widget, ...) tcl(widget, "lower", ...) 533tkitemraise <- function(widget, ...) tcl(widget, "raise", ...) 534tkitemscale <- function(widget, ...) tcl(widget, "scale", ...) 535tkmark.gravity <- function(widget, ...) tcl(widget, "mark", "gravity", ...) 536tkmark.names <- function(widget, ...) tcl(widget, "mark", "names", ...) 537tkmark.next <- function(widget, ...) tcl(widget, "mark", "next", ...) 538tkmark.previous <- function(widget, ...) tcl(widget, "mark", "previous", ...) 539tkmark.set <- function(widget, ...) tcl(widget, "mark", "set", ...) 540tkmark.unset <- function(widget, ...) tcl(widget, "mark", "unset", ...) 541tkmove <- function(widget, ...) tcl(widget, "move", ...) 542tknearest <- function(widget, ...) tcl(widget, "nearest", ...) 543tkpost <- function(widget, ...) tcl(widget, "post", ...) 544tkpostcascade <- function(widget, ...) tcl(widget, "postcascade", ...) 545tkpostscript <- function(widget, ...) tcl(widget, "postscript", ...) 546tkscan.dragto <- function(widget, ...) tcl(widget, "scan", "dragto", ...) 547tkscan.mark <- function(widget, ...) tcl(widget, "scan", "mark", ...) 548tksearch <- function(widget, ...) tcl(widget, "search", ...) 549tksee <- function(widget, ...) tcl(widget, "see", ...) 550tkselect <- function(widget, ...) tcl(widget, "select", ...) 551tkselection.adjust <- function(widget, ...) 552 tcl(widget, "selection", "adjust", ...) 553tkselection.anchor <- function(widget, ...) 554 tcl(widget, "selection", "anchor", ...) 555tkselection.clear <- function(widget, ...) 556 tcl(widget, "selection", "clear", ...) 557tkselection.from <- function(widget, ...) 558 tcl(widget, "selection", "from", ...) 559tkselection.includes <- function(widget, ...) 560 tcl(widget, "selection", "includes", ...) 561tkselection.present <- function(widget, ...) 562 tcl(widget, "selection", "present", ...) 563tkselection.range <- function(widget, ...) 564 tcl(widget, "selection", "range", ...) 565tkselection.set <- function(widget, ...) 566 tcl(widget, "selection", "set", ...) 567tkselection.to <- function(widget,...) 568 tcl(widget, "selection", "to", ...) 569tkset <- function(widget, ...) tcl(widget, "set", ...) 570tksize <- function(widget, ...) tcl(widget, "size", ...) 571tktoggle <- function(widget, ...) tcl(widget, "toggle", ...) 572tktag.add <- function(widget, ...) tcl(widget, "tag", "add", ...) 573tktag.bind <- function(widget, ...) tcl(widget, "tag", "bind", ...) 574tktag.cget <- function(widget, ...) tcl(widget, "tag", "cget", ...) 575tktag.configure <- function(widget, ...) tcl(widget, "tag", "configure", ...) 576tktag.delete <- function(widget, ...) tcl(widget, "tag", "delete", ...) 577tktag.lower <- function(widget, ...) tcl(widget, "tag", "lower", ...) 578tktag.names <- function(widget, ...) tcl(widget, "tag", "names", ...) 579tktag.nextrange <- function(widget, ...) tcl(widget, "tag", "nextrange", ...) 580tktag.prevrange <- function(widget, ...) tcl(widget, "tag", "prevrange", ...) 581tktag.raise <- function(widget, ...) tcl(widget, "tag", "raise", ...) 582tktag.ranges <- function(widget, ...) tcl(widget, "tag", "ranges", ...) 583tktag.remove <- function(widget, ...) tcl(widget, "tag", "remove", ...) 584tktype <- function(widget, ...) tcl(widget, "type", ...) 585tkunpost <- function(widget, ...) tcl(widget, "unpost", ...) 586tkwindow.cget <- function(widget, ...) tcl(widget, "window", "cget", ...) 587tkwindow.configure <- function(widget, ...) tcl(widget,"window","configure",...) 588tkwindow.create <- function(widget, ...) tcl(widget, "window", "create", ...) 589tkwindow.names <- function(widget, ...) tcl(widget, "window", "names", ...) 590tkxview <- function(widget, ...) tcl(widget, "xview", ...) 591tkxview.moveto <- function(widget, ...) tcl(widget, "xview", "moveto", ...) 592tkxview.scroll <- function(widget, ...) tcl(widget, "xview", "scroll", ...) 593tkyposition <- function(widget, ...) tcl(widget, "ypositions", ...) 594tkyview <- function(widget, ...) tcl(widget, "yview", ...) 595tkyview.moveto <- function(widget, ...) tcl(widget, "yview", "moveto", ...) 596tkyview.scroll <- function(widget, ...) tcl(widget, "yview", "scroll", ...) 597 598 599 600 601tkpager <- function(file, header, title, delete.file) 602{ 603 title <- paste(title, header) 604 for ( i in seq_along(file) ) { 605 zfile <- file[[i]] 606 tt <- tktoplevel() 607 tkwm.title(tt, 608 if (length(title)) title[(i-1L) %% length(title)+1L] else "") 609### courier font comes out awfully small on some systems 610### txt <- tktext(tt, bg = "grey90", font = "courier") 611 txt <- tktext(tt, bg = "grey90") 612 scr <- tkscrollbar(tt, repeatinterval = 5, 613 command = function(...) tkyview(txt,...)) 614 tkconfigure(txt, yscrollcommand = function(...) tkset(scr,...)) 615 tkpack(txt, side = "left", fill = "both", expand = TRUE) 616 tkpack(scr, side = "right", fill = "y") 617 618 chn <- tcl("open", zfile) 619 tkinsert(txt, "end", gsub("_\b","",tclvalue(tcl("read", chn)))) 620 tcl("close", chn) 621 622 tkconfigure(txt, state = "disabled") 623 tkmark.set(txt, "insert", "0.0") 624 tkfocus(txt) 625 626 if (delete.file) tcl("file", "delete", zfile) 627 } 628} 629 630 631 632