plugins: Re-sync with runtime; allow strings as well as bytevectors.
authorMatt Birkholz <matt@birchwood-abbey.net>
Wed, 17 May 2017 23:01:12 +0000 (16:01 -0700)
committerMatt Birkholz <matt@birchwood-abbey.net>
Wed, 17 May 2017 23:01:12 +0000 (16:01 -0700)
17 files changed:
src/blowfish/NEWS
src/blowfish/blowfish-check.scm
src/blowfish/blowfish.scm
src/gdbm/NEWS
src/gdbm/gdbm.pkg
src/gdbm/gdbm.scm
src/mcrypt/NEWS
src/mcrypt/mcrypt.pkg
src/mcrypt/mcrypt.scm
src/md5/NEWS
src/md5/md5-check.scm
src/md5/md5.pkg
src/md5/md5.scm
src/mhash/NEWS
src/mhash/mhash-check.scm
src/mhash/mhash.pkg
src/mhash/mhash.scm

index e340c6d36239f6b84abc4d158e3cab40a48cbdf3..cd0ac9f2acbd820056c9528c23ae665d0e5823e8 100644 (file)
@@ -22,8 +22,19 @@ along with MIT/GNU Scheme; if not, write to the Free Software
 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
 02110-1301, USA.
 
+mit-scheme-blowfish 0.2 - Matt Birkholz, 2017-05-18
+===================================================
+
+Use byte vectors for binary data instead of strings.  This changes
+every export except blowfish-file? and perhaps compute-blowfish-init-
+vector IF you don't care whether the init vector is a string.  Every
+procedure that previously accepted/returned strings now
+requires/produces byte vectors.  If it accepted/returned generic ports
+it now requires/produces binary ports.  If you are using the md5
+plugin to produce a digest for blowfish-set-key, you're winning, with
+blowfish-set-key at least; md5 digests are now byte vectors too.
+
 mit-scheme-blowfish 0.1 - Matt Birkholz, 2016-02-19
 ===================================================
 
-* Use libtool and automake, rather than the microcode's disappearing
-  module support.
+Use libtool and automake.
index f1bae2a103a545581ebb6487777a7cda34eec184..ae2ca5f5b3701ff7c8d85c6cdab8b3b339697775 100644 (file)
@@ -31,7 +31,7 @@ USA.
     (lambda (output)
       (blowfish-encrypt-port (open-input-bytevector sample)
                             output
-                            "secret"
+                            (string->utf8 "secret")
                             (write-blowfish-file-header output)
                             #t)))
   (let ((read-back
@@ -39,7 +39,7 @@ USA.
           (lambda (input)
             (call-with-output-bytevector
              (lambda (output)
-               (blowfish-encrypt-port input output "secret"
+               (blowfish-encrypt-port input output (string->utf8 "secret")
                                       (read-blowfish-file-header input)
                                       #f)))))))
     (if (not (bytevector=? sample read-back))
index 8a042a8ce4715b4c18bfedbea64c25ead00e9bef..ccd9b2ce32cbf2354a232104cf581d5f61056163 100644 (file)
@@ -24,26 +24,23 @@ USA.
 
 |#
 
-;;;; The BLOWFISH option.
+;;;; Interface to Blowfish
 ;;; package: (blowfish)
 
 (declare (usual-integrations))
 \f
 (C-include "blowfish")
 
-(define (blowfish-set-key string)
-  ;; Generate a Blowfish key from STRING.
-  ;; STRING must be 72 bytes or less in length.
+(define (blowfish-set-key bytes)
+  ;; Generate a Blowfish key from BYTES.
+  ;; BYTES must be 72 bytes or less in length.
   ;; For text-string keys, use MD5 on the text, and pass the digest here.
-  (guarantee string? string 'blowfish-set-key)
-  (let* ((data (string->utf8 string))
-        (len (bytevector-length data)))
+  (guarantee bytevector? bytes 'blowfish-set-key)
+  (let ((len (bytevector-length bytes)))
     (if (> len 72)
-       (error:bad-range-argument
-        string "a string encodable in UTF8 with fewer than 72 bytes"
-        'blowfish-set-key))
+       (error:bad-range-argument bytes "72 or fewer bytes" 'blowfish-set-key))
     (let ((key (make-bytevector (C-sizeof "BF_KEY"))))
-      (C-call "BF_set_key" key len data)
+      (C-call "BF_set_key" key len bytes)
       key)))
 
 (define (blowfish-ecb input output key encrypt?)
@@ -51,10 +48,10 @@ USA.
   ;; INPUT is an 8-byte bytevector.
   ;; OUTPUT is an 8-byte bytevector.
   ;; KEY is a Blowfish key.
-  ;; ENCRYPT? says whether to encrypt (non-#F) or decrypt (#F).
-  (guarantee-bfkey key 'BLOWFISH-ECB)
-  (guarantee-8byte-arg input 'BLOWFISH-ECB)
-  (guarantee-8byte-arg output 'BLOWFISH-ECB)
+  ;; ENCRYPT? says whether to encrypt (#T) or decrypt (#F).
+  (guarantee-bfkey key 'blowfish-ecb)
+  (guarantee-8byte-arg input 'blowfish-ecb)
+  (guarantee-8byte-arg output 'blowfish-ecb)
   (C-call "BF_ecb_encrypt" input output key (bf-de/encrypt encrypt?)))
 
 (define (blowfish-cbc input output key init-vector encrypt?)
@@ -63,39 +60,39 @@ USA.
   ;; OUTPUT is a bytevector whose length is the same as INPUT.
   ;; KEY is a Blowfish key.
   ;; INIT-VECTOR is an 8-byte bytevector; it is modified after each call.
-  ;; The value from any call may be passed in to a later call.
-  ;; ENCRYPT? says whether to encrypt (non-#F) or decrypt (#F).
-  (guarantee-init-vector init-vector 'BLOWFISH-CBC)
-  (guarantee-bfkey key 'BLOWFISH-CBC)
-  (guarantee-8Xbyte-arg input 'BLOWFISH-CBC)
+  ;;   The value from any call may be passed in to a later call.
+  ;; ENCRYPT? says whether to encrypt (#T) or decrypt (#F).
+  (guarantee-init-vector init-vector 'blowfish-cbc)
+  (guarantee-bfkey key 'blowfish-cbc)
+  (guarantee-8Xbyte-arg input 'blowfish-cbc)
   (if (or (eq? input output)
          (not (= (bytevector-length output) (bytevector-length input))))
       (error:bad-range-argument output
                                "a bytevector as long as the input bytevector"
-                               'BLOWFISH-CBC))
+                               'blowfish-cbc))
   (C-call "BF_cbc_encrypt" input output (bytevector-length input)
          key init-vector (bf-de/encrypt encrypt?)))
 
 (define (blowfish-cfb64 input istart iend output ostart
                        key init-vector num encrypt?)
   ;; Apply Blowfish in Cipher Feed-Back mode.
-  ;; (INPUT,ISTART,IEND) is an arbitrary subbytevector.
-  ;; OUTPUT is a bytevector as large as the input subbytevector.
-  ;; OSTART says where to start writing to the output bytevector.
+  ;; (INPUT,ISTART,IEND) is an arbitrary bytevector range.
+  ;; OUTPUT is a bytevector.
+  ;; OSTART says where to start writing in OUTPUT.
   ;; KEY is a Blowfish key.
   ;; INIT-VECTOR is an 8-byte bytevector; it is modified after each call.
-  ;; The value from any call may be passed in to a later call.
-  ;; The initial value must be unique for each message/key pair.
+  ;;   The value from any call may be passed in to a later call.
+  ;;   The initial value must be unique for each message/key pair.
   ;; NUM is a digit from 0 to 7 inclusive; it is the low 3 bits of the
-  ;; number of bytes that have previously been processed in this stream.
-  ;; ENCRYPT? says whether to encrypt (non-#F) or decrypt (#F). 
+  ;;   number of bytes that have previously been processed in this stream.
+  ;; ENCRYPT? says whether to encrypt (#T) or decrypt (#F). 
   ;; Returned value is the new value of NUM.
-  (guarantee-bfkey key 'BLOWFISH-CFB64)
-  (guarantee-init-vector init-vector 'BLOWFISH-CFB64)
-  (guarantee-subbytevector input istart iend 'BLOWFISH-CFB64)
+  (guarantee-bfkey key 'blowfish-cfb64)
+  (guarantee-init-vector init-vector 'blowfish-cfb64)
+  (guarantee-subbytevector input istart iend 'blowfish-cfb64)
   (guarantee-subbytevector output ostart (+ ostart (- iend istart))
-                          'BLOWFISH-CFB64)
-  (guarantee-init-index num 'BLOWFISH-CFB64)
+                          'blowfish-cfb64)
+  (guarantee-init-index num 'blowfish-cfb64)
   (let ((ilen (- iend istart)))
     (if (and (eq? input output)
             (< ostart iend)
@@ -103,16 +100,16 @@ USA.
        (error:bad-range-argument
         ostart
         "an index of a subbytevector not overlapping the input subbytevector"
-        'BLOWFISH-CFB64))
+        'blowfish-cfb64))
     (C-call "do_BF_cfb64_encrypt" input istart output ostart ilen
            key init-vector num (bf-de/encrypt encrypt?))))
 
 (define (blowfish-ofb64 input istart iend output ostart
                        key init-vector num)
   ;; Apply Blowfish in Output Feed-Back mode.
-  ;; (INPUT,ISTART,IEND) is an arbitrary subbytevector.
-  ;; OUTPUT is a bytevector as large as the input subbytevector.
-  ;; OSTART says where to start writing to the output bytevector.
+  ;; (INPUT,ISTART,IEND) is an arbitrary bytevector range.
+  ;; OUTPUT is a bytevector.
+  ;; OSTART says where to start writing in OUTPUT.
   ;; KEY is a Blowfish key.
   ;; INIT-VECTOR is an 8-byte bytevector; it is modified after each call.
   ;;   The value from any call may be passed in to a later call.
@@ -120,12 +117,12 @@ USA.
   ;; NUM is a digit from 0 to 7 inclusive; it is the low 3 bits of the
   ;;   number of bytes that have previously been processed in this stream.
   ;; Returned value is the new value of NUM.
-  (guarantee-bfkey key 'BLOWFISH-OFB64)
-  (guarantee-init-vector init-vector 'BLOWFISH-OFB64)
-  (guarantee-subbytevector input istart iend 'BLOWFISH-OFB64)
+  (guarantee-bfkey key 'blowfish-ofb64)
+  (guarantee-init-vector init-vector 'blowfish-ofb64)
+  (guarantee-subbytevector input istart iend 'blowfish-ofb64)
   (guarantee-subbytevector output ostart (+ ostart (- iend istart))
-                          'BLOWFISH-OFB64)
-  (guarantee-init-index num 'BLOWFISH-OFB64)
+                          'blowfish-ofb64)
+  (guarantee-init-index num 'blowfish-ofb64)
   (let ((ilen (- iend istart)))
     (if (and (eq? input output)
             (< ostart iend)
@@ -133,7 +130,7 @@ USA.
        (error:bad-range-argument
         ostart
         "an index of a subbytevector not overlapping the input subbytevector"
-        'BLOWFISH-OFB64))
+        'blowfish-ofb64))
     (C-call "do_BF_ofb64_encrypt" input istart output ostart ilen
            key init-vector num)))
 
@@ -194,12 +191,13 @@ USA.
      (lambda ()
        (let loop ((m 0))
         (let ((n (read-bytevector! input-buffer input)))
-          (if (and (not (eof-object? n))
-                   (not (fix:= 0 n)))
+          (if (and n (not (eof-object? n)))
               (let ((m
                      (blowfish-cfb64 input-buffer 0 n output-buffer 0
                                      key init-vector m encrypt?)))
-                (write-bytevector output-buffer output 0 n)
+                (let ((n* (write-bytevector output-buffer output 0 n)))
+                  (if (not (eqv? n n*))
+                      (error "Short write (requested, actual):" n n*)))
                 (loop m))))))
      (lambda ()
        (bytevector-fill! input-buffer 0)
@@ -216,40 +214,50 @@ USA.
                  #x100000)
               (random #x100000))
            (quotient t #x100)))
-       ((fix:= 8 i))
+       ((not (fix:< i 8)))
       (bytevector-u8-set! iv i (remainder t #x100)))
     iv))
 
 (define (write-blowfish-file-header port)
   (write-bytevector blowfish-file-header-v2 port)
-  (write-u8 (char->integer #\newline) port)
   (let ((init-vector (compute-blowfish-init-vector)))
     (write-bytevector init-vector port)
     init-vector))
 
 (define (read-blowfish-file-header port)
-  (let ((line (read-header port)))
-    (cond ((bytevector=? blowfish-file-header-v1 line)
-          (make-bytevector 8 #\NUL))
-         ((bytevector=? blowfish-file-header-v2 line)
-          (read-bytevector 8 port))
-         (else
-          (error:bad-range-argument port 'READ-BLOWFISH-FILE-HEADER)))))
-
-(define (read-header port)
-  (let loop ((bytes '()))
-    (let ((byte (read-u8 port)))
-      (if (eof-object? byte)
-         (apply bytevector (reverse! bytes))
-         (if (fix:= byte (char->integer #\newline))
-             (apply bytevector (reverse! bytes))
-             (loop (cons byte bytes)))))))
+  (let ((version (try-read-blowfish-file-header port)))
+    (if (not version)
+       (error:bad-range-argument port 'read-blowfish-file-header))
+    (if (= version 1)
+       (make-bytevector 8 0)
+       (or (%safe-read-bytevector 8 port)
+           (error "Short read while getting init-vector:" port)))))
+
+(define (try-read-blowfish-file-header port)
+  (let* ((n (bytevector-length blowfish-file-header-v1))
+        (bv1 (%safe-read-bytevector n port)))
+    (and bv1
+        (if (bytevector=? bv1 blowfish-file-header-v1)
+            1
+            (let* ((m (fix:- (bytevector-length blowfish-file-header-v2) n))
+                   (bv2 (%safe-read-bytevector m port)))
+              (and bv2
+                   (bytevector=? (bytevector-append bv1 bv2)
+                                 blowfish-file-header-v2)
+                   2))))))
+
+(define (%safe-read-bytevector n port)
+  (let ((bv (read-bytevector n port)))
+    (and bv
+        (not (eof-object? bv))
+        (fix:= (bytevector-length bv) n)
+        bv)))
 
 (define (blowfish-file? pathname)
-  (let ((line (call-with-binary-input-file pathname read-header)))
-    (and (not (eof-object? line))
-        (or (bytevector=? line blowfish-file-header-v1)
-            (bytevector=? line blowfish-file-header-v2)))))
+  (call-with-binary-input-file pathname try-read-blowfish-file-header))
+
+(define blowfish-file-header-v1
+  (string->utf8 "Blowfish, 16 rounds\n"))
 
-(define blowfish-file-header-v1 (string->utf8 "Blowfish, 16 rounds"))
-(define blowfish-file-header-v2 (string->utf8 "Blowfish, 16 rounds, version 2"))
\ No newline at end of file
+(define blowfish-file-header-v2
+  (string->utf8 "Blowfish, 16 rounds, version 2\n"))
\ No newline at end of file
index fe8d001c61b2086c61ad6287b1e6074e49b66b58..f0bb044533cab25bf83b8adb544125bcaa18f60b 100644 (file)
@@ -22,8 +22,14 @@ along with MIT/GNU Scheme; if not, write to the Free Software
 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
 02110-1301, USA.
 
+mit-scheme-gdbm 0.2 - Matt Birkholz, 2017-05-18
+===============================================
+
+Use new Unicode support.  Convert non-ASCII strings (keys and data) to
+UTF8.  This assumes any other program adding non-ASCII keys or data is
+using the same encoding.
+
 mit-scheme-gdbm 0.1 - Matt Birkholz, 2016-02-19
 ===============================================
 
-* Use libtool and automake, rather than the microcode's disappearing
-  module support.
+Use libtool and automake.
index d11a1a988bd0814aa5441cc8276031acb3df291a..f862304ab0c0b9ddd204730de699b59e7ef68bef 100644 (file)
@@ -30,8 +30,10 @@ USA.
   (files "gdbm")
   (parent ())
   (initialization (initialize-package!))
-  ;; You'll have to import these from (global-definitions gdbm/).
-  ;; They are currently bound in () by exports from (runtime gdbm).
+  (import (runtime ustring)
+         cp1-ref
+         ustring-cp-size
+         ustring?)
   (export (gdbm global)
          gdbm-close
          gdbm-delete
index 9a6704783b299fc54fe2b1476bc605db68798ded..3f7a1e1ee4200ee4b5429f04f3c883a2defc3ab3 100644 (file)
@@ -24,13 +24,36 @@ USA.
 
 |#
 
-;;;; The GDBM option.
+;;;; The GDBM2 option.
 ;;; package: (gdbm)
 
 (declare (usual-integrations))
 \f
 (C-include "gdbm")
 
+(define-integrable (every-loop proc ref string start end)
+  (let loop ((i start))
+    (if (fix:< i end)
+       (and (proc (ref string i))
+            (loop (fix:+ i 1)))
+       #t)))
+
+(define (->bytes string)
+  (if (and (or (bytevector? string)
+              (and (ustring? string)
+                   (fix:= 1 (ustring-cp-size string))))
+          (let ((end (string-length string)))
+            (every-loop (lambda (cp) (fix:< cp #x80))
+                        cp1-ref string 0 end)))
+      string
+      (string->utf8 string)))
+
+(declare (integrate-operator bytes-length))
+(define (bytes-length bytes)
+  (if (bytevector? bytes)
+      (bytevector-length bytes)
+      (string-length bytes)))
+
 ;; Parameters to gdbm_open for READERS, WRITERS, and WRITERS who can
 ;; create the database.
 (define GDBM_READER (C-enum "GDBM_READER"))    ;A reader.
@@ -43,14 +66,15 @@ USA.
   (guarantee integer? block-size 'GDBM-OPEN)
   (guarantee integer? mode 'GDBM-OPEN)
   (let ((args (make-alien '|gdbm_args|))
-       (flagsnum (guarantee-gdbm-open-flags flags)))
+       (flagsnum (guarantee-gdbm-open-flags flags))
+       (filename (->namestring (merge-pathnames filename))))
     (let ((gdbf (make-gdbf args (make-thread-mutex) filename)))
       (add-open-gdbf-cleanup gdbf)
       (with-gdbf-locked
        gdbf
        (lambda ()
         (C-call "do_gdbm_open"
-                args (string->utf8 filename) block-size flagsnum mode)
+                args (->bytes filename) block-size flagsnum mode)
         (if (alien-null? args)
             (error "gdbm_open failed: malloc failed")
             (if (alien-null? (C-> args "gdbm_args dbf"))
@@ -191,13 +215,11 @@ USA.
 
 (define (gdbm-strerror errno)
   (guarantee fixnum? errno 'GDBM-STRERROR)
-  (utf8->string
-   (c-peek-cstring (C-call "gdbm_strerror" (make-alien '(* char)) errno))))
+  (c-peek-cstring (C-call "gdbm_strerror" (make-alien '(* char)) errno)))
 
 (define (strerror errno)
   (guarantee fixnum? errno 'STRERROR)
-  (utf8->string
-   (c-peek-cstring (C-call "strerror" (make-alien '(* char)) errno))))
+  (c-peek-cstring (C-call "strerror" (make-alien '(* char)) errno)))
 
 ;; Parameters to gdbm_setopt, specifing the type of operation to perform.
 (define GDBM_CACHESIZE (C-enum "GDBM_CACHESIZE"))      ;Set the cache size.
@@ -229,8 +251,7 @@ USA.
           (gdbm-error gdbf "gdbm_setopt"))))))
 
 (define (gdbm-version)
-  (utf8->string
-   (c-peek-cstring (C-call "get_gdbm_version" (make-alien '(* char))))))
+  (c-peek-cstring (C-call "get_gdbm_version" (make-alien '(* char)))))
 
 (define (guarantee-nonnull-string obj procedure)
   (guarantee string? obj procedure)
@@ -276,44 +297,44 @@ USA.
           (strerror (C-> args "gdbm_args sys_errno")))))
 
 (define (gdbf-args-put-key! args key)
-  (let ((bytevector (string->utf8 key)))
-    (let ((size (bytevector-length bytevector))
+  (let ((bytes (->bytes key)))
+    (let ((size (bytes-length bytes))
          (dptr (make-alien '(* char))))
       (if (< size 1)
          (error "empty key:" key))
       (C-call "alloc_gdbm_key" dptr args size)
       (if (alien-null? dptr)
          (error "gdbf-args-put-key!: malloc failed" key))
-      (c-poke-bytes dptr 0 size bytevector 0))))
+      (c-poke-bytes dptr 0 size bytes 0))))
 
 (define (gdbf-args-put-content! args content)
-  (let ((bytevector (string->utf8 content)))
-    (let ((size (bytevector-length bytevector))
+  (let ((bytes (->bytes content)))
+    (let ((size (bytes-length bytes))
          (dptr (make-alien '(* char))))
       (if (< size 1)
          (error "empty content:" content))
       (C-call "alloc_gdbm_content" dptr args size)
       (if (alien-null? dptr)
          (error "gdbf-args-put-content!: malloc failed" size))
-      (c-poke-bytes dptr 0 size bytevector 0))))
+      (c-poke-bytes dptr 0 size bytes 0))))
 
 (define (gdbf-args-get-key args)
   (let ((data (C-> args "gdbm_args key dptr")))
     (if (alien-null? data)
        #f
        (let* ((size (C-> args "gdbm_args key dsize"))
-              (bytevector (make-bytevector size)))
-         (c-peek-bytes data 0 size bytevector 0)
-         (utf8->string bytevector)))))
+              (string ((ucode-primitive string-allocate 1) size)))
+         (c-peek-bytes data 0 size string 0)
+         string))))
 
 (define (gdbf-args-get-content args)
   (let ((data (C-> args "gdbm_args content dptr")))
     (if (alien-null? data)
        #f
        (let* ((size (C-> args "gdbm_args content dsize"))
-              (bytevector (make-bytevector size)))
-         (c-peek-bytes data 0 size bytevector 0)
-         (utf8->string bytevector)))))
+              (string ((ucode-primitive string-allocate 1) size)))
+         (c-peek-bytes data 0 size string 0)
+         string))))
 
 (define open-gdbfs '())
 (define open-gdbfs-mutex)
index 555b40c4303593edfc834c1dee235882101f9635..02cd5c3b7a4309ebf175cf45e9439691bba1a417 100644 (file)
@@ -22,8 +22,18 @@ along with MIT/GNU Scheme; if not, write to the Free Software
 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
 02110-1301, USA.
 
+mit-scheme-mcrypt 0.2 - Matt Birkholz, 2017-05-18
+=================================================
+
+Use byte vectors for binary data instead of strings.  Thus all keys
+and init vectors now must be byte vectors of the appropriate length
+(per mcrypt-supported-key-sizes or mcrypt-init-vector-size
+respectively).  The input and output arguments to mcrypt-encrypt
+should now be byte vectors, and the input and output arguments to
+mcrypt-encrypt-port must now be binary ports.  Other changes: mcrypt-
+encrypt! and mcrypt-decrypt! were added.
+
 mit-scheme-mcrypt 0.1 - Matt Birkholz, 2016-02-19
 =================================================
 
-* Use libtool and automake, rather than the microcode's disappearing
-  module support.
+Use libtool and automake.
index dcea7690ba7fb7def566c8b3d6a552c5b703be05..e3a5b9ebdb1e6f4daf32d8226f71fe6568a65218 100644 (file)
@@ -29,10 +29,6 @@ USA.
 (define-package (mcrypt)
   (files "mcrypt")
   (parent ())
-
-  ;; You'll have to import these from package (mcrypt).  They are
-  ;; currently bound in () by exports from package (runtime crypto).
-  ;; Note that CREF will need "(global-definitions mcrypt/)".
   (export (mcrypt global)
          mcrypt-algorithm-name
          mcrypt-algorithm-names
@@ -40,7 +36,9 @@ USA.
          mcrypt-block-algorithm?
          mcrypt-block-mode?
          mcrypt-context?
+         mcrypt-decrypt!
          mcrypt-encrypt
+         mcrypt-encrypt!
          mcrypt-encrypt-port
          mcrypt-end
          mcrypt-init
index 5aae9cfd48a188a8be9e33c7b5754dd61e881a4c..a8b65928677059f7fc300d360d0235b531218b45 100644 (file)
@@ -24,7 +24,7 @@ USA.
 
 |#
 
-;;;; The MCRYPT option.
+;;;; The mcrypt option.
 ;;; package: (mcrypt)
 
 (declare (usual-integrations))
@@ -130,9 +130,20 @@ USA.
 \f
 (define-structure mcrypt-context algorithm mode alien)
 
-(define (guarantee-mcrypt-context object procedure)
+(define (guarantee-mcrypt-context object caller)
   (if (not (mcrypt-context? object))
-      (error:wrong-type-argument object "mcrypt context" procedure)))
+      (error:wrong-type-argument object "mcrypt context" caller))
+  (if (alien-null? (mcrypt-context-alien object))
+      (error:bad-range-argument object caller)))
+
+(define (guarantee-subbytevector object start end operator)
+  (guarantee bytevector? object operator)
+  (guarantee index-fixnum? start operator)
+  (guarantee index-fixnum? end operator)
+  (if (not (fix:<= start end))
+      (error:bad-range-argument start operator))
+  (if (not (fix:<= end (bytevector-length object)))
+      (error:bad-range-argument end operator)))
 
 (define (mcrypt-open-module algorithm mode)
   (init!)
@@ -143,8 +154,7 @@ USA.
            (string->utf8 algorithm) 0 (string->utf8 mode) 0)
     (if (alien-null? alien)
        (error "Failed to open mcrypt module:"
-              (utf8->string
-               (C-peek-cstring (C-call "scmcrypt_get_ltdlerror")))))
+              (C-peek-cstring (C-call "scmcrypt_get_ltdlerror"))))
     context))
 
 (define (make-mcrypt-context-cleanup alien)
@@ -160,31 +170,42 @@ USA.
                  key (bytevector-length key) init-vector)))
     (if (< code 0)
        (error "Error code signalled by mcrypt_generic_init:"
-              (utf8->string
-               (C-peek-cstring (C-call "mcrypt_strerror"
-                                       (make-alien '(const (* char)))
-                                       code)))))))
+              (C-peek-cstring (C-call "mcrypt_strerror"
+                                      (make-alien '(const (* char)))
+                                      code))))))
+
+(define-integrable (make-mcrypt-transform! name procedure)
+  (lambda (context bytes start end)
+    (guarantee-mcrypt-context context name)
+    (guarantee-subbytevector bytes start end name)
+    (let ((code (procedure context bytes start end)))
+      (if (< code 0)
+         (error (string "Error code signalled by "name":") code)))))
+
+(define mcrypt-encrypt!
+  (make-mcrypt-transform!
+   'mcrypt-encrypt!
+   (named-lambda (mcrypt_generic context bytes start end)
+     (C-call "scmcrypt_generic" (mcrypt-context-alien context)
+            bytes start end))))
+
+(define mcrypt-decrypt!
+  (make-mcrypt-transform!
+   'mcrypt-decrypt!
+   (named-lambda (mdecrypt_generic context bytes start end)
+     (C-call "scmdecrypt_generic" (mcrypt-context-alien context)
+            bytes start end))))
 
 (define (mcrypt-encrypt context input input-start input-end
                        output output-start encrypt?)
-  (guarantee-mcrypt-context context 'MCRYPT-ENCRYPT)
+  (guarantee-mcrypt-context context 'mcrypt-encrypt)
   (guarantee bytevector? input 'mcrypt-encrypt)
   (guarantee bytevector? output 'mcrypt-encrypt)
-  (bytevector-copy! output output-start input input-start input-end)
-  (let ((code
-        (let ((alien (mcrypt-context-alien context))
-              (start output-start)
-              (end (+ output-start (- input-end input-start))))
-          (if encrypt?
-              (C-call "scmcrypt_generic" alien output start end)
-              (C-call "scmdecrypt_generic" alien output start end)))))
-    (if (< code 0)
-       (error (string-append "Error code signalled by "
-                             (if encrypt?
-                                 "mcrypt_generic"
-                                 "mdecrypt_generic")
-                             ":")
-              code))))
+  ((if encrypt? mcrypt-encrypt! mcrypt-decrypt!)
+   context
+   output
+   output-start
+   (bytevector-copy! output output-start input input-start input-end)))
 
 (define (mcrypt-end context)
   (let ((alien (mcrypt-context-alien context)))
@@ -199,59 +220,62 @@ USA.
   (lambda (object)
     (cond ((mcrypt-context? object)
           (context-op object))
-         ((string? object)
+         ((bytevector? object)
           (init!)
           (module-op object))
+         ((string? object)
+          (init!)
+          (module-op (string->utf8 object)))
          (else
           (error:wrong-type-argument object "mcrypt context" name)))))
 
 (define mcrypt-self-test
   (mcrypt-generic-unary
-   'MCRYPT-SELF-TEST
+   'mcrypt-self-test
    (named-lambda (mcrypt-enc-self-test context)
      (C-call "mcrypt_enc_self_test" (mcrypt-context-alien context)))
    (named-lambda (mcrypt-module-self-test module-name)
-     (C-call "mcrypt_module_self_test" (string->utf8 module-name) 0))))
+     (C-call "mcrypt_module_self_test" module-name 0))))
 
 (define mcrypt-block-algorithm-mode?
   (mcrypt-generic-unary
-   'MCRYPT-BLOCK-ALGORITHM-MODE?
+   'mcrypt-block-algorithm-mode?
    (named-lambda (mcrypt-enc-is-block-algorithm-mode? context)
      (C-call "mcrypt_enc_is_block_algorithm_mode"
             (mcrypt-context-alien context)))
    (named-lambda (mcrypt-module-is-block-algorithm-mode? name)
-     (C-call "mcrypt_module_is_block_algorithm_mode" (string->utf8 name) 0))))
+     (C-call "mcrypt_module_is_block_algorithm_mode" name 0))))
 
 (define mcrypt-block-algorithm?
   (mcrypt-generic-unary
-   'MCRYPT-BLOCK-ALGORITHM?
+   'mcrypt-block-algorithm?
    (named-lambda (mcrypt-enc-is-block-algorithm context)
      (C-call "mcrypt_enc_is_block_algorithm"
             (mcrypt-context-alien context)))
    (named-lambda (mcrypt-module-is-block-algorithm name)
-     (C-call "mcrypt_module_is_block_algorithm" (string->utf8 name) 0))))
+     (C-call "mcrypt_module_is_block_algorithm" name 0))))
 \f
 (define mcrypt-block-mode?
   (mcrypt-generic-unary
-   'MCRYPT-BLOCK-MODE?
+   'mcrypt-block-mode?
    (named-lambda (mcrypt-enc-is-block-mode context)
      (C-call "mcrypt_enc_is_block_mode"
             (mcrypt-context-alien context)))
    (named-lambda (mcrypt-module-is-block-mode name)
-     (C-call "mcrypt_module_is_block_mode" (string->utf8 name) 0))))
+     (C-call "mcrypt_module_is_block_mode" name 0))))
 
 (define mcrypt-key-size
   (mcrypt-generic-unary
-   'MCRYPT-KEY-SIZE
+   'mcrypt-key-size
    (named-lambda (mcrypt-enc-get-key-size context)
      (C-call "mcrypt_enc_get_key_size"
             (mcrypt-context-alien context)))
    (named-lambda (mcrypt-module-get-algo-key-size name)
-     (C-call "mcrypt_module_get_algo_key_size" (string->utf8 name) 0))))
+     (C-call "mcrypt_module_get_algo_key_size" name 0))))
 
 (define mcrypt-supported-key-sizes
   (mcrypt-generic-unary
-   'MCRYPT-SUPPORTED-KEY-SIZES
+   'mcrypt-supported-key-sizes
    (named-lambda (mcrypt-enc-get-supported-key-sizes context)
      (let ((mlist (malloc (C-sizeof "struct mcrypt_list")
                          '(struct |mcrypt_list|))))
@@ -262,48 +286,60 @@ USA.
         sizes)))
    (named-lambda (mcrypt-module-get-algo-supported-key-sizes name)
      (let ((mlist (make-mcrypt-size-list)))
-       (C-call "scmcrypt_module_get_algo_supported_key_sizes"
-              (string->utf8 name) 0 mlist)
+       (C-call "scmcrypt_module_get_algo_supported_key_sizes" name 0 mlist)
        (let ((sizes (mcrypt-size-list-elements mlist)))
         (free-mcrypt-size-list mlist)
         sizes)))))
 
 (define (mcrypt-init-vector-size context)
-  (guarantee-mcrypt-context context 'MCRYPT-INIT-VECTOR-SIZE)
+  (guarantee-mcrypt-context context 'mcrypt-init-vector-size)
   (C-call "mcrypt_enc_get_iv_size" (mcrypt-context-alien context)))
 
 (define (mcrypt-algorithm-name context)
-  (guarantee-mcrypt-context context 'MCRYPT-ALGORITHM-NAME)
+  (guarantee-mcrypt-context context 'mcrypt-algorithm-name)
   (mcrypt-context-algorithm context))
 
 (define (mcrypt-mode-name context)
-  (guarantee-mcrypt-context context 'MCRYPT-MODE-NAME)
+  (guarantee-mcrypt-context context 'mcrypt-mode-name)
   (mcrypt-context-mode context))
 
 (define (mcrypt-encrypt-port algorithm mode input output key init-vector
                             encrypt?)
   ;; Assumes that INPUT is in blocking mode.
-  (let ((context (mcrypt-open-module algorithm mode))
-       (input-buffer (make-bytevector 4096))
-       (output-buffer (make-bytevector 4096)))
-    (mcrypt-init context key init-vector)
+  ((port-transformer (lambda ()
+                      (let ((context (mcrypt-open-module algorithm mode)))
+                        (mcrypt-init context key init-vector)
+                        context))
+                    (if encrypt? mcrypt-encrypt! mcrypt-decrypt!)
+                    mcrypt-end)
+   input
+   output))
+
+(define (port-transformer initialize update finalize)
+  (lambda (input-port output-port)
+    (call-with-buffer #x1000
+      (lambda (buffer)
+       (let ((context (initialize)))
+         (let loop ()
+           (let ((n (read-bytevector! buffer input-port)))
+             (if (and n (not (eof-object? n)) (fix:> n 0))
+                 (begin
+                   (update context buffer 0 n)
+                   (let ((n* (write-bytevector buffer output-port 0 n)))
+                     (if (not (eqv? n n*))
+                         (error "Short write (requested, actual):" n n*)))
+                   (loop)))))
+         (finalize context))))))
+
+(define (call-with-buffer n procedure)
+  (let ((buffer (make-bytevector n)))
     (dynamic-wind
-     (lambda ()
-       unspecific)
-     (lambda ()
-       (let loop ()
-        (let ((n (read-bytevector! input-buffer input)))
-          (if (and (not (eof-object? n))
-                   (not (= 0 n)))
-              (begin
-                (mcrypt-encrypt context input-buffer 0 n output-buffer 0
-                                encrypt?)
-                (write-bytevector output-buffer output 0 n)
-                (loop)))))
-       (mcrypt-end context))
-     (lambda ()
-       (bytevector-fill! input-buffer 0)
-       (bytevector-fill! output-buffer 0)))))
+       (lambda ()
+         unspecific)
+       (lambda ()
+         (procedure buffer))
+       (lambda ()
+         (bytevector-fill! buffer 0)))))
 \f
 ;;;; Mcrypt size lists.
 
@@ -357,7 +393,7 @@ USA.
       (let loop ((i 0))
        (if (< i size)
            (begin
-             (vector-set! vector i (utf8->string (C-peek-cstringp! elements)))
+             (vector-set! vector i (C-peek-cstringp! elements))
              (loop (1+ i)))))
       vector)))
 
index 0b26cc8aeb1eadfad70030ee1f964ee1efb5663a..7e07103d5507f6f620142c3b1dead99b70492e2d 100644 (file)
@@ -22,8 +22,17 @@ along with MIT/GNU Scheme; if not, write to the Free Software
 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
 02110-1301, USA.
 
+mit-scheme-md5 0.2 - Matt Birkholz, 2017-05-18
+==============================================
+
+Use byte vectors for binary data instead of strings.  Thus all digests
+are now byte vectors.  Other changes: md5-bytevector was added,
+md5-string takes optional start and end indices, so md5-substring was
+removed, and md5-sum->hexadecimal and md5-sum->number were removed.
+The latter can be replaced by bytevector->hexadecimal and bytevector->
+exact-nonnegative-integer respectively.
+
 mit-scheme-md5 0.1 - Matt Birkholz, 2016-02-19
 ==============================================
 
-* Use libtool and automake, rather than the microcode's disappearing
-  module support.
+Use libtool and automake.
index 73c611df9155931f2c7ece418eda5aaa9c510e91..cda8de0d9ec9f621c67a0caee58e9505bed7a4d8 100644 (file)
@@ -27,11 +27,11 @@ USA.
 ;;;; Test the MD5 option.
 
 (let ((sample "Some text to hash."))
-  (let ((hash (md5-sum->hexadecimal (md5-string sample))))
+  (let ((hash (bytevector->hexadecimal (md5-string sample))))
     (if (not (string=? hash "C8E89C4CBF3ABF9AA758D691CBE4B784"))
        (error "Bad hash for sample text:" hash)))
   (call-with-output-file "sample"
     (lambda (port) (write-string sample port) (newline port)))
-  (let ((hash (md5-sum->hexadecimal (md5-file "sample"))))
+  (let ((hash (bytevector->hexadecimal (md5-file "sample"))))
     (if (not (string=? hash "43EB9ECCB88C329721925EFC04843AF1"))
        (error "Bad hash for sample file:" hash))))
\ No newline at end of file
index 4507658aa83314f52488513808817e07d0c49b7b..ece7a2878aab8d9adfa5469c8fec8a60d0de7fa3 100644 (file)
@@ -29,14 +29,10 @@ USA.
 (define-package (md5)
   (files "md5")
   (parent ())
-  ;; You'll have to import these from (global-definitions md5/).  They
-  ;; are currently bound in () by exports from (runtime crypto).
   (export (md5 global)
+         md5-bytevector
          md5-file
-         md5-string
-         md5-substring
-         md5-sum->hexadecimal
-         md5-sum->number))
+         md5-string))
 
 (define-package (md5 global)
   ;; Just to get cref to analyze whether all exports are defined.
index e4a4ff6e3af762dfaa2aacaa6f9ba3f9670f4b4e..abf60355c4de8d71ef24213e3b0ab9619a277276 100644 (file)
@@ -31,53 +31,52 @@ USA.
 \f
 (C-include "md5")
 
-(define-integrable (%md5-init)
+(define (%md5-init)
   (let ((context (make-bytevector (C-sizeof "MD5_CTX"))))
     (C-call "MD5_INIT" context)
     context))
 
-(define-integrable (%md5-update context bytevector start end)
+(define (%md5-update context bytevector start end)
   (C-call "do_MD5_UPDATE" context bytevector start end))
 
-(define-integrable (%md5-final context)
+(define (%md5-final context)
   (let ((result (make-bytevector (C-enum "MD5_DIGEST_LENGTH"))))
     (C-call "do_MD5_FINAL" context result)
     result))
 
 (define (md5-file filename)
   (call-with-binary-input-file filename
-    (lambda (port)
-      (let ((buffer (make-bytevector 4096))
-           (context (%md5-init)))
-       (dynamic-wind (lambda ()
-                       unspecific)
-                     (lambda ()
-                       (let loop ()
-                         (let ((n (read-bytevector! buffer port)))
-                           (if (or (eof-object? n)
-                                   (fix:= 0 n))
-                               (%md5-final context)
-                               (begin
-                                 (%md5-update context buffer 0 n)
-                                 (loop))))))
-                     (lambda ()
-                       (bytevector-fill! buffer 0)))))))
-
-(define (md5-string string)
-  (md5-bytevector (string->utf8 string)))
-
-(define (md5-substring string start end)
-  (md5-bytevector (string->utf8 (substring string start end))))
-
-(define (md5-bytevector bytevector)
-  (let ((context (%md5-init)))
-    (%md5-update context bytevector 0 (bytevector-length bytevector))
-    (%md5-final context)))
+    (port-consumer %md5-init %md5-update %md5-final)))
+
+(define (md5-string string #!optional start end)
+  (md5-bytevector (string->utf8 string start end)))
 
-(define (md5-sum->number sum)
-  (let ((l (bytevector-length sum)))
-    (do ((i 0 (fix:+ i 1))
-        (n 0 (+ (* n #x100) (bytevector-u8-ref sum i))))
-       ((fix:= i l) n))))
+(define (md5-bytevector bytes #!optional start end)
+  (let ((end (fix:end-index end (bytevector-length bytes) 'md5-bytevector))
+       (start (fix:start-index start end 'md5-bytevector))
+       (context (%md5-init)))
+    (%md5-update context bytes start end)
+    (%md5-final context)))
 
-(define md5-sum->hexadecimal bytevector->hexadecimal)
\ No newline at end of file
+(define (port-consumer initialize update finalize)
+  (lambda (port)
+    (call-with-buffer #x1000
+      (lambda (buffer)
+       (let ((context (initialize)))
+         (let loop ()
+           (let ((n (read-bytevector! buffer port)))
+             (if (and n (not (eof-object? n)))
+                 (begin
+                   (update context buffer 0 n)
+                   (loop)))))
+         (finalize context))))))
+
+(define (call-with-buffer n procedure)
+  (let ((buffer (make-bytevector n)))
+    (dynamic-wind
+       (lambda ()
+         unspecific)
+       (lambda ()
+         (procedure buffer))
+       (lambda ()
+         (bytevector-fill! buffer 0)))))
\ No newline at end of file
index 46c7402d3e3b1e2ea726e3d0f1efab6d2f4020fb..3af0d8574e31ecc47f925c763df55dcee2837c79 100644 (file)
@@ -22,8 +22,18 @@ along with MIT/GNU Scheme; if not, write to the Free Software
 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
 02110-1301, USA.
 
+mit-scheme-mhash 0.2 - Matt Birkholz, 2017-05-18
+================================================
+
+Use byte vectors for binary data instead of strings.  Thus all digests
+and salts now must be byte vectors; the -update procedures must be fed
+byte subvectors, not substrings.  Other changes: mhash-bytevector was
+added, mhash-string takes optional start and end indices, so mhash-
+substring was removed, and mhash-sum->hexadecimal and mhash-sum->
+number were removed.  The latter can be replaced by bytevector->
+hexadecimal and bytevector->exact-nonnegative-integer respectively.
+
 mit-scheme-mhash 0.1 - Matt Birkholz, 2016-02-19
 ================================================
 
-* Use libtool and automake, rather than the microcode's disappearing
-  module support.
+Use libtool and automake.
index 51d0b7ff00ab009de8578d9f1d4b5b5367471b5b..fc73c6e61492334d23020e26b31312906bcfd3b2 100644 (file)
@@ -27,11 +27,11 @@ USA.
 ;;;; Test the MHASH option.
 
 (let ((sample "Some text to hash."))
-  (let ((hash (mhash-sum->hexadecimal (mhash-string 'MD5 sample))))
+  (let ((hash (bytevector->hexadecimal (mhash-string 'md5 sample))))
     (if (not (string=? hash "C8E89C4CBF3ABF9AA758D691CBE4B784"))
        (error "Bad hash for sample text:" hash)))
   (call-with-output-file "sample"
     (lambda (port) (write-string sample port) (newline port)))
-  (let ((hash (mhash-sum->hexadecimal (mhash-file 'MD5 "sample"))))
+  (let ((hash (bytevector->hexadecimal (mhash-file 'md5 "sample"))))
     (if (not (string=? hash "43EB9ECCB88C329721925EFC04843AF1"))
        (error "Bad hash for sample file:" hash))))
\ No newline at end of file
index 1da5b316b03833860a233b19c9ff9100d55f47a2..5264c21c9f89f88b65adf202badabc4a1993ca0b 100644 (file)
@@ -30,10 +30,9 @@ USA.
   (files "mhash")
   (parent ())
   (initialization (initialize-package!))
-  ;; You'll have to import these from (global-definitions mhash/).
-  ;; They are currently bound in () by exports from (runtime crypto).
   (export (mhash global)
          make-mhash-keygen-type
+         mhash-bytevector
          mhash-context?
          mhash-end
          mhash-file
@@ -51,9 +50,6 @@ USA.
          mhash-keygen-uses-hash-algorithm
          mhash-keygen-uses-salt?
          mhash-string
-         mhash-substring
-         mhash-sum->hexadecimal
-         mhash-sum->number
          mhash-type-names
          mhash-update))
 
index 8be528ee8b94e0de7240fa17bf59f04dff785a48..c618699a5074789edcf8776e6613564ec821f4a5 100644 (file)
@@ -24,7 +24,7 @@ USA.
 
 |#
 
-;;;; The MHASH option.
+;;;; The mhash option.
 ;;; package: (mhash)
 
 (declare (usual-integrations))
@@ -132,17 +132,17 @@ USA.
 (define-structure mhash-context mutex alien id)
 (define-structure mhash-hmac-context mutex alien id)
 
-(define (guarantee-mhash-context object procedure)
+(define (guarantee-mhash-context object caller)
   (if (not (mhash-context? object))
-      (error:wrong-type-argument object "mhash context" procedure))
+      (error:wrong-type-argument object "mhash context" caller))
   (if (alien-null? (mhash-context-alien object))
-      (error:bad-range-argument object procedure)))
+      (error:bad-range-argument object caller)))
 
-(define (guarantee-mhash-hmac-context object procedure)
+(define (guarantee-mhash-hmac-context object caller)
   (if (not (mhash-hmac-context? object))
-      (error:wrong-type-argument object "mhash HMAC context" procedure))
+      (error:wrong-type-argument object "mhash HMAC context" caller))
   (if (alien-null? (mhash-hmac-context-alien object))
-      (error:bad-range-argument object procedure)))
+      (error:bad-range-argument object caller)))
 
 (define (guarantee-subbytevector object start end operator)
   (guarantee bytevector? object operator)
@@ -180,10 +180,10 @@ USA.
 
 (define (mhash-get-block-size name)
   (C-call "mhash_get_block_size"
-         (mhash-name->id name 'MHASH-GET-BLOCK-SIZE)))
+         (mhash-name->id name 'mhash-get-block-size)))
 
 (define (mhash-init name)
-  (let ((id (mhash-name->id name 'MHASH-INIT))
+  (let ((id (mhash-name->id name 'mhash-init))
        (alien (make-alien '|MHASH_INSTANCE|)))
     (let ((context (make-mhash-context (make-thread-mutex) alien id)))
       (add-context-cleanup context)
@@ -194,14 +194,14 @@ USA.
              (error "Unable to allocate mhash context:" name))))
       context)))
 
-(define (mhash-update context bytevector start end)
-  (guarantee-subbytevector bytevector start end 'MHASH-UPDATE)
-  (with-context-locked-open context 'MHASH-UPDATE
+(define (mhash-update context bytes start end)
+  (guarantee-subbytevector bytes start end 'mhash-update)
+  (with-context-locked-open context 'mhash-update
     (lambda (alien)
-      (C-call "do_mhash" alien bytevector start end))))
+      (C-call "do_mhash" alien bytes start end))))
 
 (define (mhash-end context)
-  (with-context-locked-open context 'MHASH-END
+  (with-context-locked-open context 'mhash-end
     (lambda (alien)
       (let* ((id (mhash-context-id context))
             (size (C-call "mhash_get_block_size" id))
@@ -211,12 +211,13 @@ USA.
        digest))))
 
 (define (mhash-hmac-init name key)
-  (guarantee bytevector? key 'hmash-hmac-init)
-  (let ((id (mhash-name->id name 'MHASH-HMAC-INIT))
+  (let ((id (mhash-name->id name 'mhash-hmac-init))
        (alien (make-alien '|MHASH_INSTANCE|)))
     (let ((context (make-mhash-hmac-context (make-thread-mutex) alien id))
          (block-size (C-call "mhash_get_hash_pblock" id))
-         (key-size (bytevector-length key)))
+         (key-size (if (bytevector? key)
+                       (bytevector-length key)
+                       (string-length key))))
       (add-hmac-context-cleanup context)
       (with-hmac-context-locked context
        (lambda ()
@@ -225,14 +226,15 @@ USA.
              (error "Unable to allocate mhash HMAC context:" name))))
       context)))
 
-(define (mhash-hmac-update context bytevector start end)
-  (guarantee-subbytevector bytevector start end 'MHASH-HMAC-UPDATE)
-  (with-hmac-context-locked-open context 'MHASH-HMAC-UPDATE
+(define (mhash-hmac-update context bytes start end)
+  (guarantee-mhash-hmac-context context 'mhash-hmac-update)
+  (guarantee-subbytevector bytes start end 'mhash-hmac-update)
+  (with-hmac-context-locked-open context 'mhash-hmac-update
     (lambda (alien)
-      (C-call "do_mhash" alien bytevector start end))))
+      (C-call "do_mhash" alien bytes start end))))
 
 (define (mhash-hmac-end context)
-  (with-hmac-context-locked-open context 'MHASH-HMAC-END
+  (with-hmac-context-locked-open context 'mhash-hmac-end
     (lambda (alien)
       (let* ((id (mhash-hmac-context-id context))
             (size (C-call "mhash_get_block_size" id))
@@ -243,10 +245,10 @@ USA.
 \f
 (define mhash-keygen-names)
 
-(define (keygen-name->id name procedure)
+(define (keygen-name->id name caller)
   (let ((n (vector-length mhash-keygen-names)))
     (let loop ((i 0))
-      (cond ((fix:= i n) (error:bad-range-argument name procedure))
+      (cond ((fix:= i n) (error:bad-range-argument name caller))
            ((eq? name (vector-ref mhash-keygen-names i)) i)
            (else (loop (fix:+ i 1)))))))
 
@@ -255,28 +257,27 @@ USA.
 
 (define (mhash-keygen-uses-salt? name)
   (not (zero? (C-call "mhash_keygen_uses_salt"
-                     (keygen-name->id name 'MHASH-KEYGEN-USES-SALT?)))))
+                     (keygen-name->id name 'mhash-keygen-uses-salt?)))))
 
 (define (mhash-keygen-uses-count? name)
   (not (zero? (C-call "mhash_keygen_uses_count"
-                     (keygen-name->id name 'MHASH-KEYGEN-USES-COUNT?)))))
+                     (keygen-name->id name 'mhash-keygen-uses-count?)))))
 
 (define (mhash-keygen-uses-hash-algorithm name)
   (C-call "mhash_keygen_uses_hash_algorithm"
-         (keygen-name->id name 'MHASH-KEYGEN-USES-HASH-ALGORITHM)))
+         (keygen-name->id name 'mhash-keygen-uses-hash-algorithm)))
 
 (define (mhash-keygen-salt-size name)
   (C-call "mhash_get_keygen_salt_size"
-         (keygen-name->id name 'MHASH-KEYGEN-SALT-SIZE)))
+         (keygen-name->id name 'mhash-keygen-salt-size)))
 
 (define (mhash-keygen-max-key-size name)
   (C-call "mhash_get_keygen_max_key_size"
-         (keygen-name->id name 'MHASH-KEYGEN-MAX-KEY-SIZE)))
+         (keygen-name->id name 'mhash-keygen-max-key-size)))
 
 (define (mhash-keygen type passphrase #!optional salt)
-
   (if (not (mhash-keygen-type? type))
-      (error:wrong-type-argument type "mhash type" 'MHASH-KEYGEN))
+      (error:wrong-type-argument type "mhash type" 'mhash-keygen))
   (let ((keygenid (mhash-keygen-type-id type))
        (keyword-size (mhash-keygen-type-key-length type))
        (passbytes (string->utf8 passphrase)))
@@ -289,7 +290,7 @@ USA.
        (let ((name (vector-ref params i)))
          (if (not name)
              0
-             (mhash-name->id name 'MHASH-KEYGEN))))
+             (mhash-name->id name 'mhash-keygen))))
 
       (if (not (or (zero? max-key-size)
                   (< max-key-size (bytevector-length keyword))))
@@ -330,15 +331,13 @@ USA.
   (parameter-vector #f read-only #t))
 
 (define (make-mhash-keygen-type name key-length hash-names #!optional count)
-  (if (not (index-fixnum? key-length))
-      (error:wrong-type-argument key-length "key length"
-                                'MAKE-MHASH-KEYGEN-TYPE))
+  (guarantee index-fixnum? key-length 'make-mhash-keygen-type)
   (if (not (let ((m (mhash-keygen-max-key-size name)))
             (or (= m 0)
                 (<= key-length m))))
-      (error:bad-range-argument key-length 'MAKE-MHASH-KEYGEN-TYPE))
+      (error:bad-range-argument key-length 'make-mhash-keygen-type))
   (%make-mhash-keygen-type
-   (keygen-name->id name 'MAKE-MHASH-KEYGEN-TYPE)
+   (keygen-name->id name 'make-mhash-keygen-type)
    key-length
    (let ((n-algorithms (mhash-keygen-uses-hash-algorithm name))
         (hash-names
@@ -360,13 +359,13 @@ USA.
                     (error "Iteration count required:" name))
                 (if (not (and (exact-integer? count)
                               (positive? count)))
-                    (error:bad-range-argument count 'MAKE-MHASH-KEYGEN-TYPE))
+                    (error:bad-range-argument count 'make-mhash-keygen-type))
                 count)))
         (do ((i 2 (fix:+ i 1))
              (names hash-names (cdr names)))
             ((fix:= i n))
           (vector-set! v i
-                       (mhash-name->id (car names) 'MAKE-MHASH-KEYGEN-TYPE)))
+                       (mhash-name->id (car names) 'make-mhash-keygen-type)))
         v)))))
 \f
 (define (initialize-mhash-variables!)
@@ -379,10 +378,10 @@ USA.
                          (lambda (alien)
                            (C-call "mhash_get_hash_name"
                                    alien hashid))))
-                 (bytevector (and (not (alien-null? alien))
-                                         (c-peek-cstring alien))))
+                 (string (and (not (alien-null? alien))
+                              (c-peek-cstring alien))))
             (free alien)
-            bytevector))))
+            string))))
   (set! mhash-keygen-names
        (make-names-vector
         (lambda () (C-call "mhash_keygen_count"))
@@ -392,10 +391,10 @@ USA.
                          (lambda (alien)
                            (C-call "mhash_get_keygen_name"
                                    alien keygenid))))
-                 (bytevector (and (not (alien-null? alien))
-                                  (c-peek-cstring alien))))
+                 (string (and (not (alien-null? alien))
+                              (c-peek-cstring alien))))
             (free alien)
-            bytevector)))))
+            string)))))
 
 (define (reset-mhash-variables!)
   (for-each (lambda (weak) (alien-null! (weak-cdr weak))) mhash-contexts)
@@ -407,41 +406,42 @@ USA.
 
 (define (mhash-file hash-type filename)
   (call-with-binary-input-file filename
-    (lambda (port)
-      (let ((buffer (make-bytevector 4096))
-           (context (mhash-init hash-type)))
-       (dynamic-wind (lambda ()
-                       unspecific)
-                     (lambda ()
-                       (let loop ()
-                         (let ((n (read-bytevector! buffer port)))
-                           (if (or (eof-object? n)
-                                   (fix:= 0 n))
-                               (mhash-end context)
-                               (begin
-                                 (mhash-update context buffer 0 n)
-                                 (loop))))))
-                     (lambda ()
-                       (bytevector-fill! buffer 0)))))))
-
-(define (mhash-string hash-type string)
-  (mhash-bytevector hash-type (string->utf8 string)))
-
-(define (mhash-substring hash-type string start end)
-  (mhash-bytevector hash-type (string->utf8 (substring string start end))))
-
-(define (mhash-bytevector hash-type bytevector)
-  (let ((context (mhash-init hash-type)))
-    (mhash-update context bytevector 0 (bytevector-length bytevector))
+    (port-consumer (lambda () (mhash-init hash-type))
+                  mhash-update
+                  mhash-end)))
+
+(define (mhash-string hash-type string #!optional start end)
+  (mhash-bytevector hash-type (string->utf8 string start end)))
+
+(define (mhash-bytevector hash-type bytes #!optional start end)
+  (let* ((end (fix:end-index end (bytevector-length bytes) 'mhash-bytevector))
+        (start (fix:start-index start end 'mhash-bytevector))
+        (context (mhash-init hash-type)))
+    (mhash-update context bytes start end)
     (mhash-end context)))
 
-(define (mhash-sum->number sum)
-  (let ((l (bytevector-length sum)))
-    (do ((i 0 (fix:+ i 1))
-        (n 0 (+ (* n #x100) (bytevector-u8-ref sum i))))
-       ((fix:= i l) n))))
-
-(define mhash-sum->hexadecimal bytevector->hexadecimal)
+(define (port-consumer initialize update finalize)
+  (lambda (port)
+    (call-with-buffer #x1000
+      (lambda (buffer)
+       (let ((context (initialize)))
+         (let loop ()
+           (let ((n (read-bytevector! buffer port)))
+             (if (and n (not (eof-object? n)))
+                 (begin
+                   (update context buffer 0 n)
+                   (loop)))))
+         (finalize context))))))
+
+(define (call-with-buffer n procedure)
+  (let ((buffer (make-bytevector n)))
+    (dynamic-wind
+       (lambda ()
+         unspecific)
+       (lambda ()
+         (procedure buffer))
+       (lambda ()
+         (bytevector-fill! buffer 0)))))
 \f
 ;;;; Package initialization
 
@@ -459,7 +459,7 @@ USA.
        (vector-set! v i
                     (let ((name (get-name i)))
                       (and name
-                           (intern (utf8->string name))))))
+                           (intern name)))))
       v)))
 
 (define (names-vector->list v)