Changeset 25479 in project for release/4/ugarit/trunk/backend-fs.scm


Ignore:
Timestamp:
11/07/11 10:43:08 (10 years ago)
Author:
Alaric Snell-Pym
Message:

ugarit: Dotting is, crossing ts...

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/4/ugarit/trunk/backend-fs.scm

    r25478 r25479  
    149149         (void))))
    150150
    151 #;(define (backend-log logfile indexfile tagsfile)
    152    (let ((*index* (gdbm-open indexfile))
    153          (*tags* (gdbm-open tagsfile))
    154          (*log* (file-open logfile (+ open/creat open/rdwr open/append) perm/irwxu))
    155          (make-index-key (lambda (key)
    156             key))
    157          (make-index-tag (lambda (tag)
    158             tag))
    159          (make-index-entry (lambda (type posn len)
    160             (sprintf "(~A ~A ~A)" type posn len)))
    161          (parse-index-entry (lambda (str)
    162             (with-input-from-string str read))))
    163 
    164       ; FIXME: Sanity check that all opened OK
    165 
    166       (make-storage
    167          (* 1024 1024) ; 1MiB blocks since local disk is fast and cheap
    168          #t ; We are writable
    169          #f ; We DO NOT support unlink!
    170 
    171          (lambda (key data type) ; put!
    172             (if (gdbm-exists *index* (make-index-key key))
    173                (signal (make-property-condition 'exn 'message "Duplicate block: put! should not be called on an existing hash" 'arguments (list key type))))
    174 
    175             (set-file-position! *log* 0 seek/end)
    176 
    177 
    178             (let ((header (sprintf "(block ~S ~S ~S)" key type (u8vector-length data)))
    179                   (posn (file-position *log*)))
    180                (file-write *log* header)
    181                (file-write *log* (u8vector->blob/shared data))
    182                (gdbm-store *index* (make-index-key key)
    183                   (make-index-entry type (+ (string-length header) posn) (u8vector-length data)))
    184                (void)))
    185 
    186          (lambda (key) ; exists?
    187             (if (gdbm-exists *index* (make-index-key key))
    188                (car (parse-index-entry (gdbm-fetch *index* key)))
    189                #f))
    190 
    191          (lambda (key) ; get
    192             (let* ((entry (parse-index-entry (gdbm-fetch *index* (make-index-key key))))
    193                    (type (car entry))
    194                    (position (cadr entry))
    195                    (length (caddr entry))
    196                    (buffer (make-blob length)))
    197                (set-file-position! *log* position seek/set)
    198                (file-read *log* length buffer)
    199                (blob->u8vector/shared buffer)))
    200          (lambda (key) ; link!
    201             (void))
    202          (lambda (key) ; unlink!
    203             (signal (make-property-condition 'exn 'message "Log archives do not support deletion")))
    204          (lambda (tag key) ; set-tag!
    205             (file-write *log* (sprintf "(tag ~S ~S)" tag key))
    206             (gdbm-store *tags* (make-index-tag tag) key))
    207          (lambda (tag) ; tag
    208             (if (gdbm-exists *tags* (make-index-tag tag))
    209                (gdbm-fetch *tags* (make-index-tag tag))
    210                #f))
    211          (lambda () ; all-tags
    212             (gdbm-fold *tags* (lambda (key value acc) (cons key acc)) '()))
    213          (lambda (tag) ; remove-tag!
    214             (file-write *log* (sprintf "(untag ~S)" tag))
    215             (gdbm-delete *tags* (make-index-tag tag)))
    216          (lambda (tag) ; lock-tag!
    217             ; (printf "FIXME: Implement lock-tag! in backend-fs.scm\n")
    218             #f)
    219          (lambda (tag) ; tag-locked?
    220             ; (printf "FIXME: Implement tag-locked? in backend-fs.scm\n")
    221             #f)
    222          (lambda (tag) ; unlock-tag!
    223             ; (printf "FIXME: Implement unlock-tag! in backend-fs.scm\n")
    224             #f)
    225          (lambda () ; close!
    226             (gdbm-close *index*)
    227             (gdbm-close *tags*)
    228             (file-close *log*)))))
    229 
    230 #;(define (backend-splitlog logdir metadir max-logpart-size)
    231    (let*
    232         ((*index* (gdbm-open (string-append metadir "/index")))
    233          (*tags* (gdbm-open (string-append metadir "/tags")))
    234          (countfile (string-append metadir "/count"))
    235          (*logcount* (if (file-read-access? countfile)
    236             (with-input-from-file countfile read)
    237             0))
    238          (*log* (file-open (string-append logdir "/log" (number->string *logcount*))
    239                   (+ open/creat open/rdwr open/append) perm/irwxu))
    240          (*logfiles* (make-hash-table)) ; hash of file number to FD
    241          (get-log (lambda (index)
    242             (if (hash-table-exists? *logfiles* index)
    243                (hash-table-ref *logfiles* index)
    244                (begin
    245                   (let ((fd (file-open (string-append logdir "/log" (number->string index)) open/rdonly perm/irwxu)))
    246                      (set! (hash-table-ref *logfiles* index) fd)
    247                      fd)))))
    248          (make-index-key (lambda (key)
    249             key))
    250          (make-index-tag (lambda (tag)
    251             tag))
    252          (make-index-entry (lambda (type index posn len)
    253             (sprintf "(~A ~A ~A ~A)" type index posn len)))
    254          (parse-index-entry (lambda (str)
    255             (with-input-from-string str read))))
    256 
    257       ; FIXME: Sanity check that all opened OK
    258 
    259       (make-storage
    260          (* 1024 1024) ; 1MiB blocks since local disk is fast and cheap
    261          #t ; We are writable
    262          #f ; We DO NOT support unlink!
    263 
    264          (lambda (key data type) ; put!
    265             (if (gdbm-exists *index* (make-index-key key))
    266                (signal (make-property-condition 'exn 'message "Duplicate block: put! should not be called on an existing hash" 'arguments (list key type))))
    267 
    268             (set-file-position! *log* 0 seek/end)
    269 
    270             (let ((header (sprintf "(block ~S ~S ~S)" key type (u8vector-length data)))
    271                   (posn (file-position *log*)))
    272                (if (> posn max-logpart-size)
    273                   (begin
    274                      (file-close *log*)
    275                      (set! posn 0)
    276                      (set! *logcount* (+ *logcount* 1))
    277                      (with-output-to-file countfile (lambda ()
    278                         (write *logcount*)))
    279                      (set! *log* (file-open (string-append logdir "/log" (number->string *logcount*))
    280                                     (+ open/creat open/rdwr open/append) perm/irwxu))))
    281                (file-write *log* header)
    282                (file-write *log* (u8vector->blob/shared data))
    283                (gdbm-store *index* (make-index-key key)
    284                   (make-index-entry type *logcount* (+ (string-length header) posn) (u8vector-length data)))
    285                (void)))
    286 
    287          (lambda (key) ; exists?
    288             (if (gdbm-exists *index* (make-index-key key))
    289                (car (parse-index-entry (gdbm-fetch *index* key)))
    290                #f))
    291 
    292          (lambda (key) ; get
    293             (let* ((entry (parse-index-entry (gdbm-fetch *index* (make-index-key key))))
    294                    (type (car entry))
    295                    (index (cadr entry))
    296                    (position (caddr entry))
    297                    (length (cadddr entry))
    298                    (buffer (make-blob length))
    299                    (logpart (get-log index)))
    300                (set-file-position! logpart position seek/set)
    301                (file-read logpart length buffer)
    302                (blob->u8vector/shared buffer)))
    303          (lambda (key) ; link!
    304             (void))
    305          (lambda (key) ; unlink!
    306             (signal (make-property-condition 'exn 'message "Log archives do not support deletion")))
    307          (lambda (tag key) ; set-tag!
    308             (file-write *log* (sprintf "(tag ~S ~S)" tag key))
    309             (gdbm-store *tags* (make-index-tag tag) key))
    310          (lambda (tag) ; tag
    311             (if (gdbm-exists *tags* (make-index-tag tag))
    312                (gdbm-fetch *tags* (make-index-tag tag))
    313                #f))
    314          (lambda () ; all-tags
    315             (gdbm-fold *tags* (lambda (key value acc) (cons key acc)) '()))
    316          (lambda (tag) ; remove-tag!
    317             (file-write *log* (sprintf "(untag ~S)" tag))
    318             (gdbm-delete *tags* (make-index-tag tag)))
    319          (lambda (tag) ; lock-tag!
    320             ; (printf "FIXME: Implement lock-tag! in backend-fs.scm\n")
    321             #f)
    322          (lambda (tag) ; tag-locked?
    323             ; (printf "FIXME: Implement tag-locked? in backend-fs.scm\n")
    324             #f)
    325          (lambda (tag) ; unlock-tag!
    326             ; (printf "FIXME: Implement unlock-tag! in backend-fs.scm\n")
    327             #f)
    328          (lambda () ; close!
    329             (gdbm-close *index*)
    330             (gdbm-close *tags*)
    331             (file-close *log*)
    332             (hash-table-for-each *logfiles*
    333                (lambda (key value)
    334                   (file-close value)))))))
    335 
    336151(define splitlog-sql-schema
    337152  (list
     
    342157   "CREATE TABLE tags (tag TEXT PRIMARY KEY, key TEXT, locked INTEGER DEFAULT 0);"))
    343158
    344 (define (backend-splitlog logdir metadir max-logpart-size)
     159(define (backend-splitlog logdir metapath max-logpart-size)
    345160   (let*
    346161        ((*db*
    347           (let ((db (open-database (string-append metadir "/metadata"))))
     162          (let ((db (open-database metapath)))
    348163            (when (null? (schema db))
    349164                  (for-each (lambda (statement)
     
    482297          (backend-fs base))
    483298
    484          #;(("log" logfile indexfile tagsfile)
    485           (backend-log logfile indexfile tagsfile))
    486 
    487299         (("splitlog" logdir metadir max-logpart-size)
    488300          (backend-splitlog logdir metadir (string->number max-logpart-size)))
    489301
    490302         (else
    491           (printf "USAGE:\nbackend-fs fs <basedir>\nbackend-fs log <logfile> <indexfile> <tagsfile>\nbackend-fs splitlog <logdir> <metadir> <max-file-size>\n")
     303          (printf "USAGE:\nbackend-fs fs <basedir-path>\nbackend-fs splitlog <logdir-path> <metadata-file-path> <max-file-size>\n")
    492304          #f)))
    493305
Note: See TracChangeset for help on using the changeset viewer.