merge trunk
This commit is contained in:
Kenichi Handa
commit
1114abdb3d
18 changed files with 569 additions and 311 deletions
|
|
@ -1,3 +1,8 @@
|
|||
2010-09-21 Lars Magne Ingebrigtsen <larsi@gnus.org>
|
||||
|
||||
* gnus.texi (Expunging mailboxes): Update name of the expunging
|
||||
command.
|
||||
|
||||
2010-09-20 Katsumi Yamaoka <yamaoka@jpl.org>
|
||||
|
||||
* emacs-mime.texi (rfc2047): Update description for
|
||||
|
|
|
|||
|
|
@ -18384,7 +18384,7 @@ INBOX.mailbox).
|
|||
@cindex expunge
|
||||
@cindex manual expunging
|
||||
@kindex G x (Group)
|
||||
@findex gnus-group-nnimap-expunge
|
||||
@findex gnus-group-expunge-group
|
||||
|
||||
If you're using the @code{never} setting of @code{nnimap-expunge-on-close},
|
||||
you may want the option of expunging all deleted articles in a mailbox
|
||||
|
|
|
|||
|
|
@ -1,3 +1,10 @@
|
|||
2010-09-21 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
|
||||
* emacs-lisp/smie.el (smie-debug--describe-cycle): Fix typo.
|
||||
(smie-indent-comment): Be more careful with comment-start-skip.
|
||||
(smie-indent-comment-close, smie-indent-comment-inside): New funs.
|
||||
(smie-indent-functions): Use them.
|
||||
|
||||
2010-09-21 Michael Albinus <michael.albinus@gmx.de>
|
||||
|
||||
* net/ange-ftp.el (ange-ftp-skip-msgs): Add "^504 ..." message.
|
||||
|
|
|
|||
|
|
@ -338,7 +338,7 @@ CSTS is a list of pairs representing arcs in a graph."
|
|||
res))
|
||||
cycle)))
|
||||
(mapconcat
|
||||
(lambda (elems) (mapconcat 'indentity elems "="))
|
||||
(lambda (elems) (mapconcat 'identity elems "="))
|
||||
(append names (list (car names)))
|
||||
" < ")))
|
||||
|
||||
|
|
@ -1173,7 +1173,11 @@ in order to figure out the indentation of some other (further down) point."
|
|||
;; front of a comment" when doing virtual-indentation anyway. And if we are
|
||||
;; (as can happen in octave-mode), moving forward can lead to inf-loops.
|
||||
(and (smie-indent--bolp)
|
||||
(looking-at comment-start-skip)
|
||||
(let ((pos (point)))
|
||||
(save-excursion
|
||||
(beginning-of-line)
|
||||
(and (re-search-forward comment-start-skip (line-end-position) t)
|
||||
(eq pos (or (match-end 1) (match-beginning 0))))))
|
||||
(save-excursion
|
||||
(forward-comment (point-max))
|
||||
(skip-chars-forward " \t\r\n")
|
||||
|
|
@ -1194,6 +1198,20 @@ in order to figure out the indentation of some other (further down) point."
|
|||
(if (looking-at (regexp-quote continue))
|
||||
(current-column))))))))
|
||||
|
||||
(defun smie-indent-comment-close ()
|
||||
(and (boundp 'comment-end-skip)
|
||||
comment-end-skip
|
||||
(not (looking-at " \t*$")) ;Not just a \n comment-closer.
|
||||
(looking-at comment-end-skip)
|
||||
(nth 4 (syntax-ppss))
|
||||
(save-excursion
|
||||
(goto-char (nth 8 (syntax-ppss)))
|
||||
(current-column))))
|
||||
|
||||
(defun smie-indent-comment-inside ()
|
||||
(and (nth 4 (syntax-ppss))
|
||||
'noindent))
|
||||
|
||||
(defun smie-indent-after-keyword ()
|
||||
;; Indentation right after a special keyword.
|
||||
(save-excursion
|
||||
|
|
@ -1275,9 +1293,10 @@ in order to figure out the indentation of some other (further down) point."
|
|||
(current-column)))))))
|
||||
|
||||
(defvar smie-indent-functions
|
||||
'(smie-indent-fixindent smie-indent-bob smie-indent-close smie-indent-comment
|
||||
smie-indent-comment-continue smie-indent-keyword smie-indent-after-keyword
|
||||
smie-indent-exps)
|
||||
'(smie-indent-fixindent smie-indent-bob smie-indent-close
|
||||
smie-indent-comment smie-indent-comment-continue smie-indent-comment-close
|
||||
smie-indent-comment-inside smie-indent-keyword smie-indent-after-keyword
|
||||
smie-indent-exps)
|
||||
"Functions to compute the indentation.
|
||||
Each function is called with no argument, shouldn't move point, and should
|
||||
return either nil if it has no opinion, or an integer representing the column
|
||||
|
|
|
|||
|
|
@ -1,3 +1,81 @@
|
|||
2010-09-21 Adam Sjøgren <asjo@koldfront.dk>
|
||||
|
||||
* gnus-sum.el (gnus-adjust-marked-articles): Fix typo.
|
||||
|
||||
2010-09-21 Lars Magne Ingebrigtsen <larsi@gnus.org>
|
||||
|
||||
* gnus-int.el (gnus-open-server): Give a better error message in the
|
||||
"go offline" case.
|
||||
|
||||
* gnus-sum.el (gnus-adjust-marked-articles): Hack to avoid adjusting
|
||||
marks for nnimap, which is seldom the right thing to do.
|
||||
|
||||
* gnus.el (gnus-sloppily-equal-method-parameters): Refactor out.
|
||||
(gnus-same-method-different-name): New function.
|
||||
|
||||
* nnimap.el (parse-time): Require.
|
||||
|
||||
* gnus-start.el (gnus-get-unread-articles): Fix the prefixed select
|
||||
method in the presence of many similar methods.
|
||||
|
||||
* nnmail.el (nnmail-expired-article-p): Fix typo: time-subtract.
|
||||
|
||||
* nnimap.el (nnimap-find-expired-articles): Don't refer to
|
||||
nnml-inhibit-expiry.
|
||||
|
||||
* gnus-sum.el (gnus-summary-move-article): Use gnus-server-equal to
|
||||
find out whether methods are equal.
|
||||
|
||||
* nnimap.el (nnimap-find-expired-articles): New function.
|
||||
(nnimap-process-expiry-targets): New function.
|
||||
(nnimap-request-move-article): Request the article before looking at
|
||||
what the Message-ID is. Fix found by Andrew Cohen.
|
||||
(nnimap-mark-and-expunge-incoming): Wait for the last sequence.
|
||||
|
||||
* nnmail.el (nnmail-expired-article-p): Allow returning the cutoff time
|
||||
for oldness in addition to being a predicate.
|
||||
|
||||
* nnimap.el (nnimap-request-group): When we have zero articles, return
|
||||
the right data to Gnus.
|
||||
(nnimap-request-expire-articles): Only delete articles immediately if
|
||||
the target is 'delete.
|
||||
|
||||
* gnus-sum.el (gnus-summary-move-article): When respooling to the same
|
||||
method, this would bug out.
|
||||
|
||||
* gnus-group.el (gnus-group-expunge-group): Renamed from
|
||||
gnus-group-nnimap-expunge, and implemented as a normal interface
|
||||
function.
|
||||
|
||||
* gnus-int.el (gnus-request-expunge-group): New function.
|
||||
|
||||
* nnimap.el (nnimap-request-create-group): Implement.
|
||||
(nnimap-request-expunge-group): New function.
|
||||
|
||||
2010-09-21 Julien Danjou <julien@danjou.info>
|
||||
|
||||
* gnus-html.el (gnus-html-image-cache-ttl): Add new variable.
|
||||
(gnus-html-cache-expired): Add new function.
|
||||
(gnus-html-wash-images): Use `gnus-html-cache-expired' to check
|
||||
wethever we should display image for fetch it.
|
||||
Compute alt-text earlier to pass it to the fetching function too.
|
||||
(gnus-html-schedule-image-fetching): Change function argument to only
|
||||
get one image at a time, not a list.
|
||||
(gnus-html-image-fetched): Use `url-store-in-cache' to store image in
|
||||
cache.
|
||||
(gnus-html-get-image-data): New function to retrieve image data from
|
||||
cache.
|
||||
(gnus-html-put-image): Change buffer argument to use image data rather
|
||||
than file, and place image above region rather than inserting a new
|
||||
one. Do not take alt-text as argument, since it's useless now: we place
|
||||
the image above alt-text.
|
||||
(gnus-html-prune-cache): Remove.
|
||||
(gnus-html-show-images): Start to fetch image when we find one, do not
|
||||
push into a temporary list.
|
||||
(gnus-html-prefetch-images): Only fetch image if they have expired.
|
||||
(gnus-html-browse-image): Fix, use 'gnus-image-url.
|
||||
(gnus-html-image-map): Add "v" to browse-url on undisplayed image.
|
||||
|
||||
2010-09-20 Katsumi Yamaoka <yamaoka@jpl.org>
|
||||
|
||||
* rfc2047.el (rfc2047-encode-parameter): Doc fix.
|
||||
|
|
|
|||
|
|
@ -509,7 +509,10 @@ simple manner.")
|
|||
(gnus-range-length (cdr (assq 'tick gnus-tmp-marked))))))
|
||||
(t number)) ?s)
|
||||
(?R gnus-tmp-number-of-read ?s)
|
||||
(?U (gnus-number-of-unseen-articles-in-group gnus-tmp-group) ?d)
|
||||
(?U (if (gnus-active gnus-tmp-group)
|
||||
(gnus-number-of-unseen-articles-in-group gnus-tmp-group)
|
||||
"*")
|
||||
?s)
|
||||
(?t gnus-tmp-number-total ?d)
|
||||
(?y gnus-tmp-number-of-unread ?s)
|
||||
(?I (gnus-range-length (cdr (assq 'dormant gnus-tmp-marked))) ?d)
|
||||
|
|
@ -675,7 +678,7 @@ simple manner.")
|
|||
"R" gnus-group-make-rss-group
|
||||
"c" gnus-group-customize
|
||||
"z" gnus-group-compact-group
|
||||
"x" gnus-group-nnimap-expunge
|
||||
"x" gnus-group-expunge-group
|
||||
"\177" gnus-group-delete-group
|
||||
[delete] gnus-group-delete-group)
|
||||
|
||||
|
|
@ -3163,21 +3166,17 @@ mail messages or news articles in files that have numeric names."
|
|||
'summary 'group)))
|
||||
(error "Couldn't enter %s" dir))))
|
||||
|
||||
(autoload 'nnimap-expunge "nnimap")
|
||||
(autoload 'nnimap-acl-get "nnimap")
|
||||
(autoload 'nnimap-acl-edit "nnimap")
|
||||
|
||||
(defun gnus-group-nnimap-expunge (group)
|
||||
(defun gnus-group-expunge-group (group)
|
||||
"Expunge deleted articles in current nnimap GROUP."
|
||||
(interactive (list (gnus-group-group-name)))
|
||||
(let ((mailbox (gnus-group-real-name group)) method)
|
||||
(unless group
|
||||
(error "No group on current line"))
|
||||
(unless (gnus-get-info group)
|
||||
(error "Killed group; can't be edited"))
|
||||
(unless (eq 'nnimap (car (setq method (gnus-find-method-for-group group))))
|
||||
(error "%s is not an nnimap group" group))
|
||||
(nnimap-expunge mailbox (cadr method))))
|
||||
(let ((method (gnus-find-method-for-group group)))
|
||||
(if (not (gnus-check-backend-function
|
||||
'request-expunge-group (car method)))
|
||||
(error "%s does not support expunging" (car method))
|
||||
(gnus-request-expunge-group group method))))
|
||||
|
||||
(autoload 'nnimap-acl-get "nnimap")
|
||||
(autoload 'nnimap-acl-edit "nnimap")
|
||||
|
||||
(defun gnus-group-nnimap-edit-acl (group)
|
||||
"Edit the Access Control List of current nnimap GROUP."
|
||||
|
|
|
|||
|
|
@ -34,15 +34,10 @@
|
|||
(require 'gnus-art)
|
||||
(require 'mm-url)
|
||||
(require 'url)
|
||||
(require 'url-cache)
|
||||
|
||||
(defcustom gnus-html-cache-directory (nnheader-concat gnus-directory "html-cache/")
|
||||
"Where Gnus will cache images it downloads from the web."
|
||||
:version "24.1"
|
||||
:group 'gnus-art
|
||||
:type 'directory)
|
||||
|
||||
(defcustom gnus-html-cache-size 500000000
|
||||
"The size of the Gnus image cache."
|
||||
(defcustom gnus-html-image-cache-ttl (days-to-time 7)
|
||||
"Time in seconds used to cache the image on disk."
|
||||
:version "24.1"
|
||||
:group 'gnus-art
|
||||
:type 'integer)
|
||||
|
|
@ -73,6 +68,7 @@ fit these criteria."
|
|||
(let ((map (make-sparse-keymap)))
|
||||
(define-key map "u" 'gnus-article-copy-string)
|
||||
(define-key map "i" 'gnus-html-insert-image)
|
||||
(define-key map "v" 'gnus-html-browse-url)
|
||||
map))
|
||||
|
||||
(defvar gnus-html-displayed-image-map
|
||||
|
|
@ -84,6 +80,19 @@ fit these criteria."
|
|||
(define-key map [tab] 'widget-forward)
|
||||
map))
|
||||
|
||||
(defun gnus-html-cache-expired (url ttl)
|
||||
"Check if URL is cached for more than TTL."
|
||||
(cond (url-standalone-mode
|
||||
(not (file-exists-p (url-cache-create-filename url))))
|
||||
(t (let ((cache-time (url-is-cached url)))
|
||||
(if cache-time
|
||||
(time-less-p
|
||||
(time-add
|
||||
cache-time
|
||||
ttl)
|
||||
(current-time))
|
||||
t)))))
|
||||
|
||||
;;;###autoload
|
||||
(defun gnus-article-html (&optional handle)
|
||||
(let ((article-buffer (current-buffer)))
|
||||
|
|
@ -133,6 +142,7 @@ fit these criteria."
|
|||
(replace-match "" t t)))
|
||||
|
||||
(defun gnus-html-wash-images ()
|
||||
"Run through current buffer and replace img tags by images."
|
||||
(let (tag parameters string start end images url)
|
||||
(goto-char (point-min))
|
||||
;; Search for all the images first.
|
||||
|
|
@ -158,62 +168,68 @@ fit these criteria."
|
|||
(setq image (gnus-create-image (buffer-string)
|
||||
nil t))))
|
||||
(when image
|
||||
(let ((string (buffer-substring start end)))
|
||||
(delete-region start end)
|
||||
(gnus-put-image image (gnus-string-or string "*") 'cid)
|
||||
(gnus-add-image 'cid image))))
|
||||
(let ((string (buffer-substring start end)))
|
||||
(delete-region start end)
|
||||
(gnus-put-image image (gnus-string-or string "*") 'cid)
|
||||
(gnus-add-image 'cid image))))
|
||||
;; Normal, external URL.
|
||||
(if (gnus-html-image-url-blocked-p
|
||||
url
|
||||
(if (buffer-live-p gnus-summary-buffer)
|
||||
(with-current-buffer gnus-summary-buffer
|
||||
gnus-blocked-images)
|
||||
gnus-blocked-images))
|
||||
(progn
|
||||
(widget-convert-button
|
||||
'link start end
|
||||
:action 'gnus-html-insert-image
|
||||
:help-echo url
|
||||
:keymap gnus-html-image-map
|
||||
:button-keymap gnus-html-image-map)
|
||||
(let ((overlay (gnus-make-overlay start end))
|
||||
(spec (list url
|
||||
(set-marker (make-marker) start)
|
||||
(set-marker (make-marker) end))))
|
||||
(gnus-overlay-put overlay 'local-map gnus-html-image-map)
|
||||
(gnus-overlay-put overlay 'gnus-image spec)
|
||||
(gnus-put-text-property
|
||||
start end
|
||||
'gnus-image spec)))
|
||||
(let ((file (gnus-html-image-id url))
|
||||
width height alt-text)
|
||||
(when (string-match "height=\"?\\([0-9]+\\)" parameters)
|
||||
(setq height (string-to-number (match-string 1 parameters))))
|
||||
(when (string-match "width=\"?\\([0-9]+\\)" parameters)
|
||||
(setq width (string-to-number (match-string 1 parameters))))
|
||||
(when (string-match "\\(alt\\|title\\)=\"\\([^\"]+\\)"
|
||||
parameters)
|
||||
(setq alt-text (match-string 2 parameters)))
|
||||
;; Don't fetch images that are really small. They're
|
||||
;; probably tracking pictures.
|
||||
(when (and (or (null height)
|
||||
(> height 4))
|
||||
(or (null width)
|
||||
(> width 4)))
|
||||
(if (file-exists-p file)
|
||||
;; It's already cached, so just insert it.
|
||||
(let ((string (buffer-substring start end)))
|
||||
;; Delete the IMG text.
|
||||
(delete-region start end)
|
||||
(gnus-html-put-image file (point) string url alt-text))
|
||||
;; We don't have it, so schedule it for fetching
|
||||
;; asynchronously.
|
||||
(push (list url
|
||||
(set-marker (make-marker) start)
|
||||
(point-marker))
|
||||
images))))))))
|
||||
(when images
|
||||
(gnus-html-schedule-image-fetching (current-buffer) (nreverse images)))))
|
||||
(let ((alt-text (when (string-match "\\(alt\\|title\\)=\"\\([^\"]+\\)"
|
||||
parameters)
|
||||
(match-string 2 parameters))))
|
||||
(if (gnus-html-image-url-blocked-p
|
||||
url
|
||||
(if (buffer-live-p gnus-summary-buffer)
|
||||
(with-current-buffer gnus-summary-buffer
|
||||
gnus-blocked-images)
|
||||
gnus-blocked-images))
|
||||
(progn
|
||||
(widget-convert-button
|
||||
'link start end
|
||||
:action 'gnus-html-insert-image
|
||||
:help-echo url
|
||||
:keymap gnus-html-image-map
|
||||
:button-keymap gnus-html-image-map)
|
||||
(let ((overlay (gnus-make-overlay start end))
|
||||
(spec (list url
|
||||
(set-marker (make-marker) start)
|
||||
(set-marker (make-marker) end)
|
||||
alt-text)))
|
||||
(gnus-overlay-put overlay 'local-map gnus-html-image-map)
|
||||
(gnus-overlay-put overlay 'gnus-image spec)
|
||||
(gnus-put-text-property start end 'gnus-image-url url)
|
||||
(gnus-put-text-property
|
||||
start end
|
||||
'gnus-image spec)))
|
||||
;; Non-blocked url
|
||||
(let ((width
|
||||
(when (string-match "width=\"?\\([0-9]+\\)" parameters)
|
||||
(string-to-number (match-string 1 parameters))))
|
||||
(height
|
||||
(when (string-match "height=\"?\\([0-9]+\\)" parameters)
|
||||
(string-to-number (match-string 1 parameters)))))
|
||||
;; Don't fetch images that are really small. They're
|
||||
;; probably tracking pictures.
|
||||
(when (and (or (null height)
|
||||
(> height 4))
|
||||
(or (null width)
|
||||
(> width 4)))
|
||||
(gnus-html-display-image url start end alt-text))))))))))
|
||||
|
||||
(defun gnus-html-display-image (url start end alt-text)
|
||||
"Display image at URL on text from START to END.
|
||||
Use ALT-TEXT for the image string."
|
||||
(if (gnus-html-cache-expired url gnus-html-image-cache-ttl)
|
||||
;; We don't have it, so schedule it for fetching
|
||||
;; asynchronously.
|
||||
(gnus-html-schedule-image-fetching
|
||||
(current-buffer)
|
||||
(list url
|
||||
(set-marker (make-marker) start)
|
||||
(set-marker (make-marker) end)
|
||||
alt-text))
|
||||
;; It's already cached, so just insert it.
|
||||
(gnus-html-put-image (gnus-html-get-image-data url)
|
||||
start end url alt-text)))
|
||||
|
||||
(defun gnus-html-wash-tags ()
|
||||
(let (tag parameters string start end images url)
|
||||
|
|
@ -300,8 +316,7 @@ fit these criteria."
|
|||
(defun gnus-html-insert-image ()
|
||||
"Fetch and insert the image under point."
|
||||
(interactive)
|
||||
(gnus-html-schedule-image-fetching
|
||||
(current-buffer) (list (get-text-property (point) 'gnus-image))))
|
||||
(apply 'gnus-html-display-image (get-text-property (point) 'gnus-image)))
|
||||
|
||||
(defun gnus-html-show-alt-text ()
|
||||
"Show the ALT text of the image under point."
|
||||
|
|
@ -311,7 +326,7 @@ fit these criteria."
|
|||
(defun gnus-html-browse-image ()
|
||||
"Browse the image under point."
|
||||
(interactive)
|
||||
(browse-url (get-text-property (point) 'gnus-image)))
|
||||
(browse-url (get-text-property (point) 'gnus-image-url)))
|
||||
|
||||
(defun gnus-html-browse-url ()
|
||||
"Browse the image under point."
|
||||
|
|
@ -321,87 +336,89 @@ fit these criteria."
|
|||
(message "No URL at point")
|
||||
(browse-url url))))
|
||||
|
||||
(defun gnus-html-schedule-image-fetching (buffer images)
|
||||
(gnus-message 8 "gnus-html-schedule-image-fetching: buffer %s, images %s"
|
||||
buffer images)
|
||||
(dolist (image images)
|
||||
(ignore-errors
|
||||
(url-retrieve (car image)
|
||||
'gnus-html-image-fetched
|
||||
(list buffer image)))))
|
||||
|
||||
(defun gnus-html-image-id (url)
|
||||
(expand-file-name (sha1 url) gnus-html-cache-directory))
|
||||
(defun gnus-html-schedule-image-fetching (buffer image)
|
||||
"Retrieve IMAGE, and place it into BUFFER on arrival."
|
||||
(gnus-message 8 "gnus-html-schedule-image-fetching: buffer %s, image %s"
|
||||
buffer image)
|
||||
(ignore-errors
|
||||
(url-retrieve (car image)
|
||||
'gnus-html-image-fetched
|
||||
(list buffer image))))
|
||||
|
||||
(defun gnus-html-image-fetched (status buffer image)
|
||||
(let ((file (gnus-html-image-id (car image))))
|
||||
;; Search the start of the image data
|
||||
(when (search-forward "\n\n" nil t)
|
||||
;; Write region (image data) silently
|
||||
(write-region (point) (point-max) file nil 1)
|
||||
(kill-buffer (current-buffer))
|
||||
(when (and (buffer-live-p buffer)
|
||||
;; If the `image' has no marker, do not replace anything
|
||||
(cadr image)
|
||||
;; If the position of the marker is 1, then that
|
||||
;; means that the text it was in has been deleted;
|
||||
;; i.e., that the user has selected a different
|
||||
;; article before the image arrived.
|
||||
(not (= (marker-position (cadr image)) (point-min))))
|
||||
(with-current-buffer buffer
|
||||
(let ((inhibit-read-only t)
|
||||
(string (buffer-substring (cadr image) (caddr image))))
|
||||
(delete-region (cadr image) (caddr image))
|
||||
(gnus-html-put-image file (cadr image) (car image) string)))))))
|
||||
(url-store-in-cache (current-buffer))
|
||||
(when (and (search-forward "\n\n" nil t)
|
||||
(buffer-live-p buffer)
|
||||
;; If the `image' has no marker, do not replace anything
|
||||
(cadr image)
|
||||
;; If the position of the marker is 1, then that
|
||||
;; means that the text it was in has been deleted;
|
||||
;; i.e., that the user has selected a different
|
||||
;; article before the image arrived.
|
||||
(not (= (marker-position (cadr image))
|
||||
(with-current-buffer buffer
|
||||
(point-min)))))
|
||||
(let ((data (buffer-substring (point) (point-max))))
|
||||
(with-current-buffer buffer
|
||||
(let ((inhibit-read-only t))
|
||||
(gnus-html-put-image data (cadr image) (caddr image) (car image) (cadddr image))))))
|
||||
(kill-buffer (current-buffer)))
|
||||
|
||||
(defun gnus-html-put-image (file point string &optional url alt-text)
|
||||
(defun gnus-html-get-image-data (url)
|
||||
"Get image data for URL.
|
||||
Return a string with image data."
|
||||
(with-temp-buffer
|
||||
(mm-disable-multibyte)
|
||||
(url-cache-extract (url-cache-create-filename url))
|
||||
(when (search-forward "\n\n" nil t)
|
||||
(buffer-substring (point) (point-max)))))
|
||||
|
||||
(defun gnus-html-put-image (data start end &optional url alt-text)
|
||||
(when (gnus-graphic-display-p)
|
||||
(let* ((image (ignore-errors
|
||||
(gnus-create-image file)))
|
||||
(size (and image
|
||||
(if (featurep 'xemacs)
|
||||
(cons (glyph-width image) (glyph-height image))
|
||||
(image-size image t)))))
|
||||
(gnus-create-image data nil t)))
|
||||
(size (and image
|
||||
(if (featurep 'xemacs)
|
||||
(cons (glyph-width image) (glyph-height image))
|
||||
(image-size image t)))))
|
||||
(save-excursion
|
||||
(goto-char point)
|
||||
(if (and image
|
||||
;; Kludge to avoid displaying 30x30 gif images, which
|
||||
;; seems to be a signal of a broken image.
|
||||
(not (and (if (featurep 'xemacs)
|
||||
(glyphp image)
|
||||
(listp image))
|
||||
(eq (if (featurep 'xemacs)
|
||||
(let ((data (cdadar (specifier-spec-list
|
||||
(glyph-image image)))))
|
||||
(and (vectorp data)
|
||||
(aref data 0)))
|
||||
(plist-get (cdr image) :type))
|
||||
'gif)
|
||||
(= (car size) 30)
|
||||
(= (cdr size) 30))))
|
||||
(let ((start (point)))
|
||||
(setq image (gnus-html-rescale-image image file size))
|
||||
(gnus-put-image image
|
||||
(gnus-string-or string "*")
|
||||
'external)
|
||||
(let ((overlay (gnus-make-overlay start (point))))
|
||||
(gnus-overlay-put overlay 'local-map
|
||||
gnus-html-displayed-image-map)
|
||||
(gnus-put-text-property start (point) 'gnus-alt-text alt-text)
|
||||
(when url
|
||||
(gnus-put-text-property start (point) 'gnus-image url)))
|
||||
(gnus-add-image 'external image)
|
||||
t)
|
||||
(insert string)
|
||||
(when (fboundp 'find-image)
|
||||
(setq image (find-image '((:type xpm :file "lock-broken.xpm"))))
|
||||
(gnus-put-image image
|
||||
(gnus-string-or string "*")
|
||||
'internal)
|
||||
(gnus-add-image 'internal image))
|
||||
nil)))))
|
||||
(goto-char start)
|
||||
(let ((alt-text (or alt-text (buffer-substring-no-properties start end))))
|
||||
(if (and image
|
||||
;; Kludge to avoid displaying 30x30 gif images, which
|
||||
;; seems to be a signal of a broken image.
|
||||
(not (and (if (featurep 'xemacs)
|
||||
(glyphp image)
|
||||
(listp image))
|
||||
(eq (if (featurep 'xemacs)
|
||||
(let ((d (cdadar (specifier-spec-list
|
||||
(glyph-image image)))))
|
||||
(and (vectorp d)
|
||||
(aref d 0)))
|
||||
(plist-get (cdr image) :type))
|
||||
'gif)
|
||||
(= (car size) 30)
|
||||
(= (cdr size) 30))))
|
||||
;; Good image, add it!
|
||||
(let ((image (gnus-html-rescale-image image data size)))
|
||||
(delete-region start end)
|
||||
(gnus-put-image image alt-text 'external)
|
||||
(gnus-overlay-put (gnus-make-overlay start (point)) 'local-map
|
||||
gnus-html-displayed-image-map)
|
||||
(gnus-put-text-property start (point) 'gnus-alt-text alt-text)
|
||||
(when url
|
||||
(gnus-put-text-property start (point) 'gnus-image-url url))
|
||||
(gnus-add-image 'external image)
|
||||
t)
|
||||
;; Bad image, try to show something else
|
||||
(delete-region start end)
|
||||
(when (fboundp 'find-image)
|
||||
(setq image (find-image '((:type xpm :file "lock-broken.xpm"))))
|
||||
(gnus-put-image image alt-text 'internal)
|
||||
(gnus-add-image 'internal image))
|
||||
nil))))))
|
||||
|
||||
(defun gnus-html-rescale-image (image file size)
|
||||
(defun gnus-html-rescale-image (image data size)
|
||||
(if (or (not (fboundp 'imagemagick-types))
|
||||
(not (get-buffer-window (current-buffer))))
|
||||
image
|
||||
|
|
@ -414,35 +431,17 @@ fit these criteria."
|
|||
(- (nth 3 edges) (nth 1 edges)))))
|
||||
scaled-image)
|
||||
(when (> height window-height)
|
||||
(setq image (or (create-image file 'imagemagick nil
|
||||
(setq image (or (create-image data 'imagemagick t
|
||||
:height window-height)
|
||||
image))
|
||||
(setq size (image-size image t)))
|
||||
(when (> (car size) window-width)
|
||||
(setq image (or
|
||||
(create-image file 'imagemagick nil
|
||||
(create-image data 'imagemagick t
|
||||
:width window-width)
|
||||
image)))
|
||||
image)))
|
||||
|
||||
(defun gnus-html-prune-cache ()
|
||||
(let ((total-size 0)
|
||||
files)
|
||||
(dolist (file (directory-files gnus-html-cache-directory t nil t))
|
||||
(let ((attributes (file-attributes file)))
|
||||
(unless (nth 0 attributes)
|
||||
(incf total-size (nth 7 attributes))
|
||||
(push (list (time-to-seconds (nth 5 attributes))
|
||||
(nth 7 attributes) file)
|
||||
files))))
|
||||
(when (> total-size gnus-html-cache-size)
|
||||
(setq files (sort files (lambda (f1 f2)
|
||||
(< (car f1) (car f2)))))
|
||||
(dolist (file files)
|
||||
(when (> total-size gnus-html-cache-size)
|
||||
(decf total-size (cadr file))
|
||||
(delete-file (nth 2 file)))))))
|
||||
|
||||
(defun gnus-html-image-url-blocked-p (url blocked-images)
|
||||
"Find out if URL is blocked by BLOCKED-IMAGES."
|
||||
(let ((ret (and blocked-images
|
||||
|
|
@ -459,14 +458,10 @@ fit these criteria."
|
|||
This only works if the article in question is HTML."
|
||||
(interactive)
|
||||
(gnus-with-article-buffer
|
||||
(let ((overlays (overlays-in (point-min) (point-max)))
|
||||
overlay images)
|
||||
(while (setq overlay (pop overlays))
|
||||
(when (overlay-get overlay 'gnus-image)
|
||||
(push (overlay-get overlay 'gnus-image) images)))
|
||||
(if (not images)
|
||||
(message "No images to show")
|
||||
(gnus-html-schedule-image-fetching (current-buffer) images)))))
|
||||
(dolist (overlay (overlays-in (point-min) (point-max)))
|
||||
(let ((o (overlay-get overlay 'gnus-image)))
|
||||
(when o
|
||||
(apply 'gnus-html-display-image o))))))
|
||||
|
||||
;;;###autoload
|
||||
(defun gnus-html-prefetch-images (summary)
|
||||
|
|
@ -477,11 +472,9 @@ This only works if the article in question is HTML."
|
|||
(while (re-search-forward "<img.*src=[\"']\\([^\"']+\\)" nil t)
|
||||
(let ((url (match-string 1)))
|
||||
(unless (gnus-html-image-url-blocked-p url blocked-images)
|
||||
(unless (file-exists-p (gnus-html-image-id url))
|
||||
(ignore-errors
|
||||
(url-retrieve (mm-url-decode-entities-string url)
|
||||
'gnus-html-image-fetched
|
||||
(list nil (list url))))))))))))
|
||||
(when (gnus-html-cache-expired url gnus-html-image-cache-ttl)
|
||||
(gnus-html-schedule-image-fetching nil
|
||||
(list url))))))))))
|
||||
|
||||
(provide 'gnus-html)
|
||||
|
||||
|
|
|
|||
|
|
@ -275,8 +275,10 @@ If it is down, start it up (again)."
|
|||
(not gnus-batch-mode)
|
||||
(gnus-y-or-n-p
|
||||
(format
|
||||
"Unable to open server %s, go offline? "
|
||||
server)))
|
||||
"Unable to open server %s (%s), go offline? "
|
||||
server
|
||||
(nnheader-get-report
|
||||
(car gnus-command-method)))))
|
||||
(setq open-offline t)
|
||||
'offline)
|
||||
(t
|
||||
|
|
@ -552,6 +554,14 @@ If BUFFER, insert the article in that group."
|
|||
(funcall (gnus-get-function gnus-command-method 'request-post)
|
||||
(nth 1 gnus-command-method)))
|
||||
|
||||
(defun gnus-request-expunge-group (group gnus-command-method)
|
||||
"Expunge GROUP, which is removing articles that have been marked as deleted."
|
||||
(when (stringp gnus-command-method)
|
||||
(setq gnus-command-method (gnus-server-to-method gnus-command-method)))
|
||||
(funcall (gnus-get-function gnus-command-method 'request-expunge-group)
|
||||
(gnus-group-real-name group)
|
||||
(nth 1 gnus-command-method)))
|
||||
|
||||
(defun gnus-request-scan (group gnus-command-method)
|
||||
"Request a SCAN being performed in GROUP from GNUS-COMMAND-METHOD.
|
||||
If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned."
|
||||
|
|
|
|||
|
|
@ -705,6 +705,7 @@ the first newsgroup."
|
|||
nnoo-state-alist nil
|
||||
gnus-current-select-method nil
|
||||
nnmail-split-history nil
|
||||
gnus-extended-servers nil
|
||||
gnus-ephemeral-servers nil)
|
||||
(gnus-shutdown 'gnus)
|
||||
;; Kill the startup file.
|
||||
|
|
@ -1693,28 +1694,19 @@ If SCAN, request a scan of that group as well."
|
|||
(while newsrc
|
||||
(setq active (gnus-active (setq group (gnus-info-group
|
||||
(setq info (pop newsrc))))))
|
||||
|
||||
;; Check newsgroups. If the user doesn't want to check them, or
|
||||
;; they can't be checked (for instance, if the news server can't
|
||||
;; be reached) we just set the number of unread articles in this
|
||||
;; newsgroup to t. This means that Gnus thinks that there are
|
||||
;; unread articles, but it has no idea how many.
|
||||
|
||||
;; To be more explicit:
|
||||
;; >0 for an active group with messages
|
||||
;; 0 for an active group with no unread messages
|
||||
;; nil for non-foreign groups that the user has requested not be checked
|
||||
;; t for unchecked foreign groups or bogus groups, or groups that can't
|
||||
;; be checked, for one reason or other.
|
||||
|
||||
;; First go through all the groups, see what select methods they
|
||||
;; belong to, and then collect them into lists per unique select
|
||||
;; method.
|
||||
(if (not (setq method (gnus-info-method info)))
|
||||
(setq method gnus-select-method)
|
||||
;; There may be several similar methods. Possibly extend the
|
||||
;; method.
|
||||
(if (setq cmethod (assoc method methods-cache))
|
||||
(setq method (cdr cmethod))
|
||||
(setq cmethod (inline (gnus-server-get-method nil method)))
|
||||
(setq cmethod (if (stringp method)
|
||||
(gnus-server-to-method method)
|
||||
(inline (gnus-find-method-for-group
|
||||
(gnus-info-group info) info))))
|
||||
(push (cons method cmethod) methods-cache)
|
||||
(setq method cmethod)))
|
||||
(setq method-group-list (assoc method type-cache))
|
||||
|
|
|
|||
|
|
@ -5850,6 +5850,10 @@ If SELECT-ARTICLES, only select those articles from GROUP."
|
|||
(types gnus-article-mark-lists)
|
||||
marks var articles article mark mark-type
|
||||
bgn end)
|
||||
;; Hack to avoid adjusting marks for imap.
|
||||
(when (eq (car (gnus-find-method-for-group (gnus-info-group info)))
|
||||
'nnimap)
|
||||
(setq min 1))
|
||||
|
||||
(dolist (marks marked-lists)
|
||||
(setq mark (car marks)
|
||||
|
|
@ -9681,7 +9685,7 @@ ACTION can be either `move' (the default), `crosspost' or `copy'."
|
|||
gnus-newsgroup-name))
|
||||
(to-method (or select-method
|
||||
(gnus-find-method-for-group to-newsgroup)))
|
||||
(move-is-internal (gnus-method-equal from-method to-method)))
|
||||
(move-is-internal (gnus-server-equal from-method to-method)))
|
||||
(gnus-request-move-article
|
||||
article ; Article to move
|
||||
gnus-newsgroup-name ; From newsgroup
|
||||
|
|
@ -9692,7 +9696,8 @@ ACTION can be either `move' (the default), `crosspost' or `copy'."
|
|||
(not articles) t) ; Accept form
|
||||
(not articles) ; Only save nov last time
|
||||
(and move-is-internal
|
||||
(gnus-group-real-name to-newsgroup))))) ; is this move internal?
|
||||
to-newsgroup ; Not respooling
|
||||
(gnus-group-real-name to-newsgroup))))) ; Is this move internal?
|
||||
;; Copy the article.
|
||||
((eq action 'copy)
|
||||
(with-current-buffer copy-buf
|
||||
|
|
|
|||
|
|
@ -2682,6 +2682,7 @@ a string, be sure to use a valid format, see RFC 2616."
|
|||
(defvar gnus-newsgroup-name nil)
|
||||
(defvar gnus-ephemeral-servers nil)
|
||||
(defvar gnus-server-method-cache nil)
|
||||
(defvar gnus-extended-servers nil)
|
||||
|
||||
(defvar gnus-agent-fetching nil
|
||||
"Whether Gnus agent is in fetching mode.")
|
||||
|
|
@ -3686,32 +3687,35 @@ that that variable is buffer-local to the summary buffers."
|
|||
(and
|
||||
(eq (car m1) (car m2))
|
||||
(equal (cadr m1) (cadr m2))
|
||||
;; Check parameters for sloppy equalness.
|
||||
(let ((p1 (copy-list (cddr m1)))
|
||||
(p2 (copy-list (cddr m2)))
|
||||
e1 e2)
|
||||
(block nil
|
||||
(while (setq e1 (pop p1))
|
||||
(unless (setq e2 (assq (car e1) p2))
|
||||
;; The parameter doesn't exist in p2.
|
||||
(return nil))
|
||||
(setq p2 (delq e2 p2))
|
||||
(unless (equalp e1 e2)
|
||||
(if (not (and (stringp (cadr e1))
|
||||
(stringp (cadr e2))))
|
||||
(return nil)
|
||||
;; Special-case string parameter comparison so that we
|
||||
;; can uniquify them.
|
||||
(let ((s1 (cadr e1))
|
||||
(s2 (cadr e2)))
|
||||
(when (string-match "/$" s1)
|
||||
(setq s1 (directory-file-name s1)))
|
||||
(when (string-match "/$" s2)
|
||||
(setq s2 (directory-file-name s2)))
|
||||
(unless (equal s1 s2)
|
||||
(return nil))))))
|
||||
;; If p2 now is empty, they were equal.
|
||||
(null p2))))))
|
||||
(gnus-sloppily-equal-method-parameters m1 m2))))
|
||||
|
||||
(defsubst gnus-sloppily-equal-method-parameters (m1 m2)
|
||||
;; Check parameters for sloppy equalness.
|
||||
(let ((p1 (copy-list (cddr m1)))
|
||||
(p2 (copy-list (cddr m2)))
|
||||
e1 e2)
|
||||
(block nil
|
||||
(while (setq e1 (pop p1))
|
||||
(unless (setq e2 (assq (car e1) p2))
|
||||
;; The parameter doesn't exist in p2.
|
||||
(return nil))
|
||||
(setq p2 (delq e2 p2))
|
||||
(unless (equalp e1 e2)
|
||||
(if (not (and (stringp (cadr e1))
|
||||
(stringp (cadr e2))))
|
||||
(return nil)
|
||||
;; Special-case string parameter comparison so that we
|
||||
;; can uniquify them.
|
||||
(let ((s1 (cadr e1))
|
||||
(s2 (cadr e2)))
|
||||
(when (string-match "/$" s1)
|
||||
(setq s1 (directory-file-name s1)))
|
||||
(when (string-match "/$" s2)
|
||||
(setq s2 (directory-file-name s2)))
|
||||
(unless (equal s1 s2)
|
||||
(return nil))))))
|
||||
;; If p2 now is empty, they were equal.
|
||||
(null p2))))
|
||||
|
||||
(defun gnus-server-equal (m1 m2)
|
||||
"Say whether two methods are equal."
|
||||
|
|
@ -4200,9 +4204,12 @@ parameters."
|
|||
(if (or (not (inline (gnus-similar-server-opened method)))
|
||||
(not (cddr method)))
|
||||
method
|
||||
`(,(car method) ,(concat (cadr method) "+" group)
|
||||
(,(intern (format "%s-address" (car method))) ,(cadr method))
|
||||
,@(cddr method))))
|
||||
(setq method
|
||||
`(,(car method) ,(concat (cadr method) "+" group)
|
||||
(,(intern (format "%s-address" (car method))) ,(cadr method))
|
||||
,@(cddr method)))
|
||||
(push method gnus-extended-servers)
|
||||
method))
|
||||
|
||||
(defun gnus-server-status (method)
|
||||
"Return the status of METHOD."
|
||||
|
|
@ -4227,6 +4234,20 @@ parameters."
|
|||
(format "%s using %s" address (car server))
|
||||
(format "%s" (car server)))))
|
||||
|
||||
(defun gnus-same-method-different-name (method)
|
||||
(let ((slot (intern (concat (symbol-name (car method)) "-address"))))
|
||||
(unless (assq slot (cddr method))
|
||||
(setq method
|
||||
(append method (list (list slot (nth 1 method)))))))
|
||||
(let ((methods gnus-extended-servers)
|
||||
open found)
|
||||
(while (and (not found)
|
||||
(setq open (pop methods)))
|
||||
(when (and (eq (car method) (car open))
|
||||
(gnus-sloppily-equal-method-parameters method open))
|
||||
(setq found open)))
|
||||
found))
|
||||
|
||||
(defun gnus-find-method-for-group (group &optional info)
|
||||
"Find the select method that GROUP uses."
|
||||
(or gnus-override-method
|
||||
|
|
@ -4249,7 +4270,10 @@ parameters."
|
|||
(cond ((stringp method)
|
||||
(inline (gnus-server-to-method method)))
|
||||
((stringp (cadr method))
|
||||
(inline (gnus-server-extend-method group method)))
|
||||
(or
|
||||
(inline
|
||||
(gnus-same-method-different-name method))
|
||||
(inline (gnus-server-extend-method group method))))
|
||||
(t
|
||||
method)))
|
||||
(cond ((equal (cadr method) "")
|
||||
|
|
|
|||
|
|
@ -37,6 +37,7 @@
|
|||
(require 'gnus)
|
||||
(require 'nnoo)
|
||||
(require 'netrc)
|
||||
(require 'parse-time)
|
||||
|
||||
(nnoo-declare nnimap)
|
||||
|
||||
|
|
@ -77,6 +78,8 @@ will fetch all parts that have types that match that string. A
|
|||
likely value would be \"text/\" to automatically fetch all
|
||||
textual parts.")
|
||||
|
||||
(defvoo nnimap-expunge nil)
|
||||
|
||||
(defvoo nnimap-connection-alist nil)
|
||||
|
||||
(defvoo nnimap-current-infos nil)
|
||||
|
|
@ -405,7 +408,7 @@ textual parts.")
|
|||
(with-current-buffer (nnimap-buffer)
|
||||
(erase-buffer)
|
||||
(let ((group-sequence
|
||||
(nnimap-send-command "SELECT %S" (utf7-encode group)))
|
||||
(nnimap-send-command "SELECT %S" (utf7-encode group t)))
|
||||
(flag-sequence
|
||||
(nnimap-send-command "UID FETCH 1:* FLAGS")))
|
||||
(nnimap-wait-for-response flag-sequence)
|
||||
|
|
@ -421,20 +424,28 @@ textual parts.")
|
|||
(setq high (nth 3 (car marks))
|
||||
low (nth 4 (car marks))))
|
||||
((re-search-backward "UIDNEXT \\([0-9]+\\)" nil t)
|
||||
(setq high (string-to-number (match-string 1))
|
||||
(setq high (1- (string-to-number (match-string 1)))
|
||||
low 1)))))
|
||||
(erase-buffer)
|
||||
(insert
|
||||
(format
|
||||
"211 %d %d %d %S\n"
|
||||
(1+ (- high low))
|
||||
low high group))))
|
||||
t)))
|
||||
"211 %d %d %d %S\n" (1+ (- high low)) low high group)))
|
||||
t))))
|
||||
|
||||
(deffoo nnimap-request-create-group (group &optional server args)
|
||||
(when (nnimap-possibly-change-group nil server)
|
||||
(with-current-buffer (nnimap-buffer)
|
||||
(car (nnimap-command "CREATE %S" (utf7-encode group t))))))
|
||||
|
||||
(deffoo nnimap-request-delete-group (group &optional force server)
|
||||
(when (nnimap-possibly-change-group nil server)
|
||||
(with-current-buffer (nnimap-buffer)
|
||||
(car (nnimap-command "DELETE %S" (utf7-encode group))))))
|
||||
(car (nnimap-command "DELETE %S" (utf7-encode group t))))))
|
||||
|
||||
(deffoo nnimap-request-expunge-group (group &optional server)
|
||||
(when (nnimap-possibly-change-group group server)
|
||||
(with-current-buffer (nnimap-buffer)
|
||||
(car (nnimap-command "EXPUNGE")))))
|
||||
|
||||
(defun nnimap-get-flags (spec)
|
||||
(let ((articles nil)
|
||||
|
|
@ -456,38 +467,95 @@ textual parts.")
|
|||
|
||||
(deffoo nnimap-request-move-article (article group server accept-form
|
||||
&optional last internal-move-group)
|
||||
(when (nnimap-possibly-change-group group server)
|
||||
;; If the move is internal (on the same server), just do it the easy
|
||||
;; way.
|
||||
(let ((message-id (message-field-value "message-id")))
|
||||
(if internal-move-group
|
||||
(let ((result
|
||||
(with-current-buffer (nnimap-buffer)
|
||||
(nnimap-command "UID COPY %d %S"
|
||||
article
|
||||
(utf7-encode internal-move-group t)))))
|
||||
(when (car result)
|
||||
(nnimap-delete-article article)
|
||||
(cons internal-move-group
|
||||
(nnimap-find-article-by-message-id
|
||||
internal-move-group message-id))))
|
||||
(with-temp-buffer
|
||||
(when (nnimap-request-article article group server (current-buffer))
|
||||
(let ((result (eval accept-form)))
|
||||
(when result
|
||||
(with-temp-buffer
|
||||
(when (nnimap-request-article article group server (current-buffer))
|
||||
;; If the move is internal (on the same server), just do it the easy
|
||||
;; way.
|
||||
(let ((message-id (message-field-value "message-id")))
|
||||
(if internal-move-group
|
||||
(let ((result
|
||||
(with-current-buffer (nnimap-buffer)
|
||||
(nnimap-command "UID COPY %d %S"
|
||||
article
|
||||
(utf7-encode internal-move-group t)))))
|
||||
(when (car result)
|
||||
(nnimap-delete-article article)
|
||||
result))))))))
|
||||
(cons internal-move-group
|
||||
(nnimap-find-article-by-message-id
|
||||
internal-move-group message-id))))
|
||||
;; Move the article to a different method.
|
||||
(let ((result (eval accept-form)))
|
||||
(when result
|
||||
(nnimap-delete-article article)
|
||||
result)))))))
|
||||
|
||||
(deffoo nnimap-request-expire-articles (articles group &optional server force)
|
||||
(cond
|
||||
((null articles)
|
||||
nil)
|
||||
((not (nnimap-possibly-change-group group server))
|
||||
articles)
|
||||
(force
|
||||
((and force
|
||||
(eq nnmail-expiry-target 'delete))
|
||||
(unless (nnimap-delete-article articles)
|
||||
(message "Article marked for deletion, but not expunged."))
|
||||
nil)
|
||||
(t
|
||||
articles)))
|
||||
(let ((deletable-articles
|
||||
(if force
|
||||
articles
|
||||
(gnus-sorted-intersection
|
||||
articles
|
||||
(nnimap-find-expired-articles group)))))
|
||||
(if (null deletable-articles)
|
||||
articles
|
||||
(if (eq nnmail-expiry-target 'delete)
|
||||
(nnimap-delete-article deletable-articles)
|
||||
(setq deletable-articles
|
||||
(nnimap-process-expiry-targets
|
||||
deletable-articles group server)))
|
||||
;; Return the articles we didn't delete.
|
||||
(gnus-sorted-complement articles deletable-articles))))))
|
||||
|
||||
(defun nnimap-process-expiry-targets (articles group server)
|
||||
(let ((deleted-articles nil))
|
||||
(dolist (article articles)
|
||||
(let ((target nnmail-expiry-target))
|
||||
(with-temp-buffer
|
||||
(when (nnimap-request-article article group server (current-buffer))
|
||||
(message "Expiring article %s:%d" group article)
|
||||
(when (functionp target)
|
||||
(setq target (funcall target group)))
|
||||
(when (and target
|
||||
(not (eq target 'delete)))
|
||||
(if (or (gnus-request-group target t)
|
||||
(gnus-request-create-group target))
|
||||
(nnmail-expiry-target-group target group)
|
||||
(setq target nil)))
|
||||
(when target
|
||||
(push article deleted-articles))))))
|
||||
;; Change back to the current group again.
|
||||
(nnimap-possibly-change-group group server)
|
||||
(setq deleted-articles (nreverse deleted-articles))
|
||||
(nnimap-delete-article deleted-articles)
|
||||
deleted-articles))
|
||||
|
||||
(defun nnimap-find-expired-articles (group)
|
||||
(let ((cutoff (nnmail-expired-article-p group nil nil)))
|
||||
(with-current-buffer (nnimap-buffer)
|
||||
(let ((result
|
||||
(nnimap-command
|
||||
"UID SEARCH SENTBEFORE %s"
|
||||
(format-time-string
|
||||
(format "%%d-%s-%%Y"
|
||||
(upcase
|
||||
(car (rassoc (nth 4 (decode-time cutoff))
|
||||
parse-time-months))))
|
||||
cutoff))))
|
||||
(and (car result)
|
||||
(delete 0 (mapcar #'string-to-number
|
||||
(cdr (assoc "SEARCH" (cdr result))))))))))
|
||||
|
||||
|
||||
(defun nnimap-find-article-by-message-id (group message-id)
|
||||
(when (nnimap-possibly-change-group group nil)
|
||||
|
|
@ -505,10 +573,14 @@ textual parts.")
|
|||
(with-current-buffer (nnimap-buffer)
|
||||
(nnimap-command "UID STORE %s +FLAGS.SILENT (\\Deleted)"
|
||||
(nnimap-article-ranges articles))
|
||||
(when (member "UIDPLUS" (nnimap-capabilities nnimap-object))
|
||||
(nnimap-send-command "UID EXPUNGE %s"
|
||||
(nnimap-article-ranges articles))
|
||||
t)))
|
||||
(cond
|
||||
((member "UIDPLUS" (nnimap-capabilities nnimap-object))
|
||||
(nnimap-command "UID EXPUNGE %s"
|
||||
(nnimap-article-ranges articles))
|
||||
t)
|
||||
(nnimap-expunge
|
||||
(nnimap-command "EXPUNGE")
|
||||
t))))
|
||||
|
||||
(deffoo nnimap-request-scan (&optional group server)
|
||||
(when (and (nnimap-possibly-change-group nil server)
|
||||
|
|
@ -1040,17 +1112,19 @@ textual parts.")
|
|||
(defun nnimap-mark-and-expunge-incoming (range)
|
||||
(when range
|
||||
(setq range (nnimap-article-ranges range))
|
||||
(nnimap-send-command
|
||||
"UID STORE %s +FLAGS.SILENT (\\Deleted)" range)
|
||||
(cond
|
||||
;; If the server supports it, we now delete the message we have
|
||||
;; just copied over.
|
||||
((member "UIDPLUS" (nnimap-capabilities nnimap-object))
|
||||
(nnimap-send-command "UID EXPUNGE %s" range))
|
||||
;; If it doesn't support UID EXPUNGE, then we only expunge if the
|
||||
;; user has configured it.
|
||||
(nnimap-expunge-inbox
|
||||
(nnimap-send-command "EXPUNGE")))))
|
||||
(let ((sequence
|
||||
(nnimap-send-command
|
||||
"UID STORE %s +FLAGS.SILENT (\\Deleted)" range)))
|
||||
(cond
|
||||
;; If the server supports it, we now delete the message we have
|
||||
;; just copied over.
|
||||
((member "UIDPLUS" (nnimap-capabilities nnimap-object))
|
||||
(setq sequence (nnimap-send-command "UID EXPUNGE %s" range)))
|
||||
;; If it doesn't support UID EXPUNGE, then we only expunge if the
|
||||
;; user has configured it.
|
||||
(nnimap-expunge-inbox
|
||||
(setq sequence (nnimap-send-command "EXPUNGE"))))
|
||||
(nnimap-wait-for-response sequence))))
|
||||
|
||||
(defun nnimap-parse-copied-articles (sequences)
|
||||
(let (sequence copied range)
|
||||
|
|
|
|||
|
|
@ -1858,9 +1858,12 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
|
|||
(run-hooks 'nnmail-post-get-new-mail-hook))))
|
||||
|
||||
(defun nnmail-expired-article-p (group time force &optional inhibit)
|
||||
"Say whether an article that is TIME old in GROUP should be expired."
|
||||
"Say whether an article that is TIME old in GROUP should be expired.
|
||||
If TIME is nil, then return the cutoff time for oldness instead."
|
||||
(if force
|
||||
t
|
||||
(if (null time)
|
||||
(current-time)
|
||||
t)
|
||||
(let ((days (or (and nnmail-expiry-wait-function
|
||||
(funcall nnmail-expiry-wait-function group))
|
||||
nnmail-expiry-wait)))
|
||||
|
|
@ -1871,14 +1874,18 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
|
|||
nil)
|
||||
((eq days 'immediate)
|
||||
;; We expire all articles on sight.
|
||||
t)
|
||||
(if (null time)
|
||||
(current-time)
|
||||
t))
|
||||
((equal time '(0 0))
|
||||
;; This is an ange-ftp group, and we don't have any dates.
|
||||
nil)
|
||||
((numberp days)
|
||||
(setq days (days-to-time days))
|
||||
;; Compare the time with the current time.
|
||||
(ignore-errors (time-less-p days (time-since time))))))))
|
||||
(if (null time)
|
||||
(time-subtract (current-time) days)
|
||||
(ignore-errors (time-less-p days (time-since time)))))))))
|
||||
|
||||
(declare-function gnus-group-mark-article-read "gnus-group" (group article))
|
||||
|
||||
|
|
|
|||
|
|
@ -942,22 +942,23 @@ Unless no-active is non-nil, update the active file too."
|
|||
(when (file-exists-p nov)
|
||||
(funcall nnmail-delete-file-function nov))
|
||||
(dolist (file files)
|
||||
(unless (file-directory-p (setq file (concat dir (cdr file))))
|
||||
(erase-buffer)
|
||||
(nnheader-insert-file-contents file)
|
||||
(narrow-to-region
|
||||
(goto-char (point-min))
|
||||
(progn
|
||||
(re-search-forward "\n\r?\n" nil t)
|
||||
(setq chars (- (point-max) (point)))
|
||||
(max (point-min) (1- (point)))))
|
||||
(unless (zerop (buffer-size))
|
||||
(goto-char (point-min))
|
||||
(setq headers (nnml-parse-head chars (car file)))
|
||||
(with-current-buffer nov-buffer
|
||||
(goto-char (point-max))
|
||||
(nnheader-insert-nov headers)))
|
||||
(widen)))
|
||||
(let ((path (concat dir (cdr file))))
|
||||
(unless (file-directory-p path)
|
||||
(erase-buffer)
|
||||
(nnheader-insert-file-contents path)
|
||||
(narrow-to-region
|
||||
(goto-char (point-min))
|
||||
(progn
|
||||
(re-search-forward "\n\r?\n" nil t)
|
||||
(setq chars (- (point-max) (point)))
|
||||
(max (point-min) (1- (point)))))
|
||||
(unless (zerop (buffer-size))
|
||||
(goto-char (point-min))
|
||||
(setq headers (nnml-parse-head chars (car file)))
|
||||
(with-current-buffer nov-buffer
|
||||
(goto-char (point-max))
|
||||
(nnheader-insert-nov headers)))
|
||||
(widen))))
|
||||
(with-current-buffer nov-buffer
|
||||
(nnmail-write-region (point-min) (point-max) nov nil 'nomesg)
|
||||
(kill-buffer (current-buffer))))))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
@echo off
|
||||
rem ----------------------------------------------------------------------
|
||||
rem Configuration script for MS Windows 95/98/Me and NT/2000/XP
|
||||
rem Configuration script for MS Windows operating systems
|
||||
rem Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005,
|
||||
rem 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
|
||||
|
||||
|
|
@ -22,7 +22,7 @@ rem along with GNU Emacs. If not, see http://www.gnu.org/licenses/.
|
|||
rem ----------------------------------------------------------------------
|
||||
rem YOU'LL NEED THE FOLLOWING UTILITIES TO MAKE EMACS:
|
||||
rem
|
||||
rem + MS Windows 95/98/Me or NT/2000/XP
|
||||
rem + MS Windows 95, NT or later
|
||||
rem + either MSVC 2.x or later, or gcc-2.95 or later (with GNU make 3.75
|
||||
rem or later) and the Mingw32 and W32 API headers and libraries.
|
||||
rem + Visual Studio 2005 is not supported at this time.
|
||||
|
|
@ -116,6 +116,7 @@ if "%1" == "--without-xpm" goto withoutxpm
|
|||
if "%1" == "--with-svg" goto withsvg
|
||||
if "%1" == "--distfiles" goto distfiles
|
||||
if "%1" == "" goto checkutils
|
||||
|
||||
:usage
|
||||
echo Usage: configure [options]
|
||||
echo Options:
|
||||
|
|
@ -137,61 +138,82 @@ echo. --without-xpm do not use XPM library even if it is installed
|
|||
echo. --with-svg use the RSVG library (experimental)
|
||||
echo. --distfiles path to files for make dist, e.g. libXpm.dll
|
||||
goto end
|
||||
|
||||
rem ----------------------------------------------------------------------
|
||||
|
||||
:setprefix
|
||||
shift
|
||||
set prefix=%1
|
||||
shift
|
||||
goto again
|
||||
|
||||
rem ----------------------------------------------------------------------
|
||||
|
||||
:withgcc
|
||||
set COMPILER=gcc
|
||||
shift
|
||||
goto again
|
||||
|
||||
rem ----------------------------------------------------------------------
|
||||
|
||||
:withmsvc
|
||||
set COMPILER=cl
|
||||
shift
|
||||
goto again
|
||||
|
||||
rem ----------------------------------------------------------------------
|
||||
|
||||
:nodebug
|
||||
set nodebug=Y
|
||||
shift
|
||||
goto again
|
||||
|
||||
rem ----------------------------------------------------------------------
|
||||
|
||||
:noopt
|
||||
set noopt=Y
|
||||
shift
|
||||
goto again
|
||||
|
||||
rem ----------------------------------------------------------------------
|
||||
|
||||
:enablechecking
|
||||
set enablechecking=Y
|
||||
shift
|
||||
goto again
|
||||
|
||||
rem ----------------------------------------------------------------------
|
||||
|
||||
:profile
|
||||
set profile=Y
|
||||
shift
|
||||
goto again
|
||||
|
||||
rem ----------------------------------------------------------------------
|
||||
|
||||
:nocygwin
|
||||
set nocygwin=Y
|
||||
shift
|
||||
goto again
|
||||
|
||||
rem ----------------------------------------------------------------------
|
||||
|
||||
:usercflags
|
||||
shift
|
||||
set usercflags=%usercflags%%sep1%%1
|
||||
set sep1= %nothing%
|
||||
shift
|
||||
goto again
|
||||
|
||||
rem ----------------------------------------------------------------------
|
||||
|
||||
:userldflags
|
||||
shift
|
||||
set userldflags=%userldflags%%sep2%%1
|
||||
set sep2= %nothing%
|
||||
shift
|
||||
goto again
|
||||
|
||||
rem ----------------------------------------------------------------------
|
||||
|
||||
:withoutpng
|
||||
|
|
@ -249,6 +271,7 @@ goto again
|
|||
|
||||
rem ----------------------------------------------------------------------
|
||||
rem Check that necessary utilities (cp and rm) are present.
|
||||
|
||||
:checkutils
|
||||
echo Checking for 'cp'...
|
||||
cp configure.bat junk.bat
|
||||
|
|
@ -257,9 +280,11 @@ echo Checking for 'rm'...
|
|||
rm junk.bat
|
||||
if exist junk.bat goto needrm
|
||||
goto checkcompiler
|
||||
|
||||
:needcp
|
||||
echo You need 'cp' (the Unix file copy program) to build Emacs.
|
||||
goto end
|
||||
|
||||
:needrm
|
||||
del junk.bat
|
||||
echo You need 'rm' (the Unix file delete program) to build Emacs.
|
||||
|
|
@ -267,6 +292,7 @@ goto end
|
|||
|
||||
rem ----------------------------------------------------------------------
|
||||
rem Auto-detect compiler if not specified, and validate GCC if chosen.
|
||||
|
||||
:checkcompiler
|
||||
if (%COMPILER%)==(cl) goto compilercheckdone
|
||||
if (%COMPILER%)==(gcc) goto checkgcc
|
||||
|
|
@ -301,6 +327,7 @@ if exist junk.o set nocygwin=Y
|
|||
:chkapi
|
||||
echo The failed program was: >>config.log
|
||||
type junk.c >>config.log
|
||||
|
||||
:chkapiN
|
||||
rm -f junk.c junk.o
|
||||
rem ----------------------------------------------------------------------
|
||||
|
|
@ -320,8 +347,10 @@ echo {PIMAGE_SECTION_HEADER pSection = IMAGE_FIRST_SECTION(pHeader);} >>junk.c
|
|||
if (%nocygwin%) == (Y) goto chkapi1
|
||||
set cf=%usercflags%
|
||||
goto chkapi2
|
||||
|
||||
:chkapi1
|
||||
set cf=%usercflags% -mno-cygwin
|
||||
|
||||
:chkapi2
|
||||
echo on
|
||||
gcc %cf% -c junk.c
|
||||
|
|
@ -357,10 +386,12 @@ type junk.c >>config.log
|
|||
set mf=-mcpu=i686
|
||||
rm -f junk.c junk.o
|
||||
goto gccdebug
|
||||
|
||||
:gccMtuneOk
|
||||
echo GCC supports -mtune=pentium4 >>config.log
|
||||
set mf=-mtune=pentium4
|
||||
rm -f junk.c junk.o
|
||||
|
||||
:gccdebug
|
||||
rem Check for DWARF-2 debug info support, else default to stabs
|
||||
echo main(){} >junk.c
|
||||
|
|
@ -372,6 +403,7 @@ type junk.c >>config.log
|
|||
set dbginfo=-gstabs+
|
||||
rm -f junk.c junk.o
|
||||
goto compilercheckdone
|
||||
|
||||
:gccdwarf
|
||||
echo GCC supports DWARF-2 >>config.log
|
||||
set dbginfo=-gdwarf-2 -g3
|
||||
|
|
@ -565,6 +597,7 @@ goto :distfilesDone
|
|||
set fileNotFound=
|
||||
|
||||
rem ----------------------------------------------------------------------
|
||||
|
||||
:genmakefiles
|
||||
echo Generating makefiles
|
||||
if %COMPILER% == gcc set MAKECMD=gmake
|
||||
|
|
@ -619,6 +652,7 @@ fc /b config.tmp ..\src\config.h >nul 2>&1
|
|||
if errorlevel 1 goto doCopy
|
||||
fc /b paths.h ..\src\epaths.h >nul 2>&1
|
||||
if errorlevel 0 goto dontCopy
|
||||
|
||||
:doCopy
|
||||
copy config.tmp ..\src\config.h
|
||||
copy paths.h ..\src\epaths.h
|
||||
|
|
@ -648,6 +682,7 @@ fc /b foo.bar foo.bar >nul 2>&1
|
|||
if not errorlevel 2 goto doUpdateSubdirs
|
||||
fc /b subdirs.el ..\site-lisp\subdirs.el >nul 2>&1
|
||||
if not errorlevel 1 goto dontUpdateSubdirs
|
||||
|
||||
:doUpdateSubdirs
|
||||
if exist ..\site-lisp\subdirs.el del ..\site-lisp\subdirs.el
|
||||
copy subdirs.el ..\site-lisp\subdirs.el
|
||||
|
|
@ -716,6 +751,7 @@ goto end
|
|||
echo Your environment size is too small. Please enlarge it and rerun configure.
|
||||
echo For example, type "command.com /e:2048" to have 2048 bytes available.
|
||||
set $foo$=
|
||||
|
||||
:end
|
||||
set prefix=
|
||||
set nodebug=
|
||||
|
|
|
|||
|
|
@ -10,6 +10,15 @@
|
|||
current display element is a grapheme cluster in bidi-reordered
|
||||
region.
|
||||
|
||||
2010-09-21 Ari Roponen <ari.roponen@gmail.com> (tiny change)
|
||||
|
||||
* doc.c (Fsnarf_documentation): Use memmove instead of memcpy as
|
||||
the regions may overlap.
|
||||
|
||||
2010-09-21 Juanma Barranquero <lekktu@gmail.com>
|
||||
|
||||
* makefile.w32-in ($(BLD)/sysdep.$(O)): Update dependencies.
|
||||
|
||||
2010-09-21 Dan Nicolaescu <dann@ics.uci.edu>
|
||||
|
||||
* emacs.c: Do not include sys/ioctl.h, not needed.
|
||||
|
|
|
|||
|
|
@ -678,7 +678,7 @@ the same file name is found in the `doc-directory'. */)
|
|||
}
|
||||
pos += end - buf;
|
||||
filled -= end - buf;
|
||||
memcpy (buf, end, filled);
|
||||
memmove (buf, end, filled);
|
||||
}
|
||||
emacs_close (fd);
|
||||
return Qnil;
|
||||
|
|
|
|||
|
|
@ -1344,7 +1344,6 @@ $(BLD)/sysdep.$(O) : \
|
|||
$(EMACS_ROOT)/nt/inc/pwd.h \
|
||||
$(EMACS_ROOT)/nt/inc/unistd.h \
|
||||
$(EMACS_ROOT)/nt/inc/sys/file.h \
|
||||
$(EMACS_ROOT)/nt/inc/sys/ioctl.h \
|
||||
$(EMACS_ROOT)/nt/inc/sys/socket.h \
|
||||
$(EMACS_ROOT)/nt/inc/sys/time.h \
|
||||
$(SRC)/lisp.h \
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue