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", datafile))
  44                 if(is.null(object@meta$metaEnv))
  45                     return(gettextf("object is missing 'metaEnv' element"))
  46                 TRUE
  47             })
  48
  49 createDB1 <- function(dbName) {
  50     if(!hasWorkingFtell())
  51         stop("need working 'ftell()' to use DB1 format")
  52     if(!file.exists(dbName))
  53         file.create(dbName)
  54     else
  55         message(gettextf("database '%s' already exists", dbName))
  56     TRUE
  57 }
  58
  59 makeMetaEnv <- function(filename) {
  60     ## Create database map and store in environment.  Don't read map
  61     ## until you need it; for example, it's not needed for *writing*
  62     ## to the database.
  63     metaEnv <- new.env(parent = emptyenv())
  64     metaEnv$map <- NULL  ## 'NULL' indicates the map needs to be read
  65     metaEnv$dbfilesize <- file.info(filename)$size
  66
  67     metaEnv
  68 }
  69
  70 initializeDB1 <- function(dbName) {
  71     if(!hasWorkingFtell())
  72         stop("need working 'ftell()' to use DB1 format")
  73     dbName <- normalizePath(dbName)
  74
  75     new("filehashDB1",
  76         datafile = dbName,
  77         meta = list(metaEnv = makeMetaEnv(dbName)),
  78         name = basename(dbName)
  79         )
  80 }
  81
  82
  83 findEndPos <- function(con) {
  84     seek(con, 0, "end")
  85     seek(con)
  86 }
  87
  88 readKeyMap <- function(con, map = NULL, pos = 0) {
  89     if(is.null(map)) {
  90         map <- new.env(hash = TRUE, parent = emptyenv())
  91         pos <- 0
  92     }
  93     seek(con, pos, "start", "read")
  94     status <- NULL
  95
  96     while(!inherits(status, "condition")) {
  97         status <- tryCatch({
  98             key <- unserialize(con)
  99             datalen <- unserialize(con)
 100             pos <- seek(con, rw = "read")  ## Update position
 101
 102             if(datalen > 0) {
 103                 ## Negative values of 'datalen' indicate deleted keys so only
 104                 ## record positive 'datalen' values
 105                 map[[key]] <- pos
 106
 107                 ## Fast forward to the next key
 108                 seek(con, datalen, "current", "read")
 109                 pos <- pos + datalen
 110             }
 111             else {
 112                 ## Key is deleted; there is no data after it
 113                 if(exists(key, map, inherits = FALSE))
 114                     remove(list = key, pos = map)
 115             }
 116             NULL
 117         }, error = function(err) {
 118             err
 119         })
 120     }
 121     map
 122 }
 123
 124 convertDB1 <- function(old, new) {
 125     dbCreate(new, "DB1")
 126     newdb <- dbInit(new, "DB1")
 127
 128     con <- file(old, "rb")
 129     on.exit(close(con))
 130
 131     endpos <- findEndPos(con)
 132     pos <- 0
 133
 134     while(pos < endpos) {
 135         keylen <- readBin(con, "numeric", endian = "little")
 136         key <- rawToChar(readBin(con, "raw", keylen))
 137         datalen <- readBin(con, "numeric", endian = "little")
 138         value <- unserialize(con)
 139
 140         dbInsert(newdb, key, value)
 141         pos <- seek(con)
 142     }
 143     newdb
 144 }
 145
 146 readSingleKey <- function(con, map, key) {
 147     start <- map[[key]]
 148
 149     if(is.null(start))
 150         stop(gettextf("'%s' not in database", key))
 151
 152     seek(con, start, rw = "read")
 153     unserialize(con)
 154 }
 155
 156 readKeys <- function(con, map, keys) {
 157     r <- lapply(keys, function(key) readSingleKey(con, map, key))
 158     names(r) <- keys
 159     r
 160 }
 161
 162 writeNullKeyValue <- function(con, key) {
 163     writestart <- findEndPos(con)
 164
 165     handler <- function(cond) {
 166         ## Rewind the file back to where writing began and truncate at
 167         ## that position
 168         seek(con, writestart, "start", "write")
 169         truncate(con)
 170         cond
 171     }
 172     repeat {
 173         if(!isLocked(con)) {
 174             createLockFile(con)
 175
 176             tryCatch({
 177                 writeKey(con, key)
 178
 179                 len <- as.integer(-1)
 180                 serialize(len, con)
 181             }, interrupt = handler, error = handler, finally = {
 182                 flush(con)
 183                 deleteLockFile(con)
 184             })
 185             break
 186         }
 187         else
 188             next
 189     }
 190 }
 191
 192 writeKey <- function(con, key) {
 193     ## Write out key
 194     serialize(key, con)
 195 }
 196
 197 writeKeyValue <- function(con, key, value) {
 198     writestart <- findEndPos(con)
 199
 200     handler <- function(cond) {
 201         ## Rewind the file back to where writing began and truncate at
 202         ## that position; this is probably a bad idea for files > 2GB
 203         seek(con, writestart, "start", "write")
 204         truncate(con)
 205         cond
 206     }
 207     repeat {
 208         if(!isLocked(con)) {
 209             createLockFile(con)
 210
 211             tryCatch({
 212                 writeKey(con, key)
 213
 214                 ## Serialize data to raw bytes
 215                 byteData <- serialize(value, NULL)
 216
 217                 ## Write out length of data
 218                 len <- length(byteData)
 219                 serialize(len, con)
 220
 221                 ## Write out data
 222                 writeBin(byteData, con)
 223             }, interrupt = handler, error = handler, finally = {
 224                 flush(con)
 225                 deleteLockFile(con)
 226             })
 227             break
 228         }
 229         else
 230             next
 231     }
 232 }
 233
 234 lockFileName <- function(con) {
 235     ## Use 3 underscores for lock file
 236     paste(summary(con)$description, "LOCK", sep = "___")
 237 }
 238
 239 createLockFile <- function(con) {
 240     lockfile <- lockFileName(con)
 241     file.create(lockfile)
 242 }
 243
 244 deleteLockFile <- function(con) {
 245     if(isLocked(con)) {
 246         lockfile <- lockFileName(con)
 247         file.remove(lockfile)
 248     }
 249 }
 250
 251 isLocked <- function(con) {
 252     lockfile <- lockFileName(con)
 253     isTRUE( file.exists(lockfile) )
 254 }
 255
 256 ######################################################################
 257 ## Internal utilities
 258
 259 filesize <- findEndPos
 260
 261 setGeneric("checkMap", function(db, ...) standardGeneric("checkMap"))
 262
 263 setMethod("checkMap", "filehashDB1",
 264           function(db, filecon, ...) {
 265               old.size <- get("dbfilesize", db@meta$metaEnv)
 266               cur.size <- tryCatch({
 267                   filesize(filecon)
 268               }, error = function(err) {
 269                   old.size
 270               })
 271               size.change <- old.size != cur.size
 272               map.orig <- getMap(db)
 273
 274               map <- if(is.null(map.orig))
 275                   readKeyMap(filecon)
 276               else if(size.change)
 277                   readKeyMap(filecon, map.orig, old.size)
 278               else
 279                   map.orig
 280
 281               if(!identical(map, map.orig)) {
 282                   assign("map", map, db@meta$metaEnv)
 283                   assign("dbfilesize", cur.size, db@meta$metaEnv)
 284               }
 285               invisible(db)
 286           })
 287
 288
 289 setGeneric("getMap", function(db) standardGeneric("getMap"))
 290
 291 setMethod("getMap", "filehashDB1",
 292           function(db) {
 293               get("map", db@meta$metaEnv)
 294           })
 295
 296 ######################################################################
 297 ## Interface functions
 298
 299 setMethod("dbInsert",
 300           signature(db = "filehashDB1", key = "character", value = "ANY"),
 301           function(db, key, value, ...) {
 302               filecon <- file(db@datafile, "ab")
 303               on.exit(close(filecon))
 304               writeKeyValue(filecon, key, value)
 305           })
 306
 307 setMethod("dbFetch",
 308           signature(db = "filehashDB1", key = "character"),
 309           function(db, key, ...) {
 310               filecon <- file(db@datafile, "rb")
 311               on.exit(close(filecon))
 312
 313               checkMap(db, filecon)
 314               map <- getMap(db)
 315
 316               r <- readKeys(filecon, map, key[1])
 317               r[[1]]
 318           })
 319
 320 setMethod("dbMultiFetch",
 321           signature(db = "filehashDB1", key = "character"),
 322           function(db, key, ...) {
 323               filecon <- file(db@datafile, "rb")
 324               on.exit(close(filecon))
 325
 326               checkMap(db, filecon)
 327               map <- getMap(db)
 328
 329               readKeys(filecon, map, key)
 330           })
 331
 332 setMethod("[", signature(x = "filehashDB1", i = "character", j = "missing",
 333                          drop = "missing"),
 334           function(x, i , j, drop) {
 335               dbMultiFetch(x, i)
 336           })
 337
 338 setMethod("dbExists", signature(db = "filehashDB1", key = "character"),
 339           function(db, key, ...) {
 340               dbkeys <- dbList(db)
 341               key %in% dbkeys
 342           })
 343
 344 setMethod("dbList", "filehashDB1",
 345           function(db, ...) {
 346               filecon <- file(db@datafile, "rb")
 347               on.exit(close(filecon))
 348
 349               checkMap(db, filecon)
 350               map <- getMap(db)
 351
 352               if(length(map) == 0)
 353                   character(0)
 354               else
 355                   names(as.list(map, all.names = TRUE))
 356           })
 357
 358 setMethod("dbDelete", signature(db = "filehashDB1", key = "character"),
 359           function(db, key, ...) {
 360               filecon <- file(db@datafile, "ab")
 361               on.exit(close(filecon))
 362
 363               writeNullKeyValue(filecon, key)
 364           })
 365
 366 setMethod("dbUnlink", "filehashDB1",
 367           function(db, ...) {
 368               file.remove(db@datafile)
 369           })
 370
 371 setMethod("dbReorganize", "filehashDB1",
 372           function(db, ...) {
 373               datafile <- db@datafile
 374
 375               ## Find a temporary file name
 376               tempdata <- paste(datafile, "Tmp", sep = "")
 377               i <- 0
 378               while(file.exists(tempdata)) {
 379                   i <- i + 1
 380                   tempdata <- paste(datafile, "Tmp", i, sep = "")
 381               }
 382               if(!dbCreate(tempdata, type = "DB1")) {
 383                   warning("could not create temporary database")
 384                   return(FALSE)
 385               }
 386               on.exit(file.remove(tempdata))
 387
 388               tempdb <- dbInit(tempdata, type = "DB1")
 389               keys <- dbList(db)
 390
 391               ## Copy all keys to temporary database
 392               for(key in keys)
 393                   dbInsert(tempdb, key, dbFetch(db, key))
 394
 395               dbDisconnect(tempdb)
 396               dbDisconnect(db)
 397               status <- file.rename(tempdata, datafile)
 398
 399               if(!isTRUE(status)) {
 400                   on.exit()
 401                   warning("temporary database could not be renamed and is left in ",
 402                           tempdata)
 403                   return(FALSE)
 404               }
 405               message("original database has been disconnected; ",
 406                       "reload with 'dbInit'")
 407               TRUE
 408           })
 409
 410
 411 ######################################################################
 412 ## Test system's ftell()
 413
 414 hasWorkingFtell <- function() {
 415     tfile <- tempfile()
 416     con <- file(tfile, "wb")
 417
 418     tryCatch({
 419         bytes <- raw(10)
 420         begin <- seek(con)
 421
 422         if(begin != 0)
 423             return(FALSE)
 424         writeBin(bytes, con)
 425         end <- seek(con)
 426         offset <- end - begin
 427         isTRUE(offset == 10)
 428     }, finally = {
 429         close(con)
 430         unlink(tfile)
 431     })
 432 }
 433
 434 ######################################################################
 435
 436