source: project/release/4/message-digest/tags/3.8.0/message-digest-update-item.scm @ 35045

;;;; message-digest-update-item.scm
;;;; Kon Lovett, Jan '06 (message-digest.scm)
;;;; Kon Lovett, May '10 (message-digest.scm)
;;;; Kon Lovett, Apr '12
;;;; Kon Lovett, Aug '17

;; Issues

(module message-digest-update-item

(;export
  message-digest-update-object
  message-digest-update-procedure
  message-digest-update-port
  message-digest-update-file)

(import scheme chicken)

(use
  (only lolevel number-of-bytes pointer?)
  (only posix
    file-open file-close
    open/rdonly
    directory?)
    (only miscmacros while*)
  message-digest-primitive
  message-digest-type
  message-digest-chunk
  message-digest-support
  type-checks
  type-errors)

;;; Support

;;

;=> #f or converted-chunk
(define (chunk-convert obj)
  (and-let* ((cnv (message-digest-chunk-converter)))
    (cnv obj) ) )

(define (get-port-chunk-reader in)
        ((message-digest-chunk-port-read-maker) in) )

(define (get-fileno-chunk-reader fd)
        ((message-digest-chunk-fileno-read-maker) fd) )

(define (get-update md)
  (message-digest-primitive-update (message-digest-algorithm md)) )

(define (get-raw-update md)
  (message-digest-primitive-raw-update (message-digest-algorithm md)) )

;;

(define (do-object-update loc md src start end)
  (cond
    ((input-port? src)    (do-port-update loc md src start end) )
    ((procedure? src)     (do-procedure-update loc md src start end) )
    (else                 (do-bytes-update loc md src start end) ) ) )

(define (do-port-update loc md in start end)
  (do-procedure-update loc md (get-port-chunk-reader in) start end) )

(define (do-bytes-update loc md src start end)
  (do-byte-source-update
    loc
    (message-digest-context md)
    src
    (get-update md)
    (get-raw-update md)
    start end) )

(define (do-procedure-update loc md proc start end)
  (let ((s-updt (get-update md))
        (r-updt (get-raw-update md))
        (ctx (message-digest-context md)) )
    ;note the 'src' object (return of proc) may or may not be unique
    (while* (proc)
      (do-byte-source-update loc ctx it s-updt r-updt start end) ) ) )

(define (do-byte-source-update loc ctx src s-updt r-updt start end)
  (cond
    ; simple bytes
    ((blob? src)
      (let ((src (blob/slice src start end)))
          (s-updt ctx src (blob-size src)) ) )
    ((string? src)
      (let ((src (string/slice src start end)))
          (s-updt ctx src (string-length src)) ) )
    ((message-digest-raw-chunk? src)
      (let* ((obj (message-digest-raw-chunk-object src))
             (updtr (if (pointer? obj) r-updt s-updt)))
        (unless updtr
          (error loc "primitive does not support raw-update") )
        (updtr ctx
          obj
          (message-digest-raw-chunk-size src)
          #;(message-digest-raw-chunk-start src)
          ) ) )
    ; more complicated bytes
    ((object->bytevector-like src) =>
        (cut do-byte-source-update loc ctx <> s-updt r-updt start end) )
    ; too complicated bytes
    (else
      (signal-type-error loc "indigestible object" src start end) ) ) )

;;

;=> #f or bytevector-like
(define (object->bytevector-like obj)
  (or
    (packed-vector->blob/shared obj)
    (chunk-convert obj)) )

;;; Update Operation

;;

(define (message-digest-update-object md obj #!optional (start 0) (end #f))
  (do-object-update
    'message-digest-update-object
    (check-message-digest 'message-digest-update-object md)
    obj
    start end) )

;;

(define (message-digest-update-procedure md proc)
  (do-procedure-update
    'message-digest-update-procedure
    (check-message-digest 'message-digest-update-procedure md)
    (check-procedure 'message-digest-update-procedure proc)
    0 #f) )

;;

(define (message-digest-update-port md in)
  (do-port-update
    'message-digest-update-port
    (check-message-digest 'message-digest-update-port md)
    (check-input-port 'message-digest-update-port in)
    0 #f) )

;;

(define (message-digest-update-file md flnm)
  ;
  (unless (file-exists? (check-string 'message-digest-update-file flnm))
    (error 'message-digest-update-file "no such file" flnm) )
  ;
  #; ;can't open a directory?
  (when (directory? flnm)
    (error 'message-digest-update-file "file is a directory" flnm) )
  ;
  (if (get-raw-update (check-message-digest 'message-digest-update-file md))
    (*message-digest-update-file/fileno 'message-digest-update-file md flnm)
    (*message-digest-update-file/port 'message-digest-update-file md flnm) ) )

(define (*message-digest-update-file/fileno loc md flnm)
  (let ((fd (file-open flnm open/rdonly)))
    (handle-exceptions
      ;as
      exn
      ;with
      (begin
        (file-close fd)
        (abort exn) )
      ;in
      (do-procedure-update loc md (get-fileno-chunk-reader fd) 0 #f) )
    (file-close fd) ) )

(define (*message-digest-update-file/port loc md flnm)
  (let ((in (open-input-file flnm)))
    (handle-exceptions
      ;as
      exn
      ;with
      (begin
        (close-input-port in)
        (abort exn) )
      ;in
      (do-port-update loc md in 0 #f) )
    (close-input-port in) ) )

#;
(define (message-digest-update-file md flnm)
  (let ((in #f))
        (dynamic-wind
                (lambda () (set! in (open-input-file flnm)) )
                (lambda () (do-port-update 'message-digest-update-file md in) )
        (lambda () (close-input-port in) ) ) ) )

) ;module message-digest-update-item