summaryrefslogtreecommitdiff
path: root/lisp/gnus
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/gnus')
-rw-r--r--lisp/gnus/ChangeLog96
-rw-r--r--lisp/gnus/ChangeLog.12
-rw-r--r--lisp/gnus/auth-source.el164
-rw-r--r--lisp/gnus/gnus-demon.el5
-rw-r--r--lisp/gnus/gnus-msg.el20
-rw-r--r--lisp/gnus/gnus-registry.el136
-rw-r--r--lisp/gnus/gnus-win.el27
-rw-r--r--lisp/gnus/gnus.el21
-rw-r--r--lisp/gnus/legacy-gnus-agent.el18
-rw-r--r--lisp/gnus/nndraft.el3
-rw-r--r--lisp/gnus/nnimap.el2
-rw-r--r--lisp/gnus/nnspool.el20
-rw-r--r--lisp/gnus/nntp.el38
-rw-r--r--lisp/gnus/nnweb.el2
-rw-r--r--lisp/gnus/plstore.el147
15 files changed, 495 insertions, 206 deletions
diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog
index 05eb0dd76c6..df3fa715751 100644
--- a/lisp/gnus/ChangeLog
+++ b/lisp/gnus/ChangeLog
@@ -1,19 +1,97 @@
-2012-05-21 Katsumi Yamaoka <yamaoka@jpl.org>
+2012-06-07 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-msg.el (gnus-msg-mail): Warn the user about Gnus not running
+ (bug#11514).
+
+2012-06-01 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * nntp.el: Stop the `letf' madness.
+ (nntp--report-1): New var.
+ (nntp-report): Merge nntp-report-1 into it.
+ (nntp-with-open-group-function): Set nntp--report-1 instead of modifying
+ the nntp-report function.
+
+ * auth-source.el: Fix comment-style to follow the convention.
+
+2012-05-27 Katsumi Yamaoka <yamaoka@jpl.org>
* gnus-msg.el (gnus-msg-mail): Ensure that gnus-newsgroup-name is
a string so that Gcc works (bug#11514).
-2012-04-21 Andreas Schwab <schwab@linux-m68k.org>
+2012-05-26 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * legacy-gnus-agent.el (gnus-agent-unhook-expire-days):
+ * gnus-demon.el (gnus-demon-init): Don't bother with type-of.
+
+2012-05-25 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * gnus-win.el (gnus-configure-frame): Don't signal an error when
+ jumping to *Server* from a dedicated *Group* window.
+ (gnus-configure-frame): CSE.
+
+ * gnus-registry.el: Minor style cleanup.
+ (gnus-registry--set/remove-mark): New function, extracted from
+ gnus-registry-install-shortcuts.
+ (gnus-registry-install-shortcuts): Use it.
+
+2012-05-25 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * nnspool.el (news-path): Use eval-and-compile.
+
+2012-05-24 Glenn Morris <rgm@gnu.org>
+
+ * nnspool.el (news-directory, news-path, news-inews-program):
+ Move here from paths.el. Don't see a need for these to be autoloaded.
+
+ * gnus.el (gnus-default-nntp-server): Make it a defcustom.
+ Merge in doc from paths.el version. Don't see any need for this to be
+ autoloaded, or for the warning about users not setting it.
+
+2012-05-04 Paul Eggert <eggert@cs.ucla.edu>
+
+ Fix minor Y10k bug.
+ * nnweb.el (nnweb-google-parse-1): Don't assume years have 4 digits.
+
+2012-05-01 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * nnimap.el (nnimap-open-connection-1): Don't leave an "opening..."
+ message once it's actually open.
+
+2012-04-28 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * auth-source.el (auth-source--aput-1, auth-source--aput)
+ (auth-source--aget): New functions and macros.
+ Use them instead of aput/aget.
+
+2012-04-27 Andreas Schwab <schwab@linux-m68k.org>
* gnus.el (debbugs-gnu): Don't override existing autoload definition.
-2012-04-12 Lars Magne Ingebrigtsen <larsi@gnus.org>
+2012-04-26 Daiki Ueno <ueno@unixuser.org>
+
+ * plstore.el (plstore-called-interactively-p): New compat macro copied
+ from message.el.
+ (plstore-mode): Use it.
+
+2012-04-26 Daiki Ueno <ueno@unixuser.org>
+
+ * plstore.el: Revive the editing feature.
+ (plstore-mode): New mode to edit plstore file.
+ (plstore-mode-toggle-display, plstore-mode-original)
+ (plstore-mode-decoded): New command.
+ (plstore--encode, plstore--decode, plstore--write-contents-functions)
+ (plstore--insert-buffer, plstore--make): New function.
+ (plstore-open, plstore-save): Simplify by using them.
+
+2012-04-16 Glenn Morris <rgm@gnu.org>
+
+ * nndraft.el (nndraft-request-list): Fix declaration.
+
+2012-04-14 Lars Magne Ingebrigtsen <larsi@gnus.org>
* gnus-msg.el (gnus-inews-insert-gcc): Don't do the alist stuff when we
don't have a current group.
-2012-04-10 Lars Magne Ingebrigtsen <larsi@gnus.org>
-
* gnus-msg.el (gnus-inews-insert-gcc): Protect against when we don't
have a group name.
@@ -25,6 +103,12 @@
* gnus-start.el (gnus-read-newsrc-el-file): Protect against broken
.newsrc.el files.
+2012-04-10 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-msg.el (gnus-summary-cancel-article): See what From header we
+ would have gotten if we posted to the group, and use that to compare
+ against the message we want to cancel (bug#10808).
+
2012-03-22 Lars Magne Ingebrigtsen <larsi@gnus.org>
* auth-source.el (auth-source-netrc-create): Quote tokens that contain
@@ -22626,7 +22710,7 @@
See ChangeLog.2 for earlier changes.
- Copyright (C) 2004-2012 Free Software Foundation, Inc.
+ Copyright (C) 2004-2012 Free Software Foundation, Inc.
This file is part of GNU Emacs.
diff --git a/lisp/gnus/ChangeLog.1 b/lisp/gnus/ChangeLog.1
index f3ba7bca4d4..f223bd77085 100644
--- a/lisp/gnus/ChangeLog.1
+++ b/lisp/gnus/ChangeLog.1
@@ -2966,7 +2966,7 @@
1997-11-25 Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
- * gnus-move.el (gnus-move-group-to-server): Protect agains
+ * gnus-move.el (gnus-move-group-to-server): Protect against
nil-ness.
1997-11-25 Lars Magne Ingebrigtsen <larsi@menja.ifi.uio.no>
diff --git a/lisp/gnus/auth-source.el b/lisp/gnus/auth-source.el
index 34fe5afe7af..47359500dc4 100644
--- a/lisp/gnus/auth-source.el
+++ b/lisp/gnus/auth-source.el
@@ -42,7 +42,6 @@
(require 'password-cache)
(require 'mm-util)
(require 'gnus-util)
-(require 'assoc)
(eval-when-compile (require 'cl))
(require 'eieio)
@@ -92,9 +91,9 @@ let-binding."
(const :tag "30 Minutes" 1800)
(integer :tag "Seconds")))
-;;; The slots below correspond with the `auth-source-search' spec,
-;;; so a backend with :host set, for instance, would match only
-;;; searches for that host. Normally they are nil.
+;; The slots below correspond with the `auth-source-search' spec,
+;; so a backend with :host set, for instance, would match only
+;; searches for that host. Normally they are nil.
(defclass auth-source-backend ()
((type :initarg :type
:initform 'netrc
@@ -149,8 +148,8 @@ let-binding."
(repeat :tag "Names"
(string :tag "Name")))))
-;;; generate all the protocols in a format Customize can use
-;;; TODO: generate on the fly from auth-source-protocols
+;; Generate all the protocols in a format Customize can use.
+;; TODO: generate on the fly from auth-source-protocols
(defconst auth-source-protocols-customize
(mapcar (lambda (a)
(let ((p (car-safe a)))
@@ -339,7 +338,7 @@ If the value is not a list, symmetric encryption will be used."
msg))
-;;; (auth-source-read-char-choice "enter choice? " '(?a ?b ?q))
+;; (auth-source-read-char-choice "enter choice? " '(?a ?b ?q))
(defun auth-source-read-char-choice (prompt choices)
"Read one of CHOICES by `read-char-choice', or `read-char'.
`dropdown-list' support is disabled because it doesn't work reliably.
@@ -711,10 +710,10 @@ must call it to obtain the actual value."
(setq matches (append matches bmatches))))))
matches))
-;;; (auth-source-search :max 1)
-;;; (funcall (plist-get (nth 0 (auth-source-search :max 1)) :secret))
-;;; (auth-source-search :host "nonesuch" :type 'netrc :K 1)
-;;; (auth-source-search :host "nonesuch" :type 'secrets)
+;; (auth-source-search :max 1)
+;; (funcall (plist-get (nth 0 (auth-source-search :max 1)) :secret))
+;; (auth-source-search :host "nonesuch" :type 'netrc :K 1)
+;; (auth-source-search :host "nonesuch" :type 'secrets)
(defun* auth-source-delete (&rest spec
&key delete
@@ -776,16 +775,16 @@ This is the same SPEC you passed to `auth-source-search'.
Returns t or nil for forgotten or not found."
(password-cache-remove (auth-source-format-cache-entry spec)))
-;;; (loop for sym being the symbols of password-data when (string-match (concat "^" auth-source-magic) (symbol-name sym)) collect (symbol-name sym))
+;; (loop for sym being the symbols of password-data when (string-match (concat "^" auth-source-magic) (symbol-name sym)) collect (symbol-name sym))
-;;; (auth-source-remember '(:host "wedd") '(4 5 6))
-;;; (auth-source-remembered-p '(:host "wedd"))
-;;; (auth-source-remember '(:host "xedd") '(1 2 3))
-;;; (auth-source-remembered-p '(:host "xedd"))
-;;; (auth-source-remembered-p '(:host "zedd"))
-;;; (auth-source-recall '(:host "xedd"))
-;;; (auth-source-recall '(:host t))
-;;; (auth-source-forget+ :host t)
+;; (auth-source-remember '(:host "wedd") '(4 5 6))
+;; (auth-source-remembered-p '(:host "wedd"))
+;; (auth-source-remember '(:host "xedd") '(1 2 3))
+;; (auth-source-remembered-p '(:host "xedd"))
+;; (auth-source-remembered-p '(:host "zedd"))
+;; (auth-source-recall '(:host "xedd"))
+;; (auth-source-recall '(:host t))
+;; (auth-source-forget+ :host t)
(defun* auth-source-forget+ (&rest spec &allow-other-keys)
"Forget any cached data matching SPEC. Returns forgotten count.
@@ -819,8 +818,8 @@ while \(:host t) would find all host entries."
(return 'no)))
'no))))
-;;; (auth-source-pick-first-password :host "z.lifelogs.com")
-;;; (auth-source-pick-first-password :port "imap")
+;; (auth-source-pick-first-password :host "z.lifelogs.com")
+;; (auth-source-pick-first-password :port "imap")
(defun auth-source-pick-first-password (&rest spec)
"Pick the first secret found from applying SPEC to `auth-source-search'."
(let* ((result (nth 0 (apply 'auth-source-search (plist-put spec :max 1))))
@@ -853,7 +852,22 @@ while \(:host t) would find all host entries."
;;; Backend specific parsing: netrc/authinfo backend
-;;; (auth-source-netrc-parse "~/.authinfo.gpg")
+(defun auth-source--aput-1 (alist key val)
+ (let ((seen ())
+ (rest alist))
+ (while (and (consp rest) (not (equal key (caar rest))))
+ (push (pop rest) seen))
+ (cons (cons key val)
+ (if (null rest) alist
+ (nconc (nreverse seen)
+ (if (equal key (caar rest)) (cdr rest) rest))))))
+(defmacro auth-source--aput (var key val)
+ `(setq ,var (auth-source--aput-1 ,var ,key ,val)))
+
+(defun auth-source--aget (alist key)
+ (cdr (assoc key alist)))
+
+;; (auth-source-netrc-parse "~/.authinfo.gpg")
(defun* auth-source-netrc-parse (&rest
spec
&key file max host user port delete require
@@ -888,10 +902,11 @@ Note that the MAX parameter is used so we can exit the parse early."
;; cache all netrc files (used to be just .gpg files)
;; Store the contents of the file heavily encrypted in memory.
;; (note for the irony-impaired: they are just obfuscated)
- (aput 'auth-source-netrc-cache file
- (list :mtime (nth 5 (file-attributes file))
- :secret (lexical-let ((v (mapcar '1+ (buffer-string))))
- (lambda () (apply 'string (mapcar '1- v)))))))
+ (auth-source--aput
+ auth-source-netrc-cache file
+ (list :mtime (nth 5 (file-attributes file))
+ :secret (lexical-let ((v (mapcar '1+ (buffer-string))))
+ (lambda () (apply 'string (mapcar '1- v)))))))
(goto-char (point-min))
;; Go through the file, line by line.
(while (and (not (eobp))
@@ -937,21 +952,21 @@ Note that the MAX parameter is used so we can exit the parse early."
(auth-source-search-collection
host
(or
- (aget alist "machine")
- (aget alist "host")
+ (auth-source--aget alist "machine")
+ (auth-source--aget alist "host")
t))
(auth-source-search-collection
user
(or
- (aget alist "login")
- (aget alist "account")
- (aget alist "user")
+ (auth-source--aget alist "login")
+ (auth-source--aget alist "account")
+ (auth-source--aget alist "user")
t))
(auth-source-search-collection
port
(or
- (aget alist "port")
- (aget alist "protocol")
+ (auth-source--aget alist "port")
+ (auth-source--aget alist "protocol")
t))
(or
;; the required list of keys is nil, or
@@ -1086,8 +1101,8 @@ FILE is the file from which we obtained this token."
ret))
alist))
-;;; (setq secret (plist-get (nth 0 (auth-source-search :host t :type 'netrc :K 1 :max 1)) :secret))
-;;; (funcall secret)
+;; (setq secret (plist-get (nth 0 (auth-source-search :host t :type 'netrc :K 1 :max 1)) :secret))
+;; (funcall secret)
(defun* auth-source-netrc-search (&rest
spec
@@ -1133,8 +1148,8 @@ See `auth-source-search' for details on SPEC."
(nth 0 v)
v))
-;;; (auth-source-search :host "nonesuch" :type 'netrc :max 1 :create t)
-;;; (auth-source-search :host "nonesuch" :type 'netrc :max 1 :create t :create-extra-keys '((A "default A") (B)))
+;; (auth-source-search :host "nonesuch" :type 'netrc :max 1 :create t)
+;; (auth-source-search :host "nonesuch" :type 'netrc :max 1 :create t :create-extra-keys '((A "default A") (B)))
(defun* auth-source-netrc-create (&rest spec
&key backend
@@ -1166,7 +1181,7 @@ See `auth-source-search' for details on SPEC."
;; just the value otherwise
(t (symbol-value br)))))
(when br-choice
- (aput 'valist br br-choice)))))
+ (auth-source--aput valist br br-choice)))))
;; for extra required elements, see if the spec includes a value for them
(dolist (er create-extra)
@@ -1175,17 +1190,18 @@ See `auth-source-search' for details on SPEC."
collect (nth i spec))))
(dolist (k keys)
(when (equal (symbol-name k) name)
- (aput 'valist er (plist-get spec k))))))
+ (auth-source--aput valist er (plist-get spec k))))))
;; for each required element
(dolist (r required)
- (let* ((data (aget valist r))
+ (let* ((data (auth-source--aget valist r))
;; take the first element if the data is a list
(data (or (auth-source-netrc-element-or-first data)
(plist-get current-data
(intern (format ":%s" r) obarray))))
;; this is the default to be offered
- (given-default (aget auth-source-creation-defaults r))
+ (given-default (auth-source--aget
+ auth-source-creation-defaults r))
;; the default supplementals are simple:
;; for the user, try `given-default' and then (user-login-name);
;; otherwise take `given-default'
@@ -1197,22 +1213,22 @@ See `auth-source-search' for details on SPEC."
(cons 'user
(or
(auth-source-netrc-element-or-first
- (aget valist 'user))
+ (auth-source--aget valist 'user))
(plist-get artificial :user)
"[any user]"))
(cons 'host
(or
(auth-source-netrc-element-or-first
- (aget valist 'host))
+ (auth-source--aget valist 'host))
(plist-get artificial :host)
"[any host]"))
(cons 'port
(or
(auth-source-netrc-element-or-first
- (aget valist 'port))
+ (auth-source--aget valist 'port))
(plist-get artificial :port)
"[any port]"))))
- (prompt (or (aget auth-source-creation-prompts r)
+ (prompt (or (auth-source--aget auth-source-creation-prompts r)
(case r
(secret "%p password for %u@%h: ")
(user "%p user name for %h: ")
@@ -1221,9 +1237,9 @@ See `auth-source-search' for details on SPEC."
(format "Enter %s (%%u@%%h:%%p): " r)))
(prompt (auth-source-format-prompt
prompt
- `((?u ,(aget printable-defaults 'user))
- (?h ,(aget printable-defaults 'host))
- (?p ,(aget printable-defaults 'port))))))
+ `((?u ,(auth-source--aget printable-defaults 'user))
+ (?h ,(auth-source--aget printable-defaults 'host))
+ (?p ,(auth-source--aget printable-defaults 'port))))))
;; Store the data, prompting for the password if needed.
(setq data (or data
@@ -1384,16 +1400,16 @@ Respects `auth-source-save-behavior'. Uses
file)
(message "Saved new authentication information to %s" file)
nil))))
- (aput 'auth-source-netrc-cache key "ran"))))
+ (auth-source--aput auth-source-netrc-cache key "ran"))))
;;; Backend specific parsing: Secrets API backend
-;;; (let ((auth-sources '(default))) (auth-source-search :max 1 :create t))
-;;; (let ((auth-sources '(default))) (auth-source-search :max 1 :delete t))
-;;; (let ((auth-sources '(default))) (auth-source-search :max 1))
-;;; (let ((auth-sources '(default))) (auth-source-search))
-;;; (let ((auth-sources '("secrets:Login"))) (auth-source-search :max 1))
-;;; (let ((auth-sources '("secrets:Login"))) (auth-source-search :max 1 :signon_realm "https://git.gnus.org/Git"))
+;; (let ((auth-sources '(default))) (auth-source-search :max 1 :create t))
+;; (let ((auth-sources '(default))) (auth-source-search :max 1 :delete t))
+;; (let ((auth-sources '(default))) (auth-source-search :max 1))
+;; (let ((auth-sources '(default))) (auth-source-search))
+;; (let ((auth-sources '("secrets:Login"))) (auth-source-search :max 1))
+;; (let ((auth-sources '("secrets:Login"))) (auth-source-search :max 1 :signon_realm "https://git.gnus.org/Git"))
(defun* auth-source-secrets-search (&rest
spec
@@ -1609,7 +1625,7 @@ authentication tokens:
;; just the value otherwise
(t (symbol-value br)))))
(when br-choice
- (aput 'valist br br-choice)))))
+ (auth-source--aput valist br br-choice)))))
;; for extra required elements, see if the spec includes a value for them
(dolist (er create-extra)
@@ -1618,17 +1634,18 @@ authentication tokens:
collect (nth i spec))))
(dolist (k keys)
(when (equal (symbol-name k) name)
- (aput 'valist er (plist-get spec k))))))
+ (auth-source--aput valist er (plist-get spec k))))))
;; for each required element
(dolist (r required)
- (let* ((data (aget valist r))
+ (let* ((data (auth-source--aget valist r))
;; take the first element if the data is a list
(data (or (auth-source-netrc-element-or-first data)
(plist-get current-data
(intern (format ":%s" r) obarray))))
;; this is the default to be offered
- (given-default (aget auth-source-creation-defaults r))
+ (given-default (auth-source--aget
+ auth-source-creation-defaults r))
;; the default supplementals are simple:
;; for the user, try `given-default' and then (user-login-name);
;; otherwise take `given-default'
@@ -1640,22 +1657,22 @@ authentication tokens:
(cons 'user
(or
(auth-source-netrc-element-or-first
- (aget valist 'user))
+ (auth-source--aget valist 'user))
(plist-get artificial :user)
"[any user]"))
(cons 'host
(or
(auth-source-netrc-element-or-first
- (aget valist 'host))
+ (auth-source--aget valist 'host))
(plist-get artificial :host)
"[any host]"))
(cons 'port
(or
(auth-source-netrc-element-or-first
- (aget valist 'port))
+ (auth-source--aget valist 'port))
(plist-get artificial :port)
"[any port]"))))
- (prompt (or (aget auth-source-creation-prompts r)
+ (prompt (or (auth-source--aget auth-source-creation-prompts r)
(case r
(secret "%p password for %u@%h: ")
(user "%p user name for %h: ")
@@ -1664,20 +1681,21 @@ authentication tokens:
(format "Enter %s (%%u@%%h:%%p): " r)))
(prompt (auth-source-format-prompt
prompt
- `((?u ,(aget printable-defaults 'user))
- (?h ,(aget printable-defaults 'host))
- (?p ,(aget printable-defaults 'port))))))
+ `((?u ,(auth-source--aget printable-defaults 'user))
+ (?h ,(auth-source--aget printable-defaults 'host))
+ (?p ,(auth-source--aget printable-defaults 'port))))))
;; Store the data, prompting for the password if needed.
(setq data (or data
(if (eq r 'secret)
(or (eval default) (read-passwd prompt))
(if (stringp default)
- (read-string (if (string-match ": *\\'" prompt)
- (concat (substring prompt 0 (match-beginning 0))
- " (default " default "): ")
- (concat prompt "(default " default ") "))
- nil nil default)
+ (read-string
+ (if (string-match ": *\\'" prompt)
+ (concat (substring prompt 0 (match-beginning 0))
+ " (default " default "): ")
+ (concat prompt "(default " default ") "))
+ nil nil default)
(eval default)))))
(when data
@@ -1701,7 +1719,7 @@ authentication tokens:
;;; older API
-;;; (auth-source-user-or-password '("login" "password") "imap.myhost.com" t "tzz")
+;; (auth-source-user-or-password '("login" "password") "imap.myhost.com" t "tzz")
;; deprecate the old interface
(make-obsolete 'auth-source-user-or-password
diff --git a/lisp/gnus/gnus-demon.el b/lisp/gnus/gnus-demon.el
index d0baf25d5d9..2a4fa6f483e 100644
--- a/lisp/gnus/gnus-demon.el
+++ b/lisp/gnus/gnus-demon.el
@@ -116,7 +116,6 @@ Emacs has been idle for IDLE `gnus-demon-timestep's."
;; Set up the timer.
(let* ((func (nth 0 handler))
(time (nth 1 handler))
- (time-type (type-of time))
(idle (nth 2 handler))
;; Compute time according with timestep.
;; If t, replace by 1
@@ -140,10 +139,10 @@ Emacs has been idle for IDLE `gnus-demon-timestep's."
(run-with-idle-timer idle t 'gnus-demon-run-callback func))
;; (func number any)
;; Call every `time'
- ((eq time-type 'integer)
+ ((integerp time)
(run-with-timer time time 'gnus-demon-run-callback func idle))
;; (func string any)
- ((eq time-type 'string)
+ ((stringp time)
(run-with-timer time (* 24 60 60) 'gnus-demon-run-callback func idle)))))
(when timer
(add-to-list 'gnus-demon-timers timer)))))
diff --git a/lisp/gnus/gnus-msg.el b/lisp/gnus/gnus-msg.el
index c6d0c3213a0..a041a85d444 100644
--- a/lisp/gnus/gnus-msg.el
+++ b/lisp/gnus/gnus-msg.el
@@ -487,8 +487,10 @@ If Gnus isn't running, a plain `message-mail' setup is used
instead."
(interactive)
(if (not (gnus-alive-p))
- (message-mail to subject other-headers continue
- nil yank-action send-actions return-action)
+ (progn
+ (message "Gnus not running; using plain Message mode")
+ (message-mail to subject other-headers continue
+ nil yank-action send-actions return-action))
(let ((buf (current-buffer))
(gnus-newsgroup-name (or gnus-newsgroup-name ""))
mail-buf)
@@ -810,9 +812,21 @@ post using the current select method."
(interactive (gnus-interactive "P\ny"))
(let ((message-post-method
`(lambda (arg)
- (gnus-post-method (eq ',symp 'a) ,gnus-newsgroup-name))))
+ (gnus-post-method (eq ',symp 'a) ,gnus-newsgroup-name)))
+ (user-mail-address user-mail-address))
(dolist (article (gnus-summary-work-articles n))
(when (gnus-summary-select-article t nil nil article)
+ ;; Pretend that we're doing a followup so that we can see what
+ ;; the From header would have ended up being.
+ (save-window-excursion
+ (save-excursion
+ (gnus-summary-followup nil)
+ (let ((from (message-fetch-field "from")))
+ (when from
+ (setq user-mail-address
+ (car (mail-header-parse-address from)))))
+ (kill-buffer (current-buffer))))
+ ;; Now cancel the article using the From header we got.
(when (gnus-eval-in-buffer-window gnus-original-article-buffer
(message-cancel-news))
(gnus-summary-mark-as-read article gnus-canceled-mark)
diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el
index f1618b376ef..53690f04169 100644
--- a/lisp/gnus/gnus-registry.el
+++ b/lisp/gnus/gnus-registry.el
@@ -96,7 +96,7 @@
(defvar gnus-adaptive-word-syntax-table)
(defvar gnus-registry-dirty t
- "Boolean set to t when the registry is modified")
+ "Boolean set to t when the registry is modified.")
(defgroup gnus-registry nil
"The Gnus registry."
@@ -284,7 +284,7 @@ the Bit Bucket."
:tracked nil)))
(defvar gnus-registry-db (gnus-registry-make-db)
- "*The article registry by Message ID. See `registry-db'")
+ "The article registry by Message ID. See `registry-db'.")
;; top-level registry data management
(defun gnus-registry-remake-db (&optional forsure)
@@ -418,9 +418,9 @@ This is not required after changing `gnus-registry-cache-file'."
;; Function for nn{mail|imap}-split-fancy: look up all references in
;; the cache and if a match is found, return that group.
(defun gnus-registry-split-fancy-with-parent ()
- "Split this message into the same group as its parent. The parent
-is obtained from the registry. This function can be used as an entry
-in `nnmail-split-fancy' or `nnimap-split-fancy', for example like
+ "Split this message into the same group as its parent.
+The parent is obtained from the registry. This function can be used as an
+entry in `nnmail-split-fancy' or `nnimap-split-fancy', for example like
this: (: gnus-registry-split-fancy-with-parent)
This function tracks ALL backends, unlike
@@ -746,7 +746,7 @@ Overrides existing keywords with FORCE set non-nil."
(registry-lookup-secondary-value gnus-registry-db 'keyword keyword))
(defun gnus-registry-register-message-ids ()
- "Register the Message-ID of every article in the group"
+ "Register the Message-ID of every article in the group."
(unless (gnus-parameter-registry-ignore gnus-newsgroup-name)
(dolist (article gnus-newsgroup-articles)
(let* ((id (gnus-registry-fetch-message-id-fast article))
@@ -761,7 +761,7 @@ Overrides existing keywords with FORCE set non-nil."
;; message field fetchers
(defun gnus-registry-fetch-message-id-fast (article)
- "Fetch the Message-ID quickly, using the internal gnus-data-list function"
+ "Fetch the Message-ID quickly, using the internal gnus-data-list function."
(if (and (numberp article)
(assoc article (gnus-data-list nil)))
(mail-header-id (gnus-data-header (assoc article (gnus-data-list nil))))
@@ -793,7 +793,7 @@ Addresses without a name will say \"noname\"."
nil))
(defun gnus-registry-fetch-simplified-message-subject-fast (article)
- "Fetch the Subject quickly, using the internal gnus-data-list function"
+ "Fetch the Subject quickly, using the internal gnus-data-list function."
(if (and (numberp article)
(assoc article (gnus-data-list nil)))
(gnus-string-remove-all-properties
@@ -811,7 +811,7 @@ Addresses without a name will say \"noname\"."
(or (ignore-errors (gnus-registry-fetch-header-fast "To" article)) "")))
(defun gnus-registry-fetch-header-fast (article header)
- "Fetch the HEADER quickly, using the internal gnus-data-list function"
+ "Fetch the HEADER quickly, using the internal gnus-data-list function."
(if (and (numberp article)
(assoc article (gnus-data-list nil)))
(gnus-string-remove-all-properties
@@ -831,7 +831,34 @@ FUNCTION should take two parameters, a mark symbol and the cell value."
(when cell-data
(funcall function mark cell-data)))))
-;;; this is ugly code, but I don't know how to do it better
+;; FIXME: Why not merge gnus-registry--set/remove-mark and
+;; gnus-registry-set-article-mark-internal?
+(defun gnus-registry--set/remove-mark (remove mark articles)
+ "Set/remove the MARK over process-marked ARTICLES."
+ ;; If this is called and the user doesn't want the
+ ;; registry enabled, we'll ask anyhow.
+ (unless gnus-registry-install
+ (let ((gnus-registry-install 'ask))
+ (gnus-registry-install-p)))
+
+ ;; Now the user is asked if gnus-registry-install is `ask'.
+ (when (gnus-registry-install-p)
+ (gnus-registry-set-article-mark-internal
+ ;; All this just to get the mark, I must be doing it wrong.
+ mark articles remove t)
+ ;; FIXME: Why do we do the above only here and not directly inside
+ ;; gnus-registry-set-article-mark-internal? I.e. we wouldn't we want to do
+ ;; the things below when gnus-registry-set-article-mark-internal is called
+ ;; from gnus-registry-set-article-mark or
+ ;; gnus-registry-remove-article-mark?
+ (gnus-message 9 "Applying mark %s to %d articles"
+ mark (length articles))
+ (dolist (article articles)
+ (gnus-summary-update-article
+ article
+ (assoc article (gnus-data-list nil))))))
+
+;; This is ugly code, but I don't know how to do it better.
(defun gnus-registry-install-shortcuts ()
"Install the keyboard shortcuts and menus for the registry.
Uses `gnus-registry-marks' to find what shortcuts to install."
@@ -843,69 +870,41 @@ Uses `gnus-registry-marks' to find what shortcuts to install."
(let ((function-format
(format "gnus-registry-%%s-article-%s-mark" mark)))
-;;; The following generates these functions:
-;;; (defun gnus-registry-set-article-Important-mark (&rest articles)
-;;; "Apply the Important mark to process-marked ARTICLES."
-;;; (interactive (gnus-summary-work-articles current-prefix-arg))
-;;; (gnus-registry-set-article-mark-internal 'Important articles nil t))
-;;; (defun gnus-registry-remove-article-Important-mark (&rest articles)
-;;; "Apply the Important mark to process-marked ARTICLES."
-;;; (interactive (gnus-summary-work-articles current-prefix-arg))
-;;; (gnus-registry-set-article-mark-internal 'Important articles t t))
+;;; The following generates these functions:
+;;; (defun gnus-registry-set-article-Important-mark (&rest articles)
+;;; "Apply the Important mark to process-marked ARTICLES."
+;;; (interactive (gnus-summary-work-articles current-prefix-arg))
+;;; (gnus-registry-set-article-mark-internal 'Important articles nil t))
+;;; (defun gnus-registry-remove-article-Important-mark (&rest articles)
+;;; "Apply the Important mark to process-marked ARTICLES."
+;;; (interactive (gnus-summary-work-articles current-prefix-arg))
+;;; (gnus-registry-set-article-mark-internal 'Important articles t t))
(dolist (remove '(t nil))
(let* ((variant-name (if remove "remove" "set"))
- (function-name (format function-format variant-name))
- (shortcut (format "%c" data))
- (shortcut (if remove (upcase shortcut) shortcut)))
- (unintern function-name obarray)
- (eval
- `(defun
- ;; function name
- ,(intern function-name)
- ;; parameter definition
- (&rest articles)
- ;; documentation
- ,(format
- "%s the %s mark over process-marked ARTICLES."
- (upcase-initials variant-name)
- mark)
- ;; interactive definition
- (interactive
- (gnus-summary-work-articles current-prefix-arg))
- ;; actual code
-
- ;; if this is called and the user doesn't want the
- ;; registry enabled, we'll ask anyhow
- (unless gnus-registry-install
- (let ((gnus-registry-install 'ask))
- (gnus-registry-install-p)))
-
- ;; now the user is asked if gnus-registry-install is 'ask
- (when (gnus-registry-install-p)
- (gnus-registry-set-article-mark-internal
- ;; all this just to get the mark, I must be doing it wrong
- (intern ,(symbol-name mark))
- articles ,remove t)
- (gnus-message
- 9
- "Applying mark %s to %d articles"
- ,(symbol-name mark) (length articles))
- (dolist (article articles)
- (gnus-summary-update-article
- article
- (assoc article (gnus-data-list nil)))))))
- (push (intern function-name) keys-plist)
+ (function-name
+ (intern (format function-format variant-name)))
+ (shortcut (format "%c" (if remove (upcase data) data))))
+ (defalias function-name
+ ;; If it weren't for the function's docstring, we could
+ ;; use a closure, with lexical-let :-(
+ `(lambda (&rest articles)
+ ,(format
+ "%s the %s mark over process-marked ARTICLES."
+ (upcase-initials variant-name)
+ mark)
+ (interactive
+ (gnus-summary-work-articles current-prefix-arg))
+ (gnus-registry--set/remove-mark ',mark ',remove articles)))
+ (push function-name keys-plist)
(push shortcut keys-plist)
(push (vector (format "%s %s"
(upcase-initials variant-name)
(symbol-name mark))
- (intern function-name) t)
+ function-name t)
gnus-registry-misc-menus)
- (gnus-message
- 9
- "Defined mark handling function %s"
- function-name))))))
+ (gnus-message 9 "Defined mark handling function %s"
+ function-name))))))
(gnus-define-keys-1
'(gnus-registry-mark-map "M" gnus-summary-mark-map)
keys-plist)
@@ -925,7 +924,7 @@ Uses `gnus-registry-marks' to find what shortcuts to install."
;; use like this:
;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-chars)
(defun gnus-registry-article-marks-to-chars (headers)
- "Show the marks for an article by the :char property"
+ "Show the marks for an article by the :char property."
(let* ((id (mail-header-message-id headers))
(marks (when id (gnus-registry-get-id-key id 'mark))))
(mapconcat (lambda (mark)
@@ -938,7 +937,7 @@ Uses `gnus-registry-marks' to find what shortcuts to install."
;; use like this:
;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-names)
(defun gnus-registry-article-marks-to-names (headers)
- "Show the marks for an article by name"
+ "Show the marks for an article by name."
(let* ((id (mail-header-message-id headers))
(marks (when id (gnus-registry-get-id-key id 'mark))))
(mapconcat (lambda (mark) (symbol-name mark)) marks ",")))
@@ -1153,13 +1152,14 @@ only the last one's marks are returned."
;;;###autoload
(defun gnus-registry-initialize ()
-"Initialize the Gnus registry."
+ "Initialize the Gnus registry."
(interactive)
(gnus-message 5 "Initializing the registry")
(gnus-registry-install-hooks)
(gnus-registry-install-shortcuts)
(gnus-registry-read))
+;; FIXME: Why autoload this function?
;;;###autoload
(defun gnus-registry-install-hooks ()
"Install the registry hooks."
diff --git a/lisp/gnus/gnus-win.el b/lisp/gnus/gnus-win.el
index 579210c6138..efe2a319854 100644
--- a/lisp/gnus/gnus-win.el
+++ b/lisp/gnus/gnus-win.el
@@ -239,7 +239,8 @@ See the Gnus manual for an explanation of the syntax used.")
(defun gnus-configure-frame (split &optional window)
"Split WINDOW according to SPLIT."
- (let* ((current-window (or (get-buffer-window (current-buffer)) (selected-window)))
+ (let* ((current-window (or (get-buffer-window (current-buffer))
+ (selected-window)))
(window (or window current-window)))
(select-window window)
;; The SPLIT might be something that is to be evalled to
@@ -269,9 +270,21 @@ See the Gnus manual for an explanation of the syntax used.")
(let ((buf (gnus-get-buffer-create
(gnus-window-to-buffer-helper buffer))))
(when (buffer-name buf)
- (if (eq buf (window-buffer (selected-window)))
- (set-buffer buf)
- (switch-to-buffer buf))))
+ (cond
+ ((eq buf (window-buffer (selected-window)))
+ (set-buffer buf))
+ ((eq t (window-dedicated-p))
+ ;; If the window is hard-dedicated, we have a problem because
+ ;; we just can't do what we're asked. But signaling an error,
+ ;; like `switch-to-buffer' would do, is not an option because
+ ;; it would prevent things like "^" (to jump to the *Servers*)
+ ;; in a dedicated *Group*.
+ ;; FIXME: Maybe a better/additional fix would be to change
+ ;; gnus-configure-windows so that when called
+ ;; from a hard-dedicated frame, it creates (and
+ ;; configures) a new frame, leaving the dedicated frame alone.
+ (pop-to-buffer buf))
+ (t (switch-to-buffer buf)))))
(when (memq 'frame-focus split)
(setq gnus-window-frame-focus window))
;; We return the window if it has the `point' spec.
@@ -340,9 +353,9 @@ See the Gnus manual for an explanation of the syntax used.")
;; fashion.
(setq comp-subs (nreverse comp-subs))
(while comp-subs
- (if (null (cdr comp-subs))
- (setq new-win window)
- (setq new-win
+ (setq new-win
+ (if (null (cdr comp-subs))
+ window
(split-window window (cadar comp-subs)
(eq type 'horizontal))))
(setq result (or (gnus-configure-frame
diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el
index 635bb6fc96f..bba56e31d9b 100644
--- a/lisp/gnus/gnus.el
+++ b/lisp/gnus/gnus.el
@@ -1271,15 +1271,18 @@ Set this variable in `.emacs' instead."
:type '(choice (const :tag "current" nil)
directory))
-;; Site dependent variables. These variables should be defined in
-;; paths.el.
+;; Site dependent variables.
-(defvar gnus-default-nntp-server nil
- "Specify a default NNTP server.
-This variable should be defined in paths.el, and should never be set
-by the user.
-If you want to change servers, you should use `gnus-select-method'.
-See the documentation to that variable.")
+;; Should this be obsolete?
+(defcustom gnus-default-nntp-server nil
+ "The hostname of the default NNTP server.
+The empty string, or nil, means to use the local host.
+You may wish to set this on a site-wide basis.
+
+If you want to change servers, you should use `gnus-select-method'."
+ :group 'gnus-server
+ :type '(choice (const :tag "local host" nil)
+ (string :tag "host name")))
(defcustom gnus-nntpserver-file "/etc/nntpserver"
"A file with only the name of the nntp server in it."
@@ -1326,6 +1329,8 @@ If you use this variable, you must set `gnus-nntp-server' to nil.
There is a lot more to know about select methods and virtual servers -
see the manual for details."
+ ;; Emacs has set-after since 22.1.
+ ;set-after '(gnus-default-nntp-server)
:group 'gnus-server
:group 'gnus-start
:initialize 'custom-initialize-default
diff --git a/lisp/gnus/legacy-gnus-agent.el b/lisp/gnus/legacy-gnus-agent.el
index afbebbff79f..ecde35dca8f 100644
--- a/lisp/gnus/legacy-gnus-agent.el
+++ b/lisp/gnus/legacy-gnus-agent.el
@@ -206,29 +206,31 @@ converted to the compressed format."
(gnus-convert-mark-converter-prompt 'gnus-agent-unlist-expire-days t)
(defun gnus-agent-unhook-expire-days (converting-to)
- "Remove every lambda from gnus-group-prepare-hook that mention the
-symbol gnus-agent-do-once in their definition. This should NOT be
+ "Remove every lambda from `gnus-group-prepare-hook' that mention the
+symbol `gnus-agent-do-once' in their definition. This should NOT be
necessary as gnus-agent.el no longer adds them. However, it is
possible that the hook was persistently saved."
- (let ((h t)) ; iterate from bgn of hook
+ (let ((h t)) ; Iterate from bgn of hook.
(while h
(let ((func (progn (when (eq h t)
- ;; init h to list of functions
+ ;; Init h to list of functions.
(setq h (cond ((listp gnus-group-prepare-hook)
gnus-group-prepare-hook)
((boundp 'gnus-group-prepare-hook)
(list gnus-group-prepare-hook)))))
(pop h))))
- (when (cond ((eq (type-of func) 'compiled-function)
- ;; Search def. of compiled function for gnus-agent-do-once string
+ (when (cond ((byte-code-function-p func)
+ ;; Search def. of compiled function for
+ ;; gnus-agent-do-once string.
(let* (definition
print-level
print-length
(standard-output
(lambda (char)
(setq definition (cons char definition)))))
- (princ func) ; populates definition with reversed list of characters
+ (princ func) ; Populates definition with reversed list
+ ; of characters.
(let* ((i (length definition))
(s (make-string i 0)))
(while definition
@@ -236,7 +238,7 @@ possible that the hook was persistently saved."
(string-match "\\bgnus-agent-do-once\\b" s))))
((listp func)
- (eq (cadr (nth 2 func)) 'gnus-agent-do-once) ; handles eval'd lambda
+ (eq (cadr (nth 2 func)) 'gnus-agent-do-once) ; Handles eval'd lambda.
))
(remove-hook 'gnus-group-prepare-hook func)
diff --git a/lisp/gnus/nndraft.el b/lisp/gnus/nndraft.el
index 1800d0c02de..da50720ebbe 100644
--- a/lisp/gnus/nndraft.el
+++ b/lisp/gnus/nndraft.el
@@ -37,7 +37,8 @@
(require 'mm-util)
(eval-when-compile (require 'cl))
-(declare-function nndraft-request-list "nnmh" (&rest args))
+;; The nnoo-import at the end, I think.
+(declare-function nndraft-request-list "nndraft" (&rest args) t)
(nnoo-declare nndraft
nnmh)
diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el
index f978b8c9906..114d83b7286 100644
--- a/lisp/gnus/nnimap.el
+++ b/lisp/gnus/nnimap.el
@@ -475,6 +475,8 @@ textual parts.")
(when nnimap-object
(when (nnimap-capability "QRESYNC")
(nnimap-command "ENABLE QRESYNC"))
+ (nnheader-message 7 "Opening connection to %s...done"
+ nnimap-address)
(nnimap-process nnimap-object))))))))
(autoload 'rfc2104-hash "rfc2104")
diff --git a/lisp/gnus/nnspool.el b/lisp/gnus/nnspool.el
index 2b024e20740..ad9e9c62d6d 100644
--- a/lisp/gnus/nnspool.el
+++ b/lisp/gnus/nnspool.el
@@ -31,6 +31,26 @@
(require 'nnoo)
(eval-when-compile (require 'cl))
+;; Probably this entire thing should be obsolete.
+;; It's only used to init nnspool-spool-directory, so why not just
+;; set that variable's default directly?
+(eval-and-compile
+ (defvar news-directory (if (file-exists-p "/usr/spool/news/")
+ "/usr/spool/news/"
+ "/var/spool/news/")
+ "The root directory below which all news files are stored.")
+ (defvaralias 'news-path 'news-directory))
+
+;; Ditto re obsolescence.
+(defvar news-inews-program
+ (cond ((file-exists-p "/usr/bin/inews") "/usr/bin/inews")
+ ((file-exists-p "/usr/local/inews") "/usr/local/inews")
+ ((file-exists-p "/usr/local/bin/inews") "/usr/local/bin/inews")
+ ((file-exists-p "/usr/contrib/lib/news/inews") "/usr/contrib/lib/news/inews")
+ ((file-exists-p "/usr/lib/news/inews") "/usr/lib/news/inews")
+ (t "inews"))
+ "Program to post news.")
+
(nnoo-declare nnspool)
(defvoo nnspool-inews-program news-inews-program
diff --git a/lisp/gnus/nntp.el b/lisp/gnus/nntp.el
index 621aece8920..e237227f78a 100644
--- a/lisp/gnus/nntp.el
+++ b/lisp/gnus/nntp.el
@@ -344,26 +344,26 @@ backend doesn't catch this error.")
(insert (format-time-string "%Y%m%dT%H%M%S.%3N")
" " nntp-address " " string "\n")))
+(defvar nntp--report-1 nil)
+
(defun nntp-report (&rest args)
"Report an error from the nntp backend. The first string in ARGS
can be a format string. For some commands, the failed command may be
retried once before actually displaying the error report."
+ (if nntp--report-1
+ (progn
+ ;; Throw out to nntp-with-open-group-error so that the connection may
+ ;; be restored and the command retried."
+ (when nntp-record-commands
+ (nntp-record-command "*** CONNECTION LOST ***"))
+ (throw 'nntp-with-open-group-error t))
- (when nntp-record-commands
- (nntp-record-command "*** CALLED nntp-report ***"))
-
- (nnheader-report 'nntp args)
+ (when nntp-record-commands
+ (nntp-record-command "*** CALLED nntp-report ***"))
- (apply 'error args))
+ (nnheader-report 'nntp args)
-(defun nntp-report-1 (&rest args)
- "Throws out to nntp-with-open-group-error so that the connection may
-be restored and the command retried."
-
- (when nntp-record-commands
- (nntp-record-command "*** CONNECTION LOST ***"))
-
- (throw 'nntp-with-open-group-error t))
+ (apply 'error args)))
(defmacro nntp-copy-to-buffer (buffer start end)
"Copy string from unibyte current buffer to multibyte buffer."
@@ -633,10 +633,6 @@ be restored and the command retried."
(t
nil)))
-(eval-when-compile
- (defvar nntp-with-open-group-internal nil)
- (defvar nntp-report-n nil))
-
(defun nntp-with-open-group-function (-group -server -connectionless -bodyfun)
"Protect against servers that don't like clients that keep idle connections opens.
The problem being that these servers may either close a connection or
@@ -647,9 +643,9 @@ connection timeouts (which may be several minutes) or
`nntp-connection-timeout' has expired. When these occur
`nntp-with-open-group', opens a new connection then re-issues the NNTP
command whose response triggered the error."
- (letf ((nntp-report-n (symbol-function 'nntp-report))
- ((symbol-function 'nntp-report) (symbol-function 'nntp-report-1))
- (nntp-with-open-group-internal nil))
+ (let ((nntp-report-n nntp--report-1)
+ (nntp--report-1 t)
+ (nntp-with-open-group-internal nil))
(while (catch 'nntp-with-open-group-error
;; Open the connection to the server
;; NOTE: Existing connections are NOT tested.
@@ -685,7 +681,7 @@ command whose response triggered the error."
(when -timer
(nnheader-cancel-timer -timer)))
nil))
- (setf (symbol-function 'nntp-report) nntp-report-n))
+ (setq nntp--report-1 nntp-report-n))
nntp-with-open-group-internal))
(defmacro nntp-with-open-group (group server &optional connectionless &rest forms)
diff --git a/lisp/gnus/nnweb.el b/lisp/gnus/nnweb.el
index a171cb35ae4..8c9c984ba2e 100644
--- a/lisp/gnus/nnweb.el
+++ b/lisp/gnus/nnweb.el
@@ -365,7 +365,7 @@ Valid types include `google', `dejanews', and `gmane'.")
(match-string 1)
(match-string 2)
(or (match-string 3)
- (substring (current-time-string) -4)))
+ (format-time-string "%Y")))
(current-time-string)))
(setq From (match-string 4)))
(widen)
diff --git a/lisp/gnus/plstore.el b/lisp/gnus/plstore.el
index cbd5e2a3b0a..6d5424e833d 100644
--- a/lisp/gnus/plstore.el
+++ b/lisp/gnus/plstore.el
@@ -64,8 +64,18 @@
;;
;; Editing:
;;
-;; Currently not supported but in the future plstore will provide a
-;; major mode to edit PLSTORE files.
+;; This file also provides `plstore-mode', a major mode for editing
+;; the PLSTORE format file. Visit a non-existing file and put the
+;; following line:
+;;
+;; (("foo" :host "foo.example.org" :secret-user "user"))
+;;
+;; where the prefixing `:secret-' means the property (without
+;; `:secret-' prefix) is marked as secret. Thus, when you save the
+;; buffer, the `:secret-user' property is encrypted as `:user'.
+;;
+;; You can toggle the view between encrypted form and the decrypted
+;; form with C-c C-c.
;;; Code:
@@ -107,6 +117,10 @@ symmetric encryption will be used.")
(put 'plstore-encrypt-to 'permanent-local t)
+(defvar plstore-encoded nil)
+
+(put 'plstore-encoded 'permanent-local t)
+
(defvar plstore-cache-passphrase-for-symmetric-encryption nil)
(defvar plstore-passphrase-alist nil)
@@ -194,10 +208,6 @@ symmetric encryption will be used.")
(generate-new-buffer (format " plstore %s" filename))))
(store (plstore--make buffer)))
(with-current-buffer buffer
- ;; In the future plstore will provide a major mode called
- ;; `plstore-mode' to edit PLSTORE files.
- (if (eq major-mode 'plstore-mode)
- (error "%s is opened for editing; kill the buffer first" file))
(erase-buffer)
(condition-case nil
(insert-file-contents-literally file)
@@ -435,6 +445,131 @@ If no one is selected, symmetric encryption will be performed. "
(plstore--insert-buffer plstore)
(save-buffer)))
+(defun plstore--encode (plstore)
+ (plstore--decrypt plstore)
+ (let ((merged-alist (plstore--get-merged-alist plstore)))
+ (concat "("
+ (mapconcat
+ (lambda (entry)
+ (setq entry (copy-sequence entry))
+ (let ((merged-plist (cdr (assoc (car entry) merged-alist)))
+ (plist (cdr entry)))
+ (while plist
+ (if (string-match "\\`:secret-" (symbol-name (car plist)))
+ (setcar (cdr plist)
+ (plist-get
+ merged-plist
+ (intern (concat ":"
+ (substring (symbol-name
+ (car plist))
+ (match-end 0)))))))
+ (setq plist (nthcdr 2 plist)))
+ (prin1-to-string entry)))
+ (plstore--get-alist plstore)
+ "\n")
+ ")")))
+
+(defun plstore--decode (string)
+ (let* ((alist (car (read-from-string string)))
+ (pointer alist)
+ secret-alist
+ plist
+ entry)
+ (while pointer
+ (unless (stringp (car (car pointer)))
+ (error "Invalid PLSTORE format %s" string))
+ (setq plist (cdr (car pointer)))
+ (while plist
+ (when (string-match "\\`:secret-" (symbol-name (car plist)))
+ (setq entry (assoc (car (car pointer)) secret-alist))
+ (unless entry
+ (setq entry (list (car (car pointer)))
+ secret-alist (cons entry secret-alist)))
+ (setcdr entry (plist-put (cdr entry)
+ (intern (concat ":"
+ (substring (symbol-name
+ (car plist))
+ (match-end 0))))
+ (car (cdr plist))))
+ (setcar (cdr plist) t))
+ (setq plist (nthcdr 2 plist)))
+ (setq pointer (cdr pointer)))
+ (plstore--make nil alist nil secret-alist)))
+
+(defun plstore--write-contents-functions ()
+ (when plstore-encoded
+ (let ((store (plstore--decode (buffer-string)))
+ (file (buffer-file-name)))
+ (unwind-protect
+ (progn
+ (set-visited-file-name nil)
+ (with-temp-buffer
+ (plstore--insert-buffer store)
+ (write-region (buffer-string) nil file)))
+ (set-visited-file-name file)
+ (set-buffer-modified-p nil))
+ t)))
+
+(defun plstore-mode-original ()
+ "Show the original form of the this buffer."
+ (interactive)
+ (when plstore-encoded
+ (if (and (buffer-modified-p)
+ (y-or-n-p "Save buffer before reading the original form? "))
+ (save-buffer))
+ (erase-buffer)
+ (insert-file-contents-literally (buffer-file-name))
+ (set-buffer-modified-p nil)
+ (setq plstore-encoded nil)))
+
+(defun plstore-mode-decoded ()
+ "Show the decoded form of the this buffer."
+ (interactive)
+ (unless plstore-encoded
+ (if (and (buffer-modified-p)
+ (y-or-n-p "Save buffer before decoding? "))
+ (save-buffer))
+ (let ((store (plstore--make (current-buffer))))
+ (plstore--init-from-buffer store)
+ (erase-buffer)
+ (insert
+ (substitute-command-keys "\
+;;; You are looking at the decoded form of the PLSTORE file.\n\
+;;; To see the original form content, do \\[plstore-mode-toggle-display]\n\n"))
+ (insert (plstore--encode store))
+ (set-buffer-modified-p nil)
+ (setq plstore-encoded t))))
+
+(defun plstore-mode-toggle-display ()
+ "Toggle the display mode of PLSTORE between the original and decoded forms."
+ (interactive)
+ (if plstore-encoded
+ (plstore-mode-original)
+ (plstore-mode-decoded)))
+
+(eval-when-compile
+ (defmacro plstore-called-interactively-p (kind)
+ (condition-case nil
+ (progn
+ (eval '(called-interactively-p 'any))
+ ;; Emacs >=23.2
+ `(called-interactively-p ,kind))
+ ;; Emacs <23.2
+ (wrong-number-of-arguments '(called-interactively-p))
+ ;; XEmacs
+ (void-function '(interactive-p)))))
+
+;;;###autoload
+(define-derived-mode plstore-mode emacs-lisp-mode "PLSTORE"
+ "Major mode for editing PLSTORE files."
+ (make-local-variable 'plstore-encoded)
+ (add-hook 'write-contents-functions #'plstore--write-contents-functions)
+ (define-key plstore-mode-map "\C-c\C-c" #'plstore-mode-toggle-display)
+ ;; to create a new file with plstore-mode, mark it as already decoded
+ (if (plstore-called-interactively-p 'any)
+ (setq plstore-encoded t)
+ (plstore-mode-decoded)))
+
(provide 'plstore)
;;; plstore.el ends here
generated by cgit v1.2.3 (git 2.39.1) at 2025-04-27 20:23:24 +0000