R/filehash-DB1.R

   1 ######################################################################
   2 ## Copyright (C) 2006, Roger D. Peng <rpeng@jhsph.edu>
   3 ##
   4 ## This program is free software; you can redistribute it and/or modify
   5 ## it under the terms of the GNU General Public License as published by
   6 ## the Free Software Foundation; either version 2 of the License, or
   7 ## (at your option) any later version.
   8 ##
   9 ## This program is distributed in the hope that it will be useful,
  10 ## but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 ## GNU General Public License for more details.
  13 ##
  14 ## You should have received a copy of the GNU General Public License
  15 ## along with this program; if not, write to the Free Software
  16 ## Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  17 ## 02110-1301, USA
  18 #####################################################################
  19
  20 ######################################################################
  21 ## Class 'filehashDB1'
  22
  23 ## Database entries
  24 ##
  25 ## File format: [key]        [nbytes data] [data]
  26 ##              serialized   serialized    raw bytes (serialized)
  27 ##
  28
  29 ######################################################################
  30
  31 ## 'meta' is a list with an element called 'metaEnv'.  'metaEnv' is an
  32 ## environment that contains metadata for the database.
  33
  34 setClass("filehashDB1",
  35          representation(datafile = "character",
  36                         meta = "list"),  ## contains 'metaEnv' element
  37          contains = "filehash"
  38          )
  39
  40 setValidity("filehashDB1",
  41             function(object) {
  42                     if(!file.exists(object@datafile))
  43                             return(gettextf("datafile '%s' does not exist",
  44                                             datafile))
  45                     if(is.null(object@meta$metaEnv))
  46                             return(gettextf("object is missing 'metaEnv' element"))
  47                     TRUE
  48             })
  49
  50 createDB1 <- function(dbName) {
  51         if(!hasWorkingFtell())
  52                 stop("need working 'ftell()' to use 'DB1' format")
  53         if(file.exists(dbName)) {
  54                 message(gettextf("database '%s' already exists", dbName))
  55                 return(TRUE)
  56         }
  57         status <- file.create(dbName)
  58
  59         if(!status)
  60                 stop(gettextf("unable to create database file '%s'", dbName))
  61         TRUE
  62 }
  63
  64 makeMetaEnv <- function(filename) {
  65         ## Create database map and store in environment.  Don't read map
  66         ## until you need it; for example, it's not needed for *writing*
  67         ## to the database.
  68         metaEnv <- new.env(parent = emptyenv())
  69         metaEnv$map <- NULL  ## 'NULL' indicates the map needs to be read
  70         metaEnv$dbfilesize <- file.info(filename)$size
  71
  72         metaEnv
  73 }
  74
  75 initializeDB1 <- function(dbName) {
  76         if(!hasWorkingFtell())
  77                 stop("need working 'ftell()' to use DB1 format")
  78         dbName <- normalizePath(dbName)
  79
  80         new("filehashDB1",
  81             datafile = dbName,
  82             meta = list(metaEnv = makeMetaEnv(dbName)),
  83             name = basename(dbName)
  84             )
  85 }
  86
  87
  88 readKeyMap <- function(con, map = NULL, pos = 0) {
  89         if(is.null(map)) {
  90                 ## using 'hash = TRUE' is critical because it can have a major
  91                 ## impact on performance for large databases
  92                 map <- new.env(hash = TRUE, parent = emptyenv())
  93                 pos <- 0
  94         }
  95         if(pos < 0)
  96                 stop("'pos' cannot be negative")
  97         filename <- path.expand(summary(con)$description)
  98         filesize <- file.info(filename)$size
  99
 100         if(pos > filesize)
 101                 stop("'pos' cannot be greater than file size")
 102         .Call("read_key_map", filename, map, filesize, pos)
 103 }
 104
 105 readSingleKey <- function(con, map, key) {
 106         start <- map[[key]]
 107
 108         if(is.null(start))
 109                 stop(gettextf("unable to obtain value for key '%s'", key))
 110
 111         seek(con, start, rw = "read")
 112         unserialize(con)
 113 }
 114
 115 readKeys <- function(con, map, keys) {
 116         r <- lapply(keys, function(key) readSingleKey(con, map, key))
 117         names(r) <- keys
 118         r
 119 }
 120
 121 gotoEndPos <- function(con) {
 122         ## Move connection to the end
 123         seek(con, 0, "end")
 124         seek(con)
 125 }
 126
 127 writeNullKeyValue <- function(con, key) {
 128         writestart <- gotoEndPos(con)
 129
 130         handler <- function(cond) {
 131                 ## Rewind the file back to where writing began and truncate at
 132                 ## that position
 133                 seek(con, writestart, "start", "write")
 134                 truncate(con)
 135                 cond
 136         }
 137         if(!createLockFile(con))
 138                 stop("cannot create lock file")
 139         tryCatch({
 140                 serialize(key, con)
 141
 142                 len <- as.integer(-1)
 143                 serialize(len, con)
 144         }, interrupt = handler, error = handler, finally = {
 145                 flush(con)
 146                 deleteLockFile(con)
 147         })
 148 }
 149
 150 writeKeyValue <- function(con, key, value) {
 151         writestart <- gotoEndPos(con)
 152
 153         handler <- function(cond) {
 154                 ## Rewind the file back to where writing began and
 155                 ## truncate at that position; this is probably a bad
 156                 ## idea for files > 2GB
 157                 seek(con, writestart, "start", "write")
 158                 truncate(con)
 159                 cond
 160         }
 161         if(!createLockFile(con))
 162                 stop("cannot create lock file")
 163         tryCatch({
 164                 serialize(key, con)
 165
 166                 byteData <- serialize(value, NULL)
 167                 len <- length(byteData)
 168                 serialize(len, con)
 169
 170                 writeBin(byteData, con)
 171         }, interrupt = handler, error = handler, finally = {
 172                 flush(con)
 173                 deleteLockFile(con)
 174         })
 175 }
 176
 177 lockFileName <- function(con) {
 178         ## Use 3 underscores for lock file
 179         sprintf("%s___LOCK", summary(con)$description)
 180 }
 181
 182 createLockFile <- function(con) {
 183         status <- .Call("lock_file", lockFileName(con))
 184         isTRUE(status >= 0)
 185 }
 186
 187 deleteLockFile <- function(con) {
 188         lockfile <- lockFileName(con)
 189         file.remove(lockfile)
 190 }
 191
 192 ######################################################################
 193 ## Internal utilities
 194
 195 filesize <- gotoEndPos
 196
 197 setGeneric("checkMap", function(db, ...) standardGeneric("checkMap"))
 198
 199 setMethod("checkMap", "filehashDB1",
 200           function(db, filecon, ...) {
 201                   old.size <- get("dbfilesize", db@meta$metaEnv)
 202                   cur.size <- tryCatch({
 203                           filesize(filecon)
 204                   }, error = function(err) {
 205                           old.size
 206                   })
 207                   size.change <- old.size != cur.size
 208                   map.orig <- getMap(db)
 209
 210                   map <- if(is.null(map.orig))
 211                           readKeyMap(filecon)
 212                   else if(size.change)
 213                           readKeyMap(filecon, map.orig, old.size)
 214                   else
 215                           map.orig
 216                   if(!identical(map, map.orig)) {
 217                           assign("map", map, db@meta$metaEnv)
 218                           assign("dbfilesize", cur.size, db@meta$metaEnv)
 219                   }
 220                   invisible(db)
 221           })
 222
 223
 224 setGeneric("getMap", function(db) standardGeneric("getMap"))
 225
 226 setMethod("getMap", "filehashDB1",
 227           function(db) {
 228                   get("map", db@meta$metaEnv)
 229           })
 230
 231 ######################################################################
 232 ## Interface functions
 233
 234 setMethod("dbInsert",
 235           signature(db = "filehashDB1", key = "character", value = "ANY"),
 236           function(db, key, value, ...) {
 237                   filecon <- try(file(db@datafile, "ab"), silent = TRUE)
 238
 239                   if(inherits(filecon, "try-error"))
 240                           stop("unable to open connection to database")
 241                   on.exit(close(filecon))
 242                   writeKeyValue(filecon, key, value)
 243           })
 244
 245 setMethod("dbFetch",
 246           signature(db = "filehashDB1", key = "character"),
 247           function(db, key, ...) {
 248                   filecon <- try(file(db@datafile, "rb"), silent = TRUE)
 249
 250                   if(inherits(filecon, "try-error"))
 251                           stop("unable to open connection to database")
 252                   on.exit(close(filecon))
 253
 254                   checkMap(db, filecon)
 255                   map <- getMap(db)
 256
 257                   r <- readKeys(filecon, map, key[1])
 258                   r[[1]]
 259           })
 260
 261 setMethod("dbMultiFetch",
 262           signature(db = "filehashDB1", key = "character"),
 263           function(db, key, ...) {
 264                   filecon <- file(db@datafile, "rb")
 265                   on.exit(close(filecon))
 266
 267                   checkMap(db, filecon)
 268                   map <- getMap(db)
 269
 270                   readKeys(filecon, map, key)
 271           })
 272
 273 setMethod("[", signature(x = "filehashDB1", i = "character", j = "missing",
 274                          drop = "missing"),
 275           function(x, i , j, drop) {
 276                   dbMultiFetch(x, i)
 277           })
 278
 279 setMethod("dbExists", signature(db = "filehashDB1", key = "character"),
 280           function(db, key, ...) {
 281                   dbkeys <- dbList(db)
 282                   key %in% dbkeys
 283           })
 284
 285 setMethod("dbList", "filehashDB1",
 286           function(db, ...) {
 287                   filecon <- file(db@datafile, "rb")
 288                   on.exit(close(filecon))
 289
 290                   checkMap(db, filecon)
 291                   map <- getMap(db)
 292
 293                   if(length(map) == 0)
 294                           character(0)
 295                   else {
 296                           keys <- as.list(map, all.names = TRUE)
 297                           use <- !sapply(keys, is.null)
 298                           names(keys[use])
 299                   }
 300           })
 301
 302 setMethod("dbDelete", signature(db = "filehashDB1", key = "character"),
 303           function(db, key, ...) {
 304                   filecon <- file(db@datafile, "ab")
 305                   on.exit(close(filecon))
 306
 307                   writeNullKeyValue(filecon, key)
 308           })
 309
 310 setMethod("dbUnlink", "filehashDB1",
 311           function(db, ...) {
 312                   file.remove(db@datafile)
 313           })
 314
 315 reorganizeDB <- function(db, ...) {
 316         datafile <- db@datafile
 317
 318         ## Find a temporary file name
 319         tempdata <- paste(datafile, "Tmp", sep = "")
 320         i <- 0
 321         while(file.exists(tempdata)) {
 322                 i <- i + 1
 323                 tempdata <- paste(datafile, "Tmp", i, sep = "")
 324         }
 325         if(!dbCreate(tempdata, type = "DB1")) {
 326                 warning("could not create temporary database")
 327                 return(FALSE)
 328         }
 329         on.exit(file.remove(tempdata))
 330
 331         tempdb <- dbInit(tempdata, type = "DB1")
 332         keys <- dbList(db)
 333
 334         ## Copy all keys to temporary database
 335         nkeys <- length(keys)
 336         cat("Reorganizing database: ")
 337
 338         for(i in seq_along(keys)) {
 339                 key <- keys[i]
 340                 msg <- sprintf("%d%% (%d/%d)", round (100 * i / nkeys),
 341                                i, nkeys)
 342                 cat(msg)
 343
 344                 dbInsert(tempdb, key, dbFetch(db, key))
 345
 346                 back <- paste(rep("\b", nchar(msg)), collapse = "")
 347                 cat(back)
 348         }
 349         cat("\n")
 350         status <- file.rename(tempdata, datafile)
 351
 352         if(!isTRUE(status)) {
 353                 on.exit()
 354                 warning("temporary database could not be renamed and is left in ",
 355                         tempdata)
 356                 return(FALSE)
 357         }
 358         on.exit()
 359         message("Finished; reload database with 'dbInit'")
 360         TRUE
 361 }
 362
 363 setMethod("dbReorganize", "filehashDB1", reorganizeDB)
 364
 365
 366 ################################################################################
 367 ## Test system's ftell()
 368
 369 hasWorkingFtell <- function() {
 370         tfile <- tempfile()
 371         con <- file(tfile, "wb")
 372
 373         tryCatch({
 374                 bytes <- raw(10)
 375                 begin <- seek(con)
 376
 377                 if(begin != 0)
 378                         return(FALSE)
 379                 writeBin(bytes, con)
 380                 end <- seek(con)
 381                 offset <- end - begin
 382                 isTRUE(offset == 10)
 383         }, finally = {
 384                 close(con)
 385                 unlink(tfile)
 386         })
 387 }
 388
 389 ######################################################################
 390
 391