← Back to branch summary

~ubuntu-branches/debian/sid/emacs24/sid

« back to all changes in this revision

Viewing changes to lisp/gnus/gnus-salt.el

  • Committer: Package Import Robot
  • Author(s): Rob Browning
  • Date: 2014-10-25 14:37:43 UTC
  • mfrom: (13.1.3 experimental)
  • Revision ID: package-import@ubuntu.com-20141025143743-m9q5reoyyyjq3p2h
Tags: 24.4+1-4
Update emacsen-common dependency as per policy.

Show diffs side-by-side

added added

removed removed

Lines of Context:
lisp/gnus/gnus-salt.el
1
1
;;; gnus-salt.el --- alternate summary mode interfaces for Gnus
2
2
 
3
 
;; Copyright (C) 1996-1999, 2001-2013 Free Software Foundation, Inc.
 
3
;; Copyright (C) 1996-1999, 2001-2014 Free Software Foundation, Inc.
4
4
 
5
5
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
6
6
;; Keywords: news
292
292
                  (mouse-scroll-subr start-window
293
293
                                     (1+ (- mouse-row bottom)))))))))))
294
294
      (when (consp event)
295
 
        (let ((fun (key-binding (vector (car event)))))
 
295
        (let (;; (fun (key-binding (vector (car event))))
 
296
              )
296
297
          ;; Run the binding of the terminating up-event, if possible.
297
 
       ;; In the case of a multiple click, it gives the wrong results,
 
298
          ;; In the case of a multiple click, it gives the wrong results,
298
299
          ;; because it would fail to set up a region.
299
300
          (when nil
300
 
      ;; (and (= (mod mouse-selection-click-count 3) 0) (fboundp fun))
301
 
       ;; In this case, we can just let the up-event execute normally.
 
301
            ;; (and (= (mod mouse-selection-click-count 3) 0) (fboundp fun))
 
302
            ;; In this case, we can just let the up-event execute normally.
302
303
            (let ((end (event-end event)))
303
304
              ;; Set the position in the event before we replay it,
304
305
              ;; because otherwise it may have a position in the wrong
305
306
              ;; buffer.
306
307
              (setcar (cdr end) end-of-range)
307
308
              ;; Delete the overlay before calling the function,
308
 
             ;; because delete-overlay increases buffer-modified-tick.
 
309
              ;; because delete-overlay increases buffer-modified-tick.
309
310
              (push event unread-command-events))))))))
310
311
 
 
312
(defvar scroll-in-place)
 
313
 
311
314
(defun gnus-pick-next-page ()
312
315
  "Go to the next page.  If at the end of the buffer, start reading articles."
313
316
  (interactive)
356
359
    (when (gnus-visual-p 'binary-menu 'menu)
357
360
      (gnus-binary-make-menu-bar)))))
358
361
 
359
 
(defun gnus-binary-display-article (article &optional all-header)
 
362
(defun gnus-binary-display-article (article &optional _all-header)
360
363
  "Run ARTICLE through the binary decode functions."
361
364
  (when (gnus-summary-goto-subject article)
362
365
    (let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic)))
385
388
                 integer)
386
389
  :group 'gnus-summary-tree)
387
390
 
388
 
(defcustom gnus-selected-tree-face 'modeline
 
391
(defcustom gnus-selected-tree-face 'mode-line
389
392
  "*Face used for highlighting selected articles in the thread tree."
390
393
  :type 'face
391
394
  :group 'gnus-summary-tree)
423
426
 
424
427
;;; Internal variables.
425
428
 
 
429
(defvar gnus-tmp-name)
 
430
(defvar gnus-tmp-from)
 
431
(defvar gnus-tmp-number)
 
432
(defvar gnus-tmp-open-bracket)
 
433
(defvar gnus-tmp-close-bracket)
 
434
(defvar gnus-tmp-subject)
 
435
 
426
436
(defvar gnus-tree-line-format-alist
427
437
  `((?n gnus-tmp-name ?s)
428
438
    (?f gnus-tmp-from ?s)
442
452
(defvar gnus-tree-displayed-thread nil)
443
453
(defvar gnus-tree-inhibit nil)
444
454
 
445
 
(defvar gnus-tree-mode-map nil)
 
455
(defvar gnus-tree-mode-map
 
456
  (let ((map (make-keymap)))
 
457
    (suppress-keymap map)
 
458
    (gnus-define-keys
 
459
        map
 
460
      "\r" gnus-tree-select-article
 
461
      gnus-mouse-2 gnus-tree-pick-article
 
462
      "\C-?" gnus-tree-read-summary-keys
 
463
      "h" gnus-tree-show-summary
 
464
 
 
465
      "\C-c\C-i" gnus-info-find-node)
 
466
 
 
467
    (substitute-key-definition
 
468
     'undefined 'gnus-tree-read-summary-keys map)
 
469
    map))
 
470
 
446
471
(put 'gnus-tree-mode 'mode-class 'special)
447
472
 
448
 
(unless gnus-tree-mode-map
449
 
  (setq gnus-tree-mode-map (make-keymap))
450
 
  (suppress-keymap gnus-tree-mode-map)
451
 
  (gnus-define-keys
452
 
      gnus-tree-mode-map
453
 
    "\r" gnus-tree-select-article
454
 
    gnus-mouse-2 gnus-tree-pick-article
455
 
    "\C-?" gnus-tree-read-summary-keys
456
 
    "h" gnus-tree-show-summary
457
 
 
458
 
    "\C-c\C-i" gnus-info-find-node)
459
 
 
460
 
  (substitute-key-definition
461
 
   'undefined 'gnus-tree-read-summary-keys gnus-tree-mode-map))
462
 
 
463
473
(defun gnus-tree-make-menu-bar ()
464
474
  (unless (boundp 'gnus-tree-menu)
465
475
    (easy-menu-define
467
477
      '("Tree"
468
478
        ["Select article" gnus-tree-select-article t]))))
469
479
 
470
 
(defun gnus-tree-mode ()
 
480
(define-derived-mode gnus-tree-mode fundamental-mode "Tree"
471
481
  "Major mode for displaying thread trees."
472
 
  (interactive)
473
482
  (gnus-set-format 'tree-mode)
474
483
  (gnus-set-format 'tree t)
475
484
  (when (gnus-visual-p 'tree-menu 'menu)
476
485
    (gnus-tree-make-menu-bar))
477
 
  (kill-all-local-variables)
478
486
  (gnus-simplify-mode-line)
479
 
  (setq mode-name "Tree")
480
 
  (setq major-mode 'gnus-tree-mode)
481
 
  (use-local-map gnus-tree-mode-map)
482
487
  (buffer-disable-undo)
483
488
  (setq buffer-read-only t)
484
489
  (setq truncate-lines t)
485
 
  (save-excursion
 
490
  (save-current-buffer
486
491
    (gnus-set-work-buffer)
487
492
    (gnus-tree-node-insert (make-mail-header "") nil)
488
 
    (setq gnus-tree-node-length (1- (point))))
489
 
  (gnus-run-mode-hooks 'gnus-tree-mode-hook))
 
493
    (setq gnus-tree-node-length (1- (point)))))
490
494
 
491
495
(defun gnus-tree-read-summary-keys (&optional arg)
492
496
  "Read a summary buffer key sequence and execute it."
562
566
(defun gnus-get-tree-buffer ()
563
567
  "Return the tree buffer properly initialized."
564
568
  (with-current-buffer (gnus-get-buffer-create gnus-tree-buffer)
565
 
    (unless (eq major-mode 'gnus-tree-mode)
 
569
    (unless (derived-mode-p 'gnus-tree-mode)
566
570
      (gnus-tree-mode))
567
571
    (current-buffer)))
568
572
 
571
575
             (not (one-window-p)))
572
576
    (let ((windows 0)
573
577
          tot-win-height)
574
 
      (walk-windows (lambda (window) (incf windows)))
 
578
      (walk-windows (lambda (_window) (incf windows)))
575
579
      (setq tot-win-height
576
580
            (- (frame-height)
577
581
               (* window-min-height (1- windows))
642
646
    (when (or t (gnus-visual-p 'tree-highlight 'highlight))
643
647
      (gnus-tree-highlight-node gnus-tmp-number beg end))))
644
648
 
 
649
(defmacro gnus--let-eval (bindings evalsym &rest body)
 
650
  "Build an environment in which to evaluate expressions.
 
651
BINDINGS is a `let'-style list of bindings to use for the environment.
 
652
EVALSYM is then bound in BODY to a function that takes a sexp and evaluates
 
653
it in the environment specified by BINDINGS."
 
654
  (declare (indent 2) (debug ((&rest (sym form)) sym body)))
 
655
  (if (ignore-errors (let ((x 3)) (eq (eval '(- x 1) '((x . 4))) x)))
 
656
      ;; Use lexical vars if possible.
 
657
      `(let* ((env (list ,@(mapcar (lambda (binding)
 
658
                                     `(cons ',(car binding) ,(cadr binding)))
 
659
                                   bindings)))
 
660
             (,evalsym (lambda (exp) (eval exp env))))
 
661
         ,@body)
 
662
    `(let (,@bindings (,evalsym #'eval)) ,@body)))
 
663
 
645
664
(defun gnus-tree-highlight-node (article beg end)
646
665
  "Highlight current line according to `gnus-summary-highlight'."
647
666
  (let ((list gnus-summary-highlight)
648
667
        face)
649
668
    (with-current-buffer gnus-summary-buffer
650
 
      (let* ((score (or (cdr (assq article gnus-newsgroup-scored))
 
669
      (let ((uncached (memq article gnus-newsgroup-undownloaded)))
 
670
        (gnus--let-eval
 
671
            ((score (or (cdr (assq article gnus-newsgroup-scored))
651
672
                        gnus-summary-default-score 0))
652
673
             (default gnus-summary-default-score)
653
674
             (default-high gnus-summary-default-high-score)
654
675
             (default-low gnus-summary-default-low-score)
655
 
             (uncached (memq article gnus-newsgroup-undownloaded))
 
676
             (uncached uncached)
656
677
             (downloaded (not uncached))
657
678
             (mark (or (gnus-summary-article-mark article) gnus-unread-mark)))
658
 
        ;; Eval the cars of the lists until we find a match.
659
 
        (while (and list
660
 
                    (not (eval (caar list))))
661
 
          (setq list (cdr list)))))
662
 
    (unless (eq (setq face (cdar list)) (get-text-property beg 'face))
 
679
            evalfun
 
680
          ;; Eval the cars of the lists until we find a match.
 
681
          (while (and list
 
682
                      (not (funcall evalfun (caar list))))
 
683
            (setq list (cdr list))))))
 
684
    (unless (eq (setq face (cdar list)) (gnus-get-text-property-excluding-characters-with-faces beg 'face))
663
685
      (gnus-put-text-property-excluding-characters-with-faces
664
686
       beg end 'face
665
687
       (if (boundp face) (symbol-value face) face)))))
814
836
          (gnus-generate-tree top)
815
837
          (setq gnus-tree-displayed-thread top))))))
816
838
 
817
 
(defun gnus-tree-open (group)
 
839
(defun gnus-tree-open ()
818
840
  (gnus-get-tree-buffer))
819
841
 
820
 
(defun gnus-tree-close (group)
 
842
(defun gnus-tree-close ()
821
843
  (gnus-kill-buffer gnus-tree-buffer))
822
844
 
823
845
(defun gnus-tree-perhaps-minimize ()
828
850
 
829
851
(defun gnus-highlight-selected-tree (article)
830
852
  "Highlight the selected article in the tree."
831
 
  (let ((buf (current-buffer))
832
 
        region)
833
 
    (set-buffer gnus-tree-buffer)
834
 
    (when (setq region (gnus-tree-article-region article))
835
 
      (when (or (not gnus-selected-tree-overlay)
836
 
                (gnus-extent-detached-p gnus-selected-tree-overlay))
837
 
        ;; Create a new overlay.
838
 
        (gnus-overlay-put
839
 
         (setq gnus-selected-tree-overlay
840
 
               (gnus-make-overlay (point-min) (1+ (point-min))))
841
 
         'face gnus-selected-tree-face))
842
 
      ;; Move the overlay to the article.
843
 
      (gnus-move-overlay
844
 
       gnus-selected-tree-overlay (goto-char (car region)) (cdr region))
845
 
      (gnus-tree-minimize)
846
 
      (gnus-tree-recenter)
847
 
      (let ((selected (selected-window)))
848
 
        (when (gnus-get-buffer-window (set-buffer gnus-tree-buffer) t)
849
 
          (select-window (gnus-get-buffer-window (set-buffer gnus-tree-buffer) t))
850
 
          (gnus-horizontal-recenter)
851
 
          (select-window selected))))
852
 
;; If we remove this save-excursion, it updates the wrong mode lines?!?
853
 
    (with-current-buffer gnus-tree-buffer
854
 
      (gnus-set-mode-line 'tree))
855
 
    (set-buffer buf)))
 
853
  (when (buffer-live-p gnus-tree-buffer)
 
854
    (let ((buf (current-buffer))
 
855
          region)
 
856
      (set-buffer gnus-tree-buffer)
 
857
      (when (setq region (gnus-tree-article-region article))
 
858
        (when (or (not gnus-selected-tree-overlay)
 
859
                  (gnus-extent-detached-p gnus-selected-tree-overlay))
 
860
          ;; Create a new overlay.
 
861
          (gnus-overlay-put
 
862
           (setq gnus-selected-tree-overlay
 
863
                 (gnus-make-overlay (point-min) (1+ (point-min))))
 
864
           'face gnus-selected-tree-face))
 
865
        ;; Move the overlay to the article.
 
866
        (gnus-move-overlay
 
867
         gnus-selected-tree-overlay (goto-char (car region)) (cdr region))
 
868
        (gnus-tree-minimize)
 
869
        (gnus-tree-recenter)
 
870
        (let ((selected (selected-window)))
 
871
          (when (gnus-get-buffer-window (set-buffer gnus-tree-buffer) t)
 
872
            (select-window
 
873
             (gnus-get-buffer-window (set-buffer gnus-tree-buffer) t))
 
874
            (gnus-horizontal-recenter)
 
875
            (select-window selected))))
 
876
      ;; If we remove this save-excursion, it updates the wrong mode lines?!?
 
877
      (with-current-buffer gnus-tree-buffer
 
878
        (gnus-set-mode-line 'tree))
 
879
      (set-buffer buf))))
856
880
 
857
881
(defun gnus-tree-highlight-article (article face)
858
 
  (with-current-buffer (gnus-get-tree-buffer)
859
 
    (let (region)
860
 
      (when (setq region (gnus-tree-article-region article))
861
 
        (gnus-put-text-property (car region) (cdr region) 'face face)
862
 
        (set-window-point
863
 
         (gnus-get-buffer-window (current-buffer) t) (cdr region))))))
 
882
  ;; The save-excursion here is apparently necessary because
 
883
  ;; `set-window-point' somehow manages to alter the buffer position.
 
884
  (save-excursion
 
885
    (with-current-buffer (gnus-get-tree-buffer)
 
886
      (let (region)
 
887
        (when (setq region (gnus-tree-article-region article))
 
888
          (gnus-put-text-property (car region) (cdr region) 'face face)
 
889
          (set-window-point
 
890
           (gnus-get-buffer-window (current-buffer) t) (cdr region)))))))
864
891
 
865
892
;;; Allow redefinition of functions.
866
893
(gnus-ems-redefine)