Mercurial > hg > xemacs-beta
comparison lisp/gnats/send-pr.el @ 110:fe104dbd9147 r20-1b7
Import from CVS: tag r20-1b7
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 09:19:45 +0200 |
| parents | |
| children | 48d667d6f17f |
comparison
equal
deleted
inserted
replaced
| 109:e183fc049578 | 110:fe104dbd9147 |
|---|---|
| 1 ;;;; -*-emacs-lisp-*- | |
| 2 ;;;;--------------------------------------------------------------------------- | |
| 3 ;;;; EMACS interface for send-pr (by Heinz G. Seidl, hgs@cygnus.com) | |
| 4 ;;;; Slightly hacked by Brendan Kehoe (brendan@cygnus.com). | |
| 5 ;;;; | |
| 6 ;;;; This file is part of the Problem Report Management System (GNATS) | |
| 7 ;;;; Copyright 1992, 1993 Cygnus Support | |
| 8 ;;;; | |
| 9 ;;;; This program is free software; you can redistribute it and/or | |
| 10 ;;;; modify it under the terms of the GNU General Public | |
| 11 ;;;; License as published by the Free Software Foundation; either | |
| 12 ;;;; version 2 of the License, or (at your option) any later version. | |
| 13 ;;;; | |
| 14 ;;;; This program is distributed in the hope that it will be useful, | |
| 15 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 16 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
| 17 ;;;; General Public License for more details. | |
| 18 ;;;; | |
| 19 ;;;; You should have received a copy of the GNU Library General Public | |
| 20 ;;;; License along with this program; if not, write to the Free | |
| 21 ;;;; Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. | |
| 22 ;;;; | |
| 23 ;;;;--------------------------------------------------------------------------- | |
| 24 ;;;; | |
| 25 ;;;; This file contains the EMACS interface to the Problem Report Management | |
| 26 ;;;; System (GNATS): | |
| 27 ;;;; | |
| 28 ;;;; - The `send-pr' command and the `send-pr-mode' for sending | |
| 29 ;;;; Problem Reports (PRs). | |
| 30 ;;;; | |
| 31 ;;;; For more information about how to send a PR see send-pr(1). | |
| 32 ;;;; | |
| 33 ;;;;--------------------------------------------------------------------------- | |
| 34 ;;;; | |
| 35 ;;;; Configuration: the symbol `DEFAULT-RELEASE' can be replaced by | |
| 36 ;;;; site/release specific strings during the configuration/installation | |
| 37 ;;;; process. | |
| 38 ;;;; | |
| 39 ;;;; Install this file in your EMACS library directory. | |
| 40 ;;;; | |
| 41 ;;;;--------------------------------------------------------------------------- | |
| 42 | |
| 43 (provide 'send-pr) | |
| 44 | |
| 45 ;;;;--------------------------------------------------------------------------- | |
| 46 ;;;; Customization: put the following forms into your default.el file | |
| 47 ;;;; (or into your .emacs) | |
| 48 ;;;;--------------------------------------------------------------------------- | |
| 49 | |
| 50 ;(autoload 'send-pr-mode "send-pr" | |
| 51 ; "Major mode for sending problem reports." t) | |
| 52 | |
| 53 ;(autoload 'send-pr "send-pr" | |
| 54 ; "Command to create and send a problem report." t) | |
| 55 | |
| 56 ;;;;--------------------------------------------------------------------------- | |
| 57 ;;;; End of Customization Section | |
| 58 ;;;;--------------------------------------------------------------------------- | |
| 59 | |
| 60 (autoload 'server-buffer-done "server") | |
| 61 (defvar server-buffer-clients nil) | |
| 62 (defvar mail-self-blind nil) | |
| 63 (defvar mail-default-reply-to nil) | |
| 64 | |
| 65 (defconst send-pr::version "3.101") | |
| 66 | |
| 67 (defvar gnats:root "" | |
| 68 "*The top of the tree containing the GNATS database.") | |
| 69 | |
| 70 ;;;;--------------------------------------------------------------------------- | |
| 71 ;;;; hooks | |
| 72 ;;;;--------------------------------------------------------------------------- | |
| 73 | |
| 74 (defvar text-mode-hook nil) ; we define it here in case it's not defined | |
| 75 (defvar send-pr-mode-hook text-mode-hook "Called when send-pr is invoked.") | |
| 76 | |
| 77 ;;;;--------------------------------------------------------------------------- | |
| 78 ;;;; Domains and default values for (some of) the Problem Report fields; | |
| 79 ;;;; constants and definitions. | |
| 80 ;;;;--------------------------------------------------------------------------- | |
| 81 | |
| 82 (defconst gnats::emacs-19p | |
| 83 (not (or (and (boundp 'epoch::version) epoch::version) | |
| 84 (string-lessp emacs-version "19"))) | |
| 85 "Is this emacs v19?") | |
| 86 | |
| 87 ;;; This has to be here rather than at the bottom of this file with | |
| 88 ;;; the other utility functions because it is used by | |
| 89 ;;; gnats::get-config, which is called when send-pr.el is being | |
| 90 ;;; loaded (see the "defconst" below), before the whole file has been | |
| 91 ;;; loaded. | |
| 92 | |
| 93 (defun gnats::find-safe-default-directory (&optional buffer) | |
| 94 "If the directory referred to by `default-directory' for the current | |
| 95 buffer (or for optional argument BUFFER) does not exist, set it to the home | |
| 96 directory of the current user if that exists, or to `/'. | |
| 97 | |
| 98 Returns the final value of default-directory in the buffer." | |
| 99 (let ((homedir (expand-file-name "~/"))) | |
| 100 (save-excursion | |
| 101 (if buffer (set-buffer buffer)) | |
| 102 (if (not (file-exists-p default-directory)) | |
| 103 (if (file-exists-p homedir) | |
| 104 (setq default-directory homedir) | |
| 105 (setq default-directory "/"))) | |
| 106 default-directory))) | |
| 107 | |
| 108 ;;; These may be changed during configuration/installation or by the individual | |
| 109 ;;; user in his/her .emacs file. | |
| 110 ;;; | |
| 111 (defun gnats::get-config (var) | |
| 112 (let ((shell-file-name "/bin/sh") | |
| 113 (buf (generate-new-buffer " *GNATS config*")) | |
| 114 ret) | |
| 115 (save-excursion | |
| 116 (set-buffer buf) | |
| 117 (shell-command-on-region | |
| 118 (point-min) (point-max) | |
| 119 (concat ". " gnats:root "/gnats-adm/config; echo $" var ) t) | |
| 120 (goto-char (point-min)) | |
| 121 ; We have to use get-buffer, since shell-command-on-region will wipe | |
| 122 ; out the buffer if there's no output from the command. | |
| 123 (if (or (not (get-buffer "*Shell Command Output*")) | |
| 124 (looking-at "/bin/sh:\\|\.:\\|\n")) | |
| 125 (setq ret nil) | |
| 126 (setq ret (buffer-substring (point-min) (- (point-max) 1))))) | |
| 127 (if (and ret (string-equal ret "")) (setq ret nil)) | |
| 128 (kill-buffer buf) | |
| 129 ret)) | |
| 130 | |
| 131 ;; const because it must match the script's value | |
| 132 (defconst send-pr:datadir (or (gnats::get-config "DATADIR") "/usr/local/share") | |
| 133 "*Where the `gnats' subdirectory containing category lists lives.") | |
| 134 | |
| 135 (defvar send-pr::sites nil | |
| 136 "List of GNATS support sites; computed at runtime.") | |
| 137 (defvar send-pr:default-site | |
| 138 (or (gnats::get-config "GNATS_SITE") "cygnus") | |
| 139 "Default site to send bugs to.") | |
| 140 (defvar send-pr:::site send-pr:default-site | |
| 141 "The site to which a problem report is currently being submitted, or NIL | |
| 142 if using the default site (buffer local).") | |
| 143 | |
| 144 (defvar send-pr:::categories nil | |
| 145 "Buffer local list of available categories, derived at runtime from | |
| 146 send-pr:::site and send-pr::category-alist.") | |
| 147 (defvar send-pr::category-alist nil | |
| 148 "Alist of GNATS support sites and the categories supported at each; computed | |
| 149 at runtime.") | |
| 150 | |
| 151 ;;; Ideally we would get all the following values from a central database | |
| 152 ;;; during runtime instead of having them here in the code. | |
| 153 ;;; | |
| 154 (defconst send-pr::fields | |
| 155 (` (("Category" send-pr::set-categories | |
| 156 (, (or (gnats::get-config "DEFAULT_CATEGORY") nil)) enum) | |
| 157 ("Class" (("sw-bug") ("doc-bug") ("change-request") ("support")) | |
| 158 (, (or (gnats::get-config "DEFAULT_CLASS") 0)) enum) | |
| 159 ("Confidential" (("yes") ("no")) | |
| 160 (, (or (gnats::get-config "DEFAULT_CONFIDENTIAL") 1)) enum) | |
| 161 ("Severity" (("non-critical") ("serious") ("critical")) | |
| 162 (, (or (gnats::get-config "DEFAULT_SEVERITY") 1)) enum) | |
| 163 ("Priority" (("low") ("medium") ("high")) | |
| 164 (, (or (gnats::get-config "DEFAULT_PRIORITY") 1)) enum) | |
| 165 ("Release" nil | |
| 166 (, (or (gnats::get-config "DEFAULT_RELEASE") "gnats-3.101")) | |
| 167 text) | |
| 168 ("Submitter-Id" nil | |
| 169 (, (or (gnats::get-config "SUBMITTER") "xSUBMITTERx")) text) | |
| 170 ("Synopsis" nil nil text | |
| 171 (lambda (a b c) (gnats::set-mail-field "Subject" c))))) | |
| 172 "AList, keyed on the name of the field, of: | |
| 173 1) The field name. | |
| 174 2) The list of completions. This can be a list, a function to call, or nil. | |
| 175 3) The default value. | |
| 176 4) The type of the field. | |
| 177 5) A sub-function to call when changed.") | |
| 178 | |
| 179 (defvar gnats::fields nil) | |
| 180 | |
| 181 (defmacro gnats::push (i l) | |
| 182 (` (setq (, l) (cons (,@ (list i l)))))) | |
| 183 | |
| 184 (defun send-pr::set-categories (&optional arg) | |
| 185 "Get the list of categories for the current site out of | |
| 186 send-pr::category-alist if there or from send-pr if not. With arg, force | |
| 187 update." | |
| 188 ;; | |
| 189 (let ((entry (assoc send-pr:::site send-pr::category-alist))) | |
| 190 (or (and entry (null arg)) | |
| 191 (let ((oldpr (getenv "GNATS_ROOT")) cats) | |
| 192 (send-pr::set-sites arg) | |
| 193 (setenv "GNATS_ROOT" gnats:root) | |
| 194 (setq cats (gnats::get-value-from-shell | |
| 195 "send-pr" "-CL" send-pr:::site)) | |
| 196 (setenv "GNATS_ROOT" oldpr) | |
| 197 (if entry (setcdr entry cats) | |
| 198 (setq entry (cons send-pr:::site cats)) | |
| 199 (gnats::push entry send-pr::category-alist)))) | |
| 200 (setq send-pr:::categories (cdr entry)))) | |
| 201 | |
| 202 (defun send-pr::set-sites (&optional arg) | |
| 203 "Get the list of sites (by listing the contents of DATADIR/gnats) and assign | |
| 204 it to send-pr::sites. With arg, force update." | |
| 205 (or (and (null arg) send-pr::sites) | |
| 206 (progn | |
| 207 (setq send-pr::sites nil) | |
| 208 (mapcar | |
| 209 (function | |
| 210 (lambda (file) | |
| 211 (or (memq t (mapcar (function (lambda (x) (string= x file))) | |
| 212 '("." ".." "pr-edit" "pr-addr"))) | |
| 213 (not (file-readable-p file)) | |
| 214 (gnats::push (list (file-name-nondirectory file)) | |
| 215 send-pr::sites)))) | |
| 216 (directory-files (format "%s/gnats" send-pr:datadir) t)) | |
| 217 (setq send-pr::sites (reverse send-pr::sites))))) | |
| 218 | |
| 219 (defconst send-pr::pr-buffer-name "*send-pr*" | |
| 220 "Name of the temporary buffer, where the problem report gets composed.") | |
| 221 | |
| 222 (defconst send-pr::err-buffer-name "*send-pr-error*" | |
| 223 "Name of the temporary buffer, where send-pr error messages appear.") | |
| 224 | |
| 225 (defvar send-pr:::err-buffer nil | |
| 226 "The error buffer used by the current PR buffer.") | |
| 227 | |
| 228 (defvar send-pr:::spawn-to-send nil | |
| 229 "Whether or not send-pr-mode should spawn a send-pr process to send the PR.") | |
| 230 | |
| 231 (defconst gnats::indent 17 "Indent for formatting the value.") | |
| 232 | |
| 233 ;;;;--------------------------------------------------------------------------- | |
| 234 ;;;; `send-pr' - command for creating and sending of problem reports | |
| 235 ;;;;--------------------------------------------------------------------------- | |
| 236 | |
| 237 ;;;###autoload | |
| 238 (fset 'send-pr 'send-pr:send-pr) | |
| 239 ;;;###autoload | |
| 240 (defun send-pr:send-pr (&optional site) | |
| 241 "Create a buffer and read in the result of `send-pr -P'. | |
| 242 When finished with editing the problem report use \\[send-pr:submit-pr] | |
| 243 to send the PR with `send-pr -b -f -'." | |
| 244 ;; | |
| 245 (interactive | |
| 246 (if current-prefix-arg | |
| 247 (list (completing-read "Site: " (send-pr::set-sites 'recheck) nil t | |
| 248 send-pr:default-site)))) | |
| 249 (or site (setq site send-pr:default-site)) | |
| 250 (let ((buf (get-buffer send-pr::pr-buffer-name))) | |
| 251 (if (or (not buf) | |
| 252 (progn (switch-to-buffer buf) | |
| 253 (cond ((or (not (buffer-modified-p buf)) | |
| 254 (y-or-n-p "Erase previous problem report? ")) | |
| 255 (erase-buffer) t) | |
| 256 (t nil)))) | |
| 257 (send-pr::start-up site)))) | |
| 258 | |
| 259 (defun send-pr::start-up (site) | |
| 260 (switch-to-buffer (get-buffer-create send-pr::pr-buffer-name)) | |
| 261 (setq default-directory (expand-file-name "~/")) | |
| 262 (auto-save-mode auto-save-default) | |
| 263 (let ((oldpr (getenv "GNATS_ROOT")) | |
| 264 (case-fold-search nil)) | |
| 265 (setenv "GNATS_ROOT" gnats:root) | |
| 266 (send-pr::insert-template site) | |
| 267 (setenv "GNATS_ROOT" oldpr) | |
| 268 (goto-char (point-min)) | |
| 269 (if (looking-at "send-pr:") | |
| 270 (cond ((looking-at "send-pr: .* does not have a categories list") | |
| 271 (setq send-pr::sites nil) | |
| 272 (error "send-pr: the GNATS site %s does not have a categories list" site)) | |
| 273 (t (error (buffer-substring (point-min) (point-max))))) | |
| 274 (save-excursion | |
| 275 ;; Clear cruft inserted by bdamaged .cshrcs | |
| 276 (goto-char 1) | |
| 277 (re-search-forward "^SEND-PR:") | |
| 278 (delete-region 1 (match-beginning 0))))) | |
| 279 (set-buffer-modified-p nil) | |
| 280 (send-pr:send-pr-mode) | |
| 281 (setq send-pr:::site site) | |
| 282 (setq send-pr:::spawn-to-send t) | |
| 283 (send-pr::set-categories) | |
| 284 (if (null send-pr:::categories) | |
| 285 (progn | |
| 286 (and send-pr:::err-buffer (kill-buffer send-pr:::err-buffer)) | |
| 287 (kill-buffer nil) | |
| 288 (message "send-pr: no categories found")) | |
| 289 (or (stringp mail-default-reply-to) | |
| 290 (setq mail-default-reply-to (getenv "REPLYTO"))) | |
| 291 (and mail-default-reply-to | |
| 292 (gnats::set-mail-field "Reply-To" mail-default-reply-to)) | |
| 293 (and mail-self-blind | |
| 294 (gnats::set-mail-field "BCC" (user-login-name))) | |
| 295 (mapcar 'send-pr::maybe-change-field send-pr::fields) | |
| 296 (gnats::position-on-field "Description") | |
| 297 (message (substitute-command-keys | |
| 298 "To send the problem report use: \\[send-pr:submit-pr]")))) | |
| 299 | |
| 300 (defvar send-pr::template-alist nil | |
| 301 "An alist containing the output of send-pr -P <sitename> for various sites.") | |
| 302 | |
| 303 (defun send-pr::insert-template (site) | |
| 304 (let ((elt (assoc site send-pr::template-alist))) | |
| 305 (if elt | |
| 306 (save-excursion (insert (cdr elt))) | |
| 307 (call-process "send-pr" nil t nil "-P" site) | |
| 308 (save-excursion | |
| 309 (setq send-pr::template-alist | |
| 310 (cons (cons site (buffer-substring (point-min) (point-max))) | |
| 311 send-pr::template-alist)))))) | |
| 312 | |
| 313 (fset 'do-send-pr 'send-pr:submit-pr) ;backward compat | |
| 314 (defun send-pr:submit-pr () | |
| 315 "Pipe the contents of the buffer *send-pr* to `send-pr -f -.' unless this | |
| 316 buffer was loaded with emacsclient, in which case save the buffer and exit." | |
| 317 ;; | |
| 318 (interactive) | |
| 319 (cond | |
| 320 ((and (boundp 'server-buffer-clients) | |
| 321 server-buffer-clients) | |
| 322 (let ((buffer (current-buffer)) | |
| 323 (version-control nil) (buffer-backed-up nil)) | |
| 324 (save-buffer buffer) | |
| 325 (kill-buffer buffer) | |
| 326 (server-buffer-done buffer))) | |
| 327 (send-pr:::spawn-to-send | |
| 328 (or (and send-pr:::err-buffer | |
| 329 (buffer-name send-pr:::err-buffer)) | |
| 330 (setq send-pr:::err-buffer | |
| 331 (get-buffer-create send-pr::err-buffer-name))) | |
| 332 (let ((err-buffer send-pr:::err-buffer) mesg ok) | |
| 333 (save-excursion (set-buffer err-buffer) (erase-buffer)) | |
| 334 (message "running send-pr...") | |
| 335 (let ((oldpr (getenv "GNATS_ROOT"))) | |
| 336 (setenv "GNATS_ROOT" gnats:root) | |
| 337 (call-process-region (point-min) (point-max) "send-pr" | |
| 338 nil err-buffer nil send-pr:::site | |
| 339 "-b" "-f" "-") | |
| 340 (setenv "GNATS_ROOT" oldpr)) | |
| 341 (message "running send-pr...done") | |
| 342 ;; stupidly we cannot check the return value in EMACS 18.57, thus we need | |
| 343 ;; this kluge to find out whether send-pr succeeded. | |
| 344 (if (save-excursion | |
| 345 (set-buffer err-buffer) | |
| 346 (goto-char (point-min)) | |
| 347 (setq mesg (buffer-substring (point-min) (- (point-max) 1))) | |
| 348 (search-forward "problem report sent" nil t)) | |
| 349 (progn (message mesg) | |
| 350 (kill-buffer err-buffer) | |
| 351 (delete-auto-save-file-if-necessary) | |
| 352 (set-buffer-modified-p nil) | |
| 353 (bury-buffer)) | |
| 354 (pop-to-buffer err-buffer)) | |
| 355 )) | |
| 356 (t | |
| 357 (save-buffer) | |
| 358 (message "Exit emacs to send the PR.")))) | |
| 359 | |
| 360 ;;;;--------------------------------------------------------------------------- | |
| 361 ;;;; send-pr:send-pr-mode mode | |
| 362 ;;;;--------------------------------------------------------------------------- | |
| 363 | |
| 364 (defvar send-pr-mode-map | |
| 365 (let ((map (make-sparse-keymap))) | |
| 366 (define-key map "\C-c\C-c" 'send-pr:submit-pr) | |
| 367 (define-key map "\C-c\C-f" 'gnats:change-field) | |
| 368 (define-key map "\M-n" 'gnats:next-field) | |
| 369 (define-key map "\M-p" 'gnats:previous-field) | |
| 370 (define-key map "\C-\M-f" 'gnats:forward-field) | |
| 371 (define-key map "\C-\M-b" 'gnats:backward-field) | |
| 372 map) | |
| 373 "Keymap for send-pr mode.") | |
| 374 | |
| 375 (defconst gnats::keyword "^>\\([-a-zA-Z]+\\):") | |
| 376 (defconst gnats::before-keyword "[ \t\n\f]*[\n\f]+>\\([-a-zA-Z]+\\):") | |
| 377 (defconst gnats::after-keyword "^>\\([-a-zA-Z]+\\):[ \t\n\f]+") | |
| 378 | |
| 379 ;;;###autoload | |
| 380 (fset 'send-pr-mode 'send-pr:send-pr-mode) | |
| 381 ;;;###autoload | |
| 382 (defun send-pr:send-pr-mode () | |
| 383 "Major mode for submitting problem reports. | |
| 384 For information about the form see gnats(1) and send-pr(1). | |
| 385 Special commands: \\{send-pr-mode-map} | |
| 386 Turning on send-pr-mode calls the value of the variable send-pr-mode-hook, | |
| 387 if it is not nil." | |
| 388 (interactive) | |
| 389 (gnats::patch-exec-path) | |
| 390 (put 'send-pr:send-pr-mode 'mode-class 'special) | |
| 391 (kill-all-local-variables) | |
| 392 (setq major-mode 'send-pr:send-pr-mode) | |
| 393 (setq mode-name "send-pr") | |
| 394 (use-local-map send-pr-mode-map) | |
| 395 (set-syntax-table text-mode-syntax-table) | |
| 396 (setq local-abbrev-table text-mode-abbrev-table) | |
| 397 (setq buffer-offer-save t) | |
| 398 (make-local-variable 'send-pr:::site) | |
| 399 (make-local-variable 'send-pr:::categories) | |
| 400 (make-local-variable 'send-pr:::err-buffer) | |
| 401 (make-local-variable 'send-pr:::spawn-to-send) | |
| 402 (make-local-variable 'paragraph-separate) | |
| 403 (setq paragraph-separate (concat (default-value 'paragraph-separate) | |
| 404 "\\|" gnats::keyword "[ \t\n\f]*$")) | |
| 405 (make-local-variable 'paragraph-start) | |
| 406 (setq paragraph-start (concat (default-value 'paragraph-start) | |
| 407 "\\|" gnats::keyword)) | |
| 408 (run-hooks 'send-pr-mode-hook) | |
| 409 t) | |
| 410 | |
| 411 ;;;;--------------------------------------------------------------------------- | |
| 412 ;;;; Functions to read and replace field values. | |
| 413 ;;;;--------------------------------------------------------------------------- | |
| 414 | |
| 415 (defun gnats::position-on-field (field &optional quiet) | |
| 416 (goto-char (point-min)) | |
| 417 (if (not (re-search-forward (concat "^>" field ":") nil t)) | |
| 418 (if quiet | |
| 419 nil | |
| 420 (error "Field `>%s:' not found." field)) | |
| 421 (re-search-forward "[ \t\n\f]*") | |
| 422 (if (looking-at gnats::keyword) | |
| 423 (backward-char 1)) | |
| 424 t)) | |
| 425 | |
| 426 (defun gnats::mail-position-on-field (field) | |
| 427 (let (end | |
| 428 (case-fold-search t)) | |
| 429 (goto-char (point-min)) | |
| 430 (re-search-forward "^$") | |
| 431 (setq end (match-beginning 0)) | |
| 432 (goto-char (point-min)) | |
| 433 (if (not (re-search-forward (concat "^" field ":") end 'go-to-end)) | |
| 434 (insert field ": \n") | |
| 435 (re-search-forward "[ \t\n\f]*")) | |
| 436 (skip-chars-backward "\n") | |
| 437 t)) | |
| 438 | |
| 439 (defun gnats::field-contents (field &optional elem move) | |
| 440 (let (pos) | |
| 441 (unwind-protect | |
| 442 (save-excursion | |
| 443 (if (not (gnats::position-on-field field t)) | |
| 444 nil | |
| 445 (setq pos (point-marker)) | |
| 446 (if (or (looking-at "<.*>$") (eolp)) | |
| 447 t | |
| 448 (looking-at ".*$") ; to set match-{beginning,end} | |
| 449 (gnats::nth-word | |
| 450 (buffer-substring (match-beginning 0) (match-end 0)) | |
| 451 elem)))) | |
| 452 (and move pos (goto-char pos))))) | |
| 453 | |
| 454 (defun gnats::functionp (thing) | |
| 455 (or (and (symbolp thing) (fboundp thing)) | |
| 456 (and (listp thing) (eq (car thing) 'lambda)))) | |
| 457 | |
| 458 (defun gnats::field-values (field) | |
| 459 "Return the possible (known) values for field FIELD." | |
| 460 (let* ((fields (if (eq major-mode 'gnats:gnats-mode) gnats::fields | |
| 461 send-pr::fields)) | |
| 462 (thing (elt (assoc field fields) 1))) | |
| 463 (cond ((gnats::functionp thing) (funcall thing)) | |
| 464 ((listp thing) thing) | |
| 465 (t (error "ACK"))))) | |
| 466 | |
| 467 (defun gnats::field-default (field) | |
| 468 "Return the default value for field FIELD." | |
| 469 (let* ((fields (if (eq major-mode 'gnats:gnats-mode) gnats::fields | |
| 470 send-pr::fields)) | |
| 471 (thing (elt (assoc field fields) 2))) | |
| 472 (cond ((stringp thing) thing) | |
| 473 ((null thing) "") | |
| 474 ((numberp thing) (car (elt (gnats::field-values field) thing))) | |
| 475 ((gnats::functionp thing) | |
| 476 (funcall thing (gnats::field-contents field))) | |
| 477 ((eq thing t) (gnats::field-contents field)) | |
| 478 (t (error "ACK"))))) | |
| 479 | |
| 480 (defun gnats::field-type (field) | |
| 481 "Return the type of field FIELD." | |
| 482 (let* ((fields (if (eq major-mode 'gnats:gnats-mode) gnats::fields | |
| 483 send-pr::fields)) | |
| 484 (thing (elt (assoc field fields) 3))) | |
| 485 thing)) | |
| 486 | |
| 487 (defun gnats::field-action (field) | |
| 488 "Return the extra handling function for field FIELD." | |
| 489 (let* ((fields (if (eq major-mode 'gnats:gnats-mode) gnats::fields | |
| 490 send-pr::fields)) | |
| 491 (thing (elt (assoc field fields) 4))) | |
| 492 (cond ((null thing) 'ignore) | |
| 493 ((gnats::functionp thing) thing) | |
| 494 (t (error "ACK"))))) | |
| 495 | |
| 496 ;;;;--------------------------------------------------------------------------- | |
| 497 ;;;; Point movement functions | |
| 498 ;;;;--------------------------------------------------------------------------- | |
| 499 | |
| 500 (or (fboundp 'defsubst) (fset 'defsubst 'defun)) | |
| 501 | |
| 502 (defun send-pr::maybe-change-field (field) | |
| 503 (setq field (car field)) | |
| 504 (let ((thing (gnats::field-contents field))) | |
| 505 (and thing (eq t thing) | |
| 506 (not (eq 'multi-text (gnats::field-type field))) | |
| 507 (gnats:change-field field)))) | |
| 508 | |
| 509 (defun gnats:change-field (&optional field default) | |
| 510 "Change the value of the field containing the cursor. With arg, ask the | |
| 511 user for the field to change. From a program, the function takes optional | |
| 512 arguments of the field to change and the default value to use." | |
| 513 (interactive) | |
| 514 (or field current-prefix-arg (setq field (gnats::current-field))) | |
| 515 (or field | |
| 516 (setq field | |
| 517 (completing-read "Field: " | |
| 518 (if (eq major-mode 'gnats:gnats-mode) | |
| 519 gnats::fields | |
| 520 send-pr::fields) | |
| 521 nil t))) | |
| 522 (gnats::position-on-field field) | |
| 523 (sit-for 0) | |
| 524 (let* ((old (gnats::field-contents field)) | |
| 525 new) | |
| 526 (if (null old) | |
| 527 (error "ACK") | |
| 528 (if (or (interactive-p) t) | |
| 529 (let ((prompt (concat ">" field ": ")) | |
| 530 (domain (gnats::field-values field)) | |
| 531 (type (gnats::field-type field))) | |
| 532 (or default (setq default (gnats::field-default field))) | |
| 533 (setq new | |
| 534 (if (eq type 'enum) | |
| 535 (completing-read prompt domain nil t | |
| 536 (if gnats::emacs-19p (cons default 0) | |
| 537 default)) | |
| 538 (read-string prompt (if gnats::emacs-19p (cons default 1) | |
| 539 default))))) | |
| 540 (setq new default)) | |
| 541 (gnats::set-field field new) | |
| 542 (funcall (gnats::field-action field) field old new) | |
| 543 new))) | |
| 544 | |
| 545 (defun gnats::set-field (field value) | |
| 546 (save-excursion | |
| 547 (gnats::position-on-field field) | |
| 548 (delete-horizontal-space) | |
| 549 (looking-at ".*$") | |
| 550 (replace-match | |
| 551 (concat (make-string (- gnats::indent (length field) 2) ?\40 ) value) t))) | |
| 552 | |
| 553 (defun gnats::set-mail-field (field value) | |
| 554 (save-excursion | |
| 555 (gnats::mail-position-on-field field) | |
| 556 (delete-horizontal-space) | |
| 557 (looking-at ".*$") | |
| 558 (replace-match (concat " " value) t))) | |
| 559 | |
| 560 (defun gnats::before-keyword (&optional where) | |
| 561 "Returns t if point is in some white space before a keyword. | |
| 562 If where is nil, then point is not changed; if where is t then point is moved | |
| 563 to the beginning of the keyword, otherwise it is moved to the beginning | |
| 564 of the white space it was in." | |
| 565 ;; | |
| 566 (if (looking-at gnats::before-keyword) | |
| 567 (prog1 t | |
| 568 (cond ((eq where t) | |
| 569 (re-search-forward "^>") (backward-char)) | |
| 570 ((not (eq where nil)) | |
| 571 (re-search-backward "[^ \t\n\f]") (forward-char)))) | |
| 572 nil)) | |
| 573 | |
| 574 (defun gnats::after-keyword (&optional where) | |
| 575 "Returns t if point is in some white space after a keyword. | |
| 576 If where is nil, then point is not changed; if where is t then point is moved | |
| 577 to the beginning of the keyword, otherwise it is moved to the end of the white | |
| 578 space it was in." | |
| 579 ;; | |
| 580 (if (gnats::looking-after gnats::after-keyword) | |
| 581 (prog1 t | |
| 582 (cond ((eq where t) | |
| 583 (re-search-backward "^>")) | |
| 584 ((not (eq where nil)) | |
| 585 (re-search-forward "[^ \t\n\f]") (backward-char)))) | |
| 586 nil)) | |
| 587 | |
| 588 (defun gnats::in-keyword (&optional where) | |
| 589 "Returns t if point is within a keyword. | |
| 590 If where is nil, then point is not changed; if where is t then point is moved | |
| 591 to the beginning of the keyword." | |
| 592 ;; | |
| 593 (let ((old-point (point-marker))) | |
| 594 (beginning-of-line) | |
| 595 (cond ((and (looking-at gnats::keyword) | |
| 596 (< old-point (match-end 0))) | |
| 597 (prog1 t | |
| 598 (if (eq where t) | |
| 599 t | |
| 600 (goto-char old-point)))) | |
| 601 (t (goto-char old-point) | |
| 602 nil)))) | |
| 603 | |
| 604 (defun gnats::forward-bofield () | |
| 605 "Moves point to the beginning of a field. Assumes that point is in the | |
| 606 keyword." | |
| 607 ;; | |
| 608 (if (re-search-forward "[ \t\n\f]+[^ \t\n\f]" (point-max) '-) | |
| 609 (backward-char) | |
| 610 t)) | |
| 611 | |
| 612 (defun gnats::backward-eofield () | |
| 613 "Moves point to the end of a field. Assumes point is in the keyword." | |
| 614 ;; | |
| 615 (if (re-search-backward "[^ \t\n\f][ \t\n\f]+" (point-min) '-) | |
| 616 (forward-char) | |
| 617 t)) | |
| 618 | |
| 619 (defun gnats::forward-eofield () | |
| 620 "Moves point to the end of a field. Assumes that point is in the field." | |
| 621 ;; | |
| 622 ;; look for the next field | |
| 623 (if (re-search-forward gnats::keyword (point-max) '-) | |
| 624 (progn (beginning-of-line) (gnats::backward-eofield)) | |
| 625 (re-search-backward "[^ \t\n\f][ \t\n\f]*" (point-min) '-) | |
| 626 (forward-char))) | |
| 627 | |
| 628 (defun gnats::backward-bofield () | |
| 629 "Moves point to the beginning of a field. Assumes that point is in the | |
| 630 field." | |
| 631 ;; | |
| 632 ;;look for previous field | |
| 633 (if (re-search-backward gnats::keyword (point-min) '-) | |
| 634 (gnats::forward-bofield) | |
| 635 t)) | |
| 636 | |
| 637 | |
| 638 (defun gnats:forward-field () | |
| 639 "Move point forward to the end of the field or to the beginning of the next | |
| 640 field." | |
| 641 ;; | |
| 642 (interactive) | |
| 643 (if (or (gnats::before-keyword t) (gnats::in-keyword t) | |
| 644 (gnats::after-keyword t)) | |
| 645 (gnats::forward-bofield) | |
| 646 (gnats::forward-eofield))) | |
| 647 | |
| 648 (defun gnats:backward-field () | |
| 649 "Move point backward to the beginning/end of a field." | |
| 650 ;; | |
| 651 (interactive) | |
| 652 (backward-char) | |
| 653 (if (or (gnats::before-keyword t) (gnats::in-keyword t) | |
| 654 (gnats::after-keyword t)) | |
| 655 (gnats::backward-eofield) | |
| 656 (gnats::backward-bofield))) | |
| 657 | |
| 658 (defun gnats:next-field () | |
| 659 "Move point to the beginning of the next field." | |
| 660 ;; | |
| 661 (interactive) | |
| 662 (if (or (gnats::before-keyword t) (gnats::in-keyword t) | |
| 663 (gnats::after-keyword t)) | |
| 664 (gnats::forward-bofield) | |
| 665 (if (re-search-forward gnats::keyword (point-max) '-) | |
| 666 (gnats::forward-bofield) | |
| 667 t))) | |
| 668 | |
| 669 (defun gnats:previous-field () | |
| 670 "Move point to the beginning of the previous field." | |
| 671 ;; | |
| 672 (interactive) | |
| 673 (backward-char) | |
| 674 (if (or (gnats::after-keyword t) (gnats::in-keyword t) | |
| 675 (gnats::before-keyword t)) | |
| 676 (progn (re-search-backward gnats::keyword (point-min) '-) | |
| 677 (gnats::forward-bofield)) | |
| 678 (gnats::backward-bofield))) | |
| 679 | |
| 680 (defun gnats:beginning-of-field () | |
| 681 "Move point to the beginning of the current field." | |
| 682 (interactive) | |
| 683 (cond ((gnats::in-keyword t) | |
| 684 (gnats::forward-bofield)) | |
| 685 ((gnats::after-keyword 0)) | |
| 686 (t | |
| 687 (gnats::backward-bofield)))) | |
| 688 | |
| 689 (defun gnats::current-field () | |
| 690 (save-excursion | |
| 691 (if (cond ((or (gnats::in-keyword t) (gnats::after-keyword t)) | |
| 692 (looking-at gnats::keyword)) | |
| 693 ((re-search-backward gnats::keyword nil t))) | |
| 694 (buffer-substring (match-beginning 1) (match-end 1)) | |
| 695 nil))) | |
| 696 | |
| 697 ;;;;--------------------------------------------------------------------------- | |
| 698 ;;;; Support functions | |
| 699 ;;;;--------------------------------------------------------------------------- | |
| 700 | |
| 701 (defun gnats::looking-after (regex) | |
| 702 "Returns t if point is after regex." | |
| 703 ;; | |
| 704 (let* ((old-point (point)) | |
| 705 (start (if (eobp) | |
| 706 old-point | |
| 707 (forward-char) (point)))) | |
| 708 (cond ((re-search-backward regex (point-min) t) | |
| 709 (goto-char old-point) | |
| 710 (cond ((eq (match-end 0) start) | |
| 711 t)))))) | |
| 712 | |
| 713 (defun gnats::nth-word (string &optional elem) | |
| 714 "Returns the elem-th word of the string. | |
| 715 If elem is nil, then the first wort is returned, if elem is 0 then | |
| 716 the whole string is returned." | |
| 717 ;; | |
| 718 (if (integerp elem) | |
| 719 (cond ((eq elem 0) string) | |
| 720 ((eq elem 1) (gnats::first-word string)) | |
| 721 ((equal string "") "") | |
| 722 ((>= elem 2) | |
| 723 (let ((i 0) (value "")) | |
| 724 (setq string ; strip leading blanks | |
| 725 (substring string (or (string-match "[^ \t]" string) 0))) | |
| 726 (while (< i elem) | |
| 727 (setq value | |
| 728 (substring string 0 | |
| 729 (string-match "[ \t]*$\\|[ \t]+" string))) | |
| 730 (setq string | |
| 731 (substring string (match-end 0))) | |
| 732 (setq i (+ i 1))) | |
| 733 value))) | |
| 734 (gnats::first-word string))) | |
| 735 | |
| 736 (defun gnats::first-word (string) | |
| 737 (setq string | |
| 738 (substring string (or (string-match "[^ \t]" string) 0))) | |
| 739 (substring string 0 (string-match "[ \t]*$\\|[ \t]+" string))) | |
| 740 | |
| 741 ;;;;--------------------------------------------------------------------------- | |
| 742 | |
| 743 (defun gnats::patch-exec-path () | |
| 744 ;; | |
| 745 "Replaces `//' by `/' in `exec-path'." | |
| 746 ;; | |
| 747 ;(make-local-variable 'exec-path) | |
| 748 (let ((err-buffer (get-buffer-create " *gnats::patch-exec-path*")) | |
| 749 (ret)) | |
| 750 (setq exec-path (save-excursion (set-buffer err-buffer) | |
| 751 (prin1 exec-path err-buffer) | |
| 752 (goto-char (point-min)) | |
| 753 (while (search-forward "//" nil t) | |
| 754 (replace-match "/" nil t)) | |
| 755 (goto-char (point-min)) | |
| 756 (setq ret (read err-buffer)) | |
| 757 (kill-buffer err-buffer) | |
| 758 ret | |
| 759 )))) | |
| 760 | |
| 761 (defun gnats::get-value-from-shell (&rest command) | |
| 762 "Execute shell command to get a list of valid values for `variable'." | |
| 763 ;; | |
| 764 (let ((err-buffer (get-buffer-create " *gnats::get-value-from-shell*"))) | |
| 765 (save-excursion | |
| 766 (set-buffer err-buffer) | |
| 767 (unwind-protect | |
| 768 (condition-case var | |
| 769 (progn | |
| 770 (apply 'call-process | |
| 771 (car command) nil err-buffer nil (cdr command)) | |
| 772 (goto-char (point-min)) | |
| 773 (if (looking-at "[-a-z]+: ") | |
| 774 (error (buffer-substring (point-min) (point-max)))) | |
| 775 (read err-buffer)) | |
| 776 (error nil)) | |
| 777 (kill-buffer err-buffer))))) | |
| 778 | |
| 779 (or (fboundp 'setenv) | |
| 780 (defun setenv (variable &optional value) | |
| 781 "Set the value of the environment variable named VARIABLE to VALUE. | |
| 782 VARIABLE should be a string. VALUE is optional; if not provided or is | |
| 783 `nil', the environment variable VARIABLE will be removed. | |
| 784 This function works by modifying `process-environment'." | |
| 785 (interactive "sSet environment variable: \nsSet %s to value: ") | |
| 786 (if (string-match "=" variable) | |
| 787 (error "Environment variable name `%s' contains `='" variable) | |
| 788 (let ((pattern (concat "\\`" (regexp-quote (concat variable "=")))) | |
| 789 (case-fold-search nil) | |
| 790 (scan process-environment)) | |
| 791 (while scan | |
| 792 (cond | |
| 793 ((string-match pattern (car scan)) | |
| 794 (if (eq nil value) | |
| 795 (setq process-environment (delq (car scan) | |
| 796 process-environment)) | |
| 797 (setcar scan (concat variable "=" value))) | |
| 798 (setq scan nil)) | |
| 799 ((null (setq scan (cdr scan))) | |
| 800 (setq process-environment | |
| 801 (cons (concat variable "=" value) | |
| 802 process-environment))))))))) | |
| 803 | |
| 804 ;;;; end of send-pr.el |