home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / gdbm.scm < prev    next >
Text File  |  2000-04-10  |  4KB  |  125 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: gdbm.scm,v 1.3 2000/04/10 18:32:32 cph Exp $
  4.  
  5. Copyright (c) 1996, 1999, 2000 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; gdbm Database Library Interface
  23. ;;; package: (runtime gdbm)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define (gdbm-available?)
  28.   (implemented-primitive-procedure? (ucode-primitive gdbm-open 4)))
  29.  
  30. ;; Parameters to gdbm_open for READERS, WRITERS, and WRITERS who can
  31. ;; create the database.
  32. (define GDBM_READER  0)        ;A reader.
  33. (define GDBM_WRITER  1)        ;A writer.
  34. (define GDBM_WRCREAT 2)        ;A writer.  Create the db if needed.
  35. (define GDBM_NEWDB   3)        ;A writer.  Always create a new db.
  36. (define GDBM_FAST    16)    ;Write fast! => No fsyncs.
  37.  
  38. (define (gdbm-open filename block-size flags mode)
  39.   (let ((filename (->namestring (merge-pathnames filename))))
  40.     (without-interrupts
  41.      (lambda ()
  42.        (let ((descriptor
  43.           (gdbm-error ((ucode-primitive gdbm-open 4)
  44.                filename block-size flags mode))))
  45.      (let ((gdbf (make-gdbf descriptor filename)))
  46.        (add-to-gc-finalizer! gdbf-finalizer gdbf descriptor)
  47.        gdbf))))))
  48.  
  49. (define (gdbm-close gdbf)
  50.   (if (not (gdbf? gdbf))
  51.       (error:wrong-type-argument gdbf "gdbm handle" 'GDBM-CLOSE))
  52.   (without-interrupts
  53.    (lambda ()
  54.      (if (gdbf-descriptor gdbf)
  55.      (begin
  56.        (remove-from-gc-finalizer! gdbf-finalizer gdbf)
  57.        (set-gdbf-descriptor! gdbf #f))))))
  58.  
  59. ;; Parameters to gdbm_store for simple insertion or replacement in the
  60. ;; case that the key is already in the database.
  61. (define GDBM_INSERT  0)        ;Never replace old data with new.
  62. (define GDBM_REPLACE 1)        ;Always replace old data with new.
  63.  
  64. (define (gdbm-store gdbf key datum flags)
  65.   (gdbm-error
  66.    ((ucode-primitive gdbm-store 4) (guarantee-gdbf gdbf 'GDBM-STORE)
  67.                    key datum flags)))
  68.  
  69. (define (gdbm-fetch gdbf key)
  70.   ((ucode-primitive gdbm-fetch 2) (guarantee-gdbf gdbf 'GDBM-FETCH) key))
  71.  
  72. (define (gdbm-exists? gdbf key)
  73.   ((ucode-primitive gdbm-exists 2) (guarantee-gdbf gdbf 'GDBM-EXISTS?) key))
  74.  
  75. (define (gdbm-delete gdbf key)
  76.   (gdbm-error
  77.    ((ucode-primitive gdbm-delete 2) (guarantee-gdbf gdbf 'GDBM-DELETE) key)))
  78.  
  79. (define (gdbm-firstkey gdbf)
  80.   ((ucode-primitive gdbm-firstkey 1) (guarantee-gdbf gdbf 'GDBM-FIRSTKEY)))
  81.  
  82. (define (gdbm-nextkey gdbf key)
  83.   ((ucode-primitive gdbm-nextkey 2) (guarantee-gdbf gdbf 'GDBM-NEXTKEY) key))
  84.  
  85. (define (gdbm-reorganize gdbf)
  86.   (gdbm-error
  87.    ((ucode-primitive gdbm-reorganize 1)
  88.     (guarantee-gdbf gdbf 'GDBM-REORGANIZE))))
  89.  
  90. (define (gdbm-sync gdbf)
  91.   ((ucode-primitive gdbm-sync 1) (guarantee-gdbf gdbf 'GDBM-SYNC)))
  92.  
  93. (define (gdbm-version)
  94.   ((ucode-primitive gdbm-version 0)))
  95.  
  96. ;; Parameters to gdbm_setopt, specifing the type of operation to perform.
  97. (define GDBM_CACHESIZE 1)       ;Set the cache size.
  98. (define GDBM_FASTMODE  2)       ;Toggle fast mode.
  99.  
  100. (define (gdbm-setopt gdbf opt val)
  101.   (gdbm-error
  102.    ((ucode-primitive gdbm-setopt 3) (guarantee-gdbf gdbf 'GDBM-SETOPT)
  103.                     opt val)))
  104.  
  105. (define-structure (gdbf
  106.            (print-procedure (standard-unparser-method 'GDBF
  107.                       (lambda (gdbf port)
  108.                     (write-char #\space port)
  109.                     (write (gdbf-filename gdbf) port)))))
  110.   descriptor
  111.   (filename #f read-only #t))
  112.  
  113. (define (guarantee-gdbf gdbf procedure)
  114.   (if (gdbf? gdbf)
  115.       (or (gdbf-descriptor gdbf) (error:bad-range-argument gdbf procedure))
  116.       (error:wrong-type-argument gdbf "gdbm handle" procedure)))
  117.  
  118. (define (gdbm-error object)
  119.   (if (string? object) (error "gdbm error:" object))
  120.   object)
  121.  
  122. (define gdbf-finalizer)
  123. (define (initialize-package!)
  124.   (set! gdbf-finalizer (make-gc-finalizer (ucode-primitive gdbm-close 1)))
  125.   unspecific)