code.delx.au - gnu-emacs/blob - lisp/progmodes/hideshow.el

   1 ;;; hideshow.el --- minor mode cmds to selectively display blocks of code
   2
   3 ;; Copyright (C) 1994, 1995, 1996, 1997 Free Software Foundation
   4
   5 ;; Author: Thien-Thi Nguyen <ttn@netcom.com>
   6 ;; Maintainer: Dan Nicolaescu <done@ece.arizona.edu>
   7 ;; Version: 4.0
   8 ;; Keywords: C C++ java lisp tools editing comments blocks hiding outlines
   9 ;; Time-of-Day-Author-Most-Likely-to-be-Recalcitrant: early morning
  10
  11 ;; This file is part of GNU Emacs.
  12
  13 ;; GNU Emacs is free software; you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation; either version 2, or (at your option)
  16 ;; any later version.
  17
  18 ;; GNU Emacs is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26 ;; Boston, MA 02111-1307, USA.
  27
  28 ;; LCD Archive Entry:
  29 ;; hideshow|Thien-Thi Nguyen|ttn@netcom.com|
  30 ;; minor mode commands to selectively display blocks of code|
  31 ;; 18-Oct-1994|3.4|~/modes/hideshow.el.Z|
  32
  33 ;;; Commentary:
  34
  35 ;; This file provides `hs-minor-mode'.  When active, six commands:
  36 ;;   hs-{hide,show}-{all,block}, hs-show-region and hs-minor-mode
  37 ;; are available.  They implement block hiding and showing.  Blocks are
  38 ;; defined in mode-specific way.  In c-mode or c++-mode, they are simply
  39 ;; curly braces, while in lisp-ish modes they are parens.  Multi-line
  40 ;; comments (c-mode) can also be hidden.  The command M-x hs-minor-mode
  41 ;; toggles the minor mode or sets it (similar to outline minor mode).
  42 ;; See documentation for each command for more info.
  43 ;;
  44 ;; The variable `hs-unbalance-handler-method' controls hideshow's behavior
  45 ;; in the case of "unbalanced parentheses".  See doc for more info.
  46
  47 ;; Suggested usage:
  48
  49 ;; (load-library "hideshow")
  50 ;; (add-hook 'X-mode-hook 'hs-minor-mode)   ; other modes similarly
  51 ;;
  52 ;; where X = {emacs-lisp,c,c++,perl,...}.  See the doc for the variable
  53 ;; `hs-special-modes-alist' if you'd like to use hideshow w/ other modes.
  54
  55 ;; Etc:
  56
  57 ;; Bug reports and fixes welcome (comments, too).  Thanks go to
  58 ;;      Dean Andrews <adahome@ix.netcom.com>
  59 ;;      Preston F. Crow <preston.f.crow@dartmouth.edu>
  60 ;;      Gael Marziou <gael@gnlab030.grenoble.hp.com>
  61 ;;      Keith Sheffield <sheff@edcsgw2.cr.usgs.gov>
  62 ;;      Jan Djarv <jan.djarv@sa.erisoft.se>
  63 ;;      Lars Lindberg <qhslali@aom.ericsson.se>
  64 ;;      Alf-Ivar Holm <alfh@ifi.uio.no>
  65 ;; for valuable feedback, code and bug reports.
  66
  67 ;;; Code:
  68
  69
  70 ;;;----------------------------------------------------------------------------
  71 ;;; user-configurable variables
  72
  73 (defgroup hideshow nil
  74   "Minor mode for hiding and showing program and comment blocks."
  75   :prefix "hs-"
  76   :group 'languages)
  77
  78 ;;;###autoload
  79 (defcustom hs-hide-comments-when-hiding-all t
  80   "Hide the comments too when you do an `hs-hide-all'."
  81   :type 'boolean
  82   :group 'hideshow)
  83
  84 ;;;###autoload
  85 (defcustom hs-show-hidden-short-form t
  86   "Leave only the first line visible in a hidden block.
  87 If t only the first line is visible when a block is in the hidden state,
  88 else both the first line and the last line are showed. Also if t and
  89 `hs-adjust-block-beginning' is set, it is used also.
  90
  91 An example of how this works: (in c-mode)
  92 original:
  93
  94 /* My function main
  95    some more stuff about main
  96 */
  97 int
  98 main(void)
  99 {
 100   int x=0;
 101   return 0;
 102 }
 103
 104
 105 hidden and hs-show-hidden-short-form is nil
 106 /* My function main...
 107 */
 108 int
 109 main(void)
 110 {...
 111 }
 112
 113 hidden and hs-show-hidden-short-form is t
 114 /* My function main...
 115 int
 116 main(void)...
 117
 118 For latest you have to be on the line containing the ellipsis when
 119 you do `hs-show-block'."
 120   :type 'boolean
 121   :group 'hideshow)
 122
 123 (defcustom hs-minor-mode-hook 'hs-hide-initial-comment-block
 124   "Hook called when `hs-minor-mode' is installed.
 125 A good value for this would be `hs-hide-initial-comment-block' to
 126 hide all the comments at the beginning of the file."
 127   :type 'hook
 128   :group 'hideshow)
 129
 130 (defcustom hs-isearch-open 'block
 131 "What kind of hidden blocks to open when doing `isearch'.
 132 It can have the following values:
 133     `block'     open only  blocks
 134     `comment'   open only comments
 135     t           open all of them
 136     nil         don't open any.
 137 This only has effect iff `search-invisible' is set to `open'."
 138   :type '(choice (const :tag "open only  blocks" block)
 139                  (const :tag "open only comments" comment)
 140                  (const :tag "open both blocks and comments" t)
 141                  (const :tag "don't open any of them" nil))
 142   :group 'hideshow)
 143
 144 (defvar hs-unbalance-handler-method 'top-level
 145   "*Symbol representing how \"unbalanced parentheses\" should be handled.
 146 This error is usually signaled by `hs-show-block'.  One of four values:
 147 `top-level', `next-line', `signal' or `ignore'.  Default is `top-level'.
 148
 149 - `top-level' -- Show top-level block containing the currently troublesome
 150                  block.
 151 - `next-line' -- Use the fact that, for an already hidden block, its end
 152                  will be on the next line.  Attempt to show this block.
 153 - `signal' -- Pass the error through, stopping execution.
 154 - `ignore' -- Ignore the error, continuing execution.
 155
 156 Values other than these four will be interpreted as `signal'.")
 157
 158 ;;;###autoload
 159 (defvar hs-special-modes-alist
 160   '((c-mode "{" "}" nil nil hs-c-like-adjust-block-beginning)
 161     (c++-mode "{" "}" "/[*/]" nil hs-c-like-adjust-block-beginning)
 162     (java-mode   "\\(\\(\\([ \t]*\\(\\(abstract\\|final\\|p\\(r\\(ivate\\|otected\\)\\|ublic\\)\\|static\\)[ \t\n]+\\)+\\(synchronized[ \t\n]*\\)?[a-zA-Z0-9_:]+[ \t\n]*\\(\\[[ \t\n]*\\][ \t\n]*\\)?\\([a-zA-Z0-9_:]+[ \t\n]*\\)([^)]*)\\([ \n\t]+throws[ \t\n][^{]+\\)?\\)\\|\\([ \t]*static[^{]*\\)\\)[ \t\n]*{\\)" "}" "/[*/]" java-hs-forward-sexp hs-c-like-adjust-block-beginning))
 163 ; I tested the java regexp using the following:
 164 ;(defvar hsj-public)
 165 ;(defvar hsj-syncronised)
 166 ;(defvar hsj-type)
 167 ;(defvar hsj-fname)
 168 ;(defvar hsj-par)
 169 ;(defvar hsj-throws)
 170 ;(defvar hsj-static)
 171
 172 ;(setq hsj-public
 173 ;      (concat "[ \t]*\\("
 174 ;             (regexp-opt '("public" "private" "protected" "abstract"
 175 ;                           "static" "final") 1)
 176 ;             "[ \t\n]+\\)+"))
 177
 178 ;(setq hsj-syncronised "\\(synchronized[ \t\n]*\\)?")
 179 ;(setq hsj-type "[a-zA-Z0-9_:]+[ \t\n]*\\(\\[[ \t\n]*\\][ \t\n]*\\)?")
 180 ;(setq hsj-fname "\\([a-zA-Z0-9_:]+[ \t\n]*\\)")
 181 ;(setq hsj-par "([^)]*)")
 182 ;(setq hsj-throws "\\([ \n\t]+throws[ \t\n][^{]+\\)?")
 183
 184 ;(setq hsj-static "[ \t]*static[^{]*")
 185
 186
 187 ;(setq hs-block-start-regexp (concat
 188 ;                            "\\("
 189 ;                                "\\("
 190 ;                                     "\\("
 191 ;                                        hsj-public
 192 ;                                        hsj-syncronised
 193 ;                                        hsj-type
 194 ;                                        hsj-fname
 195 ;                                        hsj-par
 196 ;                                        hsj-throws
 197 ;                                     "\\)"
 198 ;                                     "\\|"
 199 ;                                     "\\("
 200 ;                                        hsj-static
 201 ;                                     "\\)"
 202 ;                                "\\)"
 203 ;                                   "[ \t\n]*{"
 204 ;                             "\\)"
 205 ;                                   ))
 206
 207   "*Alist for initializing the hideshow variables for different modes.
 208 It has the form
 209 (MODE START-RE END-RE COMMENT-START-RE FORWARD-SEXP-FUNC ADJUST-BEG-FUNC).
 210 If present, hideshow will use these values for the start and end regexps,
 211 respectively.  Since Algol-ish languages do not have single-character
 212 block delimiters, the function `forward-sexp' which is used by hideshow
 213 doesn't work.  In this case, if a similar function is provided, you can
 214 register it and have hideshow use it instead of `forward-sexp'.  To add
 215 more values, use
 216
 217 \t(pushnew '(new-mode st-re end-re function-name)
 218 \t      hs-special-modes-alist :test 'equal)
 219
 220 For example:
 221
 222 \t(pushnew '(simula-mode \"begin\" \"end\" \"!\" simula-next-statement)
 223 \t      hs-special-modes-alist :test 'equal)
 224
 225 See the documentation for `hs-adjust-block-beginning' to see what
 226 is the use of ADJUST-BEG-FUNC.
 227
 228 If any of those is left nil, hideshow will try to guess some values, see
 229 `hs-grok-mode-type' for this.
 230
 231 Note that the regexps should not contain leading or trailing whitespace.")
 232
 233 (defvar hs-hide-hook nil
 234   "*Hooks called at the end of `hs-hide-all' and `hs-hide-block'.")
 235
 236 (defvar hs-show-hook nil
 237   "*Hooks called at the end of commands to show text.
 238 These commands include `hs-show-all', `hs-show-block' and `hs-show-region'.")
 239
 240 (defvar hs-minor-mode-prefix "\C-c"
 241   "*Prefix key to use for hideshow commands in hideshow minor mode.")
 242
 243 ;;;----------------------------------------------------------------------------
 244 ;;; internal variables
 245
 246 (defvar hs-minor-mode nil
 247   "Non-nil if using hideshow mode as a minor mode of some other mode.
 248 Use the command `hs-minor-mode' to toggle this variable.")
 249
 250 (defvar hs-minor-mode-map nil
 251   "Mode map for hideshow minor mode.")
 252
 253 ;(defvar hs-menu-bar nil
 254 ;  "Menu bar for hideshow minor mode (Xemacs only).")
 255
 256 (defvar hs-c-start-regexp nil
 257   "Regexp for beginning of comments.
 258 Differs from mode-specific comment regexps in that
 259 surrounding whitespace is stripped.")
 260
 261 (defvar hs-block-start-regexp nil
 262   "Regexp for beginning of block.")
 263
 264 (defvar hs-block-end-regexp nil
 265   "Regexp for end of block.")
 266
 267 (defvar hs-forward-sexp-func 'forward-sexp
 268   "Function used to do a forward-sexp.
 269 Should change for Algol-ish modes.  For single-character block
 270 delimiters -- ie, the syntax table regexp for the character is
 271 either `(' or `)' -- `hs-forward-sexp-func' would just be `forward-sexp'.
 272 For other modes such as simula, a more specialized function
 273 is necessary.")
 274
 275 (defvar hs-adjust-block-beginning nil
 276   "Function used to tweak the block beginning.
 277 It has effect only if `hs-show-hidden-short-form' is t. The block it
 278 is hidden from the point returned by this function, as opposed to
 279 hiding it from the point returned when searching
 280 `hs-block-start-regexp'.  In c-like modes, if we wish to also hide the
 281 curly braces (if you think they occupy too much space on the screen),
 282 this function should return the starting point (at the end of line) of
 283 the hidden region.
 284
 285 It is called with a single argument ARG which is the the position in
 286 buffer after the block beginning.
 287
 288 It should return the position from where we should start hiding.
 289
 290 It should not move the point.
 291
 292 See `hs-c-like-adjust-block-beginning' for an example of using this.")
 293
 294 ;(defvar hs-emacs-type 'fsf
 295 ;  "Used to support both Emacs and Xemacs.")
 296
 297 ;(eval-when-compile
 298 ;  (if (string-match "xemacs\\|lucid" emacs-version)
 299 ;      (progn
 300 ;       (defvar current-menubar nil "")
 301 ;       (defun set-buffer-menubar (arg1))
 302 ;       (defun add-menu (arg1 arg2 arg3)))))
 303
 304 ;;;----------------------------------------------------------------------------
 305 ;;; support funcs
 306
 307 ;; snarfed from outline.el;
 308 (defun hs-flag-region (from to flag)
 309   "Hides or shows lines from FROM to TO, according to FLAG.  If FLAG
 310 is nil then text is shown, while if FLAG is non-nil the text is
 311 hidden. Actualy flag is realy either `comment' or `block' depending on
 312 what kind of block it is suppose to hide."
 313     (save-excursion
 314       (goto-char from)
 315       (end-of-line)
 316       (hs-discard-overlays (point) to 'invisible 'hs)
 317       (if flag
 318           (let ((overlay (make-overlay (point) to)))
 319             ;; Make overlay hidden and intangible.
 320             (overlay-put overlay 'invisible 'hs)
 321             (overlay-put overlay 'hs t)
 322             (when (or (eq hs-isearch-open t) (eq hs-isearch-open flag))
 323                 (overlay-put overlay 'isearch-open-invisible
 324                              'hs-isearch-open-invisible))
 325             (overlay-put overlay 'intangible t)))))
 326
 327 ;; This is set as an `isearch-open-invisible' property to hidden
 328 ;; overlays.
 329 (defun hs-isearch-open-invisible (ov)
 330   (save-excursion
 331     (goto-char (overlay-start ov))
 332     (hs-show-block)))
 333
 334 ;; Remove from the region BEG ... END all overlays
 335 ;; with a PROP property equal to VALUE.
 336 ;; Overlays with a PROP property different from VALUE are not touched.
 337 (defun hs-discard-overlays (beg end prop value)
 338   (if (< end beg)
 339       (setq beg (prog1 end (setq end beg))))
 340   (save-excursion
 341     (goto-char beg)
 342     (let ((overlays (overlays-in beg end))
 343           o)
 344       (while overlays
 345         (setq o (car overlays))
 346         (if (eq (overlay-get o prop) value)
 347             (delete-overlay o))
 348           (setq overlays (cdr overlays))))))
 349
 350 (defun hs-hide-block-at-point (&optional end comment-reg)
 351   "Hide block iff on block beginning, optional END means reposition at end.
 352 COMMENT-REG is a list of the form (BEGIN . END) and specifies the limits
 353 of the comment, or nil if the block is not a comment."
 354   (if comment-reg
 355       (progn
 356         ;; goto the end of line at the end of the comment
 357         (goto-char (nth 1 comment-reg))
 358         (unless hs-show-hidden-short-form (forward-line -1))
 359         (end-of-line)
 360         (hs-flag-region (car comment-reg)  (point) 'comment)
 361         (goto-char (if end (nth 1 comment-reg) (car comment-reg))))
 362       (if (looking-at hs-block-start-regexp)
 363           (let* ((p ;; p is the point at the end of the block beginning
 364                   (if (and  hs-show-hidden-short-form
 365                             hs-adjust-block-beginning)
 366                       ;; we need to adjust the block beginning
 367                       (funcall hs-adjust-block-beginning (match-end 0))
 368                     (match-end 0)))
 369                  ;; q is the point at the end of the block
 370                  (q (progn (funcall hs-forward-sexp-func 1) (point))))
 371             ;; position the point so we can call `hs-flag-region'
 372             (unless hs-show-hidden-short-form (forward-line -1))
 373             (end-of-line)
 374             (if (and (< p (point)) (> (count-lines p q)
 375                                       (if hs-show-hidden-short-form 1 2)))
 376                 (hs-flag-region p (point) 'block))
 377             (goto-char (if end q p))))))
 378
 379 (defun hs-show-block-at-point (&optional end comment-reg)
 380   "Show block iff on block beginning.  Optional END means reposition at end.
 381 COMMENT-REG is a list of the forme (BEGIN . END) and specifies the limits
 382 of the comment. It should be nil when hiding a block."
 383   (if comment-reg
 384       (when (car comment-reg)
 385         (hs-flag-region (car comment-reg) (nth 1 comment-reg) nil)
 386         (goto-char (if end (nth 1 comment-reg) (car comment-reg))))
 387     (if (looking-at hs-block-start-regexp)
 388         (let* ((p (point))
 389                (q
 390                 (condition-case error   ; probably unbalanced paren
 391                     (progn
 392                       (funcall hs-forward-sexp-func 1)
 393                       (point))
 394                   (error
 395                    (cond
 396                     ((eq hs-unbalance-handler-method 'ignore)
 397                      ;; just ignore this block
 398                      (point))
 399                     ((eq hs-unbalance-handler-method 'top-level)
 400                      ;; try to get out of rat's nest and expose the whole func
 401                      (if (/= (current-column) 0) (beginning-of-defun))
 402                      (setq p (point))
 403                      (re-search-forward (concat "^" hs-block-start-regexp)
 404                                         (point-max) t 2)
 405                      (point))
 406                     ((eq hs-unbalance-handler-method 'next-line)
 407                      ;; assumption is that user knows what s/he's doing
 408                      (beginning-of-line) (setq p (point))
 409                      (end-of-line 2) (point))
 410                     (t
 411                      ;; pass error through -- this applies to `signal', too
 412                      (signal (car error) (cdr error))))))))
 413           (hs-flag-region p q nil)
 414           (goto-char (if end (1+ (point)) p))))))
 415
 416 (defun hs-safety-is-job-n ()
 417   "Warn `buffer-invisibility-spec' does not contain hs."
 418     (if (or buffer-invisibility-spec (assq 'hs buffer-invisibility-spec) )
 419         nil
 420       (message "Warning: `buffer-invisibility-spec' does not contain hs!!")
 421       (sit-for 2)))
 422
 423 (defun hs-hide-initial-comment-block ()
 424   (interactive)
 425   "Hides the first block of comments in a file.
 426 The best usage is in `hs-minor-mode-hook', it hides all the comments at the
 427 file beginning, so if you have huge RCS logs you won't see them!"
 428       (let ((p (point))
 429             c-reg)
 430         (goto-char (point-min))
 431         (skip-chars-forward " \t\n^L")
 432         (setq c-reg (hs-inside-comment-p))
 433         ;; see if we have enough comment lines to hide
 434         (if (and c-reg (> (count-lines (car c-reg) (nth 1 c-reg))
 435                           (if hs-show-hidden-short-form 1 2)))
 436             (hs-hide-block)
 437           (goto-char p))))
 438
 439 (defun hs-inside-comment-p ()
 440   "Returns non-nil if point is inside a comment, otherwise nil.
 441 Actually, returns a list containing the buffer position of the start
 442 and the end of the comment. A comment block can be hided only if on its
 443 starting line there are only white spaces preceding the actual comment
 444 beginning, if we are inside of a comment but this condition is not
 445 we return a list having a nil as its car and the end of comment position
 446 as cdr."
 447   (save-excursion
 448     ;; the idea is to look backwards for a comment start regexp, do a
 449     ;; forward comment, and see if we are inside, then extend extend
 450     ;; forward and backward as long as we have comments
 451     (let ((q (point)))
 452       (when (or (looking-at hs-c-start-regexp)
 453               (re-search-backward hs-c-start-regexp (point-min) t))
 454         (forward-comment (- (buffer-size)))
 455         (skip-chars-forward " \t\n\f")
 456         (let ((p (point))
 457               (not-hidable nil))
 458           (beginning-of-line)
 459           (unless (looking-at (concat "[ \t]*" hs-c-start-regexp))
 460             ;; we are in this situation: (example)
 461             ;; (defun bar ()
 462             ;;      (foo)
 463             ;;                ) ; comment
 464             ;;                 ^
 465             ;;   the point was here before doing (beginning-of-line)
 466             ;; here we should advance till the next comment which
 467             ;; eventually has only white spaces preceding it on the same
 468             ;; line
 469             (goto-char p)
 470             (forward-comment 1)
 471             (skip-chars-forward " \t\n\f")
 472             (setq p (point))
 473             (while (and (< (point) q)
 474                         (> (point) p)
 475                         (not (looking-at hs-c-start-regexp)))
 476               (setq p (point))  ;; use this to avoid an infinit cycle.
 477               (forward-comment 1)
 478               (skip-chars-forward " \t\n\f"))
 479             (if (or (not (looking-at hs-c-start-regexp))
 480                     (> (point) q))
 481                 ;; we cannot hide this comment block
 482                 (setq not-hidable t)))
 483           ;; goto the end of the comment
 484           (forward-comment (buffer-size))
 485           (skip-chars-backward " \t\n\f")
 486           (end-of-line)
 487           (if (>= (point) q)
 488               (list (if not-hidable nil p) (point))))))))
 489
 490 (defun hs-grok-mode-type ()
 491   "Setup variables for new buffers where applicable."
 492   (when (and (boundp 'comment-start)
 493              (boundp 'comment-end))
 494     (let ((lookup (assoc major-mode hs-special-modes-alist)))
 495       (setq hs-block-start-regexp (or (nth 1 lookup) "\\s\(")
 496             hs-block-end-regexp (or (nth 2 lookup) "\\s\)")
 497             hs-c-start-regexp (or (nth 3 lookup)
 498                                   (let ((c-start-regexp
 499                                          (regexp-quote comment-start)))
 500                                     (if (string-match " +$" c-start-regexp)
 501                                          (substring c-start-regexp 0 (1- (match-end 0)))
 502                                       c-start-regexp)))
 503             hs-forward-sexp-func (or (nth 4 lookup) 'forward-sexp)
 504             hs-adjust-block-beginning (nth 5 lookup)))))
 505
 506 (defun hs-find-block-beginning ()
 507   "Repositions point at block-start.
 508 Return point, or nil if top-level."
 509   (let (done
 510         (try-again t)
 511         (here (point))
 512         (both-regexps (concat "\\(" hs-block-start-regexp "\\)\\|\\("
 513                               hs-block-end-regexp "\\)"))
 514         (buf-size (buffer-size)))
 515     (beginning-of-line)
 516     ;; A block beginning can span on multiple lines, if the point
 517     ;; is on one of those lines, trying a regexp search from
 518     ;; that point would fail to find the block beginning, so we look
 519     ;; backwards for the block beginning, or a block end.
 520     (while try-again
 521       (setq try-again nil)
 522       (if (and (re-search-backward both-regexps (point-min) t)
 523                (match-beginning 1)) ; found a block beginning
 524           (if (save-match-data (hs-inside-comment-p))
 525               ;;but it was inside a comment, so we have to look for
 526               ;;it again
 527               (setq try-again t)
 528             ;; that's what we were looking for
 529             (setq done (match-beginning 0)))
 530         ;; we found a block end, or we reached the beginning of the
 531         ;; buffer look to see if we were on a block beginning when we
 532         ;; started
 533         (if (and
 534              (re-search-forward hs-block-start-regexp (point-max) t)
 535              (or
 536               (and (>= here (match-beginning 0)) (< here (match-end 0)))
 537               (and hs-show-hidden-short-form hs-adjust-block-beginning
 538                    (save-match-data
 539                      (= 1 (count-lines
 540                            (funcall hs-adjust-block-beginning
 541                                     (match-end 0)) here))))))
 542               (setq done (match-beginning 0)))))
 543     (goto-char here)
 544     (while (and (not done)
 545                 ;; This had problems because the regexp can match something
 546                 ;; inside of a comment!
 547                 ;; Since inside a comment we can have incomplete sexps
 548                 ;; this would have signaled an error.
 549                 (or (forward-comment (- buf-size)) t); `or' is a hack to
 550                                                          ; make it return t
 551                 (re-search-backward both-regexps (point-min) t))
 552       (if (match-beginning 1)           ; start of start-regexp
 553           (setq done (match-beginning 0))
 554         (goto-char (match-end 0))       ; end of end-regexp
 555         (funcall hs-forward-sexp-func -1)))
 556     (goto-char (or done here))
 557     done))
 558
 559 (defmacro hs-life-goes-on (&rest body)
 560   "Executes optional BODY iff variable `hs-minor-mode' is non-nil."
 561   (` (let ((inhibit-point-motion-hooks t))
 562        (when hs-minor-mode
 563            (,@ body)))))
 564
 565 (put 'hs-life-goes-on 'edebug-form-spec '(&rest form))
 566
 567 (defun hs-already-hidden-p ()
 568   "Return non-nil if point is in an already-hidden block, otherwise nil."
 569   (save-excursion
 570     (let ((c-reg (hs-inside-comment-p)))
 571       (if (and c-reg (nth 0 c-reg))
 572           ;; point is inside a comment, and that comment is hidable
 573           (goto-char (nth 0 c-reg))
 574         (if (and (not c-reg) (hs-find-block-beginning)
 575                  (looking-at hs-block-start-regexp))
 576             ;; point is inside a block
 577             (goto-char (match-end 0)))))
 578     (end-of-line)
 579     (let ((overlays (overlays-at (point)))
 580           (found nil))
 581       (while (and (not found) (overlayp (car overlays)))
 582            (setq found (overlay-get (car overlays) 'hs)
 583                  overlays (cdr overlays)))
 584       found)))
 585
 586 (defun java-hs-forward-sexp (arg)
 587   "Function used by `hs-minor-mode' for `forward-sexp' in Java mode."
 588   (if (< arg 0)
 589       (backward-sexp 1)
 590     (if (looking-at hs-block-start-regexp)
 591         (progn
 592           (goto-char (match-end 0))
 593           (forward-char -1)
 594           (forward-sexp 1))
 595       (forward-sexp 1))))
 596
 597 (defun hs-c-like-adjust-block-beginning (arg)
 598   "Function to be assigned to `hs-adjust-block-beginning' for C like modes.
 599 Arg is a position in buffer just after {. This goes back to the end of
 600 the function header. The purpose is to save some space on the screen
 601 when displaying hidden blocks."
 602   (save-excursion
 603     (goto-char arg)
 604     (forward-char -1)
 605     (forward-comment (- (buffer-size)))
 606     (point)))
 607
 608 ;;;----------------------------------------------------------------------------
 609 ;;; commands
 610
 611 ;;;###autoload
 612 (defun hs-hide-all ()
 613   "Hides all top-level blocks, displaying only first and last lines.
 614 It moves point to the beginning of the line, and it runs the normal hook
 615 `hs-hide-hook'.  See documentation for `run-hooks'.
 616 If `hs-hide-comments-when-hiding-all' is t also hides the comments."
 617   (interactive)
 618   (hs-life-goes-on
 619    (message "Hiding all blocks ...")
 620    (save-excursion
 621      (hs-flag-region (point-min) (point-max) nil) ; eliminate weirdness
 622      (goto-char (point-min))
 623      (if hs-hide-comments-when-hiding-all
 624          (let (c-reg
 625                (count 0)
 626                (block-and-comment-re  ;; this should match
 627                 (concat "\\(^"        ;; the block beginning and comment start
 628                         hs-block-start-regexp
 629                         "\\)\\|\\(" hs-c-start-regexp "\\)")))
 630            (while (re-search-forward block-and-comment-re (point-max) t)
 631              (if (match-beginning 1) ;; we have found a block beginning
 632                  (progn
 633                    (goto-char (match-beginning 1))
 634                    (hs-hide-block-at-point t)
 635                    (message "Hiding ... %d" (setq count (1+ count))))
 636                ;;found a comment
 637                (setq c-reg (hs-inside-comment-p))
 638                (if (and c-reg (car c-reg))
 639                    (if (> (count-lines (car c-reg) (nth 1 c-reg))
 640                           (if hs-show-hidden-short-form 1 2))
 641                        (progn
 642                          (hs-hide-block-at-point t c-reg)
 643                          (message "Hiding ... %d" (setq count (1+ count))))
 644                      (goto-char (nth 1 c-reg)))))))
 645        (let ((count 0)
 646              (top-level-re (concat "^" hs-block-start-regexp))
 647              (buf-size (buffer-size)))
 648          (while
 649              (progn
 650                (forward-comment buf-size)
 651                (re-search-forward top-level-re (point-max) t))
 652            (goto-char (match-beginning 0))
 653            (hs-hide-block-at-point t)
 654            (message "Hiding ... %d" (setq count (1+ count))))))
 655    (hs-safety-is-job-n))
 656    (beginning-of-line)
 657    (message "Hiding all blocks ... done")
 658    (run-hooks 'hs-hide-hook)))
 659
 660 (defun hs-show-all ()
 661   "Shows all top-level blocks.
 662 This does not change point; it runs the normal hook `hs-show-hook'.
 663 See documentation for `run-hooks'."
 664   (interactive)
 665   (hs-life-goes-on
 666    (message "Showing all blocks ...")
 667    (hs-flag-region (point-min) (point-max) nil)
 668    (message "Showing all blocks ... done")
 669    (run-hooks 'hs-show-hook)))
 670
 671 (defun hs-hide-block (&optional end)
 672   "Selects a block and hides it.
 673 With prefix arg, reposition at end. Block is defined as a sexp for
 674 lispish modes, mode-specific otherwise. Comments are blocks, too.
 675 Upon completion, point is at repositioned and the normal hook
 676 `hs-hide-hook' is run.  See documentation for `run-hooks'."
 677   (interactive "P")
 678   (hs-life-goes-on
 679    (let ((c-reg (hs-inside-comment-p)))
 680      (cond
 681       ((and c-reg (or (null (nth 0 c-reg))
 682                       (<= (count-lines (car c-reg) (nth 1 c-reg))
 683                           (if hs-show-hidden-short-form 1 2))))
 684            (message "Not enough comment lines to hide!"))
 685       ((or c-reg (looking-at hs-block-start-regexp)
 686                (hs-find-block-beginning))
 687        (hs-hide-block-at-point end c-reg)
 688        (hs-safety-is-job-n)
 689        (run-hooks 'hs-hide-hook))))))
 690
 691 (defun hs-show-block (&optional end)
 692   "Selects a block and shows it.
 693 With prefix arg, reposition at end. Upon completion, point is
 694 repositioned and the normal hook `hs-show-hook' is run.
 695 See documentation for `hs-hide-block' and `run-hooks'."
 696   (interactive "P")
 697   (hs-life-goes-on
 698    (let ((c-reg (hs-inside-comment-p)))
 699      (if (or c-reg
 700              (looking-at hs-block-start-regexp)
 701              (hs-find-block-beginning))
 702            (progn
 703              (hs-show-block-at-point end c-reg)
 704              (hs-safety-is-job-n)
 705              (run-hooks 'hs-show-hook))))))
 706
 707 (defun hs-show-region (beg end)
 708   "Shows all lines from BEG to END, without doing any block analysis.
 709 Note:`hs-show-region' is intended for use when `hs-show-block' signals
 710 `unbalanced parentheses' and so is an emergency measure only.  You may
 711 become very confused if you use this command indiscriminately."
 712   (interactive "r")
 713   (hs-life-goes-on
 714    (hs-flag-region beg end nil)
 715    (hs-safety-is-job-n)
 716    (run-hooks 'hs-show-hook)))
 717
 718 ;;;###autoload
 719 (defun hs-mouse-toggle-hiding (e)
 720   "Toggles hiding/showing of a block.
 721 Should be bound to a mouse key."
 722   (interactive "@e")
 723   (mouse-set-point e)
 724   (if (hs-already-hidden-p)
 725       (hs-show-block)
 726     (hs-hide-block)))
 727
 728 ;;;###autoload
 729 (defun hs-minor-mode (&optional arg)
 730   "Toggle hideshow minor mode.
 731 With ARG, turn hideshow minor mode on if ARG is positive, off otherwise.
 732 When hideshow minor mode is on, the menu bar is augmented with hideshow
 733 commands and the hideshow commands are enabled.
 734 The value '(hs . t) is added to `buffer-invisibility-spec'.
 735 Last, the normal hook `hs-minor-mode-hook' is run; see the doc
 736 for `run-hooks'.
 737
 738 The main commands are: `hs-hide-all', `hs-show-all', `hs-hide-block'
 739 and `hs-show-block'.
 740 Also see the documentation for the variable `hs-show-hidden-short-form'.
 741
 742 Turning hideshow minor mode off reverts the menu bar and the
 743 variables to default values and disables the hideshow commands.
 744
 745 Key bindings:
 746 \\{hs-minor-mode-map}"
 747
 748   (interactive "P")
 749   (setq hs-minor-mode
 750         (if (null arg)
 751             (not hs-minor-mode)
 752           (> (prefix-numeric-value arg) 0)))
 753   (if hs-minor-mode
 754       (progn
 755 ;       (if (eq hs-emacs-type 'lucid)
 756 ;           (progn
 757 ;             (set-buffer-menubar (copy-sequence current-menubar))
 758 ;             (add-menu nil (car hs-menu-bar) (cdr hs-menu-bar))))
 759         (make-variable-buffer-local 'line-move-ignore-invisible)
 760         (setq  line-move-ignore-invisible t)
 761         (add-to-invisibility-spec '(hs . t)) ;;hs invisible
 762         (hs-grok-mode-type)
 763         (run-hooks 'hs-minor-mode-hook))
 764 ;    (if (eq hs-emacs-type 'lucid)
 765 ;       (set-buffer-menubar (delete hs-menu-bar current-menubar)))
 766     (remove-from-invisibility-spec '(hs . t))))
 767
 768
 769 ;;;----------------------------------------------------------------------------
 770 ;;; load-time setup routines
 771
 772 ;; which emacs being used?
 773 ;(setq hs-emacs-type
 774 ;      (if (string-match "xemacs\\|lucid" emacs-version)
 775 ;         'lucid
 776 ;       'fsf))
 777
 778 ;; keymaps and menus
 779 (if hs-minor-mode-map
 780     nil
 781   (setq hs-minor-mode-map (make-sparse-keymap))
 782   ;; I beleive there is nothing bound on this keys
 783   (define-key hs-minor-mode-map "\C-ch" 'hs-hide-block)
 784   (define-key hs-minor-mode-map "\C-cs" 'hs-show-block)
 785   (define-key hs-minor-mode-map "\C-cH" 'hs-hide-all)
 786   (define-key hs-minor-mode-map "\C-cS" 'hs-show-all)
 787   (define-key hs-minor-mode-map "\C-cR" 'hs-show-region)
 788
 789   (define-key hs-minor-mode-map [S-mouse-2] 'hs-mouse-toggle-hiding)
 790
 791   ;; should we use easymenu here?
 792   (define-key hs-minor-mode-map [menu-bar Hide/Show]
 793     (cons "Hide/Show" (make-sparse-keymap "Hide/Show")))
 794   (define-key hs-minor-mode-map [menu-bar Hide/Show  hs-show-region]
 795     '("Show Region" . hs-show-region))
 796   (define-key hs-minor-mode-map [menu-bar Hide/Show hs-show-all]
 797     '("Show All" . hs-show-all))
 798   (define-key hs-minor-mode-map [menu-bar Hide/Show hs-hide-all]
 799     '("Hide All" . hs-hide-all))
 800   (define-key hs-minor-mode-map [menu-bar Hide/Show hs-show-block]
 801     '("Show Block" . hs-show-block))
 802   (define-key hs-minor-mode-map [menu-bar Hide/Show hs-hide-block]
 803     '("Hide Block" . hs-hide-block)))
 804
 805 ;; some housekeeping
 806 (or (assq 'hs-minor-mode minor-mode-map-alist)
 807     (setq minor-mode-map-alist
 808           (cons (cons 'hs-minor-mode hs-minor-mode-map)
 809                 minor-mode-map-alist)))
 810 (or (assq 'hs-minor-mode minor-mode-alist)
 811     (setq minor-mode-alist (append minor-mode-alist
 812                                    (list '(hs-minor-mode " hs")))))
 813
 814 ;; make some variables buffer-local
 815 (make-variable-buffer-local 'hs-minor-mode)
 816 (make-variable-buffer-local 'hs-c-start-regexp)
 817 (make-variable-buffer-local 'hs-block-start-regexp)
 818 (make-variable-buffer-local 'hs-block-end-regexp)
 819 (make-variable-buffer-local 'hs-forward-sexp-func)
 820 (make-variable-buffer-local 'hs-adjust-block-beginning)
 821 (put 'hs-minor-mode 'permanent-local t)
 822 (put 'hs-c-start-regexp 'permanent-local t)
 823 (put 'hs-block-start-regexp 'permanent-local t)
 824 (put 'hs-block-end-regexp 'permanent-local t)
 825 (put 'hs-forward-sexp-func 'permanent-local t)
 826 (put 'hs-adjust-block-beginning 'permanent-local t)
 827
 828
 829 ;;;----------------------------------------------------------------------------
 830 ;;; that's it
 831
 832 (provide 'hideshow)
 833
 834 ;;; hideshow.el ends here