;; Example code of incorporating custodian-handled objects with (lib
;; "foreign.ss").  
;;
;; Mental note: read
;; http://list.cs.brown.edu/pipermail/plt-scheme/2003-July/003129.html.
;; I get the feeling I may want to change some of the code here
;; according to those notes.



(module foreign-util mzscheme
  (require (lib "foreign.ss"))
  (require (prefix lowlevel: #%foreign))
  (require (prefix c: (lib "contract.ss")))
  (unsafe!)

  ;; fixme: contracts
  (provide manage-with-current-custodian)
  (provide register-finalizer/custodian)


  ;; Get at the currently running mzscheme process.
  (define self-lib.so (ffi-lib #f))

  (define custodian-add-managed
    (get-ffi-obj "scheme_add_managed" self-lib.so
                 (_fun _pointer _scheme _fpointer _pointer _int -> _pointer)))

  ;; Checks to see if the custodian's still alive.
  (define custodian-check-available
    (get-ffi-obj "scheme_custodian_check_available" self-lib.so
                 (_fun _pointer _string _string -> _void)))
  
  ;; Builds a low-level C-callable function ready to be passed as a
  ;; _fpointer.
  (define (make-custodian-callback f)
    (lowlevel:ffi-callback f (list _scheme _pointer) _pointer))
  

  ;; manage-with-current-custodian: A (A -> void) string string -> void
  ;; Associates the object to the current-custodian.  When the custodian
  ;; shuts down, the shutdown-f is called.
  ;;
  ;; name and resname are the arguments passed to
  ;; scheme_check_available for error checking; see
  ;; http://download.plt-scheme.org/doc/299.400/html/insidemz/insidemz-Z-H-16.html#node_chap_16
  (define (manage-with-current-custodian object shutdown-f name resname)
    (let ((callback (make-custodian-callback
                     (lambda (obj _)
                       (shutdown-f obj)
                       #f))))
      ;; Attach to the current-custodian
      (custodian-check-available #f name resname)
      (custodian-add-managed #f object callback #f 0)
      (void)))

  
  ;; register-finalizer/custodian: A (A -> void) string string -> void
  ;; Attaches both the finalizer and a custodian to the object.  The
  ;; finalizer will be called at most once.
  (define (register-finalizer/custodian object finalizer name resname)
    (let*
        ((weak-object (make-weak-box object)) ; subtle: weak box
                                              ; necessary to avoid
                                              ; holding hard reference
                                              ; to object in closure
         (mutex (make-semaphore 1))
         (already-finalized? #f)
         (single-entry-finalizer-thunk
          (lambda ()
            (unless already-finalized?
              (set! already-finalized? #t)
              (let ((val (weak-box-value weak-object)))
                (when val
                  (finalizer val))))))
         (synced-finalizer
          (lambda (o)
            (call-with-semaphore mutex single-entry-finalizer-thunk))))
      ;; fixme: what happens if current-custodian gets killed here
      ;; before we get to register finalizers?  Low-level race
      ;; condition?
      (register-finalizer object synced-finalizer)
      (manage-with-current-custodian object synced-finalizer name resname))))





;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Test code below:

(require foreign-util)

(require (lib "foreign.ss"))
(unsafe!)
(define self-lib.so (ffi-lib #f))

(define fopen
  (get-ffi-obj "fopen" self-lib.so (_fun _string _string -> _pointer)))

(define fclose
  (get-ffi-obj "fclose" self-lib.so (_fun _pointer -> _int)))

(define (my-input-fopen name)
  (let* ((file (fopen "/etc/passwd" "r")))
    (register-finalizer/custodian
     file fclose "my-input-fopen" "file-stream")
    file))


(printf "open and shut and open and shut and give a little clap clap clap...~%")
(let loop ()
  (let ((custodian (make-custodian)))
    (parameterize ((current-custodian custodian))
      (my-input-fopen "/etc/passwd")
      ;; As long as we either collect garbage, or call the custodian
      ;; shutdown, our file resource should close down fine.  Comment
      ;; one or the other (but not both!  *grin*) for tests.
      (custodian-shutdown-all (current-custodian))
      (collect-garbage)
      ))
  (loop))