gnus-registry.el 49 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259
  1. ;;; gnus-registry.el --- article registry for Gnus
  2. ;; Copyright (C) 2002-2015 Free Software Foundation, Inc.
  3. ;; Author: Ted Zlatanov <tzz@lifelogs.com>
  4. ;; Keywords: news registry
  5. ;; This file is part of GNU Emacs.
  6. ;; GNU Emacs is free software: you can redistribute it and/or modify
  7. ;; it under the terms of the GNU General Public License as published by
  8. ;; the Free Software Foundation, either version 3 of the License, or
  9. ;; (at your option) any later version.
  10. ;; GNU Emacs is distributed in the hope that it will be useful,
  11. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  13. ;; GNU General Public License for more details.
  14. ;; You should have received a copy of the GNU General Public License
  15. ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
  16. ;;; Commentary:
  17. ;; This is the gnus-registry.el package, which works with all
  18. ;; Gnus backends, not just nnmail. The major issue is that it
  19. ;; doesn't go across backends, so for instance if an article is in
  20. ;; nnml:sys and you see a reference to it in nnimap splitting, the
  21. ;; article will end up in nnimap:sys
  22. ;; gnus-registry.el intercepts article respooling, moving, deleting,
  23. ;; and copying for all backends. If it doesn't work correctly for
  24. ;; you, submit a bug report and I'll be glad to fix it. It needs
  25. ;; better documentation in the manual (also on my to-do list).
  26. ;; If you want to track recipients (and you should to make the
  27. ;; gnus-registry splitting work better), you need the To and Cc
  28. ;; headers collected by Gnus. Note that in more recent Gnus versions
  29. ;; this is already the case: look at `gnus-extra-headers' to be sure.
  30. ;; ;;; you may also want Gcc Newsgroups Keywords X-Face
  31. ;; (add-to-list 'gnus-extra-headers 'To)
  32. ;; (add-to-list 'gnus-extra-headers 'Cc)
  33. ;; (setq nnmail-extra-headers gnus-extra-headers)
  34. ;; Put this in your startup file (~/.gnus.el for instance) or use Customize:
  35. ;; (setq gnus-registry-max-entries 2500
  36. ;; gnus-registry-track-extra '(sender subject recipient))
  37. ;; (gnus-registry-initialize)
  38. ;; Then use this in your fancy-split:
  39. ;; (: gnus-registry-split-fancy-with-parent)
  40. ;; You should also consider using the nnregistry backend to look up
  41. ;; articles. See the Gnus manual for more information.
  42. ;; Finally, you can put %uM in your summary line format to show the
  43. ;; registry marks if you do this:
  44. ;; show the marks as single characters (see the :char property in
  45. ;; `gnus-registry-marks'):
  46. ;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-chars)
  47. ;; show the marks by name (see `gnus-registry-marks'):
  48. ;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-names)
  49. ;; TODO:
  50. ;; - get the correct group on spool actions
  51. ;; - articles that are spooled to a different backend should be moved
  52. ;; after splitting
  53. ;;; Code:
  54. (eval-when-compile (require 'cl))
  55. (require 'gnus)
  56. (require 'gnus-int)
  57. (require 'gnus-sum)
  58. (require 'gnus-art)
  59. (require 'gnus-util)
  60. (require 'nnmail)
  61. (require 'easymenu)
  62. (require 'registry)
  63. ;; Silence XEmacs byte compiler, which will otherwise complain about
  64. ;; call to `eieio-persistent-read'.
  65. (when (featurep 'xemacs)
  66. (byte-compiler-options
  67. (warnings (- callargs))))
  68. (defvar gnus-adaptive-word-syntax-table)
  69. (defvar gnus-registry-dirty t
  70. "Boolean set to t when the registry is modified.")
  71. (defgroup gnus-registry nil
  72. "The Gnus registry."
  73. :version "22.1"
  74. :group 'gnus)
  75. (defvar gnus-registry-marks
  76. '((Important
  77. :char ?i
  78. :image "summary_important")
  79. (Work
  80. :char ?w
  81. :image "summary_work")
  82. (Personal
  83. :char ?p
  84. :image "summary_personal")
  85. (To-Do
  86. :char ?t
  87. :image "summary_todo")
  88. (Later
  89. :char ?l
  90. :image "summary_later"))
  91. "List of registry marks and their options.
  92. `gnus-registry-mark-article' will offer symbols from this list
  93. for completion.
  94. Each entry must have a character to be useful for summary mode
  95. line display and for keyboard shortcuts.
  96. Each entry must have an image string to be useful for visual
  97. display.")
  98. (defcustom gnus-registry-default-mark 'To-Do
  99. "The default mark. Should be a valid key for `gnus-registry-marks'."
  100. :group 'gnus-registry
  101. :type 'symbol)
  102. (defcustom gnus-registry-unfollowed-addresses
  103. (list (regexp-quote user-mail-address))
  104. "List of addresses that gnus-registry-split-fancy-with-parent won't trace.
  105. The addresses are matched, they don't have to be fully qualified.
  106. In the messages, these addresses can be the sender or the
  107. recipients."
  108. :version "24.1"
  109. :group 'gnus-registry
  110. :type '(repeat regexp))
  111. (defcustom gnus-registry-unfollowed-groups
  112. '("delayed$" "drafts$" "queue$" "INBOX$" "^nnmairix:" "archive")
  113. "List of groups that gnus-registry-split-fancy-with-parent won't return.
  114. The group names are matched, they don't have to be fully
  115. qualified. This parameter tells the Gnus registry 'never split a
  116. message into a group that matches one of these, regardless of
  117. references.'
  118. nnmairix groups are specifically excluded because they are ephemeral."
  119. :group 'gnus-registry
  120. :type '(repeat regexp))
  121. (defcustom gnus-registry-install 'ask
  122. "Whether the registry should be installed."
  123. :group 'gnus-registry
  124. :type '(choice (const :tag "Never Install" nil)
  125. (const :tag "Always Install" t)
  126. (const :tag "Ask Me" ask)))
  127. (defvar gnus-registry-enabled nil)
  128. (defvar gnus-summary-misc-menu) ;; Avoid byte compiler warning.
  129. (defvar gnus-registry-misc-menus nil) ; ugly way to keep the menus
  130. (make-obsolete-variable 'gnus-registry-clean-empty nil "23.4")
  131. (make-obsolete-variable 'gnus-registry-use-long-group-names nil "23.4")
  132. (make-obsolete-variable 'gnus-registry-max-track-groups nil "23.4")
  133. (make-obsolete-variable 'gnus-registry-entry-caching nil "23.4")
  134. (make-obsolete-variable 'gnus-registry-trim-articles-without-groups nil "23.4")
  135. ;; FIXME it was simply deleted.
  136. (make-obsolete-variable 'gnus-registry-max-pruned-entries nil "25.1")
  137. (defcustom gnus-registry-track-extra '(subject sender recipient)
  138. "Whether the registry should track extra data about a message.
  139. The subject, recipients (To: and Cc:), and Sender (From:) headers
  140. are tracked this way by default."
  141. :group 'gnus-registry
  142. :type
  143. '(set :tag "Tracking choices"
  144. (const :tag "Track by subject (Subject: header)" subject)
  145. (const :tag "Track by recipient (To: and Cc: headers)" recipient)
  146. (const :tag "Track by sender (From: header)" sender)))
  147. (defcustom gnus-registry-split-strategy nil
  148. "The splitting strategy applied to the keys in `gnus-registry-track-extra'.
  149. Given a set of unique found groups G and counts for each element
  150. of G, and a key K (typically 'sender or 'subject):
  151. When nil, if G has only one element, use it. Otherwise give up.
  152. This is the fastest but also least useful strategy.
  153. When 'majority, use the majority by count. So if there is a
  154. group with the most articles counted by K, use that. Ties are
  155. resolved in no particular order, simply the first one found wins.
  156. This is the slowest strategy but also the most accurate one.
  157. When 'first, the first element of G wins. This is fast and
  158. should be OK if your senders and subjects don't \"bleed\" across
  159. groups."
  160. :group 'gnus-registry
  161. :type
  162. '(choice :tag "Splitting strategy"
  163. (const :tag "Only use single choices, discard multiple matches" nil)
  164. (const :tag "Majority of matches wins" majority)
  165. (const :tag "First found wins" first)))
  166. (defcustom gnus-registry-minimum-subject-length 5
  167. "The minimum length of a subject before it's considered trackable."
  168. :group 'gnus-registry
  169. :type 'integer)
  170. (defcustom gnus-registry-extra-entries-precious '(mark)
  171. "What extra keys are precious, meaning entries with them won't get pruned.
  172. By default, 'mark is included, so articles with marks are
  173. considered precious.
  174. Before you save the Gnus registry, it's pruned. Any entries with
  175. keys in this list will not be pruned. All other entries go to
  176. the Bit Bucket."
  177. :group 'gnus-registry
  178. :type '(repeat symbol))
  179. (defcustom gnus-registry-cache-file
  180. (nnheader-concat
  181. (or gnus-dribble-directory gnus-home-directory "~/")
  182. ".gnus.registry.eieio")
  183. "File where the Gnus registry will be stored."
  184. :group 'gnus-registry
  185. :type 'file)
  186. (defcustom gnus-registry-max-entries nil
  187. "Maximum number of entries in the registry, nil for unlimited."
  188. :group 'gnus-registry
  189. :type '(radio (const :format "Unlimited " nil)
  190. (integer :format "Maximum number: %v")))
  191. (defcustom gnus-registry-prune-factor 0.1
  192. "When pruning, try to prune back to this factor less than the maximum size.
  193. In order to prevent constant pruning, we prune back to a number
  194. somewhat less than the maximum size. This option controls
  195. exactly how much less. For example, given a maximum size of
  196. 50000 and a prune factor of 0.1, the pruning process will try to
  197. cut the registry back to \(- 50000 \(* 50000 0.1\)\) -> 45000
  198. entries. The pruning process is constrained by the presence of
  199. \"precious\" entries."
  200. :version "25.1"
  201. :group 'gnus-registry
  202. :type 'float)
  203. (defcustom gnus-registry-default-sort-function
  204. #'gnus-registry-sort-by-creation-time
  205. "Sort function to use when pruning the registry.
  206. Entries that sort to the front of the list are pruned first.
  207. This can slow pruning down. Set to nil to perform no sorting."
  208. :version "25.1"
  209. :group 'gnus-registry
  210. :type '(choice (const :tag "No sorting" nil) function))
  211. (defun gnus-registry-sort-by-creation-time (l r)
  212. "Sort older entries to front of list."
  213. ;; Pruning starts from the front of the list.
  214. (time-less-p
  215. (cadr (assq 'creation-time r))
  216. (cadr (assq 'creation-time l))))
  217. (defun gnus-registry-fixup-registry (db)
  218. (when db
  219. (let ((old (oref db tracked)))
  220. (setf (oref db precious)
  221. (append gnus-registry-extra-entries-precious
  222. '()))
  223. (setf (oref db max-size)
  224. (or gnus-registry-max-entries
  225. most-positive-fixnum))
  226. (setf (oref db prune-factor)
  227. (or gnus-registry-prune-factor
  228. 0.1))
  229. (setf (oref db tracked)
  230. (append gnus-registry-track-extra
  231. '(mark group keyword)))
  232. (when (not (equal old (oref db tracked)))
  233. (gnus-message 9 "Reindexing the Gnus registry (tracked change)")
  234. (registry-reindex db))))
  235. db)
  236. (defun gnus-registry-make-db (&optional file)
  237. (interactive "fGnus registry persistence file: \n")
  238. (gnus-registry-fixup-registry
  239. (make-instance 'registry-db
  240. :file (or file gnus-registry-cache-file)
  241. ;; these parameters are set in `gnus-registry-fixup-registry'
  242. :max-size most-positive-fixnum
  243. :version registry-db-version
  244. :precious nil
  245. :tracked nil)))
  246. (defvar gnus-registry-db (gnus-registry-make-db)
  247. "The article registry by Message ID. See `registry-db'.")
  248. ;; top-level registry data management
  249. (defun gnus-registry-remake-db (&optional forsure)
  250. "Remake the registry database after customization.
  251. This is not required after changing `gnus-registry-cache-file'."
  252. (interactive (list (y-or-n-p "Remake and CLEAR the Gnus registry? ")))
  253. (when forsure
  254. (gnus-message 4 "Remaking the Gnus registry")
  255. (setq gnus-registry-db (gnus-registry-make-db))))
  256. (defun gnus-registry-load ()
  257. "Load the registry from the cache file."
  258. (interactive)
  259. (let ((file gnus-registry-cache-file))
  260. (condition-case nil
  261. (gnus-registry-read file)
  262. (file-error
  263. ;; Fix previous mis-naming of the registry file.
  264. (let ((old-file-name
  265. (concat (file-name-sans-extension
  266. gnus-registry-cache-file)
  267. ".eioio")))
  268. (if (and (file-exists-p old-file-name)
  269. (yes-or-no-p
  270. (format "Rename registry file from %s to %s? "
  271. old-file-name file)))
  272. (progn
  273. (gnus-registry-read old-file-name)
  274. (setf (oref gnus-registry-db file) file)
  275. (gnus-message 1 "Registry filename changed to %s" file))
  276. (gnus-registry-remake-db t))))
  277. (error
  278. (gnus-message
  279. 1
  280. "The Gnus registry could not be loaded from %s, creating a new one"
  281. file)
  282. (gnus-registry-remake-db t)))))
  283. (defun gnus-registry-read (file)
  284. "Do the actual reading of the registry persistence file."
  285. (gnus-message 5 "Reading Gnus registry from %s..." file)
  286. (setq gnus-registry-db
  287. (gnus-registry-fixup-registry
  288. (condition-case nil
  289. (with-no-warnings
  290. (eieio-persistent-read file 'registry-db))
  291. ;; Older EIEIO versions do not check the class name.
  292. ('wrong-number-of-arguments
  293. (eieio-persistent-read file)))))
  294. (gnus-message 5 "Reading Gnus registry from %s...done" file))
  295. (defun gnus-registry-save (&optional file db)
  296. "Save the registry cache file."
  297. (interactive)
  298. (let ((file (or file gnus-registry-cache-file))
  299. (db (or db gnus-registry-db)))
  300. (gnus-message 5 "Saving Gnus registry (%d entries) to %s..."
  301. (registry-size db) file)
  302. (registry-prune
  303. db gnus-registry-default-sort-function)
  304. ;; TODO: call (gnus-string-remove-all-properties v) on all elements?
  305. (eieio-persistent-save db file)
  306. (gnus-message 5 "Saving Gnus registry (size %d) to %s...done"
  307. (registry-size db) file)))
  308. (defun gnus-registry-remove-ignored ()
  309. (interactive)
  310. (let* ((db gnus-registry-db)
  311. (grouphashtb (registry-lookup-secondary db 'group))
  312. (old-size (registry-size db)))
  313. (registry-reindex db)
  314. (loop for k being the hash-keys of grouphashtb
  315. using (hash-values v)
  316. when (gnus-registry-ignore-group-p k)
  317. do (registry-delete db v nil))
  318. (registry-reindex db)
  319. (gnus-message 4 "Removed %d ignored entries from the Gnus registry"
  320. (- old-size (registry-size db)))))
  321. ;; article move/copy/spool/delete actions
  322. (defun gnus-registry-action (action data-header from &optional to method)
  323. (let* ((id (mail-header-id data-header))
  324. (subject (mail-header-subject data-header))
  325. (extra (mail-header-extra data-header))
  326. (recipients (gnus-registry-sort-addresses
  327. (or (cdr-safe (assq 'Cc extra)) "")
  328. (or (cdr-safe (assq 'To extra)) "")))
  329. (sender (nth 0 (gnus-registry-extract-addresses
  330. (mail-header-from data-header))))
  331. (from (gnus-group-guess-full-name-from-command-method from))
  332. (to (if to (gnus-group-guess-full-name-from-command-method to) nil)))
  333. (gnus-message 7 "Gnus registry: article %s %s from %s to %s"
  334. id (if method "respooling" "going") from to)
  335. (gnus-registry-handle-action
  336. id
  337. ;; unless copying, remove the old "from" group
  338. (if (not (equal 'copy action)) from nil)
  339. to subject sender recipients)))
  340. (defun gnus-registry-spool-action (id group &optional subject sender recipients)
  341. (let ((to (gnus-group-guess-full-name-from-command-method group))
  342. (recipients (or recipients
  343. (gnus-registry-sort-addresses
  344. (or (message-fetch-field "cc") "")
  345. (or (message-fetch-field "to") ""))))
  346. (subject (or subject (message-fetch-field "subject")))
  347. (sender (or sender (message-fetch-field "from"))))
  348. (when (and (stringp id) (string-match "\r$" id))
  349. (setq id (substring id 0 -1)))
  350. (gnus-message 7 "Gnus registry: article %s spooled to %s"
  351. id
  352. to)
  353. (gnus-registry-handle-action id nil to subject sender recipients)))
  354. (defun gnus-registry-handle-action (id from to subject sender
  355. &optional recipients)
  356. (gnus-message
  357. 10
  358. "gnus-registry-handle-action %S" (list id from to subject sender recipients))
  359. (let ((db gnus-registry-db)
  360. ;; if the group is ignored, set the destination to nil (same as delete)
  361. (to (if (gnus-registry-ignore-group-p to) nil to))
  362. ;; safe if not found
  363. (entry (gnus-registry-get-or-make-entry id))
  364. (subject (gnus-string-remove-all-properties
  365. (gnus-registry-simplify-subject subject)))
  366. (sender (gnus-string-remove-all-properties sender)))
  367. ;; this could be done by calling `gnus-registry-set-id-key'
  368. ;; several times but it's better to bunch the transactions
  369. ;; together
  370. (registry-delete db (list id) nil)
  371. (when from
  372. (setq entry (cons (delete from (assoc 'group entry))
  373. (assq-delete-all 'group entry))))
  374. (dolist (kv `((group ,to)
  375. (sender ,sender)
  376. (recipient ,@recipients)
  377. (subject ,subject)))
  378. (when (second kv)
  379. (let ((new (or (assq (first kv) entry)
  380. (list (first kv)))))
  381. (dolist (toadd (cdr kv))
  382. (unless (member toadd new)
  383. (setq new (append new (list toadd)))))
  384. (setq entry (cons new
  385. (assq-delete-all (first kv) entry))))))
  386. (gnus-message 10 "Gnus registry: new entry for %s is %S"
  387. id
  388. entry)
  389. (gnus-registry-insert db id entry)))
  390. ;; Function for nn{mail|imap}-split-fancy: look up all references in
  391. ;; the cache and if a match is found, return that group.
  392. (defun gnus-registry-split-fancy-with-parent ()
  393. "Split this message into the same group as its parent.
  394. The parent is obtained from the registry. This function can be used as an
  395. entry in `nnmail-split-fancy' or `nnimap-split-fancy', for example like
  396. this: (: gnus-registry-split-fancy-with-parent)
  397. This function tracks ALL backends, unlike
  398. `nnmail-split-fancy-with-parent' which tracks only nnmail
  399. messages.
  400. For a message to be split, it looks for the parent message in the
  401. References or In-Reply-To header and then looks in the registry
  402. to see which group that message was put in. This group is
  403. returned, unless `gnus-registry-follow-group-p' return nil for
  404. that group.
  405. See the Info node `(gnus)Fancy Mail Splitting' for more details."
  406. (let* ((refstr (or (message-fetch-field "references") "")) ; guaranteed
  407. (reply-to (message-fetch-field "in-reply-to")) ; may be nil
  408. ;; now, if reply-to is valid, append it to the References
  409. (refstr (if reply-to
  410. (concat refstr " " reply-to)
  411. refstr))
  412. (references (and refstr (gnus-extract-references refstr)))
  413. ;; these may not be used, but the code is cleaner having them up here
  414. (sender (gnus-string-remove-all-properties
  415. (message-fetch-field "from")))
  416. (recipients (gnus-registry-sort-addresses
  417. (or (message-fetch-field "cc") "")
  418. (or (message-fetch-field "to") "")))
  419. (subject (gnus-string-remove-all-properties
  420. (gnus-registry-simplify-subject
  421. (message-fetch-field "subject"))))
  422. (nnmail-split-fancy-with-parent-ignore-groups
  423. (if (listp nnmail-split-fancy-with-parent-ignore-groups)
  424. nnmail-split-fancy-with-parent-ignore-groups
  425. (list nnmail-split-fancy-with-parent-ignore-groups))))
  426. (gnus-registry--split-fancy-with-parent-internal
  427. :references references
  428. :refstr refstr
  429. :sender sender
  430. :recipients recipients
  431. :subject subject
  432. :log-agent "Gnus registry fancy splitting with parent")))
  433. (defun* gnus-registry--split-fancy-with-parent-internal
  434. (&rest spec
  435. &key references refstr sender subject recipients log-agent
  436. &allow-other-keys)
  437. (gnus-message
  438. 10
  439. "gnus-registry--split-fancy-with-parent-internal %S" spec)
  440. (let ((db gnus-registry-db)
  441. found)
  442. ;; this is a big chain of statements. it uses
  443. ;; gnus-registry-post-process-groups to filter the results after
  444. ;; every step.
  445. ;; the references string must be valid and parse to valid references
  446. (when references
  447. (gnus-message
  448. 9
  449. "%s is tracing references %s"
  450. log-agent refstr)
  451. (dolist (reference (nreverse references))
  452. (gnus-message 9 "%s is looking up %s" log-agent reference)
  453. (loop for group in (gnus-registry-get-id-key reference 'group)
  454. when (gnus-registry-follow-group-p group)
  455. do
  456. (progn
  457. (gnus-message 7 "%s traced %s to %s" log-agent reference group)
  458. (push group found))))
  459. ;; filter the found groups and return them
  460. ;; the found groups are the full groups
  461. (setq found (gnus-registry-post-process-groups
  462. "references" refstr found)))
  463. ;; else: there were no matches, now try the extra tracking by subject
  464. (when (and (null found)
  465. (memq 'subject gnus-registry-track-extra)
  466. subject
  467. (< gnus-registry-minimum-subject-length (length subject)))
  468. (let ((groups (apply
  469. 'append
  470. (mapcar
  471. (lambda (reference)
  472. (gnus-registry-get-id-key reference 'group))
  473. (registry-lookup-secondary-value db 'subject subject)))))
  474. (setq found
  475. (loop for group in groups
  476. when (gnus-registry-follow-group-p group)
  477. do (gnus-message
  478. ;; warn more if gnus-registry-track-extra
  479. (if gnus-registry-track-extra 7 9)
  480. "%s (extra tracking) traced subject `%s' to %s"
  481. log-agent subject group)
  482. and collect group))
  483. ;; filter the found groups and return them
  484. ;; the found groups are NOT the full groups
  485. (setq found (gnus-registry-post-process-groups
  486. "subject" subject found))))
  487. ;; else: there were no matches, try the extra tracking by sender
  488. (when (and (null found)
  489. (memq 'sender gnus-registry-track-extra)
  490. sender
  491. (not (gnus-grep-in-list
  492. sender
  493. gnus-registry-unfollowed-addresses)))
  494. (let ((groups (apply
  495. 'append
  496. (mapcar
  497. (lambda (reference)
  498. (gnus-registry-get-id-key reference 'group))
  499. (registry-lookup-secondary-value db 'sender sender)))))
  500. (setq found
  501. (loop for group in groups
  502. when (gnus-registry-follow-group-p group)
  503. do (gnus-message
  504. ;; warn more if gnus-registry-track-extra
  505. (if gnus-registry-track-extra 7 9)
  506. "%s (extra tracking) traced sender `%s' to %s"
  507. log-agent sender group)
  508. and collect group)))
  509. ;; filter the found groups and return them
  510. ;; the found groups are NOT the full groups
  511. (setq found (gnus-registry-post-process-groups
  512. "sender" sender found)))
  513. ;; else: there were no matches, try the extra tracking by recipient
  514. (when (and (null found)
  515. (memq 'recipient gnus-registry-track-extra)
  516. recipients)
  517. (dolist (recp recipients)
  518. (when (and (null found)
  519. (not (gnus-grep-in-list
  520. recp
  521. gnus-registry-unfollowed-addresses)))
  522. (let ((groups (apply 'append
  523. (mapcar
  524. (lambda (reference)
  525. (gnus-registry-get-id-key reference 'group))
  526. (registry-lookup-secondary-value
  527. db 'recipient recp)))))
  528. (setq found
  529. (loop for group in groups
  530. when (gnus-registry-follow-group-p group)
  531. do (gnus-message
  532. ;; warn more if gnus-registry-track-extra
  533. (if gnus-registry-track-extra 7 9)
  534. "%s (extra tracking) traced recipient `%s' to %s"
  535. log-agent recp group)
  536. and collect group)))))
  537. ;; filter the found groups and return them
  538. ;; the found groups are NOT the full groups
  539. (setq found (gnus-registry-post-process-groups
  540. "recipients" (mapconcat 'identity recipients ", ") found)))
  541. ;; after the (cond) we extract the actual value safely
  542. (car-safe found)))
  543. (defun gnus-registry-post-process-groups (mode key groups)
  544. "Inspects GROUPS found by MODE for KEY to determine which ones to follow.
  545. MODE can be `subject' or `sender' for example. The KEY is the
  546. value by which MODE was searched.
  547. Transforms each group name to the equivalent short name.
  548. Checks if the current Gnus method (from `gnus-command-method' or
  549. from `gnus-newsgroup-name') is the same as the group's method.
  550. Foreign methods are not supported so they are rejected.
  551. Reduces the list to a single group, or complains if that's not
  552. possible. Uses `gnus-registry-split-strategy'."
  553. (let ((log-agent "gnus-registry-post-process-group")
  554. (desc (format "%d groups" (length groups)))
  555. out chosen)
  556. ;; the strategy can be nil, in which case chosen is nil
  557. (setq chosen
  558. (case gnus-registry-split-strategy
  559. ;; default, take only one-element lists into chosen
  560. ((nil)
  561. (and (= (length groups) 1)
  562. (car-safe groups)))
  563. ((first)
  564. (car-safe groups))
  565. ((majority)
  566. (let ((freq (make-hash-table
  567. :size 256
  568. :test 'equal)))
  569. (mapc (lambda (x) (let ((x (gnus-group-short-name x)))
  570. (puthash x (1+ (gethash x freq 0)) freq)))
  571. groups)
  572. (setq desc (format "%d groups, %d unique"
  573. (length groups)
  574. (hash-table-count freq)))
  575. (car-safe
  576. (sort groups
  577. (lambda (a b)
  578. (> (gethash (gnus-group-short-name a) freq 0)
  579. (gethash (gnus-group-short-name b) freq 0)))))))))
  580. (if chosen
  581. (gnus-message
  582. 9
  583. "%s: strategy %s on %s produced %s"
  584. log-agent gnus-registry-split-strategy desc chosen)
  585. (gnus-message
  586. 9
  587. "%s: strategy %s on %s did not produce an answer"
  588. log-agent
  589. (or gnus-registry-split-strategy "default")
  590. desc))
  591. (setq groups (and chosen (list chosen)))
  592. (dolist (group groups)
  593. (let ((m1 (gnus-find-method-for-group group))
  594. (m2 (or gnus-command-method
  595. (gnus-find-method-for-group gnus-newsgroup-name)))
  596. (short-name (gnus-group-short-name group)))
  597. (if (gnus-methods-equal-p m1 m2)
  598. (progn
  599. ;; this is REALLY just for debugging
  600. (when (not (equal group short-name))
  601. (gnus-message
  602. 10
  603. "%s: stripped group %s to %s"
  604. log-agent group short-name))
  605. (pushnew short-name out :test #'equal))
  606. ;; else...
  607. (gnus-message
  608. 7
  609. "%s: ignored foreign group %s"
  610. log-agent group))))
  611. (setq out (delq nil out))
  612. (cond
  613. ((= (length out) 1) out)
  614. ((null out)
  615. (gnus-message
  616. 5
  617. "%s: no matches for %s `%s'."
  618. log-agent mode key)
  619. nil)
  620. (t (gnus-message
  621. 5
  622. "%s: too many extra matches (%s) for %s `%s'. Returning none."
  623. log-agent out mode key)
  624. nil))))
  625. (defun gnus-registry-follow-group-p (group)
  626. "Determines if a group name should be followed.
  627. Consults `gnus-registry-unfollowed-groups' and
  628. `nnmail-split-fancy-with-parent-ignore-groups'."
  629. (and group
  630. (not (or (gnus-grep-in-list
  631. group
  632. gnus-registry-unfollowed-groups)
  633. (gnus-grep-in-list
  634. group
  635. nnmail-split-fancy-with-parent-ignore-groups)))))
  636. ;; note that gnus-registry-ignored-groups is defined in gnus.el as a
  637. ;; group/topic parameter and an associated variable!
  638. ;; we do special logic for ignoring to accept regular expressions and
  639. ;; nnmail-split-fancy-with-parent-ignore-groups as well
  640. (defun gnus-registry-ignore-group-p (group)
  641. "Determines if a group name should be ignored.
  642. Consults `gnus-registry-ignored-groups' and
  643. `nnmail-split-fancy-with-parent-ignore-groups'."
  644. (and group
  645. (or (gnus-grep-in-list
  646. group
  647. (delq nil (mapcar (lambda (g)
  648. (cond
  649. ((stringp g) g)
  650. ((and (listp g) (nth 1 g))
  651. (nth 0 g))
  652. (t nil))) gnus-registry-ignored-groups)))
  653. ;; only use `gnus-parameter-registry-ignore' if
  654. ;; `gnus-registry-ignored-groups' is a list of lists
  655. ;; (it can be a list of regexes)
  656. (and (listp (nth 0 gnus-registry-ignored-groups))
  657. (get-buffer "*Group*") ; in automatic tests this is false
  658. (gnus-parameter-registry-ignore group))
  659. (gnus-grep-in-list
  660. group
  661. nnmail-split-fancy-with-parent-ignore-groups))))
  662. (defun gnus-registry-wash-for-keywords (&optional force)
  663. "Get the keywords of the current article.
  664. Overrides existing keywords with FORCE set non-nil."
  665. (interactive)
  666. (let ((id (gnus-registry-fetch-message-id-fast gnus-current-article))
  667. word words)
  668. (if (or (not (gnus-registry-get-id-key id 'keyword))
  669. force)
  670. (with-current-buffer gnus-article-buffer
  671. (article-goto-body)
  672. (save-window-excursion
  673. (save-restriction
  674. (narrow-to-region (point) (point-max))
  675. (with-syntax-table gnus-adaptive-word-syntax-table
  676. (while (re-search-forward "\\b\\w+\\b" nil t)
  677. (setq word (gnus-string-remove-all-properties
  678. (downcase (buffer-substring
  679. (match-beginning 0) (match-end 0)))))
  680. (if (> (length word) 2)
  681. (push word words))))))
  682. (gnus-registry-set-id-key id 'keyword words)))))
  683. (defun gnus-registry-keywords ()
  684. (let ((table (registry-lookup-secondary gnus-registry-db 'keyword))
  685. (ks ()))
  686. (when table (maphash (lambda (k _v) (push k ks)) table) ks)))
  687. (defun gnus-registry-find-keywords (keyword)
  688. (interactive (list
  689. (completing-read "Keyword: " (gnus-registry-keywords) nil t)))
  690. (registry-lookup-secondary-value gnus-registry-db 'keyword keyword))
  691. (defun gnus-registry-register-message-ids ()
  692. "Register the Message-ID of every article in the group."
  693. (unless (gnus-parameter-registry-ignore gnus-newsgroup-name)
  694. (dolist (article gnus-newsgroup-articles)
  695. (let* ((id (gnus-registry-fetch-message-id-fast article))
  696. (groups (gnus-registry-get-id-key id 'group)))
  697. (unless (member gnus-newsgroup-name groups)
  698. (gnus-message 9 "Registry: Registering article %d with group %s"
  699. article gnus-newsgroup-name)
  700. (gnus-registry-handle-action id nil gnus-newsgroup-name
  701. (gnus-registry-fetch-simplified-message-subject-fast article)
  702. (gnus-registry-fetch-sender-fast article)
  703. (gnus-registry-fetch-recipients-fast article)))))))
  704. ;; message field fetchers
  705. (defun gnus-registry-fetch-message-id-fast (article)
  706. "Fetch the Message-ID quickly, using the internal gnus-data-list function."
  707. (if (and (numberp article)
  708. (assoc article (gnus-data-list nil)))
  709. (mail-header-id (gnus-data-header (assoc article (gnus-data-list nil))))
  710. nil))
  711. (defun gnus-registry-extract-addresses (text)
  712. "Extract all the addresses in a normalized way from TEXT.
  713. Returns an unsorted list of strings in the name <address> format.
  714. Addresses without a name will say \"noname\"."
  715. (mapcar (lambda (add)
  716. (gnus-string-remove-all-properties
  717. (let* ((name (or (nth 0 add) "noname"))
  718. (addr (nth 1 add))
  719. (addr (if (bufferp addr)
  720. (with-current-buffer addr
  721. (buffer-string))
  722. addr)))
  723. (format "%s <%s>" name addr))))
  724. (mail-extract-address-components text t)))
  725. (defun gnus-registry-sort-addresses (&rest addresses)
  726. "Return a normalized and sorted list of ADDRESSES."
  727. (sort (apply 'nconc (mapcar 'gnus-registry-extract-addresses addresses))
  728. 'string-lessp))
  729. (defun gnus-registry-simplify-subject (subject)
  730. (if (stringp subject)
  731. (gnus-simplify-subject subject)
  732. nil))
  733. (defun gnus-registry-fetch-simplified-message-subject-fast (article)
  734. "Fetch the Subject quickly, using the internal gnus-data-list function."
  735. (if (and (numberp article)
  736. (assoc article (gnus-data-list nil)))
  737. (gnus-string-remove-all-properties
  738. (gnus-registry-simplify-subject
  739. (mail-header-subject (gnus-data-header
  740. (assoc article (gnus-data-list nil))))))
  741. nil))
  742. (defun gnus-registry-fetch-sender-fast (article)
  743. (gnus-registry-fetch-header-fast "from" article))
  744. (defun gnus-registry-fetch-recipients-fast (article)
  745. (gnus-registry-sort-addresses
  746. (or (ignore-errors (gnus-registry-fetch-header-fast "Cc" article)) "")
  747. (or (ignore-errors (gnus-registry-fetch-header-fast "To" article)) "")))
  748. (defun gnus-registry-fetch-header-fast (article header)
  749. "Fetch the HEADER quickly, using the internal gnus-data-list function."
  750. (if (and (numberp article)
  751. (assoc article (gnus-data-list nil)))
  752. (gnus-string-remove-all-properties
  753. (cdr (assq header (gnus-data-header
  754. (assoc article (gnus-data-list nil))))))
  755. nil))
  756. ;; registry marks glue
  757. (defun gnus-registry-do-marks (type function)
  758. "For each known mark, call FUNCTION for each cell of type TYPE.
  759. FUNCTION should take two parameters, a mark symbol and the cell value."
  760. (dolist (mark-info gnus-registry-marks)
  761. (let* ((mark (car-safe mark-info))
  762. (data (cdr-safe mark-info))
  763. (cell-data (plist-get data type)))
  764. (when cell-data
  765. (funcall function mark cell-data)))))
  766. ;; FIXME: Why not merge gnus-registry--set/remove-mark and
  767. ;; gnus-registry-set-article-mark-internal?
  768. (defun gnus-registry--set/remove-mark (mark remove articles)
  769. "Set/remove the MARK over process-marked ARTICLES."
  770. ;; If this is called and the user doesn't want the
  771. ;; registry enabled, we'll ask anyhow.
  772. (unless gnus-registry-install
  773. (let ((gnus-registry-install 'ask))
  774. (gnus-registry-install-p)))
  775. ;; Now the user is asked if gnus-registry-install is `ask'.
  776. (when (gnus-registry-install-p)
  777. (gnus-registry-set-article-mark-internal
  778. ;; All this just to get the mark, I must be doing it wrong.
  779. mark articles remove t)
  780. ;; FIXME: Why do we do the above only here and not directly inside
  781. ;; gnus-registry-set-article-mark-internal? I.e. we wouldn't we want to do
  782. ;; the things below when gnus-registry-set-article-mark-internal is called
  783. ;; from gnus-registry-set-article-mark or
  784. ;; gnus-registry-remove-article-mark?
  785. (gnus-message 9 "Applying mark %s to %d articles"
  786. mark (length articles))
  787. (dolist (article articles)
  788. (gnus-summary-update-article
  789. article
  790. (assoc article (gnus-data-list nil))))))
  791. ;; This is ugly code, but I don't know how to do it better.
  792. (defun gnus-registry-install-shortcuts ()
  793. "Install the keyboard shortcuts and menus for the registry.
  794. Uses `gnus-registry-marks' to find what shortcuts to install."
  795. (let (keys-plist)
  796. (setq gnus-registry-misc-menus nil)
  797. (gnus-registry-do-marks
  798. :char
  799. (lambda (mark data)
  800. (let ((function-format
  801. (format "gnus-registry-%%s-article-%s-mark" mark)))
  802. ;;; The following generates these functions:
  803. ;;; (defun gnus-registry-set-article-Important-mark (&rest articles)
  804. ;;; "Apply the Important mark to process-marked ARTICLES."
  805. ;;; (interactive (gnus-summary-work-articles current-prefix-arg))
  806. ;;; (gnus-registry-set-article-mark-internal 'Important articles nil t))
  807. ;;; (defun gnus-registry-remove-article-Important-mark (&rest articles)
  808. ;;; "Apply the Important mark to process-marked ARTICLES."
  809. ;;; (interactive (gnus-summary-work-articles current-prefix-arg))
  810. ;;; (gnus-registry-set-article-mark-internal 'Important articles t t))
  811. (dolist (remove '(t nil))
  812. (let* ((variant-name (if remove "remove" "set"))
  813. (function-name
  814. (intern (format function-format variant-name)))
  815. (shortcut (format "%c" (if remove (upcase data) data))))
  816. (defalias function-name
  817. ;; If it weren't for the function's docstring, we could
  818. ;; use a closure, with lexical-let :-(
  819. `(lambda (&rest articles)
  820. ,(format
  821. "%s the %s mark over process-marked ARTICLES."
  822. (upcase-initials variant-name)
  823. mark)
  824. (interactive
  825. (gnus-summary-work-articles current-prefix-arg))
  826. (gnus-registry--set/remove-mark ',mark ',remove articles)))
  827. (push function-name keys-plist)
  828. (push shortcut keys-plist)
  829. (push (vector (format "%s %s"
  830. (upcase-initials variant-name)
  831. (symbol-name mark))
  832. function-name t)
  833. gnus-registry-misc-menus)
  834. (gnus-message 9 "Defined mark handling function %s"
  835. function-name))))))
  836. (gnus-define-keys-1
  837. '(gnus-registry-mark-map "M" gnus-summary-mark-map)
  838. keys-plist)
  839. (add-hook 'gnus-summary-menu-hook
  840. (lambda ()
  841. (easy-menu-add-item
  842. gnus-summary-misc-menu
  843. nil
  844. (cons "Registry Marks" gnus-registry-misc-menus))))))
  845. (make-obsolete 'gnus-registry-user-format-function-M
  846. 'gnus-registry-article-marks-to-chars "24.1") ?
  847. (defalias 'gnus-registry-user-format-function-M
  848. 'gnus-registry-article-marks-to-chars)
  849. ;; use like this:
  850. ;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-chars)
  851. (defun gnus-registry-article-marks-to-chars (headers)
  852. "Show the marks for an article by the :char property."
  853. (let* ((id (mail-header-message-id headers))
  854. (marks (when id (gnus-registry-get-id-key id 'mark))))
  855. (mapconcat (lambda (mark)
  856. (plist-get
  857. (cdr-safe
  858. (assoc mark gnus-registry-marks))
  859. :char))
  860. marks "")))
  861. ;; use like this:
  862. ;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-names)
  863. (defun gnus-registry-article-marks-to-names (headers)
  864. "Show the marks for an article by name."
  865. (let* ((id (mail-header-message-id headers))
  866. (marks (when id (gnus-registry-get-id-key id 'mark))))
  867. (mapconcat (lambda (mark) (symbol-name mark)) marks ",")))
  868. (defun gnus-registry-read-mark ()
  869. "Read a mark name from the user with completion."
  870. (let ((mark (gnus-completing-read
  871. "Label"
  872. (mapcar 'symbol-name (mapcar 'car gnus-registry-marks))
  873. nil nil nil
  874. (symbol-name gnus-registry-default-mark))))
  875. (when (stringp mark)
  876. (intern mark))))
  877. (defun gnus-registry-set-article-mark (&rest articles)
  878. "Apply a mark to process-marked ARTICLES."
  879. (interactive (gnus-summary-work-articles current-prefix-arg))
  880. (gnus-registry-set-article-mark-internal (gnus-registry-read-mark)
  881. articles nil t))
  882. (defun gnus-registry-remove-article-mark (&rest articles)
  883. "Remove a mark from process-marked ARTICLES."
  884. (interactive (gnus-summary-work-articles current-prefix-arg))
  885. (gnus-registry-set-article-mark-internal (gnus-registry-read-mark)
  886. articles t t))
  887. (defun gnus-registry-set-article-mark-internal (mark
  888. articles
  889. &optional remove
  890. show-message)
  891. "Apply or remove MARK across a list of ARTICLES."
  892. (let ((article-id-list
  893. (mapcar 'gnus-registry-fetch-message-id-fast articles)))
  894. (dolist (id article-id-list)
  895. (let* ((marks (delq mark (gnus-registry-get-id-key id 'mark)))
  896. (marks (if remove marks (cons mark marks))))
  897. (when show-message
  898. (gnus-message 1 "%s mark %s with message ID %s, resulting in %S"
  899. (if remove "Removing" "Adding")
  900. mark id marks))
  901. (gnus-registry-set-id-key id 'mark marks)))))
  902. (defun gnus-registry-get-article-marks (&rest articles)
  903. "Get the Gnus registry marks for ARTICLES and show them if interactive.
  904. Uses process/prefix conventions. For multiple articles,
  905. only the last one's marks are returned."
  906. (interactive (gnus-summary-work-articles 1))
  907. (let* ((article (last articles))
  908. (id (gnus-registry-fetch-message-id-fast article))
  909. (marks (when id (gnus-registry-get-id-key id 'mark))))
  910. (when (gmm-called-interactively-p 'any)
  911. (gnus-message 1 "Marks are %S" marks))
  912. marks))
  913. (defun gnus-registry-group-count (id)
  914. "Get the number of groups of a message, based on the message ID."
  915. (length (gnus-registry-get-id-key id 'group)))
  916. (defun gnus-registry-get-or-make-entry (id)
  917. (let* ((db gnus-registry-db)
  918. ;; safe if not found
  919. (entries (registry-lookup db (list id))))
  920. (when (null entries)
  921. (gnus-registry-insert db id (list (list 'creation-time (current-time))
  922. '(group) '(sender) '(subject)))
  923. (setq entries (registry-lookup db (list id))))
  924. (nth 1 (assoc id entries))))
  925. (defun gnus-registry-delete-entries (idlist)
  926. (registry-delete gnus-registry-db idlist nil))
  927. (defun gnus-registry-get-id-key (id key)
  928. (cdr-safe (assq key (gnus-registry-get-or-make-entry id))))
  929. (defun gnus-registry-set-id-key (id key vals)
  930. (let* ((db gnus-registry-db)
  931. (entry (gnus-registry-get-or-make-entry id)))
  932. (registry-delete db (list id) nil)
  933. (setq entry (cons (cons key vals) (assq-delete-all key entry)))
  934. (gnus-registry-insert db id entry)
  935. entry))
  936. (defun gnus-registry-insert (db id entry)
  937. "Just like `registry-insert' but tries to prune on error."
  938. (when (registry-full db)
  939. (message "Trying to prune the registry because it's full")
  940. (registry-prune
  941. db gnus-registry-default-sort-function))
  942. (registry-insert db id entry)
  943. entry)
  944. (defun gnus-registry-import-eld (file)
  945. (interactive "fOld registry file to import? ")
  946. ;; example content:
  947. ;; (setq gnus-registry-alist '(
  948. ;; ("<messageID>" ((marks nil)
  949. ;; (mtime 19365 1776 440496)
  950. ;; (sender . "root (Cron Daemon)")
  951. ;; (subject . "Cron"))
  952. ;; "cron" "nnml+private:cron")
  953. (load file t)
  954. (when (boundp 'gnus-registry-alist)
  955. (let* ((old (symbol-value 'gnus-registry-alist))
  956. (count 0)
  957. (expected (length old))
  958. entry)
  959. (while (car-safe old)
  960. (incf count)
  961. ;; don't use progress reporters for backwards compatibility
  962. (when (and (< 0 expected)
  963. (= 0 (mod count 100)))
  964. (message "importing: %d of %d (%.2f%%)"
  965. count expected (/ (* 100.0 count) expected)))
  966. (setq entry (car-safe old)
  967. old (cdr-safe old))
  968. (let* ((id (car-safe entry))
  969. (rest (cdr-safe entry))
  970. (groups (loop for p in rest
  971. when (stringp p)
  972. collect p))
  973. extra-cell key val)
  974. ;; remove all the strings from the entry
  975. (dolist (elem rest)
  976. (if (stringp elem) (setq rest (delq elem rest))))
  977. (gnus-registry-set-id-key id 'group groups)
  978. ;; just use the first extra element
  979. (setq rest (car-safe rest))
  980. (while (car-safe rest)
  981. (setq extra-cell (car-safe rest)
  982. key (car-safe extra-cell)
  983. val (cdr-safe extra-cell)
  984. rest (cdr-safe rest))
  985. (when (and val (atom val))
  986. (setq val (list val)))
  987. (gnus-registry-set-id-key id key val))))
  988. (message "Import done, collected %d entries" count))))
  989. ;;;###autoload
  990. (defun gnus-registry-initialize ()
  991. "Initialize the Gnus registry."
  992. (interactive)
  993. (gnus-message 5 "Initializing the registry")
  994. (gnus-registry-install-hooks)
  995. (gnus-registry-install-shortcuts)
  996. (gnus-registry-load))
  997. ;; FIXME: Why autoload this function?
  998. ;;;###autoload
  999. (defun gnus-registry-install-hooks ()
  1000. "Install the registry hooks."
  1001. (interactive)
  1002. (setq gnus-registry-enabled t)
  1003. (add-hook 'gnus-summary-article-move-hook 'gnus-registry-action)
  1004. (add-hook 'gnus-summary-article-delete-hook 'gnus-registry-action)
  1005. (add-hook 'gnus-summary-article-expire-hook 'gnus-registry-action)
  1006. (add-hook 'nnmail-spool-hook 'gnus-registry-spool-action)
  1007. (add-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
  1008. (add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-load)
  1009. (add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids))
  1010. (defun gnus-registry-unload-hook ()
  1011. "Uninstall the registry hooks."
  1012. (interactive)
  1013. (remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action)
  1014. (remove-hook 'gnus-summary-article-delete-hook 'gnus-registry-action)
  1015. (remove-hook 'gnus-summary-article-expire-hook 'gnus-registry-action)
  1016. (remove-hook 'nnmail-spool-hook 'gnus-registry-spool-action)
  1017. (remove-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
  1018. (remove-hook 'gnus-read-newsrc-el-hook 'gnus-registry-load)
  1019. (remove-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids)
  1020. (setq gnus-registry-enabled nil))
  1021. (add-hook 'gnus-registry-unload-hook 'gnus-registry-unload-hook)
  1022. (defun gnus-registry-install-p ()
  1023. "Return non-nil if the registry is enabled (and maybe enable it first).
  1024. If the registry is not already enabled, then if `gnus-registry-install'
  1025. is `ask', ask the user; or if `gnus-registry-install' is non-nil, enable it."
  1026. (interactive)
  1027. (unless gnus-registry-enabled
  1028. (when (if (eq gnus-registry-install 'ask)
  1029. (gnus-y-or-n-p
  1030. (concat "Enable the Gnus registry? "
  1031. "See the variable `gnus-registry-install' "
  1032. "to get rid of this query permanently. "))
  1033. gnus-registry-install)
  1034. (gnus-registry-initialize)))
  1035. gnus-registry-enabled)
  1036. ;; largely based on nnir-warp-to-article
  1037. (defun gnus-try-warping-via-registry ()
  1038. "Try to warp via the registry.
  1039. This will be done via the current article's source group based on
  1040. data stored in the registry."
  1041. (interactive)
  1042. (when (gnus-summary-article-header)
  1043. (let* ((message-id (mail-header-id (gnus-summary-article-header)))
  1044. ;; Retrieve the message's group(s) from the registry
  1045. (groups (gnus-registry-get-id-key message-id 'group))
  1046. ;; If starting from an ephemeral group, this describes
  1047. ;; how to restore the window configuration
  1048. (quit-config
  1049. (gnus-ephemeral-group-p gnus-newsgroup-name))
  1050. (seen-groups (list (gnus-group-group-name))))
  1051. (catch 'found
  1052. (dolist (group (mapcar 'gnus-simplify-group-name groups))
  1053. ;; skip over any groups we really don't want to warp to.
  1054. (unless (or (member group seen-groups)
  1055. (gnus-ephemeral-group-p group) ;; any ephemeral group
  1056. (memq (car (gnus-find-method-for-group group))
  1057. ;; Specific methods; this list may need to expand.
  1058. '(nnir)))
  1059. ;; remember that we've seen this group already
  1060. (push group seen-groups)
  1061. ;; first exit from any ephemeral summary buffer.
  1062. (when quit-config
  1063. (gnus-summary-exit)
  1064. ;; and if the ephemeral summary buffer in turn came from
  1065. ;; another summary buffer we have to clean that summary
  1066. ;; up too.
  1067. (when (eq (cdr quit-config) 'summary)
  1068. (gnus-summary-exit))
  1069. ;; remember that we've already done this part
  1070. (setq quit-config nil))
  1071. ;; Try to activate the group. If that fails, just move
  1072. ;; along. We may have more groups to work with
  1073. (when
  1074. (ignore-errors
  1075. (gnus-select-group-with-message-id group message-id) t)
  1076. (throw 'found t))))))))
  1077. (defun gnus-registry-remove-extra-data (extra)
  1078. "Remove tracked EXTRA data from the gnus registry.
  1079. EXTRA is a list of symbols. Valid symbols are those contained in
  1080. the docs of `gnus-registry-track-extra'. This command is useful
  1081. when you stop tracking some extra data and now want to purge it
  1082. from your existing entries."
  1083. (interactive (list (mapcar 'intern
  1084. (completing-read-multiple
  1085. "Extra data: "
  1086. '("subject" "sender" "recipient")))))
  1087. (when extra
  1088. (let ((db gnus-registry-db))
  1089. (registry-reindex db)
  1090. (loop for k being the hash-keys of (oref db data)
  1091. using (hash-value v)
  1092. do (let ((newv (delq nil (mapcar #'(lambda (entry)
  1093. (unless (member (car entry) extra)
  1094. entry))
  1095. v))))
  1096. (registry-delete db (list k) nil)
  1097. (gnus-registry-insert db k newv)))
  1098. (registry-reindex db))))
  1099. ;; TODO: a few things
  1100. (provide 'gnus-registry)
  1101. ;;; gnus-registry.el ends here