R/gobject.R

Defines functions toRGClosure as.GClosure .getAutoElementByName .comparePointers .getAutoMethodByName .getAutoMemberByName parentHandler gObjectGetData gObjectSetData as.GParamSpec gParamSpec gObjectNew gObjectSet gObjectGet gTypeGetPropInfo gObjectGetPropInfo gSignalEmit gSignalGetInfo gTypeGetSignals gObjectGetSignals gSignalStopEmission gSignalHandlerUnblock gSignalHandlerBlock gSignalHandlerDisconnect print.CallbackID gSignalConnect print.GType gTypeFromName gTypeGetClass gTypeGetInterfaces gTypeGetAncestors interface as.GType

Documented in as.GClosure as.GParamSpec as.GType gObjectGet gObjectGetData gObjectGetPropInfo gObjectGetSignals gObjectNew gObjectSet gObjectSetData gParamSpec gSignalConnect gSignalEmit gSignalGetInfo gSignalHandlerBlock gSignalHandlerDisconnect gSignalHandlerUnblock gSignalStopEmission gTypeFromName gTypeGetAncestors gTypeGetClass gTypeGetInterfaces gTypeGetPropInfo gTypeGetSignals interface parentHandler print.CallbackID print.GType toRGClosure

##### GObject wrapping #####

# GType support

# currently just converts type name to GType object, if x isn't one already
as.GType <- function(x)
{
  mapping <- c("integer" = "gint", "character" = "gchararray", "logical" = "gboolean",
    "numeric" = "gdouble", "raw" = "guchar", "externalptr" = "gpointer") 
  type <- x
  if (is.character(type)) {
    if (type %in% names(mapping))
      type <- mapping[[type]]
    type <- try(gTypeFromName(type), TRUE)
    if (inherits(type, "try-error")) {
      func <- paste(tolower(substring(x, 1, 1)), substring(x, 2), "GetType", sep="")
      if (exists(func))
        type <- do.call(func, list())
      }
  }
  if (!inherits(type, "GType"))
    stop("Cannot convert ", x, " to GType")
  type
}

interface <-
function(obj)
{
 attr(obj, "interfaces")
}

gTypeGetAncestors <-
function(type)
{
  type <- as.GType(type)
  .Call("R_getGTypeAncestors", type, PACKAGE = "RGtk2")
}

gTypeGetInterfaces <-
function(type)
{
  type <- as.GType(type)
  .Call("R_getInterfaces", type, PACKAGE = "RGtk2")
}

gTypeGetClass <-
function(type)
{
  type <- as.GType(type)
  ancestors <- gTypeGetAncestors(type)
  class_ptr <- .Call("R_getGTypeClass", type, PACKAGE = "RGtk2")
  class(class_ptr) <- c(paste(ancestors, "Class", sep=""), class(class_ptr))
  class_ptr
}

gTypeFromName <-
function(name)
{
 .Call("R_gTypeFromName", as.character(name), PACKAGE = "RGtk2")
}

print.GType <- function(x, ...) {
  cat("GType identifier for '", attr(x, "name"), "'\n", sep = "")
}

# GSignal support

GSignalFlags <- c(
  "run-first"  = 1,
  "run-last"  = 2,
  "run-cleanup"  = 4,
  "no-recurse"  = 8,
  "detailed"  = 16,
  "action"  = 32,
  "no-hooks"  = 64
)

GConnectFlags <- c(
  "after" = 1,
  "swapped" = 2
)

connectSignal <- gSignalConnect <-
function(obj, signal, f, data = NULL, after = FALSE, user.data.first = FALSE)
{
  useData <- missing(data) == FALSE
  checkPtrType(obj, "GObject")

  if(is.null(f))
    stop("You've specified NULL as the action in setting a callback. Did you mean to use quote()")

  if(is.expression(f)) {
    f <- f[[1]]
  }

  if(!( is.expression(f) || is.function(f) || is.call(f))) {
    stop(paste("Callback action must be an expression, a call or a function, but instead is of type", typeof(f), ". Did you forget to use quote()"))
  }

  invisible(.Call("R_connectGSignalHandler", obj, f, as.character(signal), data,
                  useData, as.logical(after), as.logical(user.data.first),
                  PACKAGE = "RGtk2"))
}

print.CallbackID <- function(x, ...)
  cat("Connection to '", names(x), "': ", x, "\n", sep = "")

gSignalHandlerDisconnect <-
function(obj, id)
{
 checkPtrType(obj, "GObject")
 .Call("R_disconnectGSignalHandler", obj, as.integer(id), PACKAGE = "RGtk2")
}

gSignalHandlerBlock <-
function(obj, id)
{
  checkPtrType(obj, "GObject")
 .Call("R_blockGSignalHandler", obj, as.integer(id), TRUE, PACKAGE = "RGtk2")
}

gSignalHandlerUnblock <-
function(obj, id)
{
  checkPtrType(obj, "GObject")
 .Call("R_blockGSignalHandler", obj, as.integer(id), FALSE, PACKAGE = "RGtk2")
}

gSignalStopEmission <-
function(obj, signal, detail = NULL)
{
  if (!is.null(detail))
    signal <- paste(signal, detail, sep="::")
  .Call("R_gSignalStopEmission", obj, signal, PACKAGE = "RGtk2")
}

gObjectGetSignals <-
function(obj)
{
  checkPtrType(obj, "GObject")
  type <- class(obj)[1]
  els <- gTypeGetSignals(type)
  els
}

gTypeGetSignals <-
function(type)
{
  if(is.character(type))
    type <- as.GType(type)

  checkPtrType(type, "GType")
  els <- .Call("R_getGSignalIdsByType", type, PACKAGE = "RGtk2")

  names(els) <- sapply(els, function(x) names(x))

  els
}


gSignalGetInfo <-
function(sig)
{
 checkPtrType(sig, "GSignalId")
 .Call("R_getGSignalInfo", sig, PACKAGE = "RGtk2")
}

gSignalEmit <-
function(obj, signal, ..., detail = NULL)
{
  checkPtrType(obj, "GObject")
  args <- list(...)
  signal <- as.character(signal)
  if (!is.null(detail))
    signal <- paste(signal, detail, sep="::")
  .RGtkCall("R_gSignalEmit", obj, signal, args, PACKAGE = "RGtk2")
}

# GObject properties

names.GObject <-
  #
  # return a vector of the names of the properties
  # available for the given GObject, collapsing over
  # all the inherited classes and removing the class::
  # prefix.
  #
function(x)
{
  names(gObjectGetPropInfo(x, parents = TRUE, collapse = TRUE))
}

gObjectGetPropInfo <-
function(obj, parents = TRUE, collapse = TRUE)
{
  checkPtrType(obj, "GObject")
  real_classes <- class(obj)[-length(class(obj))]
  props <- lapply(real_classes, gTypeGetPropInfo)
  if (parents && collapse)
    return(props[[1]])
  # props is a list containing the properties for each class in the hierarchy
  # as well as the parents of that class. We must remove the duplicates.
  n_dups <- c(sapply(props, length), 0)
  stripped <- lapply(1:length(props), function(ind) 
    if (n_dups[ind+1] > 0)
      props[[ind]][-(1:n_dups[ind+1])]
    else props[[ind]])
  names(stripped) <- real_classes
  result <- stripped
  if (!parents)
    result <- stripped[[1]]
  result
}

gTypeGetPropInfo <-
function(type)
{
  type <- as.GType(type)
  if (!("GObject" %in% gTypeGetAncestors(type)))
    stop("Cannot retrieve properties, because type is not a GObject type")
  
  .RGtkCall("R_getGTypeParamSpecs", type)
}

gObjectGet <-
function(obj, ..., drop = T)
{
   checkPtrType(obj, "GObject")
   props <- .Call("R_getGObjectProps", obj, as.character(c(...)), PACKAGE = "RGtk2")
   if (drop && length(props) == 1)
     props[[1]]
   else props
}

"[.GObject" <-
function(obj, value, ...)
{
 gObjectGet(obj, c(value, ...))
}

gObjectSet <-
function(obj, ...)
{
  args <- list(...)
  checkPtrType(obj, "GObject")
  if(any(names(args) == ""))
    stop("All values must have a name")

  invisible(.RGtkCall("R_setGObjectProps", obj, args, PACKAGE = "RGtk2"))
}

"[<-.GObject" <-
function(obj, propNames, value)
{
  value <- list(value)
  names(value) <- propNames
  .RGtkCall("R_setGObjectProps", obj, value, PACKAGE = "RGtk2")
  obj
}

gObject <- gObjectNew <-
function(type, ...)
{
  args <- list(...)
  type <- as.GType(type)
  if (!("GObject" %in% gTypeGetAncestors(type)))
    stop("GType must inherit from GObject")
  if(any(names(args) == ""))
    stop("All values must have a name")

  invisible(.RGtkCall("R_gObjectNew", type, args, PACKAGE = "RGtk2"))
}

## Parameter specifications

GParamFlags <- c("readable" = 1, "writable" = 2, "construct" = 4, 
  "construct-only" = 8, "lax-validation" = 16, "static-name" = 32,
  "private" = 32, "static-nick" = 64, "static-blurb" = 128)
  
gParamSpec <-
function(type, name, nick = NULL, blurb = NULL, flags = NULL, ...)
{
  # map type to param spec type, pass on the args
  
  spec <- list(name = name, nick = nick, blurb = blurb, flags = flags, ...)
  
  if (type == "integer")
    param_type <- "GParamInt"
  else if (type == "numeric")
    param_type <- "GParamDouble"
  else if (type == "logical")
    param_type <- "GParamBoolean"
  else if (type == "character")
    param_type <- "GParamString"
  else if (type == "raw")
    param_type <- "GParamUChar"
  else if (type == "R")
    param_type <- "RGtkParamSexp"
  else param_type <- type
  
  class(spec) <- c(param_type)
  
  as.GParamSpec(spec)
}

as.GParamSpec <- 
function(x)
{
  type <- sub(".*Param", "", class(x)[1])
  
  fields <- NULL
  common_fields <- c("name", "nick", "blurb", "flags")
  if (type %in% c("Boolean", "String", "Unichar"))
    fields <- "default.value"
  else if (type == "Flags")
    fields <- c("flags.type", "default.value")
  else if (type == "Enum")
    fields <- c("enum.type", "default.value")
  else if (type %in% c("Char", "UChar", "Int", "UInt", "ULong", "Long", "UInt64",
      "Int64", "Float", "Double"))
    fields <- c("minimum", "maximum", "default.value")
  else if (type == "Param")
    fields <- "param.type"
  else if (type == "Boxed")
    fields <- "boxed.type"
  else if (type == "Object")
    fields <- "object.type"
  else if (type == "ValueArray")
    fields <- "element.spec"
  else if (type == "GType")
    fields <- "is.a.type"
  else if (type == "Sexp")
    fields <- c("s.type", "default.value")
  
  x <- as.struct(x, c(class(x)[1], "GParamSpec"), c(common_fields, fields))

  x[[1]] <- as.character(x[[1]])
  x[[2]] <- as.character(x[[2]])
  x[[3]] <- as.character(x[[3]])
  
  if (is.null(x[[4]]))
    x[[4]] <- sum(GParamFlags[c("readable", "writable", "construct")])
  
  if (type == "Boolean")
    x[[5]] <- ifelse(is.null(x[[5]]), F, as.logical(x[[5]]))
  else if (type == "String")
    x[[5]] <- ifelse(is.null(x[[5]]), "", as.character(x[[5]]))
  else if (type == "Unichar")
    x[[5]] <- ifelse(is.null(x[[5]]), as.integer(0), as.integer(x[[5]]))
  else if (type %in% c("Flags", "Enum", "Param", "Boxed", "Object", "GType"))
    x[[5]] <- as.GType(x[[5]])
  else if (type %in% c("Char", "UChar")) {
    x[[5]] <- ifelse(is.null(x[[5]]), 0, as.raw(x[[5]]))
    x[[6]] <- as.raw(x[[6]])
    x[[7]] <- as.raw(x[[7]])
  } else if (type == "Int") {
    x[[5]] <- ifelse(is.null(x[[5]]), 0, as.integer(x[[5]]))
    x[[6]] <- as.integer(x[[6]])
    x[[7]] <- as.integer(x[[7]])
  } else if (type %in% c("UInt", "ULong", "Long", "UInt64", "Int64", "Float", "Double")) {
    x[[5]] <- ifelse(is.null(x[[5]]), 0, as.numeric(x[[5]]))
    x[[6]] <- as.numeric(x[[6]])
    x[[7]] <- as.numeric(x[[7]])
  } else if (type == "ValueArray")
    x[[5]] <- as.GParamSpec(x[[5]])
  else if (type == "Sexp") {
    # if there's no type, try to get it from the default value
    if (is.null(x[[5]]) && !is.null(x[[6]]))
      x[[5]] <- typeof(x[[6]])
    else if (is.null(x[[5]])) # otherwise, fallback to ANY
      x[[5]] <- "any"
    # if there's no default value, create one given the type (ANY->NULL)
    anysxp <- .RGtkCall("getNumericType", "any")
    if (is.null(x[[6]]) && x[[5]] != "any" && x[[5]] != anysxp)
      x[[6]] <- new(x[[5]])
    # if type is numeric, assume it's a type code, otherwise assume it's a type 
    # name and ask the C side to query the for the code
    if (!is.numeric(x[[5]]))
      x[[5]] <- .RGtkCall("getNumericType", x[[5]])
  }
  
  return(x)
}
  

gObjectSetData <-
function(obj, key, data = NULL)
{
        checkPtrType(obj, "GObject")
        key <- as.character(key)

        w <- .RGtkCall("S_g_object_set_data", obj, key, data, PACKAGE = "RGtk2")

        return(invisible(w))
}
gObjectGetData <-
function(obj, key)
{
        checkPtrType(obj, "GObject")
        key <- as.character(key)

        w <- .RGtkCall("S_g_object_get_data", obj, key, PACKAGE = "RGtk2")

        return(w)
}

# Methods

parentHandler <-
function(method, obj = NULL, ...)
{
  # untested stuff
  # chaining up is only allowed/makes sense from inside a GObject implementation
  stopifnot(implements(obj, "SGObject"))
  if (is.null(attr(obj, ".private")))
    stop("Parent methods should only be invoked within the instance")
  if (FALSE) { # stuff that might work some day
  parent_call <- sys.call(sys.parent(1))
  parent_frame <- parent.frame()
  formal_args <- formals(parent_call[[1]])
  if (missing(obj))
    obj <- get(names(formal_args)[1], parent_frame)
  args <- list(...)
  formal_names <- names(formal_args)[-1]
  missing_names <- formal_names[!(formal_names %in% names(args))]
  unnamed <- sapply(names(args), nchar) == 0
  names(args)[unnamed] <- missing_names[seq(along=unnamed)]
  missing_names <- missing_names[!(missing_names %in% names(args))]
  args[missing_names] <- lapply(missing_names, get, parent_frame)
  parent <- .Call("S_g_object_parent", obj, PACKAGE = "RGtk2")
  if (!is.null(parent) && is.function(try(parent[[method]], T)))
    fun <- parent[[method]]
  else { # fallback to calling a wrapper of the C virtual
    fun <- eval(substitute(gTypeGetClass(class(obj)[2])$sym, list(sym=method)))
    args <- c(obj, args)
  }      
  do.call(fun, args)
  }
  # assume looking for a function, does not make sense for fields
  #function(...) {
    # is this a function defined by a parent R class?
    parent <- .Call("S_g_object_parent", obj, PACKAGE = "RGtk2")
    if (!is.null(parent) && is.function(try(parent[[method]], T))) {
      parent[[method]](...)
    } else # fallback to calling a wrapper of the C virtual
      eval(substitute(gTypeGetClass(class(obj)[2])$sym(obj, ...), 
        list(obj=obj,sym=method)))
  #}
}

"$.<invalid>" <-
function(obj, name)
{
  stop("attempt to call '", name, "' on invalid reference '", deparse(substitute(obj)), "'", call.=FALSE)
}

"$.GObject" <- "$.RGtkObject" <-
function(x, member)
{ # try for a declared method first, else fall back to member
 result <- try(.getAutoMethodByName(x, member, parent.frame()), T)
 if (inherits(result, "try-error"))
   result <- x[[member]]
 result
}

.getAutoMemberByName <- 
function(obj, name)
{
  # if we have an SGObject, try private env (includes protected) then public
  stopifnot(implements(obj, "SGObject"))
  attrs <- attributes(obj)
  has_private <- ".private" %in% names(attrs)
  if (has_private)
    member <- try(get(name, attrs$.private), T)
  if (!has_private || inherits(member, "try-error"))
    member <- try(get(name, attrs$.public), T)
  if (is.function(member)) {
    # we need to add private env if it's not there
    if (!has_private)
      obj <- .Call("S_g_object_private", obj, PACKAGE="RGtk2")
    function(...) member(obj, ...)
  }
  else member
}

.getAutoMethodByName <-
function(obj, name, where)
{
    classes <- c(attr(obj, "interfaces"), class(obj))
    sym <- paste(tolower(substring(classes, 1, 1)), substring(classes, 2), toupper(substring(name, 1, 1)),
        substring(name,2), sep="")
    which <- sapply(sym, exists, where)

 if(!any(which))
   stop(paste("No such method", name, "for classes", paste(class(obj), collapse=", ")))

 method <- get(sym[which][1], where)
 
 function(...) method(obj, ...)
 
 #sym <- as.name(sym[which][1])
 
  # evaluate it to turn it into a function
  # and also get the correct environment
 #eval(substitute( function(...) {
 #                    sym(obj, ...)
 #                }, list(obj=obj,sym=sym)))
}

# Comparing pointers

.comparePointers <- function(x, y) {
    .Call("comparePointers", x, y, PACKAGE="RGtk2")
}

"==.RGtkObject" <-
function(x, y) {
  .comparePointers(x, y)
}

# Fields

"$<-.GObject" <- "[[<-.GObject" <-
function(obj, member, value)
{ # first try for prop, then fall back to private env
  # this encourages the setting of properties, rather than using the back door
  result <- try(obj[member] <- value, T)
  if (inherits(result, "try-error")) {
    env <- attr(obj, ".private")
    if (is.null(env))
      stop("Cannot find '", member, "' to set in ", paste(class(obj),collapse=", "))
    protected_env <- parent.env(env)
    if (exists(member, protected_env))
      env <- protected_env
    assign(member, value, env)
  }
  obj
}

"[[.GObject" <-
function(obj, member, where = parent.frame())
{
  # check SGObject environments first, then fall back to field/property
  val <- try(.getAutoMemberByName(obj, member), TRUE)
  # check for C field (fast), then GObject prop
  if (inherits(val, "try-error"))
    val <- try(NextMethod("[[", where = where), TRUE)
  if (inherits(val, "try-error"))
    val <- try(obj$get(member), TRUE)
  if (inherits(val, "try-error"))
    stop("Cannot find '", member, "' for classes ", paste(class(obj), collapse=", "))
  val
}

"[[.RGtkObject" <-
  #
  #
  #
function(x, field, where = parent.frame())
{
  fun <- try(.getAutoElementByName(x, field, error = FALSE, where = where),
             TRUE)
  if (!inherits(fun, "try-error"))
    val <- fun(x)
  else stop("Cannot find '", field, "' for classes ",
            paste(class(x), collapse=", "))
  return(val)
}
# C field setting is not allowed
if (FALSE) {
"[[<-.RGtkObject" <-
  #
  #
  #
function(x, name, value)
{
  sym <- try(.getAutoElementByName(x, name, op = "Set", error = FALSE))
  if (!inherits(sym, "try-error"))
    val <- eval(substitute(sym(x, value), list(sym=sym)))
  else if(inherits(x, "GObject"))
   val <- x$set(name)
  else val <- sym
  return(val)
}
}
.getAutoElementByName <-
function(obj, name, op = "Get", error = TRUE, where = parent.frame())
{
  sym <- paste("S_", class(obj), op,
               toupper(substring(name, 1, 1)), substring(name, 2), sep = "")
  sym <- Find(function(x) is.loaded(x, PACKAGE = "RGtk2"), sym)
  
  if(is.null(sym)) {
    message <- paste("Could not", op, "field", name, "for classes",
                     paste(class(obj), collapse=", "))
    if(error)
      stop(message)
    else {
      v <- paste(message)
      class(v) <- "try-error"
      return(v)
    }
  }

  function(obj) .Call(sym, obj, PACKAGE = "RGtk2")
}

# This attempts to coerce an R object to an RGClosure that is understood on the C side
as.GClosure <- 
function(x)
{
  if (inherits(x, "GClosure"))
    x <- toRGClosure(x)
  else x <- as.function(x)
  class(x) <- "RGClosure"
  x
}

# This attempts to convert a C GClosure to an R closure 
# (with extra ref attribute that prevents recursion on C side)
toRGClosure <-
function(c_closure)
{
  checkPtrType(c_closure, "GClosure")
  closure <- function(...) {
    .RGtkCall("R_g_closure_invoke", c_closure, c(...), PACKAGE = "RGtk2")
  }
  attr(closure, "ref") <- c_closure
  closure
}

# virtuals for GObject
assign("GObject", c("set_property", "get_property"), .virtuals)

Try the RGtk2 package in your browser

Any scripts or data that you put into this service are public.

RGtk2 documentation built on Oct. 14, 2021, 5:08 p.m.