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