#  File src/library/methods/R/SClasses.R
#  Part of the R package, http://www.R-project.org
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  A copy of the GNU General Public License is available at
#  http://www.r-project.org/Licenses/

setClass <-
    ## Define Class to be an S-style class.
    function(Class, representation = list(), prototype = NULL,
             contains = character(), validity = NULL, access = list(),
             where = topenv(parent.frame()), version = .newExternalptr(),
             sealed = FALSE, package = getPackageName(where),
             S3methods = FALSE)
{
    oldDef <- getClassDef(Class, where)
    if(is(oldDef, "classRepresentation") && oldDef@sealed)
        stop(gettextf("\"%s\" has a sealed class definition and cannot be redefined", Class), domain = NA)
    if(is(representation, "classRepresentation")) {
        ## supplied a class definition object
        classDef <- representation
        if(!(missing(prototype) && missing(contains) && missing(validity) && missing(access)
             && missing(version) && missing(package)))
            stop("only arguments 'Class' and 'where' can be supplied when argument 'representation' is a 'classRepresentation' object")
        if(length(classDef@package) == 0L)
            classDef@package <- package # the default
        superClasses <- allNames(classDef@contains)
    }
    else {
        ## catch the special case of a single class name as the representation
        if(is.character(representation) && length(representation) == 1L &&
           is.null(names(representation)))
            representation <- list(representation)
        slots <- nzchar(allNames(representation))
        superClasses <- c(as.character(representation[!slots]), contains)
        properties <- representation[slots]
        classDef <- makeClassRepresentation(Class, properties,superClasses, prototype, package,
                                             validity, access, version, sealed, where = where)
        superClasses <- names(classDef@contains)
    }
    classDef <- completeClassDefinition(Class, classDef, where, doExtends = FALSE)
    oldDef <- getClassDef(Class, where)
    if(is(oldDef, "classRepresentation"))
      .uncacheClass(Class, oldDef)
    if(length(superClasses) > 0L) {
        sealed <- classDef@sealed
        classDef@sealed <- FALSE # to allow setIs to work anyway; will be reset later
        assignClassDef(Class, classDef, where)
        badContains <- character()
        for(class2 in superClasses) {
            if(is(try(setIs(Class, class2, classDef = classDef, where = where)), "try-error"))
                badContains <- c(badContains, class2)
            else { # update class definition
                classDef <- getClassDef(Class, where = where)
                if(is.null(classDef))
                  stop(gettextf('Internal error: definition of class "%s" not properly assigned', Class),
                       domain = NA)
            }
          }
        if(length(badContains)) {
            msg <- paste(.dQ(badContains), collapse = ", ")
            if(is(try(removeClass(Class, where)), "try-error"))
                stop(gettextf("error in contained classes (%s) for class \"%s\" and unable to remove definition from \"%s\"",
                              msg, Class, getPackageName(where)), domain = NA)
            if(is.null(oldDef))
                stop(gettextf("error in contained classes (%s) for class \"%s\"; class definition removed from \"%s\"",
                              msg, Class, getPackageName(where)), domain = NA)
            else if(is(try(setClass(Class, oldDef, where=where)), "try-error"))
                stop(gettextf("error in contained classes (%s) for class \"%s\" and unable to restore previous definition from \"%s\"",
                              msg, Class, getPackageName(where)), domain = NA)
            else
                stop(gettextf("error in contained classes (%s) for class \"%s\"; previous definition restored to \"%s\"",
                              msg, Class, getPackageName(where)), domain = NA)
        }
        if(length(attr(classDef@contains, "conflicts")) > 0)
          .reportSuperclassConflicts(Class, classDef@contains, where)
        .checkRequiredGenerics(Class, classDef, where)
        if(sealed) {
            classDef@sealed <- TRUE
        }
    }
    if(S3methods)
      classDef <- .setS3MethodsOn(classDef)
    assignClassDef(Class, classDef, where)
     Class
}

representation <-
  ## Representation of a class; that is,
  ## a list of named slots and unnamed classes to be included in a class
  ## definition.
  function(...)
{
    value <- list(...)
    ## unlike the S-Plus function, this does not form the class representation,
    ## since set SClass works separately with the slots and extends arguments.
    anames <- allNames(value)
    for(i in seq_along(value)) {
        ei <- el(value, i)
        if(!is.character(ei) || length(ei) != 1L)
            stop(gettextf("element %d of the representation was not a single character string", i), domain = NA)
    }
    includes <- as.character(value[!nzchar(anames)])
    if(anyDuplicated(includes))
        stop(gettextf("duplicate class names among superclasses: %s",
                      paste(.dQ(includes[duplicated(includes)]),
                            collapse = ", ")),
             domain = NA)
    slots <- anames[nzchar(anames)]
    if(anyDuplicated(slots))
       stop(gettextf("duplicated slot names: %s",
                     paste(sQuote(slots[duplicated(slots)]), collapse="")),
            domain = NA)
    value
}

### the version called prototype is the external interface.  But functions with argument
### named prototype in R cannot call the prototype function (until there is a methods namespace
### to allow methods::prototype(...)
prototype <- function(...)
    .prototype(...)

.prototype <- function(...) {
    props <- list(...)
    names <- allNames(props)
    data <- !nzchar(names)
    dataPart <- any(data)
    if(dataPart) {
        if(sum(data) > 1)
            stop("only one data object (unnamed argument to prototype) allowed")
        obj <- unclass(props[[seq_along(data)[data] ]])
        props <- props[!data]
        names <- names[!data]
    }
    else
        obj <- defaultPrototype()
    for(i in seq_along(names))
        slot(obj, names[[i]], FALSE) <- props[[i]]
    new("classPrototypeDef", object = obj, slots = names, dataPart = dataPart)
}

makeClassRepresentation <-
  ## Set the Class Definition.
  ## The formal definition of the class is set according to the arguments.
  ##
  ## Users should call setClass instead of this function.
  function(name, slots = list(), superClasses = character(), prototype = NULL, package, validity = NULL, access = list(), version = .newExternalptr(), sealed = FALSE, virtual = NA, where)
{
    if(any(superClasses %in% .AbnormalTypes))
        superClasses <- .addAbnormalDataType(superClasses)
    if(!is.null(prototype) || length(slots) || length(superClasses)) {
        ## collect information about slots, create prototype if needed
        pp <- reconcilePropertiesAndPrototype(name, slots, prototype, superClasses, where)
        slots <- pp$properties
        prototype <- pp$prototype
    }
    contains <- list()
    if(nzchar(package))
        packageSlot(name) <- package
    for(what in superClasses) {
        if(is(what, "classRepresentation"))
            whatClassDef <- what
        else if(is.null(packageSlot(what)))
            whatClassDef <- getClass(what, where = where)
        else
            whatClassDef <- getClass(what)
        what <- whatClassDef@className # includes package name as attribute
        ## Create the SClassExtension objects (will be simple, possibly dataPart).
        ## The slots are supplied explicitly, since `name' is currently an undefined class
        elNamed(contains, what) <- makeExtends(name, what, slots = slots,
                                              classDef2 = whatClassDef, package = package)
    }
    validity <- .makeValidityMethod(name, validity)
    if(is.na(virtual)) {
        virtual <- testVirtual(slots, contains, prototype, where)
        if(virtual && !is.na(match("VIRTUAL", superClasses)))
            elNamed(contains, "VIRTUAL") <- NULL
    }
    # new() must return an S4 object, except perhaps for basic classes
    if(!is.null(prototype) && is.na(match(name, .BasicClasses)))
      prototype <- .asS4(prototype)
    if(".S3Class" %in% names(slots))
      prototype <- .addS3Class(name, prototype, contains, where)
    newClassRepresentation(className = name, slots = slots,
                           contains = contains,
                           prototype = prototype,
                           virtual = virtual,
                           validity = validity,
                           access = access,
                           package = package,
                           versionKey = version,
                           sealed = sealed)
}

getClassDef <-
  ## Get the definition of the class supplied as a string.
  function(Class, where = topenv(parent.frame()), package = packageSlot(Class),
           inherits = TRUE)
{
    if(inherits) #includes both the lookup and Class being alread a definition
      value <- .getClassFromCache(Class, where)
    else # want to force a search for the metadata in this case (Why?)
      value <- NULL
    if(is.null(value)) {
	cname <-
	    classMetaName(if(length(Class) > 1L)
			  ## S3 class; almost certainly has no packageSlot,
			  ## but we'll continue anyway
			  Class[[1L]] else Class)
	## a string with a package slot strongly implies the class definition
	## should be in that package.
	if(identical(nzchar(package), TRUE)) {
	    whereP <- .requirePackage(package)
	    if(exists(cname, whereP, inherits = inherits))
		value <- get(cname, whereP)
	}
	if(is.null(value) && exists(cname, where, inherits = inherits))
	    value <- get(cname, where)
    }
    value
}

getClass <-
  ## Get the complete definition of the class supplied as a string,
  ## including all slots, etc. in classes that this class extends.
  function(Class, .Force = FALSE,
	   where = .classEnv(Class, topenv(parent.frame()), FALSE))
{
    value <- .getClassFromCache(Class, where) # the quick way
    if(is.null(value)) {
        value <- getClassDef(Class, where) # searches
        if(is.null(value)) {
            if(!.Force)
                stop(gettextf("\"%s\" is not a defined class", Class), domain = NA)
            else
                value <- makeClassRepresentation(Class, package = "base",
                                                 virtual = TRUE, where = where)
        }
    }
    value
}

slot <-
  ## Get the value of the named slot.  This function does exact, not partial, matching of names,
  ## and the name must be one of the slot names specified in the class's definition.
  ##
  ## Because slots are stored as attributes, the validity check is not 100% guaranteed,
  ## but should be OK if nobody has "cheated" (e.g., by setting other attributes directly).
  function(object, name)
    .Call("R_get_slot", object, name, PACKAGE = "methods")

"slot<-" <-
  ## Set the value of the named slot.  Must be one of the slots in the class's definition.
  function(object, name, check = TRUE, value) {
      if(check)
          value <- checkSlotAssignment(object, name, value)
      .Call("R_set_slot", object, name, value, PACKAGE="methods")
      ## currently --> R_do_slot_assign() in ../../../main/attrib.c
  }

## ". - hidden" since one should typically rather use is(), extends() etc:
.hasSlot <- function(object, name)
    .Call("R_hasSlot", object, name, PACKAGE = "methods")

checkSlotAssignment <- function(obj, name, value)
{
    cl <- class(obj)
    ClassDef <- getClass(cl) # fails if cl not a defined class (!)
    slotClass <- elNamed(ClassDef@slots, name)
    if(is.null(slotClass))
        stop(gettextf("\"%s\" is not a slot in class \"%s\"", name, cl),
             domain = NA)
    valueClass <- class(value)
    if(.identC(slotClass, valueClass))
       return(value)
    ## check the value, but be careful to use the definition of the slot's class from
    ## the class environment of obj (change validObject too if a better way is found)
    ok <- possibleExtends(valueClass, slotClass,
                          ClassDef2 = getClassDef(slotClass, where = .classEnv(ClassDef)))
    if(identical(ok, FALSE))
       stop(gettextf("assignment of an object of class \"%s\" is not valid for slot \"%s\" in an object of class \"%s\"; is(value, \"%s\") is not TRUE",
		     valueClass, name, cl, slotClass),
            domain = NA)
    else if(identical(ok, TRUE))
        value
    else
       as(value, slotClass, strict=FALSE, ext = ok)
}



## "@" <-
##   function(object, name)
##   .Internal(object@name)

"@<-" <-
   function(object, name, value) {
     arg <- substitute(name)
     if(is.name(arg))
       name <- as.character(arg)
     "slot<-"(object, name, TRUE, value)
   }

##  The names of the class's slots.  The argument is either the name
##  of a class, or an object from the relevant class.

## NOTA BENE:  .slotNames() shouldn't be needed,
##             rather slotNames() should be changed (to work like .slotNames())!
slotNames <- function(x)
    if(is(x, "classRepresentation")) names(x@slots) else .slotNames(x)

.slotNames <- function(x)
{
    classDef <-
	getClassDef(if(identical(class(x), "character") && length(x) == 1L) x else class(x))
    if(is.null(classDef))
	character()
    else
	names(classDef@slots)
}


removeClass <-  function(Class, where = topenv(parent.frame())) {
    if(missing(where)) {
       classEnv <- .classEnv(Class, where, FALSE)
        classWhere <- findClass(Class, where = classEnv)
        if(length(classWhere) == 0L) {
            warning(gettextf("Class definition for \"%s\" not found  (no action taken)", Class),
                    domain = NA)
            return(FALSE)
        }
        if(length(classWhere) > 1L)
            warning(gettextf("class \"%s\" has multiple definitions visible; only the first removed", Class), domain = NA)
        classWhere <- classWhere[[1L]]
    }
    else classWhere <- where
    classDef <- getClassDef(Class, where=classWhere)
    if(length(classDef@subclasses)) {
      subclasses <- names(classDef@subclasses)
      found <- sapply(subclasses, isClass, where = where)
      for(what in subclasses[found])
          .removeSuperClass(what, Class)
    }
    .removeSuperclassBackRefs(Class, classDef, classWhere)
    .uncacheClass(Class, classDef)
    .undefineMethod("initialize", Class, classWhere)
    what <- classMetaName(Class)
    rm(list=what, pos=classWhere)
    TRUE
}


isClass <-
  ## Is this a formally defined class?
  function(Class, formal=TRUE, where = topenv(parent.frame()))
{
    ## argument formal is for Splus compatibility & is ignored.  (All classes that
    ## are defined must have a class definition object.)
    if(missing(where))
        !is.null(getClassDef(Class))
    else
        !is.null(getClassDef(Class, where))
}

### TODO   s/Class/._class/  -- in order to allow 'Class' as regular slot name
new <-
  ## Generate an object from the specified class.
  ##
  ## Note that the basic vector classes, `"numeric"', etc. are implicitly defined,
  ## so one can use `new' for these classes.
  ##
  function(Class, ...)
{
    ClassDef <- getClass(Class, where = topenv(parent.frame()))
    value <- .Call("R_do_new_object", ClassDef, PACKAGE = "base")
    initialize(value, ...)
}

getClasses <-
  ## The names of all the classes formally defined on `where'.
  ## If called with no argument, all the classes currently known in the session
  ## (which does not include classes that may be defined on one of the attached
  ## libraries, but have not yet been used in the session).
  function(where = .externalCallerEnv(), inherits = missing(where))
{
    pat <- paste("^",classMetaName(""), sep="")
    if(inherits) {
        evList <- .parentEnvList(where)
        clNames <- character()
        for(ev in evList)
            clNames <- c(clNames, objects(ev, pattern = pat, all.names = TRUE))
        clNames <- unique(clNames)
    }
    else
        clNames <- objects(where, pattern = pat, all.names = TRUE)
    ## strip off the leading pattern (this implicitly assumes the characters
    ## in classMetaName("") are either "." or not metacharacters
    substring(clNames, nchar(pat, "c"))
}


validObject <- function(object, test = FALSE, complete = FALSE)
{
    Class <- class(object)
    classDef <- getClassDef(Class)
    where <- .classEnv(classDef)
    anyStrings <- function(x) if(identical(x, TRUE)) character() else x
    ## perform, from bottom up, the default and any explicit validity tests
    ## First, validate the slots.
    errors <- character()
    slotTypes <- classDef@slots
    slotNames <- names(slotTypes)
    attrNames <- c(".Data", ".S3Class", names(attributes(object)))
    if(any(is.na(match(slotNames, attrNames)))) {
        badSlots <- is.na(match(slotNames, attrNames))
        errors <- c(errors, paste("slots in class definition but not in object:", paste('"', slotNames[badSlots], '"', sep="", collapse = ", ")))
        slotTypes <- slotTypes[!badSlots]
        slotNames <- slotNames[!badSlots]
    }
    for(i in seq_along(slotTypes)) {
	classi <- slotTypes[[i]]
	classDefi <- getClassDef(classi, where = where)
	if(is.null(classDefi)) {
	    errors <- c(errors, paste("undefined class for slot \"", slotNames[[i]],
				      "\" (\"", classi, "\")", sep=""))
	    next
	}
        namei <- slotNames[[i]]
        sloti <- try(switch(namei,
                            ## .S3Class for S3 objects (e.g., "factor")
                            .S3Class = S3Class(object),
                            slot(object, namei)
                            ), silent = TRUE)
        if(inherits(sloti, "try-error")) {
           errors <- c(errors, sloti)
           next
        }
	## note that the use of possibleExtends is shared with checkSlotAssignment(), in case a
	## future revision improves on it!
	ok <- possibleExtends(class(sloti), classi, ClassDef2 = classDefi)
	if(identical(ok, FALSE)) {
	    errors <- c(errors,
			paste("invalid object for slot \"", slotNames[[i]],
			      "\" in class \"", Class,
			      "\": got class \"", class(sloti),
			      "\", should be or extend class \"", classi, "\"",
			      sep = ""))
	    next
	}
	if(!complete)
          next
        errori <- anyStrings(Recall(sloti, TRUE, TRUE))
        if(length(errori)) {
            errori <- paste("In slot \"", slotNames[[i]],
                            "\" of class \"", class(sloti), "\": ",
                            errori, sep = "")
            errors <- c(errors, errori)
        }
    }
    extends <- rev(classDef@contains)
    for(i in seq_along(extends)) {
	exti <- extends[[i]]
	superClass <- exti@superClass
	if(!exti@simple && !is(object, superClass))
	    next ## skip conditional relations that don't hold for this object
	superDef <- getClassDef(superClass, where = where)
	if(is.null(superDef)) {
	    errors <- c(errors,
			paste("superclass \"", superClass,
			      "\" not defined in the environment of the object's class",
			      sep=""))
	    break
	}
	validityMethod <- superDef@validity
	if(is(validityMethod, "function")) {
	    errors <- c(errors, anyStrings(validityMethod(as(object, superClass))))
	    if(length(errors))
		break
	}
    }
    validityMethod <- classDef@validity
    if(length(errors) == 0L && is(validityMethod, "function")) {
	errors <- c(errors, anyStrings(validityMethod(object)))
    }
    if(length(errors)) {
	if(test)
	    errors
	else {
	    msg <- gettextf("invalid class \"%s\" object:", Class)
	    if(length(errors) > 1L)
		stop(paste(msg,
			   paste(paste(seq_along(errors), errors, sep=": ")),
			   collapse = "\n"), domain = NA)
	    else stop(msg, " ", errors, domain = NA)
	}
    }
    else
	TRUE
}

setValidity <- function(Class, method, where = topenv(parent.frame())) {
    if(isClassDef(Class)) {
	ClassDef <- Class
	Class <- ClassDef@className
    }
    else {
	ClassDef <- getClassDef(Class, where)
    }
    method <- .makeValidityMethod(Class, method)
    if(is.null(method) ||
       (is(method, "function") && length(formalArgs(method)) == 1L))
	ClassDef@validity <- method
    else
	stop("validity method must be NULL or a function of one argument")
    ## TO DO:  check the where argument against the package of the class def.
    assignClassDef(Class, ClassDef, where = where)
    resetClass(Class, ClassDef, where = where)
}

getValidity <- function (ClassDef) {
    ## "needed" according to ../man/validObject.Rd
    ClassDef@validity
}


resetClass <- function(Class, classDef, where) {
        if(is(Class, "classRepresentation")) {
            classDef <- Class
            Class <- Class@className
            if(missing(where))
                where <- .classDefEnv(classDef)
        }
        else {
            if(missing(where)) {
                if(missing(classDef))
                    where <- findClass(Class, unique = "resetting the definition")[[1L]]
                else
                    where <- .classDefEnv(classDef)
            }
            if(missing(classDef)) {
                classDef <- getClassDef(Class, where)
                if(is.null(classDef)) {
                    warning(gettextf("class \"%s\" not found on \"%s\"; 'resetClass' will have no effect", Class, getPackageName(where)), domain = NA)
                    return(classDef)
                }
            }
            else if(!is(classDef, "classRepresentation"))
                stop(gettextf("argument 'classDef' must be a string or a class representation; got an object of class \"%s\"", class(classDef)), domain = NA)
            package <- getPackageName(where)
        }
        if(classDef@sealed)
            warning(gettextf("class \"%s\" is sealed; 'resetClass' will have no effect", Class), domain = NA)
        else {
            classDef <-  .uncompleteClassDefinition(classDef)
            classDef <- completeClassDefinition(Class, classDef, where)
            assignClassDef(Class, classDef, where)
        }
        classDef
    }

## the (default) initialization:  becomes the default method when the function
## is made a generic by .InitMethodDefinitions

initialize <- function(.Object, ...) {
    args <- list(...)
    if(length(args)) {
        Class <- class(.Object)
        ## the basic classes have fixed definitions
        if(!is.na(match(Class, .BasicClasses)))
            return(newBasic(Class, ...))
        ClassDef <- getClass(Class)
        ## separate the slots, superclass objects
        snames <- allNames(args)
        which <- nzchar(snames)
        elements <- args[which]
        supers <- args[!which]
        thisExtends <- names(ClassDef@contains)
        slotDefs <- ClassDef@slots
        dataPart <- elNamed(slotDefs, ".Data")
        if(is.null(dataPart)) dataPart <- "missing"
        if(length(supers)) {
            for(i in rev(seq_along(supers))) {
                obj <- el(supers, i)
                Classi <- class(obj)
                if(length(Classi) > 1L)
                    Classi <- Classi[[1L]] #possible S3 inheritance
                ## test some cases that let information be copied into the
                ## object, ordered from more to less:  all the slots in the
                ## first two cases, some in the 3rd, just the data part in 4th
                if(.identC(Classi, Class))
                    .Object <- obj
                else if(extends(Classi, Class))
                    .Object <- as(obj, Class, strict=FALSE)
                else if(extends(Class, Classi))
                    as(.Object, Classi) <- obj
                else if(extends(Classi, dataPart))
                    .Object@.Data <- obj
                else {
                    ## is there a class to which we can coerce obj
                    ## that is then among the superclasses of Class?
                    extendsi <- extends(Classi)[-1L]
                    ## look for the common extensions, choose the first
                    ## one in the extensions of Class
                    which <- match(thisExtends, extendsi)
                    which <- seq_along(which)[!is.na(which)]
                    if(length(which)) {
                        Classi <- thisExtends[which[1L]]
###                    was:    as(.Object, Classi) <- as(obj, Classi, strict = FALSE)
                        ## but   as<- does an as(....) to its value argument
                        as(.Object, Classi) <- obj
                    }
                    else
                        stop(gettextf("cannot use object of class \"%s\" in new():  class \"%s\" does not extend that class", Classi, Class), domain = NA)
                }
            }
        }
        if(length(elements)) {
            snames <- names(elements)
	    if(anyDuplicated(snames))
                stop(gettextf("duplicated slot names: %s",
                              paste(sQuote(snames[duplicated(snames)]),
                                    collapse = ", ")), domain = NA)
            which  <- match(snames, names(slotDefs))
            if(any(is.na(which)))
                stop(gettextf("invalid names for slots of class \"%s\": %s",
                              Class,
                              paste(snames[is.na(which)], collapse=", ")),
                     domain = NA)
            firstTime <- TRUE
            for(i in seq_along(snames)) {
                slotName <- el(snames, i)
                slotClass <- elNamed(slotDefs, slotName)
                slotClassDef <- getClassDef(slotClass, package=ClassDef@package)
                slotVal <- el(elements, i)
                ## perform non-strict coercion, but leave the error messages for
                ## values not conforming to the slot definitions to validObject(),
                ## hence the check = FALSE argument in the slot assignment
                if(!.identC(class(slotVal), slotClass)
                   && !is.null(slotClassDef) ) {
                    valClass <- class(slotVal)
                    valClassDef <- getClassDef(valClass, package = ClassDef@package)
                    if(!identical(possibleExtends(valClass, slotClass,
                                         valClassDef, slotClassDef), FALSE))
                        slotVal <- as(slotVal, slotClass, strict = FALSE)
                }
                if (firstTime) {
                    ## force a copy of .Object
                    slot(.Object, slotName, check = FALSE) <- slotVal
                    firstTime <- FALSE
                } else {
                    ## XXX: do the assignment in-place
                    "slot<-"(.Object, slotName, check = FALSE, slotVal)
                }
            }
        }
        validObject(.Object)
     }
    .Object
}

findClass <- function(Class, where = topenv(parent.frame()), unique = "") {
    if(is(Class, "classRepresentation")) {
        pkg <- Class@package
        classDef <- Class
        Class <- Class@className
    }
    else {
        pkg <- packageSlot(Class)
        if(is.null(pkg))
          pkg <- ""
        classDef <- getClassDef(Class, where, pkg)
    }
    if(missing(where) && nzchar(pkg))
            where <- .requirePackage(pkg)
    else
        where <- as.environment(where)
    what <- classMetaName(Class)
    where <- .findAll(what, where)
    if(length(where) > 1L && nzchar(pkg)) {
        pkgs <- sapply(where, function(db)get(what, db)@package)
        where <- where[match(pkg, pkgs, 0L)]
    }
    else
      pkgs <- pkg
    if(length(where) != 1L) {
            if(length(where) == 0L) {
                if(is.null(classDef))
                  classDef <- getClassDef(Class) # but won't likely succeed over previous
                if(nzchar(unique)) {
                    if(is(classDef, "classRepresentation"))
                      stop(gettextf('Class "%s" is defined, with package "%s", but no corresponding metadata object was found (not exported?)',
                                  Class, classDef@package), domain = NA)
                    else
                      stop(gettextf("no definition of \"%s\" to use for %s",
                              Class, unique), domain = NA)
                }
            }
            else if(nzchar(unique)) {
                where <- where[1L]
                ## problem: 'unique'x is text passed in, so do not translate
                warning(gettextf("multiple definitions of class \"%s\" visible; using the definition\n   in package \"%s\" for %s",
                                 Class, getPackageName(where[[1L]]), unique),
                        domain = NA)
            }
            ## else returns a list of >1 places, for the caller to sort out (e.g., .findOrCopyClass)
    }
    where
}

isSealedClass <- function(Class, where = topenv(parent.frame())) {
    if(is.character(Class))
            Class <- getClass(Class, TRUE, where)
    if(!is(Class, "classRepresentation"))
        FALSE
    else
        Class@sealed
}

sealClass <- function(Class, where = topenv(parent.frame())) {
    if(missing(where))
        where <- findClass(Class, unique = "sealing the class", where = where)
    classDef <- getClassDef(Class, where)
    if(!classDef@sealed) {
        classDef@sealed <- TRUE
        assignClassDef(Class, classDef, where)
    }
    invisible(classDef)
}

## see $RHOME/src/main/duplicate.c for the corresponding datatypes
## not copied by duplicate1
.AbnormalTypes <- c("environment", "name", "primitive", "externalptr", "weakref", "NULL", "bytecode")

.indirectAbnormalClasses <- c(environment = ".environment",
                              name = ".name",
                              primitive = ".primitive",
                              weakref = ".weakref",
                              "NULL" = ".NULL",
                              bytecode = ".bytecode"
                              )

.addAbnormalDataType <- function(classes) {
  types <- match(classes, .AbnormalTypes, 0) > 0
  type = classes[types]
  if(length(type) == 0)
    return(classes)
  if(length(type) > 1)
    stop(gettextf("Class definition cannot extend more than one of these data types: %s", paste('"',type, '"', sep="", collapse = ", ")),
         domain = NA)
  class <- .indirectAbnormalClasses[type]
  if(is.na(class))
    stop(gettextf("Sorry, abnormal type \"%s\" is not supported as a superclass of a class definition", type),
         domain = NA)
  ## this message USED TO BE PRINTED: reminds programmers that
  ## they will see an unexpected superclass
  ## message(gettextf('Defining type "%s" as a superclass via class "%s"',
  ##                 type, class), domain = NA)
  c(class, classes[!types])
}

.checkRequiredGenerics <- function(Class, classDef, where) {}

..checkRequiredGenerics <- function(Class, classDef, where) {
  ## If any of the superclasses are in the .NeedPrimitiveMethods
  ## list, cache the corresponding generics now and also save their names in
  ## .requireCachedGenerics to be used when the environment
  ## where= is loaded.
  supers <- names(classDef@contains)
  allNeeded <- get(".NeedPrimitiveMethods", envir = .methodsNamespace)
  specials <- names(allNeeded)
  needed <- match(specials, supers, 0) > 0
  if(any(needed)) {
    generics <- unique(allNeeded[needed])
    packages <- character()
    for(g in generics) {
      def <- getGeneric(g)
      packages <- c(packages, def@package) # must be "methods" ?
      cacheGenericsMetaData(g, def, TRUE, where, def@package)
    }
    if(exists(".requireCachedGenerics",  where, inherits = FALSE))
      previous <- get(".requireCachedGenerics",  where)
    else
      previous <- character()
    packages <- c(attr(previous, "package"), packages)
    gg <- c(previous, generics)
    attr(gg, "package") <- packages
    assign(".requireCachedGenerics", gg, where)
  }
}

.setS3MethodsOn <- function(classDef) {
    ext <- extends(classDef)
    slots <- classDef@slots
    if(is.na(match(".S3Class", names(slots)))) {
        ## add the slot if it's not there
        slots$.S3Class <- getClass("oldClass")@slots$.S3Class
        classDef@slots <- slots
    }
    ## in any case give the prototype the full extends as .S3Class
    proto <- classDef@prototype
    if(is.null(proto)) # simple virtual class--unlikely but valid
        proto <- defaultPrototype()
    attr(proto, ".S3Class") <- ext
    classDef@prototype <- proto
    classDef
  }
