cgit.sxemacs.org Git - packages/blob - xemacs-packages/gnats/gnats-admin.el

   1 ;; gnats administration code
   2 ;; display the pr's in a buffer,
   3 ;; dired-style commands to edit & view them.
   4
   5 ;; this version is known to work in XEmacs.
   6
   7 ;; author: Roger Hayes, roger.hayes@sun.com
   8
   9 ;; copyright: You are welcome to use this software as you see fit.
  10 ;; Neither the author nor his employer make any representation about
  11 ;; the suitability of this software for any purpose whatsoever.
  12
  13 (defconst gnats-admin-copyright
  14 "Copyright (c) 1996 Roger Hayes.
  15
  16 Permission to use, copy, modify and distribute this software and
  17 documentation for any purpose and without fee is hereby granted in
  18 perpetuity, provided that this COPYRIGHT AND LICENSE NOTICE appears in
  19 its entirety in all copies of the software and supporting
  20 documentation.
  21
  22 The names of the author or Sun Microsystems, Inc. shall not be used in
  23 advertising or publicity pertaining to distribution of the software
  24 and documentation without specific, written prior permission.
  25
  26 ANY USE OF THE SOFTWARE AND DOCUMENTATION SHALL BE GOVERNED BY
  27 CALIFORNIA LAW.  THE AUTHOR AND SUN MICROSYSTEMS, INC. MAKE NO
  28 REPRESENTATIONS OR WARRANTIES ABOUT THE SUITABILITY OF THE SOFTWARE OR
  29 DOCUMENTATION FOR ANY PURPOSE.  THEY ARE PROVIDED *AS IS* WITHOUT
  30 EXPRESS OR IMPLIED WARRANTY OF ANY KIND.  THE AUTHOR AND SUN
  31 MICROSYSTEMS, INC. SEVERALLY AND INDIVIDUALLY DISCLAIM ALL WARRANTIES
  32 WITH REGARD TO THIS SOFTWARE AND DOCUMENTATION, INCLUDING THE
  33 WARRANTIES OF MERCHANTABILITY, DESIGN, FITNESS FOR A PARTICULAR
  34 PURPOSE AND NON-INFRINGEMENT OF THIRD PARTY RIGHTS. IN NO EVENT SHALL
  35 THE AUTHOR OR SUN MICROSYSTEMS, INC. BE LIABLE FOR ANY SPECIAL,
  36 INDIRECT, INCIDENTAL OR CONSEQUENTIAL DAMAGES, OR ANY DAMAGES
  37 WHATSOEVER RESULTING FROM LOSS OF USE, DATA, OR PROFITS, WHETHER IN
  38 ACTION ARISING OUT OF CONTRACT, NEGLIGENCE, PRODUCT LIABILITY, OR
  39 OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
  40 PERFORMANCE OF THIS SOFTWARE OR DOCUMENTATION."
  41
  42 "Copyright and disclaimer notice")
  43
  44 ;; magic words are highlighted using font-lock
  45
  46 ;; data structures: a pr is represented as an alist
  47 ;; the list of known pr's is represented as a vector
  48 ;; pr references are often done by number
  49 ;; (pr N) takes either a number, and returns the pr assoc list,
  50 ;; or the pr assoc list, returning the same.
  51 ;; regions are tagged with the number of the pr; the indirection lets
  52 ;; updates to pr's happen without disturbing the region.
  53
  54 (defvar pr-list nil "Vector of parsed problem reports.")
  55
  56 (require 'cl)
  57
  58 ;;; (require 'match-string)
  59 ;;; inline match-string
  60 (if (not (fboundp 'match-string))
  61     (defun match-string (n &optional target)
  62       "Return the text of the NTH match in optional TARGET."
  63       (let* ((m-data (match-data))
  64              (idx       (* 2 n))
  65              (m-beg (elt m-data idx))
  66              (m-end (elt m-data (1+ idx))))
  67         (cond
  68          ((markerp m-beg)
  69           (buffer-substring m-beg m-end))
  70          ((integerp m-beg)
  71           (substring target m-beg m-end))
  72          (t
  73           (error "Bad argument N to match-string"))))))
  74
  75 ;;; (require 'edit-expr)
  76 ;; edit-expr -- pop up a buffer to edit an expression
  77 (if (not (fboundp 'edit-expr))
  78     (defun edit-expr (e &optional explain)
  79       "Pop up a buffer to edit the EXPRESSION; return the edited value.
  80 Buffer gets optional EXPLANATION."
  81       (with-output-to-temp-buffer "*expr-buffer*"
  82         (let ((buffer standard-output)
  83               (val nil)
  84               emark)
  85
  86           (save-excursion
  87             (pop-to-buffer (buffer-name buffer))
  88             (emacs-lisp-mode)
  89             (delete-region (point-min) (point-max))
  90             (insert (or explain ";; Edit this value"))
  91             (insert "\n")
  92             (setq emark (point-marker))
  93             (prin1 e)
  94             (goto-char emark)
  95             (message "recursive edit -- M-C-c when done")
  96             (recursive-edit)
  97             (goto-char emark)
  98             (setq val (read buffer)))
  99           val))))
 100
 101 ;; (require 'regret)    ;; creates regression tests in my environment [rh]
 102
 103 (provide 'gnats-admin)
 104
 105 ;; add stuff for font-lock; harmless if you don't use font-lock.
 106 ;; beware -- font-lock uses the first match; hence longer words must
 107 ;; precede shorter words, if they both match.
 108 (defconst gnats-admin::font-lock-keywords
 109   '(;; severity
 110     ("non-critical" . non-critical)
 111     ("critical" . critical)
 112     ("serious" .  serious)
 113
 114     ;; priority
 115     ("high" . high)
 116     ("medium" . medium)
 117     ("low" . low)
 118
 119     ;; state
 120     ("open" . open)
 121     ("analyzed" . analyzed)
 122     ("suspended" . suspended)
 123     ("feedback" . feedback)
 124     ("closed\\*" . closed*)
 125     ("closed\\?" . closed?)
 126     ("closed" . closed)
 127
 128     ;; class
 129     ("sw-bug" . sw-bug)
 130     ("doc-bug" . doc-bug)
 131     ("support" . support)
 132     ("change-request" . change-request)
 133     ("mistaken" . mistaken)
 134     ("duplicate" . duplicate)))
 135
 136 (defvar gnats-admin::popup-menu
 137   '("Gnats-Admin"
 138     ["Edit"     'gnats-admin:pr-edit t]
 139     ["View"     'gnats-admin:pr-view t]
 140     )
 141   "Local popup menu.")
 142
 143 (defvar gnats-admin-query-hook nil
 144   "Hooklist for post-query processing in gnats-admin mode.")
 145 (defvar gnats-admin:query-list nil
 146   "Results of one query -- may be altered by query hook to change results of query.")
 147 (defvar gnats-admin-refresh-hook nil
 148   "Hooklist for post-refresh processing in gnats-admin mode.
 149 Run after a refresh -- gnats-admin::dirty-list may contain list of re-read pr numbers")
 150
 151 (defvar gnats-admin::selector nil
 152   "Function of one argument that governs if a PR should be displayed.")
 153
 154 (add-hook 'gnats-admin-refresh-hook
 155           (function (lambda ()
 156                       (font-lock-fontify-buffer))))
 157
 158 ;;;
 159 ;; first, how do we get & parse the pr's?
 160 (defun gnats-admin::run-query ()
 161   "Run a default query, setting pr-list to the result."
 162   (setq pr-list (apply 'vector (gnats-admin::query)))
 163   (length pr-list))
 164
 165 (defun trim (s)
 166   "trim the leading & trailing blanks from a string"
 167   (if (string-match "^\\s-*\\(\\S-.*\\S-\\|\\S-\\)\\s-*$" s)
 168       (substring s (match-beginning 1) (match-end 1))
 169     "")
 170   )
 171
 172 ;; parse one pr -- moves point.
 173 (defun gnats-admin::parse-pr ()
 174   "parse one pr, moving point"
 175   (let ((pr nil))
 176     (let ((flv (make-vector 13 nil))
 177           (lim 0)
 178           (bol 0)
 179           (index 0))
 180       (end-of-line)
 181       (setq lim (point))
 182       (beginning-of-line)
 183       (setq bol (point))
 184       (while (and (< (point) lim)
 185                   (re-search-forward "\\([^|]*\\)|" lim t))
 186         (aset flv index (trim (match-string 1)))
 187         (setq index (1+ index)))
 188       (if (not (= index 13))
 189           (error "Bad PR inquiry: %s" (buffer-substring bol lim)))
 190       (setq pr (gnats-admin::vec->pr flv)))
 191     (if (not (bolp))
 192         (forward-line 1))
 193     pr))
 194
 195 (defun gnats-admin::query (&rest args)
 196   (let ((prl (list))
 197         (buf (get-buffer-create "**gnats-query*")))
 198     (save-excursion
 199       (set-buffer buf)
 200       (delete-region (point-min) (point-max))
 201       (message "Running query")
 202       (setq args
 203             (mapcar (function (lambda (x) (format "%s" x))) args))
 204       (apply 'call-process "query-pr" nil t nil "--sql" args)
 205       (message "Query completed")
 206       ;; now parse the output
 207       (goto-char (point-min))
 208       (while (not (eobp))
 209         (setq prl (cons (gnats-admin::parse-pr) prl)))
 210       )
 211     (message "Result parsed")
 212     ;; lots of stuff to apply the proper hook
 213     (setq gnats-admin:query-list prl)
 214     (run-hooks 'gnats-admin-query-hook)
 215     (setq prl gnats-admin:query-list)
 216     (setq gnats-admin:query-list nil)
 217     (nreverse prl)))
 218
 219 ;;
 220 ;;
 221 (defun gnats-admin::vec->pr (v)
 222   "massage a 13-element vector into the internal pr representation.
 223 fields are as described in query-pr documentation."
 224   (if (not (and (vectorp v)
 225                 (= (length v) 13)))
 226       (error "Not a valid PR intermediate form"))
 227
 228   ;;; 0 - pr number
 229   (aset v 0 (read (aref v 0)))
 230   ;;; 1 - category
 231   (aset v 1 (read (aref v 1)))
 232   ;;; 2 - synopsis
 233   ; leave as string
 234   ;;; 3 - confidential
 235   (aset v 3 (if (equal "no" (aref v 3)) nil (aref v 3)))
 236   ;;; 4 - severity
 237   (let ((num (read (aref v 4))))
 238     (aset v 4 (aref
 239                [null critical serious non-critical]
 240                num)))
 241   ;;; 5 - priority
 242   (let ((num (read (aref v 5))))
 243     (aset v 5 (aref
 244                [null high medium low]
 245                num)))
 246   ;;; 6 - responsible
 247   ; leave as string
 248   ;;; 7 - state
 249   (let ((num (read (aref v 7))))
 250     (aset v 7 (aref
 251                [null open analyzed suspended feedback closed]
 252                num)))
 253   ;;; 8 - class
 254   (let ((num (read (aref v 8))))
 255     (aset v 8 (aref
 256                [null sw-bug doc-bug support change-request mistaken duplicate]
 257                num)))
 258   ;;; 9 - submitter-id
 259   ; leave as string
 260   ;;; 10 - arrival-date
 261   ; leave as string
 262   ;;; 11 - originator
 263   ; leave as string
 264   ;;; 12 - release
 265   ; leave as string
 266
 267   ;; the fields of v have been transformed; now map them into an alist
 268   (do
 269       ((vx 0 (1+ vx))                   ; v index
 270        (an                              ; field names (in order!)
 271         (gnats-admin::pr-field-names)
 272         (cdr an))
 273        (al nil)                         ; assoc list
 274        )
 275       ((null an) (nreverse al))         ; <- here's where the result comes from
 276     (setq al (cons (cons (car an) (aref v vx)) al))
 277     ))
 278
 279 (defun gnats-admin::pr-get (pr field)
 280   "Get, from PR, value of slot named FIELD (a symbol)."
 281   (let ((p (assq field (gnats-admin:pr pr))))
 282     (if p
 283         (cdr p)
 284       nil)))
 285
 286 (defun nset-assq (alist key val)
 287   "destructively set key'v association in the alist to val.  returns the original
 288 list, unless it was null"
 289   (let ((p (assq key alist)))
 290     (if p
 291         (progn
 292           (setcdr p val)
 293           alist)
 294       (nconc alist (list (cons key val))))))
 295
 296 (defun gnats-admin::pr-set! (pr field val)
 297   "Set, in PR, slot named FIELD to VAL.  Slot name is a symbol."
 298   (nset-assq pr field val))
 299
 300 ;; fast version of field name->index mapper
 301 ;; also tests if a symbol is a field name present in sql report.
 302 (defun gnats-admin::pr-field-index (feild)
 303   (case feild
 304     (Number 0)
 305     (Category 1)
 306     (Synopsis 2)
 307     (Confidential  3)
 308     (Severity  4)
 309     (Priority 5)
 310     (Responsible 6)
 311     (State 7)
 312     (Class 8)
 313     (Submitter-Id 9)
 314     (Arrival-Date 10)
 315     (Originator 11)
 316     (Release 12)))
 317
 318 ;; next is for completing-read
 319 ;; order must be the same as indices
 320 ;; content is (name index type width)
 321 ;; width is field width, not counting space
 322 (defconst gnats-admin::pr-field-alist
 323   '(("Number" 0 integer 3)
 324     ("Category" 1 symbol 15)
 325     ("Synopsis" 2 string 80)
 326     ("Confidential"  3 boolean 1)
 327     ("Severity"  4 symbol 12)
 328     ("Priority" 5 symbol 6)
 329     ("Responsible" 6 string 7)
 330     ("State" 7 symbol 8)
 331     ("Class" 8 symbol 14)
 332     ("Submitter-Id" 9 string 7)
 333     ("Arrival-Date" 10 string 14)
 334     ("Originator" 11 string 32)
 335     ("Release" 12 string 48))
 336   "Alist that maps field-name->(name index type width)")
 337
 338 (defun gnats-admin::pr-field-names ()
 339   "List of symbols that are field keys in pr.  Must be in order."
 340   (mapcar (function (lambda (pr) (intern (car pr))))
 341           gnats-admin::pr-field-alist))
 342
 343 ;; format control template for PR display
 344 (defconst gnats-admin::pr-long-format
 345   '((4 Category Class) (35 Priority Severity) (60 Responsible) (70 State ) nl
 346     4 "Synopsis:" Synopsis
 347     ))
 348 (defconst gnats-admin::pr-short-format
 349   '((4 Category Class) (35 Priority Severity) (60 Responsible) (70 State )))
 350
 351 (defvar gnats-admin::pr-format gnats-admin::pr-short-format
 352   "Format list for printing a pr.")
 353
 354 ;; hook that sets extent etc for XEmacs
 355 (defun gnats-admin::pr-display-hook (b e pr buf)
 356   "Set extent around pr."
 357   (let ((ext (make-extent b e buf)))
 358     (set-extent-begin-glyph-layout ext 'outside-margin)
 359     (set-extent-property ext 'pr pr)
 360     (set-extent-property ext 'start-open t)
 361     (set-extent-property ext 'end-open t)
 362     (set-extent-property ext 'highlight t)))
 363
 364 ;; gnats uses one face for each element of the enumerated fields,
 365 ;; to give maximum flexibility in display.
 366
 367 ;;; symbol->(face foreground background) alist
 368 (defvar gnats-admin::face-color
 369   '((critical "firebrick" nil)
 370     (serious "goldenrod" nil)
 371     (non-critical "blue3" nil)
 372
 373     (high "firebrick" nil)
 374     (medium "goldenrod" nil)
 375     (low "blue3" nil)
 376
 377     (open "firebrick" nil)
 378     (analyzed "goldenrod" nil)
 379     (suspended "turquoise" nil)
 380     (feedback "blue3" nil)
 381     (closed "ForestGreen" nil)
 382     (closed* "HotPink" nil)
 383     (closed? "blue3" nil)
 384
 385     (sw-bug nil nil)
 386     (doc-bug nil nil)
 387     (support nil nil)
 388     (change-request nil nil)
 389     (mistaken nil nil)
 390     (duplicate nil nil))
 391   "Alist of font properties")
 392
 393 (defun gnats-admin::field-display (pr fld buf)
 394   "Display value field on specified stream."
 395   (let
 396       ((fv (gnats-admin::pr-get pr fld)))
 397     (princ fv buf)))
 398
 399 (defun gnats-admin::pr-print-func (f pr buf)
 400   "Printer for pr.  Depends on free variable pr-did-indent."
 401   (cond
 402    ((eq 'nl f)
 403     (princ "\n " buf)
 404     (setq pr-did-indent t))
 405    ((listp f)
 406     (do
 407         ((fmt f (cdr fmt)))
 408         ((null fmt))
 409       (gnats-admin::pr-print-func (car fmt) pr buf)))
 410    ((numberp f)
 411     (indent-to-column f 1)
 412     (setq pr-did-indent t))
 413    ((symbolp f)
 414     (if (not pr-did-indent)
 415         (princ " " buf))
 416     (gnats-admin::field-display pr f buf)
 417     (setq pr-did-indent nil))
 418    ((stringp f)
 419     (if (not pr-did-indent)
 420         (princ " " buf))
 421     (princ f buf)
 422     (setq pr-did-indent nil))
 423    )
 424   t)
 425
 426 (defun gnats-admin::display-pr (pr &optional buf)
 427   ;; always print the number first
 428   (if (not buf)
 429       (setq buf (current-buffer)))
 430   (let
 431       ((b (point))
 432        (buffer-read-only nil)
 433        (pr-did-indent nil))
 434     (princ (gnats-admin::pr-number pr) buf)
 435     ;; now print according to the pr-format list
 436     (do
 437         ((fmt gnats-admin::pr-format (cdr fmt)))
 438         ((null fmt))
 439       (gnats-admin::pr-print-func (car fmt) pr buf))
 440     (gnats-admin::pr-display-hook
 441      b
 442      (point)
 443      (gnats-admin::pr-number pr)
 444      buf)
 445     (newline)))
 446
 447 (defun gnats-admin::pr-buffer-extent (pr)
 448   "Find the extent for this PR."
 449   (extent-at (1+ (gnats-admin::pr-buffer-begin pr))
 450              (gnats-admin::pr-buffer pr)
 451              'pr))
 452
 453 (defun gnats-admin::pr-reread (pr)
 454   "Rerun query for one PR in the pr-list."
 455   (let
 456       ((num (gnats-admin::pr-number pr)))
 457     (let
 458         ((repl (gnats-admin::query num)))
 459       (if (and (listp repl)
 460                (= (length repl) 1)
 461                (= (gnats-admin::pr-get (car repl) 'Number) num))
 462           (gnats-admin::pr-replace! num (car repl))
 463         (error "Query failed for pr %s" num)))
 464     ))
 465
 466 (defun gnats-admin::selection (loprs)
 467   "Return the elements of LOPRS (list of PR's) which satisfy PREDicate."
 468   (let ((pred gnats-admin::selector))
 469     (if (not pred)
 470         loprs
 471       ;; else use the common-lisp loop appropriate to the type of loprs
 472       (cond
 473        ((arrayp loprs)
 474         (loop
 475          for pr across loprs
 476          if (apply pred pr '())
 477            collect pr
 478          ))
 479        ((listp loprs)
 480         (loop
 481          for pr in loprs
 482          if (apply pred pr '())
 483            collect pr
 484          ))
 485        (t
 486         (error "Bad type for PR collection")))
 487       )))
 488
 489 (defun gnats-admin::selected? (pr)
 490   "Test to see if one pr meets the selection criterion."
 491   (or (null gnats-admin::selector)
 492       (apply gnats-admin::selector pr '())))
 493
 494 (defun gnats-admin::pr-replace! (oldpr newpr)
 495   "Replace the old pr with the new one"
 496   (if (not (consp newpr))
 497       (error "Replacement pr must be a full PR value"))
 498   (let ((pr-num (gnats-admin::pr-number newpr)))
 499     (if (not (= (gnats-admin::pr-number oldpr)
 500                 pr-num))
 501         (error "Cannot replace PR with one of different number"))
 502     (if (< (length pr-list) pr-num)
 503         (setq pr-list
 504               (vconcat pr-list (make-vector (- pr-num (length pr-list)) nil))))
 505     (aset pr-list (1- pr-num) newpr)))
 506
 507 (defvar gnats-admin::dirty-list nil
 508   "List of PRs which may be out of date and need refreshing.")
 509
 510 (defun gnats-admin:reset ()
 511   "Reset the cached data for gnats-admin."
 512   (setq pr-list nil)
 513   (setq gnats-admin::dirty-list nil)    ; it's everything now
 514   )
 515
 516 (defun gnats-admin:regret ()
 517   "Create or edit the regression test for the current problem report."
 518   (interactive)
 519   (let* ((pr (gnats-admin::pr-at (point)))
 520          (num (gnats-admin::pr-number pr)))
 521     (pr-regret num)))
 522
 523 (defun gnats-admin:refresh (&optional force)
 524   (interactive "P")
 525   (if force
 526       (gnats-admin:reset))
 527   (if (not pr-list)
 528       (progn
 529         (gnats-admin::run-query))
 530     (progn
 531       (mapc (function (lambda (p) (gnats-admin::pr-reread p)))
 532             gnats-admin::dirty-list)))
 533   (setq gnats-admin::dirty-list nil)
 534   (set-buffer (gnats-admin::buffer))
 535   (let ((standard-output (current-buffer))
 536         (buffer-read-only nil)
 537         (this-pr-num (gnats-admin::pr-num-at (point))))
 538     ; is this overkill; could we save our extents unless force?
 539     (if nil
 540         (map-extents (function (lambda (ext data) (delete-extent ext) nil))
 541                      (current-buffer)))
 542     (delete-region (point-min) (point-max))
 543     (beginning-of-buffer)
 544     (message "Redisplay")
 545     (mapc (function (lambda (pr)
 546                       (if (gnats-admin::selected? pr)
 547                           (gnats-admin::display-pr pr))))
 548           pr-list)
 549     (message nil)
 550     ;; catch search errors in case the current pr no longer exists--
 551     ;; if so, go to end of buffer
 552     (condition-case err
 553         (if (numberp this-pr-num)
 554             (gnats-admin:goto-pr this-pr-num))
 555       (search-failed
 556        (goto-char (point-max)))))
 557   (run-hooks 'gnats-admin-refresh-hook)
 558   t)
 559
 560 (defun gnats-admin::pr-number (pr)
 561   "Get the number of this pr -- which can be either a pr datum or a number."
 562   (or (and (numberp pr) pr)
 563       (gnats-admin::pr-get pr 'Number)))
 564
 565 ;; this must not depend on pr-at, because that depends on this.
 566 (defun gnats-admin::pr-num-at (pos)
 567   "Find the pr number for the pr at POS"
 568   (let*
 569       ((ext (extent-at pos nil 'pr))
 570        (pr-prop (and ext (extent-property ext 'pr))))
 571     (if pr-prop
 572         (gnats-admin::pr-number pr-prop)
 573       (save-excursion
 574         (goto-char pos)
 575         (if (not (looking-at "^\\s-*[0-9]"))
 576             (backward-paragraph))
 577         (if (looking-at "\\s-*[0-9]+[^0-9]")
 578             (read (match-string 0))
 579           nil)))))
 580
 581 (defun gnats-admin::pr-by-number (num)
 582   "Find the pr numbered N."
 583   ;; first try the easy way
 584   (let
 585       ((pr (elt pr-list (1- num))))
 586     (if (and pr (= num (gnats-admin::pr-number pr)))
 587         pr
 588       ;; easy way didnt work; scan the list
 589       (loop
 590        for prx across pr-list
 591        if (= num (gnats-admin::pr-number prx))
 592        return prx))))
 593
 594 ;; use face alist to set face colors
 595 (defun gnats-admin::setup-faces ()
 596   "Set up the faces for gnats admin mode."
 597   (mapc
 598    (function (lambda (l) (make-face (car l))))
 599    gnats-admin::face-color)
 600   (if (memq (device-class) '(color grayscale))
 601       (mapc
 602        (function (lambda (l)
 603                    (if (cadr l)
 604                        (set-face-foreground (car l) (cadr l)))
 605                    (if (caddr l)
 606                        (set-face-background (car l) (caddr l)))))
 607        gnats-admin::face-color))
 608   (setq font-lock-keywords gnats-admin::font-lock-keywords)
 609   ;; this is too slow -- instead, do explicit fontification after modify
 610   ; (turn-on-font-lock)
 611   )
 612
 613 (defvar gnats-admin::pr-mark-glyph nil
 614   "Glyph used to mark the current PR in display.")
 615
 616 (defun gnats-admin::buffer ()
 617   "Find or create gnats admin buffer."
 618   (or (get-buffer "*gnats*")
 619       (let ((buf (get-buffer-create "*gnats*")))
 620         (set-buffer buf)
 621         (make-local-variable 'paragraph-start)
 622         (make-local-variable 'paragraph-separate)
 623         (setq paragraph-start "^\\(\\S-\\|[ \t\n]*$\\)")
 624         (setq paragraph-separate "^[ \t\n]*$")
 625         (setq buffer-read-only t)
 626         (setq buffer-undo-list t)               ; disable undo info
 627         (setq gnats-admin::pr-mark-glyph (make-pixmap "target"))
 628         (gnats-admin::setup-faces)
 629         buf)
 630       ))
 631
 632 (defun gnats-admin:pr (pr-or-num)
 633   "If PR-OR-NUM is a pr, return it; if it's a number,
 634 return the pr with that number."
 635   (cond
 636    ((numberp pr-or-num)
 637     (gnats-admin::pr-by-number pr-or-num))
 638    ((consp pr-or-num)
 639     pr-or-num)
 640    (t
 641     (error "Not a valid PR: %s" pr-or-num))
 642    ))
 643
 644 (defun gnats-admin::pr-at (pos)
 645   "PR at POSITION"
 646   (or
 647    (let ((ext (extent-at pos nil 'pr)))
 648      (if ext (extent-property ext 'pr)))
 649    (gnats-admin::pr-num-at pos)))
 650
 651 ;; next should, ideally, run a 1-pr query then splice that into
 652 ;; pr-list to update the current pr.
 653 ;; however, there's a race condition with gnats; so put the edited
 654 ;; pr on the dirty list to be inquired later.
 655 (defun gnats-admin:pr-edit ()
 656   (interactive)
 657   (let*
 658       ((pr (gnats-admin::pr-at (point)))
 659        (num (gnats-admin::pr-number pr))
 660        (num-str (format "%d" num)))
 661     (pr-edit num-str)
 662     (setq gnats-admin::dirty-list (cons pr gnats-admin::dirty-list))))
 663
 664 (defun gnats-admin:pr-view ()
 665   (interactive)
 666   (pr-view (format "%d" (gnats-admin::pr-num-at (point)))))
 667 (defun gnats-admin:pr-synopsis ()
 668   (interactive)
 669   (let*
 670       ((pr (gnats-admin::pr-at (point)))
 671        (syn (gnats-admin::pr-get pr 'Synopsis)))
 672     (message "Synopsis: %s" syn)))
 673
 674 (defun gnats-admin:pr-originator ()
 675   (interactive)
 676   (let*
 677       ((pr (gnats-admin::pr-at (point)))
 678        (syn (gnats-admin::pr-get pr 'Originator)))
 679     (message "Originator: %s" syn)))
 680
 681 (defun gnats-admin:pr-field (fld)
 682   "Show any pr field FLD of current pr."
 683   (interactive
 684    (list (completing-read "Field: " gnats-admin::pr-field-alist
 685                            nil t)))
 686   (let*
 687       ((pr (gnats-admin::pr-at (point)))
 688        (val (gnats-admin::pr-get pr (intern fld))))
 689     (message "%s: %s" fld val)))
 690
 691 (defvar gnats-admin::current-pr nil "Current pr")
 692 (defun gnats-admin::highlight (pr)
 693   "Hilight the current PR -- may unhilight the previous."
 694   (condition-case err
 695       (progn
 696         (if gnats-admin::current-pr
 697             (highlight-extent
 698              (gnats-admin::pr-buffer-extent gnats-admin::current-pr)
 699              nil))
 700         (highlight-extent (gnats-admin::pr-buffer-extent pr) t)
 701         (setq gnats-admin::current-pr pr))
 702     (error (setq gnats-admin::current-pr nil))))
 703
 704 (defun gnats-admin::highlight-point ()
 705   "Highlight the pr at point"
 706   ;; make point visible
 707   (or
 708    (pos-visible-in-window-p)
 709    (recenter '(t)))
 710   (gnats-admin::highlight (gnats-admin::pr-at (point))))
 711
 712 (defun gnats-admin:next ()
 713   "Next pr"
 714   (interactive)
 715   (forward-paragraph)
 716   (gnats-admin::highlight-point))
 717 (defun gnats-admin:prev ()
 718   "Prev pr."
 719   (interactive)
 720   (backward-paragraph)
 721   (gnats-admin::highlight-point))
 722 (defun gnats-admin:this ()
 723   "Activate pr at point."
 724   (interactive)
 725   (end-of-line)
 726   (backward-paragraph)
 727   (gnats-admin::highlight-point))
 728
 729 (defun gnats-admin:mouse-set (ev)
 730   (interactive "e")
 731   (mouse-set-point ev)
 732   (gnats-admin::highlight-point))
 733
 734 (defun gnats-admin:mouse-synopsis (ev)
 735   (interactive "e")
 736   (gnats-admin:mouse-set ev)
 737   (gnats-admin:pr-synopsis))
 738
 739 (defun gnats-admin:mouse-menu (ev)
 740   (interactive "e")
 741   (gnats-admin:mouse-set ev)
 742   (popup-mode-menu))
 743
 744 (defun gnats-admin:refresh-this-pr ()
 745   "Reread and refresh the display of the current PR."
 746   (interactive)
 747   (let* ((pr (gnats-admin::pr-at (point)))
 748          (buffer-read-only nil)
 749          (b (gnats-admin::pr-buffer-begin pr))
 750          (e (gnats-admin::pr-buffer-end pr)))
 751     (goto-char b)
 752     (save-excursion
 753       (gnats-admin::pr-buffer-delete pr)
 754       (gnats-admin::pr-reread pr)
 755       (gnats-admin::display-pr pr (current-buffer))
 756       ;; had to dive pretty deep into font-lock to get this one...
 757       (let ((font-lock-mode t))
 758         (font-lock-after-change-function b e 1)))
 759     (gnats-admin::highlight-point)))
 760
 761 (defun gnats-admin:goto-pr (n)
 762   "Make pr number N the current pr."
 763   (interactive "nPR: ")
 764   (goto-char (gnats-admin::pr-n-pos n))
 765   (gnats-admin::highlight-point))
 766
 767 (defun gnats-admin::pr-n-pos (n)
 768   "Find the buffer position of pr numbered N in current buffer."
 769   (save-excursion
 770     (goto-char (point-min))
 771     (let ((re (format "^%s\\s-" n)))
 772       (re-search-forward re)
 773       (point)
 774       )))
 775
 776 (defun gnats-admin::pr-buffer-delete (pr)
 777   "Delete the display of the PR."
 778   (let* ((b (gnats-admin::pr-buffer-begin pr))
 779          (e (gnats-admin::pr-buffer-end pr))
 780          (mbuf (gnats-admin::pr-buffer pr))
 781          (pr-ext (gnats-admin::pr-buffer-extent pr)))
 782     (set-buffer mbuf)
 783     (let ((buffer-read-only nil))
 784       (delete-region b e)
 785       (if (extentp pr-ext)
 786           (delete-extent pr-ext)))
 787     ))
 788
 789 (defun gnats-admin:quit ()
 790   "Quit out of gnats admin mode."
 791   (interactive)
 792   (if (get-buffer "**gnats-query*")
 793       (kill-buffer "**gnats-query*"))
 794   (kill-buffer nil))
 795
 796 (defvar gnats-admin-mode-map nil "Key map for gnats admin mode.")
 797
 798 (defun gnats-admin::setup-keymap ()
 799   (if (not (keymapp gnats-admin-mode-map))
 800       (progn
 801         (setq gnats-admin-mode-map (make-keymap))
 802         (suppress-keymap gnats-admin-mode-map)
 803         (define-key gnats-admin-mode-map "e" 'gnats-admin:pr-edit)
 804         (define-key gnats-admin-mode-map "v" 'gnats-admin:pr-view)
 805         (define-key gnats-admin-mode-map "s" 'gnats-admin:pr-synopsis)
 806         (define-key gnats-admin-mode-map "o" 'gnats-admin:pr-originator)
 807         (define-key gnats-admin-mode-map "f" 'gnats-admin:pr-field)
 808         (define-key gnats-admin-mode-map "\C-l" 'gnats-admin:refresh)
 809         (define-key gnats-admin-mode-map "n" 'gnats-admin:next)
 810         (define-key gnats-admin-mode-map "p" 'gnats-admin:prev)
 811         (define-key gnats-admin-mode-map " " 'gnats-admin:this)
 812         (define-key gnats-admin-mode-map "q" 'gnats-admin:quit)
 813         (define-key gnats-admin-mode-map "g" 'gnats-admin:goto-pr)
 814         (define-key gnats-admin-mode-map "r" 'gnats-admin:refresh-this-pr)
 815         (define-key gnats-admin-mode-map "S" 'gnats-admin:edit-selection)
 816         (define-key gnats-admin-mode-map "R" 'gnats-admin:regret)
 817         (define-key gnats-admin-mode-map 'button1 'gnats-admin:mouse-set)
 818         (define-key gnats-admin-mode-map 'button2 'gnats-admin:mouse-synopsis)
 819         (define-key gnats-admin-mode-map 'button3 'gnats-admin:mouse-menu)
 820         ))
 821   )
 822
 823 (defun gnats-admin-mode ()
 824   "Major mode for looking at a summary of gnats reports.
 825 Stomps to gnats admin buffer!
 826 Commands: \\{gnats-admin-mode-map}."
 827   (interactive)
 828   (switch-to-buffer (gnats-admin::buffer))
 829   (setq major-mode 'gnats-admin-mode)
 830   (setq mode-name "Gnats Admin")
 831   (gnats-admin::setup-keymap)
 832   (use-local-map gnats-admin-mode-map)
 833   (setq mode-popup-menu gnats-admin::popup-menu)
 834   (gnats-admin:refresh)
 835   )
 836
 837 (put 'gnats-admin-mode 'mode-class 'special)
 838
 839 (defvar gnats-admin::pr-mark-glyph nil "marker for current PR.")
 840
 841 (defun gnats-admin::pr-buffer (pr)
 842   "The buffer in which this pr is displayed."
 843   (gnats-admin::buffer))
 844
 845 (defun gnats-admin::pr-buffer-begin (pr)
 846   "Return the position of beginning of this PR."
 847   (let
 848       ((pr-num (gnats-admin::pr-number pr)))
 849     (save-excursion
 850       (set-buffer (gnats-admin::pr-buffer pr))
 851       ;; first try locally, then thru whole buffer
 852       (or
 853        (and (progn (backward-paragraph 1)
 854                    (re-search-forward (format "^%d " pr-num) nil t))
 855             (progn
 856               (beginning-of-line 1)
 857               (point)))
 858        (and (progn (goto-char (point-min))
 859                    (re-search-forward (format "^%d " pr-num) nil t))
 860             (progn
 861               (beginning-of-line 1)
 862               (point)))))))
 863
 864 (defun gnats-admin::pr-buffer-end (pr)
 865   "Return the position of the end of the PR."
 866   (save-excursion
 867     (set-buffer (gnats-admin::pr-buffer pr))
 868     (goto-char (gnats-admin::pr-buffer-begin pr))
 869     (forward-paragraph 1)
 870     (point)))
 871
 872 (defun gnats-admin::unclosed (pr)
 873   "A selector that chooses unclosed PR's."
 874   (not (eq 'closed (gnats-admin::pr-get pr 'State))))
 875
 876 (defvar gnats-admin:selexpr nil
 877   "Selection expression -- see eval-selexpr.")
 878
 879 (defun gnats-admin::eval-selexpr (pr)
 880   "Evaluate the selection expression, in an environment with
 881 pr bound to the pr, and the field names bound to their value."
 882   (let
 883       ((Number (gnats-admin::pr-get pr 'Number))
 884        (Category (gnats-admin::pr-get pr 'Category))
 885        (Synopsis (gnats-admin::pr-get pr 'Synopsis))
 886        (Confidential (gnats-admin::pr-get pr 'Confidential))
 887        (Severity (gnats-admin::pr-get pr 'Severity))
 888        (Priority (gnats-admin::pr-get pr 'Priority))
 889        (Responsible (gnats-admin::pr-get pr 'Responsible))
 890        (State (gnats-admin::pr-get pr 'State))
 891        (Class (gnats-admin::pr-get pr 'Class))
 892        (Submitter-Id (gnats-admin::pr-get pr 'Submitter-Id))
 893        (Arrival-Date (gnats-admin::pr-get pr 'Arrival-Date))
 894        (Originator (gnats-admin::pr-get pr 'Originator))
 895        (Release (gnats-admin::pr-get pr 'Release)))
 896     (or (not gnats-admin:selexpr)
 897         (eval gnats-admin:selexpr))))
 898
 899 (defun gnats-admin:edit-selection ()
 900   "Edit the selection criteria."
 901   (interactive)
 902   (setq gnats-admin::selector 'gnats-admin::eval-selexpr)
 903   (setq gnats-admin:selexpr
 904         (edit-expr gnats-admin:selexpr
 905 ";; Selection expression.  This is evaluated with Number, Category, Synopsis,
 906 ;; Confidential, Severity, Priority, Responsible, State, Class, Submitter-Id,
 907 ;; Arrival-Date, Originator, and Release set from the PR; if it's a non-null
 908 ;; expression that evaluates true, then that record is displayed.  Free-form
 909 ;; fields are strings, others are symbols or other atoms.
 910 "
 911 ))
 912   (gnats-admin:refresh))