Merge remote-tracking branch 'tmp/attribute-references' into object-r…

…eferences

R/H5A.R

@@ -236,7 +236,11 @@ H5Aread <- function(h5attribute, buf = NULL, bit64conversion) {
       stop("install package 'bit64' before using bit64conversion='bit64'")
   }
 
-  return(.Call("_H5Aread", h5attribute@ID, buf, bit64conv, PACKAGE='rhdf5'))
+  rval = .Call("_H5Aread", h5attribute@ID, buf, bit64conv, PACKAGE='rhdf5')
+  if (is(rval, "H5IdComponent"))
+    rval@native <- h5attribute@native
+
+  return(rval)
 }
 
 #' Write data to an HDF5 attribute

R/h5create.R

@@ -527,6 +527,7 @@ h5createAttribute <- function(obj, attr, dims, maxdims = dims, file,
                               H5Tset_size(tid, size) # NULL = variable.
                               tid
                           },
+                          H5IdComponent=h5constants$H5T["H5T_STD_REF_OBJ"],
                           { stop("datatype ",storage.mode," not yet implemented. Try 'double', 'integer', or 'character'.") } )
         } else {
             stop("Can not create dataset. 'storage.mode' has to be a character.")

R/h5writeAttr.R

@@ -17,7 +17,10 @@
 #' @export
 h5writeAttribute <- function(attr, h5obj, name, cset=c("ASCII", "UTF8"), variableLengthString=FALSE, asScalar=FALSE) {
   h5checktype(h5obj, "object")
-  res <- UseMethod("h5writeAttribute")
+  if (is(attr, "H5IdComponent"))
+    res <- h5writeAttribute.array(attr, h5obj, name, asScalar=TRUE)
+  else
+    res <- UseMethod("h5writeAttribute")
   invisible(res)
 }
 
@@ -56,7 +59,10 @@ h5writeAttribute.array <- function(attr, h5obj, name, cset=c("ASCII", "UTF8"), v
   if (H5Aexists(h5obj, name)) {
     H5Adelete(h5obj, name)
   }
-  h5createAttribute(h5obj, name, dims = dims, storage.mode = storage.mode(attr), size = size, cset=match.arg(cset))
+  storagemode <- storage.mode(attr)
+  if (storagemode == "S4" && is(attr, "H5IdComponent"))
+    storagemode <- "H5IdComponent"
+  h5createAttribute(h5obj, name, dims = dims, storage.mode = storagemode, size = size, cset=match.arg(cset))
   h5attr <- H5Aopen(h5obj, name)
 
   DimMem <- dim(attr)

src/H5A.c

@@ -272,6 +272,25 @@ SEXP H5Aread_helper_STRING(hid_t attr_id, hsize_t n, SEXP Rdim, SEXP _buf, hid_t
   return(Rval);
 }
 
+SEXP H5Aread_helper_REFERENCE(hid_t attr_id, hsize_t n, SEXP Rdim, SEXP _buf, hid_t dtype_id) {
+    hobj_ref_t references[n];
+    herr_t err = H5Aread(attr_id, dtype_id, &references);
+    if (err < 0) {
+        error("could not read attribute");
+        return R_NilValue;
+    }
+    if (!H5Tequal(dtype_id, H5T_STD_REF_OBJ)) {
+        error("Reading references of type %s is not yet implemented", getReferenceType(dtype_id));
+        return R_NilValue;
+    }
+    hid_t obj = H5Rdereference2(attr_id, H5P_DEFAULT, H5R_OBJECT, &references);
+    SEXP hid = PROTECT(HID_2_STRSXP(obj));
+    SEXP Rval = PROTECT(R_do_new_object(R_getClassDef("H5IdComponent")));
+    R_do_slot_assign(Rval, mkString("ID"), hid);
+    UNPROTECT(2);
+    return Rval;
+}
+
 /* SEXP H5Dread_helper_COMPOUND(hid_t dataset_id, hid_t file_space_id, hid_t mem_space_id, hsize_t n, SEXP Rdim, SEXP _buf,  */
 /* 			    hid_t dtype_id, hid_t cpdType, int cpdNField, char ** cpdField, int compoundAsDataFrame ) { */
 /*   hid_t mem_type_id = -1; */
@@ -352,14 +371,16 @@ SEXP H5Aread_helper(hid_t attr_id, hsize_t n, SEXP Rdim, SEXP _buf, int bit64con
   case H5T_STRING: {
     Rval = H5Aread_helper_STRING(attr_id, n, Rdim, _buf, dtype_id);
   } break;
+  case H5T_REFERENCE: {
+    Rval = H5Aread_helper_REFERENCE(attr_id, n, Rdim, _buf, dtype_id);
+  } break;
   case H5T_COMPOUND:
  /* { */
  /*    Rval = H5Aread_helper_COMPOUND(attr_id, n, Rdim, _buf, dtype_id); */
  /*  } break; */
   case H5T_TIME:
   case H5T_BITFIELD:
   case H5T_OPAQUE:
-  case H5T_REFERENCE:
   case H5T_ENUM:
   case H5T_VLEN:
   case H5T_ARRAY:
@@ -438,57 +459,73 @@ SEXP _H5Aread( SEXP _attr_id, SEXP _buf, SEXP _bit64conversion ) {
 
 /* herr_t H5Awrite(hid_t attr_id, hid_t mem_type_id, const void *buf ) */
 SEXP _H5Awrite( SEXP _attr_id, SEXP _buf) {
-  hid_t attr_id = STRSXP_2_HID( _attr_id );
-  hid_t mem_type_id;
+    hid_t attr_id = STRSXP_2_HID( _attr_id );
+    hid_t mem_type_id;
 
-  const void * buf;
-  if (TYPEOF(_buf) == INTSXP) {
-    mem_type_id = H5T_NATIVE_INT;
-    buf = INTEGER(_buf);
-  } else {
-    if (TYPEOF(_buf) == REALSXP) {
-      mem_type_id = H5T_NATIVE_DOUBLE;
-      buf = REAL(_buf);
-    } else {
-      if (TYPEOF(_buf) == STRSXP) {
+    const void * buf;
+    static const char* classname[] = {"H5IdComponent", ""};
+    if (TYPEOF(_buf) == INTSXP) {
+        mem_type_id = H5T_NATIVE_INT;
+        buf = INTEGER(_buf);
+    } else if (TYPEOF(_buf) == REALSXP) {
+        mem_type_id = H5T_NATIVE_DOUBLE;
+        buf = REAL(_buf);
+    } else if (TYPEOF(_buf) == STRSXP) {
         mem_type_id = H5Aget_type(attr_id);
         size_t stsize;
         if (H5Tis_variable_str(mem_type_id)) {
-          const char ** strbuf = (const char **)R_alloc(LENGTH(_buf),sizeof(const char*));
-          for (int i=0; i < LENGTH(_buf); i++) {
+            const char ** strbuf = (const char **)R_alloc(LENGTH(_buf),sizeof(const char*));
+            for (int i=0; i < LENGTH(_buf); i++) {
             strbuf[i] = CHAR(STRING_ELT(_buf,i));
-          }
-          buf = strbuf;
+            }
+            buf = strbuf;
         } else {
-          stsize = H5Tget_size( mem_type_id );
-          char * strbuf = (char *)R_alloc(LENGTH(_buf),stsize);
-          int z=0;
-          int j;
-          for (int i=0; i < LENGTH(_buf); i++) {
+            stsize = H5Tget_size( mem_type_id );
+            char * strbuf = (char *)R_alloc(LENGTH(_buf),stsize);
+            int z=0;
+            int j;
+            for (int i=0; i < LENGTH(_buf); i++) {
             for (j=0; (j < LENGTH(STRING_ELT(_buf,i))) & (j < (stsize-1)); j++) {
-              strbuf[z++] = CHAR(STRING_ELT(_buf,i))[j];
+                strbuf[z++] = CHAR(STRING_ELT(_buf,i))[j];
             }
             for (; j < stsize; j++) {
-              strbuf[z++] = '\0';
+                strbuf[z++] = '\0';
             }
-          }
-          buf = strbuf;
+            }
+            buf = strbuf;
         }
-      } else {
-	mem_type_id = -1;
-	warning("Writing of this type of attribute data not supported.");
-	SEXP Rval = R_NilValue;
-	return Rval;
-      }
+    } else if (TYPEOF(_buf) == S4SXP && R_check_class_etc(_buf, classname) >= 0) {
+        SEXP _obj_id = R_do_slot(_buf, mkString("ID"));
+        hid_t obj_id = STRSXP_2_HID(_obj_id);
+        ssize_t namelength = H5Iget_name(obj_id, NULL, 0);
+        if (namelength > 0) {
+            char *name = R_alloc(sizeof(char), namelength + 1);
+            namelength = H5Iget_name(obj_id, name, namelength + 1);
+            hobj_ref_t *ref = (hobj_ref_t*)R_alloc(sizeof(hobj_ref_t), 1);
+            herr_t err = H5Rcreate(ref, obj_id, name, H5R_OBJECT, -1);
+            if (err < 0) {
+                error("Could not create reference to object.");
+                return R_NilValue;
+            }
+            mem_type_id = H5T_STD_REF_OBJ;
+            buf = ref;
+        } else {
+            error("Object has no name, cannot create a reference");
+            return R_NilValue;
+        }
+    } else {
+        error("Writing of this type of attribute data not supported.");
+        SEXP Rval = R_NilValue;
+        return Rval;
     }
-  }
-  herr_t herr = 3;
-  herr = H5Awrite(attr_id, mem_type_id, buf );
-  SEXP Rval;
-  PROTECT(Rval = allocVector(INTSXP, 1));
-  INTEGER(Rval)[0] = herr;
-  UNPROTECT(1);
-  return Rval;
+
+    herr_t herr = 3;
+    herr = H5Awrite(attr_id, mem_type_id, buf );
+    SEXP Rval;
+    PROTECT(Rval = allocVector(INTSXP, 1));
+    INTEGER(Rval)[0] = herr;
+    UNPROTECT(1);
+    return Rval;
 }
 
 /* ssize_t H5Aget_name(hid_t attr_id, size_t buf_size, char *buf ) */

src/H5constants.c

@@ -97,7 +97,7 @@ SEXP _H5constants( ) {
   const char *name_H5S_SELECT[] = { "H5S_SELECT_SET", "H5S_SELECT_OR", "H5S_SELECT_AND", "H5S_SELECT_XOR", "H5S_SELECT_NOTB", "H5S_SELECT_NOTA"};
   addVector_int(i++, Rval, groupnames, "H5S_SELECT", 6, const_H5S_SELECT, name_H5S_SELECT);
 
-  hid_t const_H5T[79]       = {  H5T_IEEE_F32BE,   H5T_IEEE_F32LE,   H5T_IEEE_F64BE,   H5T_IEEE_F64LE,   
+  hid_t const_H5T[]       = {  H5T_IEEE_F32BE,   H5T_IEEE_F32LE,   H5T_IEEE_F64BE,   H5T_IEEE_F64LE,
 			       H5T_STD_I8BE,    H5T_STD_I8LE,    H5T_STD_I16BE,   H5T_STD_I16LE,   
 			       H5T_STD_I32BE,   H5T_STD_I32LE,   H5T_STD_I64BE,   H5T_STD_I64LE,   
 			       H5T_STD_U8BE,    H5T_STD_U8LE,    H5T_STD_U16BE,   H5T_STD_U16LE,   
@@ -117,7 +117,8 @@ SEXP _H5constants( ) {
 			       H5T_NATIVE_INT32, H5T_NATIVE_UINT32, H5T_NATIVE_INT_LEAST32, H5T_NATIVE_UINT_LEAST32, H5T_NATIVE_INT_FAST32, H5T_NATIVE_UINT_FAST32,
 			       H5T_NATIVE_INT64, H5T_NATIVE_UINT64, H5T_NATIVE_INT_LEAST64, H5T_NATIVE_UINT_LEAST64, H5T_NATIVE_INT_FAST64, H5T_NATIVE_UINT_FAST64,
 			       H5T_NATIVE_DOUBLE,
-			       H5T_C_S1, H5T_FORTRAN_S1 };
+			       H5T_C_S1, H5T_FORTRAN_S1,
+                   H5T_STD_REF_OBJ, H5T_STD_REF_DSETREG };
 			      /* H5T_UNIX_D32BE,  H5T_UNIX_D32LE,  H5T_UNIX_D64BE,  H5T_UNIX_D64LE, */
 			      /* H5T_C_S1, H5T_FORTRAN_S1, */
 			      /* H5T_INTEL_I8,    H5T_INTEL_I16,   H5T_INTEL_I32,   H5T_INTEL_I64, */
@@ -154,7 +155,8 @@ SEXP _H5constants( ) {
 			     "H5T_NATIVE_INT32", "H5T_NATIVE_UINT32", "H5T_NATIVE_INT_LEAST32", "H5T_NATIVE_UINT_LEAST32", "H5T_NATIVE_INT_FAST32", "H5T_NATIVE_UINT_FAST32",
 			     "H5T_NATIVE_INT64", "H5T_NATIVE_UINT64", "H5T_NATIVE_INT_LEAST64", "H5T_NATIVE_UINT_LEAST64", "H5T_NATIVE_INT_FAST64", "H5T_NATIVE_UINT_FAST64",
 			     "H5T_NATIVE_DOUBLE",
-			     "H5T_C_S1", "H5T_FORTRAN_S1" };
+			     "H5T_C_S1", "H5T_FORTRAN_S1",
+                 "H5T_STD_REF_OBJ", "H5T_STD_REF_DSETREG" };
 
 			     /* "H5T_UNIX_D32BE", "H5T_UNIX_D32LE", "H5T_UNIX_D64BE", "H5T_UNIX_D64LE", */
 			     /* "H5T_INTEL_I8", "H5T_INTEL_I16", "H5T_INTEL_I32", "H5T_INTEL_I64", */
@@ -171,7 +173,7 @@ SEXP _H5constants( ) {
 			     /* "H5T_MIPS_U8", "H5T_MIPS_U16", "H5T_MIPS_U32", "H5T_MIPS_U64", */
 			     /* "H5T_MIPS_F32", "H5T_MIPS_F64" */
 
-  addVector_hid(i++, Rval, groupnames, "H5T", 79, const_H5T, name_H5T);
+  addVector_hid(i++, Rval, groupnames, "H5T", 81, const_H5T, name_H5T);
   /* There are more platform specific datatypes */
 
   int const_H5T_CLASS[11]      = {  H5T_INTEGER,   H5T_FLOAT,   H5T_TIME,   H5T_STRING,   H5T_BITFIELD,   H5T_OPAQUE,   H5T_COMPOUND,   H5T_REFERENCE,   H5T_ENUM,   H5T_VLEN,   H5T_ARRAY };

src/printdatatype.c

@@ -462,6 +462,17 @@ getDatatypeClass(hid_t type) {
   return(name);
 }
 
+char* getReferenceType(hid_t ref_type) {
+    char *name = NULL;
+    if (H5Tequal(ref_type, H5T_STD_REF_DSETREG))
+        name = "DATASET_REGION";
+    else if (H5Tequal(ref_type, H5T_STD_REF_OBJ))
+        name = "OBJECT";
+    else
+        name = "unknown";
+    return name;
+}
+
 SEXP _getDatatypeName(SEXP _type) {
   hid_t type = STRSXP_2_HID( _type );
   SEXP Rval = mkString(getDatatypeName(type));

src/printdatatype.h

@@ -10,6 +10,7 @@
 
 char* getDatatypeName(hid_t type);
 char* getDatatypeClass(hid_t type);
+char* getReferenceType(hid_t ref_type);
 
 SEXP _getDatatypeName(SEXP _type);
 SEXP _getDatatypeClass(SEXP _type);