Commit 1114abdb authored by Kenichi Handa's avatar Kenichi Handa
Browse files

merge trunk

parents 86282aab ee705a5c
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
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,8 +1293,9 @@ 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-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
......
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.
......@@ -163,6 +173,9 @@ fit these criteria."
(gnus-put-image image (gnus-string-or string "*") 'cid)
(gnus-add-image 'cid image))))
;; Normal, external URL.
(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)
......@@ -179,41 +192,44 @@ fit these criteria."
(let ((overlay (gnus-make-overlay start end))
(spec (list url
(set-marker (make-marker) start)
(set-marker (make-marker) end))))
(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)))
(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))))
;; Non-blocked url
(let ((width
(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)))
(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)))
(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))
(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.
(push (list url
(gnus-html-schedule-image-fetching
(current-buffer)
(list url
(set-marker (make-marker) start)
(point-marker))
images))))))))
(when images
(gnus-html-schedule-image-fetching (current-buffer) (nreverse images)))))
(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,49 +336,54 @@ 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)
(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-id (url)
(expand-file-name (sha1 url) gnus-html-cache-directory))
(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)
(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)) (point-min))))
(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)
(string (buffer-substring (cadr image) (caddr image))))
(delete-region (cadr image) (caddr image))
(gnus-html-put-image file (cadr image) (car image) string)))))))
(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-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 (file point string &optional url alt-text)
(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)))
(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)
(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.
......@@ -371,37 +391,34 @@ fit these criteria."
(glyphp image)
(listp image))
(eq (if (featurep 'xemacs)
(let ((data (cdadar (specifier-spec-list
(let ((d (cdadar (specifier-spec-list
(glyph-image image)))))
(and (vectorp data)
(aref data 0)))
(and (vectorp d)
(aref d 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
;; 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)))
(gnus-put-text-property start (point) 'gnus-image-url url))
(gnus-add-image 'external image)
t)
(insert string)
;; 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
(gnus-string-or string "*")
'internal)
(gnus-put-image image alt-text 'internal)
(gnus-add-image 'internal image))
nil)))))
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