s c h e m a t i c s : c o o k b o o k

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

  ;; FIXME: add the proper contract to register-custodian.  From notes in the thread:
  ;;
  ;; http://list.cs.brown.edu/pipermail/plt-scheme/2005-September/009746.html
  ;;
  ;; it sounds like getting the proper polymorphic contract is
  ;; slightly harder than I thought, so I'll be a bit loose here.
  ;; I'll need to read more about contracts before I dive into this
  ;; further.
  (c:provide/contract
   (register-custodian (c:any/c c:any/c string? string? . c:-> . void?)))

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

  ;; Checks to see if the custodian's still alive.  Raises an error if
  ;; the custodian's already done for.
  (define custodian-check-available
    (get-ffi-obj "scheme_custodian_check_available" self-lib.so
                 (_fun _pointer _string _string -> _void)))

  ;; Adds a callback function to an object that's about to be
  ;; terminated by a custodian.
  (define custodian-add-managed
    (get-ffi-obj "scheme_add_managed" self-lib.so
                 (_fun _pointer _scheme _fpointer _pointer _int -> _pointer)))
  
  ;; Builds a low-level C-callable function ready to be passed as a
  ;; _fpointer to custodian-add-managed.  Don't forget to hold a
  ;; reference to this callback somewhere so it doesn't get GC'ed.
  (define (make-custodian-callback f)
    (lowlevel:ffi-callback f (list _scheme _pointer) _pointer))

  
  ;; register-custodian: A (A -> void) string string -> void
  ;;
  ;; Registers an object to a shutdown procedure with the
  ;; current-custodian.  If an error occurs during registration,
  ;; raises an error with name and resname.
  (define register-custodian
    (let* ((registered-finalizers '())
           (add-registered-finalizer!
            (lambda (f) (set! registered-finalizers (cons f registered-finalizers))))
           (remove-registered-finalizer!
            (lambda (f) (set! registered-finalizers (remove f registered-finalizers)))))
      (lambda (object finalizer name resname)
        (let*
            ((callback-box (box #f))
             (wrapped-finalizer (lambda (o)
                                  (remove-registered-finalizer! (unbox callback-box))
                                  (finalizer o))))
          ;; fixme: what happens if current-custodian gets killed here
          ;; before we get to register finalizers?  Low-level race
          ;; condition?
          (let ((callback-val
                 (attach-to-current-custodian object wrapped-finalizer name resname)))
            (set-box! callback-box callback-val)
            (add-registered-finalizer! callback-val))))))
  

  ;; attach-to-current-custodian: A (A -> void) string string -> callback
  ;; Associates the object to the current-custodian.  When the custodian
  ;; shuts down, the shutdown-f is called.
  ;;
  ;; Returns the C callback that will be called when
  ;; custodian-shutdown-all is called.  Danger: there aren't any hard
  ;; references to this callback, so callers of this function must be
  ;; careful to make sure this value isn't GC-ed before the custodian
  ;; runs.
  ;;
  ;; 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 (attach-to-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)
      callback)))

(require "custodian-util.ss")
(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)))
(let loop ()
  (parameterize ((current-custodian (make-custodian)))
    (let ((file (fopen "/etc/passwd" "r")))
      (register-custodian file fclose "fopen" "io")
      (custodian-shutdown-all (current-custodian))))
  (loop))