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

;;;; message-digest-port.scm
;;;; Kon Lovett, May '10
;;;; Kon Lovett, Aug '17

;; Issues
;;
;; - Use of sys namespace routines.

(module message-digest-port

(;export
  digest-output-port? check-digest-output-port error-digest-output-port
  digest-output-port-name
  open-output-digest
  get-output-digest
  call-with-output-digest
  with-output-to-digest)

(import scheme chicken)

(use
  (only data-structures ->string)
  (only ports make-output-port with-input-from-port)
  (only srfi-13 string-suffix-length-ci)
  (only type-checks define-check+error-type check-output-port)
  (only type-errors error-argument-type make-error-type-message signal-type-error)
  message-digest-primitive
  message-digest-type
  message-digest-bv)

;;; Message Digest Output Port API

;
(define (%port-type p) (##sys#slot p 7))
(define (%port-type-set! p t) (##sys#setslot p 7 t))

;
(define (%port-name p) (##sys#slot p 3))
(define (%port-name-set! p s) (##sys#setslot p 3 s))

;
(define (check-open-port loc obj #!optional argnam)
  (if (port-closed? obj)
    (error-argument-type loc obj "open port" argnam)
    obj ) )

;
(define (check-open-digest-output-port loc obj #!optional argnam)
  (let ((pt (%port-type (check-open-port loc (check-output-port loc obj argnam) argnam))))
    (unless (eq? 'digest pt)
      (signal-type-error loc (make-error-type-message 'digest-output-port) obj argnam) ) )
  obj )

; Synthesize a port-name from a primitive-name
(define (make-digest-port-name mdp)
  (let* ((nam (->string (or (message-digest-primitive-name mdp) 'digest)) )
         (remlen (string-suffix-length-ci nam "-primitive") ) )
    (string-append
      "("
        (if (positive? remlen)
          (substring nam 0 (fx- (string-length nam) remlen))
          nam )
      ")") ) )

;; Returns a digest-output-port for the MDP

(define (open-output-digest mdp)
  (let* ((md (initialize-message-digest mdp) )
         (writer
          (lambda (obj)
            ;it will only ever be a string for now
            (if (string? obj)
              (message-digest-update-string md obj)
              (message-digest-update-blob md obj))) )
         (port (make-output-port writer void) ) ) ;use default close behavior
    (##sys#set-port-data! port md)
    (%port-type-set! port 'digest)
    (%port-name-set! port (make-digest-port-name mdp))
    port ) )

(define (digest-output-port? obj)
  (and
    (output-port? obj)
    (eq? 'digest (%port-type obj)) ) )

(define-check+error-type digest-output-port)

(define (digest-output-port-name p)
  (%port-name (check-digest-output-port 'digest-output-port-name p)) )

;; Finalizes the digest-output-port and returns the result in the form requested

(define (*close-output-digest loc digest-port result-type)
  (let ((res
          (finalize-message-digest
            (##sys#port-data (check-open-digest-output-port loc digest-port 'digest-port))
            result-type)))
    (close-output-port digest-port)
    res ) )

(define (get-output-digest digest-port #!optional (result-type (message-digest-result-form)))
  (*close-output-digest 'get-output-digest digest-port result-type) )

;;;

;; Calls the procedure PROC with a single argument that is a digest-output-port for the MDP.
;; Returns the accumulated output string | blob | u8vector | hexstring

(define (call-with-output-digest mdp proc #!optional (result-type (message-digest-result-form)))
  (let ((port (open-output-digest mdp)))
    (proc port)
    (*close-output-digest 'call-with-output-digest port result-type) ) )

;; Calls the procedure THUNK with the current-input-port temporarily bound to a
;; digest-output-port for the MDP.
;; Returns the accumulated output string | blob | u8vector | hexstring

(define (with-output-to-digest mdp thunk #!optional (result-type (message-digest-result-form)))
  (call-with-output-digest mdp (cut with-input-from-port <> thunk) result-type) )

) ;module message-digest