[load] read featurePropertyBag folder

This is used for checkboxes in MS365
JanMarvin · Dec 15, 2024 · ef09fae · ef09fae
1 parent e5c5ccf
commit ef09fae
Show file tree

Hide file tree

Showing 5 changed files with 75 additions and 11 deletions.
diff --git a/R/class-workbook.R b/R/class-workbook.R
@@ -206,6 +206,9 @@ wbWorkbook <- R6::R6Class(
     #' @field externalLinksRels externalLinksRels
     externalLinksRels = NULL,
 
+    #' @field featurePropertyBag featurePropertyBag
+    featurePropertyBag = NULL,
+
     #' @field headFoot The header and footer
     headFoot = NULL,
 
@@ -3348,6 +3351,19 @@ wbWorkbook <- R6::R6Class(
         }
       }
 
+      # featurePropertyBag
+      if (length(self$featurePropertyBag)) {
+        featurePropertyBagDir <- dir_create(tmpDir, "xl", "featurePropertyBag")
+
+        write_file(
+          body = self$featurePropertyBag,
+          fl = file.path(
+            featurePropertyBagDir,
+            sprintf("featurePropertyBag.xml")
+          )
+        )
+      }
+
       if (!is.null(self$richData)) {
         richDataDir <- dir_create(tmpDir, "xl", "richData")
         if (length(self$richData$richValueRel)) {
@@ -10102,6 +10118,15 @@ wbWorkbook <- R6::R6Class(
         )
       }
 
+      if (!is.null(self$featurePropertyBag)) {
+        self$append("workbook.xml.rels",
+          sprintf(
+            '<Relationship Id="rId%s" Type="http://schemas.microsoft.com/office/2022/11/relationships/FeaturePropertyBag" Target="featurePropertyBag/featurePropertyBag.xml"/>',
+            1L + length(self$workbook.xml.rels)
+          )
+        )
+      }
+
       ## Reassign rId to workbook sheet elements, (order sheets by sheetId first)
       self$workbook$sheets <-
         unapply(

diff --git a/R/wb_load.R b/R/wb_load.R
@@ -213,6 +213,9 @@ wb_load <- function(
   ## VBA Macro
   vbaProject        <- grep_xml("vbaProject\\.bin$")
 
+  ## feature property bag
+  featureProperty   <- grep_xml("featurePropertyBag.xml$")
+
   ## remove all EXCEPT media and charts
   on.exit(
     unlink(
@@ -227,10 +230,11 @@ wb_load <- function(
   known <- c(
     basename(xmlDir), "_rels", "activeX", "charts", "chartsheets",
     "ctrlProps", "customXml", "docMetadata", "docProps", "drawings",
-    "embeddings", "externalLinks", "media", "persons", "pivotCache",
-    "pivotTables", "printerSettings", "queryTables", "richData",
-    "slicerCaches", "slicers", "tables", "theme", "threadedComments",
-    "timelineCaches", "timelines", "worksheets", "xl", "[trash]"
+    "embeddings", "externalLinks", "featurePropertyBag", "media",
+    "persons", "pivotCache", "pivotTables", "printerSettings",
+    "queryTables", "richData", "slicerCaches", "slicers", "tables",
+    "theme", "threadedComments", "timelineCaches", "timelines",
+    "worksheets", "xl", "[trash]"
   )
   unknown <- file_folders[!file_folders %in% known]
   # nocov start
@@ -624,7 +628,7 @@ wb_load <- function(
   }
 
 
-  ## xl\sharedStrings
+  ## xl\metadata
   if (!data_only && length(metadataXML)) {
     wb$append(
       "Content_Types",
@@ -813,6 +817,14 @@ wb_load <- function(
     wb$externalLinksRels <- lapply(extLinksRelsXML, read_xml, pointer = FALSE)
   }
 
+  if (!data_only && length(featureProperty)) {
+    wb$append(
+      "Content_Types",
+      '<Override PartName="/xl/featurePropertyBag/featurePropertyBag.xml" ContentType="application/vnd.ms-excel.featurepropertybag+xml"/>'
+    )
+    wb$featurePropertyBag <- read_xml(featureProperty, pointer = FALSE)
+  }
+
 
   ##* ----------------------------------------------------------------------------------------------*##
   ### BEGIN READING IN WORKSHEET DATA

diff --git a/src/styles_xml.cpp b/src/styles_xml.cpp
@@ -119,7 +119,7 @@ Rcpp::DataFrame read_xf(XPtrXML xml_doc_xf) {
 
     // only handle known names
     // <alignment ...>
-    // <extLst ...> // FIXME should be imported as single node. most likely broken
+    // <extLst ...>
     // <protection ...>
     for (auto cld : xml_xf.children()) {
 
@@ -128,6 +128,14 @@ Rcpp::DataFrame read_xf(XPtrXML xml_doc_xf) {
       // check known names
       if (cld_name ==  "alignment" || cld_name == "extLst" || cld_name == "protection") {
 
+        if (cld_name == "extLst") {
+          R_xlen_t mtc = std::distance(nams.begin(), nams.find(cld_name));
+          uint32_t pugi_format_flags = pugi::format_raw;
+          std::ostringstream oss;
+          cld.print(oss, " ", pugi_format_flags);
+          Rcpp::as<Rcpp::CharacterVector>(df[mtc])[itr] = Rcpp::String(oss.str());
+        }
+
         for (auto attrs : cld.attributes()) {
           std::string attr_name = attrs.name();
           std::string attr_value = attrs.value();
@@ -229,9 +237,6 @@ Rcpp::CharacterVector write_xf(Rcpp::DataFrame df_xf) {
     has_extLst = has_it(df_xf, xf_nams_extLst, i);
 
     pugi::xml_node xf_extLst;
-    if (has_extLst) {
-      xf_extLst = xf.append_child("extLst");
-    }
 
     // check if protection node is required
     bool has_protection = false;
@@ -275,14 +280,19 @@ Rcpp::CharacterVector write_xf(Rcpp::DataFrame df_xf) {
         }
       }
 
-      // FIXME should be written as single node. most likely broken
       if (has_extLst && is_extLst) {
         Rcpp::CharacterVector cv_s = "";
         cv_s = Rcpp::as<Rcpp::CharacterVector>(df_xf[j])[i];
 
         if (cv_s[0] != "") {
           const std::string val_strl = Rcpp::as<std::string>(cv_s);
-          xf_extLst.append_attribute(attrnam.c_str()) = val_strl.c_str();
+          pugi::xml_document tempDoc;
+          pugi::xml_parse_result tempResult = tempDoc.load_string(val_strl.c_str());
+          if (tempResult) {
+            xf.append_copy(tempDoc.first_child());
+          } else {
+            Rcpp::stop("failed to load xf child `extLst`.");
+          }
         }
       }
 

diff --git a/tests/testthat/test-read_sources.R b/tests/testthat/test-read_sources.R
@@ -482,3 +482,11 @@ test_that("loading d3p1 file works", {
   expect_equal(exp, got)
 
 })
+
+test_that("loading file with featurePropertyBag works", {
+  fl  <- testfile_path("checkboxes.xlsx")
+  tmp <- temp_xlsx()
+
+  expect_silent(wb <- wb_load(fl))
+  expect_silent(wb$save(tmp))
+})
diff --git a/tests/testthat/test-styles_xml.R b/tests/testthat/test-styles_xml.R
@@ -164,3 +164,12 @@ test_that("colors", {
   )
 
 })
+
+test_that("reading xf node extLst works", {
+  xml <- "<xf borderId=\"0\" fillId=\"0\" fontId=\"0\" numFmtId=\"0\" xfId=\"0\"><extLst><ext><foo/></ext></extLst></xf>"
+  xf  <- read_xml(xml)
+
+  df_xf <- read_xf(xml_doc_xf = xf)
+  got   <- write_xf(df_xf)
+  all.equal(xml, got)
+})