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

Last change on this file was 35344, checked in by Kon Lovett, 17 months ago

rmv unneeded -> void, mdp name is (or string symbol) per doc, add note about windows chunk test, some procs are pure

File size: 4.4 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  typed-define)
30
31(declare
32  (bound-to-procedure
33    ##sys#slot ##sys#setslot))
34
35;;; Support
36
37;;fx-utils
38
39(: fxpositive? (fixnum --> boolean))
40;
41(define (fxpositive? n)
42  (fx< 0 n) )
43
44;;
45
46(include "message-digest-types")
47
48;;
49
50(define PORT-TAG 'digest)
51
52(define PRIMITIVE-NAME-SUFFIXES '("p" "-primitive"))
53
54;;
55
56(define (%port-type p)
57  (##sys#slot p 7) )
58
59(define (%port-type-set! p t)
60  (##sys#setslot p 7 t) )
61
62(define (%port-name p)
63  (##sys#slot p 3) )
64
65(define (%port-name-set! p s)
66  (##sys#setslot p 3 s) )
67
68;;
69
70(define (check-open-port loc obj #!optional argnam)
71  (if (port-closed? obj)
72    (error-argument-type loc obj "open port" argnam)
73    obj ) )
74
75(define (check-open-digest-output-port loc obj #!optional argnam)
76  (let (
77    (pt (%port-type (check-open-port loc (check-output-port loc obj argnam) argnam))) )
78    (unless (eq? PORT-TAG pt)
79      (signal-type-error loc (make-error-type-message 'digest-output-port) obj argnam) ) )
80  obj )
81
82;Synthesize a port-name from a primitive-name
83(define: (make-digest-port-name (mdp message-digest-primitive)) --> string
84  (let* (
85    (nam
86      (->string (or (message-digest-primitive-name mdp) 'md)))
87    ;strip trailing (why ?)
88    (remlen
89      ;longest suffix length or negative
90      (foldl
91        (lambda (remlen suf)
92          (fxmax remlen (string-suffix-length-ci nam suf)) )
93        -1
94        PRIMITIVE-NAME-SUFFIXES))
95    (nam
96      (if (fxpositive? remlen)
97        (substring nam 0 (fx- (string-length nam) remlen))
98        nam)) )
99    (string-append "(" nam ")") ) )
100
101;;; Message Digest Output Port API
102
103(define: (open-output-digest (mdp message-digest-primitive)) -> digest-output-port
104  (let* (
105    (md
106      (initialize-message-digest mdp))
107    (writer
108      (lambda (obj)
109        ;for now only a string
110        (if (string? obj)
111          (message-digest-update-string md obj)
112          (message-digest-update-blob md obj))))
113      ;use default close behavior
114      (port
115        (make-output-port writer void)) )
116    (##sys#set-port-data! port md)
117    (%port-type-set! port PORT-TAG)
118    (%port-name-set! port (make-digest-port-name mdp))
119    port ) )
120
121(: digest-output-port? (* -> boolean : digest-output-port))
122;
123(define (digest-output-port? obj)
124  (and
125    (output-port? obj)
126    (eq? PORT-TAG (%port-type obj)) ) )
127
128(define-check+error-type digest-output-port)
129
130(define: (digest-output-port-name (port digest-output-port)) --> string
131  (%port-name
132    (check-digest-output-port 'digest-output-port-name port)) )
133
134(define: (*close-output-digest (loc symbol) (port digest-output-port) (restyp message-digest-result-form)) -> message-digest-result-type
135  (let (
136    (res
137      (finalize-message-digest
138        (##sys#port-data
139          (check-open-digest-output-port loc port 'digest-port))
140        restyp)) )
141    (close-output-port port)
142    res ) )
143
144(define: (get-output-digest (port digest-output-port) . (opts (list message-digest-result-type))) -> message-digest-result-type
145  (let (
146    (restyp (optional opts (message-digest-result-form))) )
147    (*close-output-digest 'get-output-digest port restyp) ) )
148
149;;;
150
151(define: (call-with-output-digest (mdp message-digest-primitive) (proc procedure) . (opts (list message-digest-result-type))) -> message-digest-result-type
152  (let (
153    (restyp (optional opts (message-digest-result-form)))
154    (port (open-output-digest mdp)) )
155    (proc port)
156    (*close-output-digest 'call-with-output-digest port restyp) ) )
157
158(define: (with-output-to-digest (mdp message-digest-primitive) (thunk procedure) . (opts (list message-digest-result-type))) -> message-digest-result-type
159  (let (
160    (restyp (optional opts (message-digest-result-form))) )
161    (call-with-output-digest mdp (cut with-input-from-port <> thunk) restyp) ) )
162
163) ;module message-digest
Note: See TracBrowser for help on using the repository browser.