/[emacs]/emacs/lisp/gnus/gnus-art.el
ViewVC logotype

Diff of /emacs/lisp/gnus/gnus-art.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.49.2.3 by rsteib, Mon Aug 23 14:13:39 2004 UTC revision 1.49.2.4 by rsteib, Tue Aug 31 14:47:59 2004 UTC
# Line 1555  Initialized from `text-mode-syntax-table Line 1555  Initialized from `text-mode-syntax-table
1555    (interactive)    (interactive)
1556    ;; This function might be inhibited.    ;; This function might be inhibited.
1557    (unless gnus-inhibit-hiding    (unless gnus-inhibit-hiding
1558      (save-excursion      (let ((inhibit-read-only nil)
1559        (save-restriction            (case-fold-search t)
1560          (let ((inhibit-read-only t)            (max (1+ (length gnus-sorted-header-list)))
1561                (case-fold-search t)            (inhibit-point-motion-hooks t)
1562                (max (1+ (length gnus-sorted-header-list)))            (cur (current-buffer))
1563                (ignored (when (not gnus-visible-headers)            ignored visible beg)
1564                           (cond ((stringp gnus-ignored-headers)        (save-excursion
1565                                  gnus-ignored-headers)          ;; `gnus-ignored-headers' and `gnus-visible-headers' may be
1566                                 ((listp gnus-ignored-headers)          ;; group parameters, so we should go to the summary buffer.
1567                                  (mapconcat 'identity gnus-ignored-headers          (when (prog1
1568                                             "\\|")))))                    (condition-case nil
1569                (visible                        (progn (set-buffer gnus-summary-buffer) t)
1570                 (cond ((stringp gnus-visible-headers)                      (error nil))
1571                        gnus-visible-headers)                  (setq ignored (when (not gnus-visible-headers)
1572                       ((and gnus-visible-headers                                  (cond ((stringp gnus-ignored-headers)
1573                             (listp gnus-visible-headers))                                         gnus-ignored-headers)
1574                        (mapconcat 'identity gnus-visible-headers "\\|"))))                                        ((listp gnus-ignored-headers)
1575                (inhibit-point-motion-hooks t)                                         (mapconcat 'identity
1576                beg)                                                    gnus-ignored-headers
1577                                                      "\\|"))))
1578                          visible (cond ((stringp gnus-visible-headers)
1579                                         gnus-visible-headers)
1580                                        ((and gnus-visible-headers
1581                                              (listp gnus-visible-headers))
1582                                         (mapconcat 'identity
1583                                                    gnus-visible-headers
1584                                                    "\\|")))))
1585              (set-buffer cur))
1586            (save-restriction
1587            ;; First we narrow to just the headers.            ;; First we narrow to just the headers.
1588            (article-narrow-to-head)            (article-narrow-to-head)
1589            ;; Hide any "From " lines at the beginning of (mail) articles.            ;; Hide any "From " lines at the beginning of (mail) articles.
# Line 2382  If READ-CHARSET, ask for a coding system Line 2392  If READ-CHARSET, ask for a coding system
2392    (mm-setup-w3m)    (mm-setup-w3m)
2393    (save-restriction    (save-restriction
2394      (narrow-to-region (point) (point-max))      (narrow-to-region (point) (point-max))
2395      (let ((w3m-safe-url-regexp (if mm-inline-text-html-with-images      (let ((w3m-safe-url-regexp mm-w3m-safe-url-regexp)
                                    nil  
                                  "\\`cid:"))  
2396            w3m-force-redisplay)            w3m-force-redisplay)
2397        (w3m-region (point-min) (point-max)))        (w3m-region (point-min) (point-max)))
2398      (when mm-inline-text-html-with-w3m-keymap      (when (and mm-inline-text-html-with-w3m-keymap
2399                   (boundp 'w3m-minor-mode-map)
2400                   w3m-minor-mode-map)
2401        (add-text-properties        (add-text-properties
2402         (point-min) (point-max)         (point-min) (point-max)
2403         (nconc (mm-w3m-local-map-property)         (list 'keymap w3m-minor-mode-map
2404                '(mm-inline-text-html-with-w3m t))))))               ;; Put the mark meaning this part was rendered by emacs-w3m.
2405                 'mm-inline-text-html-with-w3m t)))))
2406    
2407  (defun article-hide-list-identifiers ()  (defun article-hide-list-identifiers ()
2408    "Remove list identifies from the Subject header.    "Remove list identifies from the Subject header.
# Line 3942  General format specifiers can also be us Line 3953  General format specifiers can also be us
3953    "Save the MIME part under point then replace it with an external body."    "Save the MIME part under point then replace it with an external body."
3954    (interactive)    (interactive)
3955    (gnus-article-check-buffer)    (gnus-article-check-buffer)
3956    (let* ((data (get-text-property (point) 'gnus-data))    (when (gnus-group-read-only-p)
3957           file param      (error "The current group does not support deleting of parts"))
3958           (handles gnus-article-mime-handles))    (when (mm-complicated-handles gnus-article-mime-handles)
3959      (if (mm-multiple-handles gnus-article-mime-handles)      (error "\
3960          (error "This function is not implemented"))  The current article has a complicated MIME structure, giving up..."))
3961      (setq file (and data (mm-save-part data)))    (when (gnus-yes-or-no-p "\
3962      (when file  Deleting parts may malfunction or destroy the article; continue? ")
3963        (with-current-buffer (mm-handle-buffer data)      (let* ((data (get-text-property (point) 'gnus-data))
3964          (erase-buffer)             file param
3965          (insert "Content-Type: " (mm-handle-media-type data))             (handles gnus-article-mime-handles))
3966          (mml-insert-parameter-string (cdr (mm-handle-type data))        (setq file (and data (mm-save-part data)))
3967                                       '(charset))        (when file
3968          (insert "\n")          (with-current-buffer (mm-handle-buffer data)
3969          (insert "Content-ID: " (message-make-message-id) "\n")            (erase-buffer)
3970          (insert "Content-Transfer-Encoding: binary\n")            (insert "Content-Type: " (mm-handle-media-type data))
3971          (insert "\n"))            (mml-insert-parameter-string (cdr (mm-handle-type data))
3972        (setcdr data                                         '(charset))
3973                (cdr (mm-make-handle nil            (insert "\n")
3974                                     `("message/external-body"            (insert "Content-ID: " (message-make-message-id) "\n")
3975                                       (access-type . "LOCAL-FILE")            (insert "Content-Transfer-Encoding: binary\n")
3976                                       (name . ,file)))))            (insert "\n"))
3977        (set-buffer gnus-summary-buffer)          (setcdr data
3978        (gnus-article-edit-article                  (cdr (mm-make-handle nil
3979         `(lambda ()                                       `("message/external-body"
3980             (erase-buffer)                                         (access-type . "LOCAL-FILE")
3981             (let ((mail-parse-charset (or gnus-article-charset                                         (name . ,file)))))
3982                                           ',gnus-newsgroup-charset))          (set-buffer gnus-summary-buffer)
3983                   (mail-parse-ignored-charsets          (gnus-article-edit-article
3984                    (or gnus-article-ignored-charsets           `(lambda ()
3985                        ',gnus-newsgroup-ignored-charsets))              (erase-buffer)
3986                   (mbl mml-buffer-list))              (let ((mail-parse-charset (or gnus-article-charset
3987               (setq mml-buffer-list nil)                                            ',gnus-newsgroup-charset))
3988               (insert-buffer gnus-original-article-buffer)                    (mail-parse-ignored-charsets
3989               (mime-to-mml ',handles)                     (or gnus-article-ignored-charsets
3990               (setq gnus-article-mime-handles nil)                         ',gnus-newsgroup-ignored-charsets))
3991               (let ((mbl1 mml-buffer-list))                    (mbl mml-buffer-list))
3992                 (setq mml-buffer-list mbl)                (setq mml-buffer-list nil)
3993                 (set (make-local-variable 'mml-buffer-list) mbl1))                (insert-buffer gnus-original-article-buffer)
3994               (gnus-make-local-hook 'kill-buffer-hook)                (mime-to-mml ',handles)
3995               (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t)))                (setq gnus-article-mime-handles nil)
3996         `(lambda (no-highlight)                (let ((mbl1 mml-buffer-list))
3997            (let ((mail-parse-charset (or gnus-article-charset                  (setq mml-buffer-list mbl)
3998                                          ',gnus-newsgroup-charset))                  (set (make-local-variable 'mml-buffer-list) mbl1))
3999                  (message-options message-options)                (gnus-make-local-hook 'kill-buffer-hook)
4000                  (message-options-set-recipient)                (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t)))
4001                  (mail-parse-ignored-charsets           `(lambda (no-highlight)
4002                   (or gnus-article-ignored-charsets              (let ((mail-parse-charset (or gnus-article-charset
4003                       ',gnus-newsgroup-ignored-charsets)))                                            ',gnus-newsgroup-charset))
4004             (mml-to-mime)                    (message-options message-options)
4005             (mml-destroy-buffers)                    (message-options-set-recipient)
4006             (remove-hook 'kill-buffer-hook                    (mail-parse-ignored-charsets
4007                          'mml-destroy-buffers t)                     (or gnus-article-ignored-charsets
4008             (kill-local-variable 'mml-buffer-list))                         ',gnus-newsgroup-ignored-charsets)))
4009            (gnus-summary-edit-article-done                (mml-to-mime)
4010             ,(or (mail-header-references gnus-current-headers) "")                (mml-destroy-buffers)
4011             ,(gnus-group-read-only-p)                (remove-hook 'kill-buffer-hook
4012             ,gnus-summary-buffer no-highlight))))))                             'mml-destroy-buffers t)
4013                  (kill-local-variable 'mml-buffer-list))
4014                (gnus-summary-edit-article-done
4015                 ,(or (mail-header-references gnus-current-headers) "")
4016                 ,(gnus-group-read-only-p)
4017                 ,gnus-summary-buffer no-highlight)))))))
4018    
4019  (defun gnus-mime-delete-part ()  (defun gnus-mime-delete-part ()
4020    "Delete the MIME part under point.    "Delete the MIME part under point.
4021  Replace it with some information about the removed part."  Replace it with some information about the removed part."
4022    (interactive)    (interactive)
4023    (gnus-article-check-buffer)    (gnus-article-check-buffer)
4024    (unless (and gnus-novice-user    (when (gnus-group-read-only-p)
4025                 (not (gnus-yes-or-no-p      (error "The current group does not support deleting of parts"))
4026                       "Really delete attachment forever? ")))    (when (mm-complicated-handles gnus-article-mime-handles)
4027        (error "\
4028    The current article has a complicated MIME structure, giving up..."))
4029      (when (gnus-yes-or-no-p "\
4030    Deleting parts may malfunction or destroy the article; continue? ")
4031      (let* ((data (get-text-property (point) 'gnus-data))      (let* ((data (get-text-property (point) 'gnus-data))
4032             (handles gnus-article-mime-handles)             (handles gnus-article-mime-handles)
4033             (none "(none)")             (none "(none)")
# Line 4019  Replace it with some information about t Line 4039  Replace it with some information about t
4039              (or (mail-content-type-get (mm-handle-disposition data) 'filename)              (or (mail-content-type-get (mm-handle-disposition data) 'filename)
4040                  none))                  none))
4041             (type (mm-handle-media-type data)))             (type (mm-handle-media-type data)))
4042        (if (mm-multiple-handles gnus-article-mime-handles)        (unless data
4043            (error "This function is not implemented"))          (error "No MIME part under point"))
4044        (with-current-buffer (mm-handle-buffer data)        (with-current-buffer (mm-handle-buffer data)
4045          (let ((bsize (format "%s" (buffer-size))))          (let ((bsize (format "%s" (buffer-size))))
4046            (erase-buffer)            (erase-buffer)
# Line 5016  Argument LINES specifies lines to be scr Line 5036  Argument LINES specifies lines to be scr
5036                (save-excursion                (save-excursion
5037                  (save-restriction                  (save-restriction
5038                    (widen)                    (widen)
5039                      (forward-line)
5040                    (eobp)))) ;Real end-of-buffer?                    (eobp)))) ;Real end-of-buffer?
5041            (progn            (progn
5042              (when gnus-article-over-scroll              (when gnus-article-over-scroll
# Line 5173  not have a face in `gnus-article-boring- Line 5194  not have a face in `gnus-article-boring-
5194        (let ((obuf (current-buffer))        (let ((obuf (current-buffer))
5195              (owin (current-window-configuration))              (owin (current-window-configuration))
5196              (opoint (point))              (opoint (point))
5197              (summary gnus-article-current-summary)              win func in-buffer selected new-sum-start new-sum-hscroll)
5198              func in-buffer selected)          (cond (not-restore-window
5199          (if not-restore-window                 (pop-to-buffer gnus-article-current-summary 'norecord))
5200              (pop-to-buffer summary 'norecord)                ((setq win (get-buffer-window gnus-article-current-summary))
5201            (switch-to-buffer summary 'norecord))                 (select-window win))
5202                  (t
5203                   (switch-to-buffer gnus-article-current-summary 'norecord)))
5204          (setq in-buffer (current-buffer))          (setq in-buffer (current-buffer))
5205          ;; We disable the pick minor mode commands.          ;; We disable the pick minor mode commands.
5206          (if (and (setq func (let (gnus-pick-mode)          (if (and (setq func (let (gnus-pick-mode)
# Line 5185  not have a face in `gnus-article-boring- Line 5208  not have a face in `gnus-article-boring-
5208                   (functionp func))                   (functionp func))
5209              (progn              (progn
5210                (call-interactively func)                (call-interactively func)
5211                (setq new-sum-point (point))                (when (eq win (selected-window))
5212                    (setq new-sum-point (point)
5213                          new-sum-start (window-start win)
5214                          new-sum-hscroll (window-hscroll win))
5215                (when (eq in-buffer (current-buffer))                (when (eq in-buffer (current-buffer))
5216                  (setq selected (gnus-summary-select-article))                  (setq selected (gnus-summary-select-article))
5217                  (set-buffer obuf)                  (set-buffer obuf)
# Line 5197  not have a face in `gnus-article-boring- Line 5223  not have a face in `gnus-article-boring-
5223                                      1)                                      1)
5224                    (set-window-point (get-buffer-window (current-buffer))                    (set-window-point (get-buffer-window (current-buffer))
5225                                      (point)))                                      (point)))
5226                  (let ((win (get-buffer-window gnus-article-current-summary)))                  (when (and (not not-restore-window)
5227                    (when win                             new-sum-point)
5228                      (set-window-point win new-sum-point))))    )                    (set-window-point win new-sum-point)
5229            (switch-to-buffer gnus-article-buffer)                    (set-window-start win new-sum-start)
5230                      (set-window-hscroll win new-sum-hscroll)))))
5231              (set-window-configuration owin)
5232            (ding))))))            (ding))))))
5233    
5234  (defun gnus-article-describe-key (key)  (defun gnus-article-describe-key (key)
# Line 6678  specified by `gnus-button-alist'." Line 6706  specified by `gnus-button-alist'."
6706      (define-key map "\r" 'gnus-button-prev-page)      (define-key map "\r" 'gnus-button-prev-page)
6707      map))      map))
6708    
6709    (defvar gnus-next-page-map
6710      (let ((map (make-sparse-keymap)))
6711        (unless (>= emacs-major-version 21)
6712          ;; XEmacs doesn't care.
6713          (set-keymap-parent map gnus-article-mode-map))
6714        (define-key map gnus-mouse-2 'gnus-button-next-page)
6715        (define-key map "\r" 'gnus-button-next-page)
6716        map))
6717    
6718  (defun gnus-insert-prev-page-button ()  (defun gnus-insert-prev-page-button ()
6719    (let ((b (point))    (let ((b (point))
6720          (inhibit-read-only t))          (inhibit-read-only t))
# Line 6695  specified by `gnus-button-alist'." Line 6732  specified by `gnus-button-alist'."
6732       :action 'gnus-button-prev-page       :action 'gnus-button-prev-page
6733       :button-keymap gnus-prev-page-map)))       :button-keymap gnus-prev-page-map)))
6734    
 (defvar gnus-prev-page-map  
   (let ((map (make-sparse-keymap)))  
     (unless (>= emacs-major-version 21)  
       ;; XEmacs doesn't care.  
       (set-keymap-parent map gnus-article-mode-map))  
     (define-key map gnus-mouse-2 'gnus-button-prev-page)  
     (define-key map "\r" 'gnus-button-prev-page)  
     map))  
   
 (defvar gnus-next-page-map  
   (let ((map (make-sparse-keymap)))  
     (unless (>= emacs-major-version 21)  
       ;; XEmacs doesn't care.  
       (set-keymap-parent map gnus-article-mode-map))  
     (define-key map gnus-mouse-2 'gnus-button-next-page)  
     (define-key map "\r" 'gnus-button-next-page)  
     map))  
   
6735  (defun gnus-button-next-page (&optional args more-args)  (defun gnus-button-next-page (&optional args more-args)
6736    "Go to the next page."    "Go to the next page."
6737    (interactive)    (interactive)

Legend:
Removed from v.1.49.2.3  
changed lines
  Added in v.1.49.2.4

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26