;;;; Test the BLOWFISH option.
-(if (not (blowfish-available?))
- (error "BLOWFISH plugin not found")
- (let ((sample "Some text to encrypt and decrypt."))
- (call-with-binary-output-file "test"
- (lambda (output)
- (call-with-input-string sample
- (lambda (input)
- (blowfish-encrypt-port input output "secret"
- (write-blowfish-file-header output)
- #t)))))
- (let ((read-back
- (call-with-binary-input-file "test"
- (lambda (input)
- (call-with-output-string
- (lambda (output)
- (blowfish-encrypt-port input output "secret"
- (read-blowfish-file-header input)
- #f)))))))
- (if (not (string=? sample read-back))
- (error "sample did not decrypt correctly")))))
\ No newline at end of file
+(let ((sample "Some text to encrypt and decrypt."))
+ (call-with-binary-output-file "test"
+ (lambda (output)
+ (call-with-input-string sample
+ (lambda (input)
+ (blowfish-encrypt-port input output "secret"
+ (write-blowfish-file-header output)
+ #t)))))
+ (let ((read-back
+ (call-with-binary-input-file "test"
+ (lambda (input)
+ (call-with-output-string
+ (lambda (output)
+ (blowfish-encrypt-port input output "secret"
+ (read-blowfish-file-header input)
+ #f)))))))
+ (if (not (string=? sample read-back))
+ (error "sample did not decrypt correctly"))))
\ No newline at end of file
;; You'll have to import these from (global-definitions blowfish/).
;; They are currently bound in () by exports from (runtime blowfish).
(export (blowfish global)
- blowfish-available?
blowfish-cbc
blowfish-cfb64
blowfish-ecb
"a blowfish init-vector index"
operator)))
-(define (blowfish-available?)
- (plugin-available? "blowfish"))
-
(define (blowfish-encrypt-port input output key init-vector encrypt?)
;; Assumes that INPUT is in blocking mode.
(let ((key (blowfish-set-key key))
;;;; Test the GDBM option.
-(if (not (gdbm-available?))
- (error "GDBM plugin not found")
- (let ((filename.db "gdbm-check.db"))
- (ignore-errors (lambda () (delete-file filename.db)))
- (let ((dbf (gdbm-open filename.db 0 GDBM_WRCREAT #o660)))
- ;; Must be set before first store.
- (gdbm-setopt dbf GDBM_CACHESIZE 101)
-
- (gdbm-store dbf "Silly String" "Testing 1 2 3." GDBM_REPLACE)
- (if (not (condition?
- (ignore-errors
- (lambda () (gdbm-store dbf "NullString" "" GDBM_INSERT)))))
- (error "storing null content did not signal"))
- (if (not (condition?
- (ignore-errors
- (lambda () (gdbm-store dbf "" "NullString" GDBM_INSERT)))))
- (error "storing null key did not signal"))
- (if (not (eq? #t (gdbm-store dbf "Silly String" "Ahoy!" GDBM_REPLACE)))
- (error "replace produced wrong indication"))
- (if (not (eq? #f (gdbm-store dbf "Silly String" "Oy!" GDBM_INSERT)))
- (error "double insert produced no indication"))
-
- (gdbm-setopt dbf GDBM_SYNCMODE 1)
-
- (let ((content (gdbm-fetch dbf "Silly String")))
- (if (not (string=? "Ahoy!" content))
- (error "fetched:" content)))
- (let ((content (gdbm-fetch dbf "Missing String")))
- (if (not (eq? #f content))
- (error "missing fetched:" content)))
-
- (if (gdbm-exists? dbf "Missing String")
- (error "exists"))
- (if (not (gdbm-exists? dbf "Silly String"))
- (error "not exists"))
-
- (gdbm-delete dbf "Silly String")
- (if (gdbm-exists? dbf "Silly String")
- (error "not deleted"))
- (if (gdbm-delete dbf "Missing String")
- (error "deleted"))
-
- (let ((k (gdbm-firstkey dbf)))
- (if k
- (error "empty database returned a firstkey:" k)))
- (gdbm-store dbf "AString" "Testing 1 2 3." GDBM_INSERT)
- (gdbm-store dbf "ASecondString" "Testing 1 2 3." GDBM_REPLACE)
- (gdbm-store dbf "AThirdString" "Testing 1 2 3." GDBM_INSERT)
- #;(let ((keys (sort (gdbm-keys dbf) string<?)))
- (if (not (equal? keys '("ASecondString" "AString" "AThirdString")))
- (error "keys:" keys)))
-
- (gdbm-reorganize dbf)
- (gdbm-sync dbf)
- (gdbm-setopt dbf 'SYNCMODE #f)
- (gdbm-version)
- (gdbm-close dbf))
-
- (if (not (condition?
- (ignore-errors
- (lambda () (gdbm-open "notfound.db" 0 GDBM_READER 0)))))
- (error "opened a nonexistent database file:" gdbf))
- (let ((dbf2 (gdbm-open filename.db 0 GDBM_READER 0)))
- (let ((keys (sort (gdbm-keys dbf2) string<?)))
- (if (not (equal? keys '("ASecondString" "AString" "AThirdString")))
- (error "bogus keys:" keys))
- (map (lambda (key)
- (if (not (string=? "Testing 1 2 3." (gdbm-fetch dbf2 key)))
- (error "bogus content:" key)))
- keys))
- (gdbm-close dbf2))))
\ No newline at end of file
+(let ((filename.db "gdbm-check.db"))
+ (ignore-errors (lambda () (delete-file filename.db)))
+ (let ((dbf (gdbm-open filename.db 0 GDBM_WRCREAT #o660)))
+ ;; Must be set before first store.
+ (gdbm-setopt dbf GDBM_CACHESIZE 101)
+
+ (gdbm-store dbf "Silly String" "Testing 1 2 3." GDBM_REPLACE)
+ (if (not (condition?
+ (ignore-errors
+ (lambda () (gdbm-store dbf "NullString" "" GDBM_INSERT)))))
+ (error "storing null content did not signal"))
+ (if (not (condition?
+ (ignore-errors
+ (lambda () (gdbm-store dbf "" "NullString" GDBM_INSERT)))))
+ (error "storing null key did not signal"))
+ (if (not (eq? #t (gdbm-store dbf "Silly String" "Ahoy!" GDBM_REPLACE)))
+ (error "replace produced wrong indication"))
+ (if (not (eq? #f (gdbm-store dbf "Silly String" "Oy!" GDBM_INSERT)))
+ (error "double insert produced no indication"))
+
+ (gdbm-setopt dbf GDBM_SYNCMODE 1)
+
+ (let ((content (gdbm-fetch dbf "Silly String")))
+ (if (not (string=? "Ahoy!" content))
+ (error "fetched:" content)))
+ (let ((content (gdbm-fetch dbf "Missing String")))
+ (if (not (eq? #f content))
+ (error "missing fetched:" content)))
+
+ (if (gdbm-exists? dbf "Missing String")
+ (error "exists"))
+ (if (not (gdbm-exists? dbf "Silly String"))
+ (error "not exists"))
+
+ (gdbm-delete dbf "Silly String")
+ (if (gdbm-exists? dbf "Silly String")
+ (error "not deleted"))
+ (if (gdbm-delete dbf "Missing String")
+ (error "deleted"))
+
+ (let ((k (gdbm-firstkey dbf)))
+ (if k
+ (error "empty database returned a firstkey:" k)))
+ (gdbm-store dbf "AString" "Testing 1 2 3." GDBM_INSERT)
+ (gdbm-store dbf "ASecondString" "Testing 1 2 3." GDBM_REPLACE)
+ (gdbm-store dbf "AThirdString" "Testing 1 2 3." GDBM_INSERT)
+ #;(let ((keys (sort (gdbm-keys dbf) string<?)))
+ (if (not (equal? keys '("ASecondString" "AString" "AThirdString")))
+ (error "keys:" keys)))
+
+ (gdbm-reorganize dbf)
+ (gdbm-sync dbf)
+ (gdbm-setopt dbf 'SYNCMODE #f)
+ (gdbm-version)
+ (gdbm-close dbf))
+
+ (if (not (condition?
+ (ignore-errors
+ (lambda () (gdbm-open "notfound.db" 0 GDBM_READER 0)))))
+ (error "opened a nonexistent database file:" gdbf))
+ (let ((dbf2 (gdbm-open filename.db 0 GDBM_READER 0)))
+ (let ((keys (sort (gdbm-keys dbf2) string<?)))
+ (if (not (equal? keys '("ASecondString" "AString" "AThirdString")))
+ (error "bogus keys:" keys))
+ (map (lambda (key)
+ (if (not (string=? "Testing 1 2 3." (gdbm-fetch dbf2 key)))
+ (error "bogus content:" key)))
+ keys))
+ (gdbm-close dbf2)))
\ No newline at end of file
;; You'll have to import these from (global-definitions gdbm/).
;; They are currently bound in () by exports from (runtime gdbm).
(export (gdbm global)
- gdbm-available?
gdbm-close
gdbm-delete
gdbm-exists?
\f
(C-include "gdbm")
-(define (gdbm-available?)
- (plugin-available? "gdbm"))
-
;; Parameters to gdbm_open for READERS, WRITERS, and WRITERS who can
;; create the database.
(define GDBM_READER (C-enum "GDBM_READER")) ;A reader.
(let ((args (make-alien '|gdbm_args|))
(flagsnum (guarantee-gdbm-open-flags flags)))
(let ((gdbf (make-gdbf args (make-thread-mutex) filename)))
- (if (not (gdbm-available?))
- (error "GDBM support is not installed."))
(add-open-gdbf-cleanup gdbf)
(with-gdbf-locked
gdbf
(declare (ignore i))
(ascii->char (random 256))))))
-(if (not (mcrypt-available?))
- (error "MCRYPT plugin not found")
- (begin
- (if (not (member "tripledes" (mcrypt-algorithm-names)))
- (error "No tripledes."))
+(if (not (member "tripledes" (mcrypt-algorithm-names)))
+ (error "No tripledes."))
- (if (not (member "cfb" (mcrypt-mode-names)))
- (error "No cipher-feedback mode."))
+(if (not (member "cfb" (mcrypt-mode-names)))
+ (error "No cipher-feedback mode."))
- (let ((key (let ((sizes (mcrypt-supported-key-sizes "tripledes")))
- (if (not (vector? sizes))
- (error "Bogus key sizes for tripledes."))
- (random-string (vector-ref sizes
- (-1+ (vector-length sizes))))))
- (init-vector (let* ((context
- ;; Unfortunately the size is
- ;; available only from the MCRYPT(?)!
- (mcrypt-open-module "tripledes" "cfb"))
- (size (mcrypt-init-vector-size context)))
- (mcrypt-end context)
- (random-string size))))
+(let ((key (let ((sizes (mcrypt-supported-key-sizes "tripledes")))
+ (if (not (vector? sizes))
+ (error "Bogus key sizes for tripledes."))
+ (random-string (vector-ref sizes
+ (-1+ (vector-length sizes))))))
+ (init-vector (let* ((context
+ ;; Unfortunately the size is
+ ;; available only from the MCRYPT(?)!
+ (mcrypt-open-module "tripledes" "cfb"))
+ (size (mcrypt-init-vector-size context)))
+ (mcrypt-end context)
+ (random-string size))))
- (call-with-input-file "mcrypt.scm"
- (lambda (input)
- (call-with-output-file "encrypted"
- (lambda (output)
- (let ((copy (string-copy init-vector)))
- (mcrypt-encrypt-port "tripledes" "cfb"
- input output key init-vector #t)
- (if (not (string=? copy init-vector))
- (error "Init vector modified.")))))))
+ (call-with-input-file "mcrypt.scm"
+ (lambda (input)
+ (call-with-output-file "encrypted"
+ (lambda (output)
+ (let ((copy (string-copy init-vector)))
+ (mcrypt-encrypt-port "tripledes" "cfb"
+ input output key init-vector #t)
+ (if (not (string=? copy init-vector))
+ (error "Init vector modified.")))))))
- (call-with-input-file "encrypted"
- (lambda (input)
- (call-with-output-file "decrypted"
- (lambda (output)
- (mcrypt-encrypt-port "tripledes" "cfb"
- input output key init-vector #f))))))
+ (call-with-input-file "encrypted"
+ (lambda (input)
+ (call-with-output-file "decrypted"
+ (lambda (output)
+ (mcrypt-encrypt-port "tripledes" "cfb"
+ input output key init-vector #f))))))
- (if (not (= 0 (run-shell-command "cmp mcrypt.scm decrypted")))
- (error "En/Decryption failed."))))
\ No newline at end of file
+(if (not (= 0 (run-shell-command "cmp mcrypt.scm decrypted")))
+ (error "En/Decryption failed."))
\ No newline at end of file
(export (mcrypt global)
mcrypt-algorithm-name
mcrypt-algorithm-names
- mcrypt-available?
mcrypt-block-algorithm-mode?
mcrypt-block-algorithm?
mcrypt-block-mode?
(define mcrypt-algorithm-names-vector)
(define mcrypt-mode-names-vector)
-(define (mcrypt-available?)
- (plugin-available? "mcrypt"))
-
(define (init!)
(if (not mcrypt-initialized?)
(begin
;;;; Test the MD5 option.
-(if (not (md5-available?))
- (error "MD5 plugin not found")
- (let ((sample "Some text to hash."))
- (let ((hash (md5-sum->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"))))
- (if (not (string=? hash "43eb9eccb88c329721925efc04843af1"))
- (error "Bad hash for sample file:" hash)))))
\ No newline at end of file
+(let ((sample "Some text to hash."))
+ (let ((hash (md5-sum->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"))))
+ (if (not (string=? hash "43eb9eccb88c329721925efc04843af1"))
+ (error "Bad hash for sample file:" hash))))
\ No newline at end of file
;; You'll have to import these from (global-definitions md5/). They
;; are currently bound in () by exports from (runtime crypto).
(export (md5 global)
- md5-available?
md5-file
md5-string
md5-substring
\f
(C-include "md5")
-(define (mhash-available?)
- (plugin-available? "mhash"))
-
(define (%md5-init)
;; Create and return an MD5 digest context.
(let ((context (make-string (C-sizeof "MD5_CTX"))))
(C-call "do_MD5" string length result)
result))
-(define (md5-available?)
- (or (mhash-available?)
- (%md5-available?)))
-
-(define (%md5-available?)
- (plugin-available? "md5"))
-
(define (md5-file filename)
- (cond ((mhash-available?)
- (mhash-file 'MD5 filename))
- ((%md5-available?)
- (%md5-file filename))
- (else
- (error "This Scheme system was built without MD5 support."))))
-
-(define (%md5-file filename)
(call-with-binary-input-file filename
(lambda (port)
(let ((buffer (make-string 4096))
(md5-substring string 0 (string-length string)))
(define (md5-substring string start end)
- (cond ((mhash-available?)
- (mhash-substring 'MD5 string start end))
- ((%md5-available?)
- (%md5-substring string start end))
- (else
- (error "This Scheme system was built without MD5 support."))))
-
-(define (%md5-substring string start end)
(let ((context (%md5-init)))
(%md5-update context string start end)
(%md5-final context)))
;;;; Test the MHASH option.
-(if (not (mhash-available?))
- (error "MHASH plugin not found")
- (let ((sample "Some text to hash."))
- (let ((hash (mhash-sum->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"))))
- (if (not (string=? hash "43eb9eccb88c329721925efc04843af1"))
- (error "Bad hash for sample file:" hash)))))
\ No newline at end of file
+(let ((sample "Some text to hash."))
+ (let ((hash (mhash-sum->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"))))
+ (if (not (string=? hash "43eb9eccb88c329721925efc04843af1"))
+ (error "Bad hash for sample file:" hash))))
\ No newline at end of file
;; They are currently bound in () by exports from (runtime crypto).
(export (mhash global)
make-mhash-keygen-type
- mhash-available?
mhash-context?
mhash-end
mhash-file
\f
(C-include "mhash")
-(define mhash-initialized? #f)
(define mhash-algorithm-names)
(define mhash-contexts '())
(define mhash-hmac-contexts '())
(mhash-name->id (car names) 'MAKE-MHASH-KEYGEN-TYPE)))
v)))))
\f
-(define (mhash-available?)
- (and (plugin-available? "mhash")
- (begin
- (initialize-mhash-variables!)
- #t)))
-
(define (initialize-mhash-variables!)
- (if (not mhash-initialized?)
- (begin
- (set! mhash-algorithm-names
- (make-names-vector
- (lambda () (C-call "mhash_count"))
- (lambda (hashid)
- (let* ((alien (make-alien-to-free
- '(* char)
- (lambda (alien)
- (C-call "mhash_get_hash_name"
- alien hashid))))
- (str (c-peek-cstring alien)))
- (free alien)
- str))))
- (set! mhash-keygen-names
- (make-names-vector
- (lambda () (C-call "mhash_keygen_count"))
- (lambda (keygenid)
- (let* ((alien (make-alien-to-free
- '(* char)
- (lambda (alien)
- (C-call "mhash_get_keygen_name"
- alien keygenid))))
- (str (c-peek-cstring alien)))
- (free alien)
- str))))
- (set! mhash-initialized? #t))))
+ (set! mhash-algorithm-names
+ (make-names-vector
+ (lambda () (C-call "mhash_count"))
+ (lambda (hashid)
+ (let* ((alien (make-alien-to-free
+ '(* char)
+ (lambda (alien)
+ (C-call "mhash_get_hash_name"
+ alien hashid))))
+ (str (c-peek-cstring alien)))
+ (free alien)
+ str))))
+ (set! mhash-keygen-names
+ (make-names-vector
+ (lambda () (C-call "mhash_keygen_count"))
+ (lambda (keygenid)
+ (let* ((alien (make-alien-to-free
+ '(* char)
+ (lambda (alien)
+ (C-call "mhash_get_keygen_name"
+ alien keygenid))))
+ (str (c-peek-cstring alien)))
+ (free alien)
+ str)))))
(define (reset-mhash-variables!)
- (set! mhash-initialized? #f)
(for-each (lambda (weak) (alien-null! (weak-cdr weak))) mhash-contexts)
(set! mhash-contexts '())
(for-each (lambda (weak) (alien-null! (weak-cdr weak))) mhash-hmac-contexts)
(set! mhash-hmac-contexts '())
+ (initialize-mhash-variables!)
unspecific)
(define (mhash-file hash-type filename)
projects / mit-scheme.git / commitdiff