Re: eval-after-provision

;; I could have possibly used eval-after-load defined in subr.el.
;; load defines load-history is a list of lists - each list looks like:
;;   (loadfilename (require . <foo>)* symbols* (provide . <provide>))
;;
;; (featurep 'mmm-vars)
;; (file-provides (feature-file 'mmm-vars))
;; (file-requires (feature-file 'mmm-vars))
;; (file-dependents (feature-file 'mmm-vars))
;; (feature-symbols 'mmm-vars)
;; (feature-file 'mmm-vars)
;; (symbol-file 'mmm-global-mode)

;; helper function - see what features get loaded elsewhere.
(defun features-not-loaded ()
  (let ((result nil))
    (dolist (feature features)
      (if (null (feature-file feature)) (push feature result)))
    (nreverse result)))

;;The following features are not in load-history
;;These features are provided either in c source code or in the dumped lisp?
;;(defvar features-not-loaded (features-not-loaded))


;; Helper function - see all files that define symbol.
(defun all-symbol-files (symbol)
  (let ((result ()))
    (dolist (symbols load-history)
      (if (memq symbol (cdr symbols)) (push (car symbols) result)))
    (nreverse result)))

;debugging forms:
;(all-symbol-files 'require)
;(all-symbol-files 'provide)
;(all-symbol-files 'load)
;  ("efs" "/opt/sfw/lib/xemacs-21.4.11/lisp/code-files.elc")

;(ad-get-advice-info 'load)
;(ad-get-advice-info 'provide)
;(ad-get-advice-info 'require)


;; Keep track of nesting level of require/load.
;; Do not do after-provide stuff until we know that we are done loading the files.
;; Some files do the provide at the top of the file.
(defvar load-level 0)
(defvar after-provided-sit-for nil)


;;****************************************************************
;;ADD-TO-AFTER-PROVIDEDS
;;Build after-provideds an alist of alists:
;;  (foo . ((<fn1> . result) (<fn2> . result)))
;;****************************************************************
(defvar after-provideds ())
(defun add-to-after-provideds (symbol function result)
  ;;(add-to-list 'after-provideds (list symbol nil  function))
  (let ((list (assq symbol after-provideds)))
    (if (null list)
        (push (setq list (list symbol)) after-provideds))
    (let ((element (assoc function (cdr list))))
      (if (null element)
          (setf (cdr list) (cons (setq element (cons function nil)) (cdr list))))
      (setf (cdr element) result))))


;;****************************************************************
;;AFTER-PROVIDED 'feature (lambda () <forms>)
;;  If "feature" is string, then use eval-after-load to provide 'feature
;; If feature is list, then do function after each feature in list is provided.
;; If feature has already been provided, then forms are immediately performed. 
;;****************************************************************
(put 'after-provided 'lisp-indent-function 1)
(defun after-provided (symbol function)
  ;; check function - if not functionp then wrap lambda around it.
  (if (not (functionp function))
      (setq function `(lambda () ,function)))
  ;; If symbol is really a string, then use eval-after-load to provide symbol
  ;; This is necessary when file does not do a provide.
  (if (stringp symbol)
      (if (assoc symbol load-history)
          (provide (setq symbol (intern symbol)))
          (eval-after-load symbol `(provide ',(setq symbol (intern symbol))))))
  (if (listp symbol)
      (dolist (sym symbol symbol) (after-provided sym function))
      (if (memq symbol features)
          ;; Package has already been loaded, just do it.
          (progn
            (message "%s already loaded" symbol)
            (sit-for (or after-provided-sit-for 0))
            (condition-case VAR
                (progn 
                  (funcall function)
                  (add-to-after-provideds symbol function 'immediate))
              (error
               (add-to-after-provideds symbol function `(error ,(car VAR) ,(cdr VAR)))
               (signal (car VAR) (cdr VAR)))))
          ;; Keep function around until package gets provided.
          (if (member function (get symbol 'after-provide))
              (progn (message "after provided for %s already there" symbol)
                     (sit-for (or after-provided-sit-for 0)) nil)
              (progn     
                (add-to-after-provideds symbol function nil)
                (setf (get symbol 'after-provide)
                      (cons function (get symbol 'after-provide)))
                symbol)))))


;;****************************************************************
;;PROVIDED
;; Execute any after-provided functions for each provided symbol.
;; Protect against errors when calling function.
;;****************************************************************
(defun provided (symbol)
  (while (not (null (get symbol 'after-provide)))
    (message "after %s" symbol)
    (sit-for (or after-provided-sit-for 0))
    (let ((function (pop (get symbol 'after-provide))))
      (condition-case VAR
          (progn 
            (funcall function)
            (add-to-after-provideds symbol function 'executed))
      (error
       (add-to-after-provideds symbol function `(error ,(car VAR) ,(cdr VAR)))
       (signal (car VAR) (cdr VAR)))))))


;; List of packages that have been recently provided.
;; Defer looking for after-provided forms until done loading (load-level is 0)
(defvar provided ())

;;****************************************************************
;;DO-PROVIDED 
;; If at top-level (as far as load/require/provide is concerned),
;; run deferred after-provides.
;;****************************************************************
(defun do-provided (symbol)
  (if (and symbol (not (memq symbol provided))) (push symbol provided))
  ;; If load has caused some packages to have been provided then do after stuff, when done loading.
  (when (zerop load-level)
    (while (not (null provided))
      (provided (pop provided)))))

;;****************************************************************
;;Advise LOAD, PROVIDE, REQUIRE
;;Each advice does the same basic thing.  
;; 1. Increments load-level while the real function runs
;; 2. restores load-level when done
;; 3. Calls do-provided when done. 
;; 4. Protects against errors
;;****************************************************************
(defadvice load (around after-provided first activate protect)
  (let ((original-load-level load-level))
    (condition-case ERROR
        (progn 
          (incf load-level)
          ad-do-it
          (decf load-level)
          (do-provided nil))
      (error
       (setq load-level original-load-level)
       (do-provided nil)
       (signal (car ERROR) (cdr ERROR))))))

(defadvice provide (around after-provided first activate protect)
  (interactive  "Sprovides feature: ")
  (let ((original-load-level load-level))
    (condition-case ERROR
        (progn 
          (incf load-level)
          ad-do-it
          (decf load-level)
          ;; Some packages to have been provided do after stuff, when done loading.
          ;; Doing a (provide 'foo) at top level will cause the after stuff to run.
          (do-provided (ad-get-arg 0)))
      (error
       (setq load-level original-load-level)
       (do-provided (ad-get-arg 0))
       (signal (car ERROR) (cdr ERROR))))))

(defadvice require (around after-provided first activate protect)
  (interactive "Srequire symbol: ")
  (let ((original-load-level load-level))
    (condition-case ERROR
        (progn 
          (incf load-level)
          ad-do-it
          (decf load-level)
          ;; If package already loaded just do the cleanup, this also catches the case where
          ;; the package loaded didn't do a provide - underlying require already gave error.
          ;; We're done doing require, look for packages that have been provided.
          (do-provided (ad-get-arg 0)))
      (error
       (setq load-level original-load-level)
       (do-provided (ad-get-arg 0))
       (signal (car ERROR) (cdr ERROR))))))


;;****************************************************************
;;SHOW-PROVIDES
;;  show after-provided forms with status in popup buffer.
;;****************************************************************

(eval-when (compile) (require 'pp))

(defun show-provides ()
  (interactive)
  (require 'pp)
  (let ((outbuf nil)
        (name-of-mode "*after*"))
    (save-excursion
      (setq outbuf (get-buffer-create name-of-mode))
      (set-buffer outbuf)
      (kill-all-local-variables))

    (let ((buffer-save (current-buffer))
	  outwin)
      ;; Pop up the buffer.
      (setq outwin (display-buffer outbuf))
      (unwind-protect
          (progn
            (set-buffer outbuf)
            (setq buffer-read-only nil)
            (buffer-disable-undo (current-buffer))
            (erase-buffer)
            (buffer-enable-undo (current-buffer))
            (set-buffer-modified-p nil)
            (save-window-excursion
              (select-window outwin)
              (goto-char (point-max)))
            (dolist (after-provided after-provideds)
              (let* ((provided (car after-provided))
                     (functions (cdr after-provided))
                     (isfeature (featurep provided))
                     (file (if isfeature (feature-file provided))))
                (insert "\n\n;; PACKAGE: ") (insert (symbol-name provided))
                (when file
                  (insert " provided by ") (insert (prin1-to-string file)))
                (dolist (functionresult functions)
                  (let ((function (car functionresult))
                        (result (cdr functionresult)))
                    (if (and (consp function) (eq (car function) 'lambda))
                        (if (null (cdddr function))
                            (setq function (caddr function))
                            (setq function `(progn ,@(cddr function)))))
                    (insert "\n;;Result: ") 
                    (cond ((null result)
                           (insert "Not executed"))
                          ((eq result 'immediate)
                           (insert "Executed immediately"))
                          ((eq result 'executed)
                           (insert "Executed"))
                          ((and (consp result) (eq (car result) 'error))
                           (insert "ERROR: ") (insert (prin1-to-string (cadr result)))
                           (dolist (info (cddr result))
                             (insert " ") (insert (prin1-to-string info))))
                          (t (insert (prin1-to-string result))))
                    (insert "\n")
                    (insert (pp-to-string function))))))
            (emacs-lisp-mode)
            (font-lock-mode))
       (set-buffer buffer-save)))))

(provide 'after-provided)

;;Don't load tinypath after this package.  It breaks this?
(provide 'tinypath)