cgit.sxemacs.org Git - packages/blob - xemacs-packages/semantic/senator.el

   1 ;;; senator.el --- SEmantic NAvigaTOR
   2
   3 ;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 by David Ponce
   4
   5 ;; Author: David Ponce <david@dponce.com>
   6 ;; Maintainer: David Ponce <david@dponce.com>
   7 ;; Created: 10 Nov 2000
   8 ;; Keywords: syntax
   9 ;; X-RCS: $Id: senator.el,v 1.117 2007/11/07 14:52:12 ponced Exp $
  10
  11 ;; This file is not part of Emacs
  12
  13 ;; This program is free software; you can redistribute it and/or
  14 ;; modify it under the terms of the GNU General Public License as
  15 ;; published by the Free Software Foundation; either version 2, or (at
  16 ;; your option) any later version.
  17
  18 ;; This program is distributed in the hope that it will be useful, but
  19 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  21 ;; General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with this program; see the file COPYING.  If not, write to
  25 ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  26 ;; Boston, MA 02110-1301, USA.
  27
  28 ;;; Commentary:
  29 ;;
  30 ;; This library defines commands and a minor mode to navigate between
  31 ;; semantic language tags in the current buffer.
  32 ;;
  33 ;; The commands `senator-next-tag' and `senator-previous-tag'
  34 ;; navigate respectively to the tag after or before the point.  The
  35 ;; command `senator-jump' directly jumps to a particular semantic
  36 ;; symbol.
  37 ;;
  38 ;; Also, for each built-in search command `search-forward',
  39 ;; `search-backward', `re-search-forward', `re-search-backward',
  40 ;; `word-search-forward' and `word-search-backward', there is an
  41 ;; equivalent `senator-<search-command>' defined which searches only
  42 ;; in semantic tag names.
  43 ;;
  44 ;; The command `senator-isearch-toggle-semantic-mode' toggles semantic
  45 ;; search in isearch mode.  When semantic search is enabled, isearch
  46 ;; is restricted to tag names.
  47 ;;
  48 ;; Finally, the library provides a `senator-minor-mode' to easily
  49 ;; enable or disable the SEmantic NAvigaTOR stuff for the current
  50 ;; buffer.
  51 ;;
  52 ;; The best way to use navigation commands is to bind them to keyboard
  53 ;; shortcuts.  Senator minor mode uses the common prefix key "C-c ,".
  54 ;; The following default key bindings are provided when semantic minor
  55 ;; mode is enabled:
  56 ;;
  57 ;;    key             binding
  58 ;;    ---             -------
  59 ;;    C-c , n         `senator-next-tag'
  60 ;;    C-c , p         `senator-previous-tag'
  61 ;;    C-c , j         `senator-jump'
  62 ;;    C-c , i         `senator-isearch-toggle-semantic-mode'
  63 ;;    C-c , TAB       `senator-complete-symbol'
  64 ;;    C-c , SPC       `senator-completion-menu-popup'
  65 ;;    S-mouse-3       `senator-completion-menu-popup'
  66 ;;    C-c , C-y       `senator-yank-tag'
  67 ;;    C-c , C-w       `senator-kill-tag'
  68 ;;    C-c , M-w       `senator-copy-tag'
  69 ;;
  70 ;; You can customize the `senator-step-at-tag-classes' to navigate (and
  71 ;; search) only between tags of a particular class.  (Such as
  72 ;; functions and variables.)
  73 ;;
  74 ;; Customize `senator-step-at-start-end-tag-classes' to stop at the
  75 ;; start and end of the specified tag classes.
  76 ;;
  77 ;; To have a mode specific customization, do something like this in a
  78 ;; hook:
  79 ;;
  80 ;; (add-hook 'mode-hook
  81 ;;           (lambda ()
  82 ;;             (setq senator-step-at-tag-classes '(function variable))
  83 ;;             (setq senator-step-at-start-end-tag-classes '(function))
  84 ;;             ))
  85 ;;
  86 ;; The above example specifies to navigate (and search) only between
  87 ;; functions and variables, and to step at start and end of functions
  88 ;; only.
  89
  90 ;;; History:
  91 ;;
  92
  93 ;;; Code:
  94 (require 'semantic)
  95 (require 'semantic-ctxt)
  96 (require 'semantic-imenu)
  97 (eval-when-compile
  98   (require 'semanticdb)
  99   (require 'semanticdb-find)
 100   (require 'cl)
 101   )
 102
 103 ;;; Customization
 104 (defgroup senator nil
 105   "SEmantic NAvigaTOR."
 106   :group 'semantic)
 107
 108 ;;;###autoload
 109 (defcustom global-senator-minor-mode nil
 110   "*If non-nil enable global use of senator minor mode."
 111   :group 'senator
 112   :type 'boolean
 113   :require 'senator
 114   :initialize 'custom-initialize-default
 115   :set (lambda (sym val)
 116          (global-senator-minor-mode (if val 1 -1))))
 117
 118 (defcustom senator-minor-mode-hook nil
 119   "Hook run at the end of function `senator-minor-mode'."
 120   :group 'senator
 121   :type 'hook)
 122
 123 ;;;###autoload
 124 (defcustom senator-step-at-tag-classes nil
 125   "*List of tag classes where to step.
 126 A tag class is a symbol like 'variable, 'function, 'type, or other.
 127 If nil navigation steps at any tag found.  This is a buffer local
 128 variable.  It can be set in a mode hook to get a specific langage
 129 navigation."
 130   :group 'senator
 131   :type '(repeat (symbol)))
 132 (make-variable-buffer-local 'senator-step-at-tag-classes)
 133 (semantic-varalias-obsolete 'semantic-step-at-token-ids
 134                             'semantic-step-at-tag-classes)
 135
 136 ;;;###autoload
 137 (defcustom senator-step-at-start-end-tag-classes '(function)
 138   "*List of tag classes where to step at start and end.
 139 A tag class is a symbol like 'variable, 'function, 'type, or other.
 140 If nil, navigation only step at beginning of tags.  If t, step at
 141 start and end of any tag where it is allowed to step.  Also, stepping
 142 at start and end of a tag prevent stepping inside its components.
 143 This is a buffer local variable.  It can be set in a mode hook to get
 144 a specific langage navigation."
 145   :group 'senator
 146   :type '(choice :tag "Identifiers"
 147                  (repeat :menu-tag "Symbols" (symbol))
 148                  (const  :tag "All" t)))
 149 (make-variable-buffer-local 'senator-step-at-start-end-tag-classes)
 150 (semantic-varalias-obsolete 'senator-step-at-start-end-token-ids
 151                             'senator-step-at-start-end-tag-classes)
 152
 153 (defcustom senator-highlight-found t
 154   "*If non-nil highlight tags found.
 155 This option requires semantic 1.3 and above.  This is a buffer
 156 local variable.  It can be set in a mode hook to get a specific
 157 langage behaviour."
 158   :group 'senator
 159   :type 'boolean)
 160 (make-variable-buffer-local 'senator-highlight-found)
 161
 162 ;;; Faces
 163 (defface senator-momentary-highlight-face
 164   '((((class color) (background dark))
 165      (:background "gray30"))
 166     (((class color) (background light))
 167      (:background "gray70")))
 168   "Face used to momentarily highlight tags."
 169   :group 'semantic-faces)
 170
 171 (defface senator-intangible-face
 172   '((((class color) (background light))
 173      (:foreground "gray25"))
 174     (((class color) (background dark))
 175      (:foreground "gray75")))
 176   "Face placed on intangible text."
 177   :group 'semantic-faces)
 178
 179 (defface senator-read-only-face
 180   '((((class color) (background dark))
 181      (:background "#664444"))
 182     (((class color) (background light))
 183      (:background "#CCBBBB")))
 184   "Face placed on read-only text."
 185   :group 'semantic-faces)
 186
 187 ;;;;
 188 ;;;; Common functions
 189 ;;;;
 190
 191 (defsubst senator-parse ()
 192   "Parse the current buffer and return the tags where to navigate."
 193   (semantic-fetch-tags))
 194
 195 (defsubst senator-current-tag ()
 196   "Return the current tag in the current buffer.
 197 Raise an error is there is no tag here."
 198   (or (semantic-current-tag)
 199       (error "No semantic tag here")))
 200 (semantic-alias-obsolete 'senator-current-token 'senator-current-tag)
 201
 202 (defun senator-momentary-highlight-tag (tag)
 203   "Momentary highlight TAG.
 204 Does nothing if `senator-highlight-found' is nil."
 205   (and senator-highlight-found
 206        (semantic-momentary-highlight-tag
 207         tag 'senator-momentary-highlight-face)))
 208
 209 (defun senator-step-at-start-end-p (tag)
 210   "Return non-nil if must step at start and end of TAG."
 211   (and tag
 212        (or (eq senator-step-at-start-end-tag-classes t)
 213            (memq (semantic-tag-class tag)
 214                  senator-step-at-start-end-tag-classes))))
 215
 216 (defun senator-skip-p (tag)
 217   "Return non-nil if must skip TAG."
 218   (and tag
 219        senator-step-at-tag-classes
 220        (not (memq (semantic-tag-class tag)
 221                   senator-step-at-tag-classes))))
 222
 223 (defun senator-middle-of-tag-p (pos tag)
 224   "Return non-nil if POS is between start and end of TAG."
 225   (and (> pos (semantic-tag-start tag))
 226        (< pos (semantic-tag-end   tag))))
 227
 228 (defun senator-step-at-parent (tag)
 229   "Return TAG's outermost parent if must step at start/end of it.
 230 Return nil otherwise."
 231   (if tag
 232       (let (parent parents)
 233         (setq parents (semantic-find-tag-by-overlay
 234                        (semantic-tag-start tag)))
 235         (while (and parents (not parent))
 236           (setq parent  (car parents)
 237                 parents (cdr parents))
 238           (if (or (eq tag parent)
 239                   (senator-skip-p parent)
 240                   (not (senator-step-at-start-end-p parent)))
 241               (setq parent nil)))
 242         parent)))
 243
 244 (defun senator-previous-tag-or-parent (pos)
 245   "Return the tag before POS or one of its parent where to step."
 246   (let (ol tag)
 247     (while (and pos (> pos (point-min)) (not tag))
 248       (setq pos (semantic-overlay-previous-change pos))
 249       (when pos
 250         ;; Get overlays at position
 251         (setq ol (semantic-overlays-at pos))
 252         ;; find the overlay that belongs to semantic
 253         ;; and STARTS or ENDS at the found position.
 254         (while (and ol (not tag))
 255           (setq tag (semantic-overlay-get (car ol) 'semantic))
 256           (unless (and tag (semantic-tag-p tag)
 257                        (or (= (semantic-tag-start tag) pos)
 258                            (= (semantic-tag-end   tag) pos)))
 259             (setq tag nil
 260                   ol (cdr ol))))))
 261     (or (senator-step-at-parent tag) tag)))
 262
 263 (defun senator-full-tag-name (tag parent)
 264   "Compose a full name from TAG name and PARENT names.
 265 That is append to TAG name PARENT names each one separated by
 266 `semantic-type-relation-separator-character'.  The PARENT list is in
 267 reverse order."
 268   (let ((sep  (car semantic-type-relation-separator-character))
 269         (name ""))
 270     (while parent
 271       (setq name (concat name sep
 272                          (semantic-tag-name (car parent)))
 273             parent (cdr parent)))
 274     (concat (semantic-tag-name tag) name)))
 275 (semantic-alias-obsolete 'senator-full-token-name
 276                          'senator-full-tag-name)
 277
 278 (defvar senator-completion-cache nil
 279   "The latest full completion list is cached here.")
 280 (make-variable-buffer-local 'senator-completion-cache)
 281
 282 (defun senator-completion-cache-flush-fcn (&optional ignore)
 283   "Hook run to clear the completion list cache.
 284 It is called each time the semantic cache is changed.
 285 IGNORE arguments."
 286   (setq senator-completion-cache nil))
 287
 288 (defun senator-completion-flatten-stream (stream parents &optional top-level)
 289   "Return a flat list of all tags available in STREAM.
 290 PARENTS is the list of parent tags.  Each element of the list is a
 291 pair (TAG . PARENTS) where PARENTS is the list of TAG parent
 292 tags or nil.  If TOP-LEVEL is non-nil the completion list will
 293 contain only tags at top level.  Otherwise all component tags are
 294 included too."
 295   (let (fs e tag components)
 296     (while stream
 297       (setq tag  (car stream)
 298             stream (cdr stream)
 299             e      (cons tag parents)
 300             fs     (cons e fs))
 301       (and (not top-level)
 302            ;; Not include function arguments
 303            (not (semantic-tag-of-class-p tag 'function))
 304            (setq components (semantic-tag-components tag))
 305            (setq fs (append fs (senator-completion-flatten-stream
 306                                 components e)))))
 307     fs))
 308
 309 (defun senator-completion-function-args (tag)
 310   "Return a string of argument names from function TAG."
 311   (mapconcat #'(lambda (arg)
 312                  (if (semantic-tag-p arg)
 313                      (semantic-tag-name arg)
 314                    (format "%s" arg)))
 315              (semantic-tag-function-arguments tag)
 316              semantic-function-argument-separation-character))
 317
 318 (defun senator-completion-refine-name (elt)
 319   "Refine the name part of ELT.
 320 ELT has the form (NAME . (TAG . PARENTS)).  The NAME refinement is
 321 done in the following incremental way:
 322
 323 - If TAG is a function, append the list of argument names to NAME.
 324
 325 - If TAG is a type, append \"{}\" to NAME.
 326
 327 - If TAG is an include, append \"#\" to NAME.
 328
 329 - If TAG is a package, append \"=\" to NAME.
 330
 331 - If TAG has PARENTS append to NAME, the first separator in
 332   `semantic-type-relation-separator-character', followed by the next
 333   parent name.
 334
 335 - Otherwise NAME is set to \"tag-name@tag-start-position\"."
 336   (let* ((sep     (car semantic-type-relation-separator-character))
 337          (name    (car elt))
 338          (tag     (car (cdr elt)))
 339          (parents (cdr (cdr elt)))
 340          (oname   (semantic-tag-name tag))
 341          (class   (semantic-tag-class tag)))
 342     (cond
 343      ((and (eq class 'function) (string-equal name oname))
 344       (setq name (format "%s(%s)" name
 345                          (senator-completion-function-args tag))))
 346      ((and (eq class 'type) (string-equal name oname))
 347       (setq name (format "%s{}" name)))
 348      ((and (eq class 'include) (string-equal name oname))
 349       (setq name (format "%s#" name)))
 350      ((and (eq class 'package) (string-equal name oname))
 351       (setq name (format "%s=" name)))
 352      (parents
 353       (setq name (format "%s%s%s" name
 354                          (if (semantic-tag-of-class-p
 355                               (car parents) 'function)
 356                              ")" sep)
 357                          (semantic-tag-name (car parents)))
 358             parents (cdr parents)))
 359      (t
 360       (setq name (format "%s@%d" oname
 361                          (semantic-tag-start tag)))))
 362     (setcar elt name)
 363     (setcdr elt (cons tag parents))))
 364
 365 (defun senator-completion-uniquify-names (completion-stream)
 366   "Uniquify names in COMPLETION-STREAM.
 367 That is refine the name part of each COMPLETION-STREAM element until
 368 there is no duplicated names.  Each element of COMPLETION-STREAM has
 369 the form (NAME . (TAG . PARENTS)).  See also the function
 370 `senator-completion-refine-name'."
 371   (let ((completion-stream (sort completion-stream
 372                                  #'(lambda (e1 e2)
 373                                      (string-lessp (car e1)
 374                                                    (car e2)))))
 375         (dupp t)
 376         clst elt dup name)
 377     (while dupp
 378       (setq dupp nil
 379             clst completion-stream)
 380       (while clst
 381         (setq elt  (car clst)
 382               name (car elt)
 383               clst (cdr clst)
 384               dup  (and clst
 385                         (string-equal name (car (car clst)))
 386                         elt)
 387               dupp (or dupp dup))
 388         (while dup
 389           (senator-completion-refine-name dup)
 390           (setq elt (car clst)
 391                 dup (and elt (string-equal name (car elt)) elt))
 392           (and dup (setq clst (cdr clst))))))
 393     ;; Return a usable completion alist where each element has the
 394     ;; form (NAME . TAG).
 395     (setq clst completion-stream)
 396     (while clst
 397       (setq elt  (car clst)
 398             clst (cdr clst))
 399       (setcdr elt (car (cdr elt))))
 400     completion-stream))
 401
 402 (defun senator-completion-stream (stream &optional top-level)
 403   "Return a useful completion list from tags in STREAM.
 404 That is an alist of all (COMPLETION-NAME . TAG) available.
 405 COMPLETION-NAME is an unique tag name (see also the function
 406 `senator-completion-uniquify-names').  If TOP-LEVEL is non-nil the
 407 completion list will contain only tags at top level.  Otherwise all
 408 sub tags are included too."
 409   (let* ((fs (senator-completion-flatten-stream stream nil top-level))
 410          cs elt tag)
 411     ;; Transform each FS element from (TAG . PARENTS)
 412     ;; to (NAME . (TAG . PARENT)).
 413     (while fs
 414       (setq elt (car fs)
 415             tag (car elt)
 416             fs  (cdr fs)
 417             cs  (cons (cons (semantic-tag-name tag) elt) cs)))
 418     ;; Return a completion list with unique COMPLETION-NAMEs.
 419     (senator-completion-uniquify-names cs)))
 420
 421 (defun senator-current-type-context ()
 422   "Return tags in the type context at point or nil if not found."
 423   (let ((context (semantic-find-tags-by-class
 424                   'type (semantic-find-tag-by-overlay))))
 425     (if context
 426         (semantic-tag-type-members
 427          (nth (1- (length context)) context)))))
 428
 429 (defun senator-completion-list (&optional in-context)
 430   "Return a useful completion list from tags in current buffer.
 431 If IN-CONTEXT is non-nil return only the top level tags in the type
 432 context at point or the top level tags in the current buffer if no
 433 type context exists at point."
 434   (let (stream)
 435     (if in-context
 436         (setq stream (senator-current-type-context)))
 437     (or stream (setq stream (senator-parse)))
 438     ;; IN-CONTEXT completion doesn't use nor set the cache.
 439     (or (and (not in-context) senator-completion-cache)
 440         (let ((clst (senator-completion-stream stream in-context)))
 441           (or in-context
 442               (setq senator-completion-cache clst))
 443           clst))))
 444
 445 (defun senator-find-tag-for-completion (prefix)
 446   "Find all tags with a name starting with PREFIX.
 447 Uses `semanticdb' when available."
 448   (let ((tagsa nil)
 449         (tagsb nil))
 450     (if (and (featurep 'semantic-analyze))
 451         (setq tagsa (semantic-analyze-possible-completions
 452                      (semantic-analyze-current-context))))
 453     (setq tagsb
 454           (if (and (featurep 'semanticdb) (semanticdb-minor-mode-p))
 455               ;; semanticdb version returns a list of (DB-TABLE . TAG-LIST)
 456               (semanticdb-deep-find-tags-for-completion prefix)
 457             ;; semantic version returns a TAG-LIST
 458             (semantic-deep-find-tags-for-completion prefix (current-buffer))))
 459     (append tagsa (semanticdb-strip-find-results tagsb))))
 460
 461 ;;; Senator stream searching functions: no more supported.
 462 ;;
 463 (defun senator-find-nonterminal-by-name (&rest ignore)
 464   (error "Use the semantic and semanticdb find API instead"))
 465
 466 (defun senator-find-nonterminal-by-name-regexp (&rest ignore)
 467   (error "Use the semantic and semanticdb find API instead"))
 468
 469 ;;;;
 470 ;;;; Search functions
 471 ;;;;
 472
 473 (defun senator-search-tag-name (tag)
 474   "Search for TAG name in current buffer.
 475 Limit the search to TAG bounds.
 476 If found, set point to the end of the name, and return point.  The
 477 beginning of the name is at (match-beginning 0).
 478 Return nil if not found, that is if TAG name doesn't come from the
 479 source."
 480   (let ((name (semantic-tag-name tag)))
 481     (setq name (if (string-match "\\`\\([^[]+\\)[[]" name)
 482                    (match-string 1 name)
 483                  name))
 484     (goto-char (semantic-tag-start tag))
 485     (when (re-search-forward (concat
 486                               ;; The tag name is expected to be
 487                               ;; between word delimiters, whitespaces,
 488                               ;; or punctuations.
 489                               "\\(\\<\\|\\s-+\\|\\s.\\)"
 490                               (regexp-quote name)
 491                               "\\(\\>\\|\\s-+\\|\\s.\\)")
 492                              (semantic-tag-end tag)
 493                              t)
 494       (goto-char (match-beginning 0))
 495       (search-forward name))))
 496
 497 (defcustom senator-search-ignore-tag-classes
 498   '(code block)
 499   "*List of ignored tag classes.
 500 Tags of those classes are excluded from search."
 501   :group 'senator
 502   :type '(repeat (symbol :tag "class")))
 503
 504 (defun senator-search-default-tag-filter (tag)
 505   "Default function that filters searched tags.
 506 Ignore tags of classes in `senator-search-ignore-tag-classes'"
 507   (not (memq (semantic-tag-class tag)
 508              senator-search-ignore-tag-classes)))
 509
 510 (defvar senator-search-tag-filter-functions
 511   '(senator-search-default-tag-filter)
 512   "List of functions to be called to filter searched tags.
 513 Each function is passed a tag. If one of them returns nil, the tag is
 514 excluded from the search.")
 515
 516 (defun senator-search (searcher text &optional bound noerror count)
 517   "Use the SEARCHER function to search from point for TEXT in a tag name.
 518 SEARCHER is typically the function `search-forward', `search-backward',
 519 `word-search-forward', `word-search-backward', `re-search-forward', or
 520 `re-search-backward'.  See one of the above function to see how the
 521 TEXT, BOUND, NOERROR, and COUNT arguments are interpreted."
 522   (let* ((origin (point))
 523          (count  (or count 1))
 524          (step   (cond ((> count 0) 1)
 525                        ((< count 0) (setq count (- count)) -1)
 526                        (0)))
 527          found next sstart send tag tstart tend)
 528     (or (zerop step)
 529         (while (and (not found)
 530                     (setq next (funcall searcher text bound t step)))
 531           (setq sstart (match-beginning 0)
 532                 send   (match-end 0))
 533           (if (= sstart send)
 534               (setq found t)
 535             (and (setq tag (semantic-current-tag))
 536                  (run-hook-with-args-until-failure
 537                   'senator-search-tag-filter-functions tag)
 538                  (setq tend   (senator-search-tag-name tag))
 539                  (setq tstart (match-beginning 0)
 540                        found  (and (>= sstart tstart)
 541                                    (<= send tend)
 542                                    (zerop (setq count (1- count))))))
 543             (goto-char next))))
 544     (cond ((null found)
 545            (setq next origin
 546                  send origin))
 547           ((= next sstart)
 548            (setq next send
 549                  send sstart))
 550           (t
 551            (setq next sstart)))
 552     (goto-char next)
 553     ;; Setup the returned value and the `match-data' or maybe fail!
 554     (funcall searcher text send noerror step)))
 555
 556 ;;;;
 557 ;;;; Navigation commands
 558 ;;;;
 559
 560 ;;;###autoload
 561 (defun senator-next-tag ()
 562   "Navigate to the next Semantic tag.
 563 Return the tag or nil if at end of buffer."
 564   (interactive)
 565   (let ((pos (point))
 566         (tag (semantic-current-tag))
 567         where)
 568     (if (and tag
 569              (not (senator-skip-p tag))
 570              (senator-step-at-start-end-p tag)
 571              (or (= pos (semantic-tag-start tag))
 572                  (senator-middle-of-tag-p pos tag)))
 573         nil
 574       (if (setq tag (senator-step-at-parent tag))
 575           nil
 576         (setq tag (semantic-find-tag-by-overlay-next pos))
 577         (while (and tag (senator-skip-p tag))
 578           (setq tag (semantic-find-tag-by-overlay-next
 579                        (semantic-tag-start tag))))))
 580     (if (not tag)
 581         (progn
 582           (goto-char (point-max))
 583           (working-message "End of buffer"))
 584       (cond ((and (senator-step-at-start-end-p tag)
 585                   (or (= pos (semantic-tag-start tag))
 586                       (senator-middle-of-tag-p pos tag)))
 587              (setq where "end")
 588              (goto-char (semantic-tag-end tag)))
 589             (t
 590              (setq where "start")
 591              (goto-char (semantic-tag-start tag))))
 592       (senator-momentary-highlight-tag tag)
 593       (working-message "%S: %s (%s)"
 594                        (semantic-tag-class tag)
 595                        (semantic-tag-name  tag)
 596                        where))
 597     tag))
 598 (semantic-alias-obsolete 'senator-next-token 'senator-next-tag)
 599
 600 ;;;###autoload
 601 (defun senator-previous-tag ()
 602   "Navigate to the previous Semantic tag.
 603 Return the tag or nil if at beginning of buffer."
 604   (interactive)
 605   (let ((pos (point))
 606         (tag (semantic-current-tag))
 607         where)
 608     (if (and tag
 609              (not (senator-skip-p tag))
 610              (senator-step-at-start-end-p tag)
 611              (or (= pos (semantic-tag-end tag))
 612                  (senator-middle-of-tag-p pos tag)))
 613         nil
 614       (if (setq tag (senator-step-at-parent tag))
 615           nil
 616         (setq tag (senator-previous-tag-or-parent pos))
 617         (while (and tag (senator-skip-p tag))
 618           (setq tag (senator-previous-tag-or-parent
 619                        (semantic-tag-start tag))))))
 620     (if (not tag)
 621         (progn
 622           (goto-char (point-min))
 623           (working-message "Beginning of buffer"))
 624       (cond ((or (not (senator-step-at-start-end-p tag))
 625                  (= pos (semantic-tag-end tag))
 626                  (senator-middle-of-tag-p pos tag))
 627              (setq where "start")
 628              (goto-char (semantic-tag-start tag)))
 629             (t
 630              (setq where "end")
 631              (goto-char (semantic-tag-end tag))))
 632       (senator-momentary-highlight-tag tag)
 633       (working-message "%S: %s (%s)"
 634                        (semantic-tag-class tag)
 635                        (semantic-tag-name  tag)
 636                        where))
 637     tag))
 638 (semantic-alias-obsolete 'senator-previous-token 'senator-previous-tag)
 639
 640 (defvar senator-jump-completion-list nil
 641   "`senator-jump' stores here its current completion list.
 642 Then use `assoc' to retrieve the tag associated to a symbol.")
 643
 644 (defun senator-jump-interactive (prompt &optional in-context no-default require-match)
 645   "Called interactively to provide completion on some tag name.
 646
 647 Use PROMPT.  If optional IN-CONTEXT is non-nil jump in the local
 648 type's context \(see function `senator-current-type-context').  If
 649 optional NO-DEFAULT is non-nil do not provide a default value.  If
 650 optional REQUIRE-MATCH is non-nil an explicit match must be made.
 651
 652 The IN-CONTEXT and NO-DEFAULT switches are combined using the
 653 following prefix arguments:
 654
 655 - \\[universal-argument]       IN-CONTEXT.
 656 - \\[universal-argument] -     NO-DEFAULT.
 657 - \\[universal-argument] \\[universal-argument]   IN-CONTEXT + NO-DEFAULT."
 658   (let* ((arg (prefix-numeric-value current-prefix-arg))
 659          (no-default
 660           (or no-default
 661               ;; The `completing-read' function provided by XEmacs
 662               ;; (21.1) don't allow a default value argument :-(
 663               (featurep 'xemacs)
 664               (= arg -1)                ; C-u -
 665               (= arg 16)))              ; C-u C-u
 666          (in-context
 667           (or in-context
 668               (= arg 4)                 ; C-u
 669               (= arg 16)))              ; C-u C-u
 670          (context
 671           (and (not no-default)
 672                (or (semantic-ctxt-current-symbol)
 673                    (semantic-ctxt-current-function))))
 674          (completing-read-args
 675           (list (if (and context (car context))
 676                     (format "%s(default: %s) " prompt (car context))
 677                   prompt)
 678                 (setq senator-jump-completion-list
 679                       (senator-completion-list in-context))
 680                 nil
 681                 require-match
 682                 ""
 683                 'semantic-read-symbol-history)))
 684     (list
 685      (apply #'completing-read
 686             (if (and context (car context))
 687                 (append completing-read-args context)
 688               completing-read-args))
 689      in-context no-default)))
 690
 691 (defun senator-jump-noselect (sym &optional next-p regexp-p)
 692   "Jump to the semantic symbol SYM.
 693 If NEXT-P is non-nil, then move the the next tag in the search
 694 assuming there was already one jump for the given symbol.
 695 If REGEXP-P is non nil, then treat SYM as a regular expression.
 696 Return the tag jumped to.
 697 Note: REGEXP-P doesn't work yet.  This needs to be added to get
 698 the etags override to be fully functional."
 699   (let ((tag (cdr (assoc sym senator-jump-completion-list))))
 700     (when tag
 701       (set-buffer (semantic-tag-buffer tag))
 702       (goto-char (semantic-tag-start tag))
 703       tag)))
 704
 705 ;;;###autoload
 706 (defun senator-jump (sym &optional in-context no-default)
 707   "Jump to the semantic symbol SYM.
 708
 709 If optional IN-CONTEXT is non-nil jump in the local type's context
 710 \(see function `senator-current-type-context').  If optional
 711 NO-DEFAULT is non-nil do not provide a default value.
 712
 713 When called interactively you can combine the IN-CONTEXT and
 714 NO-DEFAULT switches like this:
 715
 716 - \\[universal-argument]       IN-CONTEXT.
 717 - \\[universal-argument] -     NO-DEFAULT.
 718 - \\[universal-argument] \\[universal-argument]   IN-CONTEXT + NO-DEFAULT."
 719   (interactive (senator-jump-interactive "Jump to: " nil nil t))
 720   (push-mark)
 721   (let ((tag (senator-jump-noselect sym no-default)))
 722     (when tag
 723       (switch-to-buffer (semantic-tag-buffer tag))
 724       (senator-momentary-highlight-tag tag)
 725       (working-message "%S: %s "
 726                        (semantic-tag-class tag)
 727                        (semantic-tag-name  tag)))))
 728
 729 ;;;###autoload
 730 (defun senator-jump-regexp (symregex &optional in-context no-default)
 731   "Jump to the semantic symbol SYMREGEX.
 732 SYMREGEX is treated as a regular expression.
 733
 734 If optional IN-CONTEXT is non-nil jump in the local type's context
 735 \(see function `senator-current-type-context').  If optional
 736 NO-DEFAULT is non-nil do not provide a default value and move to the
 737 next match of SYMREGEX.  NOTE: Doesn't actually work yet.
 738
 739 When called interactively you can combine the IN-CONTEXT and
 740 NO-DEFAULT switches like this:
 741
 742 - \\[universal-argument]       IN-CONTEXT.
 743 - \\[universal-argument] -     NO-DEFAULT.
 744 - \\[universal-argument] \\[universal-argument]   IN-CONTEXT + NO-DEFAULT."
 745   (interactive (senator-jump-interactive "Jump to: "))
 746   (let ((tag (senator-jump-noselect symregex no-default)))
 747     (when tag
 748       (switch-to-buffer (semantic-tag-buffer tag))
 749       (senator-momentary-highlight-tag tag)
 750       (working-message "%S: %s "
 751                        (semantic-tag-class tag)
 752                        (semantic-tag-name  tag)))))
 753
 754 (defvar senator-last-completion-stats nil
 755   "The last senator completion was here.
 756 Of the form (BUFFER STARTPOS INDEX REGEX COMPLIST...)")
 757
 758 (defsubst senator-current-symbol-start ()
 759   "Return position of start of the current symbol under point or nil."
 760   (condition-case nil
 761       (save-excursion (forward-sexp -1) (point))
 762     (error nil)))
 763
 764 ;;;###autoload
 765 (defun senator-complete-symbol (&optional cycle-once)
 766   "Complete the current symbol under point.
 767 If optional argument CYCLE-ONCE is non-nil, only cycle through the list
 768 of completions once, doing nothing where there are no more matches."
 769   (interactive)
 770   (let ((symstart (senator-current-symbol-start))
 771         regex complst)
 772     (if symstart
 773         ;; Get old stats if apropriate.
 774         (if (and senator-last-completion-stats
 775                  ;; Check if completing in the same buffer
 776                  (eq (car senator-last-completion-stats) (current-buffer))
 777                  ;; Check if completing from the same point
 778                  (= (nth 1 senator-last-completion-stats) symstart)
 779                  ;; Check if completing the same symbol
 780                  (save-excursion
 781                    (goto-char symstart)
 782                    (looking-at (nth 3 senator-last-completion-stats))))
 783
 784             (setq complst (nthcdr 4 senator-last-completion-stats))
 785
 786           (setq regex (regexp-quote (buffer-substring symstart (point)))
 787                 complst (senator-find-tag-for-completion regex)
 788                 senator-last-completion-stats (append (list (current-buffer)
 789                                                             symstart
 790                                                             0
 791                                                             regex)
 792                                                       complst))))
 793     ;; Do the completion if apropriate.
 794     (if complst
 795         (let ((ret   t)
 796               (index (nth 2 senator-last-completion-stats))
 797               newtok)
 798           (if (= index (length complst))
 799               ;; Cycle to the first completion tag.
 800               (setq index  0
 801                     ;; Stop completion if CYCLE-ONCE is non-nil.
 802                     ret (not cycle-once)))
 803           ;; Get the new completion tag.
 804           (setq newtok (nth index complst))
 805           (when ret
 806             ;; Move index to the next completion tag.
 807             (setq index (1+ index)
 808                   ;; Return the completion string (useful to hippie
 809                   ;; expand for example)
 810                   ret   (semantic-tag-name newtok))
 811             ;; Replace the string.
 812             (delete-region symstart (point))
 813             (insert ret))
 814           ;; Update the completion index.
 815           (setcar (nthcdr 2 senator-last-completion-stats) index)
 816           ret))))
 817
 818 ;;;;
 819 ;;;; Completion menu
 820 ;;;;
 821
 822 (defcustom senator-completion-menu-summary-function
 823   'semantic-format-tag-concise-prototype
 824   "*Function to use when creating items in completion menu.
 825 Some useful functions are in `semantic-format-tag-functions'."
 826   :group 'senator
 827   :type semantic-format-tag-custom-list)
 828 (make-variable-buffer-local 'senator-completion-menu-summary-function)
 829
 830 (defcustom senator-completion-menu-insert-function
 831   'senator-completion-menu-insert-default
 832   "*Function to use to insert an item from completion menu.
 833 It will receive a Semantic tag as argument."
 834   :group 'senator
 835   :type '(radio (const senator-completion-menu-insert-default)
 836                 (function)))
 837 (make-variable-buffer-local 'senator-completion-menu-insert-function)
 838
 839 (defun senator-completion-menu-insert-default (tag)
 840   "Insert a text representation of TAG at point."
 841   (insert (semantic-tag-name tag)))
 842
 843 (defun senator-completion-menu-do-complete (tag-array)
 844   "Replace the current syntactic expression with a chosen completion.
 845 Argument TAG-ARRAY is an array of one element containting the tag
 846 choosen from the completion menu."
 847   (let ((tag (aref tag-array 0))
 848         (symstart (senator-current-symbol-start))
 849         (finsert (if (fboundp senator-completion-menu-insert-function)
 850                      senator-completion-menu-insert-function
 851                    #'senator-completion-menu-insert-default)))
 852     (if symstart
 853         (progn
 854           (delete-region symstart (point))
 855           (funcall finsert tag)))))
 856
 857 (defun senator-completion-menu-item (tag)
 858   "Return a completion menu item from TAG.
 859 That is a pair (MENU-ITEM-TEXT . TAG-ARRAY).  TAG-ARRAY is an
 860 array of one element containing TAG.  Can return nil to discard a
 861 menu item."
 862   (cons (funcall (if (fboundp senator-completion-menu-summary-function)
 863                      senator-completion-menu-summary-function
 864                    #'semantic-format-tag-prototype) tag)
 865         (vector tag)))
 866
 867 (defun senator-completion-menu-window-offsets (&optional window)
 868   "Return offsets of WINDOW relative to WINDOW's frame.
 869 Return a cons cell (XOFFSET . YOFFSET) so the position (X . Y) in
 870 WINDOW is equal to the position ((+ X XOFFSET) .  (+ Y YOFFSET)) in
 871 WINDOW'S frame."
 872   (let* ((window  (or window (selected-window)))
 873          (e       (window-edges window))
 874          (left    (nth 0 e))
 875          (top     (nth 1 e))
 876          (right   (nth 2 e))
 877          (bottom  (nth 3 e))
 878          (x       (+ left (/ (- right left) 2)))
 879          (y       (+ top  (/ (- bottom top) 2)))
 880          (wpos    (coordinates-in-window-p (cons x y) window))
 881          (xoffset 0)
 882          (yoffset 0))
 883     (if (consp wpos)
 884         (let* ((f  (window-frame window))
 885                (cy (/ 1.0 (float (frame-char-height f)))))
 886           (setq xoffset (- x (car wpos))
 887                 yoffset (float (- y (cdr wpos))))
 888           ;; If Emacs 21 add to:
 889           ;; - XOFFSET the WINDOW left margin width.
 890           ;; - YOFFSET the height of header lines above WINDOW.
 891           (if (> emacs-major-version 20)
 892               (progn
 893                 (setq wpos    (cons (+ left xoffset) 0.0)
 894                       bottom  (float bottom))
 895                 (while (< (cdr wpos) bottom)
 896                   (if (eq (coordinates-in-window-p wpos window)
 897                           'header-line)
 898                       (setq yoffset (+ yoffset cy)))
 899                   (setcdr wpos (+ (cdr wpos) cy)))
 900                 (setq xoffset (floor (+ xoffset
 901                                         (or (car (window-margins window))
 902                                             0))))))
 903           (setq yoffset (floor yoffset))))
 904     (cons xoffset yoffset)))
 905
 906 (defun senator-completion-menu-point-as-event()
 907   "Returns the text cursor position as an event.
 908 Also move the mouse pointer to the cursor position."
 909   (let* ((w (get-buffer-window (current-buffer)))
 910          (x (mod (- (current-column) (window-hscroll))
 911                  (window-width)))
 912          (y (save-excursion
 913               (save-restriction
 914                 (widen)
 915                 (narrow-to-region (window-start) (point))
 916                 (goto-char (point-min))
 917                 (1+ (vertical-motion (buffer-size))))))
 918          )
 919     (if (featurep 'xemacs)
 920         (let* ((at (progn (set-mouse-position w x (1- y))
 921                           (cdr (mouse-pixel-position))))
 922                (x  (car at))
 923                (y  (cdr at)))
 924           (make-event 'button-press
 925                       (list 'button 3
 926                             'modifiers nil
 927                             'x x
 928                             'y y)))
 929       ;; Emacs
 930       (let ((offsets (senator-completion-menu-window-offsets w)))
 931         ;; Convert window position (x,y) to the equivalent frame
 932         ;; position and move the mouse pointer to it.
 933         (set-mouse-position (window-frame w)
 934                             (+ x (car offsets))
 935                             (+ y (cdr offsets)))
 936         t))))
 937
 938 ;;;###autoload
 939 (defun senator-completion-menu-popup ()
 940   "Popup a completion menu for the symbol at point.
 941 The popup menu displays all of the possible completions for the symbol
 942 it was invoked on.  To automatically split large menus this function
 943 use `imenu--mouse-menu' to handle the popup menu."
 944   (interactive)
 945   (let ((symstart (senator-current-symbol-start))
 946         symbol regexp complst
 947         ;; Turn off tag jumping for this menu.
 948         (imenu-default-goto-function (lambda (name pos &optional rest) pos)))
 949     (if symstart
 950         (setq symbol  (buffer-substring-no-properties symstart (point))
 951               regexp  (regexp-quote symbol)
 952               complst (senator-find-tag-for-completion regexp)))
 953     (if (not complst)
 954         (error "No completions available"))
 955     ;; We have a completion list, build a menu
 956     (let ((index (delq nil
 957                        (mapcar #'senator-completion-menu-item
 958                                complst)))
 959           title item)
 960       (cond ;; Here index is a menu structure like:
 961
 962        ;; -1- (("menu-item1" . [tag1]) ...)
 963        ((vectorp (cdr (car index)))
 964         ;; There are more than one item, setup the popup title.
 965         (if (cdr index)
 966             (setq title (format "%S completion" symbol))
 967           ;; Only one item , no need to popup the menu.
 968           (setq item (car index))))
 969
 970        ;; -2- (("menu-title1" ("menu-item1" . [tag1]) ...) ...)
 971        (t
 972         ;; There are sub-menus.
 973         (if (cdr index)
 974             ;; Several sub-menus, setup the popup title.
 975             (setq title (format "%S completion" symbol))
 976           ;; Only one sub-menu, convert it to a main menu and add the
 977           ;; sub-menu title (filename) to the popup title.
 978           (setq title (format "%S completion (%s)"
 979                               symbol (car (car index)))
 980                 index (cdr (car index)))
 981           ;; But...
 982           (or (cdr index)
 983               ;; ... If only one menu item, no need to popup the menu.
 984               (setq item (car index))))))
 985       (or item
 986           ;; `imenu--mouse-menu' automagically splits large menu into
 987           ;; several submenus, displays the popup menu, and returns
 988           ;; the selected item :-)
 989           (setq item (imenu--mouse-menu
 990                       index
 991                       ;; popup at point
 992                       (senator-completion-menu-point-as-event)
 993                       title)))
 994       (if item
 995           (senator-completion-menu-do-complete (cdr item))))))
 996
 997 ;;;;
 998 ;;;; Search commands
 999 ;;;;
1000
1001 ;;;###autoload
1002 (defun senator-search-forward (string &optional bound noerror count)
1003   "Search in tag names forward from point for STRING.
1004 Set point to the end of the occurrence found, and return point.
1005 See also the function `search-forward' for details on the BOUND,
1006 NOERROR and COUNT arguments."
1007   (interactive "sSemantic search: ")
1008   (senator-search 'search-forward string bound noerror count))
1009
1010 ;;;###autoload
1011 (defun senator-re-search-forward (regexp &optional bound noerror count)
1012   "Search in tag names forward from point for regular expression REGEXP.
1013 Set point to the end of the occurrence found, and return point.
1014 See also the function `re-search-forward' for details on the BOUND,
1015 NOERROR and COUNT arguments."
1016   (interactive "sSemantic regexp search: ")
1017   (senator-search 're-search-forward regexp bound noerror count))
1018
1019 ;;;###autoload
1020 (defun senator-word-search-forward (word &optional bound noerror count)
1021   "Search in tag names forward from point for WORD.
1022 Set point to the end of the occurrence found, and return point.
1023 See also the function `word-search-forward' for details on the BOUND,
1024 NOERROR and COUNT arguments."
1025   (interactive "sSemantic word search: ")
1026   (senator-search 'word-search-forward word bound noerror count))
1027
1028 ;;;###autoload
1029 (defun senator-search-backward (string &optional bound noerror count)
1030   "Search in tag names backward from point for STRING.
1031 Set point to the beginning of the occurrence found, and return point.
1032 See also the function `search-backward' for details on the BOUND,
1033 NOERROR and COUNT arguments."
1034   (interactive "sSemantic backward search: ")
1035   (senator-search 'search-backward string bound noerror count))
1036
1037 ;;;###autoload
1038 (defun senator-re-search-backward (regexp &optional bound noerror count)
1039   "Search in tag names backward from point for regular expression REGEXP.
1040 Set point to the beginning of the occurrence found, and return point.
1041 See also the function `re-search-backward' for details on the BOUND,
1042 NOERROR and COUNT arguments."
1043   (interactive "sSemantic backward regexp search: ")
1044   (senator-search 're-search-backward regexp bound noerror count))
1045
1046 ;;;###autoload
1047 (defun senator-word-search-backward (word &optional bound noerror count)
1048   "Search in tag names backward from point for WORD.
1049 Set point to the beginning of the occurrence found, and return point.
1050 See also the function `word-search-backward' for details on the BOUND,
1051 NOERROR and COUNT arguments."
1052   (interactive "sSemantic backward word search: ")
1053   (senator-search 'word-search-backward word bound noerror count))
1054
1055 ;;;;
1056 ;;;; Others useful search commands (minor mode menu)
1057 ;;;;
1058
1059 ;;; Compatibility
1060 (or (not (featurep 'xemacs))
1061     (fboundp 'isearch-update-ring)
1062
1063     ;; Provide `isearch-update-ring' function.
1064     ;; (from XEmacs 21.1.9 isearch-mode.el)
1065     (defun isearch-update-ring (string &optional regexp)
1066       "Add STRING to the beginning of the search ring.
1067 REGEXP says which ring to use."
1068       (if (> (length string) 0)
1069           ;; Update the ring data.
1070           (if regexp
1071               (if (not (setq regexp-search-ring-yank-pointer
1072                              (member string regexp-search-ring)))
1073                   (progn
1074                     (setq regexp-search-ring
1075                           (cons string regexp-search-ring)
1076                           regexp-search-ring-yank-pointer regexp-search-ring)
1077                     (if (> (length regexp-search-ring) regexp-search-ring-max)
1078                         (setcdr (nthcdr (1- regexp-search-ring-max) regexp-search-ring)
1079                                 nil))))
1080             (if (not (setq search-ring-yank-pointer
1081                            ;; really need equal test instead of eq.
1082                            (member string search-ring)))
1083                 (progn
1084                   (setq search-ring (cons string search-ring)
1085                         search-ring-yank-pointer search-ring)
1086                   (if (> (length search-ring) search-ring-max)
1087                       (setcdr (nthcdr (1- search-ring-max) search-ring) nil)))))))
1088
1089     )
1090
1091 (defvar senator-last-search-type nil
1092   "Type of last non-incremental search command called.")
1093
1094 (defun senator-nonincremental-repeat-search-forward ()
1095   "Search forward for the previous search string or regexp."
1096   (interactive)
1097   (cond
1098    ((and (eq senator-last-search-type 'string)
1099          search-ring)
1100     (senator-search-forward (car search-ring)))
1101    ((and (eq senator-last-search-type 'regexp)
1102          regexp-search-ring)
1103     (senator-re-search-forward (car regexp-search-ring)))
1104    (t
1105     (error "No previous search"))))
1106
1107 (defun senator-nonincremental-repeat-search-backward ()
1108   "Search backward for the previous search string or regexp."
1109   (interactive)
1110   (cond
1111    ((and (eq senator-last-search-type 'string)
1112          search-ring)
1113     (senator-search-backward (car search-ring)))
1114    ((and (eq senator-last-search-type 'regexp)
1115          regexp-search-ring)
1116     (senator-re-search-backward (car regexp-search-ring)))
1117    (t
1118     (error "No previous search"))))
1119
1120 (defun senator-nonincremental-search-forward (string)
1121   "Search for STRING  nonincrementally."
1122   (interactive "sSemantic search for string: ")
1123   (setq senator-last-search-type 'string)
1124   (if (equal string "")
1125       (senator-search-forward (car search-ring))
1126     (isearch-update-ring string nil)
1127     (senator-search-forward string)))
1128
1129 (defun senator-nonincremental-search-backward (string)
1130   "Search backward for STRING nonincrementally."
1131   (interactive "sSemantic search for string: ")
1132   (setq senator-last-search-type 'string)
1133   (if (equal string "")
1134       (senator-search-backward (car search-ring))
1135     (isearch-update-ring string nil)
1136     (senator-search-backward string)))
1137
1138 (defun senator-nonincremental-re-search-forward (string)
1139   "Search for the regular expression STRING nonincrementally."
1140   (interactive "sSemantic search for regexp: ")
1141   (setq senator-last-search-type 'regexp)
1142   (if (equal string "")
1143       (senator-re-search-forward (car regexp-search-ring))
1144     (isearch-update-ring string t)
1145     (senator-re-search-forward string)))
1146
1147 (defun senator-nonincremental-re-search-backward (string)
1148   "Search backward for the regular expression STRING nonincrementally."
1149   (interactive "sSemantic search for regexp: ")
1150   (setq senator-last-search-type 'regexp)
1151   (if (equal string "")
1152       (senator-re-search-backward (car regexp-search-ring))
1153     (isearch-update-ring string t)
1154     (senator-re-search-backward string)))
1155
1156 (defvar senator--search-filter nil)
1157
1158 (defun senator-search-set-tag-class-filter (&optional classes)
1159   "In current buffer, limit search scope to tag CLASSES.
1160 CLASSES is a list of tag class symbols or nil.  If nil only global
1161 filters in `senator-search-tag-filter-functions' remain active."
1162   (interactive "sClasses: ")
1163   (setq classes
1164         (cond
1165          ((null classes)
1166           nil)
1167          ((symbolp classes)
1168           (list classes))
1169          ((stringp classes)
1170           (mapcar 'read (split-string classes)))
1171          (t
1172           (signal 'wrong-type-argument (list classes)))
1173          ))
1174   ;; Clear previous filter.
1175   (remove-hook 'senator-search-tag-filter-functions
1176                senator--search-filter t)
1177   (kill-local-variable 'senator--search-filter)
1178   (if classes
1179       (let ((tag   (make-symbol "tag"))
1180             (names (mapconcat 'symbol-name classes "', `")))
1181         (set (make-local-variable 'senator--search-filter)
1182              `(lambda (,tag)
1183                 (memq (semantic-tag-class ,tag) ',classes)))
1184         (semantic-make-local-hook
1185          'senator-search-tag-filter-functions)
1186         (add-hook 'senator-search-tag-filter-functions
1187                   senator--search-filter nil t)
1188         (message "Limit search to `%s' tags" names))
1189     (message "Default search filter restored")))
1190
1191 ;;;;
1192 ;;;; Tag Properties
1193 ;;;;
1194
1195 (defun senator-toggle-read-only (&optional tag)
1196   "Toggle the read-only status of the current TAG."
1197   (interactive)
1198   (let* ((tag  (or tag (senator-current-tag)))
1199          (read (semantic-tag-read-only-p tag)))
1200     (semantic-set-tag-read-only tag read)
1201     (semantic-set-tag-face
1202      tag
1203      (if read nil 'senator-read-only-face))))
1204
1205 (defun senator-toggle-intangible (&optional tag)
1206   "Toggle the tangibility of the current TAG."
1207   (interactive)
1208   (let* ((tag (or tag (senator-current-tag)))
1209          (tang (semantic-tag-intangible-p tag)))
1210     (semantic-set-tag-intangible tag tang)
1211     (semantic-set-tag-face
1212      tag
1213      (if tang nil 'senator-intangible-face))))
1214
1215 (defun senator-set-face (face &optional tag)
1216   "Set the foreground FACE of the current TAG."
1217   (interactive (list (read-face-name
1218                       (if (featurep 'xemacs)
1219                           "Face: "
1220                         ;; GNU Emacs already append ": "
1221                         "Face"))))
1222   (let ((tag (or tag (senator-current-tag))))
1223     (semantic-set-tag-face tag face)))
1224
1225 (defun senator-set-foreground (color &optional tag)
1226   "Set the foreground COLOR of the current TAG."
1227   ;; This was copied from facemenu
1228   (interactive (list (facemenu-read-color "Foreground color: ")))
1229   (let ((face (intern (concat "fg:" color))))
1230     (or (facemenu-get-face face)
1231         (error "Unknown color: %s" color))
1232     (senator-set-face face)))
1233
1234 (defun senator-set-background (color &optional tag)
1235   "Set the background COLOR of the current TAG."
1236   ;; This was copied from facemenu
1237   (interactive (list (facemenu-read-color "Background color: ")))
1238   (let ((face (intern (concat "bg:" color))))
1239     (or (facemenu-get-face face)
1240         (error "Unknown color: %s" color))
1241     (senator-set-face face)))
1242
1243 (defun senator-clear-tag (&optional tag)
1244   "Clear all properties from TAG."
1245   (interactive)
1246   (let ((tag (or tag (senator-current-tag))))
1247     (semantic-set-tag-read-only  tag t)
1248     (semantic-set-tag-intangible tag t)
1249     (semantic-set-tag-face       tag nil)))
1250 (semantic-alias-obsolete 'senator-clear-token 'senator-clear-tag)
1251
1252 ;;; Folding
1253 ;;
1254 ;; Use new folding state.  It might be wise to extend the idea
1255 ;; of folding for hiding all but this, or show all children, etc.
1256
1257 (defun senator-fold-tag (&optional tag)
1258   "Fold the current TAG."
1259   (interactive)
1260   (semantic-set-tag-folded (or tag (semantic-current-tag)) t))
1261
1262 (defun senator-unfold-tag (&optional tag)
1263   "Fold the current TAG."
1264   (interactive)
1265   (semantic-set-tag-folded (or tag (semantic-current-tag)) nil))
1266
1267 (defun senator-fold-tag-toggle (&optional tag)
1268   "Fold the current TAG."
1269   (interactive)
1270   (let ((tag (or tag (semantic-current-tag))))
1271     (if (semantic-tag-folded-p tag)
1272         (senator-unfold-tag tag)
1273       (senator-fold-tag tag))))
1274
1275 ;;;;
1276 ;;;;
1277 ;;;;
1278 (defun senator-go-to-up-reference (&optional tag)
1279   "Move up one reference from the current TAG.
1280 A \"reference\" could be any interesting feature of TAG.
1281 In C++, a function may have a 'parent' which is non-local.
1282 If that parent which is only a reference in the function tag
1283 is found, we can jump to it.
1284 Some tags such as includes have other reference features."
1285   (interactive)
1286   (let ((newtag (semantic-up-reference (or tag (semantic-current-tag)))))
1287     (if (not newtag)
1288         (error "No up reference found")
1289       (push-mark)
1290       (semantic-go-to-tag newtag)
1291       (switch-to-buffer (current-buffer))
1292       (semantic-momentary-highlight-tag newtag))))
1293
1294 (define-overload semantic-up-reference (tag)
1295   "Return a tag that is referredto by TAG.
1296 A \"reference\" could be any interesting feature of TAG.
1297 In C++, a function may have a 'parent' which is non-local.
1298 If that parent which is only a reference in the function tag
1299 is found, we can jump to it.
1300 Some tags such as includes have other reference features.")
1301
1302 (defun semantic-up-reference-default (tag)
1303   "Return a tag that is referredto by TAG.
1304 Makes C/C++ language like assumptions."
1305   (cond ((semantic-tag-faux-p tag)
1306          ;; Faux tags should have a real tag in some other location.
1307          (let ((options (semantic-tag-external-class tag)))
1308            ;; I should do something a little better than
1309            ;; this.  Oy!
1310            (car options)
1311            ))
1312         ((eq (semantic-tag-class tag) 'include)
1313          ;; Include always point to another file.
1314          tag
1315          ;; Note: if you then call 'semantic-go-to-tag', then
1316          ;; you would just to the source of this tag.
1317          )
1318         ((and (eq (semantic-tag-class tag) 'function)
1319               (semantic-tag-function-parent tag))
1320          ;; Is there a parent of the function to jump to?
1321          (let* ((p (semantic-tag-function-parent tag))
1322                 (sr1 (semanticdb-find-tags-by-name p))
1323                 (sr2 (when sr1
1324                        (semanticdb-find-tags-by-class 'type sr1)))
1325                 )
1326            (semanticdb-find-result-nth-in-buffer sr2 0)
1327            )
1328          )
1329         ((and (eq (semantic-tag-class tag) 'function)
1330               (semantic-tag-get-attribute tag :prototype-flag))
1331          ;; Is there a parent of the function to jump to?
1332          (let* ((p (semantic-tag-name tag))
1333                 (sr1 (semanticdb-find-tags-by-name p))
1334                 (sr2 (when sr1
1335                        (semanticdb-find-tags-by-class
1336                         (semantic-tag-class tag)
1337                         sr1)))
1338                 (int 0)
1339                 (len (semanticdb-find-result-length sr2)))
1340            (while (and (< int len)
1341                        (semantic-tag-get-attribute
1342                         (semanticdb-find-result-nth-in-buffer sr2 int)
1343                         :prototype-flag))
1344              (setq int (1+ int)))
1345            (semanticdb-find-result-nth-in-buffer sr2 int)
1346            ))
1347         ((semantic-tag-type tag)
1348          ;; Get the data type, and try to find that.
1349          (let* ((type (semantic-tag-type tag))
1350                 (tn (cond ((stringp type)
1351                            type)
1352                           ((semantic-tag-p type)
1353                            (semantic-tag-name type))
1354                           (t (error "No known type"))))
1355                 (sr1 (semanticdb-find-tags-by-name tn))
1356                 (sr2 (when sr1
1357                        (semanticdb-find-tags-by-class 'type sr1))))
1358            (semanticdb-find-result-nth-in-buffer sr2 0)
1359            ))
1360         (t nil)))
1361
1362 ;;;;
1363 ;;;; Misc. menu stuff.
1364 ;;;;
1365
1366 (defun senator-menu-item (item)
1367   "Build an XEmacs compatible menu item from vector ITEM.
1368 That is remove the unsupported :help stuff."
1369   (if (featurep 'xemacs)
1370       (let ((n (length item))
1371             (i 0)
1372             slot l)
1373         (while (< i n)
1374           (setq slot (aref item i))
1375           (if (and (keywordp slot)
1376                    (eq slot :help))
1377               (setq i (1+ i))
1378             (setq l (cons slot l)))
1379           (setq i (1+ i)))
1380         (apply #'vector (nreverse l)))
1381     item))
1382
1383 ;;;;
1384 ;;;; The dynamic sub-menu of Semantic minor modes.
1385 ;;;;
1386 (defvar senator-registered-mode-entries  nil)
1387 (defvar senator-registered-mode-settings nil)
1388 (defvar senator-modes-menu-cache nil)
1389
1390 (defun senator-register-command-menu (spec global)
1391   "Register the minor mode menu item specified by SPEC.
1392 Return a menu item allowing to change the corresponding minor mode
1393 setting.  If GLOBAL is non-nil SPEC defines a global setting else a
1394 local setting.
1395
1396 SPEC must be a list of the form:
1397
1398 \(CALLBACK [ KEYWORD ARG ] ... )
1399
1400 Where KEYWORD is one of those recognized by `easy-menu-define' plus:
1401
1402 :save VARIABLE
1403
1404 VARIABLE is a variable that will be saved by Custom when using the
1405 \"Modes/Save global settings\" menu item.  This keyword is ignored if
1406 GLOBAL is nil.
1407
1408 By default the returned menu item is setup with:
1409
1410 :active t :style toggle :selected CALLBACK.
1411
1412 So when :selected is not specified the function assumes that CALLBACK
1413 is a symbol which refer to a bound variable too."
1414   (and (consp spec)
1415        (symbolp (car spec))
1416        (fboundp (car spec))
1417        (let* ((callback (car spec))     ; callback function
1418               (props    (cdr spec))     ; properties
1419               (selected callback)       ; selected default to callback
1420               (active   t)              ; active by default
1421               (style    'toggle)        ; toggle style by default
1422               (save     nil)            ; what to save via custom
1423               item key val)
1424          (while props
1425            (setq key   (car  props)
1426                  val   (cadr props)
1427                  props (cddr props))
1428            (cond
1429             ((eq key :save)
1430              (setq save val))
1431             ((eq key :active)
1432              (setq active val))
1433             ((eq key :style)
1434              (setq style val))
1435             ((eq key :selected)
1436              (setq selected val))
1437             (t
1438              (setq item (cons key (cons val item))))))
1439          (if (and global save (symbolp save) (boundp save))
1440              (add-to-list 'senator-registered-mode-settings save))
1441          (setq item (cons :selected (cons selected item))
1442                item (cons :active   (cons active   item))
1443                item (cons :style    (cons style    item))
1444                item (cons callback  item)))))
1445
1446 (defun senator-register-custom-menu (spec)
1447   "Register SPEC as a menu item entry for customizing some aspect of a mode.
1448 SPEC can either be one entry, or a list of SPEC entries.  A SPEC is of
1449 the form
1450
1451 \(SYMBOL [ :KEYWORD ARG ] ...)
1452
1453 Valid keywords include:
1454
1455   :name - ARG represents the string used in the menu item.
1456
1457   :style - ARG represents the style of menu item this is.  Values for ARG
1458            include:
1459      :group  - SYMBOL is a group that `customize-group' will be called on.
1460      :variable - SYMBOL is a variable that `customize-variable' will be called on.
1461      :face - SYMBOL is a face that `customize-face' will be called on.
1462      :toggle - SYMBOL is a variable that will be toggled on and off.
1463
1464      If :style is not specified, the symbol is queried to try and
1465      predict the correct style to use.
1466
1467   :option-symbol - SYMBOL is a variable that contains a value that is from
1468             a list of symbols.  ARG should be a list of symbols that can assign
1469             to the variable SYMBOL."
1470   (if (and (not (null spec)) (not (consp spec)))
1471       (signal 'wrong-type-argument (list spec)))
1472   ;; Turn spec into a list of specs if it is not so already.
1473   (if (and spec (not (consp (car spec)))) (setq spec (list spec)))
1474   (let ((menulist nil)
1475         (item nil))
1476     (while spec
1477       (let* ((sym (car (car spec)))
1478              (pl (cdr (car spec)))
1479              (name (car-safe (cdr-safe (member :name pl))))
1480              (style (car-safe (cdr-safe (member :style pl)))))
1481         (if (not style)
1482             (setq style
1483                   (cond
1484                    ((get sym 'custom-group)
1485                     :group)
1486                    ((facep sym)
1487                     :face)
1488                    ((boundp sym)
1489                     :variable))))
1490         (if (not name)
1491             (setq name (symbol-name sym)))
1492         (setq menulist
1493               (cons
1494                (cond
1495                 ((eq style :group)
1496                  (senator-menu-item
1497                   (vector (concat "Customize Group " name)
1498                           `(lambda (ARG) (interactive "p")
1499                              (customize-group (quote ,sym)))
1500                           :help (format "Customize Group %s" name)))
1501                  )
1502                 ((eq style :variable)
1503                  (senator-menu-item
1504                   (vector (concat "Customize " name)
1505                           `(lambda (ARG) (interactive "p")
1506                              (customize-variable (quote ,sym)))
1507                           :help (format "Customize Variable %s" name)))
1508                  )
1509                 ((eq style :face)
1510                  (senator-menu-item
1511                   (vector (concat "Customize " name)
1512                           `(lambda (ARG) (interactive "p")
1513                              (customize-face (quote ,sym)))
1514                           :help (format "Customize Face %s" name)))
1515                  )
1516                 ((eq style :toggle)
1517                  ))
1518                menulist))
1519         )
1520       (setq spec (cdr spec)))
1521     menulist))
1522
1523 (defun senator-register-mode-menu-entry (name local global &optional custom)
1524   "Register a minor mode menu entry.
1525 This will add menu items to the \"Modes\" menu allowing to change the
1526 minor mode settings.  NAME is the name displayed in the menu.  LOCAL
1527 and GLOBAL define command menu items to respectively change the minor
1528 mode local and global settings.  nil means to omit the corresponding
1529 menu item.  See the function `senator-register-command-menu' for the
1530 command menu specification.  If NAME is already registered the
1531 corresponding entry will be updated with the given LOCAL and GLOBAL
1532 definitions.  If LOCAL and GLOBAL are both nil the NAME entry is
1533 unregistered if present.
1534 Optional fourth argument CUSTOM represents a menu item, or submenu
1535 item that will customize something about the mode being registered.
1536 See the function `senator-register-custom-menu' for the details on
1537 what this menu looks like."
1538   ;; Clear the cached menu to rebuild it.
1539   (setq senator-modes-menu-cache nil)
1540   (let* ((entry (assoc name senator-registered-mode-entries))
1541          (local-item  (senator-register-command-menu local nil))
1542          (global-item (senator-register-command-menu global t))
1543          (custom-item (senator-register-custom-menu custom))
1544          (entry-construct (append (list local-item global-item)
1545                                   custom-item))
1546          )
1547
1548     (if (not (or local-item global-item))
1549         (setq senator-registered-mode-entries
1550               (delq entry senator-registered-mode-entries))
1551       (if entry
1552           (setcdr entry entry-construct)
1553         (setq entry (cons name entry-construct)
1554               senator-registered-mode-entries
1555               (nconc senator-registered-mode-entries (list entry))))
1556       entry)))
1557
1558 (defsubst senator-build-command-menu-item (label props)
1559   "Return a command menu item with an unique name based on LABEL.
1560 PROPS is the list of properties of this menu item."
1561   (if props
1562       (senator-menu-item (apply #'vector (cons label props)))))
1563
1564 (defcustom senator-mode-menu-local-toggle-label  "In this buffer"
1565   "*Label of menu item that toggles a Semantic minor mode locally."
1566   :group 'senator
1567   :type 'string
1568   :set (lambda (sym val)
1569          (set-default sym val)
1570          (setq senator-modes-menu-cache nil)))
1571
1572 (defcustom senator-mode-menu-global-toggle-label "Globally"
1573   "*Label of menu item that toggles a Semantic minor mode globally."
1574   :group 'senator
1575   :type 'string
1576   :set (lambda (sym val)
1577          (set-default sym val)
1578          (setq senator-modes-menu-cache nil)))
1579
1580 (defun senator-build-mode-sub-menu (entry)
1581   "Return a sub-menu for the registered minor mode ENTRY.
1582 The sub-menu displayed in the Senator/Modes menu looks like this:
1583
1584   Entry-Name
1585             [x] In this buffer
1586             [x] Globally
1587             Custom1
1588             Custom2
1589             ...
1590
1591 The menu item \"In this buffer\" toggles the minor mode locally.
1592 The menu item \"Globally\" toggles the minor mode globally."
1593   (let ((mode (nth 1  entry))
1594         (global (nth 2 entry))
1595         (customs (nthcdr 3 entry)))
1596     (delq nil
1597           (append
1598            (list (car entry)
1599                  (senator-build-command-menu-item
1600                   senator-mode-menu-local-toggle-label mode)
1601                  (senator-build-command-menu-item
1602                   senator-mode-menu-global-toggle-label global))
1603            (if (and (symbolp customs) (fboundp customs))
1604                (funcall customs)
1605              customs)))))
1606
1607 (defun senator-build-modes-menu (&rest ignore)
1608   "Build and return the \"Modes\" menu.
1609 It is dynamically build from registered minor mode entries.  See also
1610 the function `senator-register-mode-menu-entry'.
1611 IGNORE any arguments.
1612 This function is a menu :filter."
1613   (or senator-modes-menu-cache
1614       (setq senator-modes-menu-cache
1615             (nconc (mapcar 'senator-build-mode-sub-menu
1616                            senator-registered-mode-entries)
1617                    (list "--"
1618                          (senator-menu-item
1619                           [ "Save global settings"
1620                             senator-save-registered-mode-settings
1621                             :help "\
1622 Save global settings of Semantic minor modes in your init file."
1623                             ]))))))
1624
1625 (defun senator-save-registered-mode-settings ()
1626   "Save current value of registered minor modes global setting.
1627 The setting is saved by Custom.  See the function
1628 `senator-register-mode-menu-entry' for details on how to register a
1629 minor mode entry."
1630   (interactive)
1631   (dolist (opt senator-registered-mode-settings)
1632     (condition-case nil
1633         (customize-save-variable opt (default-value opt))
1634       (error nil))))
1635
1636 ;; Register the various minor modes settings used by Semantic.
1637 (senator-register-mode-menu-entry
1638  "Senator"
1639  '(senator-minor-mode
1640    :help "Turn off Senator minor mode."
1641    )
1642  '(global-senator-minor-mode
1643    :help "Automatically turn on Senator on all Semantic buffers."
1644    :save global-senator-minor-mode
1645    )
1646  '(senator)
1647  )
1648
1649 (senator-register-mode-menu-entry
1650  "Highlight changes"
1651  '(semantic-highlight-edits-mode
1652    :help "Highlight changes tracked by Semantic."
1653    )
1654  '(global-semantic-highlight-edits-mode
1655    :help "Automatically highlight changes in all Semantic buffers."
1656    :save global-semantic-highlight-edits-mode
1657    )
1658  '(semantic-highlight-edits-face)
1659  )
1660
1661 (senator-register-mode-menu-entry
1662  "Show parser state"
1663  '(semantic-show-parser-state-mode
1664    :help "`-': OK, `!': will parse all, `~': will parse part, `@': running."
1665    )
1666  '(global-semantic-show-parser-state-mode
1667    :help "Automatically show parser state in all Semantic buffers."
1668    :save global-semantic-show-parser-state-mode
1669    )
1670  )
1671
1672 (senator-register-mode-menu-entry
1673  "Highlight Unmatched Syntax"
1674  '(semantic-show-unmatched-syntax-mode
1675    :help "Highlight syntax which is not recognized valid syntax."
1676    )
1677  '(global-semantic-show-unmatched-syntax-mode
1678    :help "Automatically highlight unmatched syntax in all Semantic buffers."
1679    :save global-semantic-show-unmatched-syntax-mode
1680    )
1681  '(semantic-unmatched-syntax-face)
1682  )
1683
1684 (senator-register-mode-menu-entry
1685  "Idle Scheduler"
1686  '(semantic-idle-scheduler-mode
1687    :help "Schedule idle time to automatically parse buffer following changes."
1688    )
1689  '(global-semantic-idle-scheduler-mode
1690    :help "Schedule idle time to automatically parse all Semantic buffer following changes."
1691    :save global-semantic-idle-scheduler-mode
1692    )
1693  '((semantic-idle-scheduler-idle-time)
1694    (semantic-idle-scheduler-max-buffer-size)
1695    )
1696  )
1697
1698 (senator-register-mode-menu-entry
1699  "Idle Summaries"
1700  '(semantic-idle-summary-mode
1701    :help "Show tag summaries in idle time."
1702    )
1703  '(global-semantic-idle-summary-mode
1704    :help "Show tag summaries in idle time in all buffers."
1705    :save global-semantic-idle-summary-mode
1706    )
1707  )
1708
1709 (senator-register-mode-menu-entry
1710  "Idle Completion"
1711  '(semantic-idle-completions-mode
1712    :help "Show completion tips in idle time."
1713    )
1714  '(global-semantic-idle-completions-mode
1715    :help "Show completion tips in idle time in all buffers."
1716    :save global-semantic-idle-completions-mode
1717    )
1718  )
1719
1720 (senator-register-mode-menu-entry
1721  "Sticky Func"
1722  '(semantic-stickyfunc-mode
1723    :help "Cause function declaration to become stuck to the header line."
1724    )
1725  '(global-semantic-stickyfunc-mode
1726    :help "Automatically enable sticky function mode in all Semantic buffers."
1727    :save global-semantic-stickyfunc-mode
1728    )
1729  )
1730
1731 (senator-register-mode-menu-entry
1732  "Tag Decoration"
1733  '(semantic-decoration-mode
1734    :help "Decorate Tags."
1735    )
1736  '(global-semantic-decoration-mode
1737    :help "Automatically enable decoration mode in all Semantic buffers."
1738    :save global-semantic-decoration-mode
1739    )
1740
1741  )
1742
1743 \f
1744 ;;;;
1745 ;;;; Global minor mode to show tag names in the mode line
1746 ;;;;
1747
1748 (condition-case nil
1749     (require 'which-func)
1750   (error nil))
1751
1752 (let ((select (cond
1753                ;; Emacs 21
1754                ((boundp 'which-function-mode)
1755                 'which-function-mode)
1756                ;; Emacs < 21
1757                ((boundp 'which-func-mode-global)
1758                 'which-func-mode-global)
1759                (t nil))))
1760   (if (and (fboundp 'which-func-mode) select)
1761       (senator-register-mode-menu-entry
1762        "Which Function"
1763        nil
1764        (list 'which-func-mode
1765              :select select
1766              :help "Enable `which-func-mode' and use it in Semantic buffers."
1767              :save select
1768              ))
1769     ))
1770
1771 (senator-register-mode-menu-entry
1772  "Semantic Database"
1773  nil
1774  '(semanticdb-toggle-global-mode
1775    :active (featurep 'semanticdb)
1776    :selected (and (featurep 'semanticdb) (semanticdb-minor-mode-p))
1777    :suffix (if (and (featurep 'semanticdb) (semanticdb-minor-mode-p))
1778                (if (semanticdb-write-directory-p
1779                     semanticdb-current-database)
1780                    "[persist]"
1781                  "[session]")
1782              "")
1783    :help "Cache tags for killed buffers and between sessions."
1784    :save semanticdb-global-mode
1785    )
1786  )
1787
1788 ;;;;
1789 ;;;; Senator minor mode
1790 ;;;;
1791
1792 (defvar senator-status nil
1793   "Minor mode status displayed in the mode line.")
1794 (make-variable-buffer-local 'senator-status)
1795
1796 (defvar senator-isearch-semantic-mode nil
1797   "Non-nil if isearch does semantic search.
1798 This is a buffer local variable.")
1799 (make-variable-buffer-local 'senator-isearch-semantic-mode)
1800
1801 (defvar senator-prefix-key [(control ?c) ?,]
1802   "The common prefix key in senator minor mode.")
1803
1804 (defvar senator-prefix-map
1805   (let ((km (make-sparse-keymap)))
1806     (define-key km "f"    'senator-search-set-tag-class-filter)
1807     (define-key km "i"    'senator-isearch-toggle-semantic-mode)
1808     (define-key km "j"    'semantic-complete-jump-local) ;senator-jump)
1809     (define-key km "J"    'semantic-complete-jump)
1810     (define-key km "p"    'senator-previous-tag)
1811     (define-key km "n"    'senator-next-tag)
1812     (define-key km "u"    'senator-go-to-up-reference)
1813     (define-key km "\t"   'senator-complete-symbol)
1814     (define-key km " "    'senator-completion-menu-popup)
1815     (define-key km "\C-w" 'senator-kill-tag)
1816     (define-key km "\M-w" 'senator-copy-tag)
1817     (define-key km "\C-y" 'senator-yank-tag)
1818     (define-key km "-"    'senator-fold-tag)
1819     (define-key km "+"    'senator-unfold-tag)
1820
1821     km)
1822   "Default key bindings in senator minor mode.")
1823
1824 (defvar senator-menu-bar
1825   (list
1826    "Senator"
1827    (list
1828     "Navigate"
1829     (senator-menu-item
1830      ["Next"
1831       senator-next-tag
1832       :active t
1833       :help "Go to the next tag found"
1834       ])
1835     (senator-menu-item
1836      ["Previous"
1837       senator-previous-tag
1838       :active t
1839       :help "Go to the previous tag found"
1840       ])
1841     (senator-menu-item
1842      ["Up Reference"
1843       senator-go-to-up-reference
1844       :active t
1845       :help "Navigate up one reference by tag."
1846       ])
1847     (senator-menu-item
1848      ["Jump in this file..."
1849       semantic-complete-jump-local
1850       :active t
1851       :help "Jump to a semantic symbol"
1852       ])
1853     (senator-menu-item
1854      ["Jump to any tag..."
1855       semantic-complete-jump-local
1856       :active t
1857       :help "Jump to a semantic symbol"
1858       ])
1859     (senator-menu-item
1860      ["Narrow to tag"
1861       senator-narrow-to-defun
1862       :active (semantic-current-tag)
1863       :help "Narrow to the bounds of the current tag."
1864       ])
1865     )
1866    (list
1867     "Search"
1868     (senator-menu-item
1869      ["String Forward..."
1870       senator-nonincremental-search-forward
1871       :active t
1872       :help "Search forward for a string"
1873       ])
1874     (senator-menu-item
1875      ["String Backwards..."
1876       senator-nonincremental-search-backward
1877       :active t
1878       :help "Search backwards for a string"
1879       ])
1880     (senator-menu-item
1881      ["Regexp Forward..."
1882       senator-nonincremental-re-search-forward
1883       :active t
1884       :help "Search forward for a regular expression"
1885       ])
1886     (senator-menu-item
1887      ["Regexp Backwards..."
1888       senator-nonincremental-re-search-backward
1889       :active t
1890       :help "Search backwards for a regular expression"
1891       ])
1892     "--"
1893     (senator-menu-item
1894      ["Repeat Forward"
1895       senator-nonincremental-repeat-search-forward
1896       :active (or (and (eq senator-last-search-type 'string)
1897                        search-ring)
1898                   (and (eq senator-last-search-type 'regexp)
1899                        regexp-search-ring))
1900       :help "Repeat last search forward"
1901       ])
1902     (senator-menu-item
1903      ["Repeat Backwards"
1904       senator-nonincremental-repeat-search-backward
1905       :active (or (and (eq senator-last-search-type 'string)
1906                        search-ring)
1907                   (and (eq senator-last-search-type 'regexp)
1908                        regexp-search-ring))
1909       :help "Repeat last search backwards"
1910       ])
1911     "--"
1912     (senator-menu-item
1913      ["Limit search..."
1914       senator-search-set-tag-class-filter
1915       :active t
1916       :help "In current buffer, limit search to certain classes of tag"
1917       ])
1918     (senator-menu-item
1919      ["Semantic isearch mode"
1920       senator-isearch-toggle-semantic-mode
1921       :active t
1922       :style toggle :selected senator-isearch-semantic-mode
1923       :help "Toggle semantic search in isearch mode"
1924       ])
1925     )
1926    (list
1927     "Tag Copy/Paste"
1928     (senator-menu-item
1929      [ "Copy Tag"
1930        senator-copy-tag
1931        :active (semantic-current-tag)
1932        :help "Copy the current tag to the tag ring"
1933        ])
1934     (senator-menu-item
1935      [ "Kill Tag"
1936        senator-kill-tag
1937        :active (semantic-current-tag)
1938        :help "Kill tag text to the kill ring, and copy the tag to the tag ring"
1939        ])
1940     (senator-menu-item
1941      [ "Yank Tag"
1942        senator-yank-tag
1943        :active (not (ring-empty-p senator-tag-ring))
1944        :help "Yank a tag from the tag ring, inserting a summary/prototype"
1945        ])
1946     (senator-menu-item
1947      [ "Copy Tag to Register"
1948        senator-copy-tag-to-register
1949        :active (semantic-current-tag)
1950        :help "Copy the current tag to a register"
1951        ])
1952     )
1953    (list
1954     "Tag Properties"
1955     (senator-menu-item
1956      [ "Fold Tag"
1957        senator-fold-tag-toggle
1958        :active (semantic-current-tag)
1959        :style toggle
1960        :selected (let ((tag (semantic-current-tag)))
1961                    (and tag (semantic-tag-folded-p tag)))
1962        :help "Fold the current tag to one line"
1963        ])
1964     (senator-menu-item
1965      [ "Read Only"
1966        senator-toggle-read-only
1967        :active (semantic-current-tag)
1968        :style toggle
1969        :selected (let ((tag (semantic-current-tag)))
1970                    (and tag (semantic-tag-read-only-p tag)))
1971        :help "Make the current tag read-only"
1972        ])
1973     (senator-menu-item
1974      [ "Intangible"
1975        senator-toggle-intangible
1976        ;; XEmacs extent `intangible' property seems to not exists.
1977        :active (and (not (featurep 'xemacs))
1978                     (semantic-current-tag))
1979        :style toggle
1980        :selected (and (not (featurep 'xemacs))
1981                       (let ((tag (semantic-current-tag)))
1982                         (and tag (semantic-tag-intangible-p tag))))
1983        :help "Make the current tag intangible"
1984        ])
1985     (senator-menu-item
1986      [ "Set Tag Face"
1987        senator-set-face
1988        :active (semantic-current-tag)
1989        :help "Set the face on the current tag"
1990        ])
1991     (senator-menu-item
1992      [ "Set Tag Foreground"
1993        senator-set-foreground
1994        :active (semantic-current-tag)
1995        :help "Set the foreground color on the current tag"
1996        ])
1997     (senator-menu-item
1998      [ "Set Tag Background"
1999        senator-set-background
2000        :active (semantic-current-tag)
2001        :help "Set the background color on the current tag"
2002        ])
2003     (senator-menu-item
2004      [ "Remove all properties"
2005        senator-clear-tag
2006        :active (semantic-current-tag)
2007        :help "Remove all special face properties on the current tag "
2008        ] )
2009     )
2010    (if (or (featurep 'xemacs) (> emacs-major-version 20))
2011        (list "Tag Decorations" :filter 'semantic-build-decoration-mode-menu)
2012      ;; The :filter feature seems broken in GNU Emacs versions before
2013      ;; 21.1.  So dont delay the menu creation.  This also means that
2014      ;; new registered decoration entries will not be added "on the
2015      ;; fly" to the menu :-(
2016      (cons "Tag Decorations" (semantic-build-decoration-mode-menu)))
2017    "--"
2018    (list
2019     "Analyze"
2020     (senator-menu-item
2021      [ "Speedbar Class Browser"
2022        semantic-cb-speedbar-mode
2023        :active t
2024        :help "Start speedbar in Class Broswer mode showing inheritance"
2025        ])
2026     (senator-menu-item
2027      [ "Speedbar Analyzer Mode"
2028        semantic-speedbar-analysis
2029        :active t
2030        :help "Start speedbar in Context Analysis/Completion mode."
2031        ])
2032     (senator-menu-item
2033      [ "Context Analysis Dump"
2034        semantic-analyze-current-context
2035        :active t
2036        :help "Show a dump of an analysis of the current local context"
2037        ])
2038     (senator-menu-item
2039      [ "Smart Completion Dump"
2040        semantic-analyze-possible-completions
2041        :active t
2042        :help "Show a dump of the semantic analyzer's guess at possible completions"
2043        ])
2044     )
2045    (list
2046     "Chart"
2047     (senator-menu-item
2048      [ "Chart Tags by Class"
2049        semantic-chart-tags-by-class
2050        :active t
2051        :help "Catagorize all tags by class, and chart the volume for each class"
2052        ])
2053     (senator-menu-item
2054      [ "Chart Tags by Complexity"
2055        semantic-chart-tag-complexity
2056        :active t
2057        :help "Choose the most complex tags, and chart them by complexity"
2058        ])
2059     (senator-menu-item
2060      [ "Chart File Complexity"
2061        semantic-chart-database-size
2062        :active (and (featurep 'semanticdb) (semanticdb-minor-mode-p))
2063        :help "Choose the files with the most tags, and chart them by volume"
2064        ])
2065     )
2066    (if (or (featurep 'xemacs) (> emacs-major-version 20))
2067        (list "Modes" :filter 'senator-build-modes-menu)
2068      ;; The :filter feature seems broken in GNU Emacs versions before
2069      ;; 21.1.  So dont delay the menu creation.  This also means that
2070      ;; new registered minor mode entries will not be added "on the
2071      ;; fly" to the menu :-(
2072      (cons "Modes" (senator-build-modes-menu)))
2073    "--"
2074    (list
2075     "Imenu Config"
2076     (list
2077      "Tag Sorting Function"
2078      (senator-menu-item
2079       [ "Do not sort"
2080         (setq semantic-imenu-sort-bucket-function nil)
2081         :active t
2082         :style radio
2083         :selected (eq semantic-imenu-sort-bucket-function nil)
2084         :help "Do not sort imenu items"
2085         ])
2086      (senator-menu-item
2087       [ "Increasing by name"
2088         (setq semantic-imenu-sort-bucket-function
2089               'semantic-sort-tags-by-name-increasing)
2090         :active t
2091         :style radio
2092         :selected (eq semantic-imenu-sort-bucket-function
2093                       'semantic-sort-tags-by-name-increasing)
2094         :help "Sort tags by name increasing"
2095         ])
2096      (senator-menu-item
2097       [ "Decreasing by name"
2098         (setq semantic-imenu-sort-bucket-function
2099               'semantic-sort-tags-by-name-decreasing)
2100         :active t
2101         :style radio
2102         :selected (eq semantic-imenu-sort-bucket-function
2103                       'semantic-sort-tags-by-name-decreasing)
2104         :help "Sort tags by name decreasing"
2105         ])
2106      (senator-menu-item
2107       [ "Increasing Case Insensitive by Name"
2108         (setq semantic-imenu-sort-bucket-function
2109               'semantic-sort-tags-by-name-increasing-ci)
2110         :active t
2111         :style radio
2112         :selected (eq semantic-imenu-sort-bucket-function
2113                       'semantic-sort-tags-by-name-increasing-ci)
2114         :help "Sort tags by name increasing and case insensitive"
2115         ])
2116      (senator-menu-item
2117       [ "Decreasing Case Insensitive by Name"
2118         (setq semantic-imenu-sort-bucket-function
2119               'semantic-sort-tags-by-name-decreasing-ci)
2120         :active t
2121         :style radio
2122         :selected (eq semantic-imenu-sort-bucket-function
2123                       'semantic-sort-tags-by-name-decreasing-ci)
2124         :help "Sort tags by name decreasing and case insensitive"
2125         ])
2126      )
2127     (senator-menu-item
2128      [ "Bin tags by class"
2129        (setq semantic-imenu-bucketize-file
2130              (not semantic-imenu-bucketize-file))
2131        :active t
2132        :style toggle
2133        :selected semantic-imenu-bucketize-file
2134        :help "Organize tags in bins by class of tag"
2135        ])
2136     (senator-menu-item
2137      [ "Bins are submenus"
2138        (setq semantic-imenu-buckets-to-submenu
2139              (not semantic-imenu-buckets-to-submenu))
2140        :active t
2141        :style toggle
2142        :selected semantic-imenu-buckets-to-submenu
2143        :help "Organize tags into submenus by class of tag"
2144        ])
2145     (senator-menu-item
2146      [ "Bin tags in components"
2147        (setq semantic-imenu-bucketize-type-members
2148              (not semantic-imenu-bucketize-type-members))
2149        :active t
2150        :style toggle
2151        :selected semantic-imenu-bucketize-type-members
2152        :help "When listing tags inside another tag; bin by tag class"
2153        ])
2154     (senator-menu-item
2155      [ "List other files"
2156        (setq semantic-imenu-index-directory (not semantic-imenu-index-directory))
2157        :active (and (featurep 'semanticdb) (semanticdb-minor-mode-p))
2158        :style toggle
2159        :selected semantic-imenu-index-directory
2160        :help "List all files in the current database in the Imenu menu"
2161        ])
2162     (senator-menu-item
2163      [ "Auto-rebuild other buffers"
2164        (setq semantic-imenu-auto-rebuild-directory-indexes
2165              (not semantic-imenu-auto-rebuild-directory-indexes))
2166        :active (and (featurep 'semanticdb) (semanticdb-minor-mode-p))
2167        :style toggle
2168        :selected semantic-imenu-auto-rebuild-directory-indexes
2169        :help "If listing other buffers, update all buffer menus after a parse"
2170        ])
2171     )
2172    (list
2173     "Options"
2174     (senator-menu-item
2175      ["Semantic..."
2176       (customize-group "semantic")
2177       :active t
2178       :help "Customize Semantic options"
2179       ])
2180     (senator-menu-item
2181      ["Senator..."
2182       (customize-group "senator")
2183       :active t
2184       :help "Customize SEmantic NAvigaTOR options"
2185       ])
2186     (senator-menu-item
2187      ["Semantic Imenu..."
2188       (customize-group "semantic-imenu")
2189       :active t
2190       :help "Customize Semantic Imenu options"
2191       ])
2192     (senator-menu-item
2193      ["Semantic Database..."
2194       (customize-group "semanticdb")
2195       :active t
2196       :help "Customize Semantic Database options"
2197       ])
2198     )
2199    )
2200   "Menu for senator minor mode.")
2201
2202 (defvar senator-minor-menu nil
2203   "Menu keymap build from `senator-menu-bar'.")
2204
2205 (defvar senator-mode-map
2206   (let ((km (make-sparse-keymap)))
2207     (define-key km senator-prefix-key senator-prefix-map)
2208     (define-key km [(shift mouse-3)] 'senator-completion-menu-popup)
2209     (easy-menu-define senator-minor-menu km "Senator Minor Mode Menu"
2210                       senator-menu-bar)
2211     km)
2212   "Keymap for senator minor mode.")
2213
2214 (defvar senator-minor-mode nil
2215   "Non-nil if Senator minor mode is enabled.
2216 Use the command `senator-minor-mode' to change this variable.")
2217 (make-variable-buffer-local 'senator-minor-mode)
2218
2219 (defconst senator-minor-mode-name "n"
2220   "Name shown in the mode line when senator minor mode is on.
2221 Not displayed if the minor mode is globally enabled.")
2222
2223 (defconst senator-minor-mode-isearch-suffix "i"
2224   "String appended to the mode name when senator isearch mode is on.")
2225
2226 (defun senator-mode-line-update ()
2227   "Update the modeline to show the senator minor mode state.
2228 If `senator-isearch-semantic-mode' is non-nil append
2229 `senator-minor-mode-isearch-suffix' to the value of the variable
2230 `senator-minor-mode-name'."
2231   (if (not (and senator-minor-mode senator-minor-mode-name))
2232       (setq senator-status "")
2233     (setq senator-status
2234           (format "%s%s" senator-minor-mode-name
2235                   (if senator-isearch-semantic-mode
2236                       (or senator-minor-mode-isearch-suffix "")
2237                     ""))))
2238   (semantic-mode-line-update))
2239
2240 (defun senator-minor-mode-setup ()
2241   "Actually setup the senator minor mode.
2242 The minor mode can be turned on only if semantic feature is available
2243 and the current buffer was set up for parsing.  When minor mode is
2244 enabled parse the current buffer if needed.  Return non-nil if the
2245 minor mode is enabled."
2246   (if senator-minor-mode
2247       (if (not (and (featurep 'semantic) (semantic-active-p)))
2248           (progn
2249             ;; Disable minor mode if semantic stuff not available
2250             (setq senator-minor-mode nil)
2251             (error "Buffer %s was not set up for parsing"
2252                    (buffer-name)))
2253         ;; XEmacs needs this
2254         (if (featurep 'xemacs)
2255             (easy-menu-add senator-minor-menu senator-mode-map))
2256         ;; Add completion hooks
2257         (semantic-make-local-hook
2258          'semantic-after-toplevel-cache-change-hook)
2259         (add-hook 'semantic-after-toplevel-cache-change-hook
2260                   'senator-completion-cache-flush-fcn nil t)
2261         (semantic-make-local-hook
2262          'semantic-after-partial-cache-change-hook)
2263         (add-hook 'semantic-after-partial-cache-change-hook
2264                   'senator-completion-cache-flush-fcn nil t))
2265     ;; XEmacs needs this
2266     (if (featurep 'xemacs)
2267         (easy-menu-remove senator-minor-menu))
2268     ;; Remove completion hooks
2269     (remove-hook 'semantic-after-toplevel-cache-change-hook
2270                  'senator-completion-cache-flush-fcn t)
2271     (remove-hook 'semantic-after-partial-cache-change-hook
2272                  'senator-completion-cache-flush-fcn t)
2273     ;; Disable semantic isearch
2274     (setq senator-isearch-semantic-mode nil))
2275   senator-minor-mode)
2276
2277 ;;;###autoload
2278 (defun senator-minor-mode (&optional arg)
2279   "Toggle senator minor mode.
2280 With prefix argument ARG, turn on if positive, otherwise off.  The
2281 minor mode can be turned on only if semantic feature is available and
2282 the current buffer was set up for parsing.  Return non-nil if the
2283 minor mode is enabled.
2284
2285 \\{senator-mode-map}"
2286   (interactive
2287    (list (or current-prefix-arg
2288              (if senator-minor-mode 0 1))))
2289   (setq senator-minor-mode
2290         (if arg
2291             (>
2292              (prefix-numeric-value arg)
2293              0)
2294           (not senator-minor-mode)))
2295   (senator-minor-mode-setup)
2296   (run-hooks 'senator-minor-mode-hook)
2297   (if (interactive-p)
2298       (message "Senator minor mode %sabled"
2299                (if senator-minor-mode "en" "dis")))
2300   (senator-mode-line-update)
2301   senator-minor-mode)
2302
2303 (semantic-add-minor-mode 'senator-minor-mode
2304                          'senator-status
2305                          senator-mode-map)
2306
2307 ;; To show senator isearch mode in the mode line
2308 (semantic-add-minor-mode 'senator-isearch-semantic-mode
2309                          'senator-status
2310                          nil)
2311 ;;; Emacs 21 goodies
2312 (and (not (featurep 'xemacs))
2313      (> emacs-major-version 20)
2314      (progn
2315
2316        ;; Add Senator to the the minor mode menu in the mode line
2317        (define-key mode-line-mode-menu [senator-minor-mode]
2318          `(menu-item "Senator" senator-minor-mode
2319                      :button  (:toggle . senator-minor-mode)
2320                      :visible (and (featurep 'semantic)
2321                                    (semantic-active-p))))
2322
2323        ))
2324
2325 ;;;###autoload
2326 (defun global-senator-minor-mode (&optional arg)
2327   "Toggle global use of senator minor mode.
2328 If ARG is positive, enable, if it is negative, disable.
2329 If ARG is nil, then toggle."
2330   (interactive "P")
2331   (setq global-senator-minor-mode
2332         (semantic-toggle-minor-mode-globally
2333          'senator-minor-mode arg)))
2334
2335 ;;;;
2336 ;;;; Useful advices
2337 ;;;;
2338
2339 (defun senator-beginning-of-defun (&optional arg)
2340   "Move backward to the beginning of a defun.
2341 Use semantic tags to navigate.
2342 ARG is the number of tags to navigate (not yet implemented)."
2343   (let* ((senator-highlight-found nil)
2344          ;; Step at beginning of next tag with class specified in
2345          ;; `senator-step-at-tag-classes'.
2346          (senator-step-at-start-end-tag-classes t)
2347          (tag (senator-previous-tag)))
2348     (when tag
2349       (if (= (point) (semantic-tag-end tag))
2350           (goto-char (semantic-tag-start tag)))
2351       (beginning-of-line))
2352     (working-message nil)))
2353
2354 (defun senator-end-of-defun (&optional arg)
2355   "Move forward to next end of defun.
2356 Use semantic tags to navigate.
2357 ARG is the number of tags to navigate (not yet implemented)."
2358   (let* ((senator-highlight-found nil)
2359          ;; Step at end of next tag with class specified in
2360          ;; `senator-step-at-tag-classes'.
2361          (senator-step-at-start-end-tag-classes t)
2362          (tag (senator-next-tag)))
2363     (when tag
2364       (if (= (point) (semantic-tag-start tag))
2365           (goto-char (semantic-tag-end tag)))
2366       (skip-chars-forward " \t")
2367       (if (looking-at "\\s<\\|\n")
2368           (forward-line 1)))
2369     (working-message nil)))
2370
2371 (defun senator-narrow-to-defun ()
2372   "Make text outside current defun invisible.
2373 The defun visible is the one that contains point or follows point.
2374 Use semantic tags to navigate."
2375   (interactive)
2376   (save-excursion
2377     (widen)
2378     (senator-end-of-defun)
2379     (let ((end (point)))
2380       (senator-beginning-of-defun)
2381       (narrow-to-region (point) end))))
2382
2383 (defun senator-mark-defun ()
2384   "Put mark at end of this defun, point at beginning.
2385 The defun marked is the one that contains point or follows point.
2386 Use semantic tags to navigate."
2387   (interactive)
2388   (let ((origin (point))
2389         (end    (progn (senator-end-of-defun) (point)))
2390         (start  (progn (senator-beginning-of-defun) (point))))
2391     (goto-char origin)
2392     (push-mark (point))
2393     (goto-char end) ;; end-of-defun
2394     (push-mark (point) nil t)
2395     (goto-char start) ;; beginning-of-defun
2396     (re-search-backward "^\n" (- (point) 1) t)))
2397
2398 (defadvice beginning-of-defun (around senator activate)
2399   "Move backward to the beginning of a defun.
2400 If semantic tags are available, use them to navigate."
2401   (if (and senator-minor-mode (interactive-p))
2402       (senator-beginning-of-defun (ad-get-arg 0))
2403     ad-do-it))
2404
2405 (defadvice end-of-defun (around senator activate)
2406   "Move forward to next end of defun.
2407 If semantic tags are available, use them to navigate."
2408   (if (and senator-minor-mode (interactive-p))
2409       (senator-end-of-defun (ad-get-arg 0))
2410     ad-do-it))
2411
2412 (defadvice narrow-to-defun (around senator activate)
2413   "Make text outside current defun invisible.
2414 The defun visible is the one that contains point or follows point.
2415 If semantic tags are available, use them to navigate."
2416   (if (and senator-minor-mode (interactive-p))
2417       (senator-narrow-to-defun)
2418     ad-do-it))
2419
2420 (defadvice mark-defun (around senator activate)
2421   "Put mark at end of this defun, point at beginning.
2422 The defun marked is the one that contains point or follows point.
2423 If semantic tags are available, use them to navigate."
2424   (if (and senator-minor-mode (interactive-p))
2425       (senator-mark-defun)
2426     ad-do-it))
2427
2428 (defadvice c-mark-function (around senator activate)
2429   "Put mark at end of this defun, point at beginning.
2430 The defun marked is the one that contains point or follows point.
2431 If semantic tags are available, use them to navigate."
2432   (if (and senator-minor-mode (interactive-p))
2433       (senator-mark-defun)
2434     ad-do-it))
2435
2436 (defvar senator-add-log-tags '(function variable type)
2437   "When advising `add-log-current-defun', tag classes used.
2438 Semantic tags that are of these classes will be used to find the name
2439 used by add log.")
2440 (semantic-varalias-obsolete 'senator-add-log-tokens
2441                             'senator-add-log-tags)
2442
2443 (defadvice add-log-current-defun (around senator activate)
2444   "Return name of function definition point is in, or nil."
2445   (if senator-minor-mode
2446       (let ((tag (semantic-current-tag))
2447             (name nil))
2448         (if (and tag (memq (semantic-tag-class tag)
2449                            senator-add-log-tags))
2450             (progn
2451               (setq name
2452                     (semantic-format-tag-canonical-name
2453                      tag
2454                      (or (semantic-current-tag-parent)
2455                          (if (semantic-tag-function-parent tag)
2456                              (or (semantic-find-first-tag-by-name
2457                                   (semantic-tag-function-parent tag)
2458                                   (current-buffer))
2459                                  (semantic-tag-function-parent
2460                                   tag))))))
2461               (setq ad-return-value name))
2462           ad-do-it))
2463     ad-do-it))
2464
2465 ;;;;
2466 ;;;; Tag Cut & Paste
2467 ;;;;
2468
2469 ;; To copy a tag, means to put a tag definition into the tag
2470 ;; ring.  To kill a tag, put the tag into the tag ring AND put
2471 ;; the body of the tag into the kill-ring.
2472 ;;
2473 ;; To retrieve a killed tag's text, use C-y (yank), but to retrieve
2474 ;; the tag as a reference of some sort, use senator-yank-tag.
2475
2476 (defvar senator-tag-ring (make-ring 20)
2477   "Ring of tags for use with cut and paste.")
2478
2479 (make-obsolete-overload 'semantic-insert-foreign-token
2480                         'semantic-insert-foreign-tag)
2481
2482 (semantic-alias-obsolete 'senator-insert-foreign-token
2483                          'semantic-insert-foreign-tag)
2484
2485 (defun senator-copy-tag ()
2486   "Take the current tag, and place it in the tag ring."
2487   (interactive)
2488   (senator-parse)
2489   (let ((ft (semantic-obtain-foreign-tag)))
2490     (when ft
2491       (ring-insert senator-tag-ring ft)
2492       (message (semantic-format-tag-summarize ft)))
2493     ft))
2494 (semantic-alias-obsolete 'senator-copy-token 'senator-copy-tag)
2495
2496 (defun senator-kill-tag ()
2497   "Take the current tag, place it in the tag ring, and kill it.
2498 Killing the tag removes the text for that tag, and places it into
2499 the kill ring.  Retrieve that text with \\[yank]."
2500   (interactive)
2501   (let ((ct (senator-copy-tag))) ;; this handles the reparse for us.
2502     (kill-region (semantic-tag-start ct)
2503                  (semantic-tag-end ct))))
2504 (semantic-alias-obsolete 'senator-kill-token 'senator-kill-tag)
2505
2506 (defun senator-yank-tag ()
2507   "Yank a tag from the tag ring.
2508 The form the tag takes is differnet depending on where it is being
2509 yanked to."
2510   (interactive)
2511   (or (ring-empty-p senator-tag-ring)
2512       (let ((ft (ring-ref senator-tag-ring 0)))
2513           (semantic-foreign-tag-check ft)
2514           (semantic-insert-foreign-tag ft))))
2515 (semantic-alias-obsolete 'senator-yank-token 'senator-yank-tag)
2516
2517 (defun senator-copy-tag-to-register (register &optional kill-flag)
2518   "Copy the current tag into REGISTER.
2519 Optional argument KILL-FLAG will delete the text of the tag to the
2520 kill ring."
2521   (interactive "cTag to register: \nP")
2522   (senator-parse)
2523   (let ((ft (semantic-obtain-foreign-tag)))
2524     (when ft
2525       (set-register register ft)
2526       (if kill-flag
2527           (kill-region (semantic-tag-start ft)
2528                        (semantic-tag-end ft))))))
2529 (semantic-alias-obsolete 'senator-copy-token-to-register
2530                          'senator-copy-tag-to-register)
2531
2532 (defadvice insert-register (around senator activate)
2533   "Insert contents of register REGISTER as a tag.
2534 If senator is not active, use the original mechanism."
2535   (let ((val (get-register (ad-get-arg 0))))
2536     (if (and senator-minor-mode (interactive-p)
2537              (semantic-foreign-tag-p val))
2538         (semantic-insert-foreign-tag val)
2539       ad-do-it)))
2540
2541 (defadvice jump-to-register (around senator activate)
2542   "Insert contents of register REGISTER as a tag.
2543 If senator is not active, use the original mechanism."
2544   (let ((val (get-register (ad-get-arg 0))))
2545     (if (and senator-minor-mode (interactive-p)
2546              (semantic-foreign-tag-p val))
2547         (progn
2548           (switch-to-buffer (semantic-tag-buffer val))
2549           (goto-char (semantic-tag-start val)))
2550       ad-do-it)))
2551
2552 (defun senator-transpose-tags-up ()
2553   "Transpose the current tag, and the preceeding tag."
2554   (interactive)
2555   (senator-parse)
2556   (let* ((current-tag (semantic-current-tag))
2557          (prev-tag (save-excursion
2558                      (goto-char (semantic-tag-start current-tag))
2559                      (semantic-find-tag-by-overlay-prev)))
2560          (ct-parent (semantic-find-tag-parent-by-overlay current-tag))
2561          (pt-parent (semantic-find-tag-parent-by-overlay prev-tag)))
2562     (if (not (eq ct-parent pt-parent))
2563         (error "Cannot transpose tags"))
2564     (let ((txt (buffer-substring (semantic-tag-start current-tag)
2565                                  (semantic-tag-end current-tag)))
2566           (line (count-lines (semantic-tag-start current-tag)
2567                              (point)))
2568           (insert-point nil)
2569           )
2570       (delete-region (semantic-tag-start current-tag)
2571                      (semantic-tag-end current-tag))
2572       (delete-blank-lines)
2573       (goto-char (semantic-tag-start prev-tag))
2574       (setq insert-point (point))
2575       (insert txt)
2576       (if (/= (current-column) 0)
2577           (insert "\n"))
2578       (insert "\n")
2579       (goto-char insert-point)
2580       (forward-line line)
2581       )))
2582
2583 (defun senator-transpose-tags-down ()
2584   "Transpose the current tag, and the following tag."
2585   (interactive)
2586   (senator-parse)
2587   (let* ((current-tag (semantic-current-tag))
2588          (next-tag (save-excursion
2589                      (goto-char (semantic-tag-end current-tag))
2590                      (semantic-find-tag-by-overlay-next)))
2591          (end-pt (point-marker))
2592          )
2593     (goto-char (semantic-tag-start next-tag))
2594     (forward-char 1)
2595     (senator-transpose-tags-up)
2596     ;; I know that the above fcn deletes the next tag, so our pt marker
2597     ;; will be stable.
2598     (goto-char end-pt)))
2599
2600 ;;; HIPPIE EXPAND
2601 ;;
2602 ;; Senator has a nice completion mechanism.  Use it to add a new
2603 ;; hippie expand try method.
2604
2605 (eval-when-compile (require 'hippie-exp))
2606
2607 (defvar senator-try-function-already-enabled nil
2608   "Non-nil if `hippie-expand' semantic completion was already enabled.
2609 This flag remember `senator-hippie-expand-hook' to not remove
2610 `senator-try-expand-semantic' from `hippie-expand-try-functions-list'
2611 if it was previously put here by any sort of user's customization.")
2612
2613 (defun senator-hippie-expand-hook ()
2614   "Enable or disable use of semantic completion with `hippie-expand'.
2615 Depending on the value of the variable `senator-minor-mode'.
2616 Run as `senator-minor-mode-hook'."
2617   (make-local-variable 'hippie-expand-try-functions-list)
2618   (make-local-variable 'senator-try-function-already-enabled)
2619   (if senator-minor-mode
2620       (progn
2621         ;; Does nothing if semantic completion is already enabled (via
2622         ;; customization for example).
2623         (setq senator-try-function-already-enabled
2624               (memq 'senator-try-expand-semantic
2625                     hippie-expand-try-functions-list))
2626         (or senator-try-function-already-enabled
2627             (setq hippie-expand-try-functions-list
2628                   (cons 'senator-try-expand-semantic
2629                         hippie-expand-try-functions-list))))
2630     ;; Does nothing if semantic completion wasn't enabled here.
2631     (or senator-try-function-already-enabled
2632         (setq hippie-expand-try-functions-list
2633               (delq 'senator-try-expand-semantic
2634                     hippie-expand-try-functions-list)))))
2635
2636 (add-hook 'senator-minor-mode-hook 'senator-hippie-expand-hook)
2637
2638 ;;;###autoload
2639 (defun senator-try-expand-semantic (old)
2640   "Attempt inline completion at the cursor.
2641 Use Semantic, or the semantic database to look up possible
2642 completions.  The argument OLD has to be nil the first call of this
2643 function.  It returns t if a unique, possibly partial, completion is
2644 found, nil otherwise."
2645   (if (semantic-active-p)
2646       (let (symstart)
2647         ;; If the hippie says so, start over.
2648         (if (not old)
2649             (if (setq symstart (senator-current-symbol-start))
2650                 (progn
2651                   (he-init-string symstart (point))
2652                   (setq senator-last-completion-stats nil))))
2653         ;; do completion with senator's mechanism.
2654         (when (or old symstart)
2655           ;; This bit will turn off parsing on lexical errors.
2656           (semantic-lex-catch-errors senator-hippie-expand
2657             (semantic-fetch-tags))
2658           ;; Do the completion
2659           (let ((ret (senator-complete-symbol t)))
2660             (cond (ret
2661                    ;; Found a new completion, update the end marker.
2662                    (set-marker he-string-end (point))
2663                    ;; Update the tried table so other hippie expand
2664                    ;; try functions can see whether an expansion has
2665                    ;; already been tried.
2666                    (setq he-tried-table (cons ret he-tried-table)))
2667                   ;; No more completion
2668                   (old
2669                    ;; Reset the initial completed string for other
2670                    ;; hippie-expand try functions.
2671                    (he-reset-string)))
2672             ret)))))
2673
2674 ;;;;
2675 ;;;; Using semantic search in isearch mode
2676 ;;;;
2677
2678 ;;; Compatibility
2679 (cond
2680  ( ;; GNU Emacs 21.0 lazy highlighting
2681   (fboundp 'isearch-lazy-highlight-cleanup)
2682
2683   ;; Provide this function used by senator
2684   (defun senator-lazy-highlight-update ()
2685     "Force lazy highlight update."
2686     (funcall 'isearch-lazy-highlight-cleanup t)
2687     (set 'isearch-lazy-highlight-last-string nil)
2688     (setq isearch-adjusted t)
2689     (isearch-update))
2690
2691   ) ;; End of GNU Emacs 21 lazy highlighting
2692
2693  ( ;; XEmacs 21.4 lazy highlighting
2694   (fboundp 'isearch-highlight-all-cleanup)
2695
2696   ;; Provide this function used by senator
2697   (defun senator-lazy-highlight-update ()
2698     "Force lazy highlight update."
2699     (funcall 'isearch-highlight-all-cleanup)
2700     (set 'isearch-highlight-last-string nil)
2701     (setq isearch-adjusted t)
2702     (isearch-update))
2703
2704   ) ;; End of XEmacs 21.4 lazy highlighting
2705
2706  ( ;; GNU Emacs 20 lazy highlighting via ishl
2707   (fboundp 'ishl-cleanup)
2708
2709   ;; Provide this function used by senator
2710   (defun senator-lazy-highlight-update ()
2711     "Force lazy highlight update."
2712     (funcall 'ishl-cleanup t)
2713     (set 'ishl-last-string nil)
2714     (setq isearch-adjusted t)
2715     (isearch-update))
2716
2717   ) ;; End of GNU Emacs 20 lazy highlighting
2718
2719  (t ;; No lazy highlighting
2720
2721   ;; Ignore this function used by senator
2722   (defalias 'senator-lazy-highlight-update 'ignore)
2723
2724   ))
2725
2726 (defmacro senator-define-search-advice (searcher)
2727   "Advice the built-in SEARCHER function to do semantic search.
2728 That is to call the Senator counterpart searcher when variables
2729 `isearch-mode' and `senator-isearch-semantic-mode' are non-nil."
2730   (let ((senator-searcher (intern (format "senator-%s" searcher))))
2731     `(defadvice ,searcher (around senator activate)
2732        (if (and isearch-mode senator-isearch-semantic-mode
2733                 ;; The following condition ensure to do a senator
2734                 ;; semantic search on the `isearch-string' only!
2735                 (string-equal (ad-get-arg 0) isearch-string))
2736            (unwind-protect
2737                (progn
2738                  ;; Temporarily set `senator-isearch-semantic-mode' to
2739                  ;; nil to avoid an infinite recursive call of the
2740                  ;; senator semantic search function!
2741                  (setq senator-isearch-semantic-mode nil)
2742                  (setq ad-return-value
2743                        (funcall ',senator-searcher
2744                                 (ad-get-arg 0)     ; string
2745                                 (ad-get-arg 1)     ; bound
2746                                 (ad-get-arg 2)     ; no-error
2747                                 (ad-get-arg 3)     ; count
2748                                 )))
2749              (setq senator-isearch-semantic-mode t))
2750          ad-do-it))))
2751
2752 ;; Recent versions of GNU Emacs allow to override the isearch search
2753 ;; function for special needs, and avoid to advice the built-in search
2754 ;; function :-)
2755 (defun senator-isearch-search-fun ()
2756   "Return the function to use for the search.
2757 Use a senator search function when semantic isearch mode is enabled."
2758   (intern
2759    (concat (if senator-isearch-semantic-mode
2760                "senator-"
2761              "")
2762            (cond (isearch-word "word-")
2763                  (isearch-regexp "re-")
2764                  (t ""))
2765            "search-"
2766            (if isearch-forward
2767                "forward"
2768              "backward"))))
2769
2770 (unless (boundp 'isearch-search-fun-function)
2771   ;; Advice the built-in search functions to do semantic search when
2772   ;; `isearch-mode' and `senator-isearch-semantic-mode' are on.
2773   (senator-define-search-advice search-forward)
2774   (senator-define-search-advice re-search-forward)
2775   (senator-define-search-advice word-search-forward)
2776   (senator-define-search-advice search-backward)
2777   (senator-define-search-advice re-search-backward)
2778   (senator-define-search-advice word-search-backward)
2779   )
2780 ;;; End of compatibility stuff
2781
2782 (defun senator-isearch-toggle-semantic-mode ()
2783   "Toggle semantic searching on or off in isearch mode.
2784 \\<senator-mode-map>\\[senator-isearch-toggle-semantic-mode] toggle semantic searching."
2785   (interactive)
2786   (when senator-minor-mode
2787     (setq senator-isearch-semantic-mode
2788           (not senator-isearch-semantic-mode))
2789     (senator-mode-line-update)
2790     (if isearch-mode
2791         ;; force lazy highlight update
2792         (senator-lazy-highlight-update)
2793       (working-message "Isearch semantic mode %s"
2794                        (if senator-isearch-semantic-mode
2795                            "enabled"
2796                          "disabled")))))
2797
2798 ;; Needed by XEmacs isearch to not terminate isearch mode when
2799 ;; toggling semantic search.
2800 (put 'senator-isearch-toggle-semantic-mode 'isearch-command t)
2801
2802 ;; Keyboard shortcut to toggle semantic search in isearch mode.
2803 (define-key isearch-mode-map
2804   [(control ?,)]
2805   'senator-isearch-toggle-semantic-mode)
2806
2807 (defvar senator-old-isearch-search-fun nil
2808   "Hold previous value of `isearch-search-fun-function'.")
2809
2810 (defun senator-isearch-mode-hook ()
2811   "Isearch mode hook to setup semantic searching."
2812   (or senator-minor-mode
2813       (setq senator-isearch-semantic-mode nil))
2814   (when (boundp 'isearch-search-fun-function)
2815     (if (and isearch-mode senator-isearch-semantic-mode)
2816         (progn
2817           ;; When `senator-isearch-semantic-mode' is on save the
2818           ;; previous `isearch-search-fun-function' and install the
2819           ;; senator one.
2820           (when (and (local-variable-p 'isearch-search-fun-function)
2821                      (not (local-variable-p 'senator-old-isearch-search-fun)))
2822             (set (make-local-variable 'senator-old-isearch-search-fun)
2823                  isearch-search-fun-function))
2824           (set (make-local-variable 'isearch-search-fun-function)
2825                'senator-isearch-search-fun))
2826       ;; When `senator-isearch-semantic-mode' is off restore the
2827       ;; previous `isearch-search-fun-function'.
2828       (when (eq isearch-search-fun-function 'senator-isearch-search-fun)
2829         (if (local-variable-p 'senator-old-isearch-search-fun)
2830             (progn
2831               (set (make-local-variable 'isearch-search-fun-function)
2832                    senator-old-isearch-search-fun)
2833               (kill-local-variable 'senator-old-isearch-search-fun))
2834           (kill-local-variable 'isearch-search-fun-function)))))
2835   (senator-mode-line-update))
2836
2837
2838 (add-hook 'isearch-mode-hook     'senator-isearch-mode-hook)
2839 (add-hook 'isearch-mode-end-hook 'senator-isearch-mode-hook)
2840
2841 (provide 'senator)
2842
2843 ;;; senator.el ends here