Mercurial > hg > xemacs-beta

comparison lisp/apropos.el @ 284:558f606b08ae r21-0b40

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-0b40
author cvs
date Mon, 13 Aug 2007 10:34:13 +0200
parents 7df0dd720c89
children 4711e16a8e49
comparison
equal deleted inserted replaced
283:fa3d41851a08 284:558f606b08ae
239 (string-match "\n" doc)) 239 (string-match "\n" doc))
240 "(not documented)")) 240 "(not documented)"))
241 (if (setq doc (symbol-plist symbol)) 241 (if (setq doc (symbol-plist symbol))
242 (if (eq (/ (length doc) 2) 1) 242 (if (eq (/ (length doc) 2) 1)
243 (format "1 property (%s)" (car doc)) 243 (format "1 property (%s)" (car doc))
244 (concat (/ (length doc) 2) " properties"))) 244 (format "%d properties" (/ (length doc) 2))))
245 (if (get symbol 'widget-type) 245 (if (get symbol 'widget-type)
246 (if (setq doc (documentation-property 246 (if (setq doc (documentation-property
247 symbol 'widget-documentation t)) 247 symbol 'widget-documentation t))
248 (substring doc 0 248 (substring doc 0
249 (string-match "\n" doc)) 249 (string-match "\n" doc))
499 (or (symbolp apropos-label-face) 499 (or (symbolp apropos-label-face)
500 (facep apropos-label-face)) ; XEmacs 500 (facep apropos-label-face)) ; XEmacs
501 (setq apropos-label-face `(face ,apropos-label-face 501 (setq apropos-label-face `(face ,apropos-label-face
502 mouse-face highlight))) 502 mouse-face highlight)))
503 (let ((help-buffer-prefix-string "Apropos")) 503 (let ((help-buffer-prefix-string "Apropos"))
504 (with-displaying-help-buffer apropos-regexp 504 (with-displaying-help-buffer
505 (with-current-buffer standard-output 505 (lambda ()
506 (run-hooks 'apropos-mode-hook) 506 (with-current-buffer standard-output
507 (let ((p apropos-accumulator) 507 (run-hooks 'apropos-mode-hook)
508 (old-buffer (current-buffer)) 508 (let ((p apropos-accumulator)
509 symbol item point1 point2) 509 (old-buffer (current-buffer))
510 ;; XEmacs change from (if window-system 510 symbol item point1 point2)
511 (if (device-on-window-system-p) 511 ;; XEmacs change from (if window-system
512 (progn 512 (if (device-on-window-system-p)
513 (princ "If you move the mouse over text that changes color,\n") 513 (progn
514 (princ (substitute-command-keys 514 (princ "If you move the mouse over text that changes color,\n")
515 "you can click \\[apropos-mouse-follow] to get more information.\n")))) 515 (princ (substitute-command-keys
516 (princ (substitute-command-keys 516 "you can click \\[apropos-mouse-follow] to get more information.\n"))))
517 "Type \\[apropos-follow] in this buffer to get full documentation.\n\n")) 517 (princ (substitute-command-keys
518 (while (consp p) 518 "Type \\[apropos-follow] in this buffer to get full documentation.\n\n"))
519 (or (not spacing) (bobp) (terpri)) 519 (while (consp p)
520 (setq apropos-item (car p) 520 (or (not spacing) (bobp) (terpri))
521 symbol (car apropos-item) 521 (setq apropos-item (car p)
522 p (cdr p) 522 symbol (car apropos-item)
523 point1 (point)) 523 p (cdr p)
524 (princ symbol) ; print symbol name 524 point1 (point))
525 (setq point2 (point)) 525 (princ symbol) ; print symbol name
526 ;; Calculate key-bindings if we want them. 526 (setq point2 (point))
527 (and do-keys 527 ;; Calculate key-bindings if we want them.
528 (commandp symbol) 528 (and do-keys
529 (indent-to 30 1) 529 (commandp symbol)
530 (if (let ((keys 530 (indent-to 30 1)
531 (save-excursion 531 (if (let ((keys
532 (set-buffer old-buffer) 532 (save-excursion
533 (where-is-internal symbol))) 533 (set-buffer old-buffer)
534 filtered) 534 (where-is-internal symbol)))
535 ;; Copy over the list of key sequences, 535 filtered)
536 ;; omitting any that contain a buffer or a frame. 536 ;; Copy over the list of key sequences,
537 (while keys 537 ;; omitting any that contain a buffer or a frame.
538 (let ((key (car keys)) 538 (while keys
539 (i 0) 539 (let ((key (car keys))
540 loser) 540 (i 0)
541 (while (< i (length key)) 541 loser)
542 (if (or (framep (aref key i)) 542 (while (< i (length key))
543 (bufferp (aref key i))) 543 (if (or (framep (aref key i))
544 (setq loser t)) 544 (bufferp (aref key i)))
545 (setq i (1+ i))) 545 (setq loser t))
546 (or loser 546 (setq i (1+ i)))
547 (setq filtered (cons key filtered)))) 547 (or loser
548 (setq keys (cdr keys))) 548 (setq filtered (cons key filtered))))
549 (setq item filtered)) 549 (setq keys (cdr keys)))
550 ;; Convert the remaining keys to a string and insert. 550 (setq item filtered))
551 (princ 551 ;; Convert the remaining keys to a string and insert.
552 (mapconcat 552 (princ
553 (lambda (key) 553 (mapconcat
554 (setq key (key-description key)) 554 (lambda (key)
555 (if apropos-keybinding-face 555 (setq key (key-description key))
556 (put-text-property 0 (length key) 556 (if apropos-keybinding-face
557 'face apropos-keybinding-face 557 (put-text-property 0 (length key)
558 key)) 558 'face apropos-keybinding-face
559 key) 559 key))
560 item ", ")) 560 key)
561 (princ "Type ") 561 item ", "))
562 (princ "M-x") 562 (princ "Type ")
563 (put-text-property (- (point) 3) (point) 563 (princ "M-x")
564 'face apropos-keybinding-face) 564 (put-text-property (- (point) 3) (point)
565 (princ (format " %s " (symbol-name symbol))) 565 'face apropos-keybinding-face)
566 (princ "RET") 566 (princ (format " %s " (symbol-name symbol)))
567 (put-text-property (- (point) 3) (point) 567 (princ "RET")
568 'face apropos-keybinding-face))) 568 (put-text-property (- (point) 3) (point)
569 (terpri) 569 'face apropos-keybinding-face)))
570 ;; only now so we don't propagate text attributes all over 570 (terpri)
571 (put-text-property point1 point2 'item 571 ;; only now so we don't propagate text attributes all over
572 (if (eval `(or ,@(cdr apropos-item))) 572 (put-text-property point1 point2 'item
573 (car apropos-item) 573 (if (eval `(or ,@(cdr apropos-item)))
574 apropos-item)) 574 (car apropos-item)
575 (if apropos-symbol-face 575 apropos-item))
576 (put-text-property point1 point2 'face apropos-symbol-face)) 576 (if apropos-symbol-face
577 (apropos-print-doc 'describe-function 1 577 (put-text-property point1 point2 'face apropos-symbol-face))
578 (if (commandp symbol) 578 (apropos-print-doc 'describe-function 1
579 "Command" 579 (if (commandp symbol)
580 (if (apropos-macrop symbol) 580 "Command"
581 "Macro" 581 (if (apropos-macrop symbol)
582 "Function")) 582 "Macro"
583 do-keys) 583 "Function"))
584 (if (get symbol 'custom-type) 584 do-keys)
585 (apropos-print-doc 'customize-variable-other-window 2 585 (if (get symbol 'custom-type)
586 "User Option" do-keys) 586 (apropos-print-doc 'customize-variable-other-window 2
587 (apropos-print-doc 'describe-variable 2 587 "User Option" do-keys)
588 "Variable" do-keys)) 588 (apropos-print-doc 'describe-variable 2
589 (apropos-print-doc 'customize-other-window 6 "Group" do-keys) 589 "Variable" do-keys))
590 (apropos-print-doc 'customize-face-other-window 5 "Face" do-keys) 590 (apropos-print-doc 'customize-other-window 6 "Group" do-keys)
591 (apropos-print-doc 'widget-browse-other-window 4 "Widget" do-keys) 591 (apropos-print-doc 'customize-face-other-window 5 "Face" do-keys)
592 (apropos-print-doc 'apropos-describe-plist 3 592 (apropos-print-doc 'widget-browse-other-window 4 "Widget" do-keys)
593 "Plist" nil)))))) 593 (apropos-print-doc 'apropos-describe-plist 3
594 "Plist" nil)))))
595 apropos-regexp))
594 (prog1 apropos-accumulator 596 (prog1 apropos-accumulator
595 (setq apropos-accumulator ())))) ; permit gc 597 (setq apropos-accumulator ())))) ; permit gc
596 598
597 599
598 (defun apropos-macrop (symbol) 600 (defun apropos-macrop (symbol)
666 668
667 669
668 (defun apropos-describe-plist (symbol) 670 (defun apropos-describe-plist (symbol)
669 "Display a pretty listing of SYMBOL's plist." 671 "Display a pretty listing of SYMBOL's plist."
670 (let ((help-buffer-prefix-string "Apropos-plist")) 672 (let ((help-buffer-prefix-string "Apropos-plist"))
671 (with-displaying-help-buffer (symbol-name symbol) 673 (with-displaying-help-buffer
672 (run-hooks 'apropos-mode-hook) 674 (lambda ()
673 (princ "Symbol ") 675 (run-hooks 'apropos-mode-hook)
674 (prin1 symbol) 676 (princ "Symbol ")
675 (princ "'s plist is\n (") 677 (prin1 symbol)
676 (with-current-buffer standard-output 678 (princ "'s plist is\n (")
677 (if apropos-symbol-face 679 (with-current-buffer standard-output
678 (put-text-property 8 (- (point) 14) 'face apropos-symbol-face))) 680 (if apropos-symbol-face
679 (princ (apropos-format-plist symbol "\n ")) 681 (put-text-property 8 (- (point) 14) 'face apropos-symbol-face)))
680 (princ ")") 682 (princ (apropos-format-plist symbol "\n "))
681 (terpri) 683 (princ ")")
682 (print-help-return-message)))) 684 (terpri)
685 (print-help-return-message))
686 (symbol-name symbol))))
683 687
684 (provide 'apropos) ; XEmacs 688 (provide 'apropos) ; XEmacs
685 689
686 ;;; apropos.el ends here 690 ;;; apropos.el ends here