+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017, 2018 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* Interface to mcrypt library */
-
-#include "scheme.h"
-#include "prims.h"
-#include "usrdef.h"
-#include "os.h"
-
-/* If mcrypt.h unavailable, ignore it. This helps
- "makegen/makegen.scm" work properly on systems lacking this
- library. */
-#ifdef HAVE_MCRYPT_H
-# include <mcrypt.h>
-#endif
-
-static SCHEME_OBJECT
-cp2s (char * cp)
-{
- if (cp == 0)
- return (SHARP_F);
- else
- {
- SCHEME_OBJECT s = (char_pointer_to_string (cp));
- mcrypt_free (cp);
- return (s);
- }
-}
-\f
-static size_t context_table_length = 0;
-static MCRYPT * context_table = 0;
-
-static size_t
-search_context_table (MCRYPT context)
-{
- size_t i;
- for (i = 0; (i < context_table_length); i += 1)
- if ((context_table[i]) == context)
- break;
- return (i);
-}
-
-static size_t
-allocate_context_entry (void)
-{
- size_t i = (search_context_table (0));
- if (i < context_table_length)
- return (i);
- if (i == 0)
- {
- context_table_length = 256;
- context_table
- = (OS_malloc ((sizeof (MCRYPT)) * context_table_length));
- }
- else
- {
- context_table_length *= 2;
- context_table
- = (OS_realloc (context_table,
- ((sizeof (MCRYPT)) * context_table_length)));
- }
- {
- size_t j;
- for (j = i; (j < context_table_length); j += 1)
- (context_table[j]) = 0;
- }
- return (i);
-}
-
-static SCHEME_OBJECT
-store_context (MCRYPT context)
-{
- if (context == MCRYPT_FAILED)
- return (SHARP_F);
- {
- size_t i = (allocate_context_entry ());
- (context_table[i]) = context;
- return (ulong_to_integer (i));
- }
-}
-
-static void
-forget_context (size_t index)
-{
- (context_table[index]) = 0;
-}
-
-static size_t
-arg_context_index (unsigned int arg)
-{
- unsigned long n = (arg_ulong_index_integer (arg, context_table_length));
- if ((context_table[n]) == 0)
- error_bad_range_arg (arg);
- return (n);
-}
-
-static MCRYPT
-arg_context (unsigned int arg)
-{
- return (context_table [arg_context_index (arg)]);
-}
-\f
-DEFINE_PRIMITIVE ("MCRYPT_MODULE_OPEN", Prim_mcrypt_module_open, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- PRIMITIVE_RETURN
- (store_context
- (mcrypt_module_open ((STRING_ARG (1)), 0, (STRING_ARG (2)), 0)));
-}
-
-DEFINE_PRIMITIVE ("MCRYPT_GENERIC_INIT", Prim_mcrypt_generic_init, 3, 3, 0)
-{
- PRIMITIVE_HEADER (3);
- CHECK_ARG (2, STRING_P);
- PRIMITIVE_RETURN
- (long_to_integer
- (mcrypt_generic_init ((arg_context (1)),
- (STRING_POINTER (ARG_REF (2))),
- (STRING_LENGTH (ARG_REF (2))),
- (STRING_ARG (3)))));
-}
-
-DEFINE_PRIMITIVE ("MCRYPT_GENERIC", Prim_mcrypt_generic, 4, 4, 0)
-{
- PRIMITIVE_HEADER (4);
- CHECK_ARG (2, STRING_P);
- {
- SCHEME_OBJECT string = (ARG_REF (2));
- unsigned long l = (STRING_LENGTH (string));
- unsigned long start = (arg_ulong_index_integer (3, l));
- unsigned long end = (arg_integer_in_range (4, start, (l + 1)));
- PRIMITIVE_RETURN
- (long_to_integer
- (mcrypt_generic ((arg_context (1)),
- (STRING_LOC (string, start)),
- (end - start))));
- }
-}
-
-DEFINE_PRIMITIVE ("MDECRYPT_GENERIC", Prim_mdecrypt_generic, 4, 4, 0)
-{
- PRIMITIVE_HEADER (4);
- CHECK_ARG (2, STRING_P);
- {
- SCHEME_OBJECT string = (ARG_REF (2));
- unsigned long l = (STRING_LENGTH (string));
- unsigned long start = (arg_ulong_index_integer (3, l));
- unsigned long end = (arg_integer_in_range (4, start, (l + 1)));
- PRIMITIVE_RETURN
- (long_to_integer
- (mdecrypt_generic ((arg_context (1)),
- (STRING_LOC (string, start)),
- (end - start))));
- }
-}
-
-DEFINE_PRIMITIVE ("MCRYPT_GENERIC_END", Prim_mcrypt_generic_end, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- {
- size_t index = (arg_context_index (1));
- int result = (mcrypt_generic_end (context_table[index]));
- forget_context (index);
- PRIMITIVE_RETURN (long_to_integer (result));
- }
-}
-
-#define CONTEXT_OPERATION(name, cvt_val) \
-{ \
- PRIMITIVE_HEADER (1); \
- PRIMITIVE_RETURN (cvt_val (name (arg_context (1)))); \
-}
-
-DEFINE_PRIMITIVE ("MCRYPT_ENC_SELF_TEST", Prim_mcrypt_enc_self_test, 1, 1, 0)
- CONTEXT_OPERATION (mcrypt_enc_self_test, long_to_integer)
-
-DEFINE_PRIMITIVE ("MCRYPT_ENC_IS_BLOCK_ALGORITHM_MODE", Prim_mcrypt_enc_is_block_algorithm_mode, 1, 1, 0)
- CONTEXT_OPERATION (mcrypt_enc_is_block_algorithm_mode, BOOLEAN_TO_OBJECT)
-
-DEFINE_PRIMITIVE ("MCRYPT_ENC_IS_BLOCK_ALGORITHM", Prim_mcrypt_enc_is_block_algorithm, 1, 1, 0)
- CONTEXT_OPERATION (mcrypt_enc_is_block_algorithm, BOOLEAN_TO_OBJECT)
-
-DEFINE_PRIMITIVE ("MCRYPT_ENC_IS_BLOCK_MODE", Prim_mcrypt_enc_is_block_mode, 1, 1, 0)
- CONTEXT_OPERATION (mcrypt_enc_is_block_mode, BOOLEAN_TO_OBJECT)
-
-DEFINE_PRIMITIVE ("MCRYPT_ENC_GET_KEY_SIZE", Prim_mcrypt_enc_get_key_size, 1, 1, 0)
- CONTEXT_OPERATION (mcrypt_enc_get_key_size, long_to_integer)
-
-DEFINE_PRIMITIVE ("MCRYPT_ENC_GET_IV_SIZE", Prim_mcrypt_enc_get_iv_size, 1, 1, 0)
- CONTEXT_OPERATION (mcrypt_enc_get_iv_size, long_to_integer)
-
-DEFINE_PRIMITIVE ("MCRYPT_ENC_GET_ALGORITHMS_NAME", Prim_mcrypt_enc_get_algorithms_name, 1, 1, 0)
- CONTEXT_OPERATION (mcrypt_enc_get_algorithms_name, cp2s)
-
-DEFINE_PRIMITIVE ("MCRYPT_ENC_GET_MODES_NAME", Prim_mcrypt_enc_get_modes_name, 1, 1, 0)
- CONTEXT_OPERATION (mcrypt_enc_get_modes_name, cp2s)
-
-#define MODULE_OPERATION(name, cvt_val) \
-{ \
- PRIMITIVE_HEADER (1); \
- PRIMITIVE_RETURN (cvt_val (name ((STRING_ARG (1)), 0))); \
-}
-
-DEFINE_PRIMITIVE ("MCRYPT_MODULE_SELF_TEST", Prim_mcrypt_module_self_test, 1, 1, 0)
- MODULE_OPERATION (mcrypt_module_self_test, long_to_integer)
-
-DEFINE_PRIMITIVE ("MCRYPT_MODULE_IS_BLOCK_ALGORITHM_MODE", Prim_mcrypt_module_is_block_algorithm_mode, 1, 1, 0)
- MODULE_OPERATION (mcrypt_module_is_block_algorithm_mode, BOOLEAN_TO_OBJECT)
-
-DEFINE_PRIMITIVE ("MCRYPT_MODULE_IS_BLOCK_ALGORITHM", Prim_mcrypt_module_is_block_algorithm, 1, 1, 0)
- MODULE_OPERATION (mcrypt_module_is_block_algorithm, BOOLEAN_TO_OBJECT)
-
-DEFINE_PRIMITIVE ("MCRYPT_MODULE_IS_BLOCK_MODE", Prim_mcrypt_module_is_block_mode, 1, 1, 0)
- MODULE_OPERATION (mcrypt_module_is_block_mode, BOOLEAN_TO_OBJECT)
-
-DEFINE_PRIMITIVE ("MCRYPT_MODULE_GET_ALGO_BLOCK_SIZE", Prim_mcrypt_module_get_algo_block_size, 1, 1, 0)
- MODULE_OPERATION (mcrypt_module_get_algo_block_size, long_to_integer)
-
-DEFINE_PRIMITIVE ("MCRYPT_MODULE_GET_ALGO_KEY_SIZE", Prim_mcrypt_module_get_algo_key_size, 1, 1, 0)
- MODULE_OPERATION (mcrypt_module_get_algo_key_size, long_to_integer)
-
-struct deallocate_list_arg
-{
- char ** elements;
- int n_elements;
-};
-
-static void
-deallocate_list (void * environment)
-{
- struct deallocate_list_arg * a = environment;
- if ((a -> elements) != 0)
- mcrypt_free_p ((a -> elements), (a -> n_elements));
-}
-
-#define LIST_ITEMS(name) \
-{ \
- PRIMITIVE_HEADER (0); \
- { \
- struct deallocate_list_arg a; \
- (a . elements) = (name (0, (& (a . n_elements)))); \
- transaction_begin (); \
- transaction_record_action (tat_always, deallocate_list, (&a)); \
- if ((a . n_elements) < 0) \
- error_external_return (); \
- { \
- char ** scan = (a . elements); \
- char ** end = (scan + (a . n_elements)); \
- SCHEME_OBJECT sa = (make_vector ((a . n_elements), SHARP_F, 1)); \
- SCHEME_OBJECT * scan_sa = (VECTOR_LOC (sa, 0)); \
- while (scan < end) \
- (*scan_sa++) = (char_pointer_to_string (*scan++)); \
- transaction_commit (); \
- PRIMITIVE_RETURN (sa); \
- } \
- } \
-}
-
-DEFINE_PRIMITIVE ("MCRYPT_LIST_ALGORITHMS", Prim_mcrypt_list_algorithms, 0, 0, 0)
- LIST_ITEMS (mcrypt_list_algorithms)
-
-DEFINE_PRIMITIVE ("MCRYPT_LIST_MODES", Prim_mcrypt_list_modes, 0, 0, 0)
- LIST_ITEMS (mcrypt_list_modes)
-
-static void
-deallocate_key_sizes (void * environment)
-{
- if (environment != 0)
- mcrypt_free (environment);
-}
-
-static SCHEME_OBJECT
-convert_key_sizes (int * sizes, int n_sizes)
-{
- transaction_begin ();
- transaction_record_action (tat_always, deallocate_key_sizes, sizes);
- if (n_sizes < 0)
- error_external_return ();
- if (n_sizes == 0)
- {
- transaction_commit ();
- return (SHARP_F);
- }
- {
- SCHEME_OBJECT sa = (make_vector (n_sizes, FIXNUM_ZERO, 1));
- SCHEME_OBJECT * scan_sa = (VECTOR_LOC (sa, 0));
- int * scan = sizes;
- int * end = (scan + n_sizes);
- while (scan < end)
- (*scan_sa++) = (long_to_integer (*scan++));
- transaction_commit ();
- return (sa);
- }
-}
-
-DEFINE_PRIMITIVE ("MCRYPT_ENC_GET_SUPPORTED_KEY_SIZES", Prim_mcrypt_enc_get_supported_key_sizes, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- {
- int n_sizes;
- int * sizes
- = (mcrypt_enc_get_supported_key_sizes ((arg_context (1)), (&n_sizes)));
- PRIMITIVE_RETURN (convert_key_sizes (sizes, n_sizes));
- }
-}
-
-DEFINE_PRIMITIVE ("MCRYPT_MODULE_GET_ALGO_SUPPORTED_KEY_SIZES", Prim_mcrypt_module_get_algo_supported_key_sizes, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- {
- int n_sizes;
- int * sizes
- = (mcrypt_module_get_algo_supported_key_sizes
- ((STRING_ARG (1)), 0, (&n_sizes)));
- PRIMITIVE_RETURN (convert_key_sizes (sizes, n_sizes));
- }
-}
-
-#ifdef COMPILE_AS_MODULE
-
-char *
-dload_initialize_file (void)
-{
- declare_primitive
- ("MCRYPT_MODULE_OPEN", Prim_mcrypt_module_open, 2, 2, 0);
- declare_primitive
- ("MCRYPT_GENERIC_INIT", Prim_mcrypt_generic_init, 3, 3, 0);
- declare_primitive
- ("MCRYPT_GENERIC", Prim_mcrypt_generic, 4, 4, 0);
- declare_primitive
- ("MDECRYPT_GENERIC", Prim_mdecrypt_generic, 4, 4, 0);
- declare_primitive
- ("MCRYPT_GENERIC_END", Prim_mcrypt_generic_end, 1, 1, 0);
- declare_primitive
- ("MCRYPT_ENC_SELF_TEST", Prim_mcrypt_enc_self_test, 1, 1, 0);
- declare_primitive
- ("MCRYPT_ENC_IS_BLOCK_ALGORITHM_MODE", Prim_mcrypt_enc_is_block_algorithm_mode, 1, 1, 0);
- declare_primitive
- ("MCRYPT_ENC_IS_BLOCK_ALGORITHM", Prim_mcrypt_enc_is_block_algorithm, 1, 1, 0);
- declare_primitive
- ("MCRYPT_ENC_IS_BLOCK_MODE", Prim_mcrypt_enc_is_block_mode, 1, 1, 0);
- declare_primitive
- ("MCRYPT_ENC_GET_KEY_SIZE", Prim_mcrypt_enc_get_key_size, 1, 1, 0);
- declare_primitive
- ("MCRYPT_ENC_GET_IV_SIZE", Prim_mcrypt_enc_get_iv_size, 1, 1, 0);
- declare_primitive
- ("MCRYPT_ENC_GET_ALGORITHMS_NAME", Prim_mcrypt_enc_get_algorithms_name, 1, 1, 0);
- declare_primitive
- ("MCRYPT_ENC_GET_MODES_NAME", Prim_mcrypt_enc_get_modes_name, 1, 1, 0);
- declare_primitive
- ("MCRYPT_MODULE_SELF_TEST", Prim_mcrypt_module_self_test, 1, 1, 0);
- declare_primitive
- ("MCRYPT_MODULE_IS_BLOCK_ALGORITHM_MODE", Prim_mcrypt_module_is_block_algorithm_mode, 1, 1, 0);
- declare_primitive
- ("MCRYPT_MODULE_IS_BLOCK_ALGORITHM", Prim_mcrypt_module_is_block_algorithm, 1, 1, 0);
- declare_primitive
- ("MCRYPT_MODULE_IS_BLOCK_MODE", Prim_mcrypt_module_is_block_mode, 1, 1, 0);
- declare_primitive
- ("MCRYPT_MODULE_GET_ALGO_BLOCK_SIZE", Prim_mcrypt_module_get_algo_block_size, 1, 1, 0);
- declare_primitive
- ("MCRYPT_MODULE_GET_ALGO_KEY_SIZE", Prim_mcrypt_module_get_algo_key_size, 1, 1, 0);
- declare_primitive
- ("MCRYPT_LIST_ALGORITHMS", Prim_mcrypt_list_algorithms, 0, 0, 0);
- declare_primitive
- ("MCRYPT_LIST_MODES", Prim_mcrypt_list_modes, 0, 0, 0);
- declare_primitive
- ("MCRYPT_ENC_GET_SUPPORTED_KEY_SIZES", Prim_mcrypt_enc_get_supported_key_sizes, 1, 1, 0);
- declare_primitive
- ("MCRYPT_MODULE_GET_ALGO_SUPPORTED_KEY_SIZES", Prim_mcrypt_module_get_algo_supported_key_sizes, 1, 1, 0);
- return "#prmcrypt";
-}
-
-#endif /* COMPILE_AS_MODULE */
(context ((ucode-primitive md5-init 0))))
((ucode-primitive md5-update 4) context bytes start end)
((ucode-primitive md5-final 1) context)))
-\f
-;;;; The mcrypt library
-
-(define mcrypt-initialized?)
-(define mcrypt-algorithm-names-vector)
-(define mcrypt-mode-names-vector)
-(define mcrypt-contexts)
-(define-structure mcrypt-context index)
-
-(define (guarantee-mcrypt-context object procedure)
- (if (not (mcrypt-context? object))
- (error:wrong-type-argument object "mcrypt context" procedure))
- (if (not (mcrypt-context-index object))
- (error:bad-range-argument object procedure)))
-
-(define (mcrypt-available?)
- (load-library-object-file "prmcrypt" #f)
- (and (implemented-primitive-procedure?
- (ucode-primitive mcrypt_module_open 2))
- (begin
- (if (not mcrypt-initialized?)
- (begin
- (set! mcrypt-contexts
- (make-gc-finalizer (ucode-primitive mcrypt_generic_end 1)
- mcrypt-context?
- mcrypt-context-index
- set-mcrypt-context-index!))
- (set! mcrypt-algorithm-names-vector
- ((ucode-primitive mcrypt_list_algorithms 0)))
- (set! mcrypt-mode-names-vector
- ((ucode-primitive mcrypt_list_modes 0)))
- (set! mcrypt-initialized? #t)))
- #t)))
-
-(define (reset-mcrypt-variables!)
- (set! mcrypt-initialized? #f)
- unspecific)
-
-(define (mcrypt-algorithm-names)
- (names-vector->list mcrypt-algorithm-names-vector))
-
-(define (mcrypt-mode-names)
- (names-vector->list mcrypt-mode-names-vector))
-
-(define (mcrypt-open-module algorithm mode)
- (without-interruption
- (lambda ()
- (add-to-gc-finalizer! mcrypt-contexts
- (make-mcrypt-context
- ((ucode-primitive mcrypt_module_open 2) algorithm
- mode))))))
-\f
-(define (mcrypt-init context key init-vector)
- (guarantee-mcrypt-context context 'mcrypt-init)
- (let ((code
- ((ucode-primitive mcrypt_generic_init 3)
- (mcrypt-context-index context) key init-vector)))
- (if (not (eqv? code 0))
- (error "Error code signalled by mcrypt_generic_init:" code))))
-
-(define-integrable (make-mcrypt-transform! name primitive)
- (lambda (context bytes start end)
- (guarantee-mcrypt-context context name)
- (let ((code (primitive (mcrypt-context-index context) bytes start end)))
- (if (not (eqv? code 0))
- (error (string "Error code signalled by "name":") code)))))
-
-(define mcrypt-encrypt!
- (make-mcrypt-transform! 'mcrypt-encrypt!
- (ucode-primitive mcrypt_generic 4)))
-
-(define mcrypt-decrypt!
- (make-mcrypt-transform! 'mcrypt-decrypt!
- (ucode-primitive mdecrypt_generic 4)))
-
-(define (mcrypt-encrypt context input input-start input-end
- output output-start encrypt?)
- ((if encrypt? mcrypt-encrypt! mcrypt-decrypt!)
- context
- output
- output-start
- (bytevector-copy! output output-start input input-start input-end)))
-
-(define (mcrypt-end context)
- (remove-from-gc-finalizer! mcrypt-contexts context))
-
-(define (mcrypt-generic-unary name context-op module-op)
- (lambda (object)
- (cond ((mcrypt-context? object) (context-op (mcrypt-context-index object)))
- ((bytevector? object) (module-op object))
- ((string? object) (module-op (string->utf8 object)))
- (else (error:wrong-type-argument object "mcrypt context" name)))))
-
-(define mcrypt-self-test
- (mcrypt-generic-unary
- 'mcrypt-self-test
- (ucode-primitive mcrypt_enc_self_test 1)
- (ucode-primitive mcrypt_module_self_test 1)))
-
-(define mcrypt-block-algorithm-mode?
- (mcrypt-generic-unary
- 'mcrypt-block-algorithm-mode?
- (ucode-primitive mcrypt_enc_is_block_algorithm_mode 1)
- (ucode-primitive mcrypt_module_is_block_algorithm_mode 1)))
-
-(define mcrypt-block-algorithm?
- (mcrypt-generic-unary
- 'mcrypt-block-algorithm?
- (ucode-primitive mcrypt_enc_is_block_algorithm 1)
- (ucode-primitive mcrypt_module_is_block_algorithm 1)))
-\f
-(define mcrypt-block-mode?
- (mcrypt-generic-unary
- 'mcrypt-block-mode?
- (ucode-primitive mcrypt_enc_is_block_mode 1)
- (ucode-primitive mcrypt_module_is_block_mode 1)))
-
-(define mcrypt-key-size
- (mcrypt-generic-unary
- 'mcrypt-key-size
- (ucode-primitive mcrypt_enc_get_key_size 1)
- (ucode-primitive mcrypt_module_get_algo_key_size 1)))
-
-(define mcrypt-supported-key-sizes
- (mcrypt-generic-unary
- 'mcrypt-supported-key-sizes
- (ucode-primitive mcrypt_enc_get_supported_key_sizes 1)
- (ucode-primitive mcrypt_module_get_algo_supported_key_sizes 1)))
-
-(define (mcrypt-init-vector-size context)
- (guarantee-mcrypt-context context 'mcrypt-init-vector-size)
- ((ucode-primitive mcrypt_enc_get_iv_size 1)
- (mcrypt-context-index context)))
-
-(define (mcrypt-algorithm-name context)
- (guarantee-mcrypt-context context 'mcrypt-algorithm-name)
- ((ucode-primitive mcrypt_enc_get_algorithms_name 1)
- (mcrypt-context-index context)))
-
-(define (mcrypt-mode-name context)
- (guarantee-mcrypt-context context 'mcrypt-mode-name)
- ((ucode-primitive mcrypt_enc_get_modes_name 1)
- (mcrypt-context-index context)))
-
-(define (mcrypt-encrypt-port algorithm mode input output key init-vector
- encrypt?)
- ;; Assumes that INPUT is in blocking mode.
- ((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))
-\f
-;;;; Package initialization
-
-(define (initialize-package!)
- (reset-mcrypt-variables!)
- (add-event-receiver! event:after-restart reset-mcrypt-variables!))
-
-(define (make-names-vector get-count get-name)
- (let ((n (get-count)))
- (let ((v (make-vector n)))
- (do ((i 0 (fix:+ i 1)))
- ((fix:= i n))
- (vector-set! v i
- (let ((name (get-name i)))
- (and name
- (intern name)))))
- v)))
-
-(define (names-vector->list v)
- (let ((end (vector-length v)))
- (let loop ((index 0) (names '()))
- (if (fix:< index end)
- (loop (fix:+ index 1)
- (let ((name (vector-ref v index)))
- (if name
- (cons name names)
- names)))
- names))))
(define (port-consumer initialize update finalize)
(lambda (port)
(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 ()
(procedure buffer))
(lambda ()
- (bytevector-fill! buffer 0)))))
\ No newline at end of file
+ (bytevector-fill! buffer 0)))))
+\f
+;;;; The mcrypt library
+
+(define mcrypt-linked? #f)
+
+(define (mcrypt-available?)
+ (and (plugin-available? "mcrypt")
+ (or mcrypt-linked?
+ (begin
+ (load-option 'mcrypt)
+ (mcrypt-link!)
+ #t))))
+
+(define (mcrypt-link!)
+ (for-each
+ (let ((runtime (->environment '(runtime crypto)))
+ (mcrypt (->environment '(mcrypt))))
+ (lambda (name)
+ (environment-link-name runtime mcrypt name)))
+ mcrypt-names)
+ (set! mcrypt-linked? #t))
+
+(define mcrypt-names
+ '(mcrypt-algorithm-name
+ mcrypt-algorithm-names
+ mcrypt-block-algorithm-mode?
+ mcrypt-block-algorithm?
+ mcrypt-block-mode?
+ mcrypt-context?
+ mcrypt-decrypt!
+ mcrypt-encrypt
+ mcrypt-encrypt!
+ mcrypt-encrypt-port
+ mcrypt-end
+ mcrypt-init
+ mcrypt-init-vector-size
+ mcrypt-key-size
+ mcrypt-mode-name
+ mcrypt-mode-names
+ mcrypt-open-module
+ mcrypt-self-test
+ mcrypt-supported-key-sizes))
+
+(define mcrypt-algorithm-name)
+(define mcrypt-algorithm-names)
+(define mcrypt-block-algorithm-mode?)
+(define mcrypt-block-algorithm?)
+(define mcrypt-block-mode?)
+(define mcrypt-context?)
+(define mcrypt-decrypt!)
+(define mcrypt-encrypt)
+(define mcrypt-encrypt!)
+(define mcrypt-encrypt-port)
+(define mcrypt-end)
+(define mcrypt-init)
+(define mcrypt-init-vector-size)
+(define mcrypt-key-size)
+(define mcrypt-mode-name)
+(define mcrypt-mode-names)
+(define mcrypt-open-module)
+(define mcrypt-self-test)
+(define mcrypt-supported-key-sizes)
\ No newline at end of file
projects / mit-scheme.git / commitdiff