Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Open sidebar
emacs
emacs
Commits
1114abdb
Commit
1114abdb
authored
Sep 22, 2010
by
Kenichi Handa
Browse files
merge trunk
parents
86282aab
ee705a5c
Changes
18
Hide whitespace changes
Inline
Side-by-side
Showing
18 changed files
with
570 additions
and
312 deletions
+570
-312
doc/misc/ChangeLog
doc/misc/ChangeLog
+5
-0
doc/misc/gnus.texi
doc/misc/gnus.texi
+1
-1
lisp/ChangeLog
lisp/ChangeLog
+7
-0
lisp/emacs-lisp/smie.el
lisp/emacs-lisp/smie.el
+24
-5
lisp/gnus/ChangeLog
lisp/gnus/ChangeLog
+78
-0
lisp/gnus/gnus-group.el
lisp/gnus/gnus-group.el
+14
-15
lisp/gnus/gnus-html.el
lisp/gnus/gnus-html.el
+167
-174
lisp/gnus/gnus-int.el
lisp/gnus/gnus-int.el
+12
-2
lisp/gnus/gnus-start.el
lisp/gnus/gnus-start.el
+7
-15
lisp/gnus/gnus-sum.el
lisp/gnus/gnus-sum.el
+7
-2
lisp/gnus/gnus.el
lisp/gnus/gnus.el
+54
-30
lisp/gnus/nnimap.el
lisp/gnus/nnimap.el
+118
-44
lisp/gnus/nnmail.el
lisp/gnus/nnmail.el
+11
-4
lisp/gnus/nnml.el
lisp/gnus/nnml.el
+17
-16
nt/configure.bat
nt/configure.bat
+38
-2
src/ChangeLog
src/ChangeLog
+9
-0
src/doc.c
src/doc.c
+1
-1
src/makefile.w32-in
src/makefile.w32-in
+0
-1
No files found.
doc/misc/ChangeLog
View file @
1114abdb
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
...
...
doc/misc/gnus.texi
View file @
1114abdb
...
...
@@ -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
lisp/ChangeLog
View file @
1114abdb
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.
...
...
lisp/emacs-lisp/smie.el
View file @
1114abdb
...
...
@@ -338,7 +338,7 @@ CSTS is a list of pairs representing arcs in a graph."
res
))
cycle
)))
(
mapconcat
(
lambda
(
elems
)
(
mapconcat
'i
n
dentity
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
...
...
lisp/gnus/ChangeLog
View file @
1114abdb
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.
...
...
lisp/gnus/gnus-group.el
View file @
1114abdb
...
...
@@ -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
((
m
ailbox
(
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
((
m
ethod
(
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."
...
...
lisp/gnus/gnus-html.el
View file @
1114abdb
...
...
@@ -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
(
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-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
)
;; 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
)))))))
(
defun
gnus-html-put-image
(
file
point
string
&optional
url
alt-text
)
(
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
)))))
(
defun
gnus-html-rescale-image
(
image
file
size
)
(
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
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
)))))))