package に対応した apropos #xyzzy

gistfile1.cl

;; 全パッケージから apropos
(defun apropos-all (string)
  (interactive "sApropos(Regexp): ")
  (with-output-to-temp-buffer ("*Help2*")
    ;; undo はできるようにする
    (setq kept-undo-information (default-value 'kept-undo-information))
    (lisp-interaction-mode)
    (save-excursion
      (dolist (pkg (reverse (list-all-packages)))
        (dolist (line (apropos-filter string pkg))
          (insert line #\LFD)))))
  (let ((buf (find-buffer "*Help*")))
    (when buf
      (delete-buffer buf))))

;; バッファパッケージから apropos
(defun apropos-with-buffer-package (string)
  (interactive "sApropos(Regexp): ")
  (apropos-with-package string *buffer-package*))

;; パッケージを指定して apropos
(defun apropos-with-package (string package)
  (interactive "sApropos(Regexp): \nSPackage: ")
  (let ((*package* (or (find-package package)
                       *package*)))
    (apropos string)))

(defun apropos-filter (string package &key
                              (internal t) (external t)
                              (function t) (variable t))
  (let (result skip)
    (dolist (str (apropos->string-list string package))
      (if (string-match "^ " str)
          (unless skip
            (push str result))
        (multiple-value-bind (sym table)
            (find-symbol str package)
          (if (and sym
                   (string/= str "&environment")
                   (or (and internal (eql table :internal))
                       (and external (eql table :external)))
                   (or (and function (fboundp sym))
                       (and variable (boundp sym))))
              (let ((hide-pkg (and (member (package-name package) '("lisp" "editor" "user")
                                           :test #'string=)
                                   (eql table :external))))
                (push (format nil "~A~A~A"
                              (if hide-pkg
                                  ""
                                (or (car (package-nicknames package))
                                      (package-name package)))
                              (if hide-pkg "" (if (eql table :external) ":" "::"))
                              str)
                      result)
                (setf skip nil))
            (setf skip t)))))
    (nreverse result)))

(defun apropos->string-list (string package)
  (save-window-excursion
    (unwind-protect
        (progn
          (apropos-with-package string package)
          (split-string (buffer-substring (point-min) (point-max)) #\LFD))
      (erase-buffer (selected-buffer)))))