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

Last change on this file since 35340 was 35340, checked in by kon, 15 months ago

add types

File size: 4.1 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(use
21  (only data-structures ->string)
22  (only ports make-output-port with-input-from-port)
23  (only srfi-13 string-suffix-length-ci)
24  (only type-checks define-check+error-type check-output-port)
25  (only type-errors error-argument-type make-error-type-message signal-type-error)
26  message-digest-primitive
27  message-digest-type
28  message-digest-bv
29  fx-utils
30  typed-define)
31
32(declare
33  (bound-to-procedure ##sys#slot ##sys#setslot))
34
35;;; Support
36
37;;
38
39(include "message-digest-types")
40
41;;
42
43(define (%port-type p)
44  (##sys#slot p 7) )
45
46(define (%port-type-set! p t)
47  (##sys#setslot p 7 t) )
48
49(define (%port-name p)
50  (##sys#slot p 3) )
51
52(define (%port-name-set! p s)
53  (##sys#setslot p 3 s) )
54
55(define (check-open-port loc obj #!optional argnam)
56  (if (port-closed? obj)
57    (error-argument-type loc obj "open port" argnam)
58    obj ) )
59
60(define (check-open-digest-output-port loc obj #!optional argnam)
61  (let (
62    (pt (%port-type (check-open-port loc (check-output-port loc obj argnam) argnam))) )
63    (unless (eq? 'digest pt)
64      (signal-type-error loc (make-error-type-message 'digest-output-port) obj argnam) ) )
65  obj )
66
67;Synthesize a port-name from a primitive-name
68(define (make-digest-port-name mdp)
69  (let* (
70    (nam (->string (or (message-digest-primitive-name mdp) 'md)))
71    ;strip trailing (why ?)
72    (remlen (string-suffix-length-ci nam "-primitive"))
73    (remlen (if (fxpositive? remlen) remlen (string-suffix-length-ci nam "p"))) )
74    (string-append
75      "("
76        (if (fxpositive? remlen)
77          (substring nam 0 (fx- (string-length nam) remlen))
78          nam )
79      ")") ) )
80
81;;; Message Digest Output Port API
82
83;; Returns a digest-output-port for the MDP
84
85(define (open-output-digest mdp)
86  (let* (
87    (md
88      (initialize-message-digest mdp))
89    (writer
90      (lambda (obj)
91        ;it will only ever be a string for now
92        (if (string? obj)
93          (message-digest-update-string md obj)
94          (message-digest-update-blob md obj))))
95      ;use default close behavior
96      (port
97        (make-output-port writer void)) )
98    (##sys#set-port-data! port md)
99    (%port-type-set! port 'digest)
100    (%port-name-set! port (make-digest-port-name mdp))
101    port ) )
102
103(define (digest-output-port? obj)
104  (and
105    (output-port? obj)
106    (eq? 'digest (%port-type obj)) ) )
107
108(define-check+error-type digest-output-port)
109
110(define (digest-output-port-name p)
111  (%port-name (check-digest-output-port 'digest-output-port-name p)) )
112
113;; Finalizes the digest-output-port and returns the result in the form requested
114
115(define (*close-output-digest loc digest-port result-type)
116  (let (
117    (res
118      (finalize-message-digest
119        (##sys#port-data (check-open-digest-output-port loc digest-port 'digest-port))
120        result-type)) )
121    (close-output-port digest-port)
122    res ) )
123
124(define (get-output-digest digest-port #!optional (result-type (message-digest-result-form)))
125  (*close-output-digest 'get-output-digest digest-port result-type) )
126
127;;;
128
129;; Calls the procedure PROC with a single argument that is a digest-output-port for the MDP.
130;; Returns the accumulated output string | blob | u8vector | hexstring
131
132(define (call-with-output-digest mdp proc #!optional (result-type (message-digest-result-form)))
133  (let (
134    (port (open-output-digest mdp)) )
135    (proc port)
136    (*close-output-digest 'call-with-output-digest port result-type) ) )
137
138;; Calls the procedure THUNK with the current-input-port temporarily bound to a
139;; digest-output-port for the MDP.
140;; Returns the accumulated output string | blob | u8vector | hexstring
141
142(define (with-output-to-digest mdp thunk #!optional (result-type (message-digest-result-form)))
143  (call-with-output-digest mdp (cut with-input-from-port <> thunk) result-type) )
144
145) ;module message-digest
Note: See TracBrowser for help on using the repository browser.