source: project/release/4/message-digest/trunk/message-digest-port.scm @ 35044

Last change on this file since 35044 was 35044, checked in by kon, 7 months ago

why did i care ?

File size: 3.8 KB
Line 
1;;;; message-digest-port.scm
2;;;; Kon Lovett, May '10
3;;;; Kon Lovett, Aug '17
4
5;; Issues
6;;
7;; - Use of sys namespace routines.
8
9(module message-digest-port
10
11(;export
12  digest-output-port? check-digest-output-port error-digest-output-port
13  digest-output-port-name
14  open-output-digest
15  get-output-digest
16  call-with-output-digest
17  with-output-to-digest)
18
19(import scheme chicken)
20
21(use
22  (only data-structures ->string)
23  (only ports make-output-port with-input-from-port)
24  (only srfi-13 string-suffix-length-ci)
25  (only type-checks define-check+error-type check-output-port)
26  (only type-errors error-argument-type make-error-type-message signal-type-error)
27  message-digest-primitive
28  message-digest-type
29  message-digest-bv)
30
31;;; Message Digest Output Port API
32
33;
34(define (%port-type p) (##sys#slot p 7))
35(define (%port-type-set! p t) (##sys#setslot p 7 t))
36
37;
38(define (%port-name p) (##sys#slot p 3))
39(define (%port-name-set! p s) (##sys#setslot p 3 s))
40
41;
42(define (check-open-port loc obj #!optional argnam)
43  (if (port-closed? obj)
44    (error-argument-type loc obj "open port" argnam)
45    obj ) )
46
47;
48(define (check-open-digest-output-port loc obj #!optional argnam)
49  (let ((pt (%port-type (check-open-port loc (check-output-port loc obj argnam) argnam))))
50    (unless (eq? 'digest pt)
51      (signal-type-error loc (make-error-type-message 'digest-output-port) obj argnam) ) )
52  obj )
53
54; Synthesize a port-name from a primitive-name
55(define (make-digest-port-name mdp)
56  (let* ((nam (->string (or (message-digest-primitive-name mdp) 'digest)) )
57         (remlen (string-suffix-length-ci nam "-primitive") ) )
58    (string-append
59      "("
60        (if (positive? remlen)
61          (substring nam 0 (fx- (string-length nam) remlen))
62          nam )
63      ")") ) )
64
65;; Returns a digest-output-port for the MDP
66
67(define (open-output-digest mdp)
68  (let* ((md (initialize-message-digest mdp) )
69         (writer
70          (lambda (obj)
71            ;it will only ever be a string for now
72            (if (string? obj)
73              (message-digest-update-string md obj)
74              (message-digest-update-blob md obj))) )
75         (port (make-output-port writer void) ) ) ;use default close behavior
76    (##sys#set-port-data! port md)
77    (%port-type-set! port 'digest)
78    (%port-name-set! port (make-digest-port-name mdp))
79    port ) )
80
81(define (digest-output-port? obj)
82  (and
83    (output-port? obj)
84    (eq? 'digest (%port-type obj)) ) )
85
86(define-check+error-type digest-output-port)
87
88(define (digest-output-port-name p)
89  (%port-name (check-digest-output-port 'digest-output-port-name p)) )
90
91;; Finalizes the digest-output-port and returns the result in the form requested
92
93(define (*close-output-digest loc digest-port result-type)
94  (let ((res
95          (finalize-message-digest
96            (##sys#port-data (check-open-digest-output-port loc digest-port 'digest-port))
97            result-type)))
98    (close-output-port digest-port)
99    res ) )
100
101(define (get-output-digest digest-port #!optional (result-type (message-digest-result-form)))
102  (*close-output-digest 'get-output-digest digest-port result-type) )
103
104;;;
105
106;; Calls the procedure PROC with a single argument that is a digest-output-port for the MDP.
107;; Returns the accumulated output string | blob | u8vector | hexstring
108
109(define (call-with-output-digest mdp proc #!optional (result-type (message-digest-result-form)))
110  (let ((port (open-output-digest mdp)))
111    (proc port)
112    (*close-output-digest 'call-with-output-digest port result-type) ) )
113
114;; Calls the procedure THUNK with the current-input-port temporarily bound to a
115;; digest-output-port for the MDP.
116;; Returns the accumulated output string | blob | u8vector | hexstring
117
118(define (with-output-to-digest mdp thunk #!optional (result-type (message-digest-result-form)))
119  (call-with-output-digest mdp (cut with-input-from-port <> thunk) result-type) )
120
121) ;module message-digest
Note: See TracBrowser for help on using the repository browser.