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