1#  File src/library/methods/R/oldClass.R
2#  Part of the R package, https://www.R-project.org
3#
4#  Copyright (C) 1995-2015 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## assumes oldClass has been defined as a virtual class
20
21setOldClass <- function(Classes, prototype = NULL,
22                        where = topenv(parent.frame()), test = FALSE,
23                        S4Class) {
24    simpleCase <- is.null(prototype)
25    mainClass <- Classes[[1L]]
26    prevDef <- getClassDef(mainClass, where, inherits = FALSE)
27    if(!missing(S4Class)) {
28        if(test)
29          stop("not allowed to have test==TRUE and an S4Class definition")
30        if(!is(S4Class, "classRepresentation")) {
31            if(is.character(S4Class)) {
32                clName <- S4Class
33                S4Class <- getClass(S4Class)
34                if(.identC(clName, Classes[[1L]]))
35                  removeClass(clName, where = where) # so Recall() will work
36            }
37            else
38              stop(gettextf("argument 'S4Class' must be a class definition: got an object of class %s",
39                            dQuote(class(S4Class))),
40                   domain = NA)
41        }
42        if(!is.null(prototype)) {
43            S4prototype <- S4Class@prototype
44            ## use the explicit attributes from the supplied argument, else S4prototype
45            S4Class@prototype <- .mergeAttrs(prototype, S4prototype)
46        }
47        ## register simple S3 class(es), including main class, if it's not defined already
48        Recall(Classes, where = where)
49        return(.S4OldClass(Classes[[1L]], if(length(Classes) > 1) Classes[[2L]] else "oldClass", S4Class, where, prevDef))
50    }
51    if(test)
52        return(.setOldIs(Classes, where))
53    if(!is.null(prevDef)) {
54        on.exit(.restoreClass(prevDef, where))
55        removeClass(mainClass, where = where) # so Recall() will work
56    }
57    prevClass <- "oldClass"
58    S3Class <- character()  #will accumulate the S3 classes inherited
59    ## The table of S3 classes, used
60    ## to convert S4 objects in S3 method dispatch.
61    ## TODO:  should provide an optional argument to setOldClass()
62    ## to prevednt this conversion if it's not needed
63    if(is.null(S3table <- where$.S3MethodsClasses)) {
64      S3table <- new.env()
65      assign(".S3MethodsClasses", S3table, envir = where)
66    }
67    dataPartClass <- NULL
68    for(cl in rev(Classes)) {
69       S3Class <- c(cl, S3Class)
70        if(isClass(cl, where)) {
71            def <- getClass(cl, where)
72            if(!extends(def, prevClass)) {
73                ## maybe an object type or other valid data part
74                cl1 <- .validDataPartClass(cl, where, dataPartClass)
75                if(is.null(cl1))
76                  stop(gettextf("inconsistent old-style class information for %s; the class is defined but does not extend %s and is not valid as the data part",
77                                dQuote(cl),
78                                dQuote(prevClass)),
79                       domain = NA)
80                else dataPartClass <- cl1
81              }
82            else {
83              prevP <- def@prototype
84              if(missing(prototype))
85                prototype <- prevP # keep track of inherited prototype for use in mainClass
86              prevS3Class <- attr(prevP, ".S3Class")
87              if(length(prevS3Class) > length(S3Class)) #implies cl is registered S3 class
88                S3Class <- prevS3Class
89            }
90        }
91        else {
92            useP <- TRUE
93            if(cl != mainClass || simpleCase) {
94                setClass(cl, contains = c(prevClass, "VIRTUAL"), where = where)
95            }
96            else if(isClass(class(prototype)))
97                setClass(cl, contains = prevClass, prototype = prototype, where = where)
98            else { #exceptionally, we allow an S3 object from the S3 class as prototype
99                if(.class1(prototype) != mainClass)
100                  stop(gettextf('the S3 class of the prototype, "%s", is undefined; only allowed when this is the S3 class being registered ("%s")', .class1(prototype), mainClass), domain = NA)
101                setClass(cl, contains = prevClass, where = where)
102                useP <- FALSE
103            }
104            def <- getClassDef(cl, where)
105            if(useP) clp <- def@prototype else clp <- prototype
106            attr(clp, ".S3Class") <- S3Class
107            def@prototype <- .notS4(clp)
108            assignClassDef(cl, def, where = where)
109            ## add the class to the table of S3 classes
110            assign(cl, def, envir= S3table)
111        }
112       prevClass <- cl
113    }
114    if(!is.null(prevDef)) # cancel error action
115      on.exit()
116}
117
118.restoreClass <- function(def, where) {
119    cl <- def@className
120    message(gettextf("restoring definition of class %s", dQuote(cl)),
121            domain = NA)
122    if(isClass(cl, where = where))
123       removeClass(cl, where = where)
124    assignClassDef(cl, def, where = where)
125}
126
127.S4OldClass <- function(Class, prevClass, def,where, prevDef) {
128    ## def is the S4 version of this class def'n, maybe by another class
129    ## name, and may or may not already extend oldClass
130    curDef <- getClassDef(Class, where) # asserted to be defined
131    ## arrange to restore previous definition if there was one.  Also done in setOldClass
132    ## when no S4Class argument supplied
133    if(!is.null(prevDef)) {
134        on.exit(.restoreClass(prevDef, where))
135        removeClass(Class, where = where) # so Recall() will work
136    }
137    if(!identical(def@className, curDef@className))
138      def <- .renameClassDef(def, curDef@className)
139    ## check that any common slots will give a valid S3 object
140    .validS3Extends(def, curDef)
141    def@slots[names(curDef@slots)] <- curDef@slots
142    ext <- c(def@contains, curDef@contains)
143    ## correct ordering & duplicate resolution: copied from .walkClassGraph
144    distOrder <- sort.list(vapply(ext, function(x) x@distance, 1))
145    ext <- ext[distOrder]
146    if(anyDuplicated(names(ext)))
147        ext <- .resolveSuperclasses(def, ext, where)
148    def@contains <- ext
149    oldSupers <- setdiff(names(def@contains), names(curDef@contains))
150    addSubclass <- function(super) {
151      superDef <- getClassDef(super, where)
152      superWhere <- .findOrCopyClass(super, superDef, where, "subclass")
153      superDef@subclasses[[Class]] <- def@contains[[super]]
154      assignClassDef(super, superDef, superWhere, TRUE)
155    }
156    lapply(oldSupers, addSubclass)
157    subcls <- curDef@subclasses
158    if(length(subcls) > 0) {
159      def@subclasses[names(subcls)]  <- subcls
160    }
161    proto <- def@prototype
162    if(is.null(attr(proto, ".S3Class"))) { # no S3 class slot, as will usually be true
163        attr(proto, ".S3Class") <- if(.identC(prevClass, "oldClass")) Class else S3Class(curDef@prototype)
164        def@prototype <- proto
165    }
166    assignClassDef(Class, def, where = where)
167    ## allow an existing superclass relation to remain (it may have a coerce method)
168    ## Otherwise, create a simple transformation, which relies on consistency
169    ## in the slots.
170    if(!extends(def, prevClass, maybe = FALSE))
171      setIs(Class, prevClass, classDef = def, where = where)
172    slotsMethod <- function(object) NULL
173    body(slotsMethod) <- substitute({LIST}, list(LIST = def@slots))
174    setMethod("slotsFromS3", Class, slotsMethod, where = where)
175    if(!is.null(prevDef)) # cancel error action
176      on.exit()
177}
178
179.validS3Extends <- function(classDef1, classDef2) {
180    slots2 <- classDef2@slots
181    if(length(slots2) > 0) {
182        n2 <- names(slots2)
183        slots1 <- classDef1@slots
184        n1 <- names(slots1)
185        bad <- character()
186        for(what in n2[match(n2, n1, 0) > 0])
187          if(!extends(slots1[[what]], slots2[[what]])) {
188              message(gettextf("slot %s: class %s should extend class %s",
189                               sQuote(what),
190                               dQuote(slots1[[what]]),
191                               dQuote(slots2[[what]])),
192                      domain = NA)
193              bad <- c(bad, what)
194          }
195        if(length(bad)>0)
196          stop(
197               gettextf("invalid S4 class corresponding to S3 class: slots in  S4 version must extend corresponding slots in S3 version: fails for %s",
198                        paste0('"', bad, '"',  collapse = ", ")),
199               domain = NA)
200    }
201    TRUE
202}
203
204##.initS3Classes will make this generic, with a method for "oldClass"
205slotsFromS3 <- function(object) {
206    list()
207}
208
209utils::globalVariables("CLASS")
210
211.oldTestFun <- function(object) CLASS %in% attr(object, "class")
212.oldCoerceFun <- function(from, strict = TRUE) {
213    if(strict)
214        stop(gettextf("explicit coercion of old-style class (%s) is not defined", paste(class(from), collapse = ", ")), domain = NA)
215    from
216}
217.oldReplaceFun <- function(from, to, value)
218    stop(gettextf("explicit replacement not defined for as(x, \"%s\") <- value for old-style class %s",
219                  to, dQuote(class(from)[1L])),
220         domain = NA)
221
222## the inheritance of these S3 classes must be decided on a per-instance
223## basis.  At one time, there were classes in base/stats that had this
224## property, (e.g., POSIXt, POSIX{cl}t) but apparently no longer.
225## The possibility is still allowed
226## for user-defined S3 classes.
227.setOldIs <- function(Classes, where) {
228    if(length(Classes) != 2)
229        stop(gettextf("argument 'Classes' must be a vector of two classes; got an argument of length %d", length(Classes)), domain = NA)
230    for(cl in Classes) {
231        if(isClass(cl, where)) {
232            if(!extends(cl, "oldClass"))
233                warning(gettextf("inconsistent old-style class information for %s (maybe mixing old and new classes?)",
234                                 dQuote(cl)), domain = NA)
235        }
236        else
237            setClass(cl, representation("oldClass", "VIRTUAL"), where = where)
238    }
239    Class1 <- Classes[[1L]]
240    for(cl in Classes[-1L]) {
241        tfun <- .oldTestFun
242        body(tfun, envir = environment(tfun)) <-
243            substitute(inherits(object, CLASS), list(CLASS = cl))
244        setIs(Class1, cl, test = tfun, coerce = .oldCoerceFun,
245              replace = .oldReplaceFun, where = where)
246    }
247    NULL
248}
249
250isXS3Class <- function(classDef) {
251    ".S3Class" %in% names(classDef@slots)
252}
253
254S3Class <- function(object) {
255    value <- attr(object, ".S3Class")
256    if(is.null(value)) {
257        if(isS4(object)) {
258            if(is.na(match(".Data", names(getClass(class(object))@slots))))
259                stop(gettextf("'S3Class' only defined for extensions of %s or classes with a data part:  not true of class %s",
260                              dQuote("oldClass"),
261                              dQuote(class(object))),
262                     domain = NA)
263            class(getDataPart(object))
264        }
265        else
266          class(object)
267    }
268    else
269      value
270}
271
272.S3Class <- S3Class # alias for functions with S3Class as an argument
273
274.addS3Class <- function(class, prototype, contains, where) {
275    for(what in contains) {
276        whatDef <- getClassDef(what@superClass, package=packageSlot(what))
277        if(isXS3Class(whatDef))
278          class <- c(class, attr(whatDef@prototype, ".S3Class"))
279    }
280    attr(prototype, ".S3Class") <- unique(class)
281    prototype
282}
283
284"S3Class<-" <- function(object, value) {
285    if(isS4(object)) {
286        current <- attr(object, ".S3Class")
287        if(is.null(current)) {
288            if(is.na(match(value, .BasicClasses)))
289               stop(gettextf("'S3Class' can only assign to S4 objects that extend \"oldClass\"; not true of class %s",
290                             dQuote(class(object))),
291                    domain = NA)
292            mode(object) <- value ## may still fail, a further check would be good
293        }
294        else
295          slot(object, ".S3Class") <- value
296    }
297    else
298      class(object) <- value
299    object
300}
301
302## rename a class definition:  needs to change if any additional occurences of class
303## name are added, other than the className slot and the super/sub class names
304## in the contains, subclasses slots respectively.
305.renameClassDef <- function(def, className) {
306##    oldName <- def@className
307    validObject(def) # to catch any non-SClassExtension objects
308    def@className <- className
309    comp <- def@contains
310    for(i in seq_along(comp))
311        comp[[i]]@subClass <- className
312    def@contains <- comp
313    comp <- def@subclasses
314    for(i in seq_along(comp))
315        comp[[i]]@superClass <- className
316    def@subclasses <- comp
317    def
318}
319
320## extends() w/o conditional inheritance:  used for S3 inheritance, method
321## selection on S4 objects
322..extendsForS3 <- function(Class)
323    extends(Class, maybe = FALSE)
324## dummy version while generating methods package
325.extendsForS3 <- function(Class)
326    extends(Class)
327