(mime:get-content-description header-fields)
(mime:get-content-transfer-encoding header-fields)
(- end start)
- (ignore-errors (lambda () (md5-string string start end))
+ (ignore-errors (lambda ()
+ (load-option 'md5)
- (md5-substring string start end))
- (lambda (condition) condition #f))
++ (md5-string string start end))
+ (lambda (condition) condition #f))
(mime:get-content-disposition header-fields)
(mime:get-content-language header-fields))))
(make-alien '(const (* char)))
code)))))))
++(define-integrable (make-mcrypt-transform! name fname procedure)
++ (lambda (context bytes start end)
++ (guarantee-mcrypt-context context name)
++ (let ((code (procedure context bytes start end)))
++ (if (< code 0)
++ (error (string-append "Error code signalled by "fname":")
++ code)))))
++
++(define mcrypt-encrypt!
++ (make-mcrypt-transform!
++ 'mcrypt-encrypt! "mcrypt_generic"
++ (lambda (context bytes start end)
++ (let ((alien (mcrypt-context-alien context)))
++ (C-call "scmcrypt_generic" alien bytes start end)))))
++
++(define mcrypt-decrypt!
++ (make-mcrypt-transform!
++ 'mcrypt-decrypt! "mdecrypt_generic"
++ (lambda (context bytes start end)
++ (let ((alien (mcrypt-context-alien context)))
++ (C-call "scmdecrypt_generic" alien 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)))
(lambda (object)
(cond ((mcrypt-context? object)
(context-op object))
-- ((string? object)
++ ((bytevector? object)
(init!)
(module-op object))
(else
(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)
(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)))
(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)))
\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)))
(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)))
(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|))))
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 (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)))))
--\f
++ (lambda ()
++ unspecific)
++ (lambda ()
++ (procedure buffer))
++ (lambda ()
++ (bytevector-fill! buffer 0)))))
++
;;;; Mcrypt size lists.
(define (mcrypt-size-list-elements mlist)
;;;; 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))))
(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).
+ ;; These are "exported" to (runtime crypto) during load-option.
+ ;; (md5 global) gets them just so that CREF will report any that go
+ ;; missing.
(export (md5 global)
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.
(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)
++(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 (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 (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 ()
++ (procedure buffer))
++ (lambda ()
++ (bytevector-fill! buffer 0)))))
;;;; 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))))
mhash-keygen-uses-hash-algorithm
mhash-keygen-uses-salt?
mhash-string
-- mhash-substring
-- mhash-sum->hexadecimal
-- mhash-sum->number
mhash-type-names
mhash-update))
(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)
(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)
(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-mhash-context context 'mhash-update)
++ (subbytevector bytevector start end 'mhash-update)
++ (with-context-locked-open context 'mhash-update
(lambda (alien)
(C-call "do_mhash" alien bytevector start end))))
(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
(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)))
++ (keyword (string->utf8 passphrase)))
(let ((params (salted-keygen-params
keygenid (mhash-keygen-type-parameter-vector type) salt))
(keyword (make-bytevector keyword-size))
(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
(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!)
(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)
\f
;;;; Package initialization
(if name
(cons name names)
names)))
-- names))))
++ names))))
++
++(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 (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 (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 ()
++ (procedure buffer))
++ (lambda ()
++ (bytevector-fill! buffer 0)))))
(define with-values call-with-values)
(define (write-to-string object #!optional max)
- ((if (or (default-object? max) (not max))
- call-with-output-string
- call-with-truncated-output-string)
- (lambda (port) (write object port))))
+ (if (or (default-object? max) (not max))
+ (call-with-output-string
+ (lambda (port) (write object port)))
+ (call-with-truncated-output-string
+ max
+ (lambda (port) (write object port)))))
+
+(define (edit . args)
+ (let ((env (let ((package (name->package '(edwin))))
+ (and package (package/environment package)))))
+ (if env
+ (apply (environment-lookup env 'edit) args)
+ (begin
+ (with-notification
+ (lambda (port) (display "Loading Edwin" port))
+ (lambda ()
+ (parameterize*
+ (list (cons param:suppress-loading-message? #t))
+ (lambda ()
+ (load-option 'EDWIN)
+ (if (let ((DISPLAY (get-environment-variable "DISPLAY")))
+ (and (string? DISPLAY)
+ (not (string-null? DISPLAY))))
+ (ignore-errors (lambda () (load-option 'x11-screen))))))))
+ (apply (environment-lookup (->environment '(edwin)) 'edit) args)))))
+
+(define edwin edit)
+
+(define (spawn-edwin . args)
+ (let ((thread (create-thread #f (lambda () (apply edwin args)))))
+ (detach-thread thread)
+ thread))
\f
(define (pa procedure)
(guarantee procedure? procedure 'PA)
projects / mit-scheme.git / commitdiff