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         createEmptyFile(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 <- toBytes(value)
 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     createEmptyFile(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("dbReconnect", "filehashDB1",
 300           function(db, ...) {
 301               validObject(db)
 302               db
 303           })
 304
 305 setMethod("dbInsert",
 306           signature(db = "filehashDB1", key = "character", value = "ANY"),
 307           function(db, key, value, ...) {
 308               filecon <- file(db@datafile, "ab")
 309               on.exit(close(filecon))
 310               writeKeyValue(filecon, key, value)
 311           })
 312
 313 setMethod("dbFetch",
 314           signature(db = "filehashDB1", key = "character"),
 315           function(db, key, ...) {
 316               filecon <- file(db@datafile, "rb")
 317               on.exit(close(filecon))
 318
 319               checkMap(db, filecon)
 320               map <- getMap(db)
 321
 322               r <- readKeys(filecon, map, key[1])
 323               r[[1]]
 324           })
 325
 326 setMethod("dbMultiFetch",
 327           signature(db = "filehashDB1", key = "character"),
 328           function(db, key, ...) {
 329               filecon <- file(db@datafile, "rb")
 330               on.exit(close(filecon))
 331
 332               checkMap(db, filecon)
 333               map <- getMap(db)
 334
 335               readKeys(filecon, map, key)
 336           })
 337
 338 setMethod("[", signature(x = "filehashDB1", i = "character", j = "missing",
 339                          drop = "missing"),
 340           function(x, i , j, drop) {
 341               dbMultiFetch(x, i)
 342           })
 343
 344 setMethod("dbExists", signature(db = "filehashDB1", key = "character"),
 345           function(db, key, ...) {
 346               dbkeys <- dbList(db)
 347               key %in% dbkeys
 348           })
 349
 350 setMethod("dbList", "filehashDB1",
 351           function(db, ...) {
 352               filecon <- file(db@datafile, "rb")
 353               on.exit(close(filecon))
 354
 355               checkMap(db, filecon)
 356               map <- getMap(db)
 357
 358               if(length(map) == 0)
 359                   character(0)
 360               else
 361                   names(as.list(map, all.names = TRUE))
 362           })
 363
 364 setMethod("dbDelete", signature(db = "filehashDB1", key = "character"),
 365           function(db, key, ...) {
 366               filecon <- file(db@datafile, "ab")
 367               on.exit(close(filecon))
 368
 369               writeNullKeyValue(filecon, key)
 370           })
 371
 372 setMethod("dbUnlink", "filehashDB1",
 373           function(db, ...) {
 374               file.remove(db@datafile)
 375           })
 376
 377 setMethod("dbDisconnect", "filehashDB1",
 378           function(db, ...) {
 379               invisible()
 380           })
 381
 382 setMethod("dbReorganize", "filehashDB1",
 383           function(db, ...) {
 384               datafile <- db@datafile
 385
 386               ## Find a temporary file name
 387               tempdata <- paste(datafile, "Tmp", sep = "")
 388               i <- 0
 389               while(file.exists(tempdata)) {
 390                   i <- i + 1
 391                   tempdata <- paste(datafile, "Tmp", i, sep = "")
 392               }
 393               if(!dbCreate(tempdata, type = "DB1")) {
 394                   warning("could not create temporary database")
 395                   return(FALSE)
 396               }
 397               on.exit(file.remove(tempdata))
 398
 399               tempdb <- dbInit(tempdata, type = "DB1")
 400               keys <- dbList(db)
 401
 402               ## Copy all keys to temporary database
 403               for(key in keys)
 404                   dbInsert(tempdb, key, dbFetch(db, key))
 405
 406               dbDisconnect(tempdb)
 407               dbDisconnect(db)
 408               status <- file.rename(tempdata, datafile)
 409
 410               if(!isTRUE(status)) {
 411                   on.exit()
 412                   warning("temporary database could not be renamed and is left in ",
 413                           tempdata)
 414                   return(FALSE)
 415               }
 416               message("original database has been disconnected; ",
 417                       "reload with 'dbInit'")
 418               TRUE
 419           })
 420
 421
 422 ######################################################################
 423 ## Test system's ftell()
 424
 425 hasWorkingFtell <- function() {
 426     tfile <- tempfile()
 427     con <- file(tfile, "wb")
 428
 429     tryCatch({
 430         bytes <- raw(10)
 431         begin <- seek(con)
 432
 433         if(begin != 0)
 434             return(FALSE)
 435         writeBin(bytes, con)
 436         end <- seek(con)
 437         offset <- end - begin
 438         isTRUE(offset == 10)
 439     }, finally = {
 440         close(con)
 441         unlink(tfile)
 442     })
 443 }
 444
 445 ######################################################################
 446
 447