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

;;;;message-digest-chunk.scm
;;;;Kon Lovett, Aug '17  (message-digest-parameters.scm)

;;Issues
;;
;; - Uses 'context-info' to determine whether active context is "own" allocation or
;; callers. Again, a kludge.
;;
;; - Passes u8vector to update phase as a blob.

(module message-digest-chunk

(;export
  ;chunk
  message-digest-raw-chunk?
  message-digest-raw-chunk-object
  message-digest-raw-chunk-size message-digest-raw-chunk-start
  ;
  message-digest-chunk-size
  message-digest-chunk-port-read-maker
  message-digest-chunk-fileno-read-maker
  message-digest-chunk-read-maker ;DEPRECATED
  message-digest-chunk-converter)

(import scheme chicken)

(use
  (only posix file-size)
  (only srfi-4
    u8vector->blob/shared subu8vector
    read-u8vector! make-u8vector)
  miscmacros)

;;; Update Phase Helpers

;;

(define (positive-fixnum? obj)
  (and (fixnum? obj) (positive? obj)) )

;;

(define (default-chunk-port-read-maker in #!optional (size (message-digest-chunk-size)))
  (let ((u8buf (make-u8vector size)))
    (lambda ()
      (let ((len (read-u8vector! size u8buf in)))
        (and
          (positive? len)
          (let ((u8buf (if (fx= len size) u8buf (subu8vector u8buf 0 len))))
            (u8vector->blob/shared u8buf) ) ) ) ) ) )

(define-record-type message-digest-raw-chunk
  (make-message-digest-raw-chunk obj siz beg)
  message-digest-raw-chunk?
  (obj message-digest-raw-chunk-object)
  (siz message-digest-raw-chunk-size)
  (beg message-digest-raw-chunk-start) )

(define (default-chunk-fileno-read-maker fd #!optional (size (file-size fd)))
  (if (zero? size)
    (lambda ()
      #f )
    (let-values (((buffer cleanup)
                  (mapped-buffer 'default-chunk-fileno-read-maker fd size)))
      (let ((chunk (make-message-digest-raw-chunk buffer size 0)))
        (lambda ()
          (if buffer
            (begin0
              chunk
              (set! buffer #f))
            (begin
              (cleanup)
              #f ) ) ) ) ) ) )

(cond-expand
  ((and windows (not cygwin))
    (import (only lolevel allocate free))
    (require-library lolevel)
    (begin
      (define read-into-buffer
        (foreign-lambda* bool ((int fd) (c-pointer buffer) (integer size))
          "C_return(read(fd, buffer, size) == size);") )
      (define (mapped-buffer loc fd size)
        (let* ((buffer (allocate size))
               (finalize (cut free buffer)) )
          (unless (read-into-buffer fd buffer size)
            (finalize)
            (error loc "cannot read file") )
          (values buffer finalize) ) ) ) )
  (else
    (import
      (only posix
        map-file-to-memory unmap-file-from-memory
        memory-mapped-file-pointer
        map/shared
        prot/read))
    (require-library posix)
    (define (mapped-buffer loc fd size)
      (let* ((mmap (map-file-to-memory #f size prot/read map/shared fd))
             (ptr (memory-mapped-file-pointer mmap))
             (finalize (cut unmap-file-from-memory mmap)) )
        (values ptr finalize) ) ) ) )

;;

(define-constant DEFAULT-CHUNK-SIZE 1024)

;;; Message Digest "chunk"

;;

(define-parameter message-digest-chunk-size DEFAULT-CHUNK-SIZE
  (lambda (x)
    (cond
      ((positive-fixnum? x)   x )
      ((not x)                DEFAULT-CHUNK-SIZE )
      (else
        (warning 'message-digest-chunk-size "invalid positive-fixnum" x)
        (message-digest-chunk-size) ) ) ) )

;;

(define-parameter message-digest-chunk-port-read-maker default-chunk-port-read-maker
  (lambda (x)
    (cond
      ((procedure? x)   x )
      ((not x)          default-chunk-port-read-maker )
      (else
        (warning 'message-digest-chunk-port-read-maker "invalid procedure" x)
        (message-digest-chunk-port-read-maker) ) ) ) )

(define message-digest-chunk-read-maker message-digest-chunk-port-read-maker)

;;

(define-parameter message-digest-chunk-fileno-read-maker default-chunk-fileno-read-maker
  (lambda (x)
    (cond
      ((procedure? x)   x )
      ((not x)          default-chunk-fileno-read-maker )
      (else
        (warning 'message-digest-chunk-fileno-read-maker "invalid procedure" x)
        (message-digest-chunk-fileno-read-maker) ) ) ) )

;;

(define-parameter message-digest-chunk-converter #f
  (lambda (x)
    (if (or (not x) (procedure? x))
      x
      (begin
        (warning 'message-digest-chunk-converter "invalid procedure or #f" x)
        (message-digest-chunk-converter) ) ) ) )

) ;module message-digest-chunk