cgit.sxemacs.org Git - packages/blob - xemacs-packages/hyperbole/hibtypes.el

   1 ;;; hibtypes.el --- Hyperbole System Implicit Button Types.
   2
   3 ;; Copyright (C) 2004, 2008 Free Software Foundation, Inc.
   4 ;; Developed with support from Motorola Inc.
   5
   6 ;; Author: Bob Weiner, Brown U.
   7 ;; Maintainer: Mats Lidell <matsl@contactor.se>
   8 ;; Keywords: extensions, hypermedia
   9
  10 ;; This file is part of GNU Hyperbole.
  11
  12 ;; GNU Hyperbole is free software; you can redistribute it and/or
  13 ;; modify it under the terms of the GNU General Public License as
  14 ;; published by the Free Software Foundation; either version 3, or (at
  15 ;; your option) any later version.
  16
  17 ;; GNU Hyperbole is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20 ;; General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  25 ;; Boston, MA 02110-1301, USA.
  26
  27 ;;; Commentary:
  28
  29 ;;; Code:
  30
  31 ;;;
  32 ;;; Other required Elisp libraries
  33 ;;;
  34
  35 (require 'hactypes)
  36
  37 ;;;
  38 ;;; Public implicit button types
  39 ;;;
  40
  41 (run-hooks 'hibtypes:begin-load-hook)
  42
  43 ;;;
  44 ;;; Follows URLs by invoking a browser.
  45 ;;;
  46
  47 (require 'hsys-w3)
  48
  49 ;;;
  50 ;;; Handles internal references within an annotated bibliography, delimiters=[]
  51 ;;;
  52
  53 (defib annot-bib ()
  54   "Displays annotated bibliography entries referenced internally.
  55 References must be delimited by square brackets, must begin with a word
  56 constituent character, and must not be in buffers whose names begin with a
  57 ' ' or '*' character or which do not have an attached file."
  58   (and (not (bolp))
  59        buffer-file-name
  60        (let ((chr (aref (buffer-name) 0)))
  61          (not (or (= chr ? ) (= chr ?*))))
  62        (let* ((ref-and-pos (hbut:label-p t "[" "]" t))
  63               (ref (car ref-and-pos)))
  64          (and ref (= ?w (char-syntax (aref ref 0)))
  65               (progn (ibut:label-set ref-and-pos)
  66                      (hact 'annot-bib ref))))))
  67
  68 ;;;
  69 ;;; Summarizes an Internet rfc for random access browsing by section.
  70 ;;;
  71
  72 (defib rfc-toc ()
  73   "Summarizes contents of an Internet rfc from anywhere within rfc buffer.
  74 Each line in summary may be selected to jump to section."
  75   (let ((case-fold-search t)
  76         (toc)
  77         (opoint (point)))
  78     (if (and (string-match "rfc" (buffer-name))
  79              (goto-char (point-min))
  80              (progn (setq toc (search-forward "Table of Contents" nil t))
  81                     (re-search-forward "^[ \t]*1.0?[ \t]+[^ \t\n]" nil t
  82                                        (and toc 2))))
  83         (progn (beginning-of-line)
  84                (ibut:label-set (buffer-name))
  85                (hact 'rfc-toc (buffer-name) opoint))
  86       (goto-char opoint)
  87       nil)))
  88
  89 ;;;
  90 ;;; Jumps to C/C++ source line associated with Cscope C analyzer output line.
  91 ;;;
  92
  93 (defib cscope ()
  94   "Jumps to C/C++ source line associated with Cscope C analyzer output line.
  95 Requires pre-loading of the cscope.el Lisp library available from the Emacs
  96 Lisp archives and the commercial cscope program available from UNIX System
  97 Laboratories.  Otherwise, does nothing."
  98   (and (boundp 'cscope:bname-prefix)  ;; (featurep 'cscope)
  99        (stringp cscope:bname-prefix)
 100        (string-match (regexp-quote cscope:bname-prefix)
 101                      (buffer-name))
 102        (= (match-beginning 0) 0)
 103        (save-excursion
 104          (beginning-of-line)
 105          (looking-at cscope-output-line-regexp))
 106        (let (start end)
 107          (skip-chars-backward "^\n\^M")
 108          (setq start (point))
 109          (skip-chars-forward "^\n\^M")
 110          (setq end (point))
 111          (ibut:label-set (buffer-substring start end)
 112                          start end)
 113          (hact 'cscope-interpret-output-line))))
 114
 115 ;;;
 116 ;;; Makes README table of contents entries jump to associated sections.
 117 ;;;
 118
 119 (defib text-toc ()
 120   "Jumps to the text file section referenced by a table of contents entry at point.
 121 File name must contain README and there must be a `Table of Contents' or
 122 `Contents' label on a line by itself (it may begin with an asterisk),
 123 preceding the table of contents.  Each toc entry must begin with some
 124 whitespace followed by one or more asterisk characters.  Each file section
 125 name line must start with one or more asterisk characters at the very
 126 beginning of the line."
 127   (let (section)
 128     (if (and (string-match "README" (buffer-name))
 129              (save-excursion
 130                (beginning-of-line)
 131                (if (looking-at
 132                     "[ \t]+\\*+[ \t]+\\(.*[^ \t]\\)[ \t]*$")
 133                    (setq section (buffer-substring (match-beginning 1)
 134                                                    (match-end 1)))))
 135              (progn (ibut:label-set section (match-beginning 1) (match-end 1))
 136                     t)
 137              (save-excursion (re-search-backward
 138                               "^\\**[ \t]*\\(\\|Table of \\)Contents[ \t]*$"
 139                               nil t)))
 140         (hact 'text-toc section))))
 141
 142 ;;;
 143 ;;; Makes directory summaries into file list menus.
 144 ;;;
 145
 146 (defib dir-summary ()
 147   "Detects filename buttons in files named \"MANIFEST\" or \"DIR\".
 148 Displays selected files.  Each file name must be at the beginning of the line
 149 or may be preceded by some semicolons and must be followed by one or more
 150 spaces and then another non-space, non-parenthesis, non-brace character."
 151   (if buffer-file-name
 152       (let ((file (file-name-nondirectory buffer-file-name))
 153             entry start end)
 154         (if (or (string= file "DIR") (string= file "MANIFEST"))
 155             (save-excursion
 156               (beginning-of-line)
 157               (if (looking-at
 158                    "\\(;+[ \t]*\\)?\\([^(){}* \t\n]+\\)[ \t]+[^(){}* \t\n]")
 159                   (progn
 160                     (setq entry (buffer-substring
 161                                  (match-beginning 2) (match-end 2))
 162                           start (match-beginning 2)
 163                           end (match-end 2))
 164                     (if (file-exists-p entry)
 165                         (progn (ibut:label-set entry start end)
 166                                (hact 'link-to-file entry))))))))))
 167
 168 ;;;
 169 ;;; Executes or documents command bindings of brace delimited key sequences.
 170 ;;;
 171
 172 (require 'hib-kbd)
 173
 174 ;;;
 175 ;;; Makes Internet RFC references retrieve the RFC.
 176 ;;;
 177
 178 (defib rfc ()
 179   "Retrieves and displays an Internet rfc referenced at point.
 180 Requires ange-ftp or efs when needed for remote retrievals.  The following
 181 formats are recognized: RFC822, rfc-822, and RFC 822.  The 'hpath:rfc'
 182 variable specifies the location from which to retrieve RFCs."
 183   (let ((case-fold-search t)
 184         (rfc-num nil))
 185     (and (not (memq major-mode '(dired-mode monkey-mode)))
 186          (boundp 'hpath:rfc)
 187          (stringp hpath:rfc)
 188          (save-excursion
 189            (skip-chars-backward "-rRfFcC0-9")
 190            (if (looking-at "rfc[- ]?\\([0-9]+\\)")
 191                (progn
 192                  (setq rfc-num
 193                        (buffer-substring
 194                         (match-beginning 1) (match-end 1)))
 195                  (ibut:label-set
 196                   (buffer-substring (match-beginning 0) (match-end 0)))
 197                  t)))
 198          ;; Ensure ange-ftp is available for retrieving a remote
 199          ;; RFC, if need be.
 200          (if (string-match "^/.+:" hpath:rfc)
 201              ;; This is a remote path.
 202              (hpath:ange-ftp-available-p)
 203            ;; local path
 204            t)
 205          (hact 'link-to-rfc rfc-num))))
 206
 207 ;;;
 208 ;;; Makes Hyperbole mail addresses output Hyperbole envir info.
 209 ;;;
 210
 211 (defib hyp-address ()
 212   "Turns a Hyperbole e-mail list address into an implicit button which inserts Hyperbole environment information.
 213 Useful when sending mail to a Hyperbole mail list.
 214 See also the documentation for `actypes::hyp-config'."
 215   (if (memq major-mode (list hmail:composer hnews:composer))
 216       (let ((addr (find-tag-default)))
 217         (cond ((set:member addr (list "hyperbole" "hyperbole-users@gnu.org"))
 218                (hact 'hyp-config))
 219               ))))
 220
 221 ;;;
 222 ;;; Makes source entries in Hyperbole reports selectable.
 223 ;;;
 224
 225 (defib hyp-source ()
 226   "Turns source location entries in Hyperbole reports into buttons that jump to the associated location."
 227   (save-excursion
 228     (beginning-of-line)
 229     (if (looking-at hbut:source-prefix)
 230         (let ((src (hbut:source)))
 231           (if src
 232               (progn (if (not (stringp src)) (setq src (prin1-to-string src)))
 233                      (ibut:label-set src (point) (progn (end-of-line) (point)))
 234                      (hact 'hyp-source src)))))))
 235
 236 ;;;
 237 ;;; Shows man page associated with a man apropos entry.
 238 ;;;
 239
 240 (defib man-apropos ()
 241   "Makes man apropos entries display associated man pages when selected."
 242   (save-excursion
 243     (beginning-of-line)
 244     (let ((nm "[^ \t\n!@,][^ \t\n,]*")
 245           topic)
 246       (and (looking-at
 247             (concat
 248              "^\\(\\*[ \t]+[!@]\\)?\\(" nm "[ \t]*,[ \t]*\\)*\\(" nm "\\)[ \t]*"
 249              "\\(([-0-9a-zA-z]+)\\)\\(::\\)?[ \t]+-[ \t]+[^ \t\n]"))
 250            (setq topic
 251                  (concat (buffer-substring (match-beginning 3) (match-end 3))
 252                          (buffer-substring (match-beginning 4) (match-end 4))))
 253            (ibut:label-set topic (match-beginning 3) (match-end 4))
 254            (hact 'man-show topic)))))
 255
 256 ;;;
 257 ;;; Follows links to Hyperbole outliner cells.
 258 ;;;
 259
 260 (if hyperb:kotl-p (require 'klink))
 261
 262 ;;;
 263 ;;; Displays files and directories when double quoted pathname is activated.
 264 ;;;
 265
 266 (defib pathname ()
 267   "Makes a delimited, valid pathname display the path entry.
 268 Also works for delimited and non-delimited ange-ftp and efs pathnames.
 269 See `hpath:at-p' function documentation for possible delimiters.
 270 See `hpath:suffixes' variable documentation for suffixes that are added to or
 271 removed from pathname when searching for a valid match.
 272 See `hpath:find' function documentation and `hpath:display-alist' and
 273 `hpath:find-alist' variable documentation for special file display options."
 274      (let ((path (hpath:at-p)))
 275        (if path
 276            (progn (ibut:label-set path)
 277                   (hact 'link-to-file path)))))
 278
 279 ;;;
 280 ;;; Jumps to source line associated with debugger stack frame or breakpoint
 281 ;;; lines.  Supports gdb, dbx, and xdb.
 282 ;;;
 283
 284 (defib debugger-source ()
 285   "Jumps to source line associated with debugger stack frame or breakpoint lines.
 286 This works with gdb, dbx, and xdb.  Such lines are recognized in any buffer."
 287   (save-excursion
 288     (beginning-of-line)
 289     (cond  ((looking-at ".+ \\(at\\|file\\) \\([^ :]+\\):\\([0-9]+\\)\\.?$")
 290            ;; GDB
 291            (let* ((file (buffer-substring (match-beginning 2)
 292                                           (match-end 2)))
 293                   (line-num (buffer-substring (match-beginning 3)
 294                                               (match-end 3)))
 295                   (but-label (concat file ":" line-num)))
 296              (setq line-num (string-to-number line-num))
 297              (ibut:label-set but-label)
 298              (hact 'link-to-file-line file line-num)))
 299            ((looking-at ".+ (file=[^\"\n]+\"\\([^\"\n]+\\)\", line=\\([0-9]+\\),")
 300            ;; XEmacs assertion failure
 301            (let* ((file (buffer-substring (match-beginning 1)
 302                                           (match-end 1)))
 303                   (line-num (buffer-substring (match-beginning 2)
 304                                               (match-end 2)))
 305                   (but-label (concat file ":" line-num)))
 306              (setq line-num (string-to-number line-num))
 307              (ibut:label-set but-label)
 308              (hact 'link-to-file-line file line-num)))
 309           ((looking-at ".+ line \\([0-9]+\\) in \"\\([^\"]+\\)\"$")
 310            ;; New DBX
 311            (let* ((file (buffer-substring (match-beginning 2)
 312                                           (match-end 2)))
 313                   (line-num (buffer-substring (match-beginning 1)
 314                                               (match-end 1)))
 315                   (but-label (concat file ":" line-num)))
 316              (setq line-num (string-to-number line-num))
 317              (ibut:label-set but-label)
 318              (hact 'link-to-file-line file line-num)))
 319           ((or (looking-at ".+ \\[\"\\([^\"]+\\)\":\\([0-9]+\\),") ;; Old DBX
 320                (looking-at ".+ \\[\\([^: ]+\\): \\([0-9]+\\)\\]")) ;; HP-UX xdb
 321            (let* ((file (buffer-substring (match-beginning 1)
 322                                           (match-end 1)))
 323                   (line-num (buffer-substring (match-beginning 2)
 324                                               (match-end 2)))
 325                   (but-label (concat file ":" line-num)))
 326              (setq line-num (string-to-number line-num))
 327              (ibut:label-set but-label)
 328              (hact 'link-to-file-line file line-num))))))
 329
 330 ;;;
 331 ;;; Jumps to source line associated with grep or compilation error messages.
 332 ;;; With credit to Michael Lipp and Mike Williams for the idea.
 333 ;;;
 334
 335 (defib grep-msg ()
 336   "Jumps to line associated with grep or compilation error msgs.
 337 Messages are recognized in any buffer."
 338   (progn
 339     (if (equal (buffer-name) "*compilation*")
 340         (progn
 341           (require 'compile)
 342           ;; Make sure we have a parsed error-list
 343           (if (eq compilation-error-list t)
 344               (progn (compilation-forget-errors)
 345                      (setq compilation-parsing-end 1)))
 346           (if (not compilation-error-list)
 347               (save-excursion
 348                 (set-buffer-modified-p nil)
 349                 (condition-case ()
 350                     ;; Emacs V19 incompatibly adds two non-optional arguments
 351                     ;; over V18.
 352                     (compilation-parse-errors nil nil)
 353                   (error (compilation-parse-errors)))))))
 354     ;; Locate and parse grep messages found in any buffer.
 355     (save-excursion
 356       (beginning-of-line)
 357       (if (or
 358             ;; UNIX C compiler and Introl 68HC11 C compiler errors
 359             (looking-at "\\([^ \t\n\^M:]+\\): ?\\([0-9]+\\)[ :]")
 360             ;; BSO/Tasking 68HC08 C compiler errors
 361             (looking-at
 362              "[a-zA-Z 0-9]+: \\([^ \t\n\^M]+\\) line \\([0-9]+\\)[ \t]*:")
 363             ;; UNIX Lint errors
 364             (looking-at "[^:]+: \\([^ \t\n\^M:]+\\): line \\([0-9]+\\):")
 365             ;; SparcWorks C compiler errors (ends with :)
 366             ;; IBM AIX xlc C compiler errors (ends with .)
 367             (looking-at "\"\\([^\"]+\\)\", line \\([0-9]+\\)[:.]")
 368             ;; Introl as11 assembler errors
 369             (looking-at " \\*+ \\([^ \t\n\^M]+\\) - \\([0-9]+\\) ")
 370             ;; perl5: ... at file.c line 10
 371             (looking-at ".+ at \\([^ \t\n]+\\) line +\\([0-9]+\\)")
 372             )
 373           (let* ((file (buffer-substring (match-beginning 1)
 374                                          (match-end 1)))
 375                  (line-num (buffer-substring (match-beginning 2)
 376                                              (match-end 2)))
 377                  (but-label (concat file ":" line-num))
 378                  (source-loc (hbut:key-src t)))
 379             (if (stringp source-loc)
 380                 (setq file (expand-file-name
 381                             file (file-name-directory source-loc))))
 382             (setq line-num (string-to-number line-num))
 383             (ibut:label-set but-label)
 384             (hact 'link-to-file-line file line-num))))))
 385
 386 ;;;
 387 ;;; Jumps to source of Emacs Lisp V19 byte-compiler error messages.
 388 ;;;
 389
 390 (defib elisp-compiler-msg ()
 391   "Jumps to source code for definition associated with byte-compiler error message.
 392 Works when activated anywhere within an error line."
 393   (if (or (equal (buffer-name) "*Compile-Log*")
 394           (equal (buffer-name) "*compilation*")
 395           (save-excursion
 396             (and (re-search-backward "^[^ \t\n\r]" nil t)
 397                  (looking-at "While compiling"))))
 398       (let (src buffer-p label)
 399         (and (save-excursion
 400                (re-search-backward
 401                 "^While compiling [^\t\n]+ in \\(file\\|buffer\\) \\([^ \n]+\\):$"
 402                 nil t))
 403              (setq buffer-p
 404                    (equal (buffer-substring (match-beginning 1) (match-end 1))
 405                           "buffer")
 406                    src (buffer-substring (match-beginning 2) (match-end 2)))
 407              (save-excursion
 408                (end-of-line)
 409                (re-search-backward "^While compiling \\([^ \n]+\\)\\(:$\\| \\)"
 410                                    nil t))
 411              (progn
 412                (setq label (buffer-substring
 413                             (match-beginning 1) (match-end 1)))
 414                (ibut:label-set label (match-beginning 1) (match-end 1))
 415                ;; Remove prefix generated by actype and ibtype definitions.
 416                (setq label (hypb:replace-match-string "[^:]+::" label "" t))
 417                (hact 'link-to-regexp-match
 418                      (concat "^\(def[a-z \t]+" (regexp-quote label)
 419                              "[ \t\n\(]")
 420                      1 src buffer-p))))))
 421
 422 ;;;
 423 ;;; Jumps to source associated with a line of output from 'patch'.
 424 ;;;
 425
 426 (defib patch-msg ()
 427   "Jumps to source code associated with output from the 'patch' program.
 428 Patch applies diffs to source code."
 429   (if (save-excursion
 430         (beginning-of-line)
 431         (looking-at "Patching \\|Hunk "))
 432       (let ((opoint (point))
 433             (file) line)
 434         (beginning-of-line)
 435         (cond ((looking-at "Hunk .+ at \\([0-9]+\\)")
 436                (setq line (buffer-substring (match-beginning 1)
 437                                             (match-end 1)))
 438                (ibut:label-set line (match-beginning 1) (match-end 1))
 439                (if (re-search-backward "^Patching file \\(\\S +\\)" nil t)
 440                    (setq file (buffer-substring (match-beginning 1)
 441                                                 (match-end 1)))))
 442               ((looking-at "Patching file \\(\\S +\\)")
 443                (setq file (buffer-substring (match-beginning 1)
 444                                             (match-end 1))
 445                      line "1")
 446                (ibut:label-set file (match-beginning 1) (match-end 1))))
 447         (goto-char opoint)
 448         (if (null file)
 449             nil
 450           (setq line (string-to-number line))
 451           (hact 'link-to-file-line file line)))))
 452
 453 ;;;
 454 ;;; Composes mail, in another window, to the e-mail address at point.
 455 ;;;
 456
 457 (defib mail-address ()
 458   "If on an e-mail address in a specific buffer type, mail to that address in another window.
 459 Applies to the rolodex match buffer, any buffer attached to a file in
 460 'rolo-file-list', or any buffer with \"mail\" or \"rolo\" (case-insensitive)
 461 within its name."
 462   (if (or (and (let ((case-fold-search t))
 463                  (string-match "mail\\|rolo" (buffer-name)))
 464                ;; Don't want this to trigger in a mail/news summary buffer.
 465                (not (or (hmail:lister-p) (hnews:lister-p))))
 466           (if (boundp 'rolo-display-buffer)
 467               (equal (buffer-name) rolo-display-buffer))
 468           (and buffer-file-name
 469                (boundp 'rolo-file-list)
 470                (set:member (current-buffer)
 471                            (mapcar 'get-file-buffer rolo-file-list))))
 472       (let ((address (mail-address-at-p)))
 473         (if address
 474             (progn
 475               (ibut:label-set address (match-beginning 1) (match-end 1))
 476               (hact 'mail-other-window nil address))))))
 477
 478 (defconst mail-address-regexp
 479   "\\([_a-zA-Z][-_a-zA-Z0-9.!@+%]*@[-_a-zA-Z0-9.!@+%]+\\.[a-zA-Z][-_a-zA-Z][-_a-zA-Z]?\\|[a-zA-Z][-_a-zA-Z0-9.!+%]+@[-_a-zA-Z0-9@]+\\)\\($\\|[^a-zA-Z0-9.!@%]\\)"
 480   "Regexp with group 1 matching an Internet email address.")
 481
 482 (defun mail-address-at-p ()
 483   "Return e-mail address, a string, that point is within or nil."
 484   (save-excursion
 485     (skip-chars-backward "^ \t\n\^M\"\'(){}[];<>|")
 486     (if (looking-at mail-address-regexp)
 487         (buffer-substring (match-beginning 1) (match-end 1)))))
 488
 489 ;;;
 490 ;;; Displays Info nodes when double quoted "(file)node" button is activated.
 491 ;;;
 492
 493 (defib Info-node ()
 494   "Makes \"(file)node\" buttons display the associated Info node."
 495   (let* ((node-ref-and-pos (hbut:label-p t "\"" "\"" t))
 496          (node-ref (hpath:is-p (car node-ref-and-pos) nil t)))
 497     (and node-ref (string-match "([^\)]+)" node-ref)
 498          (ibut:label-set node-ref-and-pos)
 499          (hact 'link-to-Info-node node-ref))))
 500
 501 ;;;
 502 ;;; Inserts completion into minibuffer or other window.
 503 ;;;
 504
 505 (defib completion ()
 506   "Inserts completion at point into minibuffer or other window."
 507   (let ((completion (hargs:completion t)))
 508     (and completion
 509          (ibut:label-set completion)
 510          (hact 'completion))))
 511
 512
 513 (run-hooks 'hibtypes:end-load-hook)
 514 (provide 'hibtypes)
 515
 516 ;;; hibtypes.el ends here