[plt-scheme] Example of working with (lib "foreign.ss") with custodians

Hi everyone,

I thought this snippet of code might come in handy; I wrote some code to
see if I understood how to attach objects of a foreign origin to
custodians.  I exercise the code by just opening a file with fopen, then
using custodian-shutdown-all, and watch with /usr/sbin/lsof to make sure
it really is closing things down.

Some feedback would be useful; it would be great if something like this
were a part of foreign.ss, since it servers an analogous role to
register-finalizer.

Hope this helps!


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Example code of incorporating custodian-handled objects with
;; (lib "foreign.ss").

(require (lib "foreign.ss"))
(require #%foreign)
(unsafe!)

(define self-lib (ffi-lib #f))

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

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


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


(define custodian-check-available
  (get-ffi-obj "scheme_custodian_check_available" self-lib
               (_fun _pointer _string _string -> _void)))


(define (make-custodian-callback f)
  (ffi-callback f (list _scheme _pointer) _pointer))


(define (my-input-fopen name)
  (let ((file (fopen "/etc/passwd" "r"))
        (callback (make-custodian-callback
                   (lambda (f _)
                     (fclose f)
                     #f))))
    ;; Attach to the current custodian
    (custodian-check-available #f "my-input-fopen" "file-stream")
    (custodian-add-managed #f file callback #f 0)
    file))


(printf "open and shut and open and shut and ")
(printf "give a little clap clap clap...~%")
(let loop ()
  (let ((custodian (make-custodian)))
    (parameterize ((current-custodian custodian))
      (my-input-fopen "/etc/passwd")
      (custodian-shutdown-all (current-custodian))))
  (loop))